From 618b37d130c9520843bbac6cdfd7e3c3ab3d5530 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 19 Mar 2019 13:26:26 -0400 Subject: [PATCH 01/55] Bump reflex (patchmapwithmove2) --- dep/reflex/github.json | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dep/reflex/github.json b/dep/reflex/github.json index a3946a5e4..6dc8a5ef5 100644 --- a/dep/reflex/github.json +++ b/dep/reflex/github.json @@ -1,6 +1,6 @@ { "owner": "reflex-frp", "repo": "reflex", - "rev": "84ca5e2eb3d230e2ca3cb79c92495244635a51ff", - "sha256": "18lmi5k32sdgg12lfsnfq0wdpdby7hynsjsyg8aqy6gpmcny2z33" + "rev": "cdf873238db92535789a9e2389bb89c53b92c322", + "sha256": "0fsqlxxghzjgm97swaczaxksamcyzimz38hb8li3i3h37c7r0nb9" } From 1208143f20f3ce020eb232c8468ee8cb627afabb Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 4 Apr 2019 17:00:20 -0400 Subject: [PATCH 02/55] Update to upstream ghcjs and ghcjs-base, remove some obsolete patches --- default.nix | 6 +-- haskell-overlays/ghcjs.nix | 37 +------------------ haskell-overlays/text-jsstring/default.nix | 2 +- .../ghcjs-base-text-jsstring.patch | 10 ++--- 4 files changed, 11 insertions(+), 44 deletions(-) diff --git a/default.nix b/default.nix index ccb5a6e02..27f46136a 100644 --- a/default.nix +++ b/default.nix @@ -175,9 +175,9 @@ let iosSupport = system == "x86_64-darwin"; ghcjs8_4 = (makeRecursivelyOverridable (nixpkgs.haskell.packages.ghcjs84.override (old: { ghc = old.ghc.override { ghcjsSrc = fetchgit { - url = "https://github.com/obsidiansystems/ghcjs.git"; - rev = "584eaa138c32c5debb3aae571c4153d537ff58f1"; - sha256 = "1ib0vsv2wrwf5iivnq6jw2l9g5izs0fjpp80jrd71qyywx4xcm66"; + url = "https://github.com/ghcjs/ghcjs.git"; + rev = "00a8993a8d9c35b33b84a83b0aec5171c582a4f3"; + sha256 = "0a9qna5qffskfgw9a4jwvzfd81c41vw36k46hw52hw9xxynvk7x9"; fetchSubmodules = true; }; }; diff --git a/haskell-overlays/ghcjs.nix b/haskell-overlays/ghcjs.nix index cc1bdab5c..93dd62fb9 100644 --- a/haskell-overlays/ghcjs.nix +++ b/haskell-overlays/ghcjs.nix @@ -6,41 +6,8 @@ self: super: { _dep = super._dep or {} // { ghcjsBaseSrc = fetchgit { url = "https://github.com/ghcjs/ghcjs-base.git"; - rev = "01014ade3f8f5ae677df192d7c2a208bd795b96c"; - sha256 = "173h98m7namxj0kfy8fj29qcxmcz6ilg04x8mwkc3ydjqrvk77hh"; - postFetch = '' - ( cd $out - patch -p1 < ${nixpkgs.fetchpatch { - url = "https://github.com/ghcjs/ghcjs-base/commit/2d0d674e54c273ed5fcb9a13f588819c3303a865.patch"; #ghcjs-base/114 - sha256 = "15vbxnxa1fpdcmmx5zx1z92bzsxyb0cbs3hs3g7fb1rkds5qbvgp"; - }} - patch -p1 < ${nixpkgs.fetchpatch { - url = "https://github.com/ghcjs/ghcjs-base/commit/8eccb8d937041ba323d62dea6fe8eb1b04b3cc47.patch"; #ghcjs-base/116 - sha256 = "1lqjpg46ydpm856wcq1g7c97d69qcnnqs5jxp2b788z9cfd5n64c"; - }} - patch -p1 < ${nixpkgs.fetchpatch { - url = "https://github.com/ghcjs/ghcjs-base/commit/ce91c525b5d4377ba4aefd0d8072dc1659f75ef1.patch"; #ghcjs-base/118 - sha256 = "0f6qca1i60cjzpbq4bc74baa7xrf417cja8nmhfims1fflvsx3wy"; - }} - patch -p1 < ${nixpkgs.fetchpatch { - url = "https://github.com/ghcjs/ghcjs-base/commit/213bfc74a051242668edf0533e11a3fafbbb1bfe.patch"; #ghcjs-base/120 - sha256 = "0d5dwy22hxa79l8b4y6nn53nbcs74686s0rmfr5l63sdvqxhdy3x"; - }} - patch -p1 < ${nixpkgs.fetchpatch { - url = "https://github.com/ghcjs/ghcjs-base/commit/82d76814ab40dc9116990f69f16df330462f27d4.patch"; #ghcjs-base/121 - sha256 = "0qa74h6w8770csad0bky4hhss1b1s86i6ccpd3ky4ljx00272gqh"; - }} - patch -p1 < ${nixpkgs.fetchpatch { - url = "https://github.com/ghcjs/ghcjs-base/commit/5eb34b3dfc6fc9196931178a7a6e2c8a331a8e53.patch"; #ghcjs-base/122 - sha256 = "1wrfi0rscy8qa9pi4siv54pq5alplmy56ym1fbs8n93xwlqhddii"; - }} - patch -p1 < ${nixpkgs.fetchpatch { - url = "https://github.com/ghcjs/ghcjs-base/commit/0cf64df77cdd6275d86ec6276fcf947fa58e548b.patch"; #ghcjs-base/122 - sha256 = "16wdghfsrzrb1y7lscbf9aawgxi3kvbgdjwvl1ga2zzm4mq139dr"; - }} - cat ghcjs-base.cabal - ) - ''; + rev = "6be0e992e292db84ab42691cfb172ab7cd0e709e"; + sha256 = "0nk7a01lprf40zsiph3ikwcqcdb1lghlj17c8zzhiwfmfgcc678g"; }; }; diff --git a/haskell-overlays/text-jsstring/default.nix b/haskell-overlays/text-jsstring/default.nix index a3c9304f3..b46937720 100644 --- a/haskell-overlays/text-jsstring/default.nix +++ b/haskell-overlays/text-jsstring/default.nix @@ -6,7 +6,7 @@ with haskellLib; self: super: { _dep = super._dep or {} // { ghcjsBaseTextJSStringSrc = self._dep.ghcjsBaseSrc.overrideAttrs (drv: { - outputHash = "1ggfklrmawqh54ins98rpr7qy3zbcqaqp1w7qmh90mq5jf711x9r"; + outputHash = "0l7xadhcmc8wg9l6p91gi1a5bjbil8gqmd7jkx2758b73y8faxzi"; postFetch = (drv.postFetch or "") + '' ( cd $out patch -p1 < ${./ghcjs-base-text-jsstring.patch} diff --git a/haskell-overlays/text-jsstring/ghcjs-base-text-jsstring.patch b/haskell-overlays/text-jsstring/ghcjs-base-text-jsstring.patch index 01a5743a8..5eedbbc6c 100644 --- a/haskell-overlays/text-jsstring/ghcjs-base-text-jsstring.patch +++ b/haskell-overlays/text-jsstring/ghcjs-base-text-jsstring.patch @@ -375,18 +375,18 @@ index 4a64694..acf8806 100644 JavaScript.TypedArray.Internal.Types JavaScript.TypedArray.ArrayBuffer.Internal JavaScript.TypedArray.DataView.Internal -@@ -129,48 +129,48 @@ library +@@ -128,48 +128,48 @@ library integer-gmp, - binary >= 0.8 && < 0.9, + binary >= 0.8 && < 0.11, bytestring >= 0.10 && < 0.11, - text >= 1.1 && < 1.3, -- aeson >= 0.8 && < 1.3, +- aeson >= 0.8 && < 1.5, - scientific >= 0.3 && < 0.4, + -- text >= 1.1 && < 1.3, -+ -- aeson >= 0.8 && < 1.3, ++ -- aeson >= 0.8 && < 1.5, + -- scientific >= 0.3 && < 0.4, vector >= 0.10 && < 0.13, - containers >= 0.5 && < 0.6, + containers >= 0.5 && < 0.7, time >= 1.5 && < 1.9, - hashable >= 1.2 && < 1.3, - unordered-containers >= 0.2 && < 0.3, From cb888b71e789ed52413f9da492caaab4fd1c4d25 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 5 Apr 2019 10:47:00 -0400 Subject: [PATCH 03/55] Skip tasty-quickcheck tests on ghcjs --- haskell-overlays/ghcjs.nix | 3 +++ 1 file changed, 3 insertions(+) diff --git a/haskell-overlays/ghcjs.nix b/haskell-overlays/ghcjs.nix index 93dd62fb9..66b5dda31 100644 --- a/haskell-overlays/ghcjs.nix +++ b/haskell-overlays/ghcjs.nix @@ -39,6 +39,9 @@ self: super: { semigroupoids = disableCabalFlag super.semigroupoids "doctests"; these = dontCheck super.these; + # These tests never complete + tasty-quickcheck = dontCheck super.tasty-quickcheck; + # Convenience: tests take long to finish megaparsec = dontCheck super.megaparsec; From 606ece2a34267a2e971a37256765f08f1622f67a Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Sun, 28 Apr 2019 15:28:40 -0400 Subject: [PATCH 04/55] Bump nixpkgs; switch to ghc 8.4.4 --- default.nix | 6 +++--- haskell-overlays/android/default.nix | 2 +- nixpkgs-overlays/mobile-ghc/default.nix | 2 +- nixpkgs/github.json | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/default.nix b/default.nix index ccb5a6e02..b28c31a3c 100644 --- a/default.nix +++ b/default.nix @@ -18,14 +18,14 @@ let iosSupport = system == "x86_64-darwin"; splicesEval = self: super: { haskell = super.haskell // { compiler = super.haskell.compiler // { - ghcSplices-8_4 = super.haskell.compiler.ghc843.overrideAttrs (drv: { + ghcSplices-8_4 = super.haskell.compiler.ghc844.overrideAttrs (drv: { enableParallelBuilding = false; patches = (drv.patches or []) ++ [ ./splices-load-save.patch ./haddock.patch ]; }); }; packages = super.haskell.packages // { - ghcSplices-8_4 = super.haskell.packages.ghc843.override { + ghcSplices-8_4 = super.haskell.packages.ghc844.override { buildHaskellPackages = self.buildPackages.haskell.packages.ghcSplices-8_4; ghc = self.buildPackages.haskell.compiler.ghcSplices-8_4; }; @@ -189,7 +189,7 @@ let iosSupport = system == "x86_64-darwin"; ghcHEAD = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghcHEAD).override { overrides = nixpkgs.haskell.overlays.combined; }; - ghc8_4 = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghc843).override { + ghc8_4 = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghc844).override { overrides = nixpkgs.haskell.overlays.combined; }; diff --git a/haskell-overlays/android/default.nix b/haskell-overlays/android/default.nix index fa289b56a..fdbd9ebc3 100644 --- a/haskell-overlays/android/default.nix +++ b/haskell-overlays/android/default.nix @@ -38,7 +38,7 @@ self: super: { # Nixpkgs splices it to the android version. Haskell splicing # appears to be broken! /cc @ericson2314 haskell-src-exts = haskellLib.overrideCabal super.haskell-src-exts ({ - libraryToolDepends = [ nixpkgs.buildPackages.haskell.packages.ghc843.happy ]; + libraryToolDepends = [ nixpkgs.buildPackages.haskell.packages.ghc844.happy ]; }); } diff --git a/nixpkgs-overlays/mobile-ghc/default.nix b/nixpkgs-overlays/mobile-ghc/default.nix index 63715ad91..aaebe8bd7 100644 --- a/nixpkgs-overlays/mobile-ghc/default.nix +++ b/nixpkgs-overlays/mobile-ghc/default.nix @@ -6,6 +6,6 @@ self: super: { patches = (drv.patches or []) ++ lib.optionals self.stdenv.targetPlatform.useAndroidPrebuilt [ ./8.4.y/android-patches/force-relocation.patch ]; - })) { inherit (super.haskell.compiler) ghc843 ghcHEAD ghcSplices; }; + })) { inherit (super.haskell.compiler) ghc844 ghcHEAD ghcSplices; }; }; } diff --git a/nixpkgs/github.json b/nixpkgs/github.json index a43aa13a9..81b6de910 100644 --- a/nixpkgs/github.json +++ b/nixpkgs/github.json @@ -1,6 +1,6 @@ { "owner": "NixOS", "repo": "nixpkgs-channels", - "rev": "1d36ad6d16dbf1d3937f899a087a4360332eb141", - "sha256": "0rf1n61xlbvanrknh7g9884qjy6wmwc5x42by3f9vxqmfhz906sq" + "rev": "571b40d3f50466d3e91c1e609d372de96d782793", + "sha256": "0qjpkx2b5pac1nqr5chvlrlcyyk294w2079ybf88p95qxkqbbby5" } From 129c29c44627f7491d1c81501e1d529dab511388 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Thu, 9 May 2019 13:53:04 -0400 Subject: [PATCH 05/55] Bump reflex and reflex-dom --- haskell-overlays/reflex-packages/dep/reflex-dom/github.json | 4 ++-- haskell-overlays/reflex-packages/dep/reflex/github.json | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/haskell-overlays/reflex-packages/dep/reflex-dom/github.json b/haskell-overlays/reflex-packages/dep/reflex-dom/github.json index af49bb793..2f1c1870f 100644 --- a/haskell-overlays/reflex-packages/dep/reflex-dom/github.json +++ b/haskell-overlays/reflex-packages/dep/reflex-dom/github.json @@ -1,6 +1,6 @@ { "owner": "reflex-frp", "repo": "reflex-dom", - "rev": "c94228143318cad36e145293f7aa3e2d802785f9", - "sha256": "0405rv27lqr66kvxv0npk992h88mii3j76d3wr48r67lv953kx3c" + "rev": "2734d2d70fd0b63849a7e0b5355d80ee66eda127", + "sha256": "0qv51vn07lg6fnaxlcrns5pwg8y5h4cjv18dr56kbnh11a52wba7" } diff --git a/haskell-overlays/reflex-packages/dep/reflex/github.json b/haskell-overlays/reflex-packages/dep/reflex/github.json index 33471f550..6ec7d6b63 100644 --- a/haskell-overlays/reflex-packages/dep/reflex/github.json +++ b/haskell-overlays/reflex-packages/dep/reflex/github.json @@ -1,6 +1,6 @@ { "owner": "reflex-frp", "repo": "reflex", - "rev": "49e0bb852fc0640fac19c5f53f72465b0d5e19ad", - "sha256": "1ybg4psh5fkhhbd0nwbwqp1f4v368889garyg8ryj3bj8byc6akg" + "rev": "22c3a90984add18e07315372f7f5596c3da08ad2", + "sha256": "0gv4azqdwknx0b9fklvrasiwdzaiwk6980q99lvx4jkymbym5zqb" } From ef4d122ac5978b1611228e365a2cfc1e15659a39 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 14 May 2019 16:13:37 -0400 Subject: [PATCH 06/55] WIP: Update to GHC 8.6.4 --- default.nix | 68 ++++++++++---------- haskell-overlays/any-8.6.nix | 22 +++++++ haskell-overlays/default.nix | 14 ++-- haskell-overlays/ghcjs-8.6-text-jsstring.nix | 48 ++++++++++++++ 4 files changed, 111 insertions(+), 41 deletions(-) create mode 100644 haskell-overlays/any-8.6.nix create mode 100644 haskell-overlays/ghcjs-8.6-text-jsstring.nix diff --git a/default.nix b/default.nix index b28c31a3c..63a588cc7 100644 --- a/default.nix +++ b/default.nix @@ -18,16 +18,16 @@ let iosSupport = system == "x86_64-darwin"; splicesEval = self: super: { haskell = super.haskell // { compiler = super.haskell.compiler // { - ghcSplices-8_4 = super.haskell.compiler.ghc844.overrideAttrs (drv: { + ghcSplices-8_6 = super.haskell.compiler.ghc864.overrideAttrs (drv: { enableParallelBuilding = false; patches = (drv.patches or []) ++ [ ./splices-load-save.patch ./haddock.patch ]; }); }; packages = super.haskell.packages // { - ghcSplices-8_4 = super.haskell.packages.ghc844.override { - buildHaskellPackages = self.buildPackages.haskell.packages.ghcSplices-8_4; - ghc = self.buildPackages.haskell.compiler.ghcSplices-8_4; + ghcSplices-8_6 = super.haskell.packages.ghc864.override { + buildHaskellPackages = self.buildPackages.haskell.packages.ghcSplices-8_6; + ghc = self.buildPackages.haskell.compiler.ghcSplices-8_6; }; }; }; @@ -155,8 +155,8 @@ let iosSupport = system == "x86_64-darwin"; sha256 = null; }); - ghcSavedSplices = ghcSavedSplices-8_4; - ghcSavedSplices-8_4 = (makeRecursivelyOverridable nixpkgs.haskell.packages.integer-simple.ghcSplices-8_4).override { + ghcSavedSplices = ghcSavedSplices-8_6; + ghcSavedSplices-8_6 = (makeRecursivelyOverridable nixpkgs.haskell.packages.integer-simple.ghcSplices-8_6).override { overrides = lib.foldr lib.composeExtensions (_: _: {}) (let haskellOverlays = nixpkgs.haskell.overlays; in [ @@ -185,11 +185,11 @@ let iosSupport = system == "x86_64-darwin"; overrides = nixpkgs.haskell.overlays.combined; }; - ghc = ghc8_4; + ghc = ghc8_6; ghcHEAD = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghcHEAD).override { overrides = nixpkgs.haskell.overlays.combined; }; - ghc8_4 = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghc844).override { + ghc8_6 = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghc864).override { overrides = nixpkgs.haskell.overlays.combined; }; @@ -207,25 +207,25 @@ let iosSupport = system == "x86_64-darwin"; new)); }; - ghcAndroidAarch64 = ghcAndroidAarch64-8_4; - ghcAndroidAarch64-8_4 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.android.aarch64.haskell.packages.integer-simple.ghcSplices-8_4).override { + ghcAndroidAarch64 = ghcAndroidAarch64-8_6; + ghcAndroidAarch64-8_6 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.android.aarch64.haskell.packages.integer-simple.ghcSplices-8_6).override { overrides = nixpkgsCross.android.aarch64.haskell.overlays.combined; }); - ghcAndroidAarch32 = ghcAndroidAarch32-8_4; - ghcAndroidAarch32-8_4 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.android.aarch32.haskell.packages.integer-simple.ghcSplices-8_4).override { + ghcAndroidAarch32 = ghcAndroidAarch32-8_6; + ghcAndroidAarch32-8_6 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.android.aarch32.haskell.packages.integer-simple.ghcSplices-8_6).override { overrides = nixpkgsCross.android.aarch32.haskell.overlays.combined; }); - ghcIosSimulator64 = ghcIosSimulator64-8_4; - ghcIosSimulator64-8_4 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.ios.simulator64.haskell.packages.integer-simple.ghcSplices-8_4).override { + ghcIosSimulator64 = ghcIosSimulator64-8_6; + ghcIosSimulator64-8_6 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.ios.simulator64.haskell.packages.integer-simple.ghcSplices-8_6).override { overrides = nixpkgsCross.ios.simulator64.haskell.overlays.combined; }); - ghcIosAarch64 = ghcIosAarch64-8_4; - ghcIosAarch64-8_4 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.ios.aarch64.haskell.packages.integer-simple.ghcSplices-8_4).override { + ghcIosAarch64 = ghcIosAarch64-8_6; + ghcIosAarch64-8_6 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.ios.aarch64.haskell.packages.integer-simple.ghcSplices-8_6).override { overrides = nixpkgsCross.ios.aarch64.haskell.overlays.combined; }); - ghcIosAarch32 = ghcIosAarch32-8_4; - ghcIosAarch32-8_4 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.ios.aarch32.haskell.packages.integer-simple.ghcSplices-8_4).override { + ghcIosAarch32 = ghcIosAarch32-8_6; + ghcIosAarch32-8_6 = makeRecursivelyOverridableBHPToo ((makeRecursivelyOverridable nixpkgsCross.ios.aarch32.haskell.packages.integer-simple.ghcSplices-8_6).override { overrides = nixpkgsCross.ios.aarch32.haskell.overlays.combined; }); @@ -234,18 +234,18 @@ let iosSupport = system == "x86_64-darwin"; android = androidWithHaskellPackages { inherit ghcAndroidAarch64 ghcAndroidAarch32; }; - android-8_4 = androidWithHaskellPackages { - ghcAndroidAarch64 = ghcAndroidAarch64-8_4; - ghcAndroidAarch32 = ghcAndroidAarch32-8_4; + android-8_6 = androidWithHaskellPackages { + ghcAndroidAarch64 = ghcAndroidAarch64-8_6; + ghcAndroidAarch32 = ghcAndroidAarch32-8_6; }; androidWithHaskellPackages = { ghcAndroidAarch64, ghcAndroidAarch32 }: import ./android { inherit nixpkgs nixpkgsCross ghcAndroidAarch64 ghcAndroidAarch32 overrideCabal; acceptAndroidSdkLicenses = config.android_sdk.accept_license or false; }; iosAarch64 = iosWithHaskellPackages ghcIosAarch64; - iosAarch64-8_4 = iosWithHaskellPackages ghcIosAarch64-8_4; + iosAarch64-8_6 = iosWithHaskellPackages ghcIosAarch64-8_6; iosAarch32 = iosWithHaskellPackages ghcIosAarch32; - iosAarch32-8_4 = iosWithHaskellPackages ghcIosAarch32-8_4; + iosAarch32-8_6 = iosWithHaskellPackages ghcIosAarch32-8_6; iosWithHaskellPackages = ghc: { buildApp = nixpkgs.lib.makeOverridable (import ./ios { inherit nixpkgs ghc; }); }; @@ -261,16 +261,16 @@ in let this = rec { overrideCabal ghc ghcHEAD - ghc8_4 + ghc8_6 ghcIosSimulator64 ghcIosAarch64 - ghcIosAarch64-8_4 + ghcIosAarch64-8_6 ghcIosAarch32 - ghcIosAarch32-8_4 + ghcIosAarch32-8_6 ghcAndroidAarch64 - ghcAndroidAarch64-8_4 + ghcAndroidAarch64-8_6 ghcAndroidAarch32 - ghcAndroidAarch32-8_4 + ghcAndroidAarch32-8_6 ghcjs ghcjs8_4 ghcSavedSplices @@ -293,11 +293,11 @@ in let this = rec { applicationId = "org.reflexfrp.todomvc"; displayName = "Reflex TodoMVC"; }; - androidReflexTodomvc-8_4 = android-8_4.buildApp { + androidReflexTodomvc-8_6 = android-8_6.buildApp { package = p: p.reflex-todomvc; executableName = "reflex-todomvc"; - applicationId = "org.reflexfrp.todomvc.via_8_4"; - displayName = "Reflex TodoMVC via GHC 8.4"; + applicationId = "org.reflexfrp.todomvc.via_8_6"; + displayName = "Reflex TodoMVC via GHC 8.6"; }; iosReflexTodomvc = ios.buildApp { package = p: p.reflex-todomvc; @@ -305,11 +305,11 @@ in let this = rec { bundleIdentifier = "org.reflexfrp.todomvc"; bundleName = "Reflex TodoMVC"; }; - iosReflexTodomvc-8_4 = iosAarch64-8_4.buildApp { + iosReflexTodomvc-8_6 = iosAarch64-8_6.buildApp { package = p: p.reflex-todomvc; executableName = "reflex-todomvc"; - bundleIdentifier = "org.reflexfrp.todomvc.via_8_4"; - bundleName = "Reflex TodoMVC via GHC 8.4"; + bundleIdentifier = "org.reflexfrp.todomvc.via_8_6"; + bundleName = "Reflex TodoMVC via GHC 8.6"; }; setGhcLibdir = ghcLibdir: inputGhcjs: let libDir = "$out/lib/ghcjs-${inputGhcjs.version}"; diff --git a/haskell-overlays/any-8.6.nix b/haskell-overlays/any-8.6.nix new file mode 100644 index 000000000..df3104ea9 --- /dev/null +++ b/haskell-overlays/any-8.6.nix @@ -0,0 +1,22 @@ +{ pkgs, haskellLib, fetchFromGitHub }: +with haskellLib; +self: super: { + cabal-macosx = dontCheck super.cabal-macosx; + enclosed-exceptions = dontCheck super.enclosed-exceptions; # see https://github.com/jcristovao/enclosed-exceptions/issues/12 + haddock-library-ghcjs = dontCheck super.haddock-library-ghcjs; + haddock-api-ghcjs = dontCheck super.haddock-api-ghcjs; + algebraic-graphs = doJailbreak super.algebraic-graphs; + + # Broken in master + # PR is https://github.com/vincenthz/hit/pull/37 + hit = dontCheck (self.callCabal2nix "hit" (fetchFromGitHub { + owner = "vincenthz"; + repo = "hit"; + rev = "e93b01a295d5b4ca51b32b928b37ae040366e317"; + sha256 = "1vfxqc3kffls11dzxq0gk62ky8rjm455cnh0nv31x43g3pmhh7sp"; + }) {}); + + # doctests: doctests: could not execute: markdown-unlit + # Test suite doctests: FAIL + rank2classes = dontCheck super.rank2classes; +} diff --git a/haskell-overlays/default.nix b/haskell-overlays/default.nix index ca4a29d1f..5264a4149 100644 --- a/haskell-overlays/default.nix +++ b/haskell-overlays/default.nix @@ -45,7 +45,7 @@ rec { (optionalExtension (super.ghc.isGhcjs or false) combined-ghcjs) (optionalExtension (super.ghc.isGhcjs or false && useTextJSString) textJSString) - (optionalExtension (with nixpkgs.stdenv; versionWildcard [ 8 4 ] super.ghc.version && hostPlatform != buildPlatform) loadSplices) + (optionalExtension (with nixpkgs.stdenv; versionWildcard [ 8 6 ] super.ghc.version && hostPlatform != buildPlatform) loadSplices) (optionalExtension (nixpkgs.stdenv.hostPlatform.useAndroidPrebuilt or false) android) (optionalExtension (nixpkgs.stdenv.hostPlatform.isiOS or false) ios) @@ -60,13 +60,13 @@ rec { combined-any-8 = self: super: foldExtensions [ any-8 - (optionalExtension (versionWildcard [ 8 4 ] (getGhcVersion super.ghc)) any-8_4) - (optionalExtension (lib.versionOlder "8.5" (getGhcVersion super.ghc)) any-head) + (optionalExtension (versionWildcard [ 8 6 ] (getGhcVersion super.ghc)) any-8_6) + (optionalExtension (lib.versionOlder "8.7" (getGhcVersion super.ghc)) any-head) ] self super; combined-ghc = self: super: foldExtensions [ - (optionalExtension (versionWildcard [ 8 4 ] super.ghc.version) ghc-8_4) - (optionalExtension (lib.versionOlder "8.5" super.ghc.version) ghc-head) + (optionalExtension (versionWildcard [ 8 6 ] super.ghc.version) ghc-8_6) + (optionalExtension (lib.versionOlder "8.7" super.ghc.version) ghc-head) ] self super; combined-ghcjs = self: super: foldExtensions [ @@ -94,11 +94,11 @@ rec { # For GHC and GHCJS any = _: _: {}; any-8 = import ./any-8.nix { inherit haskellLib lib getGhcVersion; }; - any-8_4 = import ./any-8.4.nix { inherit haskellLib fetchFromGitHub; inherit (nixpkgs) pkgs; }; + any-8_6 = import ./any-8.6.nix { inherit haskellLib fetchFromGitHub; inherit (nixpkgs) pkgs; }; any-head = import ./any-head.nix { inherit haskellLib fetchFromGitHub; }; # Just for GHC, usually to sync with GHCJS - ghc-8_4 = _: _: {}; + ghc-8_6 = _: _: {}; ghc-head = _: _: {}; saveSplices = import ./save-splices.nix { diff --git a/haskell-overlays/ghcjs-8.6-text-jsstring.nix b/haskell-overlays/ghcjs-8.6-text-jsstring.nix new file mode 100644 index 000000000..e43556f17 --- /dev/null +++ b/haskell-overlays/ghcjs-8.6-text-jsstring.nix @@ -0,0 +1,48 @@ +{ lib, fetchgit }: + +self: super: { + _dep = super._dep or {} // { + + textSrc = fetchgit { + url = "https://github.com/obsidiansystems/text.git"; + rev = "50076be0262203f0d2afdd0b190a341878a08e21"; + sha256 = "1vy7a81b1vcbfhv7l3m7p4hx365ss13mzbzkjn9751bn4n7x2ydd"; + }; + dlistSrc = fetchgit { + url = "https://github.com/spl/dlist.git"; + rev = "03d91a3000cba49bd2c8588cf1b0d71e229ad3b0"; #v0.8.0.4 + sha256 = "0asvz1a2rp174r3vvgs1qaidxbdxly4mnlra33dipd0gxrrk15sq"; + }; + vectorSrc = fetchgit { + url = "https://github.com/haskell/vector.git"; + rev = "1d208ee9e3a252941ebd112e14e8cd5a982ac2bb"; #v0.12.0.1 + sha256 = "18qm1c2zqr8h150917djfc0xk62hv99b1clxfs9a79aavrsqi5hs"; + postFetch = '' + substituteInPlace $out/vector.cabal --replace 'base >= 4.5 && < 4.10' 'base >= 4.5 && < 5' + ''; + }; + }; + + ghc = super.ghc.overrideAttrs (drv: { + postUnpack = '' + set -x + ( + echo $sourceRoot + cd $sourceRoot + rm -r lib/boot/pkg/text + cp --no-preserve=mode -r "${self._dep.textSrc}" lib/boot/pkg/text + cp --no-preserve=mode -r "${self._dep.ghcjsBaseTextJSStringSrc}" lib/boot/pkg/ghcjs-base + cp --no-preserve=mode -r "${self._dep.dlistSrc}" lib/boot/pkg/dlist + rm -r lib/boot/pkg/vector + cp --no-preserve=mode -r "${self._dep.vectorSrc}" lib/boot/pkg/vector + sed -i 's/.\/pkg\/mtl/.\/pkg\/mtl\n - .\/pkg\/ghcjs-base\n - .\/pkg\/dlist\n - .\/pkg\/primitive\n - .\/pkg\/vector/' lib/boot/boot.yaml + cat lib/boot/boot.yaml + ) + ''; + }); + + dlist = null; + ghcjs-base = null; + primitive = null; + vector = null; +} From dc7b9859aee62e831913f295415cd40fd344c06f Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 14 May 2019 17:46:59 -0400 Subject: [PATCH 07/55] Bump reflex and reflex-dom --- haskell-overlays/reflex-packages/dep/reflex-dom/github.json | 4 ++-- haskell-overlays/reflex-packages/dep/reflex/github.json | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/haskell-overlays/reflex-packages/dep/reflex-dom/github.json b/haskell-overlays/reflex-packages/dep/reflex-dom/github.json index 2f1c1870f..1c9cf405d 100644 --- a/haskell-overlays/reflex-packages/dep/reflex-dom/github.json +++ b/haskell-overlays/reflex-packages/dep/reflex-dom/github.json @@ -1,6 +1,6 @@ { "owner": "reflex-frp", "repo": "reflex-dom", - "rev": "2734d2d70fd0b63849a7e0b5355d80ee66eda127", - "sha256": "0qv51vn07lg6fnaxlcrns5pwg8y5h4cjv18dr56kbnh11a52wba7" + "rev": "d919ff092841b5c980266ff99bcc0d2de3c12ba0", + "sha256": "12hb8kgzw4a0fsqcnld1s38p46mihsmap3bvgykii1idaxama3yi" } diff --git a/haskell-overlays/reflex-packages/dep/reflex/github.json b/haskell-overlays/reflex-packages/dep/reflex/github.json index 6ec7d6b63..bfc49dcbb 100644 --- a/haskell-overlays/reflex-packages/dep/reflex/github.json +++ b/haskell-overlays/reflex-packages/dep/reflex/github.json @@ -1,6 +1,6 @@ { "owner": "reflex-frp", "repo": "reflex", - "rev": "22c3a90984add18e07315372f7f5596c3da08ad2", - "sha256": "0gv4azqdwknx0b9fklvrasiwdzaiwk6980q99lvx4jkymbym5zqb" + "rev": "958a68cbb07338d97703e71ddde5ce6645c350aa", + "sha256": "14pxwazqw74iw2n5c9x3s4iflqf9xkpbbxf89zxwp1j0n9cwgygs" } From 447c906f1dd81c9be73d15bae27e26e34fb4d014 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 15 May 2019 14:39:22 -0400 Subject: [PATCH 08/55] WIP be able to bump all-cabal-hashes ahead of nixpkgs --- default.nix | 3 +++ nixpkgs-overlays/all-cabal-hashes/default.nix | 8 ++++++++ 2 files changed, 11 insertions(+) create mode 100644 nixpkgs-overlays/all-cabal-hashes/default.nix diff --git a/default.nix b/default.nix index 63a588cc7..03c729726 100644 --- a/default.nix +++ b/default.nix @@ -66,6 +66,8 @@ let iosSupport = system == "x86_64-darwin"; mobileGhcOverlay = import ./nixpkgs-overlays/mobile-ghc { inherit lib; }; + allCabalHashesOverlay = import ./nixpkgs-overlays/all-cabal-hashes; + nixpkgsArgs = { inherit system; overlays = [ @@ -73,6 +75,7 @@ let iosSupport = system == "x86_64-darwin"; bindHaskellOverlays forceStaticLibs mobileGhcOverlay + allCabalHashesOverlay splicesEval ] ++ nixpkgsOverlays; config = { diff --git a/nixpkgs-overlays/all-cabal-hashes/default.nix b/nixpkgs-overlays/all-cabal-hashes/default.nix new file mode 100644 index 000000000..3618ee2fc --- /dev/null +++ b/nixpkgs-overlays/all-cabal-hashes/default.nix @@ -0,0 +1,8 @@ +self: _: { + + all-cabal-hashes = self.fetchurl { + url = "https://github.com/commercialhaskell/all-cabal-hashes/archive/98ec0eee2ddef5d4a00e2ac4a95e8add46d23b69.tar.gz"; + sha256 = "0svcaaflqi5c815z3yrh61bjny1jnwp42sylmsnwryjldqvizc1a"; + }; + +} From 5839a49b167f4ff0e47ca2096d355f970a0471b5 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sat, 6 Jul 2019 12:05:21 -0400 Subject: [PATCH 09/55] wip: Bump ghcjs --- default.nix | 12 +- haskell-overlays/any-8.6.nix | 12 + haskell-overlays/any-8.nix | 3 +- haskell-overlays/any-head.nix | 18 +- haskell-overlays/default.nix | 4 +- nixpkgs-overlays/all-cabal-hashes/default.nix | 4 +- splices-load-save.patch | 8528 ++++++++++------- 7 files changed, 4878 insertions(+), 3703 deletions(-) diff --git a/default.nix b/default.nix index 03c729726..54c71c472 100644 --- a/default.nix +++ b/default.nix @@ -18,14 +18,14 @@ let iosSupport = system == "x86_64-darwin"; splicesEval = self: super: { haskell = super.haskell // { compiler = super.haskell.compiler // { - ghcSplices-8_6 = super.haskell.compiler.ghc864.overrideAttrs (drv: { + ghcSplices-8_6 = super.haskell.compiler.ghc863.overrideAttrs (drv: { enableParallelBuilding = false; patches = (drv.patches or []) ++ [ ./splices-load-save.patch ./haddock.patch ]; }); }; packages = super.haskell.packages // { - ghcSplices-8_6 = super.haskell.packages.ghc864.override { + ghcSplices-8_6 = super.haskell.packages.ghc863.override { buildHaskellPackages = self.buildPackages.haskell.packages.ghcSplices-8_6; ghc = self.buildPackages.haskell.compiler.ghcSplices-8_6; }; @@ -174,8 +174,8 @@ let iosSupport = system == "x86_64-darwin"; }) ]); }; - ghcjs = ghcjs8_4; - ghcjs8_4 = (makeRecursivelyOverridable (nixpkgs.haskell.packages.ghcjs84.override (old: { + ghcjs = ghcjs8_6; + ghcjs8_6 = (makeRecursivelyOverridable (nixpkgs.haskell.packages.ghcjs86.override (old: { ghc = old.ghc.override { ghcjsSrc = fetchgit { url = "https://github.com/obsidiansystems/ghcjs.git"; @@ -192,7 +192,7 @@ let iosSupport = system == "x86_64-darwin"; ghcHEAD = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghcHEAD).override { overrides = nixpkgs.haskell.overlays.combined; }; - ghc8_6 = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghc864).override { + ghc8_6 = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghc863).override { overrides = nixpkgs.haskell.overlays.combined; }; @@ -275,7 +275,7 @@ in let this = rec { ghcAndroidAarch32 ghcAndroidAarch32-8_6 ghcjs - ghcjs8_4 + ghcjs8_6 ghcSavedSplices android androidWithHaskellPackages diff --git a/haskell-overlays/any-8.6.nix b/haskell-overlays/any-8.6.nix index df3104ea9..97e6cfc42 100644 --- a/haskell-overlays/any-8.6.nix +++ b/haskell-overlays/any-8.6.nix @@ -19,4 +19,16 @@ self: super: { # doctests: doctests: could not execute: markdown-unlit # Test suite doctests: FAIL rank2classes = dontCheck super.rank2classes; + entropy = self.callHackage "entropy" "0.4.1.4" {}; + cryptohash-sha256 = doJailbreak super.cryptohash-sha256; + czipwith = doJailbreak super.czipwith; + haddock-library = doJailbreak (self.callHackage "haddock-library" "1.7.0" {}); + basement = self.callHackage "basement" "0.0.10" {}; + keycode = doJailbreak (self.callCabal2nix "hit" (fetchFromGitHub { + owner = "RyanGlScott"; + repo = "keycode"; + rev = "beecb745750de7b0b470ae5af9f2fe506f54dd31"; + sha256 = "03zm21f134cpg13fhnm541hawz649ynwmcwwmaz358gdnd2fypgv"; + }) {}); + polyparse = self.callHackage "polyparse" "1.12.1" {}; } diff --git a/haskell-overlays/any-8.nix b/haskell-overlays/any-8.nix index 6ea32b521..a8708c08f 100644 --- a/haskell-overlays/any-8.nix +++ b/haskell-overlays/any-8.nix @@ -1,9 +1,10 @@ { lib, haskellLib, getGhcVersion }: - +with haskellLib; self: super: lib.optionalAttrs (lib.versionOlder (getGhcVersion super.ghc) "8.4.0") { # TODO document why concurrent-output = haskellLib.doJailbreak super.concurrent-output; # Newer versions cause some sort of issues with multiple `(<>)` definitions. # Seems to be that semigroup-monoid stuff is being CPP'd incorrectly. base-compat= self.callHackage "base-compat" "0.9.3" {}; + haddock-library = doJailbreak (self.callHackage "haddock-library" "1.7.0" {}); } diff --git a/haskell-overlays/any-head.nix b/haskell-overlays/any-head.nix index 5321020c2..386f382b5 100644 --- a/haskell-overlays/any-head.nix +++ b/haskell-overlays/any-head.nix @@ -43,22 +43,6 @@ self: super: { }; }); - entropy = haskellLib.overrideCabal super.entropy (drv: { - src = fetchFromGitHub { - owner = "TomMD"; - repo = "entropy"; - rev = "c682fcd6cc2bcaa5cab9f6e59a93faf8c9938221"; - sha256 = "162pazw91zp3kzvivxdn3n8ffsdxi9bfwm24vwkp96sgds59xs31"; - }; - }); - - vector-algorithms = haskellLib.overrideCabal super.entropy (drv: { - src = fetchFromGitHub { - owner = "matthewbauer"; - repo = "vector-algorithms"; - rev = "7acf1e142f352d728b0b3a050da825d472fe6471"; - sha256 = "0b5pnjfwgjm2jk2hhld4y217qa3j1vvzv68h8daxnwrp07q1fyka"; - }; - }); + entropy = self.callHackage "entropy" "0.4.1.4" {}; } diff --git a/haskell-overlays/default.nix b/haskell-overlays/default.nix index 5264a4149..7a7effb7c 100644 --- a/haskell-overlays/default.nix +++ b/haskell-overlays/default.nix @@ -71,7 +71,7 @@ rec { combined-ghcjs = self: super: foldExtensions [ ghcjs - (optionalExtension (versionWildcard [ 8 4 ] super.ghc.ghcVersion) ghcjs-8_4) + (optionalExtension (versionWildcard [ 8 6 ] super.ghc.ghcVersion) ghcjs-8_6) (optionalExtension useFastWeak ghcjs-fast-weak) ] self super; @@ -117,7 +117,7 @@ rec { ghcjs-fast-weak = import ./ghcjs-fast-weak { inherit lib; }; - ghcjs-8_4 = optionalExtension useTextJSString + ghcjs-8_6 = optionalExtension useTextJSString (import ./ghcjs-8.4-text-jsstring.nix { inherit lib fetchgit; }); android = import ./android { diff --git a/nixpkgs-overlays/all-cabal-hashes/default.nix b/nixpkgs-overlays/all-cabal-hashes/default.nix index 3618ee2fc..1a6686a67 100644 --- a/nixpkgs-overlays/all-cabal-hashes/default.nix +++ b/nixpkgs-overlays/all-cabal-hashes/default.nix @@ -1,8 +1,8 @@ self: _: { all-cabal-hashes = self.fetchurl { - url = "https://github.com/commercialhaskell/all-cabal-hashes/archive/98ec0eee2ddef5d4a00e2ac4a95e8add46d23b69.tar.gz"; - sha256 = "0svcaaflqi5c815z3yrh61bjny1jnwp42sylmsnwryjldqvizc1a"; + url = "https://github.com/commercialhaskell/all-cabal-hashes/archive/5e782dacf8d2d603f3848cfa37561acba313fbd5.tar.gz"; + sha256 = "0cms0z38fcmrzplhzl34d3cm7hs8kr4z8p5cnxvhhjm7mf7357z7"; }; } diff --git a/splices-load-save.patch b/splices-load-save.patch index 5f7f16c47..c9a5900fc 100644 --- a/splices-load-save.patch +++ b/splices-load-save.patch @@ -1,4384 +1,5562 @@ diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs -index a6d05936c1..2c8bc00af2 100644 +index efcb26d047..3dd7e14b12 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs -@@ -812,6 +812,7 @@ instance Binary SrcUnpackedness where +@@ -811,7 +811,6 @@ instance Binary SrcUnpackedness where 1 -> return SrcUnpack _ -> return NoSrcUnpack -+ +- -- | Compare strictness annotations eqHsBang :: HsImplBang -> HsImplBang -> Bool eqHsBang HsLazy HsLazy = True diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs -index 07f8814767..10497fbba0 100644 +index aed09b6a42..f6febaf4dc 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -18,7 +18,7 @@ module IdInfo ( RecSelParent(..), -- * The IdInfo type -- IdInfo, -- Abstract -+ IdInfo, +- IdInfo, ++ IdInfo, -- Abstract vanillaIdInfo, noCafIdInfo, -- ** The OneShotInfo type diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot -index cacfe6af2e..229ff9abb0 100644 +index 229ff9abb0..cacfe6af2e 100644 --- a/compiler/basicTypes/IdInfo.hs-boot +++ b/compiler/basicTypes/IdInfo.hs-boot -@@ -1,6 +1,7 @@ +@@ -1,7 +1,6 @@ module IdInfo where import GhcPrelude import Outputable -+ +- data IdInfo data IdDetails -@@ -8,4 +9,3 @@ vanillaIdInfo :: IdInfo +@@ -9,3 +8,4 @@ vanillaIdInfo :: IdInfo coVarDetails :: IdDetails isCoVarDetails :: IdDetails -> Bool pprIdDetails :: IdDetails -> SDoc -- ++ diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs -index f6a66fd635..854873011d 100644 +index fa54967e8a..1af53fb3dc 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs -@@ -399,6 +399,10 @@ instance Uniquable OccName where +@@ -394,10 +394,6 @@ instance Uniquable OccName where newtype OccEnv a = A (UniqFM a) deriving Data -+instance Binary a => Binary (OccEnv a) where -+ put_ bh (A a) = put_ bh a -+ get bh = A <$> get bh -+ +-instance Binary a => Binary (OccEnv a) where +- put_ bh (A a) = put_ bh a +- get bh = A <$> get bh +- emptyOccEnv :: OccEnv a unitOccEnv :: OccName -> a -> OccEnv a extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs -index 5a74a5b68a..fa5e475487 100644 +index 76b93e4224..2e838d6b82 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs -@@ -32,6 +32,7 @@ import Outputable +@@ -32,7 +32,6 @@ import Outputable import Unique import Util import BasicTypes -+import Binary +-import Binary import Var import FieldLabel -@@ -328,6 +329,10 @@ instance Data.Data PatSyn where +@@ -329,10 +328,6 @@ instance Data.Data PatSyn where gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "PatSyn" -+instance Binary PatSyn where -+ put = error "Binary PatSyn: not implemented yet" -+ get = error "Binary PatSyn: not implemented yet" -+ +-instance Binary PatSyn where +- put = error "Binary PatSyn: not implemented yet" +- get = error "Binary PatSyn: not implemented yet" +- {- ************************************************************************ * * diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs -index 84ece4e9ff..45f2f00b13 100644 +index a4f1a68e65..610233ed9a 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs -@@ -72,6 +72,7 @@ import GhcPrelude +@@ -75,7 +75,6 @@ import GhcPrelude import Module import Name import Avail -+import Binary +-import Binary import NameSet import Maybes import SrcLoc -@@ -467,6 +468,10 @@ data GlobalRdrElt +@@ -467,10 +466,6 @@ data GlobalRdrElt -- INVARIANT: either gre_lcl = True or gre_imp is non-empty -- See Note [GlobalRdrElt provenance] -+instance Binary GlobalRdrElt where -+ put_ bh (GRE a b c d) = put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ get bh = GRE <$> get bh <*> get bh <*> get bh <*> get bh -+ +-instance Binary GlobalRdrElt where +- put_ bh (GRE a b c d) = put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- get bh = GRE <$> get bh <*> get bh <*> get bh <*> get bh +- -- | The children of a Name are the things that are abbreviated by the ".." -- notation in export lists. See Note [Parents] data Parent = NoParent -@@ -475,6 +480,18 @@ data Parent = NoParent +@@ -479,18 +474,6 @@ data Parent = NoParent -- ^ See Note [Parents for record fields] - deriving (Eq, Data, Typeable) - -+instance Binary Parent where -+ put_ bh p = case p of -+ NoParent -> putByte bh 0 -+ ParentIs p -> putByte bh 1 >> put_ bh p -+ FldParent a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure NoParent -+ 1 -> ParentIs <$> get bh -+ _ -> FldParent <$> get bh <*> get bh -+ + deriving (Eq, Data) + +-instance Binary Parent where +- put_ bh p = case p of +- NoParent -> putByte bh 0 +- ParentIs p -> putByte bh 1 >> put_ bh p +- FldParent a b -> putByte bh 2 >> put_ bh a >> put_ bh b +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure NoParent +- 1 -> ParentIs <$> get bh +- _ -> FldParent <$> get bh <*> get bh +- instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n -@@ -1135,6 +1152,10 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, +@@ -1151,10 +1134,6 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, is_item :: ImpItemSpec } deriving( Eq, Ord, Data ) -+instance Binary ImportSpec where -+ put_ bh (ImpSpec a b) = put_ bh a >> put_ bh b -+ get bh = ImpSpec <$> get bh <*> get bh -+ +-instance Binary ImportSpec where +- put_ bh (ImpSpec a b) = put_ bh a >> put_ bh b +- get bh = ImpSpec <$> get bh <*> get bh +- -- | Import Declaration Specification -- -- Describes a particular import declaration and is -@@ -1152,6 +1173,11 @@ data ImpDeclSpec +@@ -1172,11 +1151,6 @@ data ImpDeclSpec is_dloc :: SrcSpan -- ^ The location of the entire import declaration } deriving Data -+instance Binary ImpDeclSpec where -+ put_ bh (ImpDeclSpec a b c d) = -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ get bh = ImpDeclSpec <$> get bh <*> get bh <*> get bh <*> get bh -+ +-instance Binary ImpDeclSpec where +- put_ bh (ImpDeclSpec a b c d) = +- put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- get bh = ImpDeclSpec <$> get bh <*> get bh <*> get bh <*> get bh +- -- | Import Item Specification -- -- Describes import info a particular Name -@@ -1173,6 +1199,16 @@ data ImpItemSpec +@@ -1198,16 +1172,6 @@ data ImpItemSpec -- only @T@ is named explicitly. deriving Data -+instance Binary ImpItemSpec where -+ put_ bh s = case s of -+ ImpAll -> putByte bh 0 -+ ImpSome a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure ImpAll -+ _ -> ImpSome <$> get bh <*> get bh -+ +-instance Binary ImpItemSpec where +- put_ bh s = case s of +- ImpAll -> putByte bh 0 +- ImpSome a b -> putByte bh 1 >> put_ bh a >> put_ bh b +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure ImpAll +- _ -> ImpSome <$> get bh <*> get bh +- instance Eq ImpDeclSpec where p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in -index 9205648846..04e46f961d 100644 +index 3521bdc06c..01628dcad1 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in -@@ -210,6 +210,7 @@ Library +@@ -210,7 +210,6 @@ Library NameSet OccName RdrName -+ SeName +- SeName NameCache SrcLoc UniqSupply -@@ -316,6 +317,9 @@ Library +@@ -319,11 +318,6 @@ Library HsDecls HsDoc HsExpr -+ HsExprBin -+ HsExprBin_Conversions -+ HsExprBin_Instances +- HsExprBin +- HsExprBin_ConversionPS2SE +- HsExprBin_ConversionSE2PS +- HsExprBin_Conversions +- HsExprBin_Instances HsImpExp HsLit PlaceHolder diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs -index a9be2c1341..a346667b2b 100644 +index 9c3665f025..98f503b0d9 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs -@@ -12,6 +12,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. +@@ -12,7 +12,6 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder -+{-# LANGUAGE TypeFamilies #-} +-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} - -@@ -324,7 +325,8 @@ data PatSynBind idL idR - -- ^ Formal parameter names - psb_def :: LPat idR, -- ^ Right-hand side - psb_dir :: HsPatSynDir idR -- ^ Directionality -- } -+ } -+ - deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR) - - {- -@@ -779,7 +781,6 @@ deriving instance (DataId name) => Data (IPBind name) - - instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where - ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) -- $$ whenPprDebug (ppr ds) - - instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where - ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) -@@ -854,7 +855,7 @@ data Sig pass + {-# LANGUAGE TypeFamilies #-} +@@ -323,12 +322,10 @@ data NPatBindTc = NPatBindTc { + type instance XFunBind (GhcPass pL) GhcPs = NoExt + type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables + type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables +-type instance XFunBind (GhcPass pL) GhcSe = NoExt + + type instance XPatBind GhcPs (GhcPass pR) = NoExt + type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables + type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc +-type instance XPatBind GhcSe (GhcPass pR) = NoExt + + type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt + type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt +@@ -385,7 +382,6 @@ data PatSynBind idL idR + type instance XPSB (GhcPass idL) GhcPs = NoExt + type instance XPSB (GhcPass idL) GhcRn = NameSet + type instance XPSB (GhcPass idL) GhcTc = NameSet +-type instance XPSB (GhcPass idL) GhcSe = NoExt + + type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt + +@@ -832,7 +828,6 @@ type instance XIPBinds GhcPs = NoExt + type instance XIPBinds GhcRn = NoExt + type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the + -- implicit parameters +-type instance XIPBinds GhcSe = NoExt + + + type instance XXHsIPBinds (GhcPass p) = NoExt +@@ -953,7 +948,7 @@ data Sig pass -- the desired Id itself, replete with its name, type -- and IdDetails. Otherwise it's just like a type -- signature: there should be an accompanying binding -- | IdSig Id -+ | IdSig (IdSigId pass) +- | IdSig (XIdSig pass) (IdSigId pass) ++ | IdSig (XIdSig pass) Id -- | An ordinary fixity declaration -- -@@ -1063,7 +1064,9 @@ ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) - ppr_sig (ClassOpSig is_deflt vars ty) +@@ -1182,9 +1177,7 @@ ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) + ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) --ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) -+ppr_sig (IdSig id) = case getVarType id of -+ Nothing -> ppr id -+ Just t -> pprVarSig [id] (ppr t) - ppr_sig (FixSig fix_sig) = ppr fix_sig - ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec })) +-ppr_sig (IdSig _ id) = case getVarType id of +- Nothing -> ppr id +- Just t -> pprVarSig [id] (ppr t) ++ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) + ppr_sig (FixSig _ fix_sig) = ppr fix_sig + ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs -index 55d43fd058..dca809f7d1 100644 +index db5510c706..f84fcfd5ec 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs -@@ -11,6 +11,7 @@ +@@ -10,7 +10,6 @@ + {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} - {-# LANGUAGE FlexibleInstances #-} -+{-# LANGUAGE TypeFamilies #-} +-{-# LANGUAGE FlexibleInstances #-} + {-# LANGUAGE TypeFamilies #-} -- | Abstract syntax of global declarations. - -- -@@ -540,7 +541,6 @@ data TyClDecl pass +@@ -578,17 +577,14 @@ type instance XFamDecl (GhcPass _) = NoExt + type instance XSynDecl GhcPs = NoExt + type instance XSynDecl GhcRn = NameSet -- FVs + type instance XSynDecl GhcTc = NameSet -- FVs +-type instance XSynDecl GhcSe = NoExt - deriving instance (DataId id) => Data (TyClDecl id) + type instance XDataDecl GhcPs = NoExt + type instance XDataDecl GhcRn = DataDeclRn + type instance XDataDecl GhcTc = DataDeclRn +-type instance XDataDecl GhcSe = NoExt -- - -- Simple classifiers for TyClDecl - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + type instance XClassDecl GhcPs = NoExt + type instance XClassDecl GhcRn = NameSet -- FVs + type instance XClassDecl GhcTc = NameSet -- FVs +-type instance XClassDecl GhcSe = NoExt -@@ -644,7 +644,6 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars + type instance XXTyClDecl (GhcPass _) = NoExt - instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (TyClDecl pass) where -- +@@ -699,6 +695,7 @@ hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk" + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + + instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where ++ ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity , tcdRhs = rhs }) -@@ -714,7 +713,6 @@ pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) - pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) - = ppr nd +@@ -1871,7 +1868,6 @@ data DerivStrategy pass + type instance XViaStrategy GhcPs = LHsSigType GhcPs + type instance XViaStrategy GhcRn = LHsSigType GhcRn + type instance XViaStrategy GhcTc = Type +-type instance XViaStrategy GhcSe = LHsSigType GhcSe + + instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DerivStrategy p) where +@@ -1972,12 +1968,10 @@ data ForeignDecl pass + type instance XForeignImport GhcPs = NoExt + type instance XForeignImport GhcRn = NoExt + type instance XForeignImport GhcTc = Coercion +-type instance XForeignImport GhcSe = NoExt + + type instance XForeignExport GhcPs = NoExt + type instance XForeignExport GhcRn = NoExt + type instance XForeignExport GhcTc = Coercion +-type instance XForeignExport GhcSe = NoExt + + type instance XXForeignDecl (GhcPass _) = NoExt + +@@ -2120,7 +2114,6 @@ data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS + type instance XHsRule GhcPs = NoExt + type instance XHsRule GhcRn = HsRuleRn + type instance XHsRule GhcTc = HsRuleRn +-type instance XHsRule GhcSe = NoExt + + type instance XXRuleDecl (GhcPass _) = NoExt -- - {- Note [Complete user-supplied kind signatures] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We kind-check declarations differently if they have a complete, user-supplied diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs -index 333ca32d72..87a43797e6 100644 +index 72042690cd..6ca37e07ce 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs -@@ -10,7 +10,8 @@ +@@ -10,7 +10,7 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} --{-# LANGUAGE DeriveFunctor #-} -+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -+{-# LANGUAGE TypeFamilies #-} +-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} ++{-# LANGUAGE DeriveFunctor #-} + {-# LANGUAGE TypeFamilies #-} -- | Abstract Haskell syntax for expressions. - module HsExpr where -@@ -34,7 +35,7 @@ import CoreSyn - import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) - import Name - import NameSet --import RdrName ( GlobalRdrEnv ) -+import RdrName ( GlobalRdrEnv, RdrName ) - import BasicTypes - import ConLike - import SrcLoc -@@ -434,7 +435,7 @@ data HsExpr p +@@ -442,11 +442,11 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -- | HsDo (HsStmtContext Name) -- The parameterisation is unimportant -+ | HsDo (HsStmtContext (DoName p)) -- The parameterisation is unimportant - -- because in this context we never use - -- the PatGuard or ParStmt variant - (Located [ExprLStmt p]) -- "do":one or more stmts -@@ -482,7 +483,6 @@ data HsExpr p +- | HsDo (XDo p) -- Type of the whole expression +- (HsStmtContext (DoName p)) -- The parameterisation is unimportant +- -- because in this context we never use +- -- the PatGuard or ParStmt variant +- (Located [ExprLStmt p]) -- "do":one or more stmts ++ | HsDo (XDo p) -- Type of the whole expression ++ (HsStmtContext Name) -- The parameterisation is unimportant ++ -- because in this context we never use ++ -- the PatGuard or ParStmt variant ++ (Located [ExprLStmt p]) -- "do":one or more stmts + + -- | Syntactic list: [a,b,c,...] + -- +@@ -476,6 +476,7 @@ data HsExpr p -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ -- ++ -- For details on above see note [Api annotations] in ApiAnnotation | RecordUpd - { rupd_expr :: LHsExpr p -@@ -833,7 +833,8 @@ pprBinds b = pprDeeper (ppr b) - ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc - ppr_lexpr e = ppr_expr (unLoc e) - --ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc -+ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) -+ => HsExpr p -> SDoc - ppr_expr (HsVar (L _ v)) = pprPrefixOcc v - ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) - ppr_expr (HsConLikeOut c) = pprPrefixOcc c -@@ -859,6 +860,7 @@ ppr_expr (OpApp e1 op _ e2) - = pp_prefixly - - where -+ should_print_infix :: HsExpr p -> Maybe SDoc - should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v) - should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c)) - should_print_infix (HsRecFld f) = Just (pprInfixOcc f) -@@ -891,6 +893,7 @@ ppr_expr (SectionL expr op) - - pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) - 4 (hsep [pp_expr, text "x_ )"]) -+ pp_infixly :: OutputableBndr a => a -> SDoc - pp_infixly v = (sep [pp_expr, pprInfixOcc v]) - - ppr_expr (SectionR op expr) -@@ -905,6 +908,7 @@ ppr_expr (SectionR op expr) - - pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) - 4 (pp_expr <> rparen) -+ pp_infixly :: OutputableBndr a => a -> SDoc - pp_infixly v = sep [pprInfixOcc v, pp_expr] - - ppr_expr (ExplicitTuple exprs boxity) -@@ -1992,7 +1996,7 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids - , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids - , text "later_ids=" <> ppr later_ids])] - --pprStmt (ApplicativeStmt args mb_join _) -+pprStmt (ApplicativeStmt args mb_join c) - = getPprStyle $ \style -> - if userStyle style - then pp_for_user -@@ -2010,6 +2014,7 @@ pprStmt (ApplicativeStmt args mb_join _) - flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args - flattenStmt stmt = [ppr stmt] - -+ flattenArg :: forall a r. (a, ApplicativeArg idL r) -> [SDoc] - flattenArg (_, ApplicativeArgOne pat expr isBody) - | isBody = -- See Note [Applicative BodyStmt] - [ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") -@@ -2421,7 +2426,7 @@ data HsMatchContext id -- Not an extensible tag + { rupd_ext :: XRecordUpd p +@@ -718,12 +719,10 @@ type instance XApp (GhcPass _) = NoExt + type instance XAppTypeE GhcPs = LHsWcType GhcPs + type instance XAppTypeE GhcRn = LHsWcType GhcRn + type instance XAppTypeE GhcTc = LHsWcType GhcRn +-type instance XAppTypeE GhcSe = LHsWcType GhcSe + + type instance XOpApp GhcPs = NoExt + type instance XOpApp GhcRn = Fixity + type instance XOpApp GhcTc = Fixity +-type instance XOpApp GhcSe = NoExt + + type instance XNegApp (GhcPass _) = NoExt + type instance XPar (GhcPass _) = NoExt +@@ -734,7 +733,6 @@ type instance XExplicitTuple (GhcPass _) = NoExt + type instance XExplicitSum GhcPs = NoExt + type instance XExplicitSum GhcRn = NoExt + type instance XExplicitSum GhcTc = [Type] +-type instance XExplicitSum GhcSe = NoExt + + type instance XCase (GhcPass _) = NoExt + type instance XIf (GhcPass _) = NoExt +@@ -742,39 +740,32 @@ type instance XIf (GhcPass _) = NoExt + type instance XMultiIf GhcPs = NoExt + type instance XMultiIf GhcRn = NoExt + type instance XMultiIf GhcTc = Type +-type instance XMultiIf GhcSe = NoExt + + type instance XLet (GhcPass _) = NoExt + + type instance XDo GhcPs = NoExt + type instance XDo GhcRn = NoExt + type instance XDo GhcTc = Type +-type instance XDo GhcSe = NoExt + + type instance XExplicitList GhcPs = NoExt + type instance XExplicitList GhcRn = NoExt + type instance XExplicitList GhcTc = Type +-type instance XExplicitList GhcSe = NoExt + + type instance XRecordCon GhcPs = NoExt + type instance XRecordCon GhcRn = NoExt + type instance XRecordCon GhcTc = RecordConTc +-type instance XRecordCon GhcSe = NoExt + + type instance XRecordUpd GhcPs = NoExt + type instance XRecordUpd GhcRn = NoExt + type instance XRecordUpd GhcTc = RecordUpdTc +-type instance XRecordUpd GhcSe = NoExt + + type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs) + type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn) + type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn) +-type instance XExprWithTySig GhcSe = (LHsSigWcType GhcSe) + + type instance XArithSeq GhcPs = NoExt + type instance XArithSeq GhcRn = NoExt + type instance XArithSeq GhcTc = PostTcExpr +-type instance XArithSeq GhcSe = NoExt + + type instance XSCC (GhcPass _) = NoExt + type instance XCoreAnn (GhcPass _) = NoExt +@@ -789,12 +780,10 @@ type instance XProc (GhcPass _) = NoExt + type instance XStatic GhcPs = NoExt + type instance XStatic GhcRn = NameSet + type instance XStatic GhcTc = NameSet +-type instance XStatic GhcSe = NoExt + + type instance XArrApp GhcPs = NoExt + type instance XArrApp GhcRn = NoExt + type instance XArrApp GhcTc = Type +-type instance XArrApp GhcSe = NoExt + + type instance XArrForm (GhcPass _) = NoExt + type instance XTick (GhcPass _) = NoExt +@@ -831,7 +820,6 @@ type instance XPresent (GhcPass _) = NoExt + type instance XMissing GhcPs = NoExt + type instance XMissing GhcRn = NoExt + type instance XMissing GhcTc = Type +-type instance XMissing GhcSe = NoExt + + type instance XXTupArg (GhcPass _) = NoExt + +@@ -1405,7 +1393,6 @@ data HsCmd id + type instance XCmdArrApp GhcPs = NoExt + type instance XCmdArrApp GhcRn = NoExt + type instance XCmdArrApp GhcTc = Type +-type instance XCmdArrApp GhcSe = NoExt + + type instance XCmdArrForm (GhcPass _) = NoExt + type instance XCmdApp (GhcPass _) = NoExt +@@ -1418,7 +1405,6 @@ type instance XCmdLet (GhcPass _) = NoExt + type instance XCmdDo GhcPs = NoExt + type instance XCmdDo GhcRn = NoExt + type instance XCmdDo GhcTc = Type +-type instance XCmdDo GhcSe = NoExt + + type instance XCmdWrap (GhcPass _) = NoExt + type instance XXCmd (GhcPass _) = NoExt +@@ -1450,7 +1436,6 @@ data CmdTopTc + type instance XCmdTop GhcPs = NoExt + type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] + type instance XCmdTop GhcTc = CmdTopTc +-type instance XCmdTop GhcSe = NoExt + + type instance XXCmdTop (GhcPass _) = NoExt + +@@ -1601,7 +1586,6 @@ data MatchGroupTc + type instance XMG GhcPs b = NoExt + type instance XMG GhcRn b = NoExt + type instance XMG GhcTc b = MatchGroupTc +-type instance XMG GhcSe b = NoExt + + type instance XXMatchGroup (GhcPass _) b = NoExt + +@@ -2001,34 +1985,28 @@ type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExt + type instance XBindStmt (GhcPass _) GhcPs b = NoExt + type instance XBindStmt (GhcPass _) GhcRn b = NoExt + type instance XBindStmt (GhcPass _) GhcTc b = Type +-type instance XBindStmt (GhcPass _) GhcSe b = NoExt + + type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExt + type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExt + type instance XApplicativeStmt (GhcPass _) GhcTc b = Type +-type instance XApplicativeStmt (GhcPass _) GhcSe b = NoExt + + type instance XBodyStmt (GhcPass _) GhcPs b = NoExt + type instance XBodyStmt (GhcPass _) GhcRn b = NoExt + type instance XBodyStmt (GhcPass _) GhcTc b = Type +-type instance XBodyStmt (GhcPass _) GhcSe b = NoExt + + type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExt + + type instance XParStmt (GhcPass _) GhcPs b = NoExt + type instance XParStmt (GhcPass _) GhcRn b = NoExt + type instance XParStmt (GhcPass _) GhcTc b = Type +-type instance XParStmt (GhcPass _) GhcSe b = NoExt + + type instance XTransStmt (GhcPass _) GhcPs b = NoExt + type instance XTransStmt (GhcPass _) GhcRn b = NoExt + type instance XTransStmt (GhcPass _) GhcTc b = Type +-type instance XTransStmt (GhcPass _) GhcSe b = NoExt + + type instance XRecStmt (GhcPass _) GhcPs b = NoExt + type instance XRecStmt (GhcPass _) GhcRn b = NoExt + type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc +-type instance XRecStmt (GhcPass _) GhcSe b = NoExt + + type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExt + +@@ -2727,7 +2705,7 @@ data HsMatchContext id -- Not an extensible tag | ThPatSplice -- ^A Template Haskell pattern splice | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration -- deriving Functor -+ deriving (Functor, Foldable, Traversable) +- deriving (Functor, Foldable, Traversable) ++ deriving Functor deriving instance (Data id) => Data (HsMatchContext id) instance OutputableBndr id => Outputable (HsMatchContext id) where -@@ -2437,6 +2442,7 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where +@@ -2744,7 +2722,6 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where ppr ThPatQuote = text "ThPatQuote" ppr PatSyn = text "PatSyn" -+ +- isPatSynCtxt :: HsMatchContext id -> Bool isPatSynCtxt ctxt = case ctxt of -@@ -2458,7 +2464,7 @@ data HsStmtContext id +@@ -2765,7 +2742,7 @@ data HsStmtContext id | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt -- deriving Functor -+ deriving (Functor, Foldable, Traversable) +- deriving (Functor, Foldable, Traversable) ++ deriving Functor deriving instance (Data id) => Data (HsStmtContext id) isListCompExpr :: HsStmtContext id -> Bool diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot -index bac8a5a183..2ef8dbc9a5 100644 +index 4b8c15dfc8..109e9814e5 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot -@@ -5,6 +5,7 @@ +@@ -5,7 +5,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ExistentialQuantification #-} -+{-# LANGUAGE TypeFamilies #-} -- needed to use OutputableBndrId +-{-# LANGUAGE TypeFamilies #-} -- needed to use OutputableBndrId ++{-# LANGUAGE TypeFamilies #-} module HsExpr where diff --git a/compiler/hsSyn/HsExprBin.hs b/compiler/hsSyn/HsExprBin.hs -new file mode 100644 -index 0000000000..1bf4b052f9 ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin.hs -@@ -0,0 +1,118 @@ -+module HsExprBin -+ ( getModuleSplicesPath -+ , whenSet -+ , HsSpliceData(..) -+ , nonEmptyHsSpliceData -+ , emptyHsSpliceData -+ , SpliceResult(..) -+ , recordSpliceResult -+ , lookupSpliceResult -+ , exprSE2PS -+ , declSE2PS -+ , exprPS2SE -+ , declPS2SE -+ , handleUnsupported -+ ) where -+ -+import Binary -+import GhcPrelude -+import HsDecls -+import HsExpr -+-- split into several modules because it was otherwise taking -+-- too long and too much memory to compile. -+import HsExprBin_Conversions -+import HsExprBin_Instances () -+import HsExtension -+import Module -+import Outputable -+import SrcLoc -+import TcRnTypes -+ -+import qualified Data.Map.Strict as Map -+import System.FilePath -+ -+-- * .hs-splice file contents -+ -+getModuleSplicesPath :: FilePath -> Module -> FilePath -+getModuleSplicesPath splicesDir m = splicesDir -+ toPath (moduleNameString (moduleName m)) <.> "hs-splice" -+ -+ where toPath = map (\c -> if c == '.' then '/' else c) -+ -+whenSet :: Monad m => Maybe a -> (a -> m b) -> m b -> m b -+whenSet m j n = maybe n j m -+ -+newtype HsSpliceData = HsSpliceData { hsSpliceMap :: Map.Map SrcSpan SpliceResult } -+ -+emptyHsSpliceData :: HsSpliceData -+emptyHsSpliceData = HsSpliceData Map.empty -+ -+nonEmptyHsSpliceData :: HsSpliceData -> Bool -+nonEmptyHsSpliceData = not . Map.null . hsSpliceMap -+ -+data SpliceResult -+ = SRExpr (LHsExpr GhcSe) -+ | SRDecls [LHsDecl GhcSe] -- TODO: change to HsGroup ? -+ -- TODO: add patterns and types? -+ -+instance Binary SpliceResult where -+ put_ bh r = case r of -+ SRExpr e -> putByte bh 0 >> put_ bh e -+ SRDecls ds -> putByte bh 1 >> put_ bh ds -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> SRExpr <$> get bh -+ 1 -> SRDecls <$> get bh -+ _ -> panic "Binary SpliceResult: unknown tag" -+ -+instance Binary HsSpliceData where -+ put_ bh (HsSpliceData m) = put_ bh (Map.toList m) -+ get bh = (\l -> HsSpliceData (Map.fromList l)) <$> get bh -+ -+recordSpliceResult :: SrcSpan -> SpliceResult -> HsSpliceData -> HsSpliceData -+recordSpliceResult loc res (HsSpliceData m) = HsSpliceData (Map.insert loc res m) -+ -+lookupSpliceResult :: SrcSpan -> HsSpliceData -> Maybe SpliceResult -+lookupSpliceResult loc (HsSpliceData m) = Map.lookup loc m -+ -+-- * High-level conversion interface -+ -+-- * Converting Se -> Ps -+ -+exprSE2PS :: LHsExpr GhcSe -> RnM (ConvResult (LHsExpr GhcPs)) -+exprSE2PS = runConv . cvLHsExpr -+ -+declSE2PS :: LHsDecl GhcSe -> RnM (ConvResult (LHsDecl GhcPs)) -+declSE2PS = runConv . cvLHsDecl -+ -+-- * Converting Ps -> Se -+ -+exprPS2SE :: LHsExpr GhcPs -> RnM (ConvResult (LHsExpr GhcSe)) -+exprPS2SE = runConv . cvLHsExpr -+ -+declPS2SE :: LHsDecl GhcPs -> RnM (ConvResult (LHsDecl GhcSe)) -+declPS2SE = runConv . cvLHsDecl -+ -+-- * Error reporting -+ -+-- | Panics with a nice error when we encounter an unsupported -+-- construct, or returns the actual result if the conversion -+-- succeeded. -+handleUnsupported -+ :: Located SDoc -- ^ TH expression that got evaluated -+ -> Maybe SDoc -- ^ code resulting from the evaluation of the 1st arg -+ -> ConvResult a -- ^ result of the conversion -+ -> RnM a -+handleUnsupported (L loc thDoc) resDoc convRes = case convRes of -+ ConvOK a -> pure a -+ ConvError (ConvUnsupported conName tyName subexprDoc) -> -+ pprPanic "HsExprBin.handleUnsupported" . vcat $ -+ [ text "GHC encountered a Haskell construct not supported by -{load, save}-splices:" -+ , nest 4 $ subexprDoc <> text (" - constructor " ++ conName ++ " of type " ++ tyName) -+ , text "while evaluating the following expression from " <> ppr loc <> text ":" -+ , nest 4 $ thDoc -+ ] ++ -+ maybe [] (\d -> [text "which resulted in:" , nest 4 d]) resDoc -+ -+ ConvError (ConvFailure errorStr) -> panic errorStr +deleted file mode 100644 +index 7967f934fb..0000000000 +--- a/compiler/hsSyn/HsExprBin.hs ++++ /dev/null +@@ -1,149 +0,0 @@ +-module HsExprBin +- ( getModuleSplicesPath +- , whenSet +- , HsSpliceData(..) +- , nonEmptyHsSpliceData +- , emptyHsSpliceData +- , SpliceResult(..) +- , recordSpliceResult +- , lookupSpliceResult +- , exprSE2PS +- , declSE2PS +- , exprPS2SE +- , declPS2SE +- , handleUnsupported +- ) where +- +-import Binary +-import GhcPrelude +-import HsDecls +-import HsExpr +-import HsExprBin_Conversions +-import qualified HsExprBin_ConversionSE2PS as SE2PS +-import qualified HsExprBin_ConversionPS2SE as PS2SE +-import HsExprBin_Instances () +-import HsExtension +-import Module +-import Outputable +-import SrcLoc +-import TcRnTypes +- +-import qualified Data.Map.Strict as Map +-import System.FilePath +- +-{- +- +-Note [Serialisable AST phase] +- +-There is an AST phase called GhcSe, where 'Se' stands for Serialisable. +-It is quite close to GhcPs, in that it mostly represents ASTs the same way, +-except for (syntax-level) types and names, which are represented in a way +-that is (binary) serialisation friendly. +- +-The motivation for this new phase is to be able to serialise ASTs of Haskell +-code. (No existing phase has this property.) One use case would be to save +-ASTs resulting from the evaluation of Template Haskell code and to reuse them +-later, in place of evaluating the Template Haskell code. More generally, +-it seems useful to be able to persist or load parsed ASTs, may it be for +-IDE-style interactions or plugins. +- +-The purpose of the HsExprBin* modules is to define: +-- conversions from GhcSe to GhcPs, and back, with the four functions exported +- by this module; +-- Binary instances for AST data types, only when "instantiated" at the GhcSe +- phase. +- +-The former is done in two modules: HsExprBin_ConversionSE2PS and +-HsExprBin_ConversionPS2SE. The latter in HsExprBin_Instances. +- +--} +- +--- * .hs-splice file contents +- +-getModuleSplicesPath :: FilePath -> Module -> FilePath +-getModuleSplicesPath splicesDir m = splicesDir +- toPath (moduleNameString (moduleName m)) <.> "hs-splice" +- +- where toPath = map (\c -> if c == '.' then '/' else c) +- +-whenSet :: Monad m => Maybe a -> (a -> m b) -> m b -> m b +-whenSet m j n = maybe n j m +- +-newtype HsSpliceData = HsSpliceData { hsSpliceMap :: Map.Map SrcSpan SpliceResult } +- +-emptyHsSpliceData :: HsSpliceData +-emptyHsSpliceData = HsSpliceData Map.empty +- +-nonEmptyHsSpliceData :: HsSpliceData -> Bool +-nonEmptyHsSpliceData = not . Map.null . hsSpliceMap +- +-data SpliceResult +- = SRExpr (LHsExpr GhcSe) +- | SRDecls [LHsDecl GhcSe] -- TODO: change to HsGroup ? +- -- TODO: add patterns and types? +- +-instance Binary SpliceResult where +- put_ bh r = case r of +- SRExpr e -> putByte bh 0 >> put_ bh e +- SRDecls ds -> putByte bh 1 >> put_ bh ds +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> SRExpr <$> get bh +- 1 -> SRDecls <$> get bh +- _ -> panic "Binary SpliceResult: unknown tag" +- +-instance Binary HsSpliceData where +- put_ bh (HsSpliceData m) = put_ bh (Map.toList m) +- get bh = (\l -> HsSpliceData (Map.fromList l)) <$> get bh +- +-recordSpliceResult :: SrcSpan -> SpliceResult -> HsSpliceData -> HsSpliceData +-recordSpliceResult loc res (HsSpliceData m) = HsSpliceData (Map.insert loc res m) +- +-lookupSpliceResult :: SrcSpan -> HsSpliceData -> Maybe SpliceResult +-lookupSpliceResult loc (HsSpliceData m) = Map.lookup loc m +- +--- * High-level conversion interface +- +--- Converting Se -> Ps +- +--- | Convert a serialisable expression AST to a parsed expression AST +-exprSE2PS :: LHsExpr GhcSe -> RnM (ConvResult (LHsExpr GhcPs)) +-exprSE2PS = runConv . SE2PS.cvLHsExpr +- +--- | Convert a serialisable declaration AST to a parsed declaration AST +-declSE2PS :: LHsDecl GhcSe -> RnM (ConvResult (LHsDecl GhcPs)) +-declSE2PS = runConv . SE2PS.cvLHsDecl +- +--- Converting Ps -> Se +- +--- | Convert a parsed expression AST to a serialisable expression AST +-exprPS2SE :: LHsExpr GhcPs -> RnM (ConvResult (LHsExpr GhcSe)) +-exprPS2SE = runConv . PS2SE.cvLHsExpr +- +--- | Convert a parsed declaration AST to a serialisable expression AST +-declPS2SE :: LHsDecl GhcPs -> RnM (ConvResult (LHsDecl GhcSe)) +-declPS2SE = runConv . PS2SE.cvLHsDecl +- +--- * Error reporting +- +--- | Panics with a nice error when we encounter an unsupported +--- construct, or returns the actual result if the conversion +--- succeeded. +-handleUnsupported +- :: Located SDoc -- ^ TH expression that got evaluated +- -> Maybe SDoc -- ^ code resulting from the evaluation of the 1st arg +- -> ConvResult a -- ^ result of the conversion +- -> RnM a +-handleUnsupported (L loc thDoc) resDoc convRes = case convRes of +- ConvOK a -> pure a +- ConvError (ConvUnsupported conName tyName subexprDoc) -> +- pprPanic "HsExprBin.handleUnsupported" . vcat $ +- [ text "GHC encountered a Haskell construct not supported by -{load, save}-splices:" +- , nest 4 $ subexprDoc <> text (" - constructor " ++ conName ++ " of type " ++ tyName) +- , text "while evaluating the following expression from " <> ppr loc <> text ":" +- , nest 4 $ thDoc +- ] ++ +- maybe [] (\d -> [text "which resulted in:" , nest 4 d]) resDoc +- +- ConvError (ConvFailure errorStr) -> panic errorStr diff --git a/compiler/hsSyn/HsExprBin.hs-boot b/compiler/hsSyn/HsExprBin.hs-boot -new file mode 100644 -index 0000000000..964847e097 ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin.hs-boot -@@ -0,0 +1,4 @@ -+module HsExprBin where -+ -+data HsSpliceData -+emptyHsSpliceData :: HsSpliceData +deleted file mode 100644 +index 964847e097..0000000000 +--- a/compiler/hsSyn/HsExprBin.hs-boot ++++ /dev/null +@@ -1,4 +0,0 @@ +-module HsExprBin where +- +-data HsSpliceData +-emptyHsSpliceData :: HsSpliceData \ No newline at end of file -diff --git a/compiler/hsSyn/HsExprBin_Conversions.hs b/compiler/hsSyn/HsExprBin_Conversions.hs -new file mode 100644 -index 0000000000..d54bd2a7d3 ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin_Conversions.hs -@@ -0,0 +1,977 @@ -+{-# LANGUAGE ConstraintKinds, DeriveFunctor #-} -+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} -+{-# LANGUAGE MultiParamTypeClasses #-} -+{-# LANGUAGE TypeFamilies, TypeSynonymInstances #-} -+module HsExprBin_Conversions where -+ -+import Control.Applicative -+import Control.Monad -+import Control.Monad.IO.Class -+import Data.Char (isDigit) -+import Data.List (intercalate) -+import Data.Maybe -+import Data.Traversable -+ -+import Bag (mapBagM) -+import BasicTypes (Fixity) -+import Class -+import ConLike -+import CoreSyn ( Tickish(..) ) -+import DynFlags -+import FastString -+import GhcPrelude -+import HsBinds -+import HsDecls -+import HsExpr -+import HsExtension -+import HsLit -+import HsPat -+import HsTypes -+import Module -+import Name -+import Outputable -+import PackageConfig -+import Packages -+import PlaceHolder -+import RdrName -+import SeName -+import SrcLoc -+import TcRnTypes -+import IfaceType -+import ToIface (toIfaceType) -+import TcEvidence (HsWrapper) -+import TyCoRep (Type(..), TyLit(..), Kind, Coercion) -+ -+import qualified NameSet as NameSet -+ -+data ConvError -+ = ConvUnsupported String String SDoc -+ -- constructor name, type name, text rendering -+ -- of the unsupported subexpression -+ | ConvFailure String -+ -+data ConvResult a -+ = ConvError ConvError -+ | ConvOK a -+ deriving Functor -+-- * Conversion utilities -+ -+newtype Conv a = Conv { runConv :: RnM (ConvResult a) } -+ -+instance Functor Conv where -+ fmap f (Conv k) = Conv (fmap (fmap f) k) -+ -+instance Applicative Conv where -+ pure = Conv . return . ConvOK -+ (<*>) = ap -+ -+instance Monad Conv where -+ return = pure -+ -+ Conv mx >>= f = Conv $ mx >>= \cvx -> case cvx of -+ ConvOK x -> runConv (f x) -+ ConvError e -> pure (ConvError e) -+ -+unsupported :: String -- ^ constructor name -+ -> String -- ^ type name -+ -> SDoc -- ^ textual rendering of the unsupported subexpression -+ -> Conv a -+unsupported con ty subexpr = Conv $ -+ pure (ConvError $ ConvUnsupported con ty subexpr) -+ -+badInput :: String -> Conv a -+badInput str = Conv $ pure (ConvError $ ConvFailure str) -+ -+liftRn :: RnM a -> Conv a -+liftRn = Conv . fmap ConvOK -+ -+class ConvertType t u where -+ convertType :: t -> Conv u -+ -+class ConvertName a b where -+ convertName :: a -> Conv b -+ -+instance ConvertName a b => ConvertName [a] [b] where -+ convertName = traverse convertName -+ -+instance ConvertName a b => ConvertName (Either e a) (Either e b) where -+ convertName = traverse convertName -+ -+instance ConvertName a b => ConvertName (HsMatchContext a) (HsMatchContext b) where -+ convertName = traverse convertName -+ -+instance ConvertName a b => ConvertName (HsStmtContext a) (HsStmtContext b) where -+ convertName = traverse convertName -+ -+instance ConvertName a b => ConvertName (Maybe a) (Maybe b) where -+ convertName = traverse convertName -+ -+instance ConvertType Type IfaceType where -+ convertType = pure . toIfaceType -+ -+instance ConvertType IfaceType Type where -+ convertType (IfaceLitTy n) = pure $ LitTy (go n) -+ where go (IfaceNumTyLit a) = NumTyLit a -+ go (IfaceStrTyLit a) = StrTyLit a -+ convertType e@(IfaceFreeTyVar {}) = unsupported "IfaceFreeTyVar" "IfaceType" (ppr e) -+ convertType e@(IfaceTyVar {}) = unsupported "IfaceTyVar" "IfaceType" (ppr e) -+ convertType e@(IfaceAppTy {}) = unsupported "IfaceAppTy" "IfaceType" (ppr e) -+ convertType e@(IfaceFunTy {}) = unsupported "IfaceFunTy" "IfaceType" (ppr e) -+ convertType e@(IfaceDFunTy {}) = unsupported "IfaceDFunTy" "IfaceType" (ppr e) -+ convertType e@(IfaceForAllTy {}) = unsupported "IfaceForAllTy" "IfaceType" (ppr e) -+ convertType e@(IfaceTyConApp {}) = unsupported "IfaceTyConApp" "IfaceType" (ppr e) -+ convertType e@(IfaceCastTy {}) = unsupported "IfaceCastTy" "IfaceType" (ppr e) -+ convertType e@(IfaceCoercionTy {}) = unsupported "IfaceCoercion" "IfaceType" (ppr e) -+ convertType e@(IfaceTupleTy {}) = unsupported "IfaceTupleTy" "IfaceType" (ppr e) -+ -+ -+instance ConvertName RdrName SeName where -+ convertName = pure . mkSeName -+ -+instance ConvertName SeName RdrName where -+ convertName (SeName n) = case n of -+ Orig mod occn -> do -+ -- TODO: introduce some caching here, to avoid doing the -+ -- searchPackageId dance too often. -+ -+ {- liftIO . putStrLn $ -+ "/!!!\\ Processing name: module=" ++ moduleNameString (moduleName mod) ++ -+ ", occname = " ++ occNameString occn -} -+ currentMod <- liftRn getModule -+ {- liftIO . putStrLn $ -+ "Current module (" ++ moduleNameString (moduleName currentMod) ++ ") is in: " ++ -+ unitIdString (moduleUnitId currentMod) -} -+ -+ if samePackages currentMod mod -+ then let newMod = mod { moduleUnitId = moduleUnitId currentMod } in -+ -- liftIO $ putStrLn ("using the current module's unit id for name coming from: " ++ moduleNameString (moduleName mod)) >> -+ pure (Orig newMod occn) -+ else do mnewmod <- liftRn (findEquivalentModule mod) -+ case mnewmod of -+ Nothing -> {- liftIO (putStrLn "keeping old name") -+ >> -} pure (Orig mod occn) -+ Just mod' -> {- liftIO (putStrLn "using new unitid!") -+ >> -} pure (Orig mod' occn) -+ -+ _ -> pure n -+ -+ where samePackages mod1 mod2 = fromMaybe False $ do -- maybe monad -+ let str1 = unitIdString (moduleUnitId mod1) -+ str2 = unitIdString (moduleUnitId mod2) -+ (pkg1, ver1, _mhash1) <- parseUnitId' str1 -+ (pkg2, ver2, _mhash2) <- parseUnitId' str2 -+ return (pkg1 == pkg2 && ver1 == ver2) -+ -+instance ConvertName Name SeName where -+ convertName n = pure $ mkSeName (nameRdrName n) -+ -+instance ConvertName SeName Name where -+ convertName (SeName n) = case isExact_maybe n of -+ Just a -> pure a -+ _ -> badInput "convertName :: SeName -> Name: non exact RdrName in SeName" -+ -+instance ConvertName a b => ConvertName (Located a) (Located b) where -+ convertName = traverse convertName -+ -+type TypeConstraints p q = -+ ( ConvertType (LitType p) (LitType q) -+ , ConvertName (IdP p) (IdP q) -+ , ConvertName (DoName p) (DoName q) -+ , ConvertName (NameOrRdrName (IdP p)) (NameOrRdrName (IdP q)) -+ , ConvertName (RdrOrSeName p) (RdrOrSeName q) -+ , PostRn p NameSet.NameSet ~ PostRn q NameSet.NameSet -+ , PostRn p (Located Name) ~ PostRn q (Located Name) -+ , PostRn p [Name] ~ PostRn q [Name] -+ , PostRn p Bool ~ PostRn q Bool -+ , PostRn p (IdP p) ~ PostRn q (IdP q) -+ , PostRn q Fixity ~ PostRn p Fixity -+ , PostTc p Kind ~ PostTc q Kind -+ , PostTc p (IdP p) ~ PostTc q (IdP q) -+ , PostTc p [Type] ~ PostTc q [Type] -+ , PostTc p HsWrapper ~ PostTc q HsWrapper -+ , PostTc p ConLike ~ PostTc q ConLike -+ , PostTc p [ConLike] ~ PostTc q [ConLike] -+ , PostTc q Coercion ~ PostTc p Coercion -+ , ConvertIdX p q -+ , OutputableBndrId p -+ , SourceTextX p -+ ) -+ -+-- * Actual conversion implementation -+ -+-- declarations -+ -+cvLHsDecl :: TypeConstraints p q => LHsDecl p -> Conv (LHsDecl q) -+cvLHsDecl = traverse cvHsDecl -+ -+cvHsDecl :: TypeConstraints p q => HsDecl p -> Conv (HsDecl q) -+cvHsDecl (TyClD a) = TyClD <$> cvTyClDecl a -+cvHsDecl (InstD a) = InstD <$> cvInstDecl a -+cvHsDecl (DerivD a) = DerivD <$> cvDerivDecl a -+cvHsDecl (ValD a) = ValD <$> cvHsBindLR a -+cvHsDecl (SigD a) = SigD <$> cvSig a -+cvHsDecl (DefD a) = DefD <$> cvDefaultDecl a -+cvHsDecl (ForD a) = ForD <$> cvForeignDecl a -+cvHsDecl (WarningD a) = WarningD <$> cvWarningDecls a -+cvHsDecl (RoleAnnotD a) = RoleAnnotD <$> cvRoleAnnotDecl a -+cvHsDecl (AnnD a) = AnnD <$> cvAnnDecl a -+cvHsDecl (RuleD a) = RuleD <$> cvRuleDecls a -+cvHsDecl (SpliceD a) = SpliceD <$> cvSpliceDecl a -+cvHsDecl (DocD a) = pure (DocD a) -+cvHsDecl (VectD a) = VectD <$> cvVectDecl a -+ -+cvAnnDecl :: TypeConstraints p q => AnnDecl p -> Conv (AnnDecl q) -+cvAnnDecl (HsAnnotation a b c) = HsAnnotation a <$> cvAnnProvenance b <*> cvLHsExpr c -+ -+cvInstDecl :: TypeConstraints p q => InstDecl p -> Conv (InstDecl q) -+cvInstDecl (ClsInstD a) = ClsInstD <$> cvClsInstDecl a -+cvInstDecl (DataFamInstD a) = DataFamInstD <$> cvDataFamInstDecl a -+cvInstDecl (TyFamInstD a) = TyFamInstD <$> cvTyFamInstDecl a -+ -+cvClsInstDecl :: TypeConstraints p q => ClsInstDecl p -> Conv (ClsInstDecl q) -+cvClsInstDecl (ClsInstDecl a b c d e f ) = -+ ClsInstDecl -+ <$> cvHsImplicitBndrs (traverse cvType) a -+ <*> mapBagM (traverse cvHsBindLR) b -+ <*> traverse (traverse cvSig) c -+ <*> traverse (traverse cvTyFamInstDecl) d -+ <*> traverse (traverse cvDataFamInstDecl) e -+ <*> pure f -+ -+cvDerivDecl :: TypeConstraints p q => DerivDecl p -> Conv (DerivDecl q) -+cvDerivDecl (DerivDecl a b c) = -+ DerivDecl <$> cvHsImplicitBndrs (traverse cvType) a <*> pure b <*> pure c -+ -+cvTyClDecl :: TypeConstraints p q => TyClDecl p -> Conv (TyClDecl q) -+cvTyClDecl (FamDecl a) = FamDecl <$> cvFamilyDecl a -+cvTyClDecl (SynDecl a b c d e) = -+ SynDecl -+ <$> convertName a -+ <*> cvLHsQTyVars b <*> pure c -+ <*> traverse cvType d <*> pure e -+cvTyClDecl (DataDecl a b c d e f) = -+ DataDecl -+ <$> convertName a -+ <*> cvLHsQTyVars b <*> pure c -+ <*> cvHsDataDefn d <*> pure e <*> pure f -+cvTyClDecl (ClassDecl a b c d e f g h i j k) = -+ ClassDecl -+ <$> traverse (traverse (traverse cvType)) a -+ <*> convertName b -+ <*> cvLHsQTyVars c -+ <*> pure d -+ <*> traverse (traverse cvFunDep) e -+ <*> traverse (traverse cvSig) f -+ <*> mapBagM (traverse cvHsBindLR) g -+ <*> traverse (traverse cvFamilyDecl) h -+ <*> traverse (traverse $ cvFamEqn cvLHsQTyVars (traverse cvType)) i -+ <*> pure j <*> pure k -+ -+cvRoleAnnotDecl -+ :: TypeConstraints p q => RoleAnnotDecl p -> Conv (RoleAnnotDecl q) -+cvRoleAnnotDecl (RoleAnnotDecl a b) = RoleAnnotDecl <$> convertName a <*> pure b -+ -+cvRuleDecls :: TypeConstraints p q => RuleDecls p -> Conv (RuleDecls q) -+cvRuleDecls (HsRules a b) = HsRules a <$> traverse (traverse cvRuleDecl) b -+ -+cvRuleDecl :: TypeConstraints p q => RuleDecl p -> Conv (RuleDecl q) -+cvRuleDecl (HsRule a b c d e f g) = -+ HsRule a b <$> traverse (traverse cvRuleBndr) c <*> cvLHsExpr d -+ <*> pure e <*> cvLHsExpr f <*> pure g -+ -+cvSpliceDecl :: TypeConstraints p q => SpliceDecl p -> Conv (SpliceDecl q) -+cvSpliceDecl (SpliceDecl a b) = SpliceDecl <$> traverse cvHsSplice a <*> pure b -+ -+cvHsSplice :: TypeConstraints p q => HsSplice p -> Conv (HsSplice q) -+cvHsSplice (HsTypedSplice a b c) = HsTypedSplice a <$> convertName b <*> cvLHsExpr c -+cvHsSplice (HsUntypedSplice a b c) = HsUntypedSplice a <$> convertName b <*> cvLHsExpr c -+cvHsSplice (HsQuasiQuote a b c d) = HsQuasiQuote <$> convertName a <*> convertName b <*> pure c <*> pure d -+cvHsSplice e@(HsSpliced {}) = unsupported "HsSpliced" "HsSplice" (ppr e) -+ -+cvRuleBndr :: TypeConstraints p q => RuleBndr p -> Conv (RuleBndr q) -+cvRuleBndr (RuleBndr a) = RuleBndr <$> convertName a -+cvRuleBndr (RuleBndrSig a b) = RuleBndrSig <$> convertName a <*> cvHsSigWcType b -+ -+cvFamEqn -+ :: TypeConstraints p q -+ => (a -> Conv c) -+ -> (b -> Conv d) -+ -> FamEqn p a b -+ -> Conv (FamEqn q c d) -+cvFamEqn goPats goRhs (FamEqn a b c d) = -+ FamEqn <$> convertName a <*> goPats b <*> pure c <*> goRhs d -+ -+cvFamilyDecl :: TypeConstraints p q => FamilyDecl p -> Conv (FamilyDecl q) -+cvFamilyDecl (FamilyDecl a b c d e f) = -+ FamilyDecl -+ <$> cvFamilyInfo a <*> convertName b -+ <*> cvLHsQTyVars c <*> pure d -+ <*> traverse cvFamilyResultSig e -+ <*> traverse (traverse cvInjectivityAnn) f -+ -+cvAnnProvenance :: ConvertName a b => AnnProvenance a -> Conv (AnnProvenance b) -+cvAnnProvenance (ValueAnnProvenance a) = ValueAnnProvenance <$> convertName a -+cvAnnProvenance (TypeAnnProvenance a) = TypeAnnProvenance <$> convertName a -+cvAnnProvenance ModuleAnnProvenance = pure ModuleAnnProvenance -+ -+cvInjectivityAnn -+ :: TypeConstraints p q => InjectivityAnn p -> Conv (InjectivityAnn q) -+cvInjectivityAnn (InjectivityAnn a b) = -+ InjectivityAnn <$> convertName a <*> convertName b -+ -+cvFamilyResultSig -+ :: TypeConstraints p q => FamilyResultSig p -> Conv (FamilyResultSig q) -+cvFamilyResultSig NoSig = pure NoSig -+cvFamilyResultSig (KindSig a) = KindSig <$> traverse cvType a -+cvFamilyResultSig (TyVarSig a) = TyVarSig <$> traverse cvHsTyVarBndr a -+ -+cvFamilyInfo :: TypeConstraints p q => FamilyInfo p -> Conv (FamilyInfo q) -+cvFamilyInfo DataFamily = pure DataFamily -+cvFamilyInfo OpenTypeFamily = pure OpenTypeFamily -+cvFamilyInfo (ClosedTypeFamily a) = -+ ClosedTypeFamily <$> traverse (traverse (traverse (cvFamInstEqn (traverse cvType)))) a -+ -+cvFamInstEqn -+ :: TypeConstraints p q -+ => (a -> Conv b) -+ -> FamInstEqn p a -+ -> Conv (FamInstEqn q b) -+cvFamInstEqn f = cvHsImplicitBndrs (cvFamEqn (traverse (traverse cvType)) f) -+ -+cvFunDep :: ConvertName a b => FunDep a -> Conv (FunDep b) -+cvFunDep (xs, ys) = (,) <$> convertName xs <*> convertName ys -+ -+cvLHsQTyVars :: TypeConstraints p q => LHsQTyVars p -> Conv (LHsQTyVars q) -+cvLHsQTyVars (HsQTvs a b c) = HsQTvs a <$> traverse (traverse cvHsTyVarBndr) b <*> pure c -+ -+cvForeignDecl :: TypeConstraints p q => ForeignDecl p -> Conv (ForeignDecl q) -+cvForeignDecl (ForeignImport a b c d) = -+ ForeignImport -+ <$> convertName a -+ <*> cvHsImplicitBndrs (traverse cvType) b -+ <*> pure c <*> pure d -+cvForeignDecl (ForeignExport a b c d) = -+ ForeignExport -+ <$> convertName a -+ <*> cvHsImplicitBndrs (traverse cvType) b -+ <*> pure c <*> pure d -+ -+cvDefaultDecl :: TypeConstraints p q => DefaultDecl p -> Conv (DefaultDecl q) -+cvDefaultDecl (DefaultDecl a) = DefaultDecl <$> traverse (traverse cvType) a -+ -+cvTyFamInstDecl -+ :: TypeConstraints p q => TyFamInstDecl p -> Conv (TyFamInstDecl q) -+cvTyFamInstDecl (TyFamInstDecl d) = -+ TyFamInstDecl <$> cvFamInstEqn (traverse cvType) d -+ -+cvDataFamInstDecl -+ :: TypeConstraints p q => DataFamInstDecl p -> Conv (DataFamInstDecl q) -+cvDataFamInstDecl (DataFamInstDecl d) = -+ DataFamInstDecl <$> cvFamInstEqn cvHsDataDefn d -+ -+cvHsDataDefn :: TypeConstraints p q => HsDataDefn p -> Conv (HsDataDefn q) -+cvHsDataDefn (HsDataDefn a b c d e f) = -+ HsDataDefn a -+ <$> traverse (traverse (traverse cvType)) b <*> pure c -+ <*> traverse (traverse cvType) d -+ <*> traverse (traverse cvConDecl) e <*> cvHsDeriving f -+ -+cvConDecl :: TypeConstraints p q => ConDecl p -> Conv (ConDecl q) -+cvConDecl (ConDeclGADT a b c) = -+ ConDeclGADT -+ <$> convertName a -+ <*> cvHsImplicitBndrs (traverse cvType) b -+ <*> pure c -+cvConDecl (ConDeclH98 a b c d e) = -+ ConDeclH98 -+ <$> convertName a -+ <*> traverse cvLHsQTyVars b -+ <*> traverse (traverse (traverse (traverse cvType))) c -+ <*> cvHsConDeclDetails d -+ <*> pure e -+ -+cvHsDeriving :: TypeConstraints p q => HsDeriving p -> Conv (HsDeriving q) -+cvHsDeriving = traverse (traverse (traverse cvHsDerivingClause)) -+ -+cvHsDerivingClause -+ :: TypeConstraints p q => HsDerivingClause p -> Conv (HsDerivingClause q) -+cvHsDerivingClause (HsDerivingClause a b) = -+ HsDerivingClause a -+ <$> traverse (traverse (cvHsImplicitBndrs (traverse cvType))) b -+ -+cvHsConDeclDetails -+ :: TypeConstraints p q => HsConDeclDetails p -> Conv (HsConDeclDetails q) -+cvHsConDeclDetails = -+ cvHsConDetails (traverse cvType) -+ (traverse (traverse (traverse cvConDeclField))) -+ -+cvHsConDetails -+ :: (a -> Conv c) -> (b -> Conv d) -> HsConDetails a b -> Conv (HsConDetails c d) -+cvHsConDetails f _ (PrefixCon a) = PrefixCon <$> traverse f a -+cvHsConDetails _ g (RecCon a) = RecCon <$> g a -+cvHsConDetails f _ (InfixCon a b) = InfixCon <$> f a <*> f b -+ -+cvConDeclField :: TypeConstraints p q => ConDeclField p -> Conv (ConDeclField q) -+cvConDeclField (ConDeclField a b c) = -+ ConDeclField <$> traverse (traverse cvFieldOcc) a <*> traverse cvType b -+ <*> pure c -+ -+cvWarningDecls :: TypeConstraints p q => WarnDecls p -> Conv (WarnDecls q) -+cvWarningDecls (Warnings a b) = -+ Warnings a <$> traverse (traverse cvWarningDecl) b -+ -+cvWarningDecl :: TypeConstraints p q => WarnDecl p -> Conv (WarnDecl q) -+cvWarningDecl (Warning a b) = Warning <$> convertName a <*> pure b -+ -+-- expressions -+ -+cvLHsExpr -+ :: TypeConstraints p q => LHsExpr p -> Conv (LHsExpr q) -+cvLHsExpr = traverse cvHsExpr -+ -+cvHsExpr -+ :: TypeConstraints p q => HsExpr p -> Conv (HsExpr q) -+cvHsExpr e = case e of -+ HsVar a -> HsVar <$> convertName a -+ HsUnboundVar a -> pure (HsUnboundVar a) -+ HsConLikeOut a -> pure (HsConLikeOut a) -+ HsRecFld a -> HsRecFld <$> cvAFieldOcc a -+ HsOverLabel a b -> HsOverLabel <$> convertName a <*> pure b -+ HsIPVar a -> pure (HsIPVar a) -+ HsOverLit a -> HsOverLit <$> cvOverLit a -+ HsLit a -> HsLit <$> cvLit a -+ HsLam a -> HsLam <$> cvMatchGroup cvLHsExpr a -+ HsLamCase a -> HsLamCase <$> cvMatchGroup cvLHsExpr a -+ HsApp a b -> HsApp <$> cvLHsExpr a <*> cvLHsExpr b -+ HsAppType a b -> HsAppType <$> cvLHsExpr a <*> cvLHsWcType b -+ OpApp a b c d -> OpApp <$> cvLHsExpr a <*> cvLHsExpr b -+ <*> pure c <*> cvLHsExpr d -+ NegApp a b -> NegApp <$> cvLHsExpr a <*> cvSyntaxExpr b -+ HsPar a -> HsPar <$> cvLHsExpr a -+ SectionL a b -> SectionL <$> cvLHsExpr a <*> cvLHsExpr b -+ SectionR a b -> SectionR <$> cvLHsExpr a <*> cvLHsExpr b -+ ExplicitTuple a b -> ExplicitTuple <$> traverse (traverse cvHsTupArg) a <*> pure b -+ ExplicitSum a b c d -> ExplicitSum a b <$> cvLHsExpr c <*> pure d -+ ExplicitList a b c -> ExplicitList a <$> traverse cvSyntaxExpr b <*> traverse cvLHsExpr c -+ HsCase a b -> HsCase <$> cvLHsExpr a <*> cvMatchGroup cvLHsExpr b -+ HsIf a b c d -> HsIf <$> traverse cvSyntaxExpr a -+ <*> cvLHsExpr b <*> cvLHsExpr c <*> cvLHsExpr d -+ HsMultiIf a b -> HsMultiIf a <$> traverse (traverse (cvGRHS cvLHsExpr)) b -+ HsLet a b -> HsLet <$> traverse cvHsLocalBinds a <*> cvLHsExpr b -+ HsDo a b c -> HsDo -+ <$> convertName a <*> traverse (traverse (traverse (cvStmtLR cvLHsExpr))) b -+ <*> pure c -+ RecordCon a b c d -> RecordCon -+ <$> convertName a <*> pure b <*> pure c <*> cvRecordBinds d -+ RecordUpd a b c d e f -> RecordUpd -+ <$> cvLHsExpr a -+ <*> traverse (traverse cvHsRecUpdField) b -+ <*> pure c <*> pure d <*> pure e <*> pure f -+ ExprWithTySig a b -> ExprWithTySig <$> cvLHsExpr a <*> cvHsSigWcType b -+ ArithSeq a b c -> ArithSeq a <$> traverse cvSyntaxExpr b <*> cvArithSeqInfo c -+ HsSCC a b c -> HsSCC a b <$> cvLHsExpr c -+ HsCoreAnn a b c -> HsCoreAnn a b <$> cvLHsExpr c -+ HsStatic a b -> HsStatic a <$> cvLHsExpr b -+ EWildPat -> pure EWildPat -+ EAsPat a b -> EAsPat <$> convertName a <*> cvLHsExpr b -+ EViewPat a b -> EViewPat <$> cvLHsExpr a <*> cvLHsExpr b -+ ELazyPat a -> ELazyPat <$> cvLHsExpr a -+ HsProc a b -> HsProc <$> traverse cvPat a <*> traverse cvHsCmdTop b -+ HsBinTick a b c -> HsBinTick a b <$> cvLHsExpr c -+ HsTickPragma a b c d -> HsTickPragma a b c <$> cvLHsExpr d -+ HsSpliceE a -> HsSpliceE <$> cvHsSplice a -+ HsBracket a -> HsBracket <$> cvHsBracket a -+ HsTick a b -> HsTick <$> cvTickish a <*> cvLHsExpr b -+ e@(ExplicitPArr {}) -> unsupported "ExplicitPArr" "HsExpr" (ppr e) -+ e@(PArrSeq {}) -> unsupported "PArrSeq" "HsExpr" (ppr e) -+ e@(HsArrApp {}) -> unsupported "HsArrApp" "HsExpr" (ppr e) -+ e@(HsArrForm {}) -> unsupported "HsArrForm" "HsExpr" (ppr e) -+ e@(HsAppTypeOut {}) -> unsupported "HsAppTypeOut" "HsExpr" (ppr e) -+ e@(ExprWithTySigOut {}) -> unsupported "ExprWithTySigOut" "HsExpr" (ppr e) -+ e@(HsWrap {}) -> unsupported "HsWrap" "HsExpr" (ppr e) -+ e@(HsRnBracketOut {}) -> unsupported "HsRnBracketOut" "HsExpr" (ppr e) -+ e@(HsTcBracketOut {}) -> unsupported "HsTcBracketOut" "HsExpr" (ppr e) -+ -+cvHsBracket :: TypeConstraints p q => HsBracket p -> Conv (HsBracket q) -+cvHsBracket (ExpBr a) = ExpBr <$> cvLHsExpr a -+cvHsBracket (PatBr a) = PatBr <$> traverse cvPat a -+cvHsBracket (DecBrL a) = DecBrL <$> traverse (traverse cvHsDecl) a -+cvHsBracket (DecBrG a) = DecBrG <$> cvHsGroup a -+cvHsBracket (TypBr a) = TypBr <$> traverse cvType a -+cvHsBracket (VarBr a b) = VarBr a <$> convertName b -+cvHsBracket (TExpBr a) = TExpBr <$> cvLHsExpr a -+ -+cvTickish :: ConvertName a b => Tickish a -> Conv (Tickish b) -+cvTickish (ProfNote a b c) = pure (ProfNote a b c) -+cvTickish (HpcTick a b) = pure (HpcTick a b) -+cvTickish (Breakpoint a b) = Breakpoint a <$> convertName b -+cvTickish (SourceNote a b) = pure (SourceNote a b) -+ -+cvHsGroup :: TypeConstraints p q => HsGroup p -> Conv (HsGroup q) -+cvHsGroup (HsGroup a b c d e f g h i j k l) = HsGroup -+ <$> cvHsValBindsLR a <*> traverse (traverse cvSpliceDecl) b -+ <*> traverse cvTyClGroup c -+ <*> traverse (traverse cvDerivDecl) d -+ <*> traverse (traverse cvFixitySig) e -+ <*> traverse (traverse cvDefaultDecl) f -+ <*> traverse (traverse cvForeignDecl) g -+ <*> traverse (traverse cvWarningDecls) h -+ <*> traverse (traverse cvAnnDecl) i -+ <*> traverse (traverse cvRuleDecls) j -+ <*> traverse (traverse cvVectDecl) k -+ <*> pure l -+ -+cvVectDecl :: TypeConstraints p q => VectDecl p -> Conv (VectDecl q) -+cvVectDecl (HsVect a b c) = HsVect a <$> convertName b <*> cvLHsExpr c -+cvVectDecl (HsNoVect a b) = HsNoVect a <$> convertName b -+cvVectDecl (HsVectTypeIn a b c d) = HsVectTypeIn a b -+ <$> convertName c <*> traverse convertName d -+cvVectDecl (HsVectClassIn a b) = HsVectClassIn a <$> convertName b -+cvVectDecl (HsVectInstIn a) = HsVectInstIn -+ <$> cvHsImplicitBndrs (traverse cvType) a -+cvVectDecl e@(HsVectTypeOut {}) = unsupported "HsVectTypeOut" "VectDecl" (ppr e) -+cvVectDecl e@(HsVectClassOut {}) = unsupported "HsVectClassOut" "VectDecl" (ppr e) -+cvVectDecl e@(HsVectInstOut {}) = unsupported "HsVectInstOut" "VectDecl" (ppr e) -+ -+ -+cvTyClGroup :: TypeConstraints p q => TyClGroup p -> Conv (TyClGroup q) -+cvTyClGroup (TyClGroup a b c) = TyClGroup -+ <$> traverse (traverse cvTyClDecl) a -+ <*> traverse (traverse cvRoleAnnotDecl) b -+ <*> traverse (traverse cvInstDecl) c -+ -+cvHsCmdTop :: TypeConstraints p q => HsCmdTop p -> Conv (HsCmdTop q) -+cvHsCmdTop (HsCmdTop a b c d) = HsCmdTop -+ <$> traverse cvHsCmd a <*> pure b <*> pure c -+ <*> traverse (traverse cvHsExpr) d -+ -+cvHsCmd :: TypeConstraints p q => HsCmd p -> Conv (HsCmd q) -+cvHsCmd (HsCmdArrApp a b c d e) = HsCmdArrApp -+ <$> cvLHsExpr a <*> cvLHsExpr b <*> pure c <*> pure d <*> pure e -+cvHsCmd (HsCmdArrForm a b c d) = HsCmdArrForm -+ <$> cvLHsExpr a <*> pure b <*> pure c -+ <*> traverse (traverse cvHsCmdTop) d -+cvHsCmd (HsCmdApp a b) = HsCmdApp <$> traverse cvHsCmd a <*> cvLHsExpr b -+cvHsCmd (HsCmdLam a) = HsCmdLam <$> cvMatchGroup (traverse cvHsCmd) a -+cvHsCmd (HsCmdPar a) = HsCmdPar <$> traverse cvHsCmd a -+cvHsCmd (HsCmdCase a b) = HsCmdCase -+ <$> cvLHsExpr a <*> cvMatchGroup (traverse cvHsCmd) b -+cvHsCmd (HsCmdIf a b c d) = HsCmdIf -+ <$> traverse cvSyntaxExpr a -+ <*> cvLHsExpr b -+ <*> traverse cvHsCmd c -+ <*> traverse cvHsCmd d -+cvHsCmd (HsCmdLet a b) = HsCmdLet -+ <$> traverse cvHsLocalBinds a <*> traverse cvHsCmd b -+cvHsCmd (HsCmdDo a b) = HsCmdDo -+ <$> traverse (traverse (traverse (cvStmtLR (traverse cvHsCmd)))) a -+ <*> pure b -+cvHsCmd e@(HsCmdWrap {}) = unsupported "HsCmdWrap" "HsCmd" (ppr e) -+ -+cvArithSeqInfo :: TypeConstraints p q => ArithSeqInfo p -> Conv (ArithSeqInfo q) -+cvArithSeqInfo (From e) = From <$> cvLHsExpr e -+cvArithSeqInfo (FromThen a b) = FromThen <$> cvLHsExpr a <*> cvLHsExpr b -+cvArithSeqInfo (FromTo a b) = FromTo <$> cvLHsExpr a <*> cvLHsExpr b -+cvArithSeqInfo (FromThenTo a b c) = FromThenTo <$> cvLHsExpr a <*> cvLHsExpr b <*> cvLHsExpr c -+ -+cvHsTupArg :: TypeConstraints p q => HsTupArg p -> Conv (HsTupArg q) -+cvHsTupArg (Present a) = Present <$> cvLHsExpr a -+cvHsTupArg (Missing a) = pure (Missing a) -+ -+cvAFieldOcc -+ :: TypeConstraints p q => AmbiguousFieldOcc p -> Conv (AmbiguousFieldOcc q) -+cvAFieldOcc (Unambiguous a b) = Unambiguous <$> convertName a <*> pure b -+cvAFieldOcc (Ambiguous a b) = Ambiguous <$> convertName a <*> pure b -+ -+cvOverLit :: TypeConstraints p q => HsOverLit p -> Conv (HsOverLit q) -+cvOverLit (OverLit a b c d) = OverLit a b <$> cvHsExpr c <*> pure d -+ -+cvLit :: TypeConstraints p q => HsLit p -> Conv (HsLit q) -+cvLit (HsChar a b) = pure (HsChar a b) -+cvLit (HsCharPrim a b) = pure (HsCharPrim a b) -+cvLit (HsString a b) = pure (HsString a b) -+cvLit (HsStringPrim a b) = pure (HsStringPrim a b) -+cvLit (HsInt a b) = pure (HsInt a b) -+cvLit (HsIntPrim a b) = pure (HsIntPrim a b) -+cvLit (HsWordPrim a b) = pure (HsWordPrim a b) -+cvLit (HsInt64Prim a b) = pure (HsInt64Prim a b) -+cvLit (HsWord64Prim a b) = pure (HsWord64Prim a b) -+cvLit (HsInteger a b c) = HsInteger a b <$> convertType c -+cvLit (HsRat a b c) = HsRat a b <$> convertType c -+cvLit (HsFloatPrim a b) = pure (HsFloatPrim a b) -+cvLit (HsDoublePrim a b) = pure (HsDoublePrim a b) -+ -+cvMatchGroup -+ :: TypeConstraints p q -+ => (a -> Conv b) -> MatchGroup p a -> Conv (MatchGroup q b) -+cvMatchGroup f (MG a b c d) = MG -+ <$> traverse (traverse (traverse (cvMatch f))) a -+ <*> pure b <*> pure c <*> pure d -+ -+cvMatch -+ :: TypeConstraints p q -+ => (a -> Conv b) -> Match p a -> Conv (Match q b) -+cvMatch f (Match a b c) = Match -+ <$> convertName a -+ <*> traverse (traverse cvPat) b <*> cvGRHSs f c -+ -+cvPat :: TypeConstraints p q => Pat p -> Conv (Pat q) -+cvPat (WildPat a) = pure (WildPat a) -+cvPat (VarPat a) = VarPat <$> convertName a -+cvPat (LazyPat a) = LazyPat <$> traverse cvPat a -+cvPat (AsPat a b) = AsPat <$> convertName a <*> traverse cvPat b -+cvPat (ParPat a) = ParPat <$> traverse cvPat a -+cvPat (BangPat a) = BangPat <$> traverse cvPat a -+cvPat (ListPat a b c) = -+ ListPat <$> traverse (traverse cvPat) a -+ <*> pure b -+ <*> traverse (\(d, e) -> (\x -> (d, x)) <$> cvSyntaxExpr e) c -+cvPat (TuplePat a b c) = TuplePat <$> traverse (traverse cvPat) a -+ <*> pure b <*> pure c -+cvPat (SumPat a b c d) = SumPat <$> traverse cvPat a -+ <*> pure b <*> pure c <*> pure d -+cvPat (ConPatIn a b) = ConPatIn <$> convertName a <*> cvHsConPatDetails b -+cvPat (ViewPat a b c) = ViewPat <$> cvLHsExpr a <*> traverse cvPat b <*> pure c -+cvPat (LitPat a) = LitPat <$> cvLit a -+cvPat (NPat a b c d) = -+ NPat <$> traverse cvOverLit a <*> traverse cvSyntaxExpr b -+ <*> cvSyntaxExpr c <*> pure d -+cvPat (NPlusKPat a b c d e f) = -+ NPlusKPat -+ <$> convertName a -+ <*> traverse cvOverLit b <*> cvOverLit c -+ <*> cvSyntaxExpr d <*> cvSyntaxExpr e <*> pure f -+cvPat (SigPatIn a b) = SigPatIn <$> traverse cvPat a <*> cvHsSigWcType b -+cvPat (SplicePat a) = SplicePat <$> cvHsSplice a -+cvPat e@(PArrPat {}) = unsupported "PArrPat" "Pat" (ppr e) -+cvPat e@(SigPatOut {}) = unsupported "SigPatOut" "Pat" (ppr e) -+cvPat e@(CoPat {}) = unsupported "CoPat" "Pat" (ppr e) -+cvPat e@(ConPatOut {}) = unsupported "ConPatOut" "Pat" (ppr e) -+ -+cvGRHSs -+ :: TypeConstraints p q -+ => (a -> Conv b) -> GRHSs p a -> Conv (GRHSs q b) -+cvGRHSs f (GRHSs a b) = GRHSs -+ <$> traverse (traverse (cvGRHS f)) a -+ <*> traverse cvHsLocalBinds b -+ -+cvGRHS -+ :: TypeConstraints p q -+ => (a -> Conv b) -> GRHS p a -> Conv (GRHS q b) -+cvGRHS f (GRHS a b) = GRHS -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) a <*> f b -+ -+cvHsLocalBinds -+ :: TypeConstraints p q -+ => HsLocalBinds p -> Conv (HsLocalBinds q) -+cvHsLocalBinds (HsValBinds a) = HsValBinds <$> cvHsValBindsLR a -+cvHsLocalBinds (HsIPBinds a) = HsIPBinds <$> cvHsIPBinds a -+cvHsLocalBinds EmptyLocalBinds = pure EmptyLocalBinds -+ -+cvHsValBindsLR -+ :: TypeConstraints p q -+ => HsValBindsLR p p -> Conv (HsValBindsLR q q) -+cvHsValBindsLR (ValBindsIn a b) = ValBindsIn <$> mapBagM (traverse cvHsBindLR) a -+ <*> traverse (traverse cvSig) b -+cvHsValBindsLR e@(ValBindsOut {}) = unsupported "ValBindsOut" "HsValBindsLR" (ppr e) -+ -+cvHsConPatDetails -+ :: TypeConstraints p q => HsConPatDetails p -> Conv (HsConPatDetails q) -+cvHsConPatDetails (PrefixCon a) = PrefixCon <$> traverse (traverse cvPat) a -+cvHsConPatDetails (RecCon a) = RecCon <$> cvHsRecFieldsPat a -+cvHsConPatDetails (InfixCon a b) = InfixCon <$> traverse cvPat a -+ <*> traverse cvPat b -+ -+cvHsRecFields -+ :: TypeConstraints p q -+ => (thing -> Conv thing') -+ -> HsRecFields p thing -+ -> Conv (HsRecFields q thing') -+cvHsRecFields f (HsRecFields a b) = -+ HsRecFields <$> traverse (traverse (cvHsRecField' cvFieldOcc f)) a <*> pure b -+ -+cvHsRecField' -+ :: (id -> Conv id') -+ -> (thing -> Conv thing') -+ -> HsRecField' id thing -+ -> Conv (HsRecField' id' thing') -+cvHsRecField' f g (HsRecField a b c) = -+ HsRecField <$> traverse f a <*> g b <*> pure c -+ -+cvHsRecFieldsPat -+ :: TypeConstraints p q -+ => HsRecFields p (LPat p) -> Conv (HsRecFields q (LPat q)) -+cvHsRecFieldsPat = cvHsRecFields (traverse cvPat) -+ -+cvHsRecUpdField -+ :: TypeConstraints p q => HsRecUpdField p -> Conv (HsRecUpdField q) -+cvHsRecUpdField = cvHsRecField' cvAFieldOcc cvLHsExpr -+ -+cvRecordBinds -+ :: TypeConstraints p q => HsRecordBinds p -> Conv (HsRecordBinds q) -+cvRecordBinds = cvHsRecFields cvLHsExpr -+ -+cvFieldOcc :: TypeConstraints p q => FieldOcc p -> Conv (FieldOcc q) -+cvFieldOcc (FieldOcc a b) = FieldOcc <$> convertName a <*> pure b -+ -+cvStmtLR -+ :: TypeConstraints p q -+ => (a -> Conv b) -> StmtLR p p a -> Conv (StmtLR q q b) -+cvStmtLR k (LastStmt a b c) = LastStmt -+ <$> k a <*> pure b <*> cvSyntaxExpr c -+cvStmtLR k (BindStmt a b c d e) = BindStmt -+ <$> traverse cvPat a <*> k b -+ <*> cvSyntaxExpr c <*> cvSyntaxExpr d -+ <*> pure e -+cvStmtLR k (BodyStmt a b c d) = BodyStmt -+ <$> k a <*> cvSyntaxExpr b -+ <*> cvSyntaxExpr c <*> pure d -+cvStmtLR _ (ApplicativeStmt a b c) = ApplicativeStmt -+ <$> traverse -+ (\(se, aa) -> (,) <$> cvSyntaxExpr se <*> cvApplicativeArg aa) -+ a -+ <*> traverse cvSyntaxExpr b -+ <*> pure c -+cvStmtLR _ (LetStmt a) = LetStmt <$> traverse cvHsLocalBinds a -+cvStmtLR k (RecStmt a b c d e f g h i j) = RecStmt -+ <$> traverse (traverse (cvStmtLR k)) a -+ <*> convertName b -+ <*> convertName c -+ <*> cvSyntaxExpr d -+ <*> cvSyntaxExpr e -+ <*> cvSyntaxExpr f -+ <*> pure g <*> pure h <*> pure i <*> pure j -+cvStmtLR _ (ParStmt a b c d) = ParStmt -+ <$> traverse cvParStmtBlock a -+ <*> cvHsExpr b -+ <*> cvSyntaxExpr c -+ <*> pure d -+cvStmtLR _ (TransStmt a b c d e f g h i) = TransStmt a -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b -+ <*> traverse (\(x, y) -> (,) <$> convertName x <*> convertName y) c -+ <*> cvLHsExpr d -+ <*> traverse cvLHsExpr e -+ <*> cvSyntaxExpr f -+ <*> cvSyntaxExpr g -+ <*> pure h -+ <*> cvHsExpr i -+ -+cvParStmtBlock -+ :: TypeConstraints p q => ParStmtBlock p p -> Conv (ParStmtBlock q q) -+cvParStmtBlock (ParStmtBlock a b c) = ParStmtBlock -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) a -+ <*> convertName b -+ <*> cvSyntaxExpr c -+ -+cvSyntaxExpr :: TypeConstraints p q => SyntaxExpr p -> Conv (SyntaxExpr q) -+cvSyntaxExpr (SyntaxExpr a b c) = -+ SyntaxExpr <$> cvHsExpr a <*> pure b <*> pure c -+ -+cvHsIPBinds -+ :: TypeConstraints p q => HsIPBinds p -> Conv (HsIPBinds q) -+cvHsIPBinds (IPBinds a b) = IPBinds <$> traverse (traverse cvIPBind) a <*> pure b -+ -+cvIPBind -+ :: TypeConstraints p q => IPBind p -> Conv (IPBind q) -+cvIPBind (IPBind a b) = IPBind <$> convertName a <*> cvLHsExpr b -+ -+cvHsBindLR -+ :: TypeConstraints p q => HsBindLR p p -> Conv (HsBindLR q q) -+cvHsBindLR (FunBind a b c d e) = FunBind -+ <$> convertName a -+ <*> cvMatchGroup cvLHsExpr b -+ <*> pure c <*> pure d <*> pure e -+cvHsBindLR (PatBind a b c d e) = PatBind -+ <$> traverse cvPat a -+ <*> cvGRHSs cvLHsExpr b -+ <*> pure c <*> pure d <*> pure e -+cvHsBindLR (VarBind a b c) = VarBind <$> convertName a <*> cvLHsExpr b <*> pure c -+cvHsBindLR (PatSynBind a) = PatSynBind <$> cvPatSynBind a -+cvHsBindLR e@(AbsBinds {}) = unsupported "AbsBind" "HsBindLR" (ppr e) -+ -+cvHsWildCardBndrs -+ :: TypeConstraints p q -+ => (thing -> Conv thing') -+ -> HsWildCardBndrs p thing -+ -> Conv (HsWildCardBndrs q thing') -+cvHsWildCardBndrs thingF (HsWC a b) = HsWC a <$> thingF b -+ -+cvLHsWcType -+ :: TypeConstraints p q => LHsWcType p -> Conv (LHsWcType q) -+cvLHsWcType = cvHsWildCardBndrs (traverse cvType) -+ -+cvHsSigWcType -+ :: TypeConstraints p q => LHsSigWcType p -> Conv (LHsSigWcType q) -+cvHsSigWcType = cvHsWildCardBndrs (cvHsImplicitBndrs (traverse cvType)) -+ -+cvHsImplicitBndrs -+ :: TypeConstraints p q -+ => (thing -> Conv thing') -+ -> HsImplicitBndrs p thing -+ -> Conv (HsImplicitBndrs q thing') -+cvHsImplicitBndrs f (HsIB a b c) = HsIB a <$> f b <*> pure c -+ -+cvType :: TypeConstraints p q => HsType p -> Conv (HsType q) -+cvType (HsForAllTy a b) = HsForAllTy -+ <$> traverse (traverse cvHsTyVarBndr) a -+ <*> traverse cvType b -+cvType (HsQualTy a b) = HsQualTy -+ <$> traverse (traverse (traverse cvType)) a -+ <*> traverse cvType b -+cvType (HsTyVar a b) = HsTyVar a <$> convertName b -+cvType (HsAppsTy a) = HsAppsTy <$> traverse (traverse cvHsAppType) a -+cvType (HsAppTy a b) = HsAppTy <$> traverse cvType a -+ <*> traverse cvType b -+cvType (HsFunTy a b) = HsFunTy <$> traverse cvType a -+ <*> traverse cvType b -+cvType (HsListTy a) = HsListTy <$> traverse cvType a -+cvType (HsTupleTy a b) = HsTupleTy a <$> traverse (traverse cvType) b -+cvType (HsSumTy a) = HsSumTy <$> traverse (traverse cvType) a -+cvType (HsOpTy a b c) = HsOpTy <$> traverse cvType a -+ <*> convertName b -+ <*> traverse cvType c -+cvType (HsParTy a) = HsParTy <$> traverse cvType a -+cvType (HsIParamTy a b) = HsIParamTy a <$> traverse cvType b -+cvType (HsEqTy a b) = HsEqTy <$> traverse cvType a -+ <*> traverse cvType b -+cvType (HsKindSig a b) = HsKindSig <$> traverse cvType a -+ <*> traverse cvType b -+cvType (HsBangTy a b) = HsBangTy a <$> traverse cvType b -+cvType (HsRecTy a) = HsRecTy <$> traverse (traverse cvConDeclField) a -+cvType (HsExplicitListTy a b c) = HsExplicitListTy a b -+ <$> traverse (traverse cvType) c -+cvType (HsExplicitTupleTy a b) = HsExplicitTupleTy a -+ <$> traverse (traverse cvType) b -+cvType (HsTyLit a) = pure (HsTyLit a) -+cvType (HsWildCardTy (AnonWildCard a)) = pure (HsWildCardTy (AnonWildCard a)) -+cvType (HsDocTy a b) = HsDocTy <$> traverse cvType a <*> pure b -+cvType (HsSpliceTy a b) = HsSpliceTy <$> cvHsSplice a <*> pure b -+cvType e@(HsPArrTy {}) = unsupported "HsPArrTy" "HsType" (ppr e) -+cvType e@(HsCoreTy {}) = unsupported "HsCoreTy" "HsType" (ppr e) -+ -+cvHsAppType -+ :: TypeConstraints p q => HsAppType p -> Conv (HsAppType q) -+cvHsAppType (HsAppInfix a) = HsAppInfix <$> convertName a -+cvHsAppType (HsAppPrefix a) = HsAppPrefix <$> traverse cvType a -+ -+cvHsTyVarBndr -+ :: TypeConstraints p q => HsTyVarBndr p -> Conv (HsTyVarBndr q) -+cvHsTyVarBndr (UserTyVar a) = UserTyVar <$> convertName a -+cvHsTyVarBndr (KindedTyVar a b) = KindedTyVar -+ <$> convertName a -+ <*> traverse cvType b -+ -+cvApplicativeArg -+ :: TypeConstraints p q => ApplicativeArg p a -> Conv (ApplicativeArg q b) -+cvApplicativeArg (ApplicativeArgOne a b c) = ApplicativeArgOne -+ <$> traverse cvPat a <*> cvLHsExpr b <*> pure c -+cvApplicativeArg (ApplicativeArgMany a b c) = ApplicativeArgMany -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) a <*> cvHsExpr b -+ <*> traverse cvPat c -+ -+cvSig :: TypeConstraints p q => Sig p -> Conv (Sig q) -+cvSig (TypeSig a b) = TypeSig <$> convertName a <*> cvHsSigWcType b -+cvSig (PatSynSig a b) = PatSynSig -+ <$> convertName a <*> cvHsImplicitBndrs (traverse cvType) b -+cvSig (ClassOpSig a b c) = ClassOpSig a -+ <$> convertName b <*> cvHsImplicitBndrs (traverse cvType) c -+cvSig (InlineSig a b) = InlineSig <$> convertName a <*> pure b -+cvSig (FixSig a) = FixSig <$> cvFixitySig a -+cvSig (SpecSig a b c) = SpecSig -+ <$> convertName a -+ <*> traverse (cvHsImplicitBndrs (traverse cvType)) b -+ <*> pure c -+cvSig (SpecInstSig a b) = SpecInstSig a <$> cvHsImplicitBndrs (traverse cvType) b -+cvSig (SCCFunSig a b c) = SCCFunSig a <$> convertName b <*> pure c -+cvSig (CompleteMatchSig a b c) = CompleteMatchSig a -+ <$> convertName b <*> convertName c -+cvSig (MinimalSig a b) = MinimalSig a <$> traverse (traverse convertName) b -+cvSig e@(IdSig {}) = unsupported "IdSig" "Sig" (ppr e) -+ -+cvFixitySig :: TypeConstraints p q => FixitySig p -> Conv (FixitySig q) -+cvFixitySig (FixitySig a b) = FixitySig <$> convertName a <*> pure b -+ -+cvPatSynBind :: TypeConstraints p q => PatSynBind p p -> Conv (PatSynBind q q) -+cvPatSynBind (PSB a b c d e) = -+ PSB <$> convertName a -+ <*> pure b -+ <*> cvHsPatSynDetails convertName c <*> traverse cvPat d -+ <*> cvHsPatSynDir e -+ -+cvHsPatSynDetails -+ :: (a -> Conv b) -+ -> HsPatSynDetails a -+ -> Conv (HsPatSynDetails b) -+cvHsPatSynDetails f = -+ cvHsConDetails f (traverse (cvRecordPatSynField f)) -+ -+cvRecordPatSynField -+ :: (a -> Conv b) -+ -> RecordPatSynField a -+ -> Conv (RecordPatSynField b) -+cvRecordPatSynField f (RecordPatSynField a b) = -+ RecordPatSynField <$> f a <*> f b -+ -+cvHsPatSynDir :: TypeConstraints p q => HsPatSynDir p -> Conv (HsPatSynDir q) -+cvHsPatSynDir Unidirectional = pure Unidirectional -+cvHsPatSynDir ImplicitBidirectional = pure ImplicitBidirectional -+cvHsPatSynDir (ExplicitBidirectional a) = ExplicitBidirectional <$> cvMatchGroup cvLHsExpr a -+ -+-- * Looking up modules/packages for Orig names -+ -+-- this rejects wired in packages, because we want to leave them untouched -+parseUnitId' :: String -> Maybe (String, String, Maybe String) -+parseUnitId' = parse -+ -+ where -+ parse s = case splitOn '-' (reverse s) of -+ ("":_) -> Nothing -+ xs | length xs >= 1 && last xs == "" -> Nothing -+ (hash:ver:name) | isVersion ver -> -+ Just (intercalate "-" (reverse name), ver, Just hash) -+ (ver:name) | isVersion ver -> -+ Just (intercalate "-" (reverse name), ver, Nothing) -+ _ -> Nothing -+ splitOn c = go [] -+ where go acc (x:xs) -+ | x == c = acc : go "" xs -+ | otherwise = go (x:acc) xs -+ go acc [] = [acc] -+ isVersion = go False -+ -- True: waiting for digit or dot (we've seen a digit last) -+ -- False: waiting for digit (we've just seen a dot) -+ where go False (c:cs) -+ | isDigit c = go True cs -+ | otherwise = False -+ go True (c:cs) -+ | isDigit c = go True cs -+ | c == '.' = go False cs -+ | otherwise = False -+ go b [] = b -- if we've seen a dot last (False), we fail -+ -- otherwise, the version number can end here -+ -+-- | Look up the module from the same package, but built by the -+-- current compiler, therefore with a slightly different hash -+-- in the unit id than the input Module, which was built by some -+-- non-cross-compiling GHC. -+findEquivalentModule :: Module -> RnM (Maybe Module) -+findEquivalentModule mod = do -+ liftIO $ putStrLn ("Looking for equivalent to: " ++ unitIdStr) -+ case parseUnitId' unitIdStr of -+ Nothing -> return Nothing -+ Just (pkg, ver, _mhash) -> do -+ muid <- lookFor pkg ver -+ maybe (pure Nothing) (\uid -> return $ Just (mod { moduleUnitId = uid })) muid -+ -+ where unitIdStr = unitIdString (moduleUnitId mod) -+ -+lookFor :: String -> String -> RnM (Maybe UnitId) -+lookFor pkg ver = do -+ dflags <- getDynFlags -+ let pkgid = mkFastString (pkg ++ "-" ++ ver) -+ pkgs = searchPackageId dflags (SourcePackageId pkgid) -+ liftIO $ putStrLn ("Looking for: " ++ pkg ++ "-" ++ ver) -+ liftIO . putStrLn . unwords $ -+ [ "Found", show (length pkgs), "pkgs:" ] ++ -+ [ unitIdString (packageConfigId p) | p <- pkgs ] -+ if null pkgs then pure Nothing else pure (Just $ packageConfigId (head pkgs)) -diff --git a/compiler/hsSyn/HsExprBin_Instances.hs b/compiler/hsSyn/HsExprBin_Instances.hs -new file mode 100644 -index 0000000000..09187bb7cc ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin_Instances.hs -@@ -0,0 +1,1394 @@ -+-- too noisy during development... -+{-# OPTIONS_GHC -fno-warn-orphans #-} -+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -+{-# LANGUAGE StandaloneDeriving #-} -+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} -+module HsExprBin_Instances where -+ -+import Control.Applicative -+import Control.Monad -+ -+import BasicTypes -+import Binary -+import CoreSyn ( Tickish(..) ) -+import GhcPrelude -+import HsBinds -+import HsDecls -+import HsDoc -+import HsExpr -+import HsExtension -+import HsLit -+import HsPat -+import HsTypes -+import Name -+import Outputable -+import PlaceHolder -+import RdrName -+import SeName -+import SrcLoc -+import TcEvidence (HsWrapper(WpHole)) -+ -+putPanic :: String -> String -> a -+putPanic tyName conName = -+ panic ("Binary " ++ tyName ++ ".put: " ++ conName ++ " not supported") -+ -+getPanic :: String -> a -+getPanic tyName = -+ panic ("Binary " ++ tyName ++ ".get: unknown (or unsupported) tag") -+ -+-- * Binary instances -+ -+instance Binary (HsExpr GhcSe) where -+ put_ bh e = case e of -+ HsVar a -> -+ putByte bh 0 >> put_ bh a -+ HsUnboundVar a -> -+ putByte bh 1 >> put_ bh a -+ HsRecFld a -> -+ putByte bh 2 >> put_ bh a -+ HsOverLabel a b -> -+ putByte bh 3 >> put_ bh a >> put_ bh b -+ HsIPVar a -> -+ putByte bh 4 >> put_ bh a -+ HsOverLit a -> -+ putByte bh 5 >> put_ bh a -+ HsLit a -> -+ putByte bh 6 >> put_ bh a -+ HsLam a -> -+ putByte bh 7 >> put_ bh a -+ HsLamCase a -> -+ putByte bh 8 >> put_ bh a -+ HsApp a b -> -+ putByte bh 9 >> put_ bh a >> put_ bh b -+ HsAppType a b -> -+ putByte bh 10 >> put_ bh a >> put_ bh b -+ OpApp a b c d -> -+ putByte bh 11 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ NegApp a b -> -+ putByte bh 12 >> put_ bh a >> put_ bh b -+ HsPar a -> -+ putByte bh 13 >> put_ bh a -+ SectionL a b -> -+ putByte bh 14 >> put_ bh a >> put_ bh b -+ SectionR a b -> -+ putByte bh 15 >> put_ bh a >> put_ bh b -+ ExplicitTuple a b -> -+ putByte bh 16 >> put_ bh a >> put_ bh b -+ ExplicitSum a b c d -> -+ putByte bh 17 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsCase a b -> -+ putByte bh 18 >> put_ bh a >> put_ bh b -+ HsIf a b c d -> -+ putByte bh 19 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsMultiIf a b -> -+ putByte bh 20 >> put_ bh a >> put_ bh b -+ HsLet a b -> -+ putByte bh 21 >> put_ bh a >> put_ bh b -+ HsDo a b c -> -+ putByte bh 22 >> put_ bh a >> put_ bh b >> put_ bh c -+ ExplicitList a b c -> -+ putByte bh 23 >> put_ bh a >> put_ bh b >> put_ bh c -+ RecordCon a _b _c d -> -+ putByte bh 24 >> put_ bh a >> put_ bh d -+ RecordUpd a b c d e f -> -+ putByte bh 25 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e >> put_ bh f -+ ExprWithTySig a b -> -+ putByte bh 26 >> put_ bh a >> put_ bh b -+ ArithSeq _a b c -> -+ putByte bh 27 >> put_ bh b >> put_ bh c -+ EWildPat -> -+ putByte bh 28 -+ EAsPat a b -> -+ putByte bh 29 >> put_ bh a >> put_ bh b -+ EViewPat a b -> -+ putByte bh 30 >> put_ bh a >> put_ bh b -+ ELazyPat a -> -+ putByte bh 31 >> put_ bh a -+ HsStatic a b -> -+ putByte bh 32 >> put_ bh a >> put_ bh b -+ HsProc a b -> -+ putByte bh 33 >> put_ bh a >> put_ bh b -+ HsBinTick a b c -> -+ putByte bh 34 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsTickPragma a b c d -> -+ putByte bh 35 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsSpliceE a -> -+ putByte bh 36 >> put_ bh a -+ HsSCC a b c -> -+ putByte bh 37 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsCoreAnn a b c -> -+ putByte bh 38 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsBracket a -> -+ putByte bh 39 >> put_ bh a -+ HsConLikeOut {} -> putPanic "HsExpr" "HsConLikeOut" -+ HsAppTypeOut {} -> putPanic "HsExpr" "HsAppTypeOut" -+ ExplicitPArr {} -> putPanic "HsExpr" "ExplicitPArr" -+ ExprWithTySigOut {} -> putPanic "HsExpr" "ExprWithTySigOut" -+ PArrSeq {} -> putPanic "HsExpr" "PArrSeq" -+ HsRnBracketOut {} -> putPanic "HsExpr" "HsRnBracketOut" -+ HsTcBracketOut {} -> putPanic "HsExpr" "HsTcBracketOut" -+ HsArrApp {} -> putPanic "HsExpr" "HsArrApp" -+ HsArrForm {} -> putPanic "HsExpr" "HsArrForm" -+ HsTick {} -> putPanic "HsExpr" "HsTick" -+ HsWrap {} -> putPanic "HsExpr" "HsWrap" -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsVar <$> get bh -+ 1 -> HsUnboundVar <$> get bh -+ 2 -> HsRecFld <$> get bh -+ 3 -> HsOverLabel <$> get bh <*> get bh -+ 4 -> HsIPVar <$> get bh -+ 5 -> HsOverLit <$> get bh -+ 6 -> HsLit <$> get bh -+ 7 -> HsLam <$> get bh -+ 8 -> HsLamCase <$> get bh -+ 9 -> HsApp <$> get bh <*> get bh -+ 10 -> HsAppType <$> get bh <*> get bh -+ 11 -> OpApp <$> get bh <*> get bh <*> get bh <*> get bh -+ 12 -> NegApp <$> get bh <*> get bh -+ 13 -> HsPar <$> get bh -+ 14 -> SectionL <$> get bh <*> get bh -+ 15 -> SectionR <$> get bh <*> get bh -+ 16 -> ExplicitTuple <$> get bh <*> get bh -+ 17 -> ExplicitSum <$> get bh <*> get bh <*> get bh <*> get bh -+ 18 -> HsCase <$> get bh <*> get bh -+ 19 -> HsIf <$> get bh <*> get bh <*> get bh <*> get bh -+ 20 -> HsMultiIf <$> get bh <*> get bh -+ 21 -> HsLet <$> get bh <*> get bh -+ 22 -> HsDo <$> get bh <*> get bh <*> get bh -+ 23 -> ExplicitList <$> get bh <*> get bh <*> get bh -+ 24 -> RecordCon <$> get bh <*> pure PlaceHolder <*> pure noPostTcExpr -+ <*> get bh -+ 25 -> RecordUpd <$> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh -+ 26 -> ExprWithTySig <$> get bh <*> get bh -+ 27 -> ArithSeq <$> pure noPostTcExpr <*> get bh <*> get bh -+ 28 -> pure EWildPat -+ 29 -> EAsPat <$> get bh <*> get bh -+ 30 -> EViewPat <$> get bh <*> get bh -+ 31 -> ELazyPat <$> get bh -+ 32 -> HsStatic <$> get bh <*> get bh -+ 33 -> HsProc <$> get bh <*> get bh -+ 34 -> HsBinTick <$> get bh <*> get bh <*> get bh -+ 35 -> HsTickPragma <$> get bh <*> get bh <*> get bh <*> get bh -+ 36 -> HsSpliceE <$> get bh -+ 37 -> HsSCC <$> get bh <*> get bh <*> get bh -+ 38 -> HsCoreAnn <$> get bh <*> get bh <*> get bh -+ 39 -> HsBracket <$> get bh -+ _ -> getPanic "HsExpr" -+ -+instance Binary (HsBracket GhcSe) where -+ put_ bh b = case b of -+ ExpBr a -> -+ putByte bh 0 >> put_ bh a -+ PatBr a -> -+ putByte bh 1 >> put_ bh a -+ DecBrL a -> -+ putByte bh 2 >> put_ bh a -+ DecBrG a -> -+ putByte bh 3 >> put_ bh a -+ TypBr a -> -+ putByte bh 4 >> put_ bh a -+ VarBr a b -> -+ putByte bh 5 >> put_ bh a >> put_ bh b -+ TExpBr a -> -+ putByte bh 6 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ExpBr <$> get bh -+ 1 -> PatBr <$> get bh -+ 2 -> DecBrL <$> get bh -+ 3 -> DecBrG <$> get bh -+ 4 -> TypBr <$> get bh -+ 5 -> VarBr <$> get bh <*> get bh -+ 6 -> TExpBr <$> get bh -+ _ -> getPanic "HsBracket" -+ -+instance Binary SeName where -+ put_ bh (SeName n) = put_ bh n -+ get bh = mkSeName <$> get bh -+ -+instance Binary RealSrcSpan where -+ put_ bh s = -+ put_ bh (srcSpanFile s) >> -+ put_ bh (srcSpanStartLine s) >> -+ put_ bh (srcSpanStartCol s) >> -+ put_ bh (srcSpanEndLine s) >> -+ put_ bh (srcSpanEndCol s) -+ get bh = do -+ file <- get bh -+ (startLine, startCol) <- (,) <$> get bh <*> get bh -+ (endLine, endCol) <- (,) <$> get bh <*> get bh -+ let startLoc = mkRealSrcLoc file startLine startCol -+ endLoc = mkRealSrcLoc file endLine endCol -+ return (mkRealSrcSpan startLoc endLoc) -+ -+instance Binary UnboundVar where -+ put_ bh v = case v of -+ OutOfScope a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ TrueExprHole a -> putByte bh 1 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> OutOfScope <$> get bh <*> get bh -+ 1 -> TrueExprHole <$> get bh -+ _ -> getPanic "UnboundVar" -+ -+instance Binary a => Binary (StmtLR GhcSe GhcSe a) where -+ put_ bh s = case s of -+ LastStmt a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ BindStmt a b c d e -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put bh c >> put_ bh d -+ >> put_ bh e -+ ApplicativeStmt a b c -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -+ BodyStmt a b c d -> -+ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ LetStmt a -> -+ putByte bh 4 >> put_ bh a -+ ParStmt a b c d -> -+ putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ RecStmt a b c d e f _g _h _i _j -> -+ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f -+ TransStmt a b c d e f g h i -> -+ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h -+ >> put_ bh i -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> LastStmt <$> get bh <*> get bh <*> get bh -+ 1 -> BindStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ 2 -> ApplicativeStmt <$> get bh <*> get bh <*> get bh -+ 3 -> BodyStmt <$> get bh <*> get bh <*> get bh <*> get bh -+ 4 -> LetStmt <$> get bh -+ 5 -> ParStmt <$> get bh <*> get bh <*> get bh <*> get bh -+ 6 -> RecStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> pure PlaceHolder <*> pure [] <*> pure [] -+ <*> pure PlaceHolder -+ 7 -> TransStmt <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh -+ _ -> getPanic "StmtLR" -+ -+instance Binary (HsGroup GhcSe) where -+ put_ bh (HsGroup a b c d e f g h i j k l) = -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g -+ >> put_ bh h >> put_ bh i >> put_ bh j -+ >> put_ bh k >> put_ bh l -+ get bh = HsGroup -+ <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh <*> get bh -+ -+instance Binary (TyClGroup GhcSe) where -+ put_ bh (TyClGroup a b c) = put_ bh a >> put_ bh b >> put_ bh c -+ get bh = TyClGroup <$> get bh <*> get bh <*> get bh -+ -+instance Binary (VectDecl GhcSe) where -+ put_ bh d = case d of -+ HsVect a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsNoVect a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ HsVectTypeIn a b c d -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsVectClassIn a b -> -+ putByte bh 3 >> put_ bh a >> put_ bh b -+ HsVectInstIn a -> -+ putByte bh 4 >> put_ bh a -+ HsVectTypeOut {} -> putPanic "HsVectTypeOut" "VectDecl" -+ HsVectClassOut {} -> putPanic "HsVectClassOut" "VectDecl" -+ HsVectInstOut {} -> putPanic "HsVectInstOut" "VectDecl" -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsVect <$> get bh <*> get bh <*> get bh -+ 1 -> HsNoVect <$> get bh <*> get bh -+ 2 -> HsVectTypeIn <$> get bh <*> get bh <*> get bh <*> get bh -+ 3 -> HsVectClassIn <$> get bh <*> get bh -+ 4 -> HsVectInstIn <$> get bh -+ _ -> getPanic "VectDecl" -+ -+instance Binary (HsCmdTop GhcSe) where -+ put_ bh (HsCmdTop a b c d) = -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ get bh = HsCmdTop <$> get bh <*> get bh <*> get bh <*> get bh -+ -+instance Binary (HsCmd GhcSe) where -+ put_ bh c = case c of -+ HsCmdArrApp a b c d e -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ HsCmdArrForm a b c d -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsCmdApp a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ HsCmdLam a -> -+ putByte bh 3 >> put_ bh a -+ HsCmdPar a -> -+ putByte bh 4 >> put_ bh a -+ HsCmdCase a b -> -+ putByte bh 5 >> put_ bh a >> put_ bh b -+ HsCmdIf a b c d -> -+ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsCmdLet a b -> -+ putByte bh 7 >> put_ bh a >> put_ bh b -+ HsCmdDo a b -> -+ putByte bh 8 >> put_ bh a >> put_ bh b -+ HsCmdWrap {} -> -+ putPanic "HsCmdWrap" "HsCmd" -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsCmdArrApp <$> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ 1 -> HsCmdArrForm <$> get bh <*> get bh <*> get bh -+ <*> get bh -+ 2 -> HsCmdApp <$> get bh <*> get bh -+ 3 -> HsCmdLam <$> get bh -+ 4 -> HsCmdPar <$> get bh -+ 5 -> HsCmdCase <$> get bh <*> get bh -+ 6 -> HsCmdIf <$> get bh <*> get bh <*> get bh <*> get bh -+ 7 -> HsCmdLet <$> get bh <*> get bh -+ 8 -> HsCmdDo <$> get bh <*> get bh -+ _ -> getPanic "HsCmd" -+ -+instance Binary HsArrAppType where -+ put_ bh t = putByte bh $ case t of -+ HsHigherOrderApp -> 0 -+ HsFirstOrderApp -> 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure HsHigherOrderApp -+ 1 -> pure HsFirstOrderApp -+ _ -> getPanic "HsArrAppType" -+ -+instance Binary TransForm where -+ put_ bh f = putByte bh $ case f of -+ ThenForm -> 0 -+ GroupForm -> 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure ThenForm -+ 1 -> pure GroupForm -+ _ -> getPanic "TransForm" -+ -+instance Binary (ApplicativeArg GhcSe GhcSe) where -+ put_ bh a = case a of -+ ApplicativeArgOne a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ ApplicativeArgMany a b c -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ApplicativeArgOne <$> get bh <*> get bh <*> get bh -+ 1 -> ApplicativeArgMany <$> get bh <*> get bh <*> get bh -+ _ -> getPanic "ApplicativeAr" -+ -+instance Binary (ParStmtBlock GhcSe GhcSe) where -+ put_ bh b = case b of -+ ParStmtBlock a b c -> -+ put_ bh a >> put_ bh b >> put_ bh c -+ get bh = ParStmtBlock <$> get bh <*> get bh <*> get bh -+ -+instance Binary (SyntaxExpr GhcSe) where -+ put_ bh (SyntaxExpr a [] WpHole) = put_ bh a -+ put_ _ _ = panic "Binary SyntaxExpr.put: wrappers should be empty" -+ get bh = SyntaxExpr <$> get bh <*> pure [] <*> pure WpHole -+ -+instance Binary a => Binary (GRHSs GhcSe a) where -+ put_ bh g = case g of -+ GRHSs a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> GRHSs <$> get bh <*> get bh -+ _ -> getPanic "GRHSs" -+ -+instance Binary a => Binary (GRHS GhcSe a) where -+ put_ bh g = case g of -+ GRHS a b -> put_ bh a >> put_ bh b -+ get bh = GRHS <$> get bh <*> get bh -+ -+instance Binary a => Binary (MatchGroup GhcSe a) where -+ put_ bh g = case g of -+ MG a b c d -> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ get bh = MG <$> get bh <*> get bh <*> get bh <*> get bh -+ -+instance Binary a => Binary (Match GhcSe a) where -+ put_ bh m = case m of -+ Match a b c -> -+ put_ bh a >> put_ bh b >> put_ bh c -+ get bh = Match <$> get bh <*> get bh <*> get bh -+ -+instance Binary (HsMatchContext SeName) where -+ put_ bh c = case c of -+ FunRhs a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ LambdaExpr -> -+ putByte bh 1 -+ CaseAlt -> -+ putByte bh 2 -+ IfAlt -> -+ putByte bh 3 -+ ProcExpr -> -+ putByte bh 4 -+ PatBindRhs -> -+ putByte bh 5 -+ RecUpd -> -+ putByte bh 6 -+ StmtCtxt a -> -+ putByte bh 7 >> put_ bh a -+ ThPatSplice -> -+ putByte bh 8 -+ ThPatQuote -> -+ putByte bh 9 -+ PatSyn -> -+ putByte bh 10 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FunRhs <$> get bh <*> get bh <*> get bh -+ 1 -> pure LambdaExpr -+ 2 -> pure CaseAlt -+ 3 -> pure IfAlt -+ 4 -> pure ProcExpr -+ 5 -> pure PatBindRhs -+ 6 -> pure RecUpd -+ 7 -> StmtCtxt <$> get bh -+ 8 -> pure ThPatSplice -+ 9 -> pure ThPatQuote -+ 10 -> pure PatSyn -+ _ -> getPanic "HsMatchContext" -+ -+instance Binary (HsStmtContext SeName) where -+ put_ bh c = case c of -+ ListComp -> putByte bh 0 -+ MonadComp -> putByte bh 1 -+ DoExpr -> putByte bh 3 -+ MDoExpr -> putByte bh 4 -+ ArrowExpr -> putByte bh 5 -+ GhciStmtCtxt -> putByte bh 6 -+ PatGuard a -> putByte bh 7 >> put_ bh a -+ ParStmtCtxt a -> putByte bh 8 >> put_ bh a -+ TransStmtCtxt a -> putByte bh 9 >> put_ bh a -+ PArrComp {} -> putPanic "HsStmtContext" "PArrComp" -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure ListComp -+ 1 -> pure MonadComp -+ 3 -> pure DoExpr -+ 4 -> pure MDoExpr -+ 5 -> pure ArrowExpr -+ 6 -> pure GhciStmtCtxt -+ 7 -> PatGuard <$> get bh -+ 8 -> ParStmtCtxt <$> get bh -+ 9 -> TransStmtCtxt <$> get bh -+ _ -> getPanic "HsStmtContext" -+ -+instance Binary (ArithSeqInfo GhcSe) where -+ put_ bh i = case i of -+ From a -> -+ putByte bh 0 >> put_ bh a -+ FromThen a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ FromTo a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ FromThenTo a b c -> -+ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> From <$> get bh -+ 1 -> FromThen <$> get bh <*> get bh -+ 2 -> FromTo <$> get bh <*> get bh -+ 3 -> FromThenTo <$> get bh <*> get bh <*> get bh -+ _ -> getPanic "ArithSeqInfo" -+ -+instance Binary (HsTupArg GhcSe) where -+ put_ bh a = case a of -+ Present a -> putByte bh 0 >> put_ bh a -+ Missing a -> putByte bh 1 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> Present <$> get bh -+ 1 -> Missing <$> get bh -+ _ -> getPanic "HsTupArg" -+ -+instance Binary (Pat GhcSe) where -+ put_ bh p = case p of -+ WildPat a -> -+ putByte bh 0 >> put_ bh a -+ VarPat a -> -+ putByte bh 1 >> put_ bh a -+ LazyPat a -> -+ putByte bh 2 >> put_ bh a -+ AsPat a b -> -+ putByte bh 3 >> put_ bh a >> put_ bh b -+ ParPat a -> -+ putByte bh 4 >> put_ bh a -+ BangPat a -> -+ putByte bh 5 >> put_ bh a -+ ListPat a b c -> -+ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c -+ TuplePat a b c -> -+ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c -+ SumPat a b c d -> -+ putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ ConPatIn a b -> -+ putByte bh 9 >> put_ bh a >> put_ bh b -+ ViewPat a b c -> -+ putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -+ LitPat a -> -+ putByte bh 11 >> put_ bh a -+ NPat a b c d -> -+ putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ NPlusKPat a b c d e f -> -+ putByte bh 13 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f -+ SigPatIn a b -> -+ putByte bh 14 >> put_ bh a >> put_ bh b -+ SplicePat a -> -+ putByte bh 15 >> put_ bh a -+ ConPatOut {} -> putPanic "Pat" "ConPatOut" -+ CoPat {} -> putPanic "Pat" "CoPat" -+ PArrPat {} -> putPanic "Pat" "PArrPat" -+ SigPatOut {} -> putPanic "Pat" "SigPatOut" -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> WildPat <$> get bh -+ 1 -> VarPat <$> get bh -+ 2 -> LazyPat <$> get bh -+ 3 -> AsPat <$> get bh <*> get bh -+ 4 -> ParPat <$> get bh -+ 5 -> BangPat <$> get bh -+ 6 -> ListPat <$> get bh <*> get bh <*> get bh -+ 7 -> TuplePat <$> get bh <*> get bh <*> get bh -+ 8 -> SumPat <$> get bh <*> get bh <*> get bh <*> get bh -+ 9 -> ConPatIn <$> get bh <*> get bh -+ 10 -> ViewPat <$> get bh <*> get bh <*> get bh -+ 11 -> LitPat <$> get bh -+ 12 -> NPat <$> get bh <*> get bh <*> get bh <*> get bh -+ 13 -> NPlusKPat <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ 14 -> SigPatIn <$> get bh <*> get bh -+ 15 -> SplicePat <$> get bh -+ _ -> getPanic "HsPat" -+ -+instance (Binary (FieldOcc a), Binary b) => Binary (HsRecFields a b) where -+ put_ bh (HsRecFields a b) = put_ bh a >> put_ bh b -+ get bh = HsRecFields <$> get bh <*> get bh -+ -+instance (Binary id, Binary arg) => Binary (HsRecField' id arg) where -+ put_ bh (HsRecField a b c) = put_ bh a >> put_ bh b >> put_ bh c -+ get bh = HsRecField <$> get bh <*> get bh <*> get bh -+ -+instance Binary (HsType GhcSe) where -+ put_ bh t = case t of -+ HsForAllTy a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ HsQualTy a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ HsTyVar a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ HsAppsTy a -> -+ putByte bh 3 >> put_ bh a -+ HsAppTy a b -> -+ putByte bh 4 >> put_ bh a >> put_ bh b -+ HsFunTy a b -> -+ putByte bh 5 >> put_ bh a >> put_ bh b -+ HsListTy a -> -+ putByte bh 6 >> put_ bh a -+ HsTupleTy a b -> -+ putByte bh 7 >> put_ bh a >> put_ bh b -+ HsSumTy a -> -+ putByte bh 8 >> put_ bh a -+ HsOpTy a b c -> -+ putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsParTy a -> -+ putByte bh 10 >> put_ bh a -+ HsIParamTy a b -> -+ putByte bh 11 >> put_ bh a >> put_ bh b -+ HsEqTy a b -> -+ putByte bh 12 >> put_ bh a >> put_ bh b -+ HsKindSig a b -> -+ putByte bh 13 >> put_ bh a >> put_ bh b -+ HsBangTy a b -> -+ putByte bh 14 >> put_ bh a >> put_ bh b -+ HsRecTy a -> -+ putByte bh 15 >> put_ bh a -+ HsExplicitListTy a b c -> -+ putByte bh 16 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsExplicitTupleTy a b -> -+ putByte bh 17 >> put_ bh a >> put_ bh b -+ HsTyLit a -> -+ putByte bh 18 >> put_ bh a -+ HsWildCardTy a -> -+ putByte bh 19 >> put_ bh a -+ HsDocTy a b -> -+ putByte bh 20 >> put_ bh a >> put_ bh b -+ HsSpliceTy a b -> -+ putByte bh 21 >> put_ bh a >> put_ bh b -+ HsPArrTy {} -> putPanic "HsType" "PArrTy" -+ HsCoreTy {} -> putPanic "HsType" "HsCoreTy" -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsForAllTy <$> get bh <*> get bh -+ 1 -> HsQualTy <$> get bh <*> get bh -+ 2 -> HsTyVar <$> get bh <*> get bh -+ 3 -> HsAppsTy <$> get bh -+ 4 -> HsAppTy <$> get bh <*> get bh -+ 5 -> HsFunTy <$> get bh <*> get bh -+ 6 -> HsListTy <$> get bh -+ 7 -> HsTupleTy <$> get bh <*> get bh -+ 8 -> HsSumTy <$> get bh -+ 9 -> HsOpTy <$> get bh <*> get bh <*> get bh -+ 10 -> HsParTy <$> get bh -+ 11 -> HsIParamTy <$> get bh <*> get bh -+ 12 -> HsEqTy <$> get bh <*> get bh -+ 13 -> HsKindSig <$> get bh <*> get bh -+ 14 -> HsBangTy <$> get bh <*> get bh -+ 15 -> HsRecTy <$> get bh -+ 16 -> HsExplicitListTy <$> get bh <*> get bh <*> get bh -+ 17 -> HsExplicitTupleTy <$> get bh <*> get bh -+ 18 -> HsTyLit <$> get bh -+ 19 -> HsWildCardTy <$> get bh -+ 20 -> HsDocTy <$> get bh <*> get bh -+ 21 -> HsSpliceTy <$> get bh <*> get bh -+ _ -> getPanic "HsType" -+ -+instance Binary HsTyLit where -+ put_ bh l = case l of -+ HsNumTy a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ HsStrTy a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsNumTy <$> get bh <*> get bh -+ 1 -> HsStrTy <$> get bh <*> get bh -+ _ -> getPanic "HsTyLit" -+ -+instance Binary (HsAppType GhcSe) where -+ put_ bh t = case t of -+ HsAppInfix a -> putByte bh 0 >> put_ bh a -+ HsAppPrefix a -> putByte bh 1 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsAppInfix <$> get bh -+ 1 -> HsAppPrefix <$> get bh -+ _ -> getPanic "HsAppType" -+ -+deriving instance Binary (HsWildCardInfo GhcSe) -+ -+instance Binary a => Binary (HsWildCardBndrs GhcSe a) where -+ put_ bh w = case w of -+ HsWC a b -> put_ bh a >> put_ bh b -+ get bh = HsWC <$> get bh <*> get bh -+ -+instance Binary a => Binary (HsImplicitBndrs GhcSe a) where -+ put_ bh b = case b of -+ HsIB a b c -> put_ bh a >> put_ bh b >> put_ bh c -+ get bh = HsIB <$> get bh <*> get bh <*> get bh -+ -+instance Binary Promoted where -+ put_ bh p = putByte bh (case p of -+ Promoted -> 0 -+ NotPromoted -> 1) -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure Promoted -+ 1 -> pure NotPromoted -+ _ -> getPanic "Promoted" -+ -+instance Binary HsTupleSort where -+ put_ bh s = putByte bh (case s of -+ HsUnboxedTuple -> 0 -+ HsBoxedTuple -> 1 -+ HsConstraintTuple -> 2 -+ HsBoxedOrConstraintTuple -> 3) -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure HsUnboxedTuple -+ 1 -> pure HsBoxedTuple -+ 2 -> pure HsConstraintTuple -+ 3 -> pure HsBoxedOrConstraintTuple -+ _ -> getPanic "HsTupleSort" -+ -+instance Binary (ConDeclField GhcSe) where -+ put_ bh f = case f of -+ ConDeclField a b c -> -+ put_ bh a >> put_ bh b >> put_ bh c -+ get bh = ConDeclField <$> get bh <*> get bh <*> get bh -+ -+instance Binary (FieldOcc GhcSe) where -+ put_ bh o = case o of -+ FieldOcc a b -> put_ bh a >> put_ bh b -+ get bh = FieldOcc <$> get bh <*> get bh -+ -+instance Binary (HsTyVarBndr GhcSe) where -+ put_ bh v = case v of -+ UserTyVar a -> putByte bh 0 >> put_ bh a -+ KindedTyVar a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> UserTyVar <$> get bh -+ 1 -> KindedTyVar <$> get bh <*> get bh -+ _ -> getPanic "HsTyVarBndr" -+ -+instance (Binary a, Binary b) => Binary (HsConDetails a b) where -+ put_ bh c = case c of -+ PrefixCon a -> putByte bh 0 >> put_ bh a -+ RecCon a -> putByte bh 1 >> put_ bh a -+ InfixCon a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> PrefixCon <$> get bh -+ 1 -> RecCon <$> get bh -+ 2 -> InfixCon <$> get bh <*> get bh -+ _ -> getPanic "HsConDetails" -+ -+instance Binary (AmbiguousFieldOcc GhcSe) where -+ put_ bh o = case o of -+ Unambiguous a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ Ambiguous a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> Unambiguous <$> get bh <*> get bh -+ 1 -> Ambiguous <$> get bh <*> get bh -+ _ -> getPanic "AmbiguousOccField" -+ -+instance Binary (LHsQTyVars GhcSe) where -+ put_ bh v = case v of -+ HsQTvs a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ get bh = HsQTvs <$> get bh <*> get bh <*> get bh -+ -+instance Binary (Sig GhcSe) where -+ put_ bh s = case s of -+ TypeSig a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ PatSynSig a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ ClassOpSig a b c -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -+ IdSig a -> -+ putByte bh 3 >> put_ bh a -+ FixSig a -> -+ putByte bh 4 >> put_ bh a -+ InlineSig a b -> -+ putByte bh 5 >> put_ bh a >> put_ bh b -+ SpecSig a b c -> -+ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c -+ SpecInstSig a b -> -+ putByte bh 7 >> put_ bh a >> put_ bh b -+ SCCFunSig a b c -> -+ putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c -+ CompleteMatchSig a b c -> -+ putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c -+ MinimalSig a b -> -+ putByte bh 10 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> TypeSig <$> get bh <*> get bh -+ 1 -> PatSynSig <$> get bh <*> get bh -+ 2 -> ClassOpSig <$> get bh <*> get bh <*> get bh -+ 3 -> IdSig <$> get bh -+ 4 -> FixSig <$> get bh -+ 5 -> InlineSig <$> get bh <*> get bh -+ 6 -> SpecSig <$> get bh <*> get bh <*> get bh -+ 7 -> SpecInstSig <$> get bh <*> get bh -+ 8 -> SCCFunSig <$> get bh <*> get bh <*> get bh -+ 9 -> CompleteMatchSig <$> get bh <*> get bh <*> get bh -+ 10 -> MinimalSig <$> get bh <*> get bh -+ _ -> getPanic "Sig" -+ -+instance Binary (FixitySig GhcSe) where -+ put_ bh s = case s of -+ FixitySig a b -> put_ bh a >> put_ bh b -+ get bh = FixitySig <$> get bh <*> get bh -+ -+instance Binary (HsBindLR GhcSe GhcSe) where -+ put_ bh b = case b of -+ -- TODO: we drop the "fun_co_fn" field, as it seems -+ -- to always be WpHole in the places where the binary -+ -- serialisation instances will be used. -+ -- TODO: we drop the "fun_tick" field, as it is unlikely -+ -- to be used in our immediate use cases. Let's -+ -- return to parametrising away the 'Id' in that -+ -- field's type. -+ FunBind a b c d _ -> case c of -+ WpHole -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh d -+ _ -> -+ panic "Binary HsBindLR: FunBind with non-WpHole value in fun_co_fn" -+ -- TODO: same as for FunBind, we drop pat_ticks -+ PatBind a b c d _ -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ VarBind a b c -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -+ PatSynBind a -> -+ putByte bh 3 >> put_ bh a -+ AbsBinds {} -> putPanic "HsBindsLR" "AbsBinds" -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FunBind <$> get bh <*> get bh <*> pure WpHole <*> get bh <*> pure [] -+ 1 -> PatBind <$> get bh <*> get bh <*> get bh <*> get bh <*> pure ([], []) -+ 2 -> VarBind <$> get bh <*> get bh <*> get bh -+ 3 -> PatSynBind <$> get bh -+ _ -> getPanic "HsBindsLR" -+ -+instance Binary (HsLocalBindsLR GhcSe GhcSe) where -+ put_ bh b = case b of -+ HsValBinds a -> putByte bh 0 >> put_ bh a -+ EmptyLocalBinds -> putByte bh 1 -+ HsIPBinds {} -> putPanic "HsLocalBindsLR" "HsIPBinds" -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsValBinds <$> get bh -+ 1 -> pure EmptyLocalBinds -+ _ -> getPanic "HsLocalBindsLR" -+ -+instance Binary (HsValBindsLR GhcSe GhcSe) where -+ put_ bh b = case b of -+ ValBindsIn a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ ValBindsOut {} -> putPanic "HsValBindsLR" "ValBindsOut" -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ValBindsIn <$> get bh <*> get bh -+ _ -> getPanic "HsValBindsLR" -+ -+instance Binary (PatSynBind GhcSe GhcSe) where -+ put_ bh b = case b of -+ PSB a b c d e -> -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d >> put_ bh e -+ -+ get bh = PSB <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ -+instance Binary (HsPatSynDir GhcSe) where -+ put_ bh d = case d of -+ Unidirectional -> putByte bh 0 -+ ImplicitBidirectional -> putByte bh 1 -+ ExplicitBidirectional a -> putByte bh 2 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure Unidirectional -+ 1 -> pure ImplicitBidirectional -+ 2 -> ExplicitBidirectional <$> get bh -+ _ -> getPanic "HsPatSynDir" -+ -+instance Binary a => Binary (RecordPatSynField a) where -+ put_ bh (RecordPatSynField a b) = put_ bh a >> put_ bh b -+ get bh = RecordPatSynField <$> get bh <*> get bh -+ -+instance Binary (IPBind GhcSe) where -+ put_ bh b = case b of -+ IPBind a b -> put_ bh a >> put_ bh b -+ get bh = IPBind <$> get bh <*> get bh -+ -+-- * HsDecls -+ -+instance Binary (HsDecl GhcSe) where -+ put_ bh d = case d of -+ TyClD a -> putByte bh 0 >> put_ bh a -+ InstD a -> putByte bh 1 >> put_ bh a -+ DerivD a -> putByte bh 2 >> put_ bh a -+ ValD a -> putByte bh 3 >> put_ bh a -+ SigD a -> putByte bh 4 >> put_ bh a -+ DefD a -> putByte bh 5 >> put_ bh a -+ ForD a -> putByte bh 6 >> put_ bh a -+ WarningD a -> putByte bh 7 >> put_ bh a -+ RoleAnnotD a -> putByte bh 8 >> put_ bh a -+ RuleD a -> putByte bh 9 >> put_ bh a -+ AnnD a -> putByte bh 10 >> put_ bh a -+ SpliceD a -> putByte bh 11 >> put_ bh a -+ DocD a -> putByte bh 12 >> put_ bh a -+ VectD a -> putByte bh 13 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> TyClD <$> get bh -+ 1 -> InstD <$> get bh -+ 2 -> DerivD <$> get bh -+ 3 -> ValD <$> get bh -+ 4 -> SigD <$> get bh -+ 5 -> DefD <$> get bh -+ 6 -> ForD <$> get bh -+ 7 -> WarningD <$> get bh -+ 8 -> RoleAnnotD <$> get bh -+ 9 -> RuleD <$> get bh -+ 10 -> AnnD <$> get bh -+ 11 -> SpliceD <$> get bh -+ 12 -> DocD <$> get bh -+ 13 -> VectD <$> get bh -+ _ -> getPanic "HsDecl" -+ -+instance Binary (ForeignDecl GhcSe) where -+ put_ bh d = case d of -+ ForeignImport a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ ForeignExport a b c d -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ForeignImport <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> ForeignExport <$> get bh <*> get bh <*> get bh <*> get bh -+ _ -> getPanic "ForeignDecl" -+ -+instance Binary (DefaultDecl GhcSe) where -+ put_ bh d = case d of -+ DefaultDecl a -> put_ bh a -+ get bh = DefaultDecl <$> get bh -+ -+instance Binary (TyClDecl GhcSe) where -+ put_ bh d = case d of -+ FamDecl a -> -+ putByte bh 0 >> put_ bh a -+ SynDecl a b c d e -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ DataDecl a b c d e f -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e >> put_ bh f -+ ClassDecl a b c d e f g h i j k -> -+ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e >> put_ bh f -+ >> put_ bh g >> put_ bh h >> put_ bh i -+ >> put_ bh j >> put_ bh k -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FamDecl <$> get bh -+ 1 -> SynDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ 2 -> DataDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ 3 -> ClassDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh -+ _ -> getPanic "TyClDecl" -+ -+instance Binary DocDecl where -+ put_ bh d = case d of -+ DocCommentNext a -> putByte bh 0 >> put_ bh a -+ DocCommentPrev a -> putByte bh 1 >> put_ bh a -+ DocCommentNamed a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ DocGroup a b -> putByte bh 3 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> DocCommentNext <$> get bh -+ 1 -> DocCommentPrev <$> get bh -+ 2 -> DocCommentNamed <$> get bh <*> get bh -+ 3 -> DocGroup <$> get bh <*> get bh -+ _ -> getPanic "DocDecl" -+ -+instance Binary (WarnDecls GhcSe) where -+ put_ bh (Warnings a b) = put_ bh a >> put_ bh b -+ get bh = Warnings <$> get bh <*> get bh -+ -+instance Binary (WarnDecl GhcSe) where -+ put_ bh (Warning a b) = put_ bh a >> put_ bh b -+ get bh = Warning <$> get bh <*> get bh -+ -+instance Binary (RoleAnnotDecl GhcSe) where -+ put_ bh (RoleAnnotDecl a b) = put_ bh a >> put_ bh b -+ get bh = RoleAnnotDecl <$> get bh <*> get bh -+ -+instance Binary (RuleDecls GhcSe) where -+ put_ bh (HsRules a b) = put_ bh a >> put_ bh b -+ get bh = HsRules <$> get bh <*> get bh -+ -+instance Binary (RuleDecl GhcSe) where -+ put_ bh (HsRule a b c d e f g) = -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g -+ get bh = HsRule <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh -+ -+instance Binary (AnnDecl GhcSe) where -+ put_ bh (HsAnnotation a b c) = put_ bh a >> put_ bh b >> put_ bh c -+ get bh = HsAnnotation <$> get bh <*> get bh <*> get bh -+ -+instance Binary (SpliceDecl GhcSe) where -+ put_ bh (SpliceDecl a b) = put_ bh a >> put_ bh b -+ get bh = SpliceDecl <$> get bh <*> get bh -+ -+instance Binary a => Binary (Tickish a) where -+ put_ bh t = case t of -+ ProfNote a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ HpcTick a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ Breakpoint a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ SourceNote a b -> -+ putByte bh 3 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ProfNote <$> get bh <*> get bh <*> get bh -+ 1 -> HpcTick <$> get bh <*> get bh -+ 2 -> Breakpoint <$> get bh <*> get bh -+ 3 -> SourceNote <$> get bh <*> get bh -+ _ -> getPanic "Tickish" -+ -+instance Binary SpliceExplicitFlag where -+ put_ bh f = putByte bh $ case f of -+ ExplicitSplice -> 0 -+ ImplicitSplice -> 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure ExplicitSplice -+ 1 -> pure ImplicitSplice -+ _ -> getPanic "SpliceExplicitFlag" -+ -+instance Binary SpliceDecoration where -+ put_ bh d = putByte bh $ case d of -+ HasParens -> 0 -+ HasDollar -> 1 -+ NoParens -> 2 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure HasParens -+ 1 -> pure HasDollar -+ 2 -> pure NoParens -+ _ -> getPanic "SpliceDecoration" -+ -+instance Binary (HsSplice GhcSe) where -+ put_ bh s = case s of -+ HsTypedSplice a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsUntypedSplice a b c -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsQuasiQuote a b c d -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ HsSpliced {} -> putPanic "HsSplice" "HsSpliced" -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsTypedSplice <$> get bh <*> get bh <*> get bh -+ 1 -> HsUntypedSplice <$> get bh <*> get bh <*> get bh -+ 2 -> HsQuasiQuote <$> get bh <*> get bh <*> get bh <*> get bh -+ _ -> getPanic "HsSplice" -+ -+instance Binary (AnnProvenance SeName) where -+ put_ bh p = case p of -+ ValueAnnProvenance a -> putByte bh 0 >> put_ bh a -+ TypeAnnProvenance a -> putByte bh 1 >> put_ bh a -+ ModuleAnnProvenance -> putByte bh 2 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ValueAnnProvenance <$> get bh -+ 1 -> TypeAnnProvenance <$> get bh -+ 2 -> pure ModuleAnnProvenance -+ _ -> getPanic "AnnProvenance" -+ -+instance Binary ForeignImport where -+ put_ bh (CImport a b c d e) = -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e -+ get bh = CImport <$> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ -+instance Binary CImportSpec where -+ put_ bh s = case s of -+ CLabel a -> putByte bh 0 >> put_ bh a -+ CFunction a -> putByte bh 1 >> put_ bh a -+ CWrapper -> putByte bh 2 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> CLabel <$> get bh -+ 1 -> CFunction <$> get bh -+ 2 -> pure CWrapper -+ _ -> getPanic "CImportSpec" -+ -+instance Binary ForeignExport where -+ put_ bh (CExport a b) = put_ bh a >> put_ bh b -+ get bh = CExport <$> get bh <*> get bh -+ -+instance Binary (RuleBndr GhcSe) where -+ put_ bh b = case b of -+ RuleBndr a -> putByte bh 0 >> put_ bh a -+ RuleBndrSig a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> RuleBndr <$> get bh -+ 1 -> RuleBndrSig <$> get bh <*> get bh -+ _ -> getPanic "RuleBndr" -+ -+instance (Binary a, Binary b) => Binary (FamEqn GhcSe a b) where -+ put_ bh e = case e of -+ FamEqn a b c d -> -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ get bh = FamEqn <$> get bh <*> get bh <*> get bh <*> get bh -+ -+instance Binary (HsDataDefn GhcSe) where -+ put_ bh d = case d of -+ HsDataDefn a b c d e f -> -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f -+ get bh = HsDataDefn <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ -+instance Binary NewOrData where -+ put_ bh a = putByte bh (case a of -+ NewType -> 0 -+ DataType -> 1) -+ get bh = getByte bh >>= \b -> case b of -+ 0 -> pure NewType -+ 1 -> pure DataType -+ _ -> getPanic "NewOrData" -+ -+instance Binary (HsDerivingClause GhcSe) where -+ put_ bh c = case c of -+ HsDerivingClause a b -> -+ put_ bh a >> put_ bh b -+ get bh = HsDerivingClause <$> get bh <*> get bh -+ -+instance Binary (ConDecl GhcSe) where -+ put_ bh d = case d of -+ ConDeclGADT a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ ConDeclH98 a b c d e -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ConDeclGADT <$> get bh <*> get bh <*> get bh -+ 1 -> ConDeclH98 <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ _ -> getPanic "ConDecl" -+ -+ -+instance Binary (FamilyDecl GhcSe) where -+ put_ bh d = case d of -+ FamilyDecl a b c d e f -> -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d >> put_ bh e >> put_ bh f -+ -+ get bh = FamilyDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh -+ -+instance Binary (InjectivityAnn GhcSe) where -+ put_ bh a = case a of -+ InjectivityAnn a b -> put_ bh a >> put_ bh b -+ get bh = InjectivityAnn <$> get bh <*> get bh -+ -+instance Binary (FamilyInfo GhcSe) where -+ put_ bh i = case i of -+ DataFamily -> -+ putByte bh 0 -+ OpenTypeFamily -> -+ putByte bh 1 -+ ClosedTypeFamily a -> -+ putByte bh 2 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure DataFamily -+ 1 -> pure OpenTypeFamily -+ 2 -> ClosedTypeFamily <$> get bh -+ _ -> getPanic "FamilyInfo" -+ -+instance Binary (FamilyResultSig GhcSe) where -+ put_ bh s = case s of -+ NoSig -> -+ putByte bh 0 -+ KindSig a -> -+ putByte bh 1 >> put_ bh a -+ TyVarSig a -> -+ putByte bh 2 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure NoSig -+ 1 -> KindSig <$> get bh -+ 2 -> TyVarSig <$> get bh -+ _ -> getPanic "FamilyResultSig" -+ -+instance Binary (InstDecl GhcSe) where -+ put_ bh d = case d of -+ ClsInstD a -> -+ putByte bh 0 >> put_ bh a -+ DataFamInstD a -> -+ putByte bh 1 >> put_ bh a -+ TyFamInstD a -> -+ putByte bh 2 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ClsInstD <$> get bh -+ 1 -> DataFamInstD <$> get bh -+ 2 -> TyFamInstD <$> get bh -+ _ -> getPanic "InstDecl" -+ -+instance Binary (ClsInstDecl GhcSe) where -+ put_ bh d = case d of -+ ClsInstDecl a b c d e f -> -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f -+ get bh = ClsInstDecl <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ -+instance Binary (DataFamInstDecl GhcSe) where -+ put_ bh (DataFamInstDecl a) = put_ bh a -+ get bh = DataFamInstDecl <$> get bh -+ -+instance Binary (TyFamInstDecl GhcSe) where -+ put_ bh (TyFamInstDecl a) = put_ bh a -+ get bh = TyFamInstDecl <$> get bh -+ -+instance Binary (DerivDecl GhcSe) where -+ put_ bh d = case d of -+ DerivDecl a b c -> -+ put_ bh a >> put_ bh b >> put_ bh c -+ get bh = DerivDecl <$> get bh <*> get bh <*> get bh -+ -+instance Binary DerivStrategy where -+ put_ bh s = putByte bh (case s of -+ StockStrategy -> 0 -+ AnyclassStrategy -> 1 -+ NewtypeStrategy -> 2) -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure StockStrategy -+ 1 -> pure AnyclassStrategy -+ 2 -> pure NewtypeStrategy -+ _ -> getPanic "DerivStrategy" -+ -+instance Binary HsSrcBang where -+ put_ bh (HsSrcBang a b c) = -+ put_ bh a >> put_ bh b >> put_ bh c -+ get bh = HsSrcBang <$> get bh <*> get bh <*> get bh -+ -+instance Binary RdrName where -+ put_ bh n = case n of -+ Unqual a -> putByte bh 0 >> put_ bh a -+ Qual a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ Orig a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ Exact a -+ | isExternalName a -> putByte bh 3 >> put_ bh a -+ | otherwise -> putByte bh (if isSystemName a then 4 else 5) -+ >> put_ bh (nameUnique a) >> put_ bh (nameOccName a) -+ >> put_ bh (nameSrcSpan a) -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> Unqual <$> get bh -+ 1 -> Qual <$> get bh <*> get bh -+ 2 -> Orig <$> get bh <*> get bh -+ 3 -> Exact <$> get bh -+ 4 -> fmap Exact (mkSystemNameAt <$> get bh <*> get bh <*> get bh) -+ 5 -> fmap Exact (mkInternalName <$> get bh <*> get bh <*> get bh) -+ _ -> getPanic "RdrName" -+ -+-- * HsDoc -+ -+instance Binary HsDocString where -+ put_ bh (HsDocString s) = put_ bh s -+ get bh = HsDocString <$> get bh -+ -+-- * HsLit -+ -+instance Binary (HsLit GhcSe) where -+ put_ bh lit -+ = case lit of -+ HsChar a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ HsCharPrim a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ HsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ HsStringPrim a b -> putByte bh 3 >> put_ bh a >> put_ bh b -+ HsInt a b -> putByte bh 4 >> put_ bh a >> put_ bh b -+ HsIntPrim a b -> putByte bh 5 >> put_ bh a >> put_ bh b -+ HsWordPrim a b -> putByte bh 6 >> put_ bh a >> put_ bh b -+ HsInt64Prim a b -> putByte bh 7 >> put_ bh a >> put_ bh b -+ HsWord64Prim a b -> putByte bh 8 >> put_ bh a >> put_ bh b -+ HsInteger a b c -> putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsRat a b c -> putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsFloatPrim a b -> putByte bh 11 >> put_ bh a >> put_ bh b -+ HsDoublePrim a b -> putByte bh 12 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsChar <$> get bh <*> get bh -+ 1 -> HsCharPrim <$> get bh <*> get bh -+ 2 -> HsString <$> get bh <*> get bh -+ 3 -> HsStringPrim <$> get bh <*> get bh -+ 4 -> HsInt <$> get bh <*> get bh -+ 5 -> HsIntPrim <$> get bh <*> get bh -+ 6 -> HsWordPrim <$> get bh <*> get bh -+ 7 -> HsInt64Prim <$> get bh <*> get bh -+ 8 -> HsWord64Prim <$> get bh <*> get bh -+ 9 -> HsInteger <$> get bh <*> get bh <*> get bh -+ 10 -> HsRat <$> get bh <*> get bh <*> get bh -+ 11 -> HsFloatPrim <$> get bh <*> get bh -+ 12 -> HsDoublePrim <$> get bh <*> get bh -+ _ -> getPanic "Binary HsLit.get: unknown tag" -+ -+instance Binary (HsOverLit GhcSe) where -+ put_ bh lit = case lit of -+ OverLit a b c d -> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ get bh = OverLit <$> get bh <*> get bh <*> get bh <*> get bh -+ -+instance Binary OverLitVal where -+ put_ bh v -+ = case v of -+ HsIntegral a -> putByte bh 0 >> put_ bh a -+ HsFractional a -> putByte bh 1 >> put_ bh a -+ HsIsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsIntegral <$> get bh -+ 1 -> HsFractional <$> get bh -+ 2 -> HsIsString <$> get bh <*> get bh -+ _ -> getPanic "OverLitVal" -+ -+instance Binary PlaceHolder where -+ put_ _ _ = return () -+ get _ = pure PlaceHolder +diff --git a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs +deleted file mode 100644 +index 839564fbfe..0000000000 +--- a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs ++++ /dev/null +@@ -1,812 +0,0 @@ +-{-# LANGUAGE GADTs #-} +-module HsExprBin_ConversionPS2SE where +- +-import Control.Applicative +-import Data.Traversable +- +-import Bag (mapBagM) +-import Class +-import CoreSyn ( Tickish(..) ) +-import GhcPrelude +-import HsBinds +-import HsDecls +-import HsExpr +-import HsExprBin_Conversions +-import HsExtension +-import HsLit +-import HsPat +-import HsTypes +- +--- * Conversion from serialisable ASTs to parsed ASTs +- +-cvLHsDecl :: LHsDecl GhcPs -> Conv (LHsDecl GhcSe) +-cvLHsDecl = traverse cvHsDecl +- +-cvHsDecl :: HsDecl GhcPs -> Conv (HsDecl GhcSe) +-cvHsDecl (TyClD a b) = TyClD <$> pure a <*> cvTyClDecl b +-cvHsDecl (InstD a b) = InstD <$> pure a <*> cvInstDecl b +-cvHsDecl (DerivD a b) = DerivD <$> pure a <*> cvDerivDecl b +-cvHsDecl (ValD a b) = ValD <$> pure a <*> cvHsBindLR b +-cvHsDecl (SigD a b) = SigD <$> pure a <*> cvSig b +-cvHsDecl (DefD a b) = DefD <$> pure a <*> cvDefaultDecl b +-cvHsDecl (ForD a b) = ForD <$> pure a <*> cvForeignDecl b +-cvHsDecl (WarningD a b) = WarningD <$> pure a <*> cvWarningDecls b +-cvHsDecl (RoleAnnotD a b) = RoleAnnotD <$> pure a <*> cvRoleAnnotDecl b +-cvHsDecl (AnnD a b) = AnnD <$> pure a <*> cvAnnDecl b +-cvHsDecl (RuleD a b) = RuleD <$> pure a <*> cvRuleDecls b +-cvHsDecl (SpliceD a b) = SpliceD <$> pure a <*> cvSpliceDecl b +-cvHsDecl (DocD a b) = pure (DocD a b) +-cvHsDecl (XHsDecl a) = pure (XHsDecl a) +- +-cvAnnDecl :: AnnDecl GhcPs -> Conv (AnnDecl GhcSe) +-cvAnnDecl (HsAnnotation a b c d) = +- HsAnnotation a b <$> cvAnnProvenance c <*> cvLHsExpr d +-cvAnnDecl (XAnnDecl a) = pure (XAnnDecl a) +- +-cvInstDecl :: InstDecl GhcPs -> Conv (InstDecl GhcSe) +-cvInstDecl (ClsInstD a b) = ClsInstD a <$> cvClsInstDecl b +-cvInstDecl (DataFamInstD a b) = DataFamInstD a <$> cvDataFamInstDecl b +-cvInstDecl (TyFamInstD a b) = TyFamInstD a <$> cvTyFamInstDecl b +-cvInstDecl (XInstDecl a) = pure (XInstDecl a) +- +-cvClsInstDecl :: ClsInstDecl GhcPs -> Conv (ClsInstDecl GhcSe) +-cvClsInstDecl (ClsInstDecl a b c d e f g) = +- ClsInstDecl a +- <$> cvHsImplicitBndrs (traverse cvType) b +- <*> mapBagM (traverse cvHsBindLR) c +- <*> traverse (traverse cvSig) d +- <*> traverse (traverse cvTyFamInstDecl) e +- <*> traverse (traverse cvDataFamInstDecl) f +- <*> pure g +-cvClsInstDecl (XClsInstDecl a) = pure (XClsInstDecl a) +- +-cvDerivDecl :: DerivDecl GhcPs -> Conv (DerivDecl GhcSe) +-cvDerivDecl (DerivDecl a b c d) = +- DerivDecl a <$> cvHsWildCardBndrs (cvHsImplicitBndrs $ traverse cvType) b +- <*> traverse (traverse cvDerivStrategy) c +- <*> pure d +-cvDerivDecl (XDerivDecl a) = pure (XDerivDecl a) +- +-cvDerivStrategy +- :: DerivStrategy GhcPs -> Conv (DerivStrategy GhcSe) +-cvDerivStrategy StockStrategy = pure StockStrategy +-cvDerivStrategy AnyclassStrategy = pure AnyclassStrategy +-cvDerivStrategy NewtypeStrategy = pure NewtypeStrategy +-cvDerivStrategy (ViaStrategy a) = ViaStrategy +- <$> cvHsImplicitBndrs (traverse cvType) a +- +-cvTyClDecl :: TyClDecl GhcPs -> Conv (TyClDecl GhcSe) +-cvTyClDecl (FamDecl a b) = FamDecl <$> pure a <*> cvFamilyDecl b +-cvTyClDecl (SynDecl a b c d e) = +- SynDecl a +- <$> convertName b +- <*> cvLHsQTyVars c <*> pure d +- <*> traverse cvType e +-cvTyClDecl (DataDecl a b c d e) = +- DataDecl a +- <$> convertName b +- <*> cvLHsQTyVars c <*> pure d +- <*> cvHsDataDefn e +-cvTyClDecl (ClassDecl a b c d e f g h i j k) = +- ClassDecl a +- <$> traverse (traverse (traverse cvType)) b +- <*> convertName c +- <*> cvLHsQTyVars d +- <*> pure e +- <*> traverse (traverse cvFunDep) f +- <*> traverse (traverse cvSig) g +- <*> mapBagM (traverse cvHsBindLR) h +- <*> traverse (traverse cvFamilyDecl) i +- <*> traverse (traverse $ cvFamEqn cvLHsQTyVars (traverse cvType)) j +- <*> pure k +-cvTyClDecl (XTyClDecl a) = pure (XTyClDecl a) +- +-cvRoleAnnotDecl :: RoleAnnotDecl GhcPs -> Conv (RoleAnnotDecl GhcSe) +-cvRoleAnnotDecl (RoleAnnotDecl a b c) = +- RoleAnnotDecl a <$> convertName b <*> pure c +-cvRoleAnnotDecl (XRoleAnnotDecl a) = pure (XRoleAnnotDecl a) +- +-cvRuleDecls :: RuleDecls GhcPs -> Conv (RuleDecls GhcSe) +-cvRuleDecls (HsRules a b c) = HsRules a b <$> traverse (traverse cvRuleDecl) c +-cvRuleDecls (XRuleDecls a) = pure (XRuleDecls a) +- +-cvRuleDecl :: RuleDecl GhcPs -> Conv (RuleDecl GhcSe) +-cvRuleDecl (HsRule a b c d e f) = +- HsRule a b c <$> traverse (traverse cvRuleBndr) d +- <*> cvLHsExpr e <*> cvLHsExpr f +-cvRuleDecl (XRuleDecl a) = pure (XRuleDecl a) +- +-cvSpliceDecl :: SpliceDecl GhcPs -> Conv (SpliceDecl GhcSe) +-cvSpliceDecl (SpliceDecl a b c) = +- SpliceDecl a <$> traverse cvHsSplice b <*> pure c +-cvSpliceDecl (XSpliceDecl a) = pure (XSpliceDecl a) +- +-cvHsSplice :: HsSplice GhcPs -> Conv (HsSplice GhcSe) +-cvHsSplice (HsTypedSplice a b c d) = +- HsTypedSplice a b <$> convertName c <*> cvLHsExpr d +-cvHsSplice (HsUntypedSplice a b c d) = +- HsUntypedSplice a b <$> convertName c <*> cvLHsExpr d +-cvHsSplice (HsQuasiQuote a b c d e) = +- HsQuasiQuote a <$> convertName b <*> convertName c <*> pure d <*> pure e +-cvHsSplice (HsSpliced {}) = +- unsupported "HsSpliced" "HsSplice" (error "") +-cvHsSplice (XSplice a) = pure (XSplice a) +- +-cvRuleBndr :: RuleBndr GhcPs -> Conv (RuleBndr GhcSe) +-cvRuleBndr (RuleBndr a b) = RuleBndr a <$> convertName b +-cvRuleBndr (RuleBndrSig a b c) = +- RuleBndrSig a <$> convertName b <*> cvHsSigWcType c +-cvRuleBndr (XRuleBndr a) = pure (XRuleBndr a) +- +-cvFamEqn +- :: ( XCFamEqn GhcPs a b ~ XCFamEqn GhcSe c d +- , XXFamEqn GhcPs a b ~ XXFamEqn GhcSe c d +- ) +- => (a -> Conv c) +- -> (b -> Conv d) +- -> FamEqn GhcPs a b +- -> Conv (FamEqn GhcSe c d) +-cvFamEqn goPats goRhs (FamEqn a b c d e) = +- FamEqn a <$> convertName b <*> goPats c <*> pure d <*> goRhs e +-cvFamEqn _ _ (XFamEqn a) = pure (XFamEqn a) +- +-cvFamilyDecl :: FamilyDecl GhcPs -> Conv (FamilyDecl GhcSe) +-cvFamilyDecl (FamilyDecl a b c d e f g) = +- FamilyDecl a +- <$> cvFamilyInfo b <*> convertName c +- <*> cvLHsQTyVars d <*> pure e +- <*> traverse cvFamilyResultSig f +- <*> traverse (traverse cvInjectivityAnn) g +-cvFamilyDecl (XFamilyDecl a) = pure (XFamilyDecl a) +- +-cvAnnProvenance :: ConvertName a b => AnnProvenance a -> Conv (AnnProvenance b) +-cvAnnProvenance (ValueAnnProvenance a) = ValueAnnProvenance <$> convertName a +-cvAnnProvenance (TypeAnnProvenance a) = TypeAnnProvenance <$> convertName a +-cvAnnProvenance ModuleAnnProvenance = pure ModuleAnnProvenance +- +-cvInjectivityAnn +- :: InjectivityAnn GhcPs -> Conv (InjectivityAnn GhcSe) +-cvInjectivityAnn (InjectivityAnn a b) = +- InjectivityAnn <$> convertName a <*> convertName b +- +-cvFamilyResultSig +- :: FamilyResultSig GhcPs -> Conv (FamilyResultSig GhcSe) +-cvFamilyResultSig (NoSig a) = pure (NoSig a) +-cvFamilyResultSig (KindSig a b) = KindSig a <$> traverse cvType b +-cvFamilyResultSig (TyVarSig a b) = TyVarSig a <$> traverse cvHsTyVarBndr b +-cvFamilyResultSig (XFamilyResultSig a) = pure (XFamilyResultSig a) +- +-cvFamilyInfo +- :: FamilyInfo GhcPs -> Conv (FamilyInfo GhcSe) +-cvFamilyInfo DataFamily = pure DataFamily +-cvFamilyInfo OpenTypeFamily = pure OpenTypeFamily +-cvFamilyInfo (ClosedTypeFamily a) = +- ClosedTypeFamily <$> traverse (traverse (traverse (cvFamInstEqn (traverse cvType)))) a +- +-cvFamInstEqn +- :: ( XCFamEqn GhcPs (HsTyPats GhcPs) a +- ~ XCFamEqn GhcSe (HsTyPats GhcSe) b +- , XHsIB GhcPs (FamEqn GhcPs (HsTyPats p) a) +- ~ XHsIB GhcSe (FamEqn GhcSe (HsTyPats GhcSe) b) +- , XXFamEqn GhcPs (HsTyPats GhcPs) a +- ~ XXFamEqn GhcSe (HsTyPats GhcSe) b +- , XXHsImplicitBndrs GhcPs (FamEqn GhcPs (HsTyPats GhcPs) a) +- ~ XXHsImplicitBndrs GhcSe (FamEqn GhcSe (HsTyPats GhcSe) b) +- ) +- => (a -> Conv b) +- -> FamInstEqn GhcPs a +- -> Conv (FamInstEqn GhcSe b) +-cvFamInstEqn f = cvHsImplicitBndrs (cvFamEqn (traverse (traverse cvType)) f) +- +-cvFunDep :: ConvertName a b => FunDep a -> Conv (FunDep b) +-cvFunDep (xs, ys) = (,) <$> convertName xs <*> convertName ys +- +-cvLHsQTyVars :: LHsQTyVars GhcPs -> Conv (LHsQTyVars GhcSe) +-cvLHsQTyVars (HsQTvs a b) = HsQTvs a <$> traverse (traverse cvHsTyVarBndr) b +-cvLHsQTyVars (XLHsQTyVars a) = pure (XLHsQTyVars a) +- +-cvForeignDecl :: ForeignDecl GhcPs -> Conv (ForeignDecl GhcSe) +-cvForeignDecl (ForeignImport a b c d) = +- ForeignImport a +- <$> convertName b +- <*> cvHsImplicitBndrs (traverse cvType) c +- <*> pure d +-cvForeignDecl (ForeignExport a b c d) = +- ForeignExport a +- <$> convertName b +- <*> cvHsImplicitBndrs (traverse cvType) c +- <*> pure d +-cvForeignDecl (XForeignDecl a) = pure (XForeignDecl a) +- +-cvDefaultDecl :: DefaultDecl GhcPs -> Conv (DefaultDecl GhcSe) +-cvDefaultDecl (DefaultDecl a b) = DefaultDecl a <$> traverse (traverse cvType) b +-cvDefaultDecl (XDefaultDecl a) = pure (XDefaultDecl a) +- +-cvTyFamInstDecl +- :: TyFamInstDecl GhcPs -> Conv (TyFamInstDecl GhcSe) +-cvTyFamInstDecl (TyFamInstDecl d) = +- TyFamInstDecl <$> cvFamInstEqn (traverse cvType) d +- +-cvDataFamInstDecl +- :: DataFamInstDecl GhcPs -> Conv (DataFamInstDecl GhcSe) +-cvDataFamInstDecl (DataFamInstDecl d) = +- DataFamInstDecl <$> cvFamInstEqn cvHsDataDefn d +- +-cvHsDataDefn :: HsDataDefn GhcPs -> Conv (HsDataDefn GhcSe) +-cvHsDataDefn (HsDataDefn a b c d e f g) = +- HsDataDefn a b +- <$> traverse (traverse (traverse cvType)) c <*> pure d +- <*> traverse (traverse cvType) e +- <*> traverse (traverse cvConDecl) f <*> cvHsDeriving g +-cvHsDataDefn (XHsDataDefn a) = pure (XHsDataDefn a) +- +-cvConDecl :: ConDecl GhcPs -> Conv (ConDecl GhcSe) +-cvConDecl (ConDeclGADT a b c d e f g h) = +- ConDeclGADT a +- <$> convertName b +- <*> pure c +- <*> cvLHsQTyVars d +- <*> traverse (traverse (traverse (traverse cvType))) e +- <*> cvHsConDeclDetails f +- <*> traverse cvType g +- <*> pure h +-cvConDecl (ConDeclH98 a b c d e f g) = +- ConDeclH98 a +- <$> convertName b +- <*> pure c +- <*> traverse (traverse cvHsTyVarBndr) d +- <*> traverse (traverse (traverse (traverse cvType))) e +- <*> cvHsConDeclDetails f +- <*> pure g +-cvConDecl (XConDecl a) = pure (XConDecl a) +- +-cvHsDeriving :: HsDeriving GhcPs -> Conv (HsDeriving GhcSe) +-cvHsDeriving = traverse (traverse (traverse cvHsDerivingClause)) +- +-cvHsDerivingClause +- :: HsDerivingClause GhcPs -> Conv (HsDerivingClause GhcSe) +-cvHsDerivingClause (HsDerivingClause a b c) = +- HsDerivingClause a +- <$> traverse (traverse cvDerivStrategy) b +- <*> traverse (traverse (cvHsImplicitBndrs (traverse cvType))) c +-cvHsDerivingClause (XHsDerivingClause a) = pure (XHsDerivingClause a) +- +-cvHsConDeclDetails +- :: HsConDeclDetails GhcPs -> Conv (HsConDeclDetails GhcSe) +-cvHsConDeclDetails = +- cvHsConDetails (traverse cvType) +- (traverse (traverse (traverse cvConDeclField))) +- +-cvHsConDetails +- :: (a -> Conv c) -> (b -> Conv d) -> HsConDetails a b -> Conv (HsConDetails c d) +-cvHsConDetails f _ (PrefixCon a) = PrefixCon <$> traverse f a +-cvHsConDetails _ g (RecCon a) = RecCon <$> g a +-cvHsConDetails f _ (InfixCon a b) = InfixCon <$> f a <*> f b +- +-cvConDeclField :: ConDeclField GhcPs -> Conv (ConDeclField GhcSe) +-cvConDeclField (ConDeclField a b c d) = +- ConDeclField a <$> traverse (traverse cvFieldOcc) b <*> traverse cvType c +- <*> pure d +-cvConDeclField (XConDeclField a) = pure (XConDeclField a) +- +-cvWarningDecls :: WarnDecls GhcPs -> Conv (WarnDecls GhcSe) +-cvWarningDecls (Warnings a b c) = +- Warnings a b <$> traverse (traverse cvWarningDecl) c +-cvWarningDecls (XWarnDecls a) = pure (XWarnDecls a) +- +-cvWarningDecl :: WarnDecl GhcPs -> Conv (WarnDecl GhcSe) +-cvWarningDecl (Warning a b c) = Warning a <$> convertName b <*> pure c +-cvWarningDecl (XWarnDecl a) = pure (XWarnDecl a) +- +--- expressions +- +-cvLHsExpr :: LHsExpr GhcPs -> Conv (LHsExpr GhcSe) +-cvLHsExpr = traverse cvHsExpr +- +-cvHsExpr :: HsExpr GhcPs -> Conv (HsExpr GhcSe) +-cvHsExpr e = case e of +- HsVar a b -> HsVar a <$> convertName b +- HsUnboundVar a b -> pure (HsUnboundVar a b) +- HsConLikeOut a b -> pure (HsConLikeOut a b) +- HsRecFld a b -> HsRecFld a <$> cvAFieldOcc b +- HsOverLabel a b c -> HsOverLabel a <$> convertName b <*> pure c +- HsIPVar a b -> pure (HsIPVar a b) +- HsOverLit a b -> HsOverLit a <$> cvOverLit b +- HsLit a b -> HsLit a <$> cvLit b +- HsLam a b -> HsLam a <$> cvMatchGroup cvLHsExpr b +- HsLamCase a b -> HsLamCase a <$> cvMatchGroup cvLHsExpr b +- HsApp a b c -> HsApp a <$> cvLHsExpr b <*> cvLHsExpr c +- HsAppType a b -> HsAppType <$> cvLHsWcType a <*> cvLHsExpr b +- OpApp a b c d -> OpApp a <$> cvLHsExpr b <*> cvLHsExpr c <*> cvLHsExpr d +- NegApp a b c -> NegApp a <$> cvLHsExpr b <*> cvSyntaxExpr c +- HsPar a b -> HsPar a <$> cvLHsExpr b +- SectionL a b c -> SectionL a <$> cvLHsExpr b <*> cvLHsExpr c +- SectionR a b c -> SectionR a <$> cvLHsExpr b <*> cvLHsExpr c +- ExplicitTuple a b c -> ExplicitTuple a <$> traverse (traverse cvHsTupArg) b +- <*> pure c +- ExplicitSum a b c d -> ExplicitSum a b c <$> cvLHsExpr d +- ExplicitList a b c -> ExplicitList a <$> traverse cvSyntaxExpr b <*> traverse cvLHsExpr c +- HsCase a b c -> HsCase a <$> cvLHsExpr b <*> cvMatchGroup cvLHsExpr c +- HsIf a b c d e -> HsIf a <$> traverse cvSyntaxExpr b +- <*> cvLHsExpr c <*> cvLHsExpr d <*> cvLHsExpr e +- HsMultiIf a b -> HsMultiIf a <$> traverse (traverse (cvGRHS cvLHsExpr)) b +- HsLet a b c -> HsLet a <$> traverse cvHsLocalBinds b <*> cvLHsExpr c +- HsDo a b c -> HsDo a +- <$> convertName b <*> traverse (traverse (traverse (cvStmtLR cvLHsExpr))) c +- RecordCon a b c -> RecordCon a <$> convertName b <*> cvRecordBinds c +- RecordUpd a b c -> RecordUpd a <$> cvLHsExpr b +- <*> traverse (traverse cvHsRecUpdField) c +- ExprWithTySig a b -> ExprWithTySig <$> cvHsSigWcType a <*> cvLHsExpr b +- ArithSeq a b c -> ArithSeq a <$> traverse cvSyntaxExpr b <*> cvArithSeqInfo c +- HsSCC a b c d -> HsSCC a b c <$> cvLHsExpr d +- HsCoreAnn a b c d -> HsCoreAnn a b c <$> cvLHsExpr d +- HsStatic a b -> HsStatic a <$> cvLHsExpr b +- EWildPat a -> pure (EWildPat a) +- EAsPat a b c -> EAsPat a <$> convertName b <*> cvLHsExpr c +- EViewPat a b c -> EViewPat a <$> cvLHsExpr b <*> cvLHsExpr c +- ELazyPat a b -> ELazyPat a <$> cvLHsExpr b +- HsProc a b c -> HsProc a <$> traverse cvPat b <*> traverse cvHsCmdTop c +- HsBinTick a b c d -> HsBinTick a b c <$> cvLHsExpr d +- HsTickPragma a b c d e -> HsTickPragma a b c d <$> cvLHsExpr e +- HsSpliceE a b -> HsSpliceE a <$> cvHsSplice b +- HsBracket a b -> HsBracket a <$> cvHsBracket b +- HsTick a b c -> HsTick a <$> cvTickish b <*> cvLHsExpr c +- XExpr a -> pure (XExpr a) +- HsArrApp {} -> unsupported "HsArrApp" "HsExpr" (error "") +- HsArrForm {} -> unsupported "HsArrForm" "HsExpr" (error "") +- HsWrap {} -> unsupported "HsWrap" "HsExpr" (error "") +- HsRnBracketOut {} -> unsupported "HsRnBracketOut" "HsExpr" (error "") +- HsTcBracketOut {} -> unsupported "HsTcBracketOut" "HsExpr" (error "") +- +-cvHsBracket :: HsBracket GhcPs -> Conv (HsBracket GhcSe) +-cvHsBracket (ExpBr a b) = ExpBr a <$> cvLHsExpr b +-cvHsBracket (PatBr a b) = PatBr a <$> traverse cvPat b +-cvHsBracket (DecBrL a b) = DecBrL a <$> traverse (traverse cvHsDecl) b +-cvHsBracket (DecBrG a b) = DecBrG a <$> cvHsGroup b +-cvHsBracket (TypBr a b) = TypBr a <$> traverse cvType b +-cvHsBracket (VarBr a b c) = VarBr a b <$> convertName c +-cvHsBracket (TExpBr a b) = TExpBr a <$> cvLHsExpr b +-cvHsBracket (XBracket a) = pure (XBracket a) +- +-cvTickish :: ConvertName a b => Tickish a -> Conv (Tickish b) +-cvTickish (ProfNote a b c) = pure (ProfNote a b c) +-cvTickish (HpcTick a b) = pure (HpcTick a b) +-cvTickish (Breakpoint a b) = Breakpoint a <$> convertName b +-cvTickish (SourceNote a b) = pure (SourceNote a b) +- +-cvHsGroup :: HsGroup GhcPs -> Conv (HsGroup GhcSe) +-cvHsGroup (HsGroup a b c d e f g h i j k l) = HsGroup a +- <$> cvHsValBindsLR b <*> traverse (traverse cvSpliceDecl) c +- <*> traverse cvTyClGroup d +- <*> traverse (traverse cvDerivDecl) e +- <*> traverse (traverse cvFixitySig) f +- <*> traverse (traverse cvDefaultDecl) g +- <*> traverse (traverse cvForeignDecl) h +- <*> traverse (traverse cvWarningDecls) i +- <*> traverse (traverse cvAnnDecl) j +- <*> traverse (traverse cvRuleDecls) k +- <*> pure l +-cvHsGroup (XHsGroup a) = pure (XHsGroup a) +- +-cvTyClGroup :: TyClGroup GhcPs -> Conv (TyClGroup GhcSe) +-cvTyClGroup (TyClGroup a b c d) = TyClGroup a +- <$> traverse (traverse cvTyClDecl) b +- <*> traverse (traverse cvRoleAnnotDecl) c +- <*> traverse (traverse cvInstDecl) d +-cvTyClGroup (XTyClGroup a) = pure (XTyClGroup a) +- +-cvHsCmdTop :: HsCmdTop GhcPs -> Conv (HsCmdTop GhcSe) +-cvHsCmdTop (HsCmdTop a b) = HsCmdTop a <$> traverse cvHsCmd b +-cvHsCmdTop (XCmdTop a) = pure (XCmdTop a) +- +-cvHsCmd :: HsCmd GhcPs -> Conv (HsCmd GhcSe) +-cvHsCmd (HsCmdArrApp a b c d e) = HsCmdArrApp a +- <$> cvLHsExpr b <*> cvLHsExpr c <*> pure d <*> pure e +-cvHsCmd (HsCmdArrForm a b c d e) = HsCmdArrForm a +- <$> cvLHsExpr b <*> pure c <*> pure d +- <*> traverse (traverse cvHsCmdTop) e +-cvHsCmd (HsCmdApp a b c) = HsCmdApp a <$> traverse cvHsCmd b <*> cvLHsExpr c +-cvHsCmd (HsCmdLam a b) = HsCmdLam a <$> cvMatchGroup (traverse cvHsCmd) b +-cvHsCmd (HsCmdPar a b) = HsCmdPar a <$> traverse cvHsCmd b +-cvHsCmd (HsCmdCase a b c) = HsCmdCase a +- <$> cvLHsExpr b <*> cvMatchGroup (traverse cvHsCmd) c +-cvHsCmd (HsCmdIf a b c d e) = HsCmdIf a +- <$> traverse cvSyntaxExpr b +- <*> cvLHsExpr c +- <*> traverse cvHsCmd d +- <*> traverse cvHsCmd e +-cvHsCmd (HsCmdLet a b c) = HsCmdLet a +- <$> traverse cvHsLocalBinds b <*> traverse cvHsCmd c +-cvHsCmd (HsCmdDo a b) = HsCmdDo a +- <$> traverse (traverse (traverse (cvStmtLR (traverse cvHsCmd)))) b +-cvHsCmd (HsCmdWrap {}) = unsupported "HsCmdWrap" "HsCmd" (error "") +-cvHsCmd (XCmd a) = pure (XCmd a) +- +-cvArithSeqInfo :: ArithSeqInfo GhcPs -> Conv (ArithSeqInfo GhcSe) +-cvArithSeqInfo (From e) = From <$> cvLHsExpr e +-cvArithSeqInfo (FromThen a b) = FromThen <$> cvLHsExpr a <*> cvLHsExpr b +-cvArithSeqInfo (FromTo a b) = FromTo <$> cvLHsExpr a <*> cvLHsExpr b +-cvArithSeqInfo (FromThenTo a b c) = FromThenTo <$> cvLHsExpr a <*> cvLHsExpr b <*> cvLHsExpr c +- +-cvHsTupArg :: HsTupArg GhcPs -> Conv (HsTupArg GhcSe) +-cvHsTupArg (Present a b) = Present a <$> cvLHsExpr b +-cvHsTupArg (Missing a) = pure (Missing a) +-cvHsTupArg (XTupArg a) = pure (XTupArg a) +- +-cvAFieldOcc +- :: AmbiguousFieldOcc GhcPs -> Conv (AmbiguousFieldOcc GhcSe) +-cvAFieldOcc (Unambiguous a b) = Unambiguous a <$> convertName b +-cvAFieldOcc (Ambiguous a b) = Ambiguous a <$> convertName b +-cvAFieldOcc (XAmbiguousFieldOcc a) = pure (XAmbiguousFieldOcc a) +- +-cvOverLit :: HsOverLit GhcPs -> Conv (HsOverLit GhcSe) +-cvOverLit (OverLit a b c) = OverLit a b <$> cvHsExpr c +-cvOverLit (XOverLit a) = pure (XOverLit a) +- +-cvLit :: HsLit GhcPs -> Conv (HsLit GhcSe) +-cvLit (HsChar a b) = pure (HsChar a b) +-cvLit (HsCharPrim a b) = pure (HsCharPrim a b) +-cvLit (HsString a b) = pure (HsString a b) +-cvLit (HsStringPrim a b) = pure (HsStringPrim a b) +-cvLit (HsInt a b) = pure (HsInt a b) +-cvLit (HsIntPrim a b) = pure (HsIntPrim a b) +-cvLit (HsWordPrim a b) = pure (HsWordPrim a b) +-cvLit (HsInt64Prim a b) = pure (HsInt64Prim a b) +-cvLit (HsWord64Prim a b) = pure (HsWord64Prim a b) +-cvLit (HsInteger a b c) = HsInteger a b <$> convertType c +-cvLit (HsRat a b c) = HsRat a b <$> convertType c +-cvLit (HsFloatPrim a b) = pure (HsFloatPrim a b) +-cvLit (HsDoublePrim a b) = pure (HsDoublePrim a b) +-cvLit (XLit a) = pure (XLit a) +- +-cvMatchGroup +- :: ( XMG GhcPs a ~ XMG GhcSe b +- , XCMatch GhcPs a ~ XCMatch GhcSe b +- , XCGRHSs GhcPs a ~ XCGRHSs GhcSe b +- , XCGRHS GhcPs a ~ XCGRHS GhcSe b +- , XXMatchGroup GhcPs a ~ XXMatchGroup GhcSe b +- , XXMatch GhcPs a ~ XXMatch GhcSe b +- , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b +- , XXGRHS GhcPs a ~ XXGRHS GhcSe b +- ) +- => (a -> Conv b) -> MatchGroup GhcPs a -> Conv (MatchGroup GhcSe b) +-cvMatchGroup f (MG a b c) = MG a +- <$> traverse (traverse (traverse (cvMatch f))) b +- <*> pure c +-cvMatchGroup _ (XMatchGroup a) = pure (XMatchGroup a) +- +-cvMatch +- :: ( XCMatch GhcPs a ~ XCMatch GhcSe b +- , XCGRHSs GhcPs a ~ XCGRHSs GhcSe b +- , XCGRHS GhcPs a ~ XCGRHS GhcSe b +- , XXMatch GhcPs a ~ XXMatch GhcSe b +- , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b +- , XXGRHS GhcPs a ~ XXGRHS GhcSe b +- ) +- => (a -> Conv b) -> Match GhcPs a -> Conv (Match GhcSe b) +-cvMatch f (Match a b c d) = Match a +- <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d +-cvMatch _ (XMatch a) = pure (XMatch a) +- +-cvPat :: Pat GhcPs -> Conv (Pat GhcSe) +-cvPat (WildPat a) = pure (WildPat a) +-cvPat (VarPat a b) = VarPat a <$> convertName b +-cvPat (LazyPat a b) = LazyPat a <$> traverse cvPat b +-cvPat (AsPat a b c) = AsPat a <$> convertName b <*> traverse cvPat c +-cvPat (ParPat a b) = ParPat a <$> traverse cvPat b +-cvPat (BangPat a b) = BangPat a <$> traverse cvPat b +-cvPat (ListPat a b) = ListPat a +- <$> traverse (traverse cvPat) b +-cvPat (TuplePat a b c) = TuplePat a +- <$> traverse (traverse cvPat) b +- <*> pure c +-cvPat (SumPat a b c d) = SumPat a +- <$> traverse cvPat b +- <*> pure c <*> pure d +-cvPat (ConPatIn a b) = ConPatIn <$> convertName a <*> cvHsConPatDetails b +-cvPat (ViewPat a b c) = ViewPat a <$> cvLHsExpr b <*> traverse cvPat c +-cvPat (LitPat a b) = LitPat a <$> cvLit b +-cvPat (NPat a b c d) = NPat a +- <$> traverse cvOverLit b <*> traverse cvSyntaxExpr c +- <*> cvSyntaxExpr d +-cvPat (NPlusKPat a b c d e f) = NPlusKPat a +- <$> convertName b +- <*> traverse cvOverLit c <*> cvOverLit d +- <*> cvSyntaxExpr e <*> cvSyntaxExpr f +-cvPat (SigPat a b) = SigPat <$> cvHsSigWcType a <*> traverse cvPat b +-cvPat (SplicePat a b) = SplicePat a <$> cvHsSplice b +-cvPat (CoPat {}) = unsupported "CoPat" "Pat" (error "") +-cvPat (ConPatOut {}) = unsupported "ConPatOut" "Pat" (error "") +-cvPat (XPat a) = pure (XPat a) +- +-cvGRHSs +- :: ( XCGRHSs GhcPs a ~ XCGRHSs GhcSe b +- , XCGRHS GhcPs a ~ XCGRHS GhcSe b +- , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b +- , XXGRHS GhcPs a ~ XXGRHS GhcSe b +- ) +- => (a -> Conv b) -> GRHSs GhcPs a -> Conv (GRHSs GhcSe b) +-cvGRHSs f (GRHSs a b c) = GRHSs a +- <$> traverse (traverse (cvGRHS f)) b +- <*> traverse cvHsLocalBinds c +-cvGRHSs _ (XGRHSs a) = pure (XGRHSs a) +- +-cvGRHS +- :: ( XCGRHS GhcPs a ~ XCGRHS GhcSe b +- , XXGRHS GhcPs a ~ XXGRHS GhcSe b +- ) +- => (a -> Conv b) -> GRHS GhcPs a -> Conv (GRHS GhcSe b) +-cvGRHS f (GRHS a b c) = GRHS a +- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> f c +-cvGRHS _ (XGRHS a) = pure (XGRHS a) +- +-cvHsLocalBinds +- :: HsLocalBinds GhcPs -> Conv (HsLocalBinds GhcSe) +-cvHsLocalBinds (HsValBinds a b) = HsValBinds a <$> cvHsValBindsLR b +-cvHsLocalBinds (HsIPBinds a b) = HsIPBinds a <$> cvHsIPBinds b +-cvHsLocalBinds (EmptyLocalBinds a) = pure (EmptyLocalBinds a) +-cvHsLocalBinds (XHsLocalBindsLR a) = pure (XHsLocalBindsLR a) +- +-cvHsValBindsLR +- :: HsValBindsLR GhcPs GhcPs -> Conv (HsValBindsLR GhcSe GhcSe) +-cvHsValBindsLR (ValBinds a b c) = ValBinds a +- <$> mapBagM (traverse cvHsBindLR) b +- <*> traverse (traverse cvSig) c +-cvHsValBindsLR (XValBindsLR _) = +- unsupported "XValBindsLR" "HsValBindsLR" (error "") +- +-cvHsConPatDetails +- :: HsConPatDetails GhcPs -> Conv (HsConPatDetails GhcSe) +-cvHsConPatDetails (PrefixCon a) = PrefixCon <$> traverse (traverse cvPat) a +-cvHsConPatDetails (RecCon a) = RecCon <$> cvHsRecFieldsPat a +-cvHsConPatDetails (InfixCon a b) = InfixCon +- <$> traverse cvPat a <*> traverse cvPat b +- +-cvHsRecFields +- :: (thing -> Conv thing') +- -> HsRecFields GhcPs thing +- -> Conv (HsRecFields GhcSe thing') +-cvHsRecFields f (HsRecFields a b) = +- HsRecFields <$> traverse (traverse (cvHsRecField' cvFieldOcc f)) a <*> pure b +- +-cvHsRecField' +- :: (id -> Conv id') +- -> (thing -> Conv thing') +- -> HsRecField' id thing +- -> Conv (HsRecField' id' thing') +-cvHsRecField' f g (HsRecField a b c) = +- HsRecField <$> traverse f a <*> g b <*> pure c +- +-cvHsRecFieldsPat +- :: HsRecFields GhcPs (LPat GhcPs) -> Conv (HsRecFields GhcSe (LPat GhcSe)) +-cvHsRecFieldsPat = cvHsRecFields (traverse cvPat) +- +-cvHsRecUpdField +- :: HsRecUpdField GhcPs -> Conv (HsRecUpdField GhcSe) +-cvHsRecUpdField = cvHsRecField' cvAFieldOcc cvLHsExpr +- +-cvRecordBinds +- :: HsRecordBinds GhcPs -> Conv (HsRecordBinds GhcSe) +-cvRecordBinds = cvHsRecFields cvLHsExpr +- +-cvFieldOcc :: FieldOcc GhcPs -> Conv (FieldOcc GhcSe) +-cvFieldOcc (FieldOcc a b) = FieldOcc a <$> convertName b +-cvFieldOcc (XFieldOcc a) = pure (XFieldOcc a) +- +-cvStmtLR +- :: ( XLastStmt GhcPs GhcPs a ~ XLastStmt GhcSe GhcSe b +- , XBindStmt GhcPs GhcPs a ~ XBindStmt GhcSe GhcSe b +- , XBodyStmt GhcPs GhcPs a ~ XBodyStmt GhcSe GhcSe b +- , XApplicativeStmt GhcPs GhcPs a ~ XApplicativeStmt GhcSe GhcSe b +- , XLetStmt GhcPs GhcPs a ~ XLetStmt GhcSe GhcSe b +- , XRecStmt GhcPs GhcPs a ~ XRecStmt GhcSe GhcSe b +- , XParStmt GhcPs GhcPs a ~ XParStmt GhcSe GhcSe b +- , XTransStmt GhcPs GhcPs a ~ XTransStmt GhcSe GhcSe b +- , XXStmtLR GhcPs GhcPs a ~ XXStmtLR GhcSe GhcSe b +- ) +- => (a -> Conv b) -> StmtLR GhcPs GhcPs a -> Conv (StmtLR GhcSe GhcSe b) +-cvStmtLR k (LastStmt a b c d) = LastStmt a +- <$> k b <*> pure c <*> cvSyntaxExpr d +-cvStmtLR k (BindStmt a b c d e) = BindStmt a +- <$> traverse cvPat b <*> k c +- <*> cvSyntaxExpr d <*> cvSyntaxExpr e +-cvStmtLR k (BodyStmt a b c d) = BodyStmt a +- <$> k b <*> cvSyntaxExpr c +- <*> cvSyntaxExpr d +-cvStmtLR _ (ApplicativeStmt a b c) = ApplicativeStmt a +- <$> traverse +- (\(se, aa) -> (,) <$> cvSyntaxExpr se <*> cvApplicativeArg aa) +- b +- <*> traverse cvSyntaxExpr c +-cvStmtLR _ (LetStmt a b) = LetStmt a <$> traverse cvHsLocalBinds b +-cvStmtLR k (RecStmt a b c d e f g) = RecStmt a +- <$> traverse (traverse (cvStmtLR k)) b +- <*> convertName c +- <*> convertName d +- <*> cvSyntaxExpr e +- <*> cvSyntaxExpr f +- <*> cvSyntaxExpr g +-cvStmtLR _ (ParStmt a b c d) = ParStmt a +- <$> traverse cvParStmtBlock b +- <*> cvHsExpr c +- <*> cvSyntaxExpr d +-cvStmtLR _ (TransStmt a b c d e f g h i) = TransStmt a b +- <$> traverse (traverse (cvStmtLR cvLHsExpr)) c +- <*> traverse (\(x, y) -> (,) <$> convertName x <*> convertName y) d +- <*> cvLHsExpr e +- <*> traverse cvLHsExpr f +- <*> cvSyntaxExpr g +- <*> cvSyntaxExpr h +- <*> cvHsExpr i +-cvStmtLR _ (XStmtLR a) = pure (XStmtLR a) +- +-cvParStmtBlock +- :: ParStmtBlock GhcPs GhcPs -> Conv (ParStmtBlock GhcSe GhcSe) +-cvParStmtBlock (ParStmtBlock a b c d) = ParStmtBlock a +- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b +- <*> convertName c +- <*> cvSyntaxExpr d +-cvParStmtBlock (XParStmtBlock a) = pure (XParStmtBlock a) +- +-cvSyntaxExpr :: SyntaxExpr GhcPs -> Conv (SyntaxExpr GhcSe) +-cvSyntaxExpr (SyntaxExpr a b c) = +- SyntaxExpr <$> cvHsExpr a <*> pure b <*> pure c +- +-cvHsIPBinds +- :: HsIPBinds GhcPs -> Conv (HsIPBinds GhcSe) +-cvHsIPBinds (IPBinds a b) = IPBinds a <$> traverse (traverse cvIPBind) b +-cvHsIPBinds (XHsIPBinds a) = pure (XHsIPBinds a) +- +-cvIPBind :: IPBind GhcPs -> Conv (IPBind GhcSe) +-cvIPBind (IPBind a b c) = IPBind a <$> convertName b <*> cvLHsExpr c +-cvIPBind (XIPBind a) = pure (XIPBind a) +- +-cvHsBindLR +- :: HsBindLR GhcPs GhcPs -> Conv (HsBindLR GhcSe GhcSe) +-cvHsBindLR (FunBind a b c d e) = FunBind a +- <$> convertName b +- <*> cvMatchGroup cvLHsExpr c +- <*> pure d <*> pure e +-cvHsBindLR (PatBind a b c d ) = PatBind a +- <$> traverse cvPat b <*> cvGRHSs cvLHsExpr c <*> pure d +-cvHsBindLR (VarBind a b c d) = VarBind a +- <$> convertName b <*> cvLHsExpr c <*> pure d +-cvHsBindLR (PatSynBind a b) = PatSynBind a <$> cvPatSynBind b +-cvHsBindLR (AbsBinds {}) = +- unsupported "AbsBind" "HsBindLR" (error "") +-cvHsBindLR (XHsBindsLR a) = pure (XHsBindsLR a) +- +-cvHsWildCardBndrs +- :: ( XHsWC GhcPs thing ~ XHsWC GhcSe thing' +- , XXHsWildCardBndrs GhcPs thing ~ XXHsWildCardBndrs GhcSe thing' +- ) +- => (thing -> Conv thing') +- -> HsWildCardBndrs GhcPs thing +- -> Conv (HsWildCardBndrs GhcSe thing') +-cvHsWildCardBndrs thingF (HsWC a b) = HsWC a <$> thingF b +-cvHsWildCardBndrs _ (XHsWildCardBndrs a) = pure (XHsWildCardBndrs a) +- +-cvLHsWcType +- :: LHsWcType GhcPs -> Conv (LHsWcType GhcSe) +-cvLHsWcType = cvHsWildCardBndrs (traverse cvType) +- +-cvHsSigWcType +- :: LHsSigWcType GhcPs -> Conv (LHsSigWcType GhcSe) +-cvHsSigWcType = cvHsWildCardBndrs (cvHsImplicitBndrs (traverse cvType)) +- +-cvHsImplicitBndrs +- :: ( XHsIB GhcPs thing ~ XHsIB GhcSe thing' +- , XXHsImplicitBndrs GhcPs thing ~ XXHsImplicitBndrs GhcSe thing' +- ) +- => (thing -> Conv thing') +- -> HsImplicitBndrs GhcPs thing +- -> Conv (HsImplicitBndrs GhcSe thing') +-cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b +-cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) +- +-cvType :: HsType GhcPs -> Conv (HsType GhcSe) +-cvType (HsForAllTy a b c) = HsForAllTy a +- <$> traverse (traverse cvHsTyVarBndr) b +- <*> traverse cvType c +-cvType (HsQualTy a b c) = HsQualTy a +- <$> traverse (traverse (traverse cvType)) b +- <*> traverse cvType c +-cvType (HsTyVar a b c) = HsTyVar a b <$> convertName c +-cvType (HsAppTy a b c) = HsAppTy a +- <$> traverse cvType b +- <*> traverse cvType c +-cvType (HsFunTy a b c) = HsFunTy a +- <$> traverse cvType b +- <*> traverse cvType c +-cvType (HsListTy a b) = HsListTy a <$> traverse cvType b +-cvType (HsTupleTy a b c) = HsTupleTy a b <$> traverse (traverse cvType) c +-cvType (HsSumTy a b) = HsSumTy a <$> traverse (traverse cvType) b +-cvType (HsOpTy a b c d) = HsOpTy a +- <$> traverse cvType b +- <*> convertName c +- <*> traverse cvType d +-cvType (HsParTy a b) = HsParTy a <$> traverse cvType b +-cvType (HsIParamTy a b c) = HsIParamTy a b <$> traverse cvType c +-cvType (HsKindSig a b c) = HsKindSig a +- <$> traverse cvType b +- <*> traverse cvType c +-cvType (HsBangTy a b c) = HsBangTy a b <$> traverse cvType c +-cvType (HsRecTy a b) = HsRecTy a <$> traverse (traverse cvConDeclField) b +-cvType (HsExplicitListTy a b c) = HsExplicitListTy a b +- <$> traverse (traverse cvType) c +-cvType (HsExplicitTupleTy a b) = HsExplicitTupleTy a +- <$> traverse (traverse cvType) b +-cvType (HsTyLit a b) = pure (HsTyLit a b) +-cvType (HsWildCardTy a) = pure (HsWildCardTy a) +-cvType (HsDocTy a b c) = HsDocTy a <$> traverse cvType b <*> pure c +-cvType (HsSpliceTy a b) = HsSpliceTy a <$> cvHsSplice b +-cvType (HsStarTy a b) = pure (HsStarTy a b) +-cvType (XHsType a) = pure (XHsType a) +- +-cvHsTyVarBndr +- :: HsTyVarBndr GhcPs -> Conv (HsTyVarBndr GhcSe) +-cvHsTyVarBndr (UserTyVar a b) = UserTyVar a <$> convertName b +-cvHsTyVarBndr (KindedTyVar a b c) = KindedTyVar a +- <$> convertName b +- <*> traverse cvType c +-cvHsTyVarBndr (XTyVarBndr a) = pure (XTyVarBndr a) +- +-cvApplicativeArg +- :: ApplicativeArg GhcPs -> Conv (ApplicativeArg GhcSe) +-cvApplicativeArg (ApplicativeArgOne a b c d) = ApplicativeArgOne a +- <$> traverse cvPat b <*> cvLHsExpr c <*> pure d +-cvApplicativeArg (ApplicativeArgMany a b c d) = ApplicativeArgMany a +- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> cvHsExpr c +- <*> traverse cvPat d +-cvApplicativeArg (XApplicativeArg a) = pure (XApplicativeArg a) +- +-cvSig :: Sig GhcPs -> Conv (Sig GhcSe) +-cvSig (TypeSig a b c) = TypeSig a <$> convertName b <*> cvHsSigWcType c +-cvSig (PatSynSig a b c) = PatSynSig a +- <$> convertName b <*> cvHsImplicitBndrs (traverse cvType) c +-cvSig (ClassOpSig a b c d) = ClassOpSig a b +- <$> convertName c <*> cvHsImplicitBndrs (traverse cvType) d +-cvSig (InlineSig a b c) = InlineSig a <$> convertName b <*> pure c +-cvSig (FixSig a b) = FixSig a <$> cvFixitySig b +-cvSig (SpecSig a b c d) = SpecSig a +- <$> convertName b +- <*> traverse (cvHsImplicitBndrs (traverse cvType)) c +- <*> pure d +-cvSig (SpecInstSig a b c) = SpecInstSig a b +- <$> cvHsImplicitBndrs (traverse cvType) c +-cvSig (SCCFunSig a b c d) = SCCFunSig a b <$> convertName c <*> pure d +-cvSig (CompleteMatchSig a b c d) = CompleteMatchSig a b +- <$> convertName c <*> convertName d +-cvSig (MinimalSig a b c) = MinimalSig a b <$> traverse (traverse convertName) c +-cvSig (IdSig {}) = unsupported "IdSig" "Sig" (error "") +-cvSig (XSig a) = pure (XSig a) +- +-cvFixitySig :: FixitySig GhcPs -> Conv (FixitySig GhcSe) +-cvFixitySig (FixitySig a b c) = FixitySig a <$> convertName b <*> pure c +-cvFixitySig (XFixitySig a) = pure (XFixitySig a) +- +-cvPatSynBind :: PatSynBind GhcPs GhcPs -> Conv (PatSynBind GhcSe GhcSe) +-cvPatSynBind (PSB a b c d e) = PSB a +- <$> convertName b +- <*> cvHsPatSynDetails convertName c <*> traverse cvPat d +- <*> cvHsPatSynDir e +-cvPatSynBind (XPatSynBind a) = pure (XPatSynBind a) +- +-cvHsPatSynDetails +- :: (a -> Conv b) +- -> HsPatSynDetails a +- -> Conv (HsPatSynDetails b) +-cvHsPatSynDetails f = cvHsConDetails f (traverse (cvRecordPatSynField f)) +- +-cvRecordPatSynField +- :: (a -> Conv b) +- -> RecordPatSynField a +- -> Conv (RecordPatSynField b) +-cvRecordPatSynField f (RecordPatSynField a b) = +- RecordPatSynField <$> f a <*> f b +- +-cvHsPatSynDir :: HsPatSynDir GhcPs -> Conv (HsPatSynDir GhcSe) +-cvHsPatSynDir Unidirectional = pure Unidirectional +-cvHsPatSynDir ImplicitBidirectional = pure ImplicitBidirectional +-cvHsPatSynDir (ExplicitBidirectional a) = ExplicitBidirectional +- <$> cvMatchGroup cvLHsExpr a +diff --git a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs +deleted file mode 100644 +index 8fbc941a71..0000000000 +--- a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs ++++ /dev/null +@@ -1,813 +0,0 @@ +-{-# LANGUAGE GADTs #-} +-module HsExprBin_ConversionSE2PS where +- +-import Control.Applicative +-import Data.Traversable +- +-import Bag (mapBagM) +-import Class +-import CoreSyn ( Tickish(..) ) +-import GhcPrelude +-import HsBinds +-import HsDecls +-import HsExpr +-import HsExprBin_Conversions +-import HsExtension +-import HsLit +-import HsPat +-import HsTypes +- +--- * Conversion from serialisable ASTs to parsed ASTs +- +-cvLHsDecl :: LHsDecl GhcSe -> Conv (LHsDecl GhcPs) +-cvLHsDecl = traverse cvHsDecl +- +-cvHsDecl :: HsDecl GhcSe -> Conv (HsDecl GhcPs) +-cvHsDecl (TyClD a b) = TyClD <$> pure a <*> cvTyClDecl b +-cvHsDecl (InstD a b) = InstD <$> pure a <*> cvInstDecl b +-cvHsDecl (DerivD a b) = DerivD <$> pure a <*> cvDerivDecl b +-cvHsDecl (ValD a b) = ValD <$> pure a <*> cvHsBindLR b +-cvHsDecl (SigD a b) = SigD <$> pure a <*> cvSig b +-cvHsDecl (DefD a b) = DefD <$> pure a <*> cvDefaultDecl b +-cvHsDecl (ForD a b) = ForD <$> pure a <*> cvForeignDecl b +-cvHsDecl (WarningD a b) = WarningD <$> pure a <*> cvWarningDecls b +-cvHsDecl (RoleAnnotD a b) = RoleAnnotD <$> pure a <*> cvRoleAnnotDecl b +-cvHsDecl (AnnD a b) = AnnD <$> pure a <*> cvAnnDecl b +-cvHsDecl (RuleD a b) = RuleD <$> pure a <*> cvRuleDecls b +-cvHsDecl (SpliceD a b) = SpliceD <$> pure a <*> cvSpliceDecl b +-cvHsDecl (DocD a b) = pure (DocD a b) +-cvHsDecl (XHsDecl a) = pure (XHsDecl a) +- +-cvAnnDecl :: AnnDecl GhcSe -> Conv (AnnDecl GhcPs) +-cvAnnDecl (HsAnnotation a b c d) = +- HsAnnotation a b <$> cvAnnProvenance c <*> cvLHsExpr d +-cvAnnDecl (XAnnDecl a) = pure (XAnnDecl a) +- +-cvInstDecl :: InstDecl GhcSe -> Conv (InstDecl GhcPs) +-cvInstDecl (ClsInstD a b) = ClsInstD a <$> cvClsInstDecl b +-cvInstDecl (DataFamInstD a b) = DataFamInstD a <$> cvDataFamInstDecl b +-cvInstDecl (TyFamInstD a b) = TyFamInstD a <$> cvTyFamInstDecl b +-cvInstDecl (XInstDecl a) = pure (XInstDecl a) +- +-cvClsInstDecl :: ClsInstDecl GhcSe -> Conv (ClsInstDecl GhcPs) +-cvClsInstDecl (ClsInstDecl a b c d e f g) = +- ClsInstDecl a +- <$> cvHsImplicitBndrs (traverse cvType) b +- <*> mapBagM (traverse cvHsBindLR) c +- <*> traverse (traverse cvSig) d +- <*> traverse (traverse cvTyFamInstDecl) e +- <*> traverse (traverse cvDataFamInstDecl) f +- <*> pure g +-cvClsInstDecl (XClsInstDecl a) = pure (XClsInstDecl a) +- +-cvDerivDecl :: DerivDecl GhcSe -> Conv (DerivDecl GhcPs) +-cvDerivDecl (DerivDecl a b c d) = +- DerivDecl a <$> cvHsWildCardBndrs (cvHsImplicitBndrs $ traverse cvType) b +- <*> traverse (traverse cvDerivStrategy) c +- <*> pure d +-cvDerivDecl (XDerivDecl a) = pure (XDerivDecl a) +- +-cvDerivStrategy +- :: DerivStrategy GhcSe -> Conv (DerivStrategy GhcPs) +-cvDerivStrategy StockStrategy = pure StockStrategy +-cvDerivStrategy AnyclassStrategy = pure AnyclassStrategy +-cvDerivStrategy NewtypeStrategy = pure NewtypeStrategy +-cvDerivStrategy (ViaStrategy a) = ViaStrategy +- <$> cvHsImplicitBndrs (traverse cvType) a +- +-cvTyClDecl :: TyClDecl GhcSe -> Conv (TyClDecl GhcPs) +-cvTyClDecl (FamDecl a b) = FamDecl <$> pure a <*> cvFamilyDecl b +-cvTyClDecl (SynDecl a b c d e) = +- SynDecl a +- <$> convertName b +- <*> cvLHsQTyVars c <*> pure d +- <*> traverse cvType e +-cvTyClDecl (DataDecl a b c d e) = +- DataDecl a +- <$> convertName b +- <*> cvLHsQTyVars c <*> pure d +- <*> cvHsDataDefn e +-cvTyClDecl (ClassDecl a b c d e f g h i j k) = +- ClassDecl a +- <$> traverse (traverse (traverse cvType)) b +- <*> convertName c +- <*> cvLHsQTyVars d +- <*> pure e +- <*> traverse (traverse cvFunDep) f +- <*> traverse (traverse cvSig) g +- <*> mapBagM (traverse cvHsBindLR) h +- <*> traverse (traverse cvFamilyDecl) i +- <*> traverse (traverse $ cvFamEqn cvLHsQTyVars (traverse cvType)) j +- <*> pure k +-cvTyClDecl (XTyClDecl a) = pure (XTyClDecl a) +- +-cvRoleAnnotDecl :: RoleAnnotDecl GhcSe -> Conv (RoleAnnotDecl GhcPs) +-cvRoleAnnotDecl (RoleAnnotDecl a b c) = +- RoleAnnotDecl a <$> convertName b <*> pure c +-cvRoleAnnotDecl (XRoleAnnotDecl a) = pure (XRoleAnnotDecl a) +- +-cvRuleDecls :: RuleDecls GhcSe -> Conv (RuleDecls GhcPs) +-cvRuleDecls (HsRules a b c) = HsRules a b <$> traverse (traverse cvRuleDecl) c +-cvRuleDecls (XRuleDecls a) = pure (XRuleDecls a) +- +-cvRuleDecl :: RuleDecl GhcSe -> Conv (RuleDecl GhcPs) +-cvRuleDecl (HsRule a b c d e f) = +- HsRule a b c <$> traverse (traverse cvRuleBndr) d +- <*> cvLHsExpr e <*> cvLHsExpr f +-cvRuleDecl (XRuleDecl a) = pure (XRuleDecl a) +- +-cvSpliceDecl :: SpliceDecl GhcSe -> Conv (SpliceDecl GhcPs) +-cvSpliceDecl (SpliceDecl a b c) = +- SpliceDecl a <$> traverse cvHsSplice b <*> pure c +-cvSpliceDecl (XSpliceDecl a) = pure (XSpliceDecl a) +- +-cvHsSplice :: HsSplice GhcSe -> Conv (HsSplice GhcPs) +-cvHsSplice (HsTypedSplice a b c d) = +- HsTypedSplice a b <$> convertName c <*> cvLHsExpr d +-cvHsSplice (HsUntypedSplice a b c d) = +- HsUntypedSplice a b <$> convertName c <*> cvLHsExpr d +-cvHsSplice (HsQuasiQuote a b c d e) = +- HsQuasiQuote a <$> convertName b <*> convertName c <*> pure d <*> pure e +-cvHsSplice (HsSpliced {}) = +- unsupported "HsSpliced" "HsSplice" (error "") +-cvHsSplice (XSplice a) = pure (XSplice a) +- +-cvRuleBndr :: RuleBndr GhcSe -> Conv (RuleBndr GhcPs) +-cvRuleBndr (RuleBndr a b) = RuleBndr a <$> convertName b +-cvRuleBndr (RuleBndrSig a b c) = +- RuleBndrSig a <$> convertName b <*> cvHsSigWcType c +-cvRuleBndr (XRuleBndr a) = pure (XRuleBndr a) +- +-cvFamEqn +- :: ( XCFamEqn GhcSe a b ~ XCFamEqn GhcPs c d +- , XXFamEqn GhcSe a b ~ XXFamEqn GhcPs c d +- ) +- => (a -> Conv c) +- -> (b -> Conv d) +- -> FamEqn GhcSe a b +- -> Conv (FamEqn GhcPs c d) +-cvFamEqn goPats goRhs (FamEqn a b c d e) = +- FamEqn a <$> convertName b <*> goPats c <*> pure d <*> goRhs e +-cvFamEqn _ _ (XFamEqn a) = pure (XFamEqn a) +- +-cvFamilyDecl :: FamilyDecl GhcSe -> Conv (FamilyDecl GhcPs) +-cvFamilyDecl (FamilyDecl a b c d e f g) = +- FamilyDecl a +- <$> cvFamilyInfo b <*> convertName c +- <*> cvLHsQTyVars d <*> pure e +- <*> traverse cvFamilyResultSig f +- <*> traverse (traverse cvInjectivityAnn) g +-cvFamilyDecl (XFamilyDecl a) = pure (XFamilyDecl a) +- +-cvAnnProvenance :: ConvertName a b => AnnProvenance a -> Conv (AnnProvenance b) +-cvAnnProvenance (ValueAnnProvenance a) = ValueAnnProvenance <$> convertName a +-cvAnnProvenance (TypeAnnProvenance a) = TypeAnnProvenance <$> convertName a +-cvAnnProvenance ModuleAnnProvenance = pure ModuleAnnProvenance +- +-cvInjectivityAnn +- :: InjectivityAnn GhcSe -> Conv (InjectivityAnn GhcPs) +-cvInjectivityAnn (InjectivityAnn a b) = +- InjectivityAnn <$> convertName a <*> convertName b +- +-cvFamilyResultSig +- :: FamilyResultSig GhcSe -> Conv (FamilyResultSig GhcPs) +-cvFamilyResultSig (NoSig a) = pure (NoSig a) +-cvFamilyResultSig (KindSig a b) = KindSig a <$> traverse cvType b +-cvFamilyResultSig (TyVarSig a b) = TyVarSig a <$> traverse cvHsTyVarBndr b +-cvFamilyResultSig (XFamilyResultSig a) = pure (XFamilyResultSig a) +- +-cvFamilyInfo +- :: FamilyInfo GhcSe -> Conv (FamilyInfo GhcPs) +-cvFamilyInfo DataFamily = pure DataFamily +-cvFamilyInfo OpenTypeFamily = pure OpenTypeFamily +-cvFamilyInfo (ClosedTypeFamily a) = +- ClosedTypeFamily <$> traverse (traverse (traverse (cvFamInstEqn (traverse cvType)))) a +- +-cvFamInstEqn +- :: ( XCFamEqn GhcSe (HsTyPats GhcSe) a +- ~ XCFamEqn GhcPs (HsTyPats GhcPs) b +- , XHsIB GhcSe (FamEqn GhcSe (HsTyPats p) a) +- ~ XHsIB GhcPs (FamEqn GhcPs (HsTyPats GhcPs) b) +- , XXFamEqn GhcSe (HsTyPats GhcSe) a +- ~ XXFamEqn GhcPs (HsTyPats GhcPs) b +- , XXHsImplicitBndrs GhcSe (FamEqn GhcSe (HsTyPats GhcSe) a) +- ~ XXHsImplicitBndrs GhcPs (FamEqn GhcPs (HsTyPats GhcPs) b) +- ) +- => (a -> Conv b) +- -> FamInstEqn GhcSe a +- -> Conv (FamInstEqn GhcPs b) +-cvFamInstEqn f = cvHsImplicitBndrs (cvFamEqn (traverse (traverse cvType)) f) +- +-cvFunDep :: ConvertName a b => FunDep a -> Conv (FunDep b) +-cvFunDep (xs, ys) = (,) <$> convertName xs <*> convertName ys +- +-cvLHsQTyVars :: LHsQTyVars GhcSe -> Conv (LHsQTyVars GhcPs) +-cvLHsQTyVars (HsQTvs a b) = HsQTvs a <$> traverse (traverse cvHsTyVarBndr) b +-cvLHsQTyVars (XLHsQTyVars a) = pure (XLHsQTyVars a) +- +-cvForeignDecl :: ForeignDecl GhcSe -> Conv (ForeignDecl GhcPs) +-cvForeignDecl (ForeignImport a b c d) = +- ForeignImport a +- <$> convertName b +- <*> cvHsImplicitBndrs (traverse cvType) c +- <*> pure d +-cvForeignDecl (ForeignExport a b c d) = +- ForeignExport a +- <$> convertName b +- <*> cvHsImplicitBndrs (traverse cvType) c +- <*> pure d +-cvForeignDecl (XForeignDecl a) = pure (XForeignDecl a) +- +-cvDefaultDecl :: DefaultDecl GhcSe -> Conv (DefaultDecl GhcPs) +-cvDefaultDecl (DefaultDecl a b) = DefaultDecl a <$> traverse (traverse cvType) b +-cvDefaultDecl (XDefaultDecl a) = pure (XDefaultDecl a) +- +-cvTyFamInstDecl +- :: TyFamInstDecl GhcSe -> Conv (TyFamInstDecl GhcPs) +-cvTyFamInstDecl (TyFamInstDecl d) = +- TyFamInstDecl <$> cvFamInstEqn (traverse cvType) d +- +-cvDataFamInstDecl +- :: DataFamInstDecl GhcSe -> Conv (DataFamInstDecl GhcPs) +-cvDataFamInstDecl (DataFamInstDecl d) = +- DataFamInstDecl <$> cvFamInstEqn cvHsDataDefn d +- +-cvHsDataDefn :: HsDataDefn GhcSe -> Conv (HsDataDefn GhcPs) +-cvHsDataDefn (HsDataDefn a b c d e f g) = +- HsDataDefn a b +- <$> traverse (traverse (traverse cvType)) c <*> pure d +- <*> traverse (traverse cvType) e +- <*> traverse (traverse cvConDecl) f <*> cvHsDeriving g +-cvHsDataDefn (XHsDataDefn a) = pure (XHsDataDefn a) +- +-cvConDecl :: ConDecl GhcSe -> Conv (ConDecl GhcPs) +-cvConDecl (ConDeclGADT a b c d e f g h) = +- ConDeclGADT a +- <$> convertName b +- <*> pure c +- <*> cvLHsQTyVars d +- <*> traverse (traverse (traverse (traverse cvType))) e +- <*> cvHsConDeclDetails f +- <*> traverse cvType g +- <*> pure h +-cvConDecl (ConDeclH98 a b c d e f g) = +- ConDeclH98 a +- <$> convertName b +- <*> pure c +- <*> traverse (traverse cvHsTyVarBndr) d +- <*> traverse (traverse (traverse (traverse cvType))) e +- <*> cvHsConDeclDetails f +- <*> pure g +-cvConDecl (XConDecl a) = pure (XConDecl a) +- +-cvHsDeriving :: HsDeriving GhcSe -> Conv (HsDeriving GhcPs) +-cvHsDeriving = traverse (traverse (traverse cvHsDerivingClause)) +- +-cvHsDerivingClause +- :: HsDerivingClause GhcSe -> Conv (HsDerivingClause GhcPs) +-cvHsDerivingClause (HsDerivingClause a b c) = +- HsDerivingClause a +- <$> traverse (traverse cvDerivStrategy) b +- <*> traverse (traverse (cvHsImplicitBndrs (traverse cvType))) c +-cvHsDerivingClause (XHsDerivingClause a) = pure (XHsDerivingClause a) +- +-cvHsConDeclDetails +- :: HsConDeclDetails GhcSe -> Conv (HsConDeclDetails GhcPs) +-cvHsConDeclDetails = +- cvHsConDetails (traverse cvType) +- (traverse (traverse (traverse cvConDeclField))) +- +-cvHsConDetails +- :: (a -> Conv c) -> (b -> Conv d) -> HsConDetails a b -> Conv (HsConDetails c d) +-cvHsConDetails f _ (PrefixCon a) = PrefixCon <$> traverse f a +-cvHsConDetails _ g (RecCon a) = RecCon <$> g a +-cvHsConDetails f _ (InfixCon a b) = InfixCon <$> f a <*> f b +- +-cvConDeclField :: ConDeclField GhcSe -> Conv (ConDeclField GhcPs) +-cvConDeclField (ConDeclField a b c d) = +- ConDeclField a <$> traverse (traverse cvFieldOcc) b <*> traverse cvType c +- <*> pure d +-cvConDeclField (XConDeclField a) = pure (XConDeclField a) +- +-cvWarningDecls :: WarnDecls GhcSe -> Conv (WarnDecls GhcPs) +-cvWarningDecls (Warnings a b c) = +- Warnings a b <$> traverse (traverse cvWarningDecl) c +-cvWarningDecls (XWarnDecls a) = pure (XWarnDecls a) +- +-cvWarningDecl :: WarnDecl GhcSe -> Conv (WarnDecl GhcPs) +-cvWarningDecl (Warning a b c) = Warning a <$> convertName b <*> pure c +-cvWarningDecl (XWarnDecl a) = pure (XWarnDecl a) +- +--- expressions +- +-cvLHsExpr :: LHsExpr GhcSe -> Conv (LHsExpr GhcPs) +-cvLHsExpr = traverse cvHsExpr +- +-cvHsExpr :: HsExpr GhcSe -> Conv (HsExpr GhcPs) +-cvHsExpr e = case e of +- HsVar a b -> HsVar a <$> convertName b +- HsUnboundVar a b -> pure (HsUnboundVar a b) +- HsConLikeOut a b -> pure (HsConLikeOut a b) +- HsRecFld a b -> HsRecFld a <$> cvAFieldOcc b +- HsOverLabel a b c -> HsOverLabel a <$> convertName b <*> pure c +- HsIPVar a b -> pure (HsIPVar a b) +- HsOverLit a b -> HsOverLit a <$> cvOverLit b +- HsLit a b -> HsLit a <$> cvLit b +- HsLam a b -> HsLam a <$> cvMatchGroup cvLHsExpr b +- HsLamCase a b -> HsLamCase a <$> cvMatchGroup cvLHsExpr b +- HsApp a b c -> HsApp a <$> cvLHsExpr b <*> cvLHsExpr c +- HsAppType a b -> HsAppType +- <$> cvHsWildCardBndrs (traverse cvType) a <*> cvLHsExpr b +- OpApp a b c d -> OpApp a <$> cvLHsExpr b <*> cvLHsExpr c <*> cvLHsExpr d +- NegApp a b c -> NegApp a <$> cvLHsExpr b <*> cvSyntaxExpr c +- HsPar a b -> HsPar a <$> cvLHsExpr b +- SectionL a b c -> SectionL a <$> cvLHsExpr b <*> cvLHsExpr c +- SectionR a b c -> SectionR a <$> cvLHsExpr b <*> cvLHsExpr c +- ExplicitTuple a b c -> ExplicitTuple a <$> traverse (traverse cvHsTupArg) b +- <*> pure c +- ExplicitSum a b c d -> ExplicitSum a b c <$> cvLHsExpr d +- ExplicitList a b c -> ExplicitList a <$> traverse cvSyntaxExpr b <*> traverse cvLHsExpr c +- HsCase a b c -> HsCase a <$> cvLHsExpr b <*> cvMatchGroup cvLHsExpr c +- HsIf a b c d e -> HsIf a <$> traverse cvSyntaxExpr b +- <*> cvLHsExpr c <*> cvLHsExpr d <*> cvLHsExpr e +- HsMultiIf a b -> HsMultiIf a <$> traverse (traverse (cvGRHS cvLHsExpr)) b +- HsLet a b c -> HsLet a <$> traverse cvHsLocalBinds b <*> cvLHsExpr c +- HsDo a b c -> HsDo a +- <$> convertName b <*> traverse (traverse (traverse (cvStmtLR cvLHsExpr))) c +- RecordCon a b c -> RecordCon a <$> convertName b <*> cvRecordBinds c +- RecordUpd a b c -> RecordUpd a <$> cvLHsExpr b +- <*> traverse (traverse cvHsRecUpdField) c +- ExprWithTySig a b -> ExprWithTySig <$> cvHsSigWcType a <*> cvLHsExpr b +- ArithSeq a b c -> ArithSeq a <$> traverse cvSyntaxExpr b <*> cvArithSeqInfo c +- HsSCC a b c d -> HsSCC a b c <$> cvLHsExpr d +- HsCoreAnn a b c d -> HsCoreAnn a b c <$> cvLHsExpr d +- HsStatic a b -> HsStatic a <$> cvLHsExpr b +- EWildPat a -> pure (EWildPat a) +- EAsPat a b c -> EAsPat a <$> convertName b <*> cvLHsExpr c +- EViewPat a b c -> EViewPat a <$> cvLHsExpr b <*> cvLHsExpr c +- ELazyPat a b -> ELazyPat a <$> cvLHsExpr b +- HsProc a b c -> HsProc a <$> traverse cvPat b <*> traverse cvHsCmdTop c +- HsBinTick a b c d -> HsBinTick a b c <$> cvLHsExpr d +- HsTickPragma a b c d e -> HsTickPragma a b c d <$> cvLHsExpr e +- HsSpliceE a b -> HsSpliceE a <$> cvHsSplice b +- HsBracket a b -> HsBracket a <$> cvHsBracket b +- HsTick a b c -> HsTick a <$> cvTickish b <*> cvLHsExpr c +- XExpr a -> pure (XExpr a) +- HsArrApp {} -> unsupported "HsArrApp" "HsExpr" (error "") +- HsArrForm {} -> unsupported "HsArrForm" "HsExpr" (error "") +- HsWrap {} -> unsupported "HsWrap" "HsExpr" (error "") +- HsRnBracketOut {} -> unsupported "HsRnBracketOut" "HsExpr" (error "") +- HsTcBracketOut {} -> unsupported "HsTcBracketOut" "HsExpr" (error "") +- +-cvHsBracket :: HsBracket GhcSe -> Conv (HsBracket GhcPs) +-cvHsBracket (ExpBr a b) = ExpBr a <$> cvLHsExpr b +-cvHsBracket (PatBr a b) = PatBr a <$> traverse cvPat b +-cvHsBracket (DecBrL a b) = DecBrL a <$> traverse (traverse cvHsDecl) b +-cvHsBracket (DecBrG a b) = DecBrG a <$> cvHsGroup b +-cvHsBracket (TypBr a b) = TypBr a <$> traverse cvType b +-cvHsBracket (VarBr a b c) = VarBr a b <$> convertName c +-cvHsBracket (TExpBr a b) = TExpBr a <$> cvLHsExpr b +-cvHsBracket (XBracket a) = pure (XBracket a) +- +-cvTickish :: ConvertName a b => Tickish a -> Conv (Tickish b) +-cvTickish (ProfNote a b c) = pure (ProfNote a b c) +-cvTickish (HpcTick a b) = pure (HpcTick a b) +-cvTickish (Breakpoint a b) = Breakpoint a <$> convertName b +-cvTickish (SourceNote a b) = pure (SourceNote a b) +- +-cvHsGroup :: HsGroup GhcSe -> Conv (HsGroup GhcPs) +-cvHsGroup (HsGroup a b c d e f g h i j k l) = HsGroup a +- <$> cvHsValBindsLR b <*> traverse (traverse cvSpliceDecl) c +- <*> traverse cvTyClGroup d +- <*> traverse (traverse cvDerivDecl) e +- <*> traverse (traverse cvFixitySig) f +- <*> traverse (traverse cvDefaultDecl) g +- <*> traverse (traverse cvForeignDecl) h +- <*> traverse (traverse cvWarningDecls) i +- <*> traverse (traverse cvAnnDecl) j +- <*> traverse (traverse cvRuleDecls) k +- <*> pure l +-cvHsGroup (XHsGroup a) = pure (XHsGroup a) +- +-cvTyClGroup :: TyClGroup GhcSe -> Conv (TyClGroup GhcPs) +-cvTyClGroup (TyClGroup a b c d) = TyClGroup a +- <$> traverse (traverse cvTyClDecl) b +- <*> traverse (traverse cvRoleAnnotDecl) c +- <*> traverse (traverse cvInstDecl) d +-cvTyClGroup (XTyClGroup a) = pure (XTyClGroup a) +- +-cvHsCmdTop :: HsCmdTop GhcSe -> Conv (HsCmdTop GhcPs) +-cvHsCmdTop (HsCmdTop a b) = HsCmdTop a <$> traverse cvHsCmd b +-cvHsCmdTop (XCmdTop a) = pure (XCmdTop a) +- +-cvHsCmd :: HsCmd GhcSe -> Conv (HsCmd GhcPs) +-cvHsCmd (HsCmdArrApp a b c d e) = HsCmdArrApp a +- <$> cvLHsExpr b <*> cvLHsExpr c <*> pure d <*> pure e +-cvHsCmd (HsCmdArrForm a b c d e) = HsCmdArrForm a +- <$> cvLHsExpr b <*> pure c <*> pure d +- <*> traverse (traverse cvHsCmdTop) e +-cvHsCmd (HsCmdApp a b c) = HsCmdApp a <$> traverse cvHsCmd b <*> cvLHsExpr c +-cvHsCmd (HsCmdLam a b) = HsCmdLam a <$> cvMatchGroup (traverse cvHsCmd) b +-cvHsCmd (HsCmdPar a b) = HsCmdPar a <$> traverse cvHsCmd b +-cvHsCmd (HsCmdCase a b c) = HsCmdCase a +- <$> cvLHsExpr b <*> cvMatchGroup (traverse cvHsCmd) c +-cvHsCmd (HsCmdIf a b c d e) = HsCmdIf a +- <$> traverse cvSyntaxExpr b +- <*> cvLHsExpr c +- <*> traverse cvHsCmd d +- <*> traverse cvHsCmd e +-cvHsCmd (HsCmdLet a b c) = HsCmdLet a +- <$> traverse cvHsLocalBinds b <*> traverse cvHsCmd c +-cvHsCmd (HsCmdDo a b) = HsCmdDo a +- <$> traverse (traverse (traverse (cvStmtLR (traverse cvHsCmd)))) b +-cvHsCmd (HsCmdWrap {}) = unsupported "HsCmdWrap" "HsCmd" (error "") +-cvHsCmd (XCmd a) = pure (XCmd a) +- +-cvArithSeqInfo :: ArithSeqInfo GhcSe -> Conv (ArithSeqInfo GhcPs) +-cvArithSeqInfo (From e) = From <$> cvLHsExpr e +-cvArithSeqInfo (FromThen a b) = FromThen <$> cvLHsExpr a <*> cvLHsExpr b +-cvArithSeqInfo (FromTo a b) = FromTo <$> cvLHsExpr a <*> cvLHsExpr b +-cvArithSeqInfo (FromThenTo a b c) = FromThenTo <$> cvLHsExpr a <*> cvLHsExpr b <*> cvLHsExpr c +- +-cvHsTupArg :: HsTupArg GhcSe -> Conv (HsTupArg GhcPs) +-cvHsTupArg (Present a b) = Present a <$> cvLHsExpr b +-cvHsTupArg (Missing a) = pure (Missing a) +-cvHsTupArg (XTupArg a) = pure (XTupArg a) +- +-cvAFieldOcc +- :: AmbiguousFieldOcc GhcSe -> Conv (AmbiguousFieldOcc GhcPs) +-cvAFieldOcc (Unambiguous a b) = Unambiguous a <$> convertName b +-cvAFieldOcc (Ambiguous a b) = Ambiguous a <$> convertName b +-cvAFieldOcc (XAmbiguousFieldOcc a) = pure (XAmbiguousFieldOcc a) +- +-cvOverLit :: HsOverLit GhcSe -> Conv (HsOverLit GhcPs) +-cvOverLit (OverLit a b c) = OverLit a b <$> cvHsExpr c +-cvOverLit (XOverLit a) = pure (XOverLit a) +- +-cvLit :: HsLit GhcSe -> Conv (HsLit GhcPs) +-cvLit (HsChar a b) = pure (HsChar a b) +-cvLit (HsCharPrim a b) = pure (HsCharPrim a b) +-cvLit (HsString a b) = pure (HsString a b) +-cvLit (HsStringPrim a b) = pure (HsStringPrim a b) +-cvLit (HsInt a b) = pure (HsInt a b) +-cvLit (HsIntPrim a b) = pure (HsIntPrim a b) +-cvLit (HsWordPrim a b) = pure (HsWordPrim a b) +-cvLit (HsInt64Prim a b) = pure (HsInt64Prim a b) +-cvLit (HsWord64Prim a b) = pure (HsWord64Prim a b) +-cvLit (HsInteger a b c) = HsInteger a b <$> convertType c +-cvLit (HsRat a b c) = HsRat a b <$> convertType c +-cvLit (HsFloatPrim a b) = pure (HsFloatPrim a b) +-cvLit (HsDoublePrim a b) = pure (HsDoublePrim a b) +-cvLit (XLit a) = pure (XLit a) +- +-cvMatchGroup +- :: ( XMG GhcSe a ~ XMG GhcPs b +- , XCMatch GhcSe a ~ XCMatch GhcPs b +- , XCGRHSs GhcSe a ~ XCGRHSs GhcPs b +- , XCGRHS GhcSe a ~ XCGRHS GhcPs b +- , XXMatchGroup GhcSe a ~ XXMatchGroup GhcPs b +- , XXMatch GhcSe a ~ XXMatch GhcPs b +- , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b +- , XXGRHS GhcSe a ~ XXGRHS GhcPs b +- ) +- => (a -> Conv b) -> MatchGroup GhcSe a -> Conv (MatchGroup GhcPs b) +-cvMatchGroup f (MG a b c) = MG a +- <$> traverse (traverse (traverse (cvMatch f))) b +- <*> pure c +-cvMatchGroup _ (XMatchGroup a) = pure (XMatchGroup a) +- +-cvMatch +- :: ( XCMatch GhcSe a ~ XCMatch GhcPs b +- , XCGRHSs GhcSe a ~ XCGRHSs GhcPs b +- , XCGRHS GhcSe a ~ XCGRHS GhcPs b +- , XXMatch GhcSe a ~ XXMatch GhcPs b +- , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b +- , XXGRHS GhcSe a ~ XXGRHS GhcPs b +- ) +- => (a -> Conv b) -> Match GhcSe a -> Conv (Match GhcPs b) +-cvMatch f (Match a b c d) = Match a +- <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d +-cvMatch _ (XMatch a) = pure (XMatch a) +- +-cvPat :: Pat GhcSe -> Conv (Pat GhcPs) +-cvPat (WildPat a) = pure (WildPat a) +-cvPat (VarPat a b) = VarPat a <$> convertName b +-cvPat (LazyPat a b) = LazyPat a <$> traverse cvPat b +-cvPat (AsPat a b c) = AsPat a <$> convertName b <*> traverse cvPat c +-cvPat (ParPat a b) = ParPat a <$> traverse cvPat b +-cvPat (BangPat a b) = BangPat a <$> traverse cvPat b +-cvPat (ListPat a b) = ListPat a +- <$> traverse (traverse cvPat) b +-cvPat (TuplePat a b c) = TuplePat a +- <$> traverse (traverse cvPat) b +- <*> pure c +-cvPat (SumPat a b c d) = SumPat a +- <$> traverse cvPat b +- <*> pure c <*> pure d +-cvPat (ConPatIn a b) = ConPatIn <$> convertName a <*> cvHsConPatDetails b +-cvPat (ViewPat a b c) = ViewPat a <$> cvLHsExpr b <*> traverse cvPat c +-cvPat (LitPat a b) = LitPat a <$> cvLit b +-cvPat (NPat a b c d) = NPat a +- <$> traverse cvOverLit b <*> traverse cvSyntaxExpr c +- <*> cvSyntaxExpr d +-cvPat (NPlusKPat a b c d e f) = NPlusKPat a +- <$> convertName b +- <*> traverse cvOverLit c <*> cvOverLit d +- <*> cvSyntaxExpr e <*> cvSyntaxExpr f +-cvPat (SigPat a b) = SigPat <$> cvHsSigWcType a <*> traverse cvPat b +-cvPat (SplicePat a b) = SplicePat a <$> cvHsSplice b +-cvPat (CoPat {}) = unsupported "CoPat" "Pat" (error "") +-cvPat (ConPatOut {}) = unsupported "ConPatOut" "Pat" (error "") +-cvPat (XPat a) = pure (XPat a) +- +-cvGRHSs +- :: ( XCGRHSs GhcSe a ~ XCGRHSs GhcPs b +- , XCGRHS GhcSe a ~ XCGRHS GhcPs b +- , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b +- , XXGRHS GhcSe a ~ XXGRHS GhcPs b +- ) +- => (a -> Conv b) -> GRHSs GhcSe a -> Conv (GRHSs GhcPs b) +-cvGRHSs f (GRHSs a b c) = GRHSs a +- <$> traverse (traverse (cvGRHS f)) b +- <*> traverse cvHsLocalBinds c +-cvGRHSs _ (XGRHSs a) = pure (XGRHSs a) +- +-cvGRHS +- :: ( XCGRHS GhcSe a ~ XCGRHS GhcPs b +- , XXGRHS GhcSe a ~ XXGRHS GhcPs b +- ) +- => (a -> Conv b) -> GRHS GhcSe a -> Conv (GRHS GhcPs b) +-cvGRHS f (GRHS a b c) = GRHS a +- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> f c +-cvGRHS _ (XGRHS a) = pure (XGRHS a) +- +-cvHsLocalBinds +- :: HsLocalBinds GhcSe -> Conv (HsLocalBinds GhcPs) +-cvHsLocalBinds (HsValBinds a b) = HsValBinds a <$> cvHsValBindsLR b +-cvHsLocalBinds (HsIPBinds a b) = HsIPBinds a <$> cvHsIPBinds b +-cvHsLocalBinds (EmptyLocalBinds a) = pure (EmptyLocalBinds a) +-cvHsLocalBinds (XHsLocalBindsLR a) = pure (XHsLocalBindsLR a) +- +-cvHsValBindsLR +- :: HsValBindsLR GhcSe GhcSe -> Conv (HsValBindsLR GhcPs GhcPs) +-cvHsValBindsLR (ValBinds a b c) = ValBinds a +- <$> mapBagM (traverse cvHsBindLR) b +- <*> traverse (traverse cvSig) c +-cvHsValBindsLR (XValBindsLR _) = +- unsupported "XValBindsLR" "HsValBindsLR" (error "") +- +-cvHsConPatDetails +- :: HsConPatDetails GhcSe -> Conv (HsConPatDetails GhcPs) +-cvHsConPatDetails (PrefixCon a) = PrefixCon <$> traverse (traverse cvPat) a +-cvHsConPatDetails (RecCon a) = RecCon <$> cvHsRecFieldsPat a +-cvHsConPatDetails (InfixCon a b) = InfixCon +- <$> traverse cvPat a <*> traverse cvPat b +- +-cvHsRecFields +- :: (thing -> Conv thing') +- -> HsRecFields GhcSe thing +- -> Conv (HsRecFields GhcPs thing') +-cvHsRecFields f (HsRecFields a b) = +- HsRecFields <$> traverse (traverse (cvHsRecField' cvFieldOcc f)) a <*> pure b +- +-cvHsRecField' +- :: (id -> Conv id') +- -> (thing -> Conv thing') +- -> HsRecField' id thing +- -> Conv (HsRecField' id' thing') +-cvHsRecField' f g (HsRecField a b c) = +- HsRecField <$> traverse f a <*> g b <*> pure c +- +-cvHsRecFieldsPat +- :: HsRecFields GhcSe (LPat GhcSe) -> Conv (HsRecFields GhcPs (LPat GhcPs)) +-cvHsRecFieldsPat = cvHsRecFields (traverse cvPat) +- +-cvHsRecUpdField +- :: HsRecUpdField GhcSe -> Conv (HsRecUpdField GhcPs) +-cvHsRecUpdField = cvHsRecField' cvAFieldOcc cvLHsExpr +- +-cvRecordBinds +- :: HsRecordBinds GhcSe -> Conv (HsRecordBinds GhcPs) +-cvRecordBinds = cvHsRecFields cvLHsExpr +- +-cvFieldOcc :: FieldOcc GhcSe -> Conv (FieldOcc GhcPs) +-cvFieldOcc (FieldOcc a b) = FieldOcc a <$> convertName b +-cvFieldOcc (XFieldOcc a) = pure (XFieldOcc a) +- +-cvStmtLR +- :: ( XLastStmt GhcSe GhcSe a ~ XLastStmt GhcPs GhcPs b +- , XBindStmt GhcSe GhcSe a ~ XBindStmt GhcPs GhcPs b +- , XBodyStmt GhcSe GhcSe a ~ XBodyStmt GhcPs GhcPs b +- , XApplicativeStmt GhcSe GhcSe a ~ XApplicativeStmt GhcPs GhcPs b +- , XLetStmt GhcSe GhcSe a ~ XLetStmt GhcPs GhcPs b +- , XRecStmt GhcSe GhcSe a ~ XRecStmt GhcPs GhcPs b +- , XParStmt GhcSe GhcSe a ~ XParStmt GhcPs GhcPs b +- , XTransStmt GhcSe GhcSe a ~ XTransStmt GhcPs GhcPs b +- , XXStmtLR GhcSe GhcSe a ~ XXStmtLR GhcPs GhcPs b +- ) +- => (a -> Conv b) -> StmtLR GhcSe GhcSe a -> Conv (StmtLR GhcPs GhcPs b) +-cvStmtLR k (LastStmt a b c d) = LastStmt a +- <$> k b <*> pure c <*> cvSyntaxExpr d +-cvStmtLR k (BindStmt a b c d e) = BindStmt a +- <$> traverse cvPat b <*> k c +- <*> cvSyntaxExpr d <*> cvSyntaxExpr e +-cvStmtLR k (BodyStmt a b c d) = BodyStmt a +- <$> k b <*> cvSyntaxExpr c +- <*> cvSyntaxExpr d +-cvStmtLR _ (ApplicativeStmt a b c) = ApplicativeStmt a +- <$> traverse +- (\(se, aa) -> (,) <$> cvSyntaxExpr se <*> cvApplicativeArg aa) +- b +- <*> traverse cvSyntaxExpr c +-cvStmtLR _ (LetStmt a b) = LetStmt a <$> traverse cvHsLocalBinds b +-cvStmtLR k (RecStmt a b c d e f g) = RecStmt a +- <$> traverse (traverse (cvStmtLR k)) b +- <*> convertName c +- <*> convertName d +- <*> cvSyntaxExpr e +- <*> cvSyntaxExpr f +- <*> cvSyntaxExpr g +-cvStmtLR _ (ParStmt a b c d) = ParStmt a +- <$> traverse cvParStmtBlock b +- <*> cvHsExpr c +- <*> cvSyntaxExpr d +-cvStmtLR _ (TransStmt a b c d e f g h i) = TransStmt a b +- <$> traverse (traverse (cvStmtLR cvLHsExpr)) c +- <*> traverse (\(x, y) -> (,) <$> convertName x <*> convertName y) d +- <*> cvLHsExpr e +- <*> traverse cvLHsExpr f +- <*> cvSyntaxExpr g +- <*> cvSyntaxExpr h +- <*> cvHsExpr i +-cvStmtLR _ (XStmtLR a) = pure (XStmtLR a) +- +-cvParStmtBlock +- :: ParStmtBlock GhcSe GhcSe -> Conv (ParStmtBlock GhcPs GhcPs) +-cvParStmtBlock (ParStmtBlock a b c d) = ParStmtBlock a +- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b +- <*> convertName c +- <*> cvSyntaxExpr d +-cvParStmtBlock (XParStmtBlock a) = pure (XParStmtBlock a) +- +-cvSyntaxExpr :: SyntaxExpr GhcSe -> Conv (SyntaxExpr GhcPs) +-cvSyntaxExpr (SyntaxExpr a b c) = +- SyntaxExpr <$> cvHsExpr a <*> pure b <*> pure c +- +-cvHsIPBinds +- :: HsIPBinds GhcSe -> Conv (HsIPBinds GhcPs) +-cvHsIPBinds (IPBinds a b) = IPBinds a <$> traverse (traverse cvIPBind) b +-cvHsIPBinds (XHsIPBinds a) = pure (XHsIPBinds a) +- +-cvIPBind :: IPBind GhcSe -> Conv (IPBind GhcPs) +-cvIPBind (IPBind a b c) = IPBind a <$> convertName b <*> cvLHsExpr c +-cvIPBind (XIPBind a) = pure (XIPBind a) +- +-cvHsBindLR +- :: HsBindLR GhcSe GhcSe -> Conv (HsBindLR GhcPs GhcPs) +-cvHsBindLR (FunBind a b c d e) = FunBind a +- <$> convertName b +- <*> cvMatchGroup cvLHsExpr c +- <*> pure d <*> pure e +-cvHsBindLR (PatBind a b c d ) = PatBind a +- <$> traverse cvPat b <*> cvGRHSs cvLHsExpr c <*> pure d +-cvHsBindLR (VarBind a b c d) = VarBind a +- <$> convertName b <*> cvLHsExpr c <*> pure d +-cvHsBindLR (PatSynBind a b) = PatSynBind a <$> cvPatSynBind b +-cvHsBindLR (AbsBinds {}) = +- unsupported "AbsBind" "HsBindLR" (error "") +-cvHsBindLR (XHsBindsLR a) = pure (XHsBindsLR a) +- +-cvHsWildCardBndrs +- :: ( XHsWC GhcSe thing ~ XHsWC GhcPs thing' +- , XXHsWildCardBndrs GhcSe thing ~ XXHsWildCardBndrs GhcPs thing' +- ) +- => (thing -> Conv thing') +- -> HsWildCardBndrs GhcSe thing +- -> Conv (HsWildCardBndrs GhcPs thing') +-cvHsWildCardBndrs thingF (HsWC a b) = HsWC a <$> thingF b +-cvHsWildCardBndrs _ (XHsWildCardBndrs a) = pure (XHsWildCardBndrs a) +- +-cvLHsWcType +- :: LHsWcType GhcSe -> Conv (LHsWcType GhcPs) +-cvLHsWcType = cvHsWildCardBndrs (traverse cvType) +- +-cvHsSigWcType +- :: LHsSigWcType GhcSe -> Conv (LHsSigWcType GhcPs) +-cvHsSigWcType = cvHsWildCardBndrs (cvHsImplicitBndrs (traverse cvType)) +- +-cvHsImplicitBndrs +- :: ( XHsIB GhcSe thing ~ XHsIB GhcPs thing' +- , XXHsImplicitBndrs GhcSe thing ~ XXHsImplicitBndrs GhcPs thing' +- ) +- => (thing -> Conv thing') +- -> HsImplicitBndrs GhcSe thing +- -> Conv (HsImplicitBndrs GhcPs thing') +-cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b +-cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) +- +-cvType :: HsType GhcSe -> Conv (HsType GhcPs) +-cvType (HsForAllTy a b c) = HsForAllTy a +- <$> traverse (traverse cvHsTyVarBndr) b +- <*> traverse cvType c +-cvType (HsQualTy a b c) = HsQualTy a +- <$> traverse (traverse (traverse cvType)) b +- <*> traverse cvType c +-cvType (HsTyVar a b c) = HsTyVar a b <$> convertName c +-cvType (HsAppTy a b c) = HsAppTy a +- <$> traverse cvType b +- <*> traverse cvType c +-cvType (HsFunTy a b c) = HsFunTy a +- <$> traverse cvType b +- <*> traverse cvType c +-cvType (HsListTy a b) = HsListTy a <$> traverse cvType b +-cvType (HsTupleTy a b c) = HsTupleTy a b <$> traverse (traverse cvType) c +-cvType (HsSumTy a b) = HsSumTy a <$> traverse (traverse cvType) b +-cvType (HsOpTy a b c d) = HsOpTy a +- <$> traverse cvType b +- <*> convertName c +- <*> traverse cvType d +-cvType (HsParTy a b) = HsParTy a <$> traverse cvType b +-cvType (HsIParamTy a b c) = HsIParamTy a b <$> traverse cvType c +-cvType (HsKindSig a b c) = HsKindSig a +- <$> traverse cvType b +- <*> traverse cvType c +-cvType (HsBangTy a b c) = HsBangTy a b <$> traverse cvType c +-cvType (HsRecTy a b) = HsRecTy a <$> traverse (traverse cvConDeclField) b +-cvType (HsExplicitListTy a b c) = HsExplicitListTy a b +- <$> traverse (traverse cvType) c +-cvType (HsExplicitTupleTy a b) = HsExplicitTupleTy a +- <$> traverse (traverse cvType) b +-cvType (HsTyLit a b) = pure (HsTyLit a b) +-cvType (HsWildCardTy a) = pure (HsWildCardTy a) +-cvType (HsDocTy a b c) = HsDocTy a <$> traverse cvType b <*> pure c +-cvType (HsSpliceTy a b) = HsSpliceTy a <$> cvHsSplice b +-cvType (HsStarTy a b) = pure (HsStarTy a b) +-cvType (XHsType a) = pure (XHsType a) +- +-cvHsTyVarBndr +- :: HsTyVarBndr GhcSe -> Conv (HsTyVarBndr GhcPs) +-cvHsTyVarBndr (UserTyVar a b) = UserTyVar a <$> convertName b +-cvHsTyVarBndr (KindedTyVar a b c) = KindedTyVar a +- <$> convertName b +- <*> traverse cvType c +-cvHsTyVarBndr (XTyVarBndr a) = pure (XTyVarBndr a) +- +-cvApplicativeArg +- :: ApplicativeArg GhcSe -> Conv (ApplicativeArg GhcPs) +-cvApplicativeArg (ApplicativeArgOne a b c d) = ApplicativeArgOne a +- <$> traverse cvPat b <*> cvLHsExpr c <*> pure d +-cvApplicativeArg (ApplicativeArgMany a b c d) = ApplicativeArgMany a +- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> cvHsExpr c +- <*> traverse cvPat d +-cvApplicativeArg (XApplicativeArg a) = pure (XApplicativeArg a) +- +-cvSig :: Sig GhcSe -> Conv (Sig GhcPs) +-cvSig (TypeSig a b c) = TypeSig a <$> convertName b <*> cvHsSigWcType c +-cvSig (PatSynSig a b c) = PatSynSig a +- <$> convertName b <*> cvHsImplicitBndrs (traverse cvType) c +-cvSig (ClassOpSig a b c d) = ClassOpSig a b +- <$> convertName c <*> cvHsImplicitBndrs (traverse cvType) d +-cvSig (InlineSig a b c) = InlineSig a <$> convertName b <*> pure c +-cvSig (FixSig a b) = FixSig a <$> cvFixitySig b +-cvSig (SpecSig a b c d) = SpecSig a +- <$> convertName b +- <*> traverse (cvHsImplicitBndrs (traverse cvType)) c +- <*> pure d +-cvSig (SpecInstSig a b c) = SpecInstSig a b +- <$> cvHsImplicitBndrs (traverse cvType) c +-cvSig (SCCFunSig a b c d) = SCCFunSig a b <$> convertName c <*> pure d +-cvSig (CompleteMatchSig a b c d) = CompleteMatchSig a b +- <$> convertName c <*> convertName d +-cvSig (MinimalSig a b c) = MinimalSig a b <$> traverse (traverse convertName) c +-cvSig (IdSig {}) = unsupported "IdSig" "Sig" (error "") +-cvSig (XSig a) = pure (XSig a) +- +-cvFixitySig :: FixitySig GhcSe -> Conv (FixitySig GhcPs) +-cvFixitySig (FixitySig a b c) = FixitySig a <$> convertName b <*> pure c +-cvFixitySig (XFixitySig a) = pure (XFixitySig a) +- +-cvPatSynBind :: PatSynBind GhcSe GhcSe -> Conv (PatSynBind GhcPs GhcPs) +-cvPatSynBind (PSB a b c d e) = PSB a +- <$> convertName b +- <*> cvHsPatSynDetails convertName c <*> traverse cvPat d +- <*> cvHsPatSynDir e +-cvPatSynBind (XPatSynBind a) = pure (XPatSynBind a) +- +-cvHsPatSynDetails +- :: (a -> Conv b) +- -> HsPatSynDetails a +- -> Conv (HsPatSynDetails b) +-cvHsPatSynDetails f = cvHsConDetails f (traverse (cvRecordPatSynField f)) +- +-cvRecordPatSynField +- :: (a -> Conv b) +- -> RecordPatSynField a +- -> Conv (RecordPatSynField b) +-cvRecordPatSynField f (RecordPatSynField a b) = +- RecordPatSynField <$> f a <*> f b +- +-cvHsPatSynDir :: HsPatSynDir GhcSe -> Conv (HsPatSynDir GhcPs) +-cvHsPatSynDir Unidirectional = pure Unidirectional +-cvHsPatSynDir ImplicitBidirectional = pure ImplicitBidirectional +-cvHsPatSynDir (ExplicitBidirectional a) = ExplicitBidirectional +- <$> cvMatchGroup cvLHsExpr a +diff --git a/compiler/hsSyn/HsExprBin_Conversions.hs b/compiler/hsSyn/HsExprBin_Conversions.hs +deleted file mode 100644 +index df2d8f929a..0000000000 +--- a/compiler/hsSyn/HsExprBin_Conversions.hs ++++ /dev/null +@@ -1,211 +0,0 @@ +-{-# LANGUAGE ConstraintKinds, DeriveFunctor #-} +-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +-{-# LANGUAGE MultiParamTypeClasses #-} +-{-# LANGUAGE TypeFamilies, TypeSynonymInstances #-} +-module HsExprBin_Conversions where +- +-import Control.Applicative +-import Control.Monad +-import Control.Monad.IO.Class +-import Data.Char (isDigit) +-import Data.List (intercalate) +-import Data.Maybe +-import Data.Traversable +- +-import DynFlags +-import FastString +-import GhcPrelude +-import HsExpr +-import Module +-import Name +-import Outputable +-import PackageConfig +-import Packages +-import RdrName +-import SeName +-import SrcLoc +-import TcRnTypes +-import IfaceType +-import ToIface (toIfaceType) +-import TyCoRep (Type(..), TyLit(..)) +- +-data ConvError +- = ConvUnsupported String String SDoc +- -- constructor name, type name, text rendering +- -- of the unsupported subexpression +- | ConvFailure String +- +-data ConvResult a +- = ConvError ConvError +- | ConvOK a +- deriving Functor +--- * Conversion utilities +- +-newtype Conv a = Conv { runConv :: RnM (ConvResult a) } +- +-instance Functor Conv where +- fmap f (Conv k) = Conv (fmap (fmap f) k) +- +-instance Applicative Conv where +- pure = Conv . return . ConvOK +- (<*>) = ap +- +-instance Monad Conv where +- return = pure +- +- Conv mx >>= f = Conv $ mx >>= \cvx -> case cvx of +- ConvOK x -> runConv (f x) +- ConvError e -> pure (ConvError e) +- +-unsupported :: String -- ^ constructor name +- -> String -- ^ type name +- -> SDoc -- ^ textual rendering of the unsupported subexpression +- -> Conv a +-unsupported con ty subexpr = Conv $ +- pure (ConvError $ ConvUnsupported con ty subexpr) +- +-badInput :: String -> Conv a +-badInput str = Conv $ pure (ConvError $ ConvFailure str) +- +-liftRn :: RnM a -> Conv a +-liftRn = Conv . fmap ConvOK +- +-class ConvertType t u where +- convertType :: t -> Conv u +- +-class ConvertName a b where +- convertName :: a -> Conv b +- +-instance ConvertName a b => ConvertName (Located a) (Located b) where +- convertName = traverse convertName +- +-instance ConvertName a b => ConvertName [a] [b] where +- convertName = traverse convertName +- +-instance ConvertName a b => ConvertName (Either e a) (Either e b) where +- convertName = traverse convertName +- +-instance ConvertName a b => ConvertName (HsMatchContext a) (HsMatchContext b) where +- convertName = traverse convertName +- +-instance ConvertName a b => ConvertName (HsStmtContext a) (HsStmtContext b) where +- convertName = traverse convertName +- +-instance ConvertName a b => ConvertName (Maybe a) (Maybe b) where +- convertName = traverse convertName +- +-instance ConvertType a a where +- convertType = pure +- +-instance ConvertType Type IfaceType where +- convertType = pure . toIfaceType +- +-instance ConvertType IfaceType Type where +- convertType (IfaceLitTy n) = pure $ LitTy (go n) +- where go (IfaceNumTyLit a) = NumTyLit a +- go (IfaceStrTyLit a) = StrTyLit a +- convertType e@(IfaceFreeTyVar {}) = unsupported "IfaceFreeTyVar" "IfaceType" (ppr e) +- convertType e@(IfaceTyVar {}) = unsupported "IfaceTyVar" "IfaceType" (ppr e) +- convertType e@(IfaceAppTy {}) = unsupported "IfaceAppTy" "IfaceType" (ppr e) +- convertType e@(IfaceFunTy {}) = unsupported "IfaceFunTy" "IfaceType" (ppr e) +- convertType e@(IfaceDFunTy {}) = unsupported "IfaceDFunTy" "IfaceType" (ppr e) +- convertType e@(IfaceForAllTy {}) = unsupported "IfaceForAllTy" "IfaceType" (ppr e) +- convertType e@(IfaceTyConApp {}) = unsupported "IfaceTyConApp" "IfaceType" (ppr e) +- convertType e@(IfaceCastTy {}) = unsupported "IfaceCastTy" "IfaceType" (ppr e) +- convertType e@(IfaceCoercionTy {}) = unsupported "IfaceCoercion" "IfaceType" (ppr e) +- convertType e@(IfaceTupleTy {}) = unsupported "IfaceTupleTy" "IfaceType" (ppr e) +- +- +-instance ConvertName RdrName SeName where +- convertName = pure . mkSeName +- +-instance ConvertName SeName RdrName where +- convertName (SeName n) = case n of +- Orig mod occn -> do +- -- TODO: introduce some caching here, to avoid doing the +- -- searchPackageId dance too often. +- currentMod <- liftRn getModule +- +- if samePackages currentMod mod +- then let newMod = mod { moduleUnitId = moduleUnitId currentMod } in +- pure (Orig newMod occn) +- else do mnewmod <- liftRn (findEquivalentModule mod) +- case mnewmod of +- Nothing -> pure (Orig mod occn) +- Just mod' -> pure (Orig mod' occn) +- +- _ -> pure n +- +- where samePackages mod1 mod2 = fromMaybe False $ do -- maybe monad +- let str1 = unitIdString (moduleUnitId mod1) +- str2 = unitIdString (moduleUnitId mod2) +- (pkg1, ver1, _mhash1) <- parseUnitId' str1 +- (pkg2, ver2, _mhash2) <- parseUnitId' str2 +- return (pkg1 == pkg2 && ver1 == ver2) +- +-instance ConvertName Name SeName where +- convertName n = pure $ mkSeName (nameRdrName n) +- +-instance ConvertName SeName Name where +- convertName (SeName n) = case isExact_maybe n of +- Just a -> pure a +- _ -> badInput "convertName :: SeName -> Name: non exact RdrName in SeName" +- +--- * Looking up modules/packages for Orig names +- +--- this rejects wired in packages, because we want to leave them untouched +-parseUnitId' :: String -> Maybe (String, String, Maybe String) +-parseUnitId' = parse +- +- where +- parse s = case splitOn '-' (reverse s) of +- ("":_) -> Nothing +- xs | length xs >= 1 && last xs == "" -> Nothing +- (hash:ver:name) | isVersion ver -> +- Just (intercalate "-" (reverse name), ver, Just hash) +- (ver:name) | isVersion ver -> +- Just (intercalate "-" (reverse name), ver, Nothing) +- _ -> Nothing +- splitOn c = go [] +- where go acc (x:xs) +- | x == c = acc : go "" xs +- | otherwise = go (x:acc) xs +- go acc [] = [acc] +- isVersion = go False +- -- True: waiting for digit or dot (we've seen a digit last) +- -- False: waiting for digit (we've just seen a dot) +- where go False (c:cs) +- | isDigit c = go True cs +- | otherwise = False +- go True (c:cs) +- | isDigit c = go True cs +- | c == '.' = go False cs +- | otherwise = False +- go b [] = b -- if we've seen a dot last (False), we fail +- -- otherwise, the version number can end here +- +--- | Look up the module from the same package, but built by the +--- current compiler, therefore with a slightly different hash +--- in the unit id than the input Module, which was built by some +--- non-cross-compiling GHC. +-findEquivalentModule :: Module -> RnM (Maybe Module) +-findEquivalentModule mod = do +- liftIO $ putStrLn ("Looking for equivalent to: " ++ unitIdStr) +- case parseUnitId' unitIdStr of +- Nothing -> return Nothing +- Just (pkg, ver, _mhash) -> do +- muid <- lookFor pkg ver +- maybe (pure Nothing) (\uid -> return $ Just (mod { moduleUnitId = uid })) muid +- +- where unitIdStr = unitIdString (moduleUnitId mod) +- +-lookFor :: String -> String -> RnM (Maybe UnitId) +-lookFor pkg ver = do +- dflags <- getDynFlags +- let pkgid = mkFastString (pkg ++ "-" ++ ver) +- pkgs = searchPackageId dflags (SourcePackageId pkgid) +- liftIO $ putStrLn ("Looking for: " ++ pkg ++ "-" ++ ver) +- liftIO . putStrLn . unwords $ +- [ "Found", show (length pkgs), "pkgs:" ] ++ +- [ unitIdString (packageConfigId p) | p <- pkgs ] +- if null pkgs then pure Nothing else pure (Just $ packageConfigId (head pkgs)) +diff --git a/compiler/hsSyn/HsExprBin_Instances.hs b/compiler/hsSyn/HsExprBin_Instances.hs +deleted file mode 100644 +index 24abf8d69a..0000000000 +--- a/compiler/hsSyn/HsExprBin_Instances.hs ++++ /dev/null +@@ -1,1665 +0,0 @@ +--- too noisy during development... +-{-# OPTIONS_GHC -fno-warn-orphans #-} +-{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-{-# LANGUAGE StandaloneDeriving #-} +-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +-module HsExprBin_Instances where +- +-import Control.Applicative +-import Control.Monad +- +-import BasicTypes +-import Binary +-import CoreSyn ( Tickish(..) ) +-import GhcPrelude +-import HsBinds +-import HsDecls +-import HsExpr +-import HsExtension +-import HsLit +-import HsPat +-import HsTypes +-import Name +-import Outputable +-import RdrName +-import SeName +-import SrcLoc +-import TcEvidence (HsWrapper(WpHole)) +- +--- * Utilities +- +-putPanic :: String -> String -> a +-putPanic tyName conName = +- panic ("Binary " ++ tyName ++ ".put: " ++ conName ++ " not supported") +- +-getPanic :: String -> a +-getPanic tyName = +- panic ("Binary " ++ tyName ++ ".get: unknown (or unsupported) tag") +- +--- * Binary instances +- +-instance Binary (HsExpr GhcSe) where +- put_ bh e = case e of +- HsVar a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- HsUnboundVar a b -> +- putByte bh 1 >> put_ bh a >> put_ bh b +- HsRecFld a b -> +- putByte bh 2 >> put_ bh a >> put_ bh b +- HsOverLabel a b c -> +- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c +- HsIPVar a b -> +- putByte bh 4 >> put_ bh a >> put_ bh b +- HsOverLit a b -> +- putByte bh 5 >> put_ bh a >> put_ bh b +- HsLit a b -> +- putByte bh 6 >> put_ bh a >> put_ bh b +- HsLam a b -> +- putByte bh 7 >> put_ bh a >> put_ bh b +- HsLamCase a b -> +- putByte bh 8 >> put_ bh a >> put_ bh b +- HsApp a b c -> +- putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c +- HsAppType a b -> +- putByte bh 10 >> put_ bh a >> put_ bh b +- OpApp a b c d -> +- putByte bh 11 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d +- NegApp a b c -> +- putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c +- HsPar a b -> +- putByte bh 13 >> put_ bh a >> put_ bh b +- SectionL a b c -> +- putByte bh 14 >> put_ bh a >> put_ bh b >> put_ bh c +- SectionR a b c -> +- putByte bh 15 >> put_ bh a >> put_ bh b >> put_ bh c +- ExplicitTuple a b c -> +- putByte bh 16 >> put_ bh a >> put_ bh b >> put_ bh c +- ExplicitSum a b c d -> +- putByte bh 17 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d +- HsCase a b c -> +- putByte bh 18 >> put_ bh a >> put_ bh b >> put_ bh c +- HsIf a b c d e -> +- putByte bh 19 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d >> put_ bh e +- HsMultiIf a b -> +- putByte bh 20 >> put_ bh a >> put_ bh b +- HsLet a b c -> +- putByte bh 21 >> put_ bh a >> put_ bh b >> put_ bh c +- HsDo a b c -> +- putByte bh 22 >> put_ bh a >> put_ bh b >> put_ bh c +- ExplicitList a b c -> +- putByte bh 23 >> put_ bh a >> put_ bh b >> put_ bh c +- RecordCon a b c -> +- putByte bh 24 >> put_ bh a >> put_ bh b >> put_ bh c +- RecordUpd a b c -> +- putByte bh 25 >> put_ bh a >> put_ bh b >> put_ bh c +- ExprWithTySig a b -> +- putByte bh 26 >> put_ bh a >> put_ bh b +- ArithSeq a b c -> +- putByte bh 27 >> put_ bh a >> put_ bh b >> put_ bh c +- EWildPat a -> +- putByte bh 28 >> put_ bh a +- EAsPat a b c -> +- putByte bh 29 >> put_ bh a >> put_ bh b >> put_ bh c +- EViewPat a b c -> +- putByte bh 30 >> put_ bh a >> put_ bh b >> put_ bh c +- ELazyPat a b -> +- putByte bh 31 >> put_ bh a >> put_ bh b +- HsStatic a b -> +- putByte bh 32 >> put_ bh a >> put_ bh b +- HsProc a b c -> +- putByte bh 33 >> put_ bh a >> put_ bh b >> put_ bh c +- HsBinTick a b c d -> +- putByte bh 34 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d +- HsTickPragma a b c d e -> +- putByte bh 35 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d >> put_ bh e +- HsSpliceE a b -> +- putByte bh 36 >> put_ bh a >> put_ bh b +- HsSCC a b c d -> +- putByte bh 37 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d +- HsCoreAnn a b c d -> +- putByte bh 38 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d +- HsBracket a b -> +- putByte bh 39 >> put_ bh a >> put_ bh b +- XExpr a -> +- putByte bh 40 >> put_ bh a +- HsConLikeOut {} -> putPanic "HsExpr" "HsConLikeOut" +- HsRnBracketOut {} -> putPanic "HsExpr" "HsRnBracketOut" +- HsTcBracketOut {} -> putPanic "HsExpr" "HsTcBracketOut" +- HsArrApp {} -> putPanic "HsExpr" "HsArrApp" +- HsArrForm {} -> putPanic "HsExpr" "HsArrForm" +- HsTick {} -> putPanic "HsExpr" "HsTick" +- HsWrap {} -> putPanic "HsExpr" "HsWrap" +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsVar <$> get bh <*> get bh +- 1 -> HsUnboundVar <$> get bh <*> get bh +- 2 -> HsRecFld <$> get bh <*> get bh +- 3 -> HsOverLabel <$> get bh <*> get bh <*> get bh +- 4 -> HsIPVar <$> get bh <*> get bh +- 5 -> HsOverLit <$> get bh <*> get bh +- 6 -> HsLit <$> get bh <*> get bh +- 7 -> HsLam <$> get bh <*> get bh +- 8 -> HsLamCase <$> get bh <*> get bh +- 9 -> HsApp <$> get bh <*> get bh <*> get bh +- 10 -> HsAppType <$> get bh <*> get bh +- 11 -> OpApp <$> get bh <*> get bh <*> get bh <*> get bh +- 12 -> NegApp <$> get bh <*> get bh <*> get bh +- 13 -> HsPar <$> get bh <*> get bh +- 14 -> SectionL <$> get bh <*> get bh <*> get bh +- 15 -> SectionR <$> get bh <*> get bh <*> get bh +- 16 -> ExplicitTuple <$> get bh <*> get bh <*> get bh +- 17 -> ExplicitSum <$> get bh <*> get bh <*> get bh <*> get bh +- 18 -> HsCase <$> get bh <*> get bh <*> get bh +- 19 -> HsIf <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh +- 20 -> HsMultiIf <$> get bh <*> get bh +- 21 -> HsLet <$> get bh <*> get bh <*> get bh +- 22 -> HsDo <$> get bh <*> get bh <*> get bh +- 23 -> ExplicitList <$> get bh <*> get bh <*> get bh +- 24 -> RecordCon <$> get bh <*> get bh <*> get bh +- 25 -> RecordUpd <$> get bh <*> get bh <*> get bh +- 26 -> ExprWithTySig <$> get bh <*> get bh +- 27 -> ArithSeq <$> get bh <*> get bh <*> get bh +- 28 -> EWildPat <$> get bh +- 29 -> EAsPat <$> get bh <*> get bh <*> get bh +- 30 -> EViewPat <$> get bh <*> get bh <*> get bh +- 31 -> ELazyPat <$> get bh <*> get bh +- 32 -> HsStatic <$> get bh <*> get bh +- 33 -> HsProc <$> get bh <*> get bh <*> get bh +- 34 -> HsBinTick <$> get bh <*> get bh <*> get bh <*> get bh +- 35 -> HsTickPragma <$> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh +- 36 -> HsSpliceE <$> get bh <*> get bh +- 37 -> HsSCC <$> get bh <*> get bh <*> get bh <*> get bh +- 38 -> HsCoreAnn <$> get bh <*> get bh <*> get bh <*> get bh +- 39 -> HsBracket <$> get bh <*> get bh +- 40 -> XExpr <$> get bh +- _ -> getPanic "HsExpr" +- +-instance Binary (HsBracket GhcSe) where +- put_ bh b = case b of +- ExpBr a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- PatBr a b -> +- putByte bh 1 >> put_ bh a >> put_ bh b +- DecBrL a b -> +- putByte bh 2 >> put_ bh a >> put_ bh b +- DecBrG a b -> +- putByte bh 3 >> put_ bh a >> put_ bh b +- TypBr a b -> +- putByte bh 4 >> put_ bh a >> put_ bh b +- VarBr a b c -> +- putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c +- TExpBr a b -> +- putByte bh 6 >> put_ bh a >> put_ bh b +- XBracket a -> +- putByte bh 7 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ExpBr <$> get bh <*> get bh +- 1 -> PatBr <$> get bh <*> get bh +- 2 -> DecBrL <$> get bh <*> get bh +- 3 -> DecBrG <$> get bh <*> get bh +- 4 -> TypBr <$> get bh <*> get bh +- 5 -> VarBr <$> get bh <*> get bh <*> get bh +- 6 -> TExpBr <$> get bh <*> get bh +- 7 -> XBracket <$> get bh +- _ -> getPanic "HsBracket" +- +-instance Binary SeName where +- put_ bh (SeName n) = put_ bh n +- get bh = mkSeName <$> get bh +- +-instance Binary UnboundVar where +- put_ bh v = case v of +- OutOfScope a b -> putByte bh 0 >> put_ bh a >> put_ bh b +- TrueExprHole a -> putByte bh 1 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> OutOfScope <$> get bh <*> get bh +- 1 -> TrueExprHole <$> get bh +- _ -> getPanic "UnboundVar" +- +-instance Binary a => Binary (StmtLR GhcSe GhcSe a) where +- put_ bh s = case s of +- LastStmt a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- BindStmt a b c d e -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e +- ApplicativeStmt a b c -> +- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c +- BodyStmt a b c d -> +- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- LetStmt a b -> +- putByte bh 4 >> put_ bh a >> put_ bh b +- ParStmt a b c d -> +- putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- RecStmt a b c d e f g -> +- putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f >> put_ bh g +- TransStmt a b c d e f g h i -> +- putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h +- >> put_ bh i +- XStmtLR a -> +- putByte bh 8 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> LastStmt <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> BindStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh +- 2 -> ApplicativeStmt <$> get bh <*> get bh <*> get bh +- 3 -> BodyStmt <$> get bh <*> get bh <*> get bh <*> get bh +- 4 -> LetStmt <$> get bh <*> get bh +- 5 -> ParStmt <$> get bh <*> get bh <*> get bh <*> get bh +- 6 -> RecStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh +- 7 -> TransStmt <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh +- 8 -> XStmtLR <$> get bh +- _ -> getPanic "StmtLR" +- +-instance Binary (HsGroup GhcSe) where +- put_ bh x = case x of +- HsGroup a b c d e f g h i j k l -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h +- >> put_ bh i >> put_ bh j >> put_ bh k >> put_ bh l +- XHsGroup a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsGroup <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh <*> get bh <*> get bh +- 1 -> XHsGroup <$> get bh +- _ -> getPanic "HsGroup" +- +-instance Binary (TyClGroup GhcSe) where +- put_ bh g = case g of +- TyClGroup a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- XTyClGroup a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> TyClGroup <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> XTyClGroup <$> get bh +- _ -> getPanic "TyClGroup" +- +-instance Binary (HsCmdTop GhcSe) where +- put_ bh c = case c of +- HsCmdTop a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- XCmdTop a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsCmdTop <$> get bh <*> get bh +- 1 -> XCmdTop <$> get bh +- _ -> getPanic "HsCmdTop" +- +-instance Binary (HsCmd GhcSe) where +- put_ bh c = case c of +- HsCmdArrApp a b c d e -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d >> put_ bh e +- HsCmdArrForm a b c d e -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d >> put_ bh e +- HsCmdApp a b c -> +- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c +- HsCmdLam a b -> +- putByte bh 3 >> put_ bh a >> put_ bh b +- HsCmdPar a b -> +- putByte bh 4 >> put_ bh a >> put_ bh b +- HsCmdCase a b c -> +- putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c +- HsCmdIf a b c d e -> +- putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d >> put_ bh e +- HsCmdLet a b c -> +- putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c +- HsCmdDo a b -> +- putByte bh 8 >> put_ bh a >> put_ bh b +- XCmd a -> +- putByte bh 9 >> put_ bh a +- HsCmdWrap {} -> +- putPanic "HsCmdWrap" "HsCmd" +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsCmdArrApp <$> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh +- 1 -> HsCmdArrForm <$> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh +- 2 -> HsCmdApp <$> get bh <*> get bh <*> get bh +- 3 -> HsCmdLam <$> get bh <*> get bh +- 4 -> HsCmdPar <$> get bh <*> get bh +- 5 -> HsCmdCase <$> get bh <*> get bh <*> get bh +- 6 -> HsCmdIf <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh +- 7 -> HsCmdLet <$> get bh <*> get bh <*> get bh +- 8 -> HsCmdDo <$> get bh <*> get bh +- 9 -> XCmd <$> get bh +- _ -> getPanic "HsCmd" +- +-instance Binary HsArrAppType where +- put_ bh t = putByte bh $ case t of +- HsHigherOrderApp -> 0 +- HsFirstOrderApp -> 1 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure HsHigherOrderApp +- 1 -> pure HsFirstOrderApp +- _ -> getPanic "HsArrAppType" +- +-instance Binary TransForm where +- put_ bh f = putByte bh $ case f of +- ThenForm -> 0 +- GroupForm -> 1 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure ThenForm +- 1 -> pure GroupForm +- _ -> getPanic "TransForm" +- +-instance Binary (ApplicativeArg GhcSe) where +- put_ bh a = case a of +- ApplicativeArgOne a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- ApplicativeArgMany a b c d -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- XApplicativeArg a -> +- putByte bh 2 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ApplicativeArgOne <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> ApplicativeArgMany <$> get bh <*> get bh <*> get bh <*> get bh +- 2 -> XApplicativeArg <$> get bh +- _ -> getPanic "ApplicativeArg" +- +-instance Binary (ParStmtBlock GhcSe GhcSe) where +- put_ bh b = case b of +- ParStmtBlock a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- XParStmtBlock a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ParStmtBlock <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> XParStmtBlock <$> get bh +- _ -> getPanic "ParStmtBlock" +- +-instance Binary (SyntaxExpr GhcSe) where +- put_ bh (SyntaxExpr a [] WpHole) = put_ bh a +- put_ _ _ = panic "Binary SyntaxExpr.put: wrappers should be empty" +- get bh = SyntaxExpr <$> get bh <*> pure [] <*> pure WpHole +- +-instance Binary a => Binary (GRHSs GhcSe a) where +- put_ bh g = case g of +- GRHSs a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XGRHSs a -> putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> GRHSs <$> get bh <*> get bh <*> get bh +- 1 -> XGRHSs <$> get bh +- _ -> getPanic "GRHSs" +- +-instance Binary a => Binary (GRHS GhcSe a) where +- put_ bh g = case g of +- GRHS a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XGRHS a -> putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> GRHS <$> get bh <*> get bh <*> get bh +- 1 -> XGRHS <$> get bh +- _ -> getPanic "GRHS" +- +-instance Binary a => Binary (MatchGroup GhcSe a) where +- put_ bh g = case g of +- MG a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XMatchGroup a -> putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> MG <$> get bh <*> get bh <*> get bh +- 1 -> XMatchGroup <$> get bh +- _ -> getPanic "MatchGroup" +- +-instance Binary a => Binary (Match GhcSe a) where +- put_ bh m = case m of +- Match a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- XMatch a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> Match <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> XMatch <$> get bh +- _ -> getPanic "Match" +- +-instance Binary (HsMatchContext SeName) where +- put_ bh c = case c of +- FunRhs a b c -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- LambdaExpr -> +- putByte bh 1 +- CaseAlt -> +- putByte bh 2 +- IfAlt -> +- putByte bh 3 +- ProcExpr -> +- putByte bh 4 +- PatBindRhs -> +- putByte bh 5 +- RecUpd -> +- putByte bh 6 +- StmtCtxt a -> +- putByte bh 7 >> put_ bh a +- ThPatSplice -> +- putByte bh 8 +- ThPatQuote -> +- putByte bh 9 +- PatSyn -> +- putByte bh 10 +- PatBindGuards -> +- putByte bh 11 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> FunRhs <$> get bh <*> get bh <*> get bh +- 1 -> pure LambdaExpr +- 2 -> pure CaseAlt +- 3 -> pure IfAlt +- 4 -> pure ProcExpr +- 5 -> pure PatBindRhs +- 6 -> pure RecUpd +- 7 -> StmtCtxt <$> get bh +- 8 -> pure ThPatSplice +- 9 -> pure ThPatQuote +- 10 -> pure PatSyn +- 11 -> pure PatBindGuards +- _ -> getPanic "HsMatchContext" +- +-instance Binary (HsStmtContext SeName) where +- put_ bh c = case c of +- ListComp -> putByte bh 0 +- MonadComp -> putByte bh 1 +- DoExpr -> putByte bh 3 +- MDoExpr -> putByte bh 4 +- ArrowExpr -> putByte bh 5 +- GhciStmtCtxt -> putByte bh 6 +- PatGuard a -> putByte bh 7 >> put_ bh a +- ParStmtCtxt a -> putByte bh 8 >> put_ bh a +- TransStmtCtxt a -> putByte bh 9 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure ListComp +- 1 -> pure MonadComp +- 3 -> pure DoExpr +- 4 -> pure MDoExpr +- 5 -> pure ArrowExpr +- 6 -> pure GhciStmtCtxt +- 7 -> PatGuard <$> get bh +- 8 -> ParStmtCtxt <$> get bh +- 9 -> TransStmtCtxt <$> get bh +- _ -> getPanic "HsStmtContext" +- +-instance Binary (ArithSeqInfo GhcSe) where +- put_ bh i = case i of +- From a -> +- putByte bh 0 >> put_ bh a +- FromThen a b -> +- putByte bh 1 >> put_ bh a >> put_ bh b +- FromTo a b -> +- putByte bh 2 >> put_ bh a >> put_ bh b +- FromThenTo a b c -> +- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> From <$> get bh +- 1 -> FromThen <$> get bh <*> get bh +- 2 -> FromTo <$> get bh <*> get bh +- 3 -> FromThenTo <$> get bh <*> get bh <*> get bh +- _ -> getPanic "ArithSeqInfo" +- +-instance Binary (HsTupArg GhcSe) where +- put_ bh a = case a of +- Present a b -> putByte bh 0 >> put_ bh a >> put_ bh b +- Missing a -> putByte bh 1 >> put_ bh a +- XTupArg a -> putByte bh 2 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> Present <$> get bh <*> get bh +- 1 -> Missing <$> get bh +- 2 -> XTupArg <$> get bh +- _ -> getPanic "HsTupArg" +- +-instance Binary (Pat GhcSe) where +- put_ bh p = case p of +- WildPat a -> +- putByte bh 0 >> put_ bh a +- VarPat a b -> +- putByte bh 1 >> put_ bh a >> put_ bh b +- LazyPat a b -> +- putByte bh 2 >> put_ bh a >> put_ bh b +- AsPat a b c -> +- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c +- ParPat a b -> +- putByte bh 4 >> put_ bh a >> put_ bh b +- BangPat a b -> +- putByte bh 5 >> put_ bh a >> put_ bh b +- ListPat a b -> +- putByte bh 6 >> put_ bh a >> put_ bh b +- TuplePat a b c -> +- putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c +- SumPat a b c d -> +- putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- ConPatIn a b -> +- putByte bh 9 >> put_ bh a >> put_ bh b +- ViewPat a b c -> +- putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c +- LitPat a b -> +- putByte bh 11 >> put_ bh a >> put_ bh b +- NPat a b c d -> +- putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- NPlusKPat a b c d e f -> +- putByte bh 13 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f +- SigPat a b -> +- putByte bh 14 >> put_ bh a >> put_ bh b +- SplicePat a b -> +- putByte bh 15 >> put_ bh a >> put_ bh b +- XPat a -> +- putByte bh 16 >> put_ bh a +- ConPatOut {} -> putPanic "Pat" "ConPatOut" +- CoPat {} -> putPanic "Pat" "CoPat" +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> WildPat <$> get bh +- 1 -> VarPat <$> get bh <*> get bh +- 2 -> LazyPat <$> get bh <*> get bh +- 3 -> AsPat <$> get bh <*> get bh <*> get bh +- 4 -> ParPat <$> get bh <*> get bh +- 5 -> BangPat <$> get bh <*> get bh +- 6 -> ListPat <$> get bh <*> get bh +- 7 -> TuplePat <$> get bh <*> get bh <*> get bh +- 8 -> SumPat <$> get bh <*> get bh <*> get bh <*> get bh +- 9 -> ConPatIn <$> get bh <*> get bh +- 10 -> ViewPat <$> get bh <*> get bh <*> get bh +- 11 -> LitPat <$> get bh <*> get bh +- 12 -> NPat <$> get bh <*> get bh <*> get bh <*> get bh +- 13 -> NPlusKPat <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh +- 14 -> SigPat <$> get bh <*> get bh +- 15 -> SplicePat <$> get bh <*> get bh +- 16 -> XPat <$> get bh +- _ -> getPanic "HsPat" +- +-instance Binary NoExt where +- put_ _ NoExt = return () +- get _ = pure NoExt +- +-instance (Binary (FieldOcc a), Binary b) => Binary (HsRecFields a b) where +- put_ bh (HsRecFields a b) = put_ bh a >> put_ bh b +- get bh = HsRecFields <$> get bh <*> get bh +- +-instance (Binary id, Binary arg) => Binary (HsRecField' id arg) where +- put_ bh (HsRecField a b c) = put_ bh a >> put_ bh b >> put_ bh c +- get bh = HsRecField <$> get bh <*> get bh <*> get bh +- +-instance Binary (HsType GhcSe) where +- put_ bh t = case t of +- HsForAllTy a b c -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- HsQualTy a b c -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c +- HsTyVar a b c -> +- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c +- HsAppTy a b c -> +- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c +- HsFunTy a b c -> +- putByte bh 4 >> put_ bh a >> put_ bh b >> put_ bh c +- HsListTy a b -> +- putByte bh 5 >> put_ bh a >> put_ bh b +- HsTupleTy a b c -> +- putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c +- HsSumTy a b -> +- putByte bh 7 >> put_ bh a >> put_ bh b +- HsOpTy a b c d -> +- putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- HsParTy a b -> +- putByte bh 9 >> put_ bh a >> put_ bh b +- HsIParamTy a b c -> +- putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c +- HsKindSig a b c -> +- putByte bh 11 >> put_ bh a >> put_ bh b >> put_ bh c +- HsBangTy a b c -> +- putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c +- HsRecTy a b -> +- putByte bh 13 >> put_ bh a >> put_ bh b +- HsExplicitListTy a b c -> +- putByte bh 14 >> put_ bh a >> put_ bh b >> put_ bh c +- HsExplicitTupleTy a b -> +- putByte bh 15 >> put_ bh a >> put_ bh b +- HsTyLit a b -> +- putByte bh 16 >> put_ bh a >> put_ bh b +- HsWildCardTy a -> +- putByte bh 17 >> put_ bh a +- HsDocTy a b c -> +- putByte bh 18 >> put_ bh a >> put_ bh b >> put_ bh c +- HsSpliceTy a b -> +- putByte bh 19 >> put_ bh a >> put_ bh b +- HsStarTy a b -> +- putByte bh 20 >> put_ bh a >> put_ bh b +- XHsType _ -> +- putPanic "XHsType" "HsType" +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsForAllTy <$> get bh <*> get bh <*> get bh +- 1 -> HsQualTy <$> get bh <*> get bh <*> get bh +- 2 -> HsTyVar <$> get bh <*> get bh <*> get bh +- 3 -> HsAppTy <$> get bh <*> get bh <*> get bh +- 4 -> HsFunTy <$> get bh <*> get bh <*> get bh +- 5 -> HsListTy <$> get bh <*> get bh +- 6 -> HsTupleTy <$> get bh <*> get bh <*> get bh +- 7 -> HsSumTy <$> get bh <*> get bh +- 8 -> HsOpTy <$> get bh <*> get bh <*> get bh <*> get bh +- 9 -> HsParTy <$> get bh <*> get bh +- 10 -> HsIParamTy <$> get bh <*> get bh <*> get bh +- 11 -> HsKindSig <$> get bh <*> get bh <*> get bh +- 12 -> HsBangTy <$> get bh <*> get bh <*> get bh +- 13 -> HsRecTy <$> get bh <*> get bh +- 14 -> HsExplicitListTy <$> get bh <*> get bh <*> get bh +- 15 -> HsExplicitTupleTy <$> get bh <*> get bh +- 16 -> HsTyLit <$> get bh <*> get bh +- 17 -> HsWildCardTy <$> get bh +- 18 -> HsDocTy <$> get bh <*> get bh <*> get bh +- 19 -> HsSpliceTy <$> get bh <*> get bh +- 20 -> HsStarTy <$> get bh <*> get bh +- _ -> getPanic "HsType" +- +-instance Binary HsTyLit where +- put_ bh l = case l of +- HsNumTy a b -> putByte bh 0 >> put_ bh a >> put_ bh b +- HsStrTy a b -> putByte bh 1 >> put_ bh a >> put_ bh b +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsNumTy <$> get bh <*> get bh +- 1 -> HsStrTy <$> get bh <*> get bh +- _ -> getPanic "HsTyLit" +- +-instance Binary a => Binary (HsWildCardBndrs GhcSe a) where +- put_ bh w = case w of +- HsWC a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- XHsWildCardBndrs a -> +- putByte bh 1 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsWC <$> get bh <*> get bh +- 1 -> XHsWildCardBndrs <$> get bh +- _ -> getPanic "HsWildCardBndrs" +- +-instance Binary a => Binary (HsImplicitBndrs GhcSe a) where +- put_ bh b = case b of +- HsIB a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- XHsImplicitBndrs a -> +- putByte bh 1 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsIB <$> get bh <*> get bh +- 1 -> XHsImplicitBndrs <$> get bh +- _ -> getPanic "HsImplicitBndrs" +- +-instance Binary HsTupleSort where +- put_ bh s = putByte bh (case s of +- HsUnboxedTuple -> 0 +- HsBoxedTuple -> 1 +- HsConstraintTuple -> 2 +- HsBoxedOrConstraintTuple -> 3) +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure HsUnboxedTuple +- 1 -> pure HsBoxedTuple +- 2 -> pure HsConstraintTuple +- 3 -> pure HsBoxedOrConstraintTuple +- _ -> getPanic "HsTupleSort" +- +-instance Binary (ConDeclField GhcSe) where +- put_ bh f = case f of +- ConDeclField a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- XConDeclField a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ConDeclField <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> XConDeclField <$> get bh +- _ -> getPanic "ConDeclField" +- +-instance Binary (FieldOcc GhcSe) where +- put_ bh o = case o of +- FieldOcc a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- XFieldOcc a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> FieldOcc <$> get bh <*> get bh +- 1 -> XFieldOcc <$> get bh +- _ -> getPanic "FieldOcc" +- +-instance Binary (HsTyVarBndr GhcSe) where +- put_ bh v = case v of +- UserTyVar a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- KindedTyVar a b c -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c +- XTyVarBndr a -> +- putByte bh 2 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> UserTyVar <$> get bh <*> get bh +- 1 -> KindedTyVar <$> get bh <*> get bh <*> get bh +- 2 -> XTyVarBndr <$> get bh +- _ -> getPanic "HsTyVarBndr" +- +-instance (Binary a, Binary b) => Binary (HsConDetails a b) where +- put_ bh c = case c of +- PrefixCon a -> putByte bh 0 >> put_ bh a +- RecCon a -> putByte bh 1 >> put_ bh a +- InfixCon a b -> putByte bh 2 >> put_ bh a >> put_ bh b +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> PrefixCon <$> get bh +- 1 -> RecCon <$> get bh +- 2 -> InfixCon <$> get bh <*> get bh +- _ -> getPanic "HsConDetails" +- +-instance Binary (AmbiguousFieldOcc GhcSe) where +- put_ bh o = case o of +- Unambiguous a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- Ambiguous a b -> +- putByte bh 1 >> put_ bh a >> put_ bh b +- XAmbiguousFieldOcc a -> +- putByte bh 2 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> Unambiguous <$> get bh <*> get bh +- 1 -> Ambiguous <$> get bh <*> get bh +- 2 -> XAmbiguousFieldOcc <$> get bh +- _ -> getPanic "AmbiguousOccField" +- +-instance Binary (LHsQTyVars GhcSe) where +- put_ bh v = case v of +- HsQTvs a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- XLHsQTyVars a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsQTvs <$> get bh <*> get bh +- 1 -> XLHsQTyVars <$> get bh +- _ -> getPanic "LHsQTyVars" +- +-instance Binary (Sig GhcSe) where +- put_ bh s = case s of +- TypeSig a b c -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- PatSynSig a b c -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c +- ClassOpSig a b c d -> +- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- IdSig a b -> +- putByte bh 3 >> put_ bh a >> put_ bh b +- FixSig a b -> +- putByte bh 4 >> put_ bh a >> put_ bh b +- InlineSig a b c -> +- putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c +- SpecSig a b c d -> +- putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- SpecInstSig a b c -> +- putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c +- SCCFunSig a b c d -> +- putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- CompleteMatchSig a b c d -> +- putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- MinimalSig a b c -> +- putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c +- XSig a -> +- putByte bh 11 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> TypeSig <$> get bh <*> get bh <*> get bh +- 1 -> PatSynSig <$> get bh <*> get bh <*> get bh +- 2 -> ClassOpSig <$> get bh <*> get bh <*> get bh <*> get bh +- 3 -> IdSig <$> get bh <*> get bh +- 4 -> FixSig <$> get bh <*> get bh +- 5 -> InlineSig <$> get bh <*> get bh <*> get bh +- 6 -> SpecSig <$> get bh <*> get bh <*> get bh <*> get bh +- 7 -> SpecInstSig <$> get bh <*> get bh <*> get bh +- 8 -> SCCFunSig <$> get bh <*> get bh <*> get bh <*> get bh +- 9 -> CompleteMatchSig <$> get bh <*> get bh <*> get bh <*> get bh +- 10 -> MinimalSig <$> get bh <*> get bh <*> get bh +- 11 -> XSig <$> get bh +- _ -> getPanic "Sig" +- +-instance Binary (FixitySig GhcSe) where +- put_ bh s = case s of +- FixitySig a b c -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XFixitySig a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> FixitySig <$> get bh <*> get bh <*> get bh +- 1 -> XFixitySig <$> get bh +- _ -> getPanic "FixitySig" +- +-instance Binary (HsBindLR GhcSe GhcSe) where +- put_ bh b = case b of +- -- TODO: we drop the "fun_co_fn" field, as it seems +- -- to always be WpHole in the places where the binary +- -- serialisation instances will be used. +- -- TODO: we drop the "fun_tick" field, as it is unlikely +- -- to be used in our immediate use cases. Let's +- -- return to parametrising away the 'Id' in that +- -- field's type. +- FunBind a b c d _ -> case d of +- WpHole -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- _ -> +- panic "Binary HsBindLR: FunBind with non-WpHole value in fun_co_fn" +- -- TODO: same as for FunBind, we drop pat_ticks +- PatBind a b c _ -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c +- VarBind a b c d -> +- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- PatSynBind a b -> +- putByte bh 3 >> put_ bh a >> put_ bh b +- XHsBindsLR a -> +- putByte bh 4 >> put_ bh a +- AbsBinds {} -> putPanic "HsBindsLR" "AbsBinds" +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> FunBind <$> get bh <*> get bh <*> get bh <*> pure WpHole <*> pure [] +- 1 -> PatBind <$> get bh <*> get bh <*> get bh <*> pure ([], []) +- 2 -> VarBind <$> get bh <*> get bh <*> get bh <*> get bh +- 3 -> PatSynBind <$> get bh <*> get bh +- 4 -> XHsBindsLR <$> get bh +- _ -> getPanic "HsBindsLR" +- +-instance Binary (HsLocalBindsLR GhcSe GhcSe) where +- put_ bh b = case b of +- HsValBinds a b -> putByte bh 0 >> put_ bh a >> put_ bh b +- EmptyLocalBinds a -> putByte bh 1 >> put_ bh a +- XHsLocalBindsLR a -> putByte bh 2 >> put_ bh a +- HsIPBinds {} -> putPanic "HsLocalBindsLR" "HsIPBinds" +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsValBinds <$> get bh <*> get bh +- 1 -> EmptyLocalBinds <$> get bh +- 2 -> XHsLocalBindsLR <$> get bh +- _ -> getPanic "HsLocalBindsLR" +- +-instance Binary (HsValBindsLR GhcSe GhcSe) where +- put_ bh b = case b of +- ValBinds a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XValBindsLR {} -> putPanic "HsValBindsLR" "ValBindsOut" +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ValBinds <$> get bh <*> get bh <*> get bh +- _ -> getPanic "HsValBindsLR" +- +-instance Binary (PatSynBind GhcSe GhcSe) where +- put_ bh b = case b of +- PSB a b c d e -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e +- XPatSynBind a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> PSB <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh +- 1 -> XPatSynBind <$> get bh +- _ -> getPanic "PatSynBind" +- +-instance Binary (HsPatSynDir GhcSe) where +- put_ bh d = case d of +- Unidirectional -> putByte bh 0 +- ImplicitBidirectional -> putByte bh 1 +- ExplicitBidirectional a -> putByte bh 2 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure Unidirectional +- 1 -> pure ImplicitBidirectional +- 2 -> ExplicitBidirectional <$> get bh +- _ -> getPanic "HsPatSynDir" +- +-instance Binary a => Binary (RecordPatSynField a) where +- put_ bh (RecordPatSynField a b) = put_ bh a >> put_ bh b +- get bh = RecordPatSynField <$> get bh <*> get bh +- +-instance Binary (IPBind GhcSe) where +- put_ bh i = case i of +- IPBind a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XIPBind a -> putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> IPBind <$> get bh <*> get bh <*> get bh +- 1 -> XIPBind <$> get bh +- _ -> getPanic "IPBind" +- +--- * HsDecls +- +-instance Binary (HsDecl GhcSe) where +- put_ bh d = case d of +- TyClD a b -> putByte bh 0 >> put_ bh a >> put_ bh b +- InstD a b -> putByte bh 1 >> put_ bh a >> put_ bh b +- DerivD a b -> putByte bh 2 >> put_ bh a >> put_ bh b +- ValD a b -> putByte bh 3 >> put_ bh a >> put_ bh b +- SigD a b -> putByte bh 4 >> put_ bh a >> put_ bh b +- DefD a b -> putByte bh 5 >> put_ bh a >> put_ bh b +- ForD a b -> putByte bh 6 >> put_ bh a >> put_ bh b +- WarningD a b -> putByte bh 7 >> put_ bh a >> put_ bh b +- RoleAnnotD a b -> putByte bh 8 >> put_ bh a >> put_ bh b +- RuleD a b -> putByte bh 9 >> put_ bh a >> put_ bh b +- AnnD a b -> putByte bh 10 >> put_ bh a >> put_ bh b +- SpliceD a b -> putByte bh 11 >> put_ bh a >> put_ bh b +- DocD a b -> putByte bh 12 >> put_ bh a >> put_ bh b +- XHsDecl a -> putByte bh 13 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> TyClD <$> get bh <*> get bh +- 1 -> InstD <$> get bh <*> get bh +- 2 -> DerivD <$> get bh <*> get bh +- 3 -> ValD <$> get bh <*> get bh +- 4 -> SigD <$> get bh <*> get bh +- 5 -> DefD <$> get bh <*> get bh +- 6 -> ForD <$> get bh <*> get bh +- 7 -> WarningD <$> get bh <*> get bh +- 8 -> RoleAnnotD <$> get bh <*> get bh +- 9 -> RuleD <$> get bh <*> get bh +- 10 -> AnnD <$> get bh <*> get bh +- 11 -> SpliceD <$> get bh <*> get bh +- 12 -> DocD <$> get bh <*> get bh +- 13 -> XHsDecl <$> get bh +- _ -> getPanic "HsDecl" +- +-instance Binary (ForeignDecl GhcSe) where +- put_ bh d = case d of +- ForeignImport a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d +- ForeignExport a b c d -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d +- XForeignDecl a -> +- putByte bh 2 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ForeignImport <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> ForeignExport <$> get bh <*> get bh <*> get bh <*> get bh +- 2 -> XForeignDecl <$> get bh +- _ -> getPanic "ForeignDecl" +- +-instance Binary (DefaultDecl GhcSe) where +- put_ bh d = case d of +- DefaultDecl a b -> putByte bh 0 >> put_ bh a >> put_ bh b +- XDefaultDecl a -> putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> DefaultDecl <$> get bh <*> get bh +- 1 -> XDefaultDecl <$> get bh +- _ -> getPanic "DefaultDecl" +- +-instance Binary (TyClDecl GhcSe) where +- put_ bh d = case d of +- FamDecl a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- SynDecl a b c d e -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d >> put_ bh e +- DataDecl a b c d e -> +- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d >> put_ bh e +- ClassDecl a b c d e f g h i j k -> +- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c +- >> put_ bh d >> put_ bh e >> put_ bh f +- >> put_ bh g >> put_ bh h >> put_ bh i +- >> put_ bh j >> put_ bh k +- XTyClDecl a -> +- putByte bh 4 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> FamDecl <$> get bh <*> get bh +- 1 -> SynDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh +- 2 -> DataDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh +- 3 -> ClassDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh +- 4 -> XTyClDecl <$> get bh +- _ -> getPanic "TyClDecl" +- +-instance Binary DocDecl where +- put_ bh d = case d of +- DocCommentNext a -> putByte bh 0 >> put_ bh a +- DocCommentPrev a -> putByte bh 1 >> put_ bh a +- DocCommentNamed a b -> putByte bh 2 >> put_ bh a >> put_ bh b +- DocGroup a b -> putByte bh 3 >> put_ bh a >> put_ bh b +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> DocCommentNext <$> get bh +- 1 -> DocCommentPrev <$> get bh +- 2 -> DocCommentNamed <$> get bh <*> get bh +- 3 -> DocGroup <$> get bh <*> get bh +- _ -> getPanic "DocDecl" +- +-instance Binary (WarnDecls GhcSe) where +- put_ bh d = case d of +- Warnings a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XWarnDecls a -> putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> Warnings <$> get bh <*> get bh <*> get bh +- 1 -> XWarnDecls <$> get bh +- _ -> getPanic "WarnDecls" +- +-instance Binary (WarnDecl GhcSe) where +- put_ bh d = case d of +- Warning a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XWarnDecl a -> putByte bh 1 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> Warning <$> get bh <*> get bh <*> get bh +- 1 -> XWarnDecl <$> get bh +- _ -> getPanic "WarnDecl" +- +-instance Binary (RoleAnnotDecl GhcSe) where +- put_ bh d = case d of +- RoleAnnotDecl a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XRoleAnnotDecl a -> putByte bh 1 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> RoleAnnotDecl <$> get bh <*> get bh <*> get bh +- 1 -> XRoleAnnotDecl <$> get bh +- _ -> getPanic "RoleAnnotDecl" +- +-instance Binary (RuleDecls GhcSe) where +- put_ bh d = case d of +- HsRules a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XRuleDecls a -> putByte bh 1 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsRules <$> get bh <*> get bh <*> get bh +- 1 -> XRuleDecls <$> get bh +- _ -> getPanic "RuleDecls" +- +-instance Binary (RuleDecl GhcSe) where +- put_ bh decl = case decl of +- HsRule a b c d e f -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f +- XRuleDecl a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsRule <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh +- 1 -> XRuleDecl <$> get bh +- _ -> getPanic "RuleDecl" +- +-instance Binary (AnnDecl GhcSe) where +- put_ bh decl = case decl of +- HsAnnotation a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- XAnnDecl a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsAnnotation <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> XAnnDecl <$> get bh +- _ -> getPanic "AnnDecl" +- +-instance Binary (SpliceDecl GhcSe) where +- put_ bh d = case d of +- SpliceDecl a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XSpliceDecl a -> putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> SpliceDecl <$> get bh <*> get bh <*> get bh +- 1 -> XSpliceDecl <$> get bh +- _ -> getPanic "SpliceDecl" +- +-instance Binary a => Binary (Tickish a) where +- put_ bh t = case t of +- ProfNote a b c -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- HpcTick a b -> +- putByte bh 1 >> put_ bh a >> put_ bh b +- Breakpoint a b -> +- putByte bh 2 >> put_ bh a >> put_ bh b +- SourceNote a b -> +- putByte bh 3 >> put_ bh a >> put_ bh b +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ProfNote <$> get bh <*> get bh <*> get bh +- 1 -> HpcTick <$> get bh <*> get bh +- 2 -> Breakpoint <$> get bh <*> get bh +- 3 -> SourceNote <$> get bh <*> get bh +- _ -> getPanic "Tickish" +- +-instance Binary SpliceExplicitFlag where +- put_ bh f = putByte bh $ case f of +- ExplicitSplice -> 0 +- ImplicitSplice -> 1 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure ExplicitSplice +- 1 -> pure ImplicitSplice +- _ -> getPanic "SpliceExplicitFlag" +- +-instance Binary SpliceDecoration where +- put_ bh d = putByte bh $ case d of +- HasParens -> 0 +- HasDollar -> 1 +- NoParens -> 2 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure HasParens +- 1 -> pure HasDollar +- 2 -> pure NoParens +- _ -> getPanic "SpliceDecoration" +- +-instance Binary (HsSplice GhcSe) where +- put_ bh s = case s of +- HsTypedSplice a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- HsUntypedSplice a b c d -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- HsQuasiQuote a b c d e -> +- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e +- XSplice a -> +- putByte bh 3 >> put_ bh a +- HsSpliced {} -> putPanic "HsSplice" "HsSpliced" +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsTypedSplice <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> HsUntypedSplice <$> get bh <*> get bh <*> get bh <*> get bh +- 2 -> HsQuasiQuote <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh +- 3 -> XSplice <$> get bh +- _ -> getPanic "HsSplice" +- +-instance Binary (AnnProvenance SeName) where +- put_ bh p = case p of +- ValueAnnProvenance a -> putByte bh 0 >> put_ bh a +- TypeAnnProvenance a -> putByte bh 1 >> put_ bh a +- ModuleAnnProvenance -> putByte bh 2 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ValueAnnProvenance <$> get bh +- 1 -> TypeAnnProvenance <$> get bh +- 2 -> pure ModuleAnnProvenance +- _ -> getPanic "AnnProvenance" +- +-instance Binary ForeignImport where +- put_ bh (CImport a b c d e) = +- put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e +- get bh = CImport <$> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh +- +-instance Binary CImportSpec where +- put_ bh s = case s of +- CLabel a -> putByte bh 0 >> put_ bh a +- CFunction a -> putByte bh 1 >> put_ bh a +- CWrapper -> putByte bh 2 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> CLabel <$> get bh +- 1 -> CFunction <$> get bh +- 2 -> pure CWrapper +- _ -> getPanic "CImportSpec" +- +-instance Binary ForeignExport where +- put_ bh (CExport a b) = put_ bh a >> put_ bh b +- get bh = CExport <$> get bh <*> get bh +- +-instance Binary (RuleBndr GhcSe) where +- put_ bh b = case b of +- RuleBndr a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- RuleBndrSig a b c -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c +- XRuleBndr a -> +- putByte bh 2 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> RuleBndr <$> get bh <*> get bh +- 1 -> RuleBndrSig <$> get bh <*> get bh <*> get bh +- 2 -> XRuleBndr <$> get bh +- _ -> getPanic "RuleBndr" +- +-instance (Binary a, Binary b) => Binary (FamEqn GhcSe a b) where +- put_ bh e = case e of +- FamEqn a b c d e -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e +- XFamEqn a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> FamEqn <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh +- 1 -> XFamEqn <$> get bh +- _ -> getPanic "FamEqn" +- +-instance Binary (HsDataDefn GhcSe) where +- put_ bh d = case d of +- HsDataDefn a b c d e f g -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f >> put_ bh g +- XHsDataDefn a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsDataDefn <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh <*> get bh +- 1 -> XHsDataDefn <$> get bh +- _ -> getPanic "HsDataDefn" +- +-instance Binary NewOrData where +- put_ bh a = putByte bh (case a of +- NewType -> 0 +- DataType -> 1) +- get bh = getByte bh >>= \b -> case b of +- 0 -> pure NewType +- 1 -> pure DataType +- _ -> getPanic "NewOrData" +- +-instance Binary (HsDerivingClause GhcSe) where +- put_ bh c = case c of +- HsDerivingClause a b c -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XHsDerivingClause a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsDerivingClause <$> get bh <*> get bh <*> get bh +- 1 -> XHsDerivingClause <$> get bh +- _ -> getPanic "HsDerivingClause" +- +-instance Binary (ConDecl GhcSe) where +- put_ bh d = case d of +- ConDeclGADT a b c d e f g h -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h +- ConDeclH98 a b c d e f g -> +- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f >> put_ bh g +- XConDecl a -> +- putByte bh 2 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ConDeclGADT <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh <*> get bh <*> get bh +- 1 -> ConDeclH98 <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh <*> get bh +- 2 -> XConDecl <$> get bh +- _ -> getPanic "ConDecl" +- +- +-instance Binary (FamilyDecl GhcSe) where +- put_ bh d = case d of +- FamilyDecl a b c d e f g -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f >> put_ bh g +- XFamilyDecl a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> FamilyDecl <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh <*> get bh +- 1 -> XFamilyDecl <$> get bh +- _ -> getPanic "FamilyDecl" +- +-instance Binary (InjectivityAnn GhcSe) where +- put_ bh a = case a of +- InjectivityAnn a b -> put_ bh a >> put_ bh b +- get bh = InjectivityAnn <$> get bh <*> get bh +- +-instance Binary (FamilyInfo GhcSe) where +- put_ bh i = case i of +- DataFamily -> +- putByte bh 0 +- OpenTypeFamily -> +- putByte bh 1 +- ClosedTypeFamily a -> +- putByte bh 2 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure DataFamily +- 1 -> pure OpenTypeFamily +- 2 -> ClosedTypeFamily <$> get bh +- _ -> getPanic "FamilyInfo" +- +-instance Binary (FamilyResultSig GhcSe) where +- put_ bh s = case s of +- NoSig a -> +- putByte bh 0 >> put_ bh a +- KindSig a b -> +- putByte bh 1 >> put_ bh a >> put_ bh b +- TyVarSig a b -> +- putByte bh 2 >> put_ bh a >> put_ bh b +- XFamilyResultSig a -> +- putByte bh 3 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> NoSig <$> get bh +- 1 -> KindSig <$> get bh <*> get bh +- 2 -> TyVarSig <$> get bh <*> get bh +- 3 -> XFamilyResultSig <$> get bh +- _ -> getPanic "FamilyResultSig" +- +-instance Binary (InstDecl GhcSe) where +- put_ bh d = case d of +- ClsInstD a b -> +- putByte bh 0 >> put_ bh a >> put_ bh b +- DataFamInstD a b -> +- putByte bh 1 >> put_ bh a >> put_ bh b +- TyFamInstD a b -> +- putByte bh 2 >> put_ bh a >> put_ bh b +- XInstDecl a -> +- putByte bh 3 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ClsInstD <$> get bh <*> get bh +- 1 -> DataFamInstD <$> get bh <*> get bh +- 2 -> TyFamInstD <$> get bh <*> get bh +- 3 -> XInstDecl <$> get bh +- _ -> getPanic "InstDecl" +- +-instance Binary (ClsInstDecl GhcSe) where +- put_ bh d = case d of +- ClsInstDecl a b c d e f g -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- >> put_ bh e >> put_ bh f >> put_ bh g +- XClsInstDecl a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ClsInstDecl <$> get bh <*> get bh <*> get bh <*> get bh +- <*> get bh <*> get bh <*> get bh +- 1 -> XClsInstDecl <$> get bh +- _ -> getPanic "ClsInstDecl" +- +-instance Binary (DataFamInstDecl GhcSe) where +- put_ bh (DataFamInstDecl a) = put_ bh a +- get bh = DataFamInstDecl <$> get bh +- +-instance Binary (TyFamInstDecl GhcSe) where +- put_ bh (TyFamInstDecl a) = put_ bh a +- get bh = TyFamInstDecl <$> get bh +- +-instance Binary (DerivDecl GhcSe) where +- put_ bh d = case d of +- DerivDecl a b c d -> +- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d +- XDerivDecl a -> +- putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> DerivDecl <$> get bh <*> get bh <*> get bh <*> get bh +- 1 -> XDerivDecl <$> get bh +- _ -> getPanic "DerivDecl" +- +-instance Binary (DerivStrategy GhcSe) where +- put_ bh s = case s of +- StockStrategy -> putByte bh 0 +- AnyclassStrategy -> putByte bh 1 +- NewtypeStrategy -> putByte bh 2 +- ViaStrategy a -> putByte bh 3 >> put_ bh a +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure StockStrategy +- 1 -> pure AnyclassStrategy +- 2 -> pure NewtypeStrategy +- 3 -> ViaStrategy <$> get bh +- _ -> getPanic "DerivStrategy" +- +-instance Binary HsSrcBang where +- put_ bh (HsSrcBang a b c) = +- put_ bh a >> put_ bh b >> put_ bh c +- get bh = HsSrcBang <$> get bh <*> get bh <*> get bh +- +-instance Binary RdrName where +- put_ bh n = case n of +- Unqual a -> putByte bh 0 >> put_ bh a +- Qual a b -> putByte bh 1 >> put_ bh a >> put_ bh b +- Orig a b -> putByte bh 2 >> put_ bh a >> put_ bh b +- Exact a +- | isExternalName a -> putByte bh 3 >> put_ bh a +- | otherwise -> putByte bh (if isSystemName a then 4 else 5) +- >> put_ bh (nameUnique a) >> put_ bh (nameOccName a) +- >> put_ bh (nameSrcSpan a) +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> Unqual <$> get bh +- 1 -> Qual <$> get bh <*> get bh +- 2 -> Orig <$> get bh <*> get bh +- 3 -> Exact <$> get bh +- 4 -> fmap Exact (mkSystemNameAt <$> get bh <*> get bh <*> get bh) +- 5 -> fmap Exact (mkInternalName <$> get bh <*> get bh <*> get bh) +- _ -> getPanic "RdrName" +- +--- * HsLit +- +-instance Binary (HsLit GhcSe) where +- put_ bh lit +- = case lit of +- HsChar a b -> putByte bh 0 >> put_ bh a >> put_ bh b +- HsCharPrim a b -> putByte bh 1 >> put_ bh a >> put_ bh b +- HsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b +- HsStringPrim a b -> putByte bh 3 >> put_ bh a >> put_ bh b +- HsInt a b -> putByte bh 4 >> put_ bh a >> put_ bh b +- HsIntPrim a b -> putByte bh 5 >> put_ bh a >> put_ bh b +- HsWordPrim a b -> putByte bh 6 >> put_ bh a >> put_ bh b +- HsInt64Prim a b -> putByte bh 7 >> put_ bh a >> put_ bh b +- HsWord64Prim a b -> putByte bh 8 >> put_ bh a >> put_ bh b +- HsInteger a b c -> putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c +- HsRat a b c -> putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c +- HsFloatPrim a b -> putByte bh 11 >> put_ bh a >> put_ bh b +- HsDoublePrim a b -> putByte bh 12 >> put_ bh a >> put_ bh b +- XLit a -> putByte bh 13 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsChar <$> get bh <*> get bh +- 1 -> HsCharPrim <$> get bh <*> get bh +- 2 -> HsString <$> get bh <*> get bh +- 3 -> HsStringPrim <$> get bh <*> get bh +- 4 -> HsInt <$> get bh <*> get bh +- 5 -> HsIntPrim <$> get bh <*> get bh +- 6 -> HsWordPrim <$> get bh <*> get bh +- 7 -> HsInt64Prim <$> get bh <*> get bh +- 8 -> HsWord64Prim <$> get bh <*> get bh +- 9 -> HsInteger <$> get bh <*> get bh <*> get bh +- 10 -> HsRat <$> get bh <*> get bh <*> get bh +- 11 -> HsFloatPrim <$> get bh <*> get bh +- 12 -> HsDoublePrim <$> get bh <*> get bh +- 13 -> XLit <$> get bh +- _ -> getPanic "HsLit" +- +-instance Binary (HsOverLit GhcSe) where +- put_ bh lit = case lit of +- OverLit a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c +- XOverLit a -> putByte bh 1 >> put_ bh a +- +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> OverLit <$> get bh <*> get bh <*> get bh +- 1 -> XOverLit <$> get bh +- _ -> getPanic "HsOverLit" +- +-instance Binary Promoted where +- get bh = getByte bh >>= \tag -> case tag of +- 0 -> pure Promoted +- 1 -> pure NotPromoted +- _ -> getPanic "Promoted" +- +- put_ bh p = putByte bh $ case p of +- Promoted -> 0 +- NotPromoted -> 1 +- +-instance Binary RealSrcLoc where +- put_ bh l = do +- put_ bh (srcLocFile l) +- put_ bh (srcLocLine l) +- put_ bh (srcLocCol l) +- +- get bh = mkRealSrcLoc <$> get bh <*> get bh <*> get bh +- +-instance Binary RealSrcSpan where +- put_ bh s = put_ bh (realSrcSpanStart s) >> put_ bh (realSrcSpanEnd s) +- +- get bh = do +- loc1 <- get bh +- loc2 <- get bh +- return (mkRealSrcSpan loc1 loc2) +- +-instance Binary OverLitVal where +- put_ bh v +- = case v of +- HsIntegral a -> putByte bh 0 >> put_ bh a +- HsFractional a -> putByte bh 1 >> put_ bh a +- HsIsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> HsIntegral <$> get bh +- 1 -> HsFractional <$> get bh +- 2 -> HsIsString <$> get bh <*> get bh +- _ -> getPanic "OverLitVal" diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs -index 80dfa67ea3..dffae5af39 100644 +index a488da00a7..a7c467dce4 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs -@@ -23,7 +23,9 @@ import ConLike - import NameSet +@@ -23,15 +23,10 @@ import Data.Data hiding ( Fixity ) + import PlaceHolder import Name import RdrName -+import SeName +-import SeName import Var -+import IfaceType ( IfaceType ) - import Type ( Type ) +-import IfaceType ( IfaceType ) import Outputable import SrcLoc (Located) -@@ -60,14 +62,15 @@ data GhcPass (c :: Pass) + +-import Data.Kind +-import qualified Type +- + {- + Note [Trees that grow] + ~~~~~~~~~~~~~~~~~~~~~~ +@@ -73,22 +68,20 @@ data GhcPass (c :: Pass) deriving instance Eq (GhcPass c) deriving instance Typeable c => Data (GhcPass c) --data Pass = Parsed | Renamed | Typechecked -+data Pass = Parsed | Renamed | Typechecked | Serialisable +-data Pass = Parsed | Renamed | Typechecked | Serialisable ++data Pass = Parsed | Renamed | Typechecked deriving (Data) -- Type synonyms as a shorthand for tagging --type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param --type GhcRn = GhcPass 'Renamed -- Old 'Name' type param --type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, --type GhcTcId = GhcTc -- Old 'TcId' type param -+type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param -+type GhcRn = GhcPass 'Renamed -- Old 'Name' type param -+type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, -+type GhcSe = GhcPass 'Serialisable -- New pass, with serialisable AST representations -+type GhcTcId = GhcTc -- Old 'TcId' type param - - - -- | Types that are not defined until after type checking -@@ -75,19 +78,21 @@ type family PostTc x ty -- Note [Pass sensitive types] in PlaceHolder - type instance PostTc GhcPs ty = PlaceHolder - type instance PostTc GhcRn ty = PlaceHolder - type instance PostTc GhcTc ty = ty -+type instance PostTc GhcSe ty = PlaceHolder - - -- | Types that are not defined until after renaming - type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder - type instance PostRn GhcPs ty = PlaceHolder - type instance PostRn GhcRn ty = ty - type instance PostRn GhcTc ty = ty -+type instance PostRn GhcSe ty = PlaceHolder +-type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param +-type GhcRn = GhcPass 'Renamed -- Old 'Name' type param +-type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, +-type GhcSe = GhcPass 'Serialisable -- New pass, with serialisable AST representations +-type GhcTcId = GhcTc -- Old 'TcId' type param ++type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param ++type GhcRn = GhcPass 'Renamed -- Old 'Name' type param ++type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, ++type GhcTcId = GhcTc -- Old 'TcId' type param -- | Maps the "normal" id type for a given pass type family IdP p type instance IdP GhcPs = RdrName type instance IdP GhcRn = Name type instance IdP GhcTc = Id -- -+type instance IdP GhcSe = SeName - - -- We define a type family for each extension point. This is based on prepending - -- 'X' to the constructor name, for ease of reference. -@@ -169,6 +174,21 @@ type instance XHsRat GhcTc = () - type instance XHsFloatPrim GhcTc = () - type instance XHsDoublePrim GhcTc = () - -+-- Provide the specific extension types for the serialisation phase. -+type instance XHsChar GhcSe = SourceText -+type instance XHsCharPrim GhcSe = SourceText -+type instance XHsString GhcSe = SourceText -+type instance XHsStringPrim GhcSe = SourceText -+type instance XHsInt GhcSe = () -+type instance XHsIntPrim GhcSe = SourceText -+type instance XHsWordPrim GhcSe = SourceText -+type instance XHsInt64Prim GhcSe = SourceText -+type instance XHsWord64Prim GhcSe = SourceText -+type instance XHsInteger GhcSe = SourceText -+type instance XHsRat GhcSe = () -+type instance XHsFloatPrim GhcSe = () -+type instance XHsDoublePrim GhcSe = () -+ +-type instance IdP GhcSe = SeName + + type LIdP p = Located (IdP p) - -- --------------------------------------------------------------------- - -@@ -264,8 +284,11 @@ type DataId p = - ( Data p - , ForallX Data p - , Data (NameOrRdrName (IdP p)) -- -+ , Data (RdrOrSeName p) - , Data (IdP p) -+ , Data (LitType p) -+ , Data (IdSigId p) -+ , Data (DoName p) - , Data (PostRn p (IdP p)) - , Data (PostRn p (Located Name)) - , Data (PostRn p Bool) -@@ -288,4 +311,35 @@ type DataId p = - type OutputableBndrId id = +@@ -1112,34 +1105,4 @@ type OutputableBndrId id = ( OutputableBndr (NameOrRdrName (IdP id)) , OutputableBndr (IdP id) -+ , OutputableBndr (RdrOrSeName id) -+ , OutputableBndr (IdSigId id) -+ , VarType (IdSigId id) -+ -- , RdrOrSeName id ~ RdrName + , OutputableX id +- , OutputableBndr (RdrOrSeName id) +- , OutputableBndr (IdSigId id) +- , VarType (IdSigId id) ) -+ -+class VarType a where -+ getVarType :: a -> Maybe Type -+ -+instance VarType Var where -+ getVarType = Just . varType -+ -+instance VarType SeName where -+ getVarType _ = Nothing -+ -+type family IdSigId pass where -+ IdSigId GhcSe = SeName -+ IdSigId (GhcPass _) = Id -+ -+type family LitType x where -+ LitType (GhcPass 'Serialisable) = IfaceType -+ LitType a = Type -+ -+type family DoName pass where -+ DoName GhcSe = SeName -+ DoName (GhcPass _) = Name -+ -+type family RdrOrSeName pass -+type instance RdrOrSeName GhcSe = SeName -+type instance RdrOrSeName GhcRn = RdrName -+type instance RdrOrSeName GhcTc = RdrName -+type instance RdrOrSeName GhcPs = RdrName +- +-class VarType a where +- getVarType :: a -> Maybe Type.Type +- +-instance VarType Var where +- getVarType = Just . varType +- +-instance VarType SeName where +- getVarType _ = Nothing +- +-type family IdSigId pass where +- IdSigId GhcSe = SeName +- IdSigId (GhcPass _) = Id +- +-type family LitType x where +- LitType (GhcPass 'Serialisable) = IfaceType +- LitType a = Type.Type +- +-type family DoName pass where +- DoName GhcSe = SeName +- DoName (GhcPass _) = Name +- +-type family RdrOrSeName pass +-type instance RdrOrSeName GhcSe = SeName +-type instance RdrOrSeName GhcRn = RdrName +-type instance RdrOrSeName GhcTc = RdrName +-type instance RdrOrSeName GhcPs = RdrName diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs -index 2930b51ee2..fd14631718 100644 +index 9da47f62f1..39bd9b7e18 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs -@@ -11,6 +11,7 @@ HsImpExp: Abstract syntax: imports, exports, interfaces - {-# LANGUAGE StandaloneDeriving #-} +@@ -12,7 +12,6 @@ HsImpExp: Abstract syntax: imports, exports, interfaces + {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder -+{-# LANGUAGE TypeFamilies #-} +-{-# LANGUAGE TypeFamilies #-} module HsImpExp where diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs -index d46ef9b448..273f260c17 100644 +index 9546b0de30..d1411bd750 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs -@@ -14,7 +14,7 @@ +@@ -13,7 +13,7 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} -- -+{-# LANGUAGE DataKinds #-} +-{-# LANGUAGE DataKinds #-} ++ module HsLit where #include "HsVersions.h" -@@ -64,11 +64,11 @@ data HsLit x +@@ -63,11 +63,11 @@ data HsLit x -- ^ literal @Int64#@ | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer -- ^ literal @Word64#@ -- | HsInteger (XHsInteger x) {- SourceText -} Integer Type -+ | HsInteger (XHsInteger x) {- SourceText -} Integer (LitType x) +- | HsInteger (XHsInteger x) {- SourceText -} Integer (LitType x) ++ | HsInteger (XHsInteger x) {- SourceText -} Integer Type -- ^ Genuinely an integer; arises only -- from TRANSLATION (overloaded -- literals are done with HsOverLit) -- | HsRat (XHsRat x) FractionalLit Type -+ | HsRat (XHsRat x) FractionalLit (LitType x) +- | HsRat (XHsRat x) FractionalLit (LitType x) ++ | HsRat (XHsRat x) FractionalLit Type -- ^ Genuinely a rational; arises only from -- TRANSLATION (overloaded literals are -- done with HsOverLit) -@@ -124,7 +124,7 @@ overLitType = ol_type +@@ -128,7 +128,6 @@ data OverLitTc + type instance XOverLit GhcPs = NoExt + type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] + type instance XOverLit GhcTc = OverLitTc +-type instance XOverLit GhcSe = NoExt + + type instance XXOverLit (GhcPass _) = NoExt + +@@ -152,7 +151,7 @@ overLitType XOverLit{} = panic "overLitType" -- | Convert a literal from one index type to another, updating the annotations -- according to the relevant 'Convertable' instance --convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b -+convertLit :: (ConvertIdX a b, LitType a ~ LitType b) => HsLit a -> HsLit b +-convertLit :: (ConvertIdX a b, LitType a ~ LitType b) => HsLit a -> HsLit b ++convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b convertLit (HsChar a x) = (HsChar (convert a) x) convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x) convertLit (HsString a x) = (HsString (convert a) x) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs -index e25ff7bbcc..721888423d 100644 +index aa7e9989a2..6f65487411 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs -@@ -396,7 +396,8 @@ hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl +@@ -282,7 +282,6 @@ data ListPatTc + type instance XWildPat GhcPs = NoExt + type instance XWildPat GhcRn = NoExt + type instance XWildPat GhcTc = Type +-type instance XWildPat GhcSe = NoExt + + type instance XVarPat (GhcPass _) = NoExt + type instance XLazyPat (GhcPass _) = NoExt +@@ -296,22 +295,18 @@ type instance XBangPat (GhcPass _) = NoExt + type instance XListPat GhcPs = NoExt + type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) + type instance XListPat GhcTc = ListPatTc +-type instance XListPat GhcSe = NoExt + + type instance XTuplePat GhcPs = NoExt + type instance XTuplePat GhcRn = NoExt + type instance XTuplePat GhcTc = [Type] +-type instance XTuplePat GhcSe = NoExt + + type instance XSumPat GhcPs = NoExt + type instance XSumPat GhcRn = NoExt + type instance XSumPat GhcTc = [Type] +-type instance XSumPat GhcSe = NoExt + + type instance XViewPat GhcPs = NoExt + type instance XViewPat GhcRn = NoExt + type instance XViewPat GhcTc = Type +-type instance XViewPat GhcSe = NoExt + + type instance XSplicePat (GhcPass _) = NoExt + type instance XLitPat (GhcPass _) = NoExt +@@ -319,17 +314,14 @@ type instance XLitPat (GhcPass _) = NoExt + type instance XNPat GhcPs = NoExt + type instance XNPat GhcRn = NoExt + type instance XNPat GhcTc = Type +-type instance XNPat GhcSe = NoExt + + type instance XNPlusKPat GhcPs = NoExt + type instance XNPlusKPat GhcRn = NoExt + type instance XNPlusKPat GhcTc = Type +-type instance XNPlusKPat GhcSe = NoExt + + type instance XSigPat GhcPs = (LHsSigWcType GhcPs) + type instance XSigPat GhcRn = (LHsSigWcType GhcRn) + type instance XSigPat GhcTc = Type +-type instance XSigPat GhcSe = (LHsSigWcType GhcSe) + + type instance XCoPat (GhcPass _) = NoExt + type instance XXPat (GhcPass _) = NoExt +@@ -465,9 +457,7 @@ hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl hsRecFieldId :: HsRecField GhcTc arg -> Located Id hsRecFieldId = hsRecFieldSel --hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName -+hsRecUpdFieldRdr -+ :: RdrOrSeName p ~ RdrName => HsRecUpdField p -> Located RdrName +-hsRecUpdFieldRdr +- :: RdrOrSeName (GhcPass p) ~ RdrName +- => HsRecUpdField (GhcPass p) -> Located RdrName ++hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id -@@ -491,7 +492,7 @@ pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) - pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] +@@ -567,7 +557,7 @@ pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 + , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats) = ppr rpats --instance (Outputable arg) -+instance (Outputable arg, Outputable (RdrOrSeName p)) +-instance (Outputable arg, Outputable (RdrOrSeName p)) ++instance (Outputable arg) => Outputable (HsRecFields p arg) where ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) = braces (fsep (punctuate comma (map ppr flds))) diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot -index 8cb82ed22e..7cfb5ba6cd 100644 +index d56a992207..b7efb1c28c 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot -@@ -4,6 +4,7 @@ +@@ -4,7 +4,7 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} -+{-# LaNGUAGE TypeFamilies #-} -- needed to use OutputableBndrId +-{-# LANGUAGE TypeFamilies #-} -- needed to use OutputableBndrId ++{-# LANGUAGE TypeFamilies #-} module HsPat where import SrcLoc( Located ) -diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs -index 62bfa2e5c5..a5174cd3d5 100644 ---- a/compiler/hsSyn/HsSyn.hs -+++ b/compiler/hsSyn/HsSyn.hs -@@ -15,6 +15,7 @@ therefore, is almost nothing but re-exporting. - {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder - {-# LANGUAGE ConstraintKinds #-} -+{-# LANGUAGE TypeFamilies #-} - - module HsSyn ( - module HsBinds, diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs -index af30d227d3..77e70d79b9 100644 +index 2366df1d28..3512bf7a7c 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs -@@ -10,6 +10,7 @@ HsTypes: Abstract syntax: user-defined types +@@ -9,7 +9,6 @@ HsTypes: Abstract syntax: user-defined types + {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} - {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} -+{-# LANGUAGE TypeFamilies #-} +-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder -@@ -39,7 +40,7 @@ module HsTypes ( +@@ -39,7 +38,7 @@ module HsTypes ( HsConDetails(..), -- FieldOcc(..), LFieldOcc, mkFieldOcc, -+ FieldOcc(..), LFieldOcc, mkFieldOcc, fieldOccRdrName, +- FieldOcc(..), LFieldOcc, mkFieldOcc, fieldOccRdrName, ++ FieldOcc(..), LFieldOcc, mkFieldOcc, AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, -@@ -86,6 +87,7 @@ import TysPrim( funTyConName ) +@@ -86,7 +85,6 @@ import TysPrim( funTyConName ) import Type import HsDoc import BasicTypes -+import Binary +-import Binary import SrcLoc import Outputable import FastString -@@ -392,6 +394,10 @@ newtype HsIPName = HsIPName FastString +@@ -279,7 +277,6 @@ data HsQTvsRn + type instance XHsQTvs GhcPs = NoExt + type instance XHsQTvs GhcRn = HsQTvsRn + type instance XHsQTvs GhcTc = HsQTvsRn +-type instance XHsQTvs GhcSe = NoExt + + type instance XXLHsQTyVars (GhcPass _) = NoExt + +@@ -319,7 +316,6 @@ data HsIBRn + type instance XHsIB GhcPs _ = NoExt + type instance XHsIB GhcRn _ = HsIBRn + type instance XHsIB GhcTc _ = HsIBRn +-type instance XHsIB GhcSe _ = NoExt + + type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt + +@@ -341,7 +337,6 @@ data HsWildCardBndrs pass thing + type instance XHsWC GhcPs b = NoExt + type instance XHsWC GhcRn b = [Name] + type instance XHsWC GhcTc b = [Name] +-type instance XHsWC GhcSe b = NoExt + + type instance XXHsWildCardBndrs (GhcPass _) b = NoExt + +@@ -420,10 +415,6 @@ newtype HsIPName = HsIPName FastString hsIPNameFS :: HsIPName -> FastString hsIPNameFS (HsIPName n) = n -+instance Binary HsIPName where -+ put_ bh (HsIPName s) = put_ bh s -+ get bh = HsIPName <$> get bh -+ +-instance Binary HsIPName where +- put_ bh (HsIPName s) = put_ bh s +- get bh = HsIPName <$> get bh +- instance Outputable HsIPName where ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters -@@ -1100,20 +1106,24 @@ type LFieldOcc pass = Located (FieldOcc pass) - -- Represents an *occurrence* of an unambiguous field. We store +@@ -668,7 +659,6 @@ type instance XKindSig (GhcPass _) = NoExt + type instance XSpliceTy GhcPs = NoExt + type instance XSpliceTy GhcRn = NoExt + type instance XSpliceTy GhcTc = Kind +-type instance XSpliceTy GhcSe = NoExt + + type instance XDocTy (GhcPass _) = NoExt + type instance XBangTy (GhcPass _) = NoExt +@@ -677,19 +667,16 @@ type instance XRecTy (GhcPass _) = NoExt + type instance XExplicitListTy GhcPs = NoExt + type instance XExplicitListTy GhcRn = NoExt + type instance XExplicitListTy GhcTc = Kind +-type instance XExplicitListTy GhcSe = NoExt + + type instance XExplicitTupleTy GhcPs = NoExt + type instance XExplicitTupleTy GhcRn = NoExt + type instance XExplicitTupleTy GhcTc = [Kind] +-type instance XExplicitTupleTy GhcSe = NoExt + + type instance XTyLit (GhcPass _) = NoExt + + type instance XWildCardTy GhcPs = NoExt + type instance XWildCardTy GhcRn = HsWildCardInfo + type instance XWildCardTy GhcTc = HsWildCardInfo +-type instance XWildCardTy GhcSe = NoExt + + type instance XXType (GhcPass _) = NewHsTypeX + +@@ -1150,32 +1137,27 @@ type LFieldOcc pass = Located (FieldOcc pass) -- both the 'RdrName' the user originally wrote, and after the -- renamer, the selector function. --data FieldOcc pass = FieldOcc { rdrNameFieldOcc :: Located RdrName -+data FieldOcc pass = FieldOcc { rdrNameFieldOcc :: Located (RdrOrSeName pass) + data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass +- , rdrNameFieldOcc :: Located (RdrOrSeName pass) ++ , rdrNameFieldOcc :: Located RdrName -- ^ See Note [Located RdrNames] in HsExpr - , selectorFieldOcc :: PostRn pass (IdP pass) } --deriving instance Eq (PostRn pass (IdP pass)) => Eq (FieldOcc pass) --deriving instance Ord (PostRn pass (IdP pass)) => Ord (FieldOcc pass) -+deriving instance (Eq (PostRn pass (IdP pass)), Eq (RdrOrSeName pass)) -+ => Eq (FieldOcc pass) -+deriving instance (Ord (PostRn pass (IdP pass)), Ord (RdrOrSeName pass)) -+ => Ord (FieldOcc pass) - deriving instance (DataId pass) => Data (FieldOcc pass) - --instance Outputable (FieldOcc pass) where -+instance Outputable (RdrOrSeName pass) => Outputable (FieldOcc pass) where + + | XFieldOcc + (XXFieldOcc pass) +-deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p), Eq (RdrOrSeName p)) +- => Eq (FieldOcc p) +-deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p), Ord (RdrOrSeName p)) +- => Ord (FieldOcc p) ++deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p) ++deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p) + + type instance XCFieldOcc GhcPs = NoExt + type instance XCFieldOcc GhcRn = Name + type instance XCFieldOcc GhcTc = Id +-type instance XCFieldOcc GhcSe = NoExt + + type instance XXFieldOcc (GhcPass _) = NoExt + +-instance Outputable (RdrOrSeName pass) => Outputable (FieldOcc pass) where ++instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc mkFieldOcc :: Located RdrName -> FieldOcc GhcPs - mkFieldOcc rdr = FieldOcc rdr PlaceHolder + mkFieldOcc rdr = FieldOcc noExt rdr -+fieldOccRdrName :: RdrOrSeName pass ~ RdrName => FieldOcc pass -> Located RdrName -+fieldOccRdrName = rdrNameFieldOcc +-fieldOccRdrName :: RdrOrSeName pass ~ RdrName => FieldOcc pass -> Located RdrName +-fieldOccRdrName = rdrNameFieldOcc -- | Ambiguous Field Occurrence -- -@@ -1128,21 +1138,24 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder +@@ -1190,36 +1172,31 @@ fieldOccRdrName = rdrNameFieldOcc -- Note [Disambiguating record fields] in TcExpr. -- See Note [Located RdrNames] in HsExpr data AmbiguousFieldOcc pass -- = Unambiguous (Located RdrName) (PostRn pass (IdP pass)) -- | Ambiguous (Located RdrName) (PostTc pass (IdP pass)) -+ = Unambiguous (Located (RdrOrSeName pass)) (PostRn pass (IdP pass)) -+ | Ambiguous (Located (RdrOrSeName pass)) (PostTc pass (IdP pass)) - deriving instance DataId pass => Data (AmbiguousFieldOcc pass) - --instance Outputable (AmbiguousFieldOcc pass) where -+instance Outputable (RdrOrSeName pass) -+ => Outputable (AmbiguousFieldOcc pass) where +- = Unambiguous (XUnambiguous pass) (Located (RdrOrSeName pass)) +- | Ambiguous (XAmbiguous pass) (Located (RdrOrSeName pass)) ++ = Unambiguous (XUnambiguous pass) (Located RdrName) ++ | Ambiguous (XAmbiguous pass) (Located RdrName) + | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) + + type instance XUnambiguous GhcPs = NoExt + type instance XUnambiguous GhcRn = Name + type instance XUnambiguous GhcTc = Id +-type instance XUnambiguous GhcSe = NoExt + + type instance XAmbiguous GhcPs = NoExt + type instance XAmbiguous GhcRn = NoExt + type instance XAmbiguous GhcTc = Id +-type instance XAmbiguous GhcSe = NoExt + + type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt + +-instance (p ~ GhcPass pass, Outputable (RdrOrSeName p)) +- => Outputable (AmbiguousFieldOcc p) where ++instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where ppr = ppr . rdrNameAmbiguousFieldOcc --instance OutputableBndr (AmbiguousFieldOcc pass) where -+instance OutputableBndr (RdrOrSeName pass) -+ => OutputableBndr (AmbiguousFieldOcc pass) where +-instance (p ~ GhcPass pass, OutputableBndr (RdrOrSeName p)) +- => OutputableBndr (AmbiguousFieldOcc p) where ++instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs - mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder - --rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc pass -> RdrName -+rdrNameAmbiguousFieldOcc -+ :: AmbiguousFieldOcc pass -> RdrOrSeName pass - rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr - rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr - + mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr + +-rdrNameAmbiguousFieldOcc +- :: AmbiguousFieldOcc (GhcPass p) -> RdrOrSeName (GhcPass p) ++rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName + rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr + rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr + rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs -index 5cc70c4a06..65a7e10980 100644 +index be0a5281ab..eba21cf1e2 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs -@@ -1089,8 +1089,9 @@ hsTyClForeignBinders tycl_decls foreign_decls - getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs +@@ -1133,9 +1133,8 @@ hsTyClForeignBinders tycl_decls foreign_decls + getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs ------------------- --hsLTyClDeclBinders :: Located (TyClDecl pass) -- -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsLTyClDeclBinders -+ :: RdrOrSeName pass ~ RdrName -+ => Located (TyClDecl pass) -> ([Located (IdP pass)], [LFieldOcc pass]) +-hsLTyClDeclBinders +- :: RdrOrSeName pass ~ RdrName +- => Located (TyClDecl pass) -> ([Located (IdP pass)], [LFieldOcc pass]) ++hsLTyClDeclBinders :: Located (TyClDecl pass) ++ -> ([Located (IdP pass)], [LFieldOcc pass]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second -@@ -1140,8 +1141,9 @@ getPatSynBinds binds - , L _ (PatSynBind psb) <- bagToList lbinds ] +@@ -1189,8 +1188,7 @@ getPatSynBinds binds + , L _ (PatSynBind _ psb) <- bagToList lbinds ] ------------------- --hsLInstDeclBinders :: LInstDecl pass -- -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsLInstDeclBinders -+ :: RdrOrSeName pass ~ RdrName -+ => LInstDecl pass -> ([Located (IdP pass)], [LFieldOcc pass]) +-hsLInstDeclBinders :: RdrOrSeName (GhcPass p) ~ RdrName +- => LInstDecl (GhcPass p) ++hsLInstDeclBinders :: LInstDecl (GhcPass p) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) = foldMap (hsDataFamInstBinders . unLoc) dfis - hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) -@@ -1150,8 +1152,9 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty +@@ -1204,9 +1202,8 @@ hsLInstDeclBinders (L _ (XInstDecl _)) ------------------- -- the SrcLoc returned are for the whole declarations, not just the names --hsDataFamInstBinders :: DataFamInstDecl pass -- -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsDataFamInstBinders -+ :: RdrOrSeName pass ~ RdrName -+ => DataFamInstDecl pass -> ([Located (IdP pass)], [LFieldOcc pass]) +-hsDataFamInstBinders +- :: RdrOrSeName pass ~ RdrName +- => DataFamInstDecl pass -> ([Located (IdP pass)], [LFieldOcc pass]) ++hsDataFamInstBinders :: DataFamInstDecl pass ++ -> ([Located (IdP pass)], [LFieldOcc pass]) hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = defn }}}) = hsDataDefnBinders defn -@@ -1159,13 +1162,17 @@ hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = +@@ -1219,9 +1216,7 @@ hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _)) ------------------- -- the SrcLoc returned are for the whole declarations, not just the names --hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsDataDefnBinders -+ :: RdrOrSeName pass ~ RdrName -+ => HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) +-hsDataDefnBinders +- :: RdrOrSeName pass ~ RdrName +- => HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) ++hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] - - ------------------- --hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsConDeclsBinders -+ :: forall pass. RdrOrSeName pass ~ RdrName -+ => [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) - -- See hsLTyClDeclBinders for what this does - -- The function is boringly complicated because of the records - -- And since we only have equality, we have to be a little careful -@@ -1195,9 +1202,10 @@ hsConDeclsBinders cons = go id cons - (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty - record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs) - where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) -+ remSeen' :: [LFieldOcc pass] -> [LFieldOcc pass] - remSeen' = foldr (.) remSeen - [deleteBy ((==) `on` -- unLoc . rdrNameFieldOcc . unLoc) v -+ unLoc . fieldOccRdrName . unLoc) v - | v <- r'] - (ns, fs) = go remSeen' rs - -@@ -1206,10 +1214,11 @@ hsConDeclsBinders cons = go id cons - ([L loc (unLoc name)] ++ ns, r' ++ fs) - where r' = remSeen (concatMap (cd_fld_names . unLoc) - (unLoc flds)) -+ remSeen' :: [LFieldOcc pass] -> [LFieldOcc pass] - remSeen' - = foldr (.) remSeen - [deleteBy ((==) `on` -- unLoc . rdrNameFieldOcc . unLoc) v | v <- r'] -+ unLoc . fieldOccRdrName . unLoc) v | v <- r'] - (ns, fs) = go remSeen' rs - L loc (ConDeclH98 { con_name = name }) -> - ([L loc (unLoc name)] ++ ns, fs) +@@ -1231,9 +1226,7 @@ hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders" + type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass] + -- Filters out ones that have already been seen + +-hsConDeclsBinders +- :: forall pass. RdrOrSeName pass ~ RdrName +- => [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) ++hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) + -- See hsLTyClDeclBinders for what this does + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs -index 0b4711a364..e7a742ba99 100644 +index e05dfc3a33..244243a82f 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs -@@ -13,6 +13,7 @@ import Outputable +@@ -9,7 +9,6 @@ module PlaceHolder where import Name import NameSet import RdrName -+import SeName +-import SeName import Var - import Data.Data hiding ( Fixity ) -@@ -94,3 +95,4 @@ type family NameOrRdrName id where + +@@ -69,4 +68,3 @@ type family NameOrRdrName id where NameOrRdrName Id = Name NameOrRdrName Name = Name NameOrRdrName RdrName = RdrName -+ NameOrRdrName SeName = SeName +- NameOrRdrName SeName = SeName diff --git a/compiler/hsSyn/SeName.hs b/compiler/hsSyn/SeName.hs -new file mode 100644 -index 0000000000..f8bca59243 ---- /dev/null -+++ b/compiler/hsSyn/SeName.hs -@@ -0,0 +1,13 @@ -+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -+module SeName (SeName(..), mkSeName) where -+ -+import Outputable -+import RdrName -+ -+-- TODO: make this smarter, so as to check whether -+-- the name is local or not. -+newtype SeName = SeName RdrName -+ deriving (Outputable, OutputableBndr) -+ -+mkSeName :: RdrName -> SeName -+mkSeName = SeName -diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs -index 31b5af0e86..1843bee3f5 100644 ---- a/compiler/iface/BinIface.hs -+++ b/compiler/iface/BinIface.hs -@@ -15,7 +15,10 @@ module BinIface ( - getSymtabName, - getDictFastString, - CheckHiWay(..), -- TraceBinIFaceReading(..) -+ TraceBinIFaceReading(..), -+ getWithUserData, -+ putWithUserData -+ - ) where - - #include "HsVersions.h" -@@ -134,7 +137,14 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do - wantedGot "Way" way_descr check_way - when (checkHiWay == CheckHiWay) $ - errorOnMismatch "mismatched interface file ways" way_descr check_way -+ getWithUserData ncu bh -+ - -+-- | This performs a get action after reading the dictionary and symbol -+-- table. It is necessary to run this before trying to deserialise any -+-- Names or FastStrings. -+getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a -+getWithUserData ncu bh = do - -- Read the dictionary - -- The next word in the file is a pointer to where the dictionary is - -- (probably at the end of the file) -@@ -179,6 +189,17 @@ writeBinIface dflags hi_path mod_iface = do - let way_descr = getWayDescr dflags - put_ bh way_descr - -+ -+ putWithUserData (debugTraceMsg dflags 3) bh mod_iface -+ -- And send the result to the file -+ writeBinMem bh hi_path -+ -+-- | Put a piece of data with an initialised `UserData` field. This -+-- is necessary if you want to serialise Names or FastStrings. -+-- It also writes a symbol table and the dictionary. -+-- This segment should be read using `getWithUserData`. -+putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO () -+putWithUserData log_action bh payload = do - -- Remember where the dictionary pointer will go - dict_p_p <- tellBin bh - -- Placeholder for ptr to dictionary -@@ -187,7 +208,6 @@ writeBinIface dflags hi_path mod_iface = do - -- Remember where the symbol table pointer will go - symtab_p_p <- tellBin bh - put_ bh symtab_p_p -- - -- Make some intial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 -@@ -206,7 +226,7 @@ writeBinIface dflags hi_path mod_iface = do - bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) - (putName bin_dict bin_symtab) - (putFastString bin_dict) -- put_ bh mod_iface -+ put_ bh payload - - -- Write the symtab pointer at the front of the file - symtab_p <- tellBin bh -- This is where the symtab will start -@@ -217,7 +237,7 @@ writeBinIface dflags hi_path mod_iface = do - symtab_next <- readFastMutInt symtab_next - symtab_map <- readIORef symtab_map - putSymbolTable bh symtab_next symtab_map -- debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next -+ log_action (text "writeBinIface:" <+> int symtab_next - <+> text "Names") - - -- NB. write the dictionary after the symbol table, because -@@ -232,11 +252,10 @@ writeBinIface dflags hi_path mod_iface = do - dict_next <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map -- debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next -+ log_action (text "writeBinIface:" <+> int dict_next - <+> text "dict entries") - -- -- And send the result to the file -- writeBinMem bh hi_path -+ +deleted file mode 100644 +index f8bca59243..0000000000 +--- a/compiler/hsSyn/SeName.hs ++++ /dev/null +@@ -1,13 +0,0 @@ +-{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-module SeName (SeName(..), mkSeName) where +- +-import Outputable +-import RdrName +- +--- TODO: make this smarter, so as to check whether +--- the name is local or not. +-newtype SeName = SeName RdrName +- deriving (Outputable, OutputableBndr) +- +-mkSeName :: RdrName -> SeName +-mkSeName = SeName +diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs +index 2d6047d7cc..00bcaa77f1 100644 +--- a/compiler/iface/IfaceEnv.hs ++++ b/compiler/iface/IfaceEnv.hs +@@ -16,7 +16,7 @@ module IfaceEnv ( + ifaceExportNames, + + -- Name-cache stuff +- allocateGlobalBinder, updNameCacheTc, updNameCacheIO, ++ allocateGlobalBinder, updNameCacheTc, + mkNameCacheUpdater, NameCacheUpdater(..), + ) where - -- | Initial ram buffer to allocate for writing interface files - initBinMemSize :: Int diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs -index c5a4a3d6db..461282e56c 100644 +index 15a19b117f..5a7f761d32 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs -@@ -7,7 +7,7 @@ This module defines interface types and binders - -} - - {-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} --{-# LANGUAGE MultiWayIf #-} -+{-# LANGUAGE DeriveDataTypeable, MultiWayIf #-} - -- FlexibleInstances for Binary (DefMethSpec IfaceType) - - module IfaceType ( -@@ -67,6 +67,7 @@ import FastString - import FastStringEnv - import Util - -+import Data.Data (Data) - import Data.Maybe( isJust ) - import Data.List (foldl') - import qualified Data.Semigroup as Semi -@@ -130,6 +131,7 @@ data IfaceType -- A kind of universal type, used for types and kinds - IsPromoted -- A bit like IfaceTyCon - IfaceTcArgs -- arity = length args - -- For promoted data cons, the kind args are omitted -+ deriving Data - - type IfacePredType = IfaceType - type IfaceContext = [IfacePredType] -@@ -137,7 +139,7 @@ type IfaceContext = [IfacePredType] +@@ -139,7 +139,7 @@ type IfaceContext = [IfacePredType] data IfaceTyLit = IfaceNumTyLit Integer | IfaceStrTyLit FastString -- deriving (Eq) -+ deriving (Data, Eq) +- deriving Eq ++ deriving (Eq) type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag -@@ -152,6 +154,7 @@ data IfaceTcArgs - | ITC_Vis IfaceType IfaceTcArgs -- "Vis" means show when pretty-printing - | ITC_Invis IfaceKind IfaceTcArgs -- "Invis" means don't show when pretty-printing - -- except with -fprint-explicit-kinds -+ deriving Data - - instance Semi.Semigroup IfaceTcArgs where - ITC_Nil <> xs = xs -@@ -168,11 +171,11 @@ instance Monoid IfaceTcArgs where +@@ -170,7 +170,7 @@ instance Monoid IfaceTcArgs where -- properly. data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName , ifaceTyConInfo :: IfaceTyConInfo } -- deriving (Eq) -+ deriving (Data, Eq) +- deriving Eq ++ deriving (Eq) -- | Is a TyCon a promoted data constructor or just a normal type constructor? data IsPromoted = IsNotPromoted | IsPromoted -- deriving (Eq) -+ deriving (Data, Eq) - - -- | The various types of TyCons which have special, built-in syntax. - data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon -@@ -192,7 +195,7 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon +@@ -194,7 +194,7 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon -- that is actually being applied to two types -- of the same kind. This affects pretty-printing -- only: see Note [Equality predicates in IfaceType] -- deriving (Eq) -+ deriving (Data, Eq) +- deriving Eq ++ deriving (Eq) {- Note [Free tyvars in IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -@@ -247,7 +250,7 @@ data IfaceTyConInfo -- Used to guide pretty-printing +@@ -278,7 +278,7 @@ data IfaceTyConInfo -- Used to guide pretty-printing -- and to disambiguate D from 'D (they share a name) = IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted , ifaceTyConSort :: IfaceTyConSort } -- deriving (Eq) -+ deriving (Data, Eq) +- deriving Eq ++ deriving (Eq) data IfaceCoercion = IfaceReflCo Role IfaceType -@@ -269,12 +272,14 @@ data IfaceCoercion - | IfaceAxiomRuleCo IfLclName [IfaceCoercion] - | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] - | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] -+ deriving Data - - data IfaceUnivCoProv - = IfaceUnsafeCoerceProv - | IfacePhantomProv IfaceCoercion - | IfaceProofIrrelProv IfaceCoercion - | IfacePluginProv String -+ deriving Data - - {- Note [Holes in IfaceCoercion] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -@@ -1488,6 +1493,7 @@ instance Binary IfaceUnivCoProv where +@@ -1650,7 +1650,6 @@ instance Binary IfaceUnivCoProv where _ -> panic ("get IfaceUnivCoProv " ++ show tag) -+{- +-{- instance Binary (DefMethSpec IfaceType) where put_ bh VanillaDM = putByte bh 0 put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t -@@ -1496,3 +1502,4 @@ instance Binary (DefMethSpec IfaceType) where +@@ -1659,4 +1658,3 @@ instance Binary (DefMethSpec IfaceType) where case h of 0 -> return VanillaDM _ -> do { t <- get bh; return (GenericDM t) } -+-} +--} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs -index 5b512a1b71..0cb3f81a17 100644 +index 9d305efd09..95a7122a57 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs -@@ -838,6 +838,8 @@ data DynFlags = DynFlags { +@@ -916,8 +916,6 @@ data DynFlags = DynFlags { hiDir :: Maybe String, stubDir :: Maybe String, dumpDir :: Maybe String, -+ saveSplicesDir :: Maybe String, -+ loadSplicesDir :: Maybe String, +- saveSplicesDir :: Maybe String, +- loadSplicesDir :: Maybe String, objectSuf :: String, hcSuf :: String, -@@ -1692,6 +1694,8 @@ defaultDynFlags mySettings myLlvmTargets = +@@ -1799,8 +1797,6 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) = hiDir = Nothing, stubDir = Nothing, dumpDir = Nothing, -+ saveSplicesDir = Nothing, -+ loadSplicesDir = Nothing, +- saveSplicesDir = Nothing, +- loadSplicesDir = Nothing, objectSuf = phaseInputExt StopLn, hcSuf = phaseInputExt HCc, -@@ -2282,6 +2286,7 @@ getVerbFlags dflags +@@ -2375,7 +2371,6 @@ getVerbFlags dflags | otherwise = [] setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, -+ setSaveSplicesDir, setLoadSplicesDir, +- setSaveSplicesDir, setLoadSplicesDir, setDynObjectSuf, setDynHiSuf, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, -@@ -2299,6 +2304,8 @@ setStubDir f d = d { stubDir = Just f, includePaths = f : includePaths d } - -- \#included from the .hc file when compiling via C (i.e. unregisterised +@@ -2395,8 +2390,6 @@ setStubDir f d = d { stubDir = Just f -- builds). setDumpDir f d = d { dumpDir = Just f} -+setSaveSplicesDir f d = d { saveSplicesDir = Just f} -+setLoadSplicesDir f d = d { loadSplicesDir = Just f} setOutputDir f = setObjectDir f . setHiDir f . setStubDir f . setDumpDir f +-setSaveSplicesDir f d = d { saveSplicesDir = Just f} +-setLoadSplicesDir f d = d { loadSplicesDir = Just f} setDylibInstallName f d = d { dylibInstallName = Just f} -@@ -2867,6 +2874,8 @@ dynamic_flags_deps = [ + setObjectSuf f d = d { objectSuf = f} +@@ -2955,8 +2948,6 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) -+ , make_ord_flag defGhcFlag "save-splices" (hasArg setSaveSplicesDir) -+ , make_ord_flag defGhcFlag "load-splices" (hasArg setLoadSplicesDir) +- , make_ord_flag defGhcFlag "save-splices" (hasArg setSaveSplicesDir) +- , make_ord_flag defGhcFlag "load-splices" (hasArg setLoadSplicesDir) , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) , make_ord_flag defGhcFlag "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) -diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs -index 48b8eccaca..20bdbf448d 100644 ---- a/compiler/main/HscStats.hs -+++ b/compiler/main/HscStats.hs -@@ -4,8 +4,7 @@ - -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -- - --{-# LANGUAGE FlexibleContexts #-} -- -+{-# LANGUAGE FlexibleContexts, GADTs #-} - module HscStats ( ppSourceStats ) where - - import GhcPrelude diff --git a/compiler/prelude/PrimOp.hs-boot b/compiler/prelude/PrimOp.hs-boot -index f10ef44972..6d759bb961 100644 +index 6d759bb961..f10ef44972 100644 --- a/compiler/prelude/PrimOp.hs-boot +++ b/compiler/prelude/PrimOp.hs-boot -@@ -1,5 +1,7 @@ +@@ -1,7 +1,5 @@ module PrimOp where --import GhcPrelude () -+import GhcPrelude (Int) +-import GhcPrelude (Int) ++import GhcPrelude () data PrimOp -+primOpTag :: PrimOp -> Int -+allThePrimOps :: [PrimOp] +-primOpTag :: PrimOp -> Int +-allThePrimOps :: [PrimOp] diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs -index 2846754f11..fdeb5fe4a2 100644 +index 63c471d3ef..6195309cab 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs -@@ -10,7 +10,7 @@ general, all of these functions return a renamed thing, and a set of - free variables. - -} - --{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} -+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables, GADTs #-} - - module RnPat (-- main entry points - rnPat, rnPats, rnBindPat, rnPatAndThen, -@@ -794,11 +794,11 @@ rnHsRecUpdFields flds +@@ -743,7 +743,7 @@ rnHsRecUpdFields flds getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds --getFieldLbls :: [LHsRecField id arg] -> [RdrName] -+getFieldLbls :: RdrOrSeName id ~ RdrName => [LHsRecField id arg] -> [RdrName] +-getFieldLbls :: RdrOrSeName id ~ RdrName => [LHsRecField id arg] -> [RdrName] ++getFieldLbls :: [LHsRecField id arg] -> [RdrName] getFieldLbls flds = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds --getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName] -+getFieldUpdLbls :: RdrOrSeName id ~ RdrName => [LHsRecUpdField id] -> [RdrName] - getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds - - needFlagDotDot :: HsRecFieldContext -> SDoc diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs -index 9da96c4cc0..2a935b0a76 100644 +index 91d88087f8..f8f3bbe191 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -7,7 +7,7 @@ The @Inst@ type: dictionaries or method instances -} {-# LANGUAGE CPP, MultiWayIf, TupleSections #-} --{-# LANGUAGE FlexibleContexts #-} -+{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +-{-# LANGUAGE FlexibleContexts, TypeFamilies #-} ++{-# LANGUAGE FlexibleContexts #-} module Inst ( deeplySkolemise, -@@ -575,7 +575,9 @@ newNonTrivialOverloadedLit _ lit _ - = pprPanic "newNonTrivialOverloadedLit" (ppr lit) - - ------------ --mkOverLit ::(HasDefaultX p, SourceTextX p) => OverLitVal -> TcM (HsLit p) -+mkOverLit -+ :: (HasDefaultX p, SourceTextX p, LitType p ~ Type) -+ => OverLitVal -> TcM (HsLit p) - mkOverLit (HsIntegral i) - = do { integer_ty <- tcMetaTy integerTyConName - ; return (HsInteger (setSourceText $ il_text i) -diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs -index edf696e3c9..a97819ef9c 100644 ---- a/compiler/typecheck/TcAnnotations.hs -+++ b/compiler/typecheck/TcAnnotations.hs -@@ -7,6 +7,7 @@ - - {-# LANGUAGE CPP #-} - {-# LANGUAGE FlexibleContexts #-} -+{-# LANGUAGE GADTs #-} - - module TcAnnotations ( tcAnnotations, annCtxt ) where - diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs -index ef3131b922..c0d60b7a6d 100644 +index 00dcf26f09..b42557259e 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE CPP, FlexibleInstances #-} --{-# LANGUAGE FlexibleContexts #-} -+{-# LANGUAGE FlexibleContexts, GADTs #-} +-{-# LANGUAGE FlexibleContexts, GADTs #-} ++{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an -- orphan {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs -index 8d097f52fb..65d725eeca 100644 +index 1cca6f5589..986047bded 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs -@@ -110,7 +110,7 @@ hsPatType (NPlusKPat _ _ _ _ _ ty) = ty - hsPatType (CoPat _ _ ty) = ty - hsPatType p = pprPanic "hsPatType" (ppr p) +@@ -114,7 +114,7 @@ hsPatType (NPlusKPat ty _ _ _ _ _) = ty + hsPatType (CoPat _ _ _ ty) = ty + hsPatType p = pprPanic "hsPatType" (ppr p) --hsLitType :: HsLit p -> TcType -+hsLitType :: LitType p ~ TcType => HsLit p -> TcType +-hsLitType :: LitType (GhcPass p) ~ TcType => HsLit (GhcPass p) -> TcType ++hsLitType :: HsLit (GhcPass p) -> TcType hsLitType (HsChar _ _) = charTy hsLitType (HsCharPrim _ _) = charPrimTy hsLitType (HsString _ _) = stringTy diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs -index 40b5efec84..42745dd2c8 100644 +index 5a048d0c4b..2f81e07990 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs -@@ -44,7 +44,7 @@ module TcRnDriver ( +@@ -47,7 +47,7 @@ module TcRnDriver ( import GhcPrelude --import {-# SOURCE #-} TcSplice ( finishTH ) -+import {-# SOURCE #-} TcSplice ( finishTH, writeHsSpliceData ) +-import {-# SOURCE #-} TcSplice( finishTH, writeHsSpliceData ) ++import {-# SOURCE #-} TcSplice ( finishTH ) import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import IfaceEnv( externaliseName ) import TcHsType -@@ -114,6 +114,7 @@ import Avail +@@ -114,7 +114,6 @@ import Avail import TyCon import SrcLoc import HscTypes -+import HsExprBin +-import HsExprBin import ListSetOps import Outputable import ConLike -@@ -136,6 +137,8 @@ import HsDumpAst - import qualified Data.Set as S +@@ -138,8 +137,6 @@ import qualified Data.Set as S + import Control.DeepSeq import Control.Monad -+import System.Directory -+import System.FilePath (takeDirectory) +-import System.Directory +-import System.FilePath (takeDirectory) #include "HsVersions.h" -@@ -417,6 +420,17 @@ tcRnSrcDecls explicit_mod_hdr decls +@@ -424,17 +421,6 @@ tcRnSrcDecls explicit_mod_hdr decls -- Finalizers must run after constraints are simplified, or some types -- might not be complete when using reify (see #12777). ; (tcg_env, tcl_env) <- setGblEnv tcg_env run_th_modfinalizers -+ -+ ; dynflags <- getDynFlags -+ ; whenSet (saveSplicesDir dynflags) -+ (\splicesDir -> do -+ moduleSplicesPath <- getModuleSplicesPath splicesDir <$> getModule -+ hs_splice_data <- readTcRef (tcg_hs_splice_data tcg_env) -+ liftIO $ createDirectoryIfMissing True (takeDirectory moduleSplicesPath) -+ writeHsSpliceData moduleSplicesPath hs_splice_data -+ ) -+ (pure ()) -+ +- +- ; dynflags <- getDynFlags +- ; whenSet (saveSplicesDir dynflags) +- (\splicesDir -> do +- moduleSplicesPath <- getModuleSplicesPath splicesDir <$> getModule +- hs_splice_data <- readTcRef (tcg_hs_splice_data tcg_env) +- liftIO $ createDirectoryIfMissing True (takeDirectory moduleSplicesPath) +- writeHsSpliceData moduleSplicesPath hs_splice_data +- ) +- (pure ()) +- ; setEnvs (tcg_env, tcl_env) $ do { ; finishTH diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs -index 184093f066..4a03512d61 100644 +index 83449f1631..e0989ae331 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs -@@ -142,6 +142,7 @@ import IOEnv -- Re-export all +@@ -145,7 +145,6 @@ import IOEnv -- Re-export all import TcEvidence import HsSyn hiding (LIE) -+import HsExprBin +-import HsExprBin import HscTypes import Module import RdrName -@@ -179,7 +180,7 @@ import Control.Monad +@@ -183,7 +182,7 @@ import Control.Monad import Data.Set ( Set ) import qualified Data.Set as Set --import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers ) -+import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers, readHsSpliceData ) +-import {-# SOURCE #-} TcSplice ( readHsSpliceData, runRemoteModFinalizers ) ++import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers ) import {-# SOURCE #-} TcEnv ( tcInitTidyEnv ) import qualified Data.Map as Map -@@ -224,9 +225,16 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this +@@ -229,16 +228,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this th_coreplugins_var <- newIORef [] ; th_state_var <- newIORef Map.empty ; th_remote_state_var <- newIORef Nothing ; -+ dflags <- pure (hsc_dflags hsc_env) ; -+ hs_splice_data <- newIORef =<< whenSet (loadSplicesDir dflags) -+ (\splicesDir -> do -+ if moduleUnitId mod == interactiveUnitId -+ then return emptyHsSpliceData -+ else do let moduleSplicesPath = getModuleSplicesPath splicesDir mod -+ readHsSpliceData hsc_env moduleSplicesPath -+ ) -+ (pure emptyHsSpliceData) ; +- dflags <- pure (hsc_dflags hsc_env) ; +- hs_splice_data <- newIORef =<< whenSet (loadSplicesDir dflags) +- (\splicesDir -> do +- if moduleUnitId mod == interactiveUnitId +- then return emptyHsSpliceData +- else do let moduleSplicesPath = getModuleSplicesPath splicesDir mod +- readHsSpliceData hsc_env moduleSplicesPath +- ) +- (pure emptyHsSpliceData) ; let { -- dflags = hsc_dflags hsc_env ; -- ++ dflags = hsc_dflags hsc_env ; ++ maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val | dopt Opt_D_dump_rn_ast dflags = Just empty_val -@@ -302,7 +310,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this - tcg_tc_plugins = [], +@@ -318,8 +310,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_top_loc = loc, tcg_static_wc = static_wc_var, -- tcg_complete_matches = [] -+ tcg_complete_matches = [], -+ tcg_hs_splice_data = hs_splice_data + tcg_complete_matches = [], +- tcg_cc_st = cc_st_var, +- tcg_hs_splice_data = hs_splice_data ++ tcg_cc_st = cc_st_var } ; } ; diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs -index e4c781f10d..25bd697f21 100644 +index 08ed9f151d..2a4b808f54 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs -@@ -156,6 +156,7 @@ import TyCoRep ( CoercionHole(..), coHoleCoVar ) +@@ -160,7 +160,6 @@ import TyCoRep ( CoercionHole(..), coHoleCoVar ) import Coercion ( Coercion, mkHoleCo ) import ConLike ( ConLike(..) ) import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) -+import {-# SOURCE #-} HsExprBin +-import {-# SOURCE #-} HsExprBin import PatSyn ( PatSyn, pprPatSynType ) import Id ( idType, idName ) import FieldLabel ( FieldLabel ) -@@ -700,7 +701,20 @@ data TcGblEnv - tcg_static_wc :: TcRef WantedConstraints, - -- ^ Wanted constraints of static forms. - -- See Note [Constraints in static forms]. -- tcg_complete_matches :: [CompleteMatch] -+ tcg_complete_matches :: [CompleteMatch], -+ -+ -- ^ Splice evaluation results -+ -- -+ -- When @-save-splices@ is passed, we will -+ -- record splice results in this field and write -+ -- them all to an .hs-splice file when we are done -+ -- processing the module. -+ -- -+ -- When @-load-splices@ is passed, we will read -+ -- the .hs-splice file before we start processing a -+ -- module (when it exists) and store all its contents -+ -- in this field. -+ tcg_hs_splice_data :: TcRef HsSpliceData +@@ -690,19 +689,7 @@ data TcGblEnv + tcg_complete_matches :: [CompleteMatch], + + -- ^ Tracking indices for cost centre annotations +- tcg_cc_st :: TcRef CostCentreState, +- -- ^ Splice evaluation results +- -- +- -- When @-save-splices@ is passed, we will +- -- record splice results in this field and write +- -- them all to an .hs-splice file when we are done +- -- processing the module. +- -- +- -- When @-load-splices@ is passed, we will read +- -- the .hs-splice file before we start processing a +- -- module (when it exists) and store all its contents +- -- in this field. +- tcg_hs_splice_data :: TcRef HsSpliceData ++ tcg_cc_st :: TcRef CostCentreState } -- NB: topModIdentity, not topModSemantic! diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs -index 45e18e69fe..e9ee4ec540 100644 +index c6dd542937..737ddccfbd 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs -@@ -26,6 +26,7 @@ module TcSplice( +@@ -26,7 +26,6 @@ module TcSplice( runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, tcTopSpliceExpr, lookupThName_maybe, defaultRunMeta, runMeta', runRemoteModFinalizers, -+ readHsSpliceData, writeHsSpliceData, +- readHsSpliceData, writeHsSpliceData, finishTH ) where -@@ -34,6 +35,7 @@ module TcSplice( +@@ -35,7 +34,6 @@ module TcSplice( import GhcPrelude import HsSyn -+import HsExprBin +-import HsExprBin import Annotations import Finder import Name -@@ -110,6 +112,9 @@ import Maybes( MaybeErr(..) ) +@@ -112,9 +110,6 @@ import Maybes( MaybeErr(..) ) import DynFlags import Panic import Lexeme -+import BinIface ( getWithUserData, putWithUserData ) -+import IfaceEnv ( NameCacheUpdater(..) ) -+import qualified Binary as Bin +-import BinIface ( getWithUserData, putWithUserData ) +-import IfaceEnv ( NameCacheUpdater(..) ) +-import qualified Binary as Bin import qualified EnumSet - - import qualified Language.Haskell.TH as TH -@@ -130,6 +135,7 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) + import Plugins + import Bag +@@ -137,7 +132,6 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) import GHC.Exts ( unsafeCoerce# ) -+import System.Directory ( doesFileExist ) +-import System.Directory ( doesFileExist ) {- ************************************************************************ -@@ -667,12 +673,26 @@ runQResult show_th f runQ expr_span hval +@@ -678,26 +672,12 @@ runQResult show_th f runQ expr_span hval ----------------- -+ +- runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) -+ -> (LHsExpr GhcTc -> TcM hs_syn) -+ -- ^ function to load the result of the given expression from -+ -- an .hs-splice file's data -+ -> (LHsExpr GhcTc -> hs_syn -> TcM ()) -+ -- ^ function to "save" the result (hs_syn) of evaluating the given -+ -- LHsExpr +- -> (LHsExpr GhcTc -> TcM hs_syn) +- -- ^ function to load the result of the given expression from +- -- an .hs-splice file's data +- -> (LHsExpr GhcTc -> hs_syn -> TcM ()) +- -- ^ function to "save" the result (hs_syn) of evaluating the given +- -- LHsExpr -> LHsExpr GhcTc -> TcM hs_syn --runMeta unwrap e -- = do { h <- getHooked runMetaHook defaultRunMeta -- ; unwrap h e } -+runMeta unwrap loadSpliceFun saveSpliceFun e -+ = do { dflags <- getDynFlags -+ ; whenSet (loadSplicesDir dflags) -+ (\_ -> loadSpliceFun e) -+ (do { h <- getHooked runMetaHook defaultRunMeta -+ ; res <- unwrap h e -+ ; whenSet (saveSplicesDir dflags) -+ (\_ -> saveSpliceFun e res) -+ (return ()) -+ ; return res }) } +-runMeta unwrap loadSpliceFun saveSpliceFun e +- = do { dflags <- getDynFlags +- ; whenSet (loadSplicesDir dflags) +- (\_ -> loadSpliceFun e) +- (do { h <- getHooked runMetaHook defaultRunMeta +- ; res <- unwrap h e +- ; whenSet (saveSplicesDir dflags) +- (\_ -> saveSpliceFun e res) +- (return ()) +- ; return res }) } ++runMeta unwrap e ++ = do { h <- getHooked runMetaHook defaultRunMeta ++ ; unwrap h e } defaultRunMeta :: MetaHook TcM defaultRunMeta (MetaE r) -@@ -689,29 +709,110 @@ defaultRunMeta (MetaAW r) +@@ -714,110 +694,29 @@ defaultRunMeta (MetaAW r) -- the toAnnotationWrapper function that we slap around the user's code ---------------- -+ -+readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData -+readHsSpliceData hsc_env hsSpliceFile = do -+ let ncu = NCU (updNameCacheIO hsc_env) -+ exists <- doesFileExist hsSpliceFile -+ if exists -+ then do bh <- Bin.readBinMem hsSpliceFile -+ getWithUserData ncu bh -+ else pure emptyHsSpliceData -+ -+writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () -+writeHsSpliceData hsSpliceFile hsSpliceData = -+ when (nonEmptyHsSpliceData hsSpliceData) $ do -+ dflags <- getDynFlags -+ liftIO $ do -+ bh <- Bin.openBinMem (100 * 1024) -+ -- ^^^ FIXME: how should we compute an approximation of size? -+ putWithUserData (debugTraceMsg dflags 3) bh hsSpliceData -+ Bin.writeBinMem bh hsSpliceFile -+ -+-- | Update the splice data from the TcGblEnv using the given -+-- function. Used when -save-splices is passed, to record -+-- the splice results as we evaluate them and dump them -+-- to an .hs-splice file. -+modifyHsSpliceData :: (HsSpliceData -> HsSpliceData) -> TcM () -+modifyHsSpliceData f = do -+ spliceDataRef <- tcg_hs_splice_data <$> getGblEnv -+ updTcRef spliceDataRef f -+ -+-- | Record the result (second argument) of evaluating the expression splice -+-- represented by the first argument. -+addSpliceExprResult :: LHsExpr GhcTc -> LHsExpr GhcPs -> TcM () -+addSpliceExprResult th@(L l _) resultE = do -+ serialExpr <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) -+ =<< exprPS2SE resultE -+ modifyHsSpliceData $ recordSpliceResult l (SRExpr serialExpr) -+ -+-- | Record the result (second argument) of evaluating the declaration splice -+-- represented by the first argument. -+addSpliceDeclsResult :: LHsExpr GhcTc -> [LHsDecl GhcPs] -> TcM () -+addSpliceDeclsResult th@(L l _) resultDs = do -+ serialDecls <- traverse -+ (declPS2SE >=> handleUnsupported (fmap ppr th) (Just $ ppr resultDs)) -+ resultDs -+ modifyHsSpliceData $ recordSpliceResult l (SRDecls serialDecls) -+ -+-- | Look up the result of evaluating the splice represented by the first -+-- argument in an .hs-splice file, using the given function to extract -+-- the result in question (when found). -+getSpliceResult :: LHsExpr GhcTc -> (SpliceResult -> TcM a) -> TcM a -+getSpliceResult (L l _) f = do -+ gblEnv <- getGblEnv -+ hs_splice_data <- readTcRef (tcg_hs_splice_data gblEnv) -+ case lookupSpliceResult l hs_splice_data of -+ Nothing -> panic ("Could not find splice result for source span " ++ show l) -+ Just r -> f r -+ -+-- | Look up the result of evaluating an expression splice. -+getSpliceExprResult :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs) -+getSpliceExprResult spliceE = getSpliceResult spliceE $ \res -> case res of -+ SRExpr e -> exprSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing -+ SRDecls _ -> panic ("Expected an expression splice but found a declaration one") -+ -+-- | Look up the result of evaluating a declaration splice. -+getSpliceDeclsResult :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] -+getSpliceDeclsResult spliceE = getSpliceResult spliceE $ \res -> case res of -+ SRExpr _ -> panic ("Expected a declaration splice result but found an expression one") -+ SRDecls ds -> traverse -+ (declSE2PS >=> handleUnsupported (fmap ppr spliceE) Nothing) -+ ds -+ +- +-readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData +-readHsSpliceData hsc_env hsSpliceFile = do +- let ncu = NCU (updNameCache hsc_env) +- exists <- doesFileExist hsSpliceFile +- if exists +- then do bh <- Bin.readBinMem hsSpliceFile +- getWithUserData ncu bh +- else pure emptyHsSpliceData +- +-writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () +-writeHsSpliceData hsSpliceFile hsSpliceData = +- when (nonEmptyHsSpliceData hsSpliceData) $ do +- dflags <- getDynFlags +- liftIO $ do +- bh <- Bin.openBinMem (100 * 1024) +- -- ^^^ FIXME: how should we compute an approximation of size? +- putWithUserData (debugTraceMsg dflags 3) bh hsSpliceData +- Bin.writeBinMem bh hsSpliceFile +- +--- | Update the splice data from the TcGblEnv using the given +--- function. Used when -save-splices is passed, to record +--- the splice results as we evaluate them and dump them +--- to an .hs-splice file. +-modifyHsSpliceData :: (HsSpliceData -> HsSpliceData) -> TcM () +-modifyHsSpliceData f = do +- spliceDataRef <- tcg_hs_splice_data <$> getGblEnv +- updTcRef spliceDataRef f +- +--- | Record the result (second argument) of evaluating the expression splice +--- represented by the first argument. +-addSpliceExprResult :: LHsExpr GhcTc -> LHsExpr GhcPs -> TcM () +-addSpliceExprResult th@(L l _) resultE = do +- serialExpr <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) +- =<< exprPS2SE resultE +- modifyHsSpliceData $ recordSpliceResult l (SRExpr serialExpr) +- +--- | Record the result (second argument) of evaluating the declaration splice +--- represented by the first argument. +-addSpliceDeclsResult :: LHsExpr GhcTc -> [LHsDecl GhcPs] -> TcM () +-addSpliceDeclsResult th@(L l _) resultDs = do +- serialDecls <- traverse +- (declPS2SE >=> handleUnsupported (fmap ppr th) (Just $ ppr resultDs)) +- resultDs +- modifyHsSpliceData $ recordSpliceResult l (SRDecls serialDecls) +- +--- | Look up the result of evaluating the splice represented by the first +--- argument in an .hs-splice file, using the given function to extract +--- the result in question (when found). +-getSpliceResult :: LHsExpr GhcTc -> (SpliceResult -> TcM a) -> TcM a +-getSpliceResult (L l _) f = do +- gblEnv <- getGblEnv +- hs_splice_data <- readTcRef (tcg_hs_splice_data gblEnv) +- case lookupSpliceResult l hs_splice_data of +- Nothing -> panic ("Could not find splice result for source span " ++ show l) +- Just r -> f r +- +--- | Look up the result of evaluating an expression splice. +-getSpliceExprResult :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs) +-getSpliceExprResult spliceE = getSpliceResult spliceE $ \res -> case res of +- SRExpr e -> exprSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing +- SRDecls _ -> panic ("Expected an expression splice but found a declaration one") +- +--- | Look up the result of evaluating a declaration splice. +-getSpliceDeclsResult :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] +-getSpliceDeclsResult spliceE = getSpliceResult spliceE $ \res -> case res of +- SRExpr _ -> panic ("Expected a declaration splice result but found an expression one") +- SRDecls ds -> traverse +- (declSE2PS >=> handleUnsupported (fmap ppr spliceE) Nothing) +- ds +- runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper -> TcM Serialized runMetaAW = runMeta metaRequestAW -+ -- We cannot process annotations as they use the same -+ -- mechanism as TH. Instead, we ignore them when -+ -- doing a -save-splices pass, and we pretend we -+ -- read {-# ANN () #-} when doing a -load-splices pass. -+ (\_ -> pure $ toSerialized serializeWithData ()) -+ (\_ _ -> pure ()) +- -- We cannot process annotations as they use the same +- -- mechanism as TH. Instead, we ignore them when +- -- doing a -save-splices pass, and we pretend we +- -- read {-# ANN () #-} when doing a -load-splices pass. +- (\_ -> pure $ toSerialized serializeWithData ()) +- (\_ _ -> pure ()) runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) -> TcM (LHsExpr GhcPs) --runMetaE = runMeta metaRequestE -+runMetaE = runMeta metaRequestE getSpliceExprResult addSpliceExprResult +-runMetaE = runMeta metaRequestE getSpliceExprResult addSpliceExprResult ++runMetaE = runMeta metaRequestE runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) -> TcM (LPat GhcPs) runMetaP = runMeta metaRequestP -+ (panic "runMetaP doesn't support splice caching (read)") -+ (panic "runMetaP doesn't support splice caching (write)") +- (panic "runMetaP doesn't support splice caching (read)") +- (panic "runMetaP doesn't support splice caching (write)") runMetaT :: LHsExpr GhcTc -- Of type (Q Type) -> TcM (LHsType GhcPs) runMetaT = runMeta metaRequestT -+ (panic "runMetaT doesn't support splice caching (read)") -+ (panic "runMetaT doesn't support splice caching (write)") +- (panic "runMetaT doesn't support splice caching (read)") +- (panic "runMetaT doesn't support splice caching (write)") runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] -> TcM [LHsDecl GhcPs] --runMetaD = runMeta metaRequestD -+runMetaD = runMeta metaRequestD getSpliceDeclsResult addSpliceDeclsResult +-runMetaD = runMeta metaRequestD getSpliceDeclsResult addSpliceDeclsResult ++runMetaD = runMeta metaRequestD --------------- runMeta' :: Bool -- Whether code should be printed in the exception message -- -> (hs_syn -> SDoc) -- how to print the code -+ -> (hs_syn -> SDoc) -- how to print the code +- -> (hs_syn -> SDoc) -- how to print the code ++ -> (hs_syn -> SDoc) -- how to print the code -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or -- something like that -@@ -722,7 +823,7 @@ runMeta' show_code ppr_hs run_and_convert expr +@@ -828,7 +727,7 @@ runMeta' show_code ppr_hs run_and_convert expr -- we catch all kinds of splices and annotations. -- Check that we've had no errors of any sort so far. -- -- For example, if we found an error in an earlier defn f, but -+ -- For example, if we fouénd an error in an earlier defn f, but +- -- For example, if we fouénd an error in an earlier defn f, but ++ -- For example, if we found an error in an earlier defn f, but -- recovered giving it type f :: forall a.a, it'd be very dodgy -- to carry ont. Mind you, the staging restrictions mean we won't -- actually run f, but it still seems wrong. And, more concretely, diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot -index be2c67d887..003948c1fb 100644 +index 277dc95c8d..be2c67d887 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot -@@ -9,6 +9,8 @@ import HsExpr ( PendingRnSplice ) - import TcRnTypes( TcM , SpliceType ) +@@ -10,8 +10,6 @@ import TcRnTypes( TcM , SpliceType ) import TcType ( ExpRhoType ) import Annotations ( Annotation, CoreAnnTarget ) -+import HscTypes ( HscEnv ) -+import HsExprBin ( HsSpliceData ) import HsExtension ( GhcTcId, GhcRn, GhcPs ) +-import HscTypes ( HscEnv ) +-import HsExprBin ( HsSpliceData ) import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, -@@ -42,3 +44,6 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name) + LHsDecl, ThModFinalizers ) +@@ -44,6 +42,3 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a runRemoteModFinalizers :: ThModFinalizers -> TcM () finishTH :: TcM () -+ -+readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData -+writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () +- +-readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData +-writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () \ No newline at end of file diff --git a/compiler/typecheck/TcType.hs-boot b/compiler/typecheck/TcType.hs-boot -index 2bc14735f1..1b014c2d2a 100644 +index 1b014c2d2a..2bc14735f1 100644 --- a/compiler/typecheck/TcType.hs-boot +++ b/compiler/typecheck/TcType.hs-boot -@@ -4,5 +4,6 @@ import Outputable( SDoc ) +@@ -4,6 +4,5 @@ import Outputable( SDoc ) data MetaDetails data TcTyVarDetails -+ +- pprTcTyVarDetails :: TcTyVarDetails -> SDoc vanillaSkolemTv :: TcTyVarDetails diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs -index 5234290fd2..9aef679ab4 100644 +index c8334ddd42..63c21627c8 100644 --- a/compiler/types/CoAxiom.hs +++ b/compiler/types/CoAxiom.hs @@ -39,9 +39,9 @@ import Name import Unique import Var import Util --import Binary ++import Binary import Pair import BasicTypes -+import Binary +-import Binary import Data.Typeable ( Typeable ) import SrcLoc import qualified Data.Data as Data -@@ -440,15 +440,16 @@ instance Outputable Role where +@@ -440,16 +440,15 @@ instance Outputable Role where ppr = ftext . fsFromRole instance Binary Role where -- put_ bh Nominal = putByte bh 1 -- put_ bh Representational = putByte bh 2 -- put_ bh Phantom = putByte bh 3 -- -- get bh = do tag <- getByte bh -- case tag of 1 -> return Nominal -- 2 -> return Representational -- 3 -> return Phantom -- _ -> panic ("get Role " ++ show tag) -+ put_ bh r = putByte bh $ case r of -+ Nominal -> 0 -+ Representational -> 1 -+ Phantom -> 2 -+ get bh = do -+ tag <- getByte bh -+ pure $ case tag of -+ 0 -> Nominal -+ 1 -> Representational -+ _ -> Phantom +- put_ bh r = putByte bh $ case r of +- Nominal -> 0 +- Representational -> 1 +- Phantom -> 2 +- get bh = do +- tag <- getByte bh +- pure $ case tag of +- 0 -> Nominal +- 1 -> Representational +- _ -> Phantom ++ put_ bh Nominal = putByte bh 1 ++ put_ bh Representational = putByte bh 2 ++ put_ bh Phantom = putByte bh 3 ++ ++ get bh = do tag <- getByte bh ++ case tag of 1 -> return Nominal ++ 2 -> return Representational ++ 3 -> return Phantom ++ _ -> panic ("get Role " ++ show tag) {- ************************************************************************ -@@ -501,7 +502,6 @@ instance Ord CoAxiomRule where +@@ -502,6 +501,7 @@ instance Ord CoAxiomRule where instance Outputable CoAxiomRule where ppr = ppr . coaxrName -- ++ -- Type checking of built-in families data BuiltInSynFamily = BuiltInSynFamily { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot -index 8dcbd10744..3d3375bcfc 100644 ---- a/compiler/types/TyCoRep.hs-boot -+++ b/compiler/types/TyCoRep.hs-boot -@@ -20,4 +20,3 @@ pprType :: Type -> SDoc - - instance Data Type - -- To support Data instances in CoAxiom -- diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs -index cf96a49403..652edd4cf0 100644 +index 786e77ef63..82c9082ac1 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs -@@ -573,7 +573,6 @@ instance Binary TyConBndrVis where +@@ -584,6 +584,7 @@ instance Binary TyConBndrVis where 0 -> return AnonTCB _ -> do { vis <- get bh; return (NamedTCB vis) } } -- ++ {- ********************************************************************* * * The TyCon type diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs -index c3c8ae3ab7..dc869793e4 100644 +index a84624d24c..447317ca47 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs -@@ -63,12 +63,16 @@ module Binary +@@ -63,16 +63,12 @@ module Binary import GhcPrelude import {-# SOURCE #-} Name (Name) -+import Bag +-import Bag import FastString import Panic -+import Unique +-import Unique import UniqFM -+import UniqSet +-import UniqSet import FastMutInt import Fingerprint import BasicTypes -+import {-# SOURCE #-} PrimOp +-import {-# SOURCE #-} PrimOp import SrcLoc import Foreign -@@ -76,8 +80,10 @@ import Data.Array +@@ -80,17 +76,14 @@ import Data.Array import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS -+import qualified Data.IntMap as IM +-import qualified Data.IntMap as IM import Data.IORef import Data.Char ( ord, chr ) -+import Data.List ( find ) +-import Data.List ( find ) import Data.Time - #if MIN_VERSION_base(4,10,0) import Type.Reflection -@@ -87,7 +93,7 @@ import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) - #else - import Data.Typeable - #endif --import Control.Monad ( when ) -+import Control.Monad ( when, replicateM ) + import Type.Reflection.Unsafe + import Data.Kind (Type) + import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) +-import Data.Typeable ( ) +-import Control.Monad ( when, replicateM ) ++import Control.Monad ( when ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) -@@ -384,8 +390,8 @@ instance Binary () where +@@ -387,8 +380,8 @@ instance Binary () where get _ = return () instance Binary Bool where -- put_ bh b = putByte bh (fromIntegral (fromEnum b)) -- get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) -+ put_ bh b = putByte bh (if b then 1 else 0) -+ get bh = do x <- getByte bh; return $! if x == 0 then False else True +- put_ bh b = putByte bh (if b then 1 else 0) +- get bh = do x <- getByte bh; return $! if x == 0 then False else True ++ put_ bh b = putByte bh (fromIntegral (fromEnum b)) ++ get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) instance Binary Char where put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) -@@ -1199,3 +1205,130 @@ instance Binary SourceText where +@@ -1180,121 +1173,3 @@ instance Binary SourceText where s <- get bh return (SourceText s) _ -> panic $ "Binary SourceText:" ++ show h -+ -+instance Binary IntegralLit where -+ put_ bh (IL a b c) = put_ bh a >> put_ bh b >> put_ bh c -+ get bh = IL <$> get bh <*> get bh <*> get bh -+ -+instance Binary FractionalLit where -+ put_ bh (FL a b c) = put_ bh a >> put_ bh b >> put_ bh c -+ get bh = FL <$> get bh <*> get bh <*> get bh -+ -+instance Binary Boxity where -+ put_ bh b = case b of -+ Boxed -> putByte bh 0 -+ Unboxed -> putByte bh 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure Boxed -+ _ -> pure Unboxed -+ -+-- FIXME: optimise? -+instance (Ix i, Binary i, Binary a) => Binary (Array i a) where -+ put_ bh arr = case bounds arr of -+ (a, b) -> put_ bh a >> put_ bh b >> put_ bh (elems arr) -+ get bh = do -+ bounds <- (,) <$> get bh <*> get bh -+ xs <- replicateM (rangeSize bounds) (get bh) -+ return (listArray bounds xs) -+ -+instance Binary Unique where -+ put_ bh u = put_ bh (getKey u) -+ get bh = mkUniqueGrimily <$> get bh -+ -+instance Binary ty => Binary (DefMethSpec ty) where -+ put_ bh s -+ = case s of -+ VanillaDM -> putByte bh 0 -+ GenericDM t -> putByte bh 1 >> put_ bh t -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure VanillaDM -+ _ -> GenericDM <$> get bh -+ -+instance Binary a => Binary (IM.IntMap a) where -+ put_ bh m = put_ bh (IM.toAscList m) -+ get bh = IM.fromAscList <$> get bh -+ -+instance Binary PrimOp where -+ put_ bh primop = put_ bh (primOpTag primop) -+ -- FIXME: inefficient. -+ get bh = do -+ tag <- getTag -+ case find (\p -> primOpTag p == tag) allThePrimOps of -+ Nothing -> error "Binary PrimOp.get: unknown primop tag" -+ Just p -> pure p -+ -+ where getTag :: IO Int -+ getTag = get bh -+ -+instance Binary OccInfo where -+ put_ bh i -+ = case i of -+ ManyOccs a -> putByte bh 0 >> put_ bh a -+ IAmDead -> putByte bh 1 -+ OneOcc a b c d -> putByte bh 2 >> put_ bh a >> put_ bh b -+ >> put_ bh c >> put_ bh d -+ IAmALoopBreaker a b -> putByte bh 3 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ManyOccs <$> get bh -+ 1 -> pure IAmDead -+ 2 -> OneOcc <$> get bh <*> get bh <*> get bh <*> get bh -+ _ -> IAmALoopBreaker <$> get bh <*> get bh -+ -+instance Binary TailCallInfo where -+ put_ bh i -+ = case i of -+ AlwaysTailCalled a -> putByte bh 0 >> put_ bh a -+ NoTailCallInfo -> putByte bh 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> AlwaysTailCalled <$> get bh -+ _ -> pure NoTailCallInfo -+ -+instance Binary OneShotInfo where -+ put_ bh i -+ = case i of -+ NoOneShotInfo -> putByte bh 0 -+ OneShotLam -> putByte bh 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure NoOneShotInfo -+ _ -> pure OneShotLam -+ -+instance Binary LexicalFixity where -+ put_ bh f = case f of -+ Prefix -> putByte bh 0 -+ Infix -> putByte bh 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure Prefix -+ _ -> pure Infix -+ -+instance Binary ele => Binary (UniqFM ele) where -+ put_ bh ufm = put_ bh (ufmToIntMap ufm) -+ get bh = intMapToUFM <$> get bh -+ -+instance Binary a => Binary (UniqSet a) where -+ put_ bh s = put_ bh (getUniqSet s) -+ get bh = unsafeUFMToUniqSet <$> get bh -+ -+instance Binary a => Binary (Bag a) where -+ put_ bh b = put_ bh (bagToList b) -+ get bh = listToBag <$> get bh -+ -+instance Binary Origin where -+ put_ bh o = putByte bh $ case o of -+ FromSource -> 0 -+ Generated -> 1 -+ get bh = getByte bh >>= \n -> case n of -+ 0 -> pure FromSource -+ 1 -> pure Generated -+ _ -> panic "Binary Origin.get: unknown tag" +- +-instance Binary IntegralLit where +- put_ bh (IL a b c) = put_ bh a >> put_ bh b >> put_ bh c +- get bh = IL <$> get bh <*> get bh <*> get bh +- +-instance Binary FractionalLit where +- put_ bh (FL a b c) = put_ bh a >> put_ bh b >> put_ bh c +- get bh = FL <$> get bh <*> get bh <*> get bh +- +-instance Binary Boxity where +- put_ bh b = case b of +- Boxed -> putByte bh 0 +- Unboxed -> putByte bh 1 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure Boxed +- _ -> pure Unboxed +- +-instance Binary Unique where +- put_ bh u = put_ bh (getKey u) +- get bh = mkUniqueGrimily <$> get bh +- +-instance Binary ty => Binary (DefMethSpec ty) where +- put_ bh s +- = case s of +- VanillaDM -> putByte bh 0 +- GenericDM t -> putByte bh 1 >> put_ bh t +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure VanillaDM +- _ -> GenericDM <$> get bh +- +-instance Binary a => Binary (IM.IntMap a) where +- put_ bh m = put_ bh (IM.toAscList m) +- get bh = IM.fromAscList <$> get bh +- +-instance Binary PrimOp where +- put_ bh primop = put_ bh (primOpTag primop) +- -- FIXME: inefficient. +- get bh = do +- tag <- getTag +- case find (\p -> primOpTag p == tag) allThePrimOps of +- Nothing -> error "Binary PrimOp.get: unknown primop tag" +- Just p -> pure p +- +- where getTag :: IO Int +- getTag = get bh +- +-instance Binary OccInfo where +- put_ bh i +- = case i of +- ManyOccs a -> putByte bh 0 >> put_ bh a +- IAmDead -> putByte bh 1 +- OneOcc a b c d -> putByte bh 2 >> put_ bh a >> put_ bh b +- >> put_ bh c >> put_ bh d +- IAmALoopBreaker a b -> putByte bh 3 >> put_ bh a >> put_ bh b +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> ManyOccs <$> get bh +- 1 -> pure IAmDead +- 2 -> OneOcc <$> get bh <*> get bh <*> get bh <*> get bh +- _ -> IAmALoopBreaker <$> get bh <*> get bh +- +-instance Binary TailCallInfo where +- put_ bh i +- = case i of +- AlwaysTailCalled a -> putByte bh 0 >> put_ bh a +- NoTailCallInfo -> putByte bh 1 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> AlwaysTailCalled <$> get bh +- _ -> pure NoTailCallInfo +- +-instance Binary OneShotInfo where +- put_ bh i +- = case i of +- NoOneShotInfo -> putByte bh 0 +- OneShotLam -> putByte bh 1 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure NoOneShotInfo +- _ -> pure OneShotLam +- +-instance Binary LexicalFixity where +- put_ bh f = case f of +- Prefix -> putByte bh 0 +- Infix -> putByte bh 1 +- get bh = do +- tag <- getByte bh +- case tag of +- 0 -> pure Prefix +- _ -> pure Infix +- +-instance Binary ele => Binary (UniqFM ele) where +- put_ bh ufm = put_ bh (ufmToIntMap ufm) +- get bh = intMapToUFM <$> get bh +- +-instance Binary a => Binary (UniqSet a) where +- put_ bh s = put_ bh (getUniqSet s) +- get bh = unsafeUFMToUniqSet <$> get bh +- +-instance Binary a => Binary (Bag a) where +- put_ bh b = put_ bh (bagToList b) +- get bh = listToBag <$> get bh +- +-instance Binary Origin where +- put_ bh o = putByte bh $ case o of +- FromSource -> 0 +- Generated -> 1 +- get bh = getByte bh >>= \n -> case n of +- 0 -> pure FromSource +- 1 -> pure Generated +- _ -> panic "Binary Origin.get: unknown tag" diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs -index 715600ddb8..90389da0d1 100644 +index 90389da0d1..715600ddb8 100644 --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs -@@ -62,6 +62,7 @@ module UniqDFM ( +@@ -62,7 +62,6 @@ module UniqDFM ( import GhcPrelude import Unique ( Uniquable(..), Unique, getKey ) -+import Binary +-import Binary import Outputable import qualified Data.IntMap as M -@@ -128,6 +129,10 @@ instance Eq val => Eq (TaggedVal val) where +@@ -129,10 +128,6 @@ instance Eq val => Eq (TaggedVal val) where instance Functor TaggedVal where fmap f (TaggedVal val i) = TaggedVal (f val) i -+instance Binary val => Binary (TaggedVal val) where -+ put_ bh (TaggedVal a b) = put_ bh a >> put_ bh b -+ get bh = TaggedVal <$> get bh <*> get bh -+ +-instance Binary val => Binary (TaggedVal val) where +- put_ bh (TaggedVal a b) = put_ bh a >> put_ bh b +- get bh = TaggedVal <$> get bh <*> get bh +- -- | Type of unique deterministic finite maps data UniqDFM ele = UDFM -@@ -139,6 +144,10 @@ data UniqDFM ele = +@@ -144,10 +139,6 @@ data UniqDFM ele = -- time. See Note [Overflow on plusUDFM] deriving (Data, Functor) -+instance Binary ele => Binary (UniqDFM ele) where -+ put_ bh (UDFM a b) = put_ bh a >> put_ bh b -+ get bh = UDFM <$> get bh <*> get bh -+ +-instance Binary ele => Binary (UniqDFM ele) where +- put_ bh (UDFM a b) = put_ bh a >> put_ bh b +- get bh = UDFM <$> get bh <*> get bh +- emptyUDFM :: UniqDFM elt emptyUDFM = UDFM M.empty 0 diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs -index f0cc197b71..2f874c04e5 100644 +index 7a7c40ecfc..a80880f4e5 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs -@@ -67,7 +67,7 @@ module UniqFM ( +@@ -66,7 +66,7 @@ module UniqFM ( lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, nonDetEltsUFM, eltsUFM, nonDetKeysUFM, ufmToSet_Directly, -- nonDetUFMToList, ufmToIntMap, -+ nonDetUFMToList, ufmToIntMap, intMapToUFM, +- nonDetUFMToList, ufmToIntMap, intMapToUFM, ++ nonDetUFMToList, ufmToIntMap, pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM ) where -@@ -344,6 +344,9 @@ nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m +@@ -338,10 +338,7 @@ nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m ufmToIntMap :: UniqFM elt -> M.IntMap elt ufmToIntMap (UFM m) = m -+intMapToUFM :: M.IntMap elt -> UniqFM elt -+intMapToUFM = UFM -+ - -- Determines whether two 'UniqFm's contain the same keys. +-intMapToUFM :: M.IntMap elt -> UniqFM elt +-intMapToUFM = UFM +- +--- Determines whether two 'UniqFM's contain the same keys. ++-- Determines whether two 'UniqFm's contain the same keys. equalKeysUFM :: UniqFM a -> UniqFM b -> Bool - #if MIN_VERSION_containers(0,5,9) + equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 + +diff --git a/libraries/process b/libraries/process +index 36a3ad577e..7a2dfa0b48 160000 +--- a/libraries/process ++++ b/libraries/process +@@ -1 +1 @@ +-Subproject commit 36a3ad577e31e8c3336c7464b252fc2c9b01a20c ++Subproject commit 7a2dfa0b48bbb48a22174cb4c2281d4000191cb0 +diff --git a/libraries/transformers b/libraries/transformers +index 80557845cd..def8c55d0c 160000 +--- a/libraries/transformers ++++ b/libraries/transformers +@@ -1 +1 @@ +-Subproject commit 80557845cdc0e72bc05cec19cf7a1bf5495e9e69 ++Subproject commit def8c55d0c47c1c40de985d83f052f3659b40cfd From dc72af4703ab7959f428ffe42217ec920d3d742a Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sat, 6 Jul 2019 12:10:38 -0400 Subject: [PATCH 10/55] Switch to forked nixpkgs 18.09 with ghcjs86 backported --- nixpkgs/github.json | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/nixpkgs/github.json b/nixpkgs/github.json index 81b6de910..7228c38ce 100644 --- a/nixpkgs/github.json +++ b/nixpkgs/github.json @@ -1,6 +1,6 @@ { - "owner": "NixOS", - "repo": "nixpkgs-channels", - "rev": "571b40d3f50466d3e91c1e609d372de96d782793", - "sha256": "0qjpkx2b5pac1nqr5chvlrlcyyk294w2079ybf88p95qxkqbbby5" + "owner": "obsidiansystems", + "repo": "nixpkgs", + "rev": "a6f82a06b2be2e615513dda985f1dfd9f08efc93", + "sha256": "0gibajs3xka3apa5w5ac2plaxg6v9wji3izwq32ylly6r55b6fh5" } From f8af9baf5dad3dbaf143efeffcdbeb9408c0df2d Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 8 Jul 2019 10:47:37 -0400 Subject: [PATCH 11/55] WIP: Bump nixpkgs; Update to ghc865. Currently webkitgtk+deps are failing --- default.nix | 12 +-- haskell-overlays/any-8.nix | 3 +- haskell-overlays/default.nix | 3 +- haskell-overlays/ghcjs-8.6-text-jsstring.nix | 7 +- .../ghcjs-fast-weak/fast-weak.patch | 20 ++--- haskell-overlays/ghcjs.nix | 8 ++ haskell-overlays/hie/default.nix | 73 ++++++------------- .../hie/dep/haskell-ide-engine/github.json | 6 +- .../reflex-packages/dep/jsaddle/github.json | 4 +- .../dep/reflex-dom/github.json | 4 +- haskell-overlays/untriaged.nix | 32 +++++++- nixpkgs/github.json | 8 +- splices-load-save.patch | 16 +--- 13 files changed, 102 insertions(+), 94 deletions(-) diff --git a/default.nix b/default.nix index 9233b0cdd..c9dbfe9f5 100644 --- a/default.nix +++ b/default.nix @@ -18,14 +18,14 @@ let iosSupport = system == "x86_64-darwin"; splicesEval = self: super: { haskell = super.haskell // { compiler = super.haskell.compiler // { - ghcSplices-8_6 = super.haskell.compiler.ghc863.overrideAttrs (drv: { + ghcSplices-8_6 = super.haskell.compiler.ghc865.overrideAttrs (drv: { enableParallelBuilding = false; patches = (drv.patches or []) ++ [ ./splices-load-save.patch ./haddock.patch ]; }); }; packages = super.haskell.packages // { - ghcSplices-8_6 = super.haskell.packages.ghc863.override { + ghcSplices-8_6 = super.haskell.packages.ghc865.override { buildHaskellPackages = self.buildPackages.haskell.packages.ghcSplices-8_6; ghc = self.buildPackages.haskell.compiler.ghcSplices-8_6; }; @@ -83,7 +83,7 @@ let iosSupport = system == "x86_64-darwin"; "webkitgtk-2.4.11" ]; packageOverrides = pkgs: { - webkitgtk = pkgs.webkitgtk220x; + webkitgtk = pkgs.webkitgtk; #24x-gtk3; # TODO should this be gtk3? }; # XCode needed for native macOS app @@ -179,8 +179,8 @@ let iosSupport = system == "x86_64-darwin"; ghc = old.ghc.override { ghcjsSrc = fetchgit { url = "https://github.com/ghcjs/ghcjs.git"; - rev = "00a8993a8d9c35b33b84a83b0aec5171c582a4f3"; - sha256 = "0a9qna5qffskfgw9a4jwvzfd81c41vw36k46hw52hw9xxynvk7x9"; + rev = "05afd14691ac7170355f6ffd51a05226f394eb76"; + sha256 = "048glad43j0nnpmlqh9v4si4bp01h6ifv1db5ca0nnpwkyb0h9v4"; fetchSubmodules = true; }; }; @@ -192,7 +192,7 @@ let iosSupport = system == "x86_64-darwin"; ghcHEAD = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghcHEAD).override { overrides = nixpkgs.haskell.overlays.combined; }; - ghc8_6 = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghc863).override { + ghc8_6 = (makeRecursivelyOverridable nixpkgs.haskell.packages.ghc865).override { overrides = nixpkgs.haskell.overlays.combined; }; diff --git a/haskell-overlays/any-8.nix b/haskell-overlays/any-8.nix index a8708c08f..22246d4a0 100644 --- a/haskell-overlays/any-8.nix +++ b/haskell-overlays/any-8.nix @@ -1,10 +1,11 @@ { lib, haskellLib, getGhcVersion }: with haskellLib; -self: super: lib.optionalAttrs (lib.versionOlder (getGhcVersion super.ghc) "8.4.0") { +self: super: lib.optionalAttrs (lib.versionOlder (getGhcVersion super.ghc) "8.6.0") { # TODO document why concurrent-output = haskellLib.doJailbreak super.concurrent-output; # Newer versions cause some sort of issues with multiple `(<>)` definitions. # Seems to be that semigroup-monoid stuff is being CPP'd incorrectly. base-compat= self.callHackage "base-compat" "0.9.3" {}; haddock-library = doJailbreak (self.callHackage "haddock-library" "1.7.0" {}); + entropy = self.callHackage "entropy" "0.4.1.4" {}; } diff --git a/haskell-overlays/default.nix b/haskell-overlays/default.nix index 7a7effb7c..0111a84cd 100644 --- a/haskell-overlays/default.nix +++ b/haskell-overlays/default.nix @@ -118,7 +118,7 @@ rec { inherit lib; }; ghcjs-8_6 = optionalExtension useTextJSString - (import ./ghcjs-8.4-text-jsstring.nix { inherit lib fetchgit; }); + (import ./ghcjs-8.6-text-jsstring.nix { inherit lib fetchgit; }); android = import ./android { inherit haskellLib; @@ -134,6 +134,7 @@ rec { inherit haskellLib; inherit fetchFromGitHub; inherit enableLibraryProfiling; + inherit nixpkgs; }; hie = import ./hie { diff --git a/haskell-overlays/ghcjs-8.6-text-jsstring.nix b/haskell-overlays/ghcjs-8.6-text-jsstring.nix index e43556f17..9ba1ce1e5 100644 --- a/haskell-overlays/ghcjs-8.6-text-jsstring.nix +++ b/haskell-overlays/ghcjs-8.6-text-jsstring.nix @@ -21,6 +21,11 @@ self: super: { substituteInPlace $out/vector.cabal --replace 'base >= 4.5 && < 4.10' 'base >= 4.5 && < 5' ''; }; + primitiveSrc = fetchgit { + url = "https://github.com/haskell/primitive.git"; + rev = " 53f72ce69a4dfde5345cf5809a8b4a1993523367"; + sha256 = "17dr8rdfaj5sscdg5xaaaj1dj96w54l53bca2jbl211sr2004z9h"; + }; }; ghc = super.ghc.overrideAttrs (drv: { @@ -33,8 +38,8 @@ self: super: { cp --no-preserve=mode -r "${self._dep.textSrc}" lib/boot/pkg/text cp --no-preserve=mode -r "${self._dep.ghcjsBaseTextJSStringSrc}" lib/boot/pkg/ghcjs-base cp --no-preserve=mode -r "${self._dep.dlistSrc}" lib/boot/pkg/dlist - rm -r lib/boot/pkg/vector cp --no-preserve=mode -r "${self._dep.vectorSrc}" lib/boot/pkg/vector + cp --no-preserve=mode -r "${self._dep.primitiveSrc}" lib/boot/pkg/primitive sed -i 's/.\/pkg\/mtl/.\/pkg\/mtl\n - .\/pkg\/ghcjs-base\n - .\/pkg\/dlist\n - .\/pkg\/primitive\n - .\/pkg\/vector/' lib/boot/boot.yaml cat lib/boot/boot.yaml ) diff --git a/haskell-overlays/ghcjs-fast-weak/fast-weak.patch b/haskell-overlays/ghcjs-fast-weak/fast-weak.patch index bccc057d0..68070e600 100644 --- a/haskell-overlays/ghcjs-fast-weak/fast-weak.patch +++ b/haskell-overlays/ghcjs-fast-weak/fast-weak.patch @@ -1,11 +1,11 @@ diff --git a/lib/boot/shims/src/gc.js b/lib/boot/shims/src/gc.js -index 384cd77..d21757a 100644 +index 76321b2..a2cf416 100644 --- a/lib/boot/shims/src/gc.js +++ b/lib/boot/shims/src/gc.js -@@ -435,6 +435,49 @@ function h$follow(obj, sp) { - TRACE_GC("adding static marks"); - for(var i=0;i do { t <- get bh; return (GenericDM t) } --} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs -index 9d305efd09..95a7122a57 100644 +index 5f217a6a8f..539132653e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -916,8 +916,6 @@ data DynFlags = DynFlags { @@ -5546,17 +5546,3 @@ index 7a7c40ecfc..a80880f4e5 100644 equalKeysUFM :: UniqFM a -> UniqFM b -> Bool equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 -diff --git a/libraries/process b/libraries/process -index 36a3ad577e..7a2dfa0b48 160000 ---- a/libraries/process -+++ b/libraries/process -@@ -1 +1 @@ --Subproject commit 36a3ad577e31e8c3336c7464b252fc2c9b01a20c -+Subproject commit 7a2dfa0b48bbb48a22174cb4c2281d4000191cb0 -diff --git a/libraries/transformers b/libraries/transformers -index 80557845cd..def8c55d0c 160000 ---- a/libraries/transformers -+++ b/libraries/transformers -@@ -1 +1 @@ --Subproject commit 80557845cdc0e72bc05cec19cf7a1bf5495e9e69 -+Subproject commit def8c55d0c47c1c40de985d83f052f3659b40cfd From 73e763c5f9da6570b0c97f4d20109cbc44ff3c7b Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 8 Jul 2019 18:10:07 -0400 Subject: [PATCH 12/55] Fix ghcjs primitive override; Add several gi-* pkgconf and library deps --- haskell-overlays/ghcjs-8.6-text-jsstring.nix | 10 +++- haskell-overlays/hie/default.nix | 5 +- haskell-overlays/untriaged.nix | 54 ++++++++++++++------ 3 files changed, 48 insertions(+), 21 deletions(-) diff --git a/haskell-overlays/ghcjs-8.6-text-jsstring.nix b/haskell-overlays/ghcjs-8.6-text-jsstring.nix index 9ba1ce1e5..946fe79fb 100644 --- a/haskell-overlays/ghcjs-8.6-text-jsstring.nix +++ b/haskell-overlays/ghcjs-8.6-text-jsstring.nix @@ -23,8 +23,14 @@ self: super: { }; primitiveSrc = fetchgit { url = "https://github.com/haskell/primitive.git"; - rev = " 53f72ce69a4dfde5345cf5809a8b4a1993523367"; - sha256 = "17dr8rdfaj5sscdg5xaaaj1dj96w54l53bca2jbl211sr2004z9h"; + rev = "53f72ce69a4dfde5345cf5809a8b4a1993523367"; + sha256 = "0ywmn7pc7n7qafd7478dvih8pwyq0d9mrggfd8wnb5jdk3lf5xba"; + postFetch = '' + sed -i.bak 's/\(base .*\)4\.12/\15/' $out/primitive.cabal + # substituteInPlace $out/primitive.cabal --replace 'base >= 4.5 && < 4.12' 'base >= 4.5 && < 5' + cat $out/primitive.cabal + ''; + }; }; diff --git a/haskell-overlays/hie/default.nix b/haskell-overlays/hie/default.nix index ca567c2f4..797b46e3a 100644 --- a/haskell-overlays/hie/default.nix +++ b/haskell-overlays/hie/default.nix @@ -23,9 +23,10 @@ in self: super: { ghc-mod-core = doJailbreak (self.callCabal2nix "ghc-mod-core" ghcModCoreSrc {}); ghc-project-types = doJailbreak (self.callCabal2nix "ghc-project-types" ghcProjectTypesSrc {}); hie-plugin-api = self.callCabal2nix "hie-ide-engine" (hieSrc + "/hie-plugin-api") {}; - haskell-ide-engine = dontCheck (self.callCabal2nix "haskell-ide-engine" hieSrc {}); + haskell-ide-engine = dontHaddock (dontCheck (self.callCabal2nix "haskell-ide-engine" hieSrc {})); HaRe = dontHaddock (dontCheck (doJailbreak (self.callCabal2nix "HaRe" HaReSrc {}))); - hlint = doJailbreak super.hlint; haskell-lsp = self.callHackage "haskell-lsp" "0.15.0.0" {}; + haskell-lsp-types = self.callHackage "haskell-lsp-types" "0.15.0.0" {}; rope-utf16-splay = self.callHackage "rope-utf16-splay" "0.3.1.0" {}; + unix-time = self.callHackage "unix-time" "0.4.7" {}; } diff --git a/haskell-overlays/untriaged.nix b/haskell-overlays/untriaged.nix index 758e40953..fd03aa2f9 100644 --- a/haskell-overlays/untriaged.nix +++ b/haskell-overlays/untriaged.nix @@ -3,10 +3,24 @@ , enableLibraryProfiling , nixpkgs }: - with haskellLib; +let addGIDeps = p: extraBuildInputs: girSearchPathPackages: p.overrideAttrs (drv: { + # cabal2nix puts these deps in libraryPkgconfigDepends but that doesn't seem to suffice. + buildInputs = with nixpkgs; drv.buildInputs or [] ++ [ pkgconfig gobjectIntrospection ] ++ extraBuildInputs; + libraryPkgconfigDepends = drv.libraryPkgconfigDepends or [] ++ [nixpkgs.gobject-introspection]; + # This preConfigure should have been added by cabal2nix according to this commit: https://github.com/NixOS/cabal2nix/commit/426fde8847370c32731a1db314283f5ebcbabeb7 + # though that functionality was removed in a later commit: https://github.com/NixOS/cabal2nix/commit/2d278a8a1527b278939ba478fe915aa2f87cc22e#diff-387ec31295a66a4f73b8d4b507a239a2 + # Cf. https://github.com/haskell-gi/haskell-gi/issues/36 + preConfigure = "export HASKELL_GI_GIR_SEARCH_PATH=" + + nixpkgs.lib.concatStringsSep ":" + (map (x: "${x.dev}/share/gir-1.0") ([nixpkgs.gobjectIntrospection] ++ girSearchPathPackages)); + }); +in self: super: { + + # TODO + reflex-dom-core = dontCheck super.reflex-dom-core; + jsaddle-webkit2gtk = doJailbreak super.jsaddle-webkit2gtk; -self: super: { language-nix = dontCheck super.language-nix; hasktags = dontCheck super.hasktags; http-reverse-proxy = dontCheck super.http-reverse-proxy; @@ -16,7 +30,13 @@ self: super: { async = self.callHackage "async" "2.2.1" {}; hinotify = self.callHackage "hinotify" "0.3.10" {}; fsnotify = self.callHackage "fsnotify" "0.3.0.1" {}; - hlint = doJailbreak super.hlint; + + # Update hlint and add new dependency + hlint = self.callHackage "hlint" "2.1.26" {}; + ghc-lib-parser = self.callHackage "ghc-lib-parser" "8.8.0.20190424" {}; + haskell-src-exts = super.haskell-src-exts_1_21_0; + haskell-src-exts-util = self.callHackage "haskell-src-exts-util" "0.2.5" {}; + stylish-haskell = self.callHackage "stylish-haskell" "0.9.2.2" {}; # Fixing things that are marked broken in 19.03: brittany = self.callHackage "brittany" "0.12.0.0" {}; @@ -28,21 +48,21 @@ self: super: { webkit2gtk3-javascriptcore = self.callHackage "webkit2gtk3-javascriptcore" "0.14.2.1" {}; haskell-gi = self.callHackage "haskell-gi" "0.22.6" {}; - # Overrides for haskell-gi - haskell-gi-base = (self.callHackage "haskell-gi-base" "0.22.2" {}).overrideAttrs (drv: { - # cabal2nix puts these deps in libraryPkgconfigDepends but that doesn't seem to suffice. - buildInputs = drv.buildInputs or [] ++ [ nixpkgs.pkgconfig nixpkgs.glib ]; - }); - # Required by haskell-gi - gi-cairo = (self.callHackage "gi-cairo" "1.0.19" {}).overrideAttrs (drv: { - # cabal2nix puts these deps in libraryPkgconfigDepends but that doesn't seem to suffice. - buildInputs = drv.buildInputs or [] ++ [ nixpkgs.pkgconfig nixpkgs.cairo nixpkgs.glib ]; - }); - - # TODO https://github.com/NixOS/cabal2nix/commit/426fde8847370c32731a1db314283f5ebcbabeb7 + # Overrides for gi-* family of libraries + haskell-gi-base = addGIDeps (self.callHackage "haskell-gi-base" "0.22.2" {}) [nixpkgs.glib] []; + gi-glib = addGIDeps (self.callHackage "gi-glib" "2.0.19" {}) [] []; + gi-cairo = addGIDeps (self.callHackage "gi-cairo" "1.0.19" {}) [nixpkgs.cairo] []; + gi-gobject = addGIDeps (self.callHackage "gi-gobject" "2.0.21" {}) [] []; + gi-pango = addGIDeps (self.callHackage "gi-pango" "1.0.21" {}) [nixpkgs.pango] []; + gi-gio = addGIDeps (self.callHackage "gi-gio" "2.0.24" {}) [] []; + gi-atk = addGIDeps (self.callHackage "gi-atk" "2.0.20" {}) [] []; + gi-javascriptcore = addGIDeps (self.callHackage "gi-javascriptcore" "4.0.20" {}) [] []; + gi-gdkpixbuf = addGIDeps (self.callHackage "gi-gdkpixbuf" "2.0.22" {}) [nixpkgs.gdk_pixbuf nixpkgs.gtk3] [nixpkgs.gtk3]; + gi-gdk = addGIDeps (self.callHackage "gi-gdk" "3.0.21" {}) [nixpkgs.gdk_pixbuf nixpkgs.pango nixpkgs.gtk3] [nixpkgs.gtk3]; + gi-soup = addGIDeps (self.callHackage "gi-soup" "2.4.21" {}) [nixpkgs.gdk_pixbuf] [nixpkgs.libsoup]; + gi-gtk = addGIDeps (self.callHackage "gi-gtk" "3.0.31" {}) [nixpkgs.gdk_pixbuf nixpkgs.gtk3] [nixpkgs.gtk3 nixpkgs.atk nixpkgs.pango]; + gi-webkit2 = addGIDeps (self.callHackage "gi-webkit2" "4.0.24" {}) [] [nixpkgs.webkitgtk]; - # gi-javascriptcore = self.callHackage "gi-javascriptcore" "4.0.20" {}; - # gi-glib = self.callHackage "gi-glib" "2.0.19" {}; # Required by butcher deque = self.callHackage "deque" "0.4.2.3" {}; strict-list = self.callHackage "strict-list" "0.1.4" {}; From 07c8620c8225ad2bfa566da5ca36574fc2b277fe Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 8 Jul 2019 20:10:44 -0400 Subject: [PATCH 13/55] Update release.nix to ghc 8.6 --- release.nix | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/release.nix b/release.nix index 11b925b9a..5fd3080cb 100644 --- a/release.nix +++ b/release.nix @@ -42,7 +42,7 @@ let # attributes in the overlays. dep = {} - // reflex-platform.ghcjs8_4._dep + // reflex-platform.ghcjs8_6._dep // (lib.optionalAttrs reflex-platform.androidSupport reflex-platform.ghcAndroidAarch64._dep) // benchmark.dep ; @@ -51,18 +51,18 @@ let tryReflexShell = reflex-platform.tryReflexShell; ghcjs.reflexTodomvc = jsexeHydra reflex-platform.ghcjs.reflex-todomvc; # Doesn't currently build. Removing from CI until fixed. - ghcjs8_4.reflexTodomvc = jsexeHydra reflex-platform.ghcjs8_4.reflex-todomvc; + ghcjs8_6.reflexTodomvc = jsexeHydra reflex-platform.ghcjs8_6.reflex-todomvc; ghc.ReflexTodomvc = reflex-platform.ghc.reflex-todomvc; - ghc8_4.reflexTodomvc = reflex-platform.ghc8_4.reflex-todomvc; + ghc8_6.reflexTodomvc = reflex-platform.ghc8_6.reflex-todomvc; profiled = { - ghc8_4.reflexTodomvc = reflex-platform-profiled.ghc8_4.reflex-todomvc; + ghc8_6.reflexTodomvc = reflex-platform-profiled.ghc8_6.reflex-todomvc; } // lib.optionalAttrs (reflex-platform.androidSupport) { inherit (reflex-platform-profiled) androidReflexTodomvc; - inherit (reflex-platform-profiled) androidReflexTodomvc-8_4; + inherit (reflex-platform-profiled) androidReflexTodomvc-8_6; a = reflex-platform-profiled.ghcAndroidAarch64.a; } // lib.optionalAttrs (reflex-platform.iosSupport) { inherit (reflex-platform-profiled) iosReflexTodomvc; - inherit (reflex-platform-profiled) iosReflexTodomvc-8_4; + inherit (reflex-platform-profiled) iosReflexTodomvc-8_6; a = reflex-platform-profiled.ghcIosAarch64.a; }; skeleton-test-ghc = skeleton-test.ghc; @@ -73,12 +73,12 @@ let otherDeps; } // lib.optionalAttrs (reflex-platform.androidSupport) { inherit (reflex-platform) androidReflexTodomvc; - inherit (reflex-platform) androidReflexTodomvc-8_4; + inherit (reflex-platform) androidReflexTodomvc-8_6; a = reflex-platform.ghcAndroidAarch64.a; skeleton-test-project-android = skeleton-test.project.android; } // lib.optionalAttrs (reflex-platform.iosSupport) { inherit (reflex-platform) iosReflexTodomvc; - inherit (reflex-platform) iosReflexTodomvc-8_4; + inherit (reflex-platform) iosReflexTodomvc-8_6; a = reflex-platform.ghcIosAarch64.a; skeleton-test-project-ios = skeleton-test.project.ios; } // drvListToAttrs otherDeps From da3a3e280f54ffb7db259daf558c0a552014139e Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 9 Jul 2019 00:57:45 -0400 Subject: [PATCH 14/55] Update text-jsstring patch --- haskell-overlays/ghcjs.nix | 3 +++ haskell-overlays/text-jsstring/aeson.patch | 29 +++++++++++----------- haskell-overlays/text-jsstring/default.nix | 18 ++++---------- haskell-overlays/untriaged.nix | 1 + 4 files changed, 24 insertions(+), 27 deletions(-) diff --git a/haskell-overlays/ghcjs.nix b/haskell-overlays/ghcjs.nix index 9798babf4..79e2dc7da 100644 --- a/haskell-overlays/ghcjs.nix +++ b/haskell-overlays/ghcjs.nix @@ -39,6 +39,9 @@ self: super: { semigroupoids = disableCabalFlag super.semigroupoids "doctests"; these = dontCheck super.these; + # These tests are not expected to support ghcjs + QuickCheck = dontCheck super.QuickCheck; + # These tests never complete tasty-quickcheck = dontCheck super.tasty-quickcheck; diff --git a/haskell-overlays/text-jsstring/aeson.patch b/haskell-overlays/text-jsstring/aeson.patch index a13c3dc33..02e2b4d71 100644 --- a/haskell-overlays/text-jsstring/aeson.patch +++ b/haskell-overlays/text-jsstring/aeson.patch @@ -1,8 +1,8 @@ diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs -index 45e54b1..4c2d36b 100644 +index abe5afc..0e058c1 100644 --- a/Data/Aeson/Types/Internal.hs +++ b/Data/Aeson/Types/Internal.hs -@@ -74,6 +74,19 @@ module Data.Aeson.Types.Internal +@@ -75,6 +75,20 @@ module Data.Aeson.Types.Internal , DotNetTime(..) ) where @@ -19,10 +19,11 @@ index 45e54b1..4c2d36b 100644 +import qualified JavaScript.Object.Internal as OI +#endif + - import Prelude () ++ import Prelude.Compat -@@ -686,3 +699,40 @@ camelTo2 c = map toLower . go2 . go1 + import Control.Applicative (Alternative(..)) +@@ -687,3 +701,40 @@ camelTo2 c = map toLower . go2 . go1 go2 "" = "" go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs go2 (x:xs) = x : go2 xs @@ -64,15 +65,15 @@ index 45e54b1..4c2d36b 100644 + {-# INLINE toJSVal #-} +#endif diff --git a/aeson.cabal b/aeson.cabal -index 3d33078..80b3308 100644 +index 6193894..3e3618c 100644 --- a/aeson.cabal +++ b/aeson.cabal -@@ -163,6 +163,8 @@ library - ghc-options: -O2 - - include-dirs: include -+ if impl(ghcjs) -+ build-depends: ghcjs-base, transformers - if impl(ghcjs) || !flag(cffi) - hs-source-dirs: pure - other-modules: Data.Aeson.Parser.UnescapePure +@@ -169,6 +169,8 @@ library + ghc-options: -O2 + + include-dirs: include ++ if impl(ghcjs) ++ build-depends: ghcjs-base, transformers + if impl(ghcjs) || !flag(cffi) + hs-source-dirs: pure + other-modules: Data.Aeson.Parser.UnescapePure diff --git a/haskell-overlays/text-jsstring/default.nix b/haskell-overlays/text-jsstring/default.nix index b46937720..cefc3a20f 100644 --- a/haskell-overlays/text-jsstring/default.nix +++ b/haskell-overlays/text-jsstring/default.nix @@ -15,28 +15,19 @@ self: super: { }); }; - # text = (doCheck (self.callCabal2nix "text" (fetchFromGitHub { - # owner = "obsidiansystems"; - # repo = "text"; - # rev = "50076be0262203f0d2afdd0b190a341878a08e21"; - # sha256 = "1vy7a81b1vcbfhv7l3m7p4hx365ss13mzbzkjn9751bn4n7x2ydd"; - # }) {})).overrideScope (self: super: { - # text = null; - # QuickCheck = haskellLib.addBuildDepend (self.callHackage "QuickCheck" "2.9.2" {}) self.tf-random; - # }); - # parsec = dontCheck (self.callHackage "parsec" "3.1.13.0" {}); jsaddle = overrideCabal super.jsaddle (drv: { buildDepends = (drv.buildDepends or []) ++ [ self.ghcjs-base self.ghcjs-prim ]; }); - attoparsec = self.callCabal2nix "attoparsec" (fetchFromGitHub { + # TODO remove dontCheck from attoparsec - not sure why it semeingly hangs + attoparsec = dontCheck (doJailbreak (self.callCabal2nix "attoparsec" (fetchFromGitHub { owner = "obsidiansystems"; repo = "attoparsec"; rev = "5569fbd47ae235a800653134a06bf51186c91f8f"; sha256 = "0qgr9xcmwzbxxm84l9api7bib6bspmkii1d7dlg8bcgk9icqwbcw"; - }) {}; + }) {})); buffer-builder = overrideCabal super.buffer-builder (drv: { doCheck = false; src = fetchFromGitHub { @@ -75,6 +66,7 @@ self: super: { self.ghcjs-base ]; }); - aeson = appendPatch super.aeson ./aeson.patch; + # TODO Remove dontCheck. There seems to be an issue with floating point precision and with unescape of U+d800 + aeson = dontCheck (appendPatch super.aeson ./aeson.patch); text-show = appendPatch super.text-show ./text-show.patch; } diff --git a/haskell-overlays/untriaged.nix b/haskell-overlays/untriaged.nix index fd03aa2f9..ca0e6c34e 100644 --- a/haskell-overlays/untriaged.nix +++ b/haskell-overlays/untriaged.nix @@ -19,6 +19,7 @@ in self: super: { # TODO reflex-dom-core = dontCheck super.reflex-dom-core; + reflex-dom = doJailbreak super.reflex-dom; jsaddle-webkit2gtk = doJailbreak super.jsaddle-webkit2gtk; language-nix = dontCheck super.language-nix; From 437c2d7e6b964f53d70f234dbc34fe6f56bd40e9 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 9 Jul 2019 19:30:25 -0400 Subject: [PATCH 15/55] Fix jsaddle-webkit2gtk crash See https://github.com/ghcjs/jsaddle/issues/85 --- haskell-overlays/reflex-packages/default.nix | 12 ++++++------ .../reflex-packages/dep/jsaddle/github.json | 6 +++--- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/haskell-overlays/reflex-packages/default.nix b/haskell-overlays/reflex-packages/default.nix index d710200c3..f0b7f9817 100644 --- a/haskell-overlays/reflex-packages/default.nix +++ b/haskell-overlays/reflex-packages/default.nix @@ -45,11 +45,11 @@ in ## GHCJS and JSaddle ## - jsaddle = self.callCabal2nix "jsaddle" "${jsaddleSrc}/jsaddle" {}; - jsaddle-clib = self.callCabal2nix "jsaddle-clib" "${jsaddleSrc}/jsaddle-clib" {}; - jsaddle-webkit2gtk = self.callCabal2nix "jsaddle-webkit2gtk" "${jsaddleSrc}/jsaddle-webkit2gtk" {}; - jsaddle-webkitgtk = self.callCabal2nix "jsaddle-webkitgtk" "${jsaddleSrc}/jsaddle-webkitgtk" {}; - jsaddle-wkwebview = overrideCabal (self.callCabal2nix "jsaddle-wkwebview" "${jsaddleSrc}/jsaddle-wkwebview" {}) (drv: { + jsaddle = self.callCabal2nix "jsaddle" (jsaddleSrc + /jsaddle) {}; + jsaddle-clib = self.callCabal2nix "jsaddle-clib" (jsaddleSrc + /jsaddle-clib) {}; + jsaddle-webkit2gtk = self.callCabal2nix "jsaddle-webkit2gtk" (jsaddleSrc + /jsaddle-webkit2gtk) {}; + jsaddle-webkitgtk = self.callCabal2nix "jsaddle-webkitgtk" (jsaddleSrc + /jsaddle-webkitgtk) {}; + jsaddle-wkwebview = overrideCabal (self.callCabal2nix "jsaddle-wkwebview" (jsaddleSrc + /jsaddle-wkwebview) {}) (drv: { # HACK(matthewbauer): Can’t figure out why cf-private framework is # not getting pulled in correctly. Has something # to with how headers are looked up in xcode. @@ -71,7 +71,7 @@ in # another broken test # phantomjs has issues with finding the right port # jsaddle-warp = dontCheck (addTestToolDepend (self.callCabal2nix "jsaddle-warp" "${jsaddleSrc}/jsaddle-warp" {})); - jsaddle-warp = dontCheck (self.callCabal2nix "jsaddle-warp" "${jsaddleSrc}/jsaddle-warp" {}); + jsaddle-warp = dontCheck (self.callCabal2nix "jsaddle-warp" (jsaddleSrc + /jsaddle-warp) {}); jsaddle-dom = self.callPackage self._dep.jsaddle-dom {}; inherit (ghcjsDom) ghcjs-dom-jsffi; diff --git a/haskell-overlays/reflex-packages/dep/jsaddle/github.json b/haskell-overlays/reflex-packages/dep/jsaddle/github.json index 2c5f29074..11b36e222 100644 --- a/haskell-overlays/reflex-packages/dep/jsaddle/github.json +++ b/haskell-overlays/reflex-packages/dep/jsaddle/github.json @@ -1,6 +1,6 @@ { - "owner": "ghcjs", + "owner": "obsidiansystems", "repo": "jsaddle", - "rev": "c745863b2d5b50980c64b326295ed625cfae53c1", - "sha256": "0adqz72g6pr1pcg7306by5f1vkbii6jgv8lr7q57qz7azllmg5ns" + "rev": "a74c9fcd35e4ef58c8abb40ff7d85b5d5d4686f7", + "sha256": "0yazwiz8rzf5xiqcaaiapwlp0132h97azvd9vgdy6zgr3j4snh03" } From 0924f00200ca27af5c62ba8bb1328cb822f767f0 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 9 Jul 2019 19:37:56 -0400 Subject: [PATCH 16/55] Switch back to upstream jsaddle --- haskell-overlays/reflex-packages/dep/jsaddle/github.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-overlays/reflex-packages/dep/jsaddle/github.json b/haskell-overlays/reflex-packages/dep/jsaddle/github.json index 11b36e222..8c4fc5b70 100644 --- a/haskell-overlays/reflex-packages/dep/jsaddle/github.json +++ b/haskell-overlays/reflex-packages/dep/jsaddle/github.json @@ -1,5 +1,5 @@ { - "owner": "obsidiansystems", + "owner": "ghcjs", "repo": "jsaddle", "rev": "a74c9fcd35e4ef58c8abb40ff7d85b5d5d4686f7", "sha256": "0yazwiz8rzf5xiqcaaiapwlp0132h97azvd9vgdy6zgr3j4snh03" From 39bc048588239cfd451a78446c165ef878f36bc1 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 9 Jul 2019 19:39:58 -0400 Subject: [PATCH 17/55] Update platforms in HACKING.md --- HACKING.md | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/HACKING.md b/HACKING.md index 6cd431d0d..773a2c740 100644 --- a/HACKING.md +++ b/HACKING.md @@ -31,10 +31,9 @@ Many different platform are provided for you. A partial list of possible platforms include: - ghc -- ghcHEAD -- ghc8_4 +- ghc8_6 - ghcjs -- ghcjs8_4 +- ghcjs8_6 In addition, instead of specifying the name of the platform, you can specify a path to a Nix expression file representing a Haskell From ad8f1d5542e7ba1fa77f71e945a00d3feba13551 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 9 Jul 2019 20:05:42 -0400 Subject: [PATCH 18/55] Bump jsaddle to master; Update ghcjs bootpkgs from 864 to 865 --- default.nix | 3 ++- haskell-overlays/reflex-packages/dep/jsaddle/github.json | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/default.nix b/default.nix index c9dbfe9f5..0fc2db774 100644 --- a/default.nix +++ b/default.nix @@ -83,7 +83,7 @@ let iosSupport = system == "x86_64-darwin"; "webkitgtk-2.4.11" ]; packageOverrides = pkgs: { - webkitgtk = pkgs.webkitgtk; #24x-gtk3; # TODO should this be gtk3? + webkitgtk = pkgs.webkitgtk; }; # XCode needed for native macOS app @@ -177,6 +177,7 @@ let iosSupport = system == "x86_64-darwin"; ghcjs = ghcjs8_6; ghcjs8_6 = (makeRecursivelyOverridable (nixpkgs.haskell.packages.ghcjs86.override (old: { ghc = old.ghc.override { + bootPkgs = nixpkgs.haskell.packages.ghc865; ghcjsSrc = fetchgit { url = "https://github.com/ghcjs/ghcjs.git"; rev = "05afd14691ac7170355f6ffd51a05226f394eb76"; diff --git a/haskell-overlays/reflex-packages/dep/jsaddle/github.json b/haskell-overlays/reflex-packages/dep/jsaddle/github.json index 8c4fc5b70..aacf522e1 100644 --- a/haskell-overlays/reflex-packages/dep/jsaddle/github.json +++ b/haskell-overlays/reflex-packages/dep/jsaddle/github.json @@ -1,6 +1,6 @@ { "owner": "ghcjs", "repo": "jsaddle", - "rev": "a74c9fcd35e4ef58c8abb40ff7d85b5d5d4686f7", - "sha256": "0yazwiz8rzf5xiqcaaiapwlp0132h97azvd9vgdy6zgr3j4snh03" + "rev": "f06a9c5be22fa2ad65700f26c26f4a4bf8c56549", + "sha256": "0114g9984fnzknyvfkk32mrl1zj933hyqkl5bq3qkjbnm0khq70g" } From d77291288583b2a0e17ccdb210208f24d3d745c1 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 9 Jul 2019 21:29:15 -0400 Subject: [PATCH 19/55] Rely on newer haven that builds on 865 --- haskell-overlays/untriaged.nix | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/haskell-overlays/untriaged.nix b/haskell-overlays/untriaged.nix index ca0e6c34e..15dacb396 100644 --- a/haskell-overlays/untriaged.nix +++ b/haskell-overlays/untriaged.nix @@ -22,11 +22,17 @@ in self: super: { reflex-dom = doJailbreak super.reflex-dom; jsaddle-webkit2gtk = doJailbreak super.jsaddle-webkit2gtk; + # Recently uploaded to hackage: + haven = self.callHackageDirect { + pkg = "haven"; + ver = "0.2.0.2"; + sha256 = "1hz0ngzd2gbmi45lv52465zrvsfvm6gpc42g7ms0hpa0v52if0w9"; + } {}; + language-nix = dontCheck super.language-nix; hasktags = dontCheck super.hasktags; http-reverse-proxy = dontCheck super.http-reverse-proxy; xmlhtml = dontCheck super.xmlhtml; - haven = doJailbreak super.haven; mmorph = doJailbreak super.mmorph; async = self.callHackage "async" "2.2.1" {}; hinotify = self.callHackage "hinotify" "0.3.10" {}; From 56c950e07394f6fb03122e2330b3014dff5c2b70 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 9 Jul 2019 22:47:55 -0400 Subject: [PATCH 20/55] Remove several unused overrides --- haskell-overlays/any-8.4.nix | 23 ---------- haskell-overlays/any-8.6.nix | 38 ++++++++-------- haskell-overlays/any-8.nix | 12 ++--- haskell-overlays/ghcjs-8.4-text-jsstring.nix | 48 -------------------- haskell-overlays/ghcjs.nix | 26 +++++------ 5 files changed, 38 insertions(+), 109 deletions(-) delete mode 100644 haskell-overlays/any-8.4.nix delete mode 100644 haskell-overlays/ghcjs-8.4-text-jsstring.nix diff --git a/haskell-overlays/any-8.4.nix b/haskell-overlays/any-8.4.nix deleted file mode 100644 index 0e59d7009..000000000 --- a/haskell-overlays/any-8.4.nix +++ /dev/null @@ -1,23 +0,0 @@ -{ pkgs, haskellLib, fetchFromGitHub }: -with haskellLib; -self: super: { - cabal-macosx = dontCheck super.cabal-macosx; - enclosed-exceptions = dontCheck super.enclosed-exceptions; # see https://github.com/jcristovao/enclosed-exceptions/issues/12 - haddock-library-ghcjs = dontCheck super.haddock-library-ghcjs; - haddock-api-ghcjs = dontCheck super.haddock-api-ghcjs; - algebraic-graphs = doJailbreak super.algebraic-graphs; - - # Broken in master - # PR is https://github.com/vincenthz/hit/pull/37 - hit = dontCheck (self.callCabal2nix "hit" (fetchFromGitHub { - owner = "vincenthz"; - repo = "hit"; - rev = "e93b01a295d5b4ca51b32b928b37ae040366e317"; - sha256 = "1vfxqc3kffls11dzxq0gk62ky8rjm455cnh0nv31x43g3pmhh7sp"; - }) {}); - - # doctests: doctests: could not execute: markdown-unlit - # Test suite doctests: FAIL - rank2classes = dontCheck super.rank2classes; - -} diff --git a/haskell-overlays/any-8.6.nix b/haskell-overlays/any-8.6.nix index 97e6cfc42..cff6339d6 100644 --- a/haskell-overlays/any-8.6.nix +++ b/haskell-overlays/any-8.6.nix @@ -9,26 +9,26 @@ self: super: { # Broken in master # PR is https://github.com/vincenthz/hit/pull/37 - hit = dontCheck (self.callCabal2nix "hit" (fetchFromGitHub { - owner = "vincenthz"; - repo = "hit"; - rev = "e93b01a295d5b4ca51b32b928b37ae040366e317"; - sha256 = "1vfxqc3kffls11dzxq0gk62ky8rjm455cnh0nv31x43g3pmhh7sp"; - }) {}); + # hit = dontCheck (self.callCabal2nix "hit" (fetchFromGitHub { + # owner = "vincenthz"; + # repo = "hit"; + # rev = "e93b01a295d5b4ca51b32b928b37ae040366e317"; + # sha256 = "1vfxqc3kffls11dzxq0gk62ky8rjm455cnh0nv31x43g3pmhh7sp"; + # }) {}); # doctests: doctests: could not execute: markdown-unlit # Test suite doctests: FAIL - rank2classes = dontCheck super.rank2classes; - entropy = self.callHackage "entropy" "0.4.1.4" {}; - cryptohash-sha256 = doJailbreak super.cryptohash-sha256; - czipwith = doJailbreak super.czipwith; - haddock-library = doJailbreak (self.callHackage "haddock-library" "1.7.0" {}); - basement = self.callHackage "basement" "0.0.10" {}; - keycode = doJailbreak (self.callCabal2nix "hit" (fetchFromGitHub { - owner = "RyanGlScott"; - repo = "keycode"; - rev = "beecb745750de7b0b470ae5af9f2fe506f54dd31"; - sha256 = "03zm21f134cpg13fhnm541hawz649ynwmcwwmaz358gdnd2fypgv"; - }) {}); - polyparse = self.callHackage "polyparse" "1.12.1" {}; + # rank2classes = dontCheck super.rank2classes; + # entropy = self.callHackage "entropy" "0.4.1.4" {}; + # cryptohash-sha256 = doJailbreak super.cryptohash-sha256; + # czipwith = doJailbreak super.czipwith; + # haddock-library = doJailbreak (self.callHackage "haddock-library" "1.7.0" {}); + # basement = self.callHackage "basement" "0.0.10" {}; + # keycode = doJailbreak (self.callCabal2nix "hit" (fetchFromGitHub { + # owner = "RyanGlScott"; + # repo = "keycode"; + # rev = "beecb745750de7b0b470ae5af9f2fe506f54dd31"; + # sha256 = "03zm21f134cpg13fhnm541hawz649ynwmcwwmaz358gdnd2fypgv"; + # }) {}); + # polyparse = self.callHackage "polyparse" "1.12.1" {}; } diff --git a/haskell-overlays/any-8.nix b/haskell-overlays/any-8.nix index 22246d4a0..04e1a2679 100644 --- a/haskell-overlays/any-8.nix +++ b/haskell-overlays/any-8.nix @@ -2,10 +2,10 @@ with haskellLib; self: super: lib.optionalAttrs (lib.versionOlder (getGhcVersion super.ghc) "8.6.0") { # TODO document why - concurrent-output = haskellLib.doJailbreak super.concurrent-output; - # Newer versions cause some sort of issues with multiple `(<>)` definitions. - # Seems to be that semigroup-monoid stuff is being CPP'd incorrectly. - base-compat= self.callHackage "base-compat" "0.9.3" {}; - haddock-library = doJailbreak (self.callHackage "haddock-library" "1.7.0" {}); - entropy = self.callHackage "entropy" "0.4.1.4" {}; + # concurrent-output = haskellLib.doJailbreak super.concurrent-output; + # # Newer versions cause some sort of issues with multiple `(<>)` definitions. + # # Seems to be that semigroup-monoid stuff is being CPP'd incorrectly. + # base-compat= self.callHackage "base-compat" "0.9.3" {}; + # haddock-library = doJailbreak (self.callHackage "haddock-library" "1.7.0" {}); + # entropy = self.callHackage "entropy" "0.4.1.4" {}; } diff --git a/haskell-overlays/ghcjs-8.4-text-jsstring.nix b/haskell-overlays/ghcjs-8.4-text-jsstring.nix deleted file mode 100644 index e43556f17..000000000 --- a/haskell-overlays/ghcjs-8.4-text-jsstring.nix +++ /dev/null @@ -1,48 +0,0 @@ -{ lib, fetchgit }: - -self: super: { - _dep = super._dep or {} // { - - textSrc = fetchgit { - url = "https://github.com/obsidiansystems/text.git"; - rev = "50076be0262203f0d2afdd0b190a341878a08e21"; - sha256 = "1vy7a81b1vcbfhv7l3m7p4hx365ss13mzbzkjn9751bn4n7x2ydd"; - }; - dlistSrc = fetchgit { - url = "https://github.com/spl/dlist.git"; - rev = "03d91a3000cba49bd2c8588cf1b0d71e229ad3b0"; #v0.8.0.4 - sha256 = "0asvz1a2rp174r3vvgs1qaidxbdxly4mnlra33dipd0gxrrk15sq"; - }; - vectorSrc = fetchgit { - url = "https://github.com/haskell/vector.git"; - rev = "1d208ee9e3a252941ebd112e14e8cd5a982ac2bb"; #v0.12.0.1 - sha256 = "18qm1c2zqr8h150917djfc0xk62hv99b1clxfs9a79aavrsqi5hs"; - postFetch = '' - substituteInPlace $out/vector.cabal --replace 'base >= 4.5 && < 4.10' 'base >= 4.5 && < 5' - ''; - }; - }; - - ghc = super.ghc.overrideAttrs (drv: { - postUnpack = '' - set -x - ( - echo $sourceRoot - cd $sourceRoot - rm -r lib/boot/pkg/text - cp --no-preserve=mode -r "${self._dep.textSrc}" lib/boot/pkg/text - cp --no-preserve=mode -r "${self._dep.ghcjsBaseTextJSStringSrc}" lib/boot/pkg/ghcjs-base - cp --no-preserve=mode -r "${self._dep.dlistSrc}" lib/boot/pkg/dlist - rm -r lib/boot/pkg/vector - cp --no-preserve=mode -r "${self._dep.vectorSrc}" lib/boot/pkg/vector - sed -i 's/.\/pkg\/mtl/.\/pkg\/mtl\n - .\/pkg\/ghcjs-base\n - .\/pkg\/dlist\n - .\/pkg\/primitive\n - .\/pkg\/vector/' lib/boot/boot.yaml - cat lib/boot/boot.yaml - ) - ''; - }); - - dlist = null; - ghcjs-base = null; - primitive = null; - vector = null; -} diff --git a/haskell-overlays/ghcjs.nix b/haskell-overlays/ghcjs.nix index 79e2dc7da..6ae1c017c 100644 --- a/haskell-overlays/ghcjs.nix +++ b/haskell-overlays/ghcjs.nix @@ -49,18 +49,18 @@ self: super: { megaparsec = dontCheck super.megaparsec; # Need newer version of colour for some reason. - colour = dontCheck (super.colour.overrideAttrs (drv: { - src = nixpkgs.buildPackages.fetchurl { - url = "http://hackage.haskell.org/package/colour-2.3.4/colour-2.3.4.tar.gz"; - sha256 = "1sy51nz096sv91nxqk6yk7b92b5a40axv9183xakvki2nc09yhqg"; - }; - })); + # colour = dontCheck (super.colour.overrideAttrs (drv: { + # src = nixpkgs.buildPackages.fetchurl { + # url = "http://hackage.haskell.org/package/colour-2.3.4/colour-2.3.4.tar.gz"; + # sha256 = "1sy51nz096sv91nxqk6yk7b92b5a40axv9183xakvki2nc09yhqg"; + # }; + # })); stringsearch = doJailbreak super.stringsearch; - entropy = super.entropy.overrideAttrs (drv: { - src = nixpkgs.buildPackages.fetchurl { - url = "http://hackage.haskell.org/package/entropy-0.4.1.4/entropy-0.4.1.4.tar.gz"; - sha256 = "1fgf47l9klwn1xssbcbq6by651vikd8hlfxhiwd5bqzxr1jnlgrf"; - }; - version = "0.4.1.4"; - }); + # entropy = super.entropy.overrideAttrs (drv: { + # src = nixpkgs.buildPackages.fetchurl { + # url = "http://hackage.haskell.org/package/entropy-0.4.1.4/entropy-0.4.1.4.tar.gz"; + # sha256 = "1fgf47l9klwn1xssbcbq6by651vikd8hlfxhiwd5bqzxr1jnlgrf"; + # }; + # version = "0.4.1.4"; + # }); } From 5e9517a3138a03223b45b826c7380d4b369a14d0 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 9 Jul 2019 23:37:43 -0400 Subject: [PATCH 21/55] Remove unnecessary haddock patch; Remove more unnecessary overrides --- a/A.hs | 10 - a/a.cabal | 9 - default.nix | 2 +- haskell-overlays/haddock.patch | 10 - haskell-overlays/load-splices.nix | 4 - haskell-overlays/save-splices.nix | 4 - haskell-overlays/untriaged.nix | 23 - splices-load-save.patch | 8956 ++++++++++++++--------------- 8 files changed, 4479 insertions(+), 4539 deletions(-) delete mode 100644 a/A.hs delete mode 100644 a/a.cabal delete mode 100644 haskell-overlays/haddock.patch diff --git a/a/A.hs b/a/A.hs deleted file mode 100644 index 4d39f6866..000000000 --- a/a/A.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} -module A where - -import GHC.Generics -import qualified Rank2.TH - -data A f = A { _a :: f () } deriving Generic -$(Rank2.TH.deriveAll ''A) - diff --git a/a/a.cabal b/a/a.cabal deleted file mode 100644 index 10c650633..000000000 --- a/a/a.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: a -version: 0.1 -cabal-version: >= 1.2 -build-type: Simple - -library - build-depends: base, rank2classes - exposed-modules: A - ghc-options: -Wall diff --git a/default.nix b/default.nix index 0fc2db774..82fb08736 100644 --- a/default.nix +++ b/default.nix @@ -21,7 +21,7 @@ let iosSupport = system == "x86_64-darwin"; ghcSplices-8_6 = super.haskell.compiler.ghc865.overrideAttrs (drv: { enableParallelBuilding = false; patches = (drv.patches or []) - ++ [ ./splices-load-save.patch ./haddock.patch ]; + ++ [ ./splices-load-save.patch ]; }); }; packages = super.haskell.packages // { diff --git a/haskell-overlays/haddock.patch b/haskell-overlays/haddock.patch deleted file mode 100644 index ce79187d1..000000000 --- a/haskell-overlays/haddock.patch +++ /dev/null @@ -1,10 +0,0 @@ -diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs -index e002b602..11ea8ab7 100644 ---- a/haddock-api/src/Haddock/Backends/Hoogle.hs -+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs -@@ -1,4 +1,4 @@ --{-# LANGUAGE FlexibleContexts #-} -+{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - ----------------------------------------------------------------------------- - -- | - -- Module : Haddock.Backends.Hoogle diff --git a/haskell-overlays/load-splices.nix b/haskell-overlays/load-splices.nix index 379f20eba..3967302cb 100644 --- a/haskell-overlays/load-splices.nix +++ b/haskell-overlays/load-splices.nix @@ -41,8 +41,4 @@ in { ''; }); - haddock = super.haddock.overrideAttrs (drv: { - patches = (drv.patches or []) ++ [ ./haddock.patch ]; - }); - } diff --git a/haskell-overlays/save-splices.nix b/haskell-overlays/save-splices.nix index a9c329f24..7ebb247c0 100644 --- a/haskell-overlays/save-splices.nix +++ b/haskell-overlays/save-splices.nix @@ -21,10 +21,6 @@ self: super: { // { inherit SPLICE_DIR; }) else super.mkDerivation attrs; - haddock = super.haddock.overrideAttrs (drv: { - patches = (drv.patches or []) ++ [ ./haddock.patch ]; - }); - vector-th-unbox = haskellLib.dontCheck super.vector-th-unbox; lens = haskellLib.dontCheck super.lens; diff --git a/haskell-overlays/untriaged.nix b/haskell-overlays/untriaged.nix index 15dacb396..833d300c6 100644 --- a/haskell-overlays/untriaged.nix +++ b/haskell-overlays/untriaged.nix @@ -29,15 +29,6 @@ in self: super: { sha256 = "1hz0ngzd2gbmi45lv52465zrvsfvm6gpc42g7ms0hpa0v52if0w9"; } {}; - language-nix = dontCheck super.language-nix; - hasktags = dontCheck super.hasktags; - http-reverse-proxy = dontCheck super.http-reverse-proxy; - xmlhtml = dontCheck super.xmlhtml; - mmorph = doJailbreak super.mmorph; - async = self.callHackage "async" "2.2.1" {}; - hinotify = self.callHackage "hinotify" "0.3.10" {}; - fsnotify = self.callHackage "fsnotify" "0.3.0.1" {}; - # Update hlint and add new dependency hlint = self.callHackage "hlint" "2.1.26" {}; ghc-lib-parser = self.callHackage "ghc-lib-parser" "8.8.0.20190424" {}; @@ -81,26 +72,12 @@ in self: super: { ######################################################################## # Packages not in hackage ######################################################################## - servant-reflex = self.callCabal2nix "servant-reflex" (fetchFromGitHub { - owner = "imalsogreg"; - repo = "servant-reflex"; - rev = "5cd3098880741e6ade52ef4477422d9c776e5478"; - sha256 = "18yjfamx3k9xd8pz251jsmvhlj4riw0brk2fyvjq00r87cx67a6f"; - }) {}; concat = dontHaddock (dontCheck (self.callCabal2nix "concat" (fetchFromGitHub { owner = "conal"; repo = "concat"; rev = "24a4b8ccc883605ea2b0b4295460be2f8a245154"; sha256 = "0mcwqzjk3f8qymmkbpa80l6mh6aa4vcyxky3gpwbnx19g721mj35"; }) {})); - direct-sqlite = self.callCabal2nix "direct-sqlite" (fetchFromGitHub { - owner = "IreneKnapp"; - repo = "direct-sqlite"; - rev = "8e3da41c46b5de19942cc7bf421c3deb5117ba7a"; - sha256 = "0ffk5j1db2y1drn0przh4jw9gc3vygwd987wl1g1m3dw7ry4dxy6"; - }) {}; - - a = self.callCabal2nix "a" (../a) {}; mkDerivation = expr: super.mkDerivation (expr // { inherit enableLibraryProfiling; diff --git a/splices-load-save.patch b/splices-load-save.patch index 32ffe38e7..a3078852f 100644 --- a/splices-load-save.patch +++ b/splices-load-save.patch @@ -1,327 +1,327 @@ diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs -index efcb26d047..3dd7e14b12 100644 +index 3dd7e14b12..efcb26d047 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs -@@ -811,7 +811,6 @@ instance Binary SrcUnpackedness where +@@ -811,6 +811,7 @@ instance Binary SrcUnpackedness where 1 -> return SrcUnpack _ -> return NoSrcUnpack -- ++ -- | Compare strictness annotations eqHsBang :: HsImplBang -> HsImplBang -> Bool eqHsBang HsLazy HsLazy = True diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs -index aed09b6a42..f6febaf4dc 100644 +index f6febaf4dc..aed09b6a42 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -18,7 +18,7 @@ module IdInfo ( RecSelParent(..), -- * The IdInfo type -- IdInfo, -+ IdInfo, -- Abstract +- IdInfo, -- Abstract ++ IdInfo, vanillaIdInfo, noCafIdInfo, -- ** The OneShotInfo type diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot -index 229ff9abb0..cacfe6af2e 100644 +index cacfe6af2e..229ff9abb0 100644 --- a/compiler/basicTypes/IdInfo.hs-boot +++ b/compiler/basicTypes/IdInfo.hs-boot -@@ -1,7 +1,6 @@ +@@ -1,6 +1,7 @@ module IdInfo where import GhcPrelude import Outputable -- ++ data IdInfo data IdDetails -@@ -9,3 +8,4 @@ vanillaIdInfo :: IdInfo +@@ -8,4 +9,3 @@ vanillaIdInfo :: IdInfo coVarDetails :: IdDetails isCoVarDetails :: IdDetails -> Bool pprIdDetails :: IdDetails -> SDoc -+ +- diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs -index fa54967e8a..1af53fb3dc 100644 +index 1af53fb3dc..fa54967e8a 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs -@@ -394,10 +394,6 @@ instance Uniquable OccName where +@@ -394,6 +394,10 @@ instance Uniquable OccName where newtype OccEnv a = A (UniqFM a) deriving Data --instance Binary a => Binary (OccEnv a) where -- put_ bh (A a) = put_ bh a -- get bh = A <$> get bh -- ++instance Binary a => Binary (OccEnv a) where ++ put_ bh (A a) = put_ bh a ++ get bh = A <$> get bh ++ emptyOccEnv :: OccEnv a unitOccEnv :: OccName -> a -> OccEnv a extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs -index 76b93e4224..2e838d6b82 100644 +index 2e838d6b82..76b93e4224 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs -@@ -32,7 +32,6 @@ import Outputable +@@ -32,6 +32,7 @@ import Outputable import Unique import Util import BasicTypes --import Binary ++import Binary import Var import FieldLabel -@@ -329,10 +328,6 @@ instance Data.Data PatSyn where +@@ -328,6 +329,10 @@ instance Data.Data PatSyn where gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "PatSyn" --instance Binary PatSyn where -- put = error "Binary PatSyn: not implemented yet" -- get = error "Binary PatSyn: not implemented yet" -- ++instance Binary PatSyn where ++ put = error "Binary PatSyn: not implemented yet" ++ get = error "Binary PatSyn: not implemented yet" ++ {- ************************************************************************ * * diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs -index a4f1a68e65..610233ed9a 100644 +index 610233ed9a..a4f1a68e65 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs -@@ -75,7 +75,6 @@ import GhcPrelude +@@ -75,6 +75,7 @@ import GhcPrelude import Module import Name import Avail --import Binary ++import Binary import NameSet import Maybes import SrcLoc -@@ -467,10 +466,6 @@ data GlobalRdrElt +@@ -466,6 +467,10 @@ data GlobalRdrElt -- INVARIANT: either gre_lcl = True or gre_imp is non-empty -- See Note [GlobalRdrElt provenance] --instance Binary GlobalRdrElt where -- put_ bh (GRE a b c d) = put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- get bh = GRE <$> get bh <*> get bh <*> get bh <*> get bh -- ++instance Binary GlobalRdrElt where ++ put_ bh (GRE a b c d) = put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ get bh = GRE <$> get bh <*> get bh <*> get bh <*> get bh ++ -- | The children of a Name are the things that are abbreviated by the ".." -- notation in export lists. See Note [Parents] data Parent = NoParent -@@ -479,18 +474,6 @@ data Parent = NoParent +@@ -474,6 +479,18 @@ data Parent = NoParent -- ^ See Note [Parents for record fields] deriving (Eq, Data) --instance Binary Parent where -- put_ bh p = case p of -- NoParent -> putByte bh 0 -- ParentIs p -> putByte bh 1 >> put_ bh p -- FldParent a b -> putByte bh 2 >> put_ bh a >> put_ bh b -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure NoParent -- 1 -> ParentIs <$> get bh -- _ -> FldParent <$> get bh <*> get bh -- ++instance Binary Parent where ++ put_ bh p = case p of ++ NoParent -> putByte bh 0 ++ ParentIs p -> putByte bh 1 >> put_ bh p ++ FldParent a b -> putByte bh 2 >> put_ bh a >> put_ bh b ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure NoParent ++ 1 -> ParentIs <$> get bh ++ _ -> FldParent <$> get bh <*> get bh ++ instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n -@@ -1151,10 +1134,6 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, +@@ -1134,6 +1151,10 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, is_item :: ImpItemSpec } deriving( Eq, Ord, Data ) --instance Binary ImportSpec where -- put_ bh (ImpSpec a b) = put_ bh a >> put_ bh b -- get bh = ImpSpec <$> get bh <*> get bh -- ++instance Binary ImportSpec where ++ put_ bh (ImpSpec a b) = put_ bh a >> put_ bh b ++ get bh = ImpSpec <$> get bh <*> get bh ++ -- | Import Declaration Specification -- -- Describes a particular import declaration and is -@@ -1172,11 +1151,6 @@ data ImpDeclSpec +@@ -1151,6 +1172,11 @@ data ImpDeclSpec is_dloc :: SrcSpan -- ^ The location of the entire import declaration } deriving Data --instance Binary ImpDeclSpec where -- put_ bh (ImpDeclSpec a b c d) = -- put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- get bh = ImpDeclSpec <$> get bh <*> get bh <*> get bh <*> get bh -- ++instance Binary ImpDeclSpec where ++ put_ bh (ImpDeclSpec a b c d) = ++ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ get bh = ImpDeclSpec <$> get bh <*> get bh <*> get bh <*> get bh ++ -- | Import Item Specification -- -- Describes import info a particular Name -@@ -1198,16 +1172,6 @@ data ImpItemSpec +@@ -1172,6 +1198,16 @@ data ImpItemSpec -- only @T@ is named explicitly. deriving Data --instance Binary ImpItemSpec where -- put_ bh s = case s of -- ImpAll -> putByte bh 0 -- ImpSome a b -> putByte bh 1 >> put_ bh a >> put_ bh b -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure ImpAll -- _ -> ImpSome <$> get bh <*> get bh -- ++instance Binary ImpItemSpec where ++ put_ bh s = case s of ++ ImpAll -> putByte bh 0 ++ ImpSome a b -> putByte bh 1 >> put_ bh a >> put_ bh b ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure ImpAll ++ _ -> ImpSome <$> get bh <*> get bh ++ instance Eq ImpDeclSpec where p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in -index 3521bdc06c..01628dcad1 100644 +index 01628dcad1..3521bdc06c 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in -@@ -210,7 +210,6 @@ Library +@@ -210,6 +210,7 @@ Library NameSet OccName RdrName -- SeName ++ SeName NameCache SrcLoc UniqSupply -@@ -319,11 +318,6 @@ Library +@@ -318,6 +319,11 @@ Library HsDecls HsDoc HsExpr -- HsExprBin -- HsExprBin_ConversionPS2SE -- HsExprBin_ConversionSE2PS -- HsExprBin_Conversions -- HsExprBin_Instances ++ HsExprBin ++ HsExprBin_ConversionPS2SE ++ HsExprBin_ConversionSE2PS ++ HsExprBin_Conversions ++ HsExprBin_Instances HsImpExp HsLit PlaceHolder diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs -index 9c3665f025..98f503b0d9 100644 +index 98f503b0d9..9c3665f025 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs -@@ -12,7 +12,6 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. +@@ -12,6 +12,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder --{-# LANGUAGE TypeFamilies #-} ++{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} -@@ -323,12 +322,10 @@ data NPatBindTc = NPatBindTc { +@@ -322,10 +323,12 @@ data NPatBindTc = NPatBindTc { type instance XFunBind (GhcPass pL) GhcPs = NoExt type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables --type instance XFunBind (GhcPass pL) GhcSe = NoExt ++type instance XFunBind (GhcPass pL) GhcSe = NoExt type instance XPatBind GhcPs (GhcPass pR) = NoExt type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc --type instance XPatBind GhcSe (GhcPass pR) = NoExt ++type instance XPatBind GhcSe (GhcPass pR) = NoExt type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt -@@ -385,7 +382,6 @@ data PatSynBind idL idR +@@ -382,6 +385,7 @@ data PatSynBind idL idR type instance XPSB (GhcPass idL) GhcPs = NoExt type instance XPSB (GhcPass idL) GhcRn = NameSet type instance XPSB (GhcPass idL) GhcTc = NameSet --type instance XPSB (GhcPass idL) GhcSe = NoExt ++type instance XPSB (GhcPass idL) GhcSe = NoExt type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt -@@ -832,7 +828,6 @@ type instance XIPBinds GhcPs = NoExt +@@ -828,6 +832,7 @@ type instance XIPBinds GhcPs = NoExt type instance XIPBinds GhcRn = NoExt type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the -- implicit parameters --type instance XIPBinds GhcSe = NoExt ++type instance XIPBinds GhcSe = NoExt type instance XXHsIPBinds (GhcPass p) = NoExt -@@ -953,7 +948,7 @@ data Sig pass +@@ -948,7 +953,7 @@ data Sig pass -- the desired Id itself, replete with its name, type -- and IdDetails. Otherwise it's just like a type -- signature: there should be an accompanying binding -- | IdSig (XIdSig pass) (IdSigId pass) -+ | IdSig (XIdSig pass) Id +- | IdSig (XIdSig pass) Id ++ | IdSig (XIdSig pass) (IdSigId pass) -- | An ordinary fixity declaration -- -@@ -1182,9 +1177,7 @@ ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) +@@ -1177,7 +1182,9 @@ ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) --ppr_sig (IdSig _ id) = case getVarType id of -- Nothing -> ppr id -- Just t -> pprVarSig [id] (ppr t) -+ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) +-ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) ++ppr_sig (IdSig _ id) = case getVarType id of ++ Nothing -> ppr id ++ Just t -> pprVarSig [id] (ppr t) ppr_sig (FixSig _ fix_sig) = ppr fix_sig ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs -index db5510c706..f84fcfd5ec 100644 +index f84fcfd5ec..db5510c706 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs -@@ -10,7 +10,6 @@ +@@ -10,6 +10,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} --{-# LANGUAGE FlexibleInstances #-} ++{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} -- | Abstract syntax of global declarations. -@@ -578,17 +577,14 @@ type instance XFamDecl (GhcPass _) = NoExt +@@ -577,14 +578,17 @@ type instance XFamDecl (GhcPass _) = NoExt type instance XSynDecl GhcPs = NoExt type instance XSynDecl GhcRn = NameSet -- FVs type instance XSynDecl GhcTc = NameSet -- FVs --type instance XSynDecl GhcSe = NoExt ++type instance XSynDecl GhcSe = NoExt type instance XDataDecl GhcPs = NoExt type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn --type instance XDataDecl GhcSe = NoExt ++type instance XDataDecl GhcSe = NoExt type instance XClassDecl GhcPs = NoExt type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs --type instance XClassDecl GhcSe = NoExt ++type instance XClassDecl GhcSe = NoExt type instance XXTyClDecl (GhcPass _) = NoExt -@@ -699,6 +695,7 @@ hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk" +@@ -695,7 +699,6 @@ hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk" -- ~~~~~~~~~~~~~~~~~~~~~~~~ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where -+ +- ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity , tcdRhs = rhs }) -@@ -1871,7 +1868,6 @@ data DerivStrategy pass +@@ -1868,6 +1871,7 @@ data DerivStrategy pass type instance XViaStrategy GhcPs = LHsSigType GhcPs type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type --type instance XViaStrategy GhcSe = LHsSigType GhcSe ++type instance XViaStrategy GhcSe = LHsSigType GhcSe instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DerivStrategy p) where -@@ -1972,12 +1968,10 @@ data ForeignDecl pass +@@ -1968,10 +1972,12 @@ data ForeignDecl pass type instance XForeignImport GhcPs = NoExt type instance XForeignImport GhcRn = NoExt type instance XForeignImport GhcTc = Coercion --type instance XForeignImport GhcSe = NoExt ++type instance XForeignImport GhcSe = NoExt type instance XForeignExport GhcPs = NoExt type instance XForeignExport GhcRn = NoExt type instance XForeignExport GhcTc = Coercion --type instance XForeignExport GhcSe = NoExt ++type instance XForeignExport GhcSe = NoExt type instance XXForeignDecl (GhcPass _) = NoExt -@@ -2120,7 +2114,6 @@ data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS +@@ -2114,6 +2120,7 @@ data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS type instance XHsRule GhcPs = NoExt type instance XHsRule GhcRn = HsRuleRn type instance XHsRule GhcTc = HsRuleRn --type instance XHsRule GhcSe = NoExt ++type instance XHsRule GhcSe = NoExt type instance XXRuleDecl (GhcPass _) = NoExt diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs -index 72042690cd..6ca37e07ce 100644 +index 6ca37e07ce..72042690cd 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -10,7 +10,7 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} --{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -+{-# LANGUAGE DeriveFunctor #-} +-{-# LANGUAGE DeriveFunctor #-} ++{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} {-# LANGUAGE TypeFamilies #-} -- | Abstract Haskell syntax for expressions. @@ -329,4011 +329,4011 @@ index 72042690cd..6ca37e07ce 100644 -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -- | HsDo (XDo p) -- Type of the whole expression -- (HsStmtContext (DoName p)) -- The parameterisation is unimportant -- -- because in this context we never use -- -- the PatGuard or ParStmt variant -- (Located [ExprLStmt p]) -- "do":one or more stmts -+ | HsDo (XDo p) -- Type of the whole expression -+ (HsStmtContext Name) -- The parameterisation is unimportant -+ -- because in this context we never use -+ -- the PatGuard or ParStmt variant -+ (Located [ExprLStmt p]) -- "do":one or more stmts +- | HsDo (XDo p) -- Type of the whole expression +- (HsStmtContext Name) -- The parameterisation is unimportant +- -- because in this context we never use +- -- the PatGuard or ParStmt variant +- (Located [ExprLStmt p]) -- "do":one or more stmts ++ | HsDo (XDo p) -- Type of the whole expression ++ (HsStmtContext (DoName p)) -- The parameterisation is unimportant ++ -- because in this context we never use ++ -- the PatGuard or ParStmt variant ++ (Located [ExprLStmt p]) -- "do":one or more stmts -- | Syntactic list: [a,b,c,...] -- -@@ -476,6 +476,7 @@ data HsExpr p +@@ -476,7 +476,6 @@ data HsExpr p -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ -+ +- -- For details on above see note [Api annotations] in ApiAnnotation | RecordUpd { rupd_ext :: XRecordUpd p -@@ -718,12 +719,10 @@ type instance XApp (GhcPass _) = NoExt +@@ -719,10 +718,12 @@ type instance XApp (GhcPass _) = NoExt type instance XAppTypeE GhcPs = LHsWcType GhcPs type instance XAppTypeE GhcRn = LHsWcType GhcRn type instance XAppTypeE GhcTc = LHsWcType GhcRn --type instance XAppTypeE GhcSe = LHsWcType GhcSe ++type instance XAppTypeE GhcSe = LHsWcType GhcSe type instance XOpApp GhcPs = NoExt type instance XOpApp GhcRn = Fixity type instance XOpApp GhcTc = Fixity --type instance XOpApp GhcSe = NoExt ++type instance XOpApp GhcSe = NoExt type instance XNegApp (GhcPass _) = NoExt type instance XPar (GhcPass _) = NoExt -@@ -734,7 +733,6 @@ type instance XExplicitTuple (GhcPass _) = NoExt +@@ -733,6 +734,7 @@ type instance XExplicitTuple (GhcPass _) = NoExt type instance XExplicitSum GhcPs = NoExt type instance XExplicitSum GhcRn = NoExt type instance XExplicitSum GhcTc = [Type] --type instance XExplicitSum GhcSe = NoExt ++type instance XExplicitSum GhcSe = NoExt type instance XCase (GhcPass _) = NoExt type instance XIf (GhcPass _) = NoExt -@@ -742,39 +740,32 @@ type instance XIf (GhcPass _) = NoExt +@@ -740,32 +742,39 @@ type instance XIf (GhcPass _) = NoExt type instance XMultiIf GhcPs = NoExt type instance XMultiIf GhcRn = NoExt type instance XMultiIf GhcTc = Type --type instance XMultiIf GhcSe = NoExt ++type instance XMultiIf GhcSe = NoExt type instance XLet (GhcPass _) = NoExt type instance XDo GhcPs = NoExt type instance XDo GhcRn = NoExt type instance XDo GhcTc = Type --type instance XDo GhcSe = NoExt ++type instance XDo GhcSe = NoExt type instance XExplicitList GhcPs = NoExt type instance XExplicitList GhcRn = NoExt type instance XExplicitList GhcTc = Type --type instance XExplicitList GhcSe = NoExt ++type instance XExplicitList GhcSe = NoExt type instance XRecordCon GhcPs = NoExt type instance XRecordCon GhcRn = NoExt type instance XRecordCon GhcTc = RecordConTc --type instance XRecordCon GhcSe = NoExt ++type instance XRecordCon GhcSe = NoExt type instance XRecordUpd GhcPs = NoExt type instance XRecordUpd GhcRn = NoExt type instance XRecordUpd GhcTc = RecordUpdTc --type instance XRecordUpd GhcSe = NoExt ++type instance XRecordUpd GhcSe = NoExt type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs) type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn) type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn) --type instance XExprWithTySig GhcSe = (LHsSigWcType GhcSe) ++type instance XExprWithTySig GhcSe = (LHsSigWcType GhcSe) type instance XArithSeq GhcPs = NoExt type instance XArithSeq GhcRn = NoExt type instance XArithSeq GhcTc = PostTcExpr --type instance XArithSeq GhcSe = NoExt ++type instance XArithSeq GhcSe = NoExt type instance XSCC (GhcPass _) = NoExt type instance XCoreAnn (GhcPass _) = NoExt -@@ -789,12 +780,10 @@ type instance XProc (GhcPass _) = NoExt +@@ -780,10 +789,12 @@ type instance XProc (GhcPass _) = NoExt type instance XStatic GhcPs = NoExt type instance XStatic GhcRn = NameSet type instance XStatic GhcTc = NameSet --type instance XStatic GhcSe = NoExt ++type instance XStatic GhcSe = NoExt type instance XArrApp GhcPs = NoExt type instance XArrApp GhcRn = NoExt type instance XArrApp GhcTc = Type --type instance XArrApp GhcSe = NoExt ++type instance XArrApp GhcSe = NoExt type instance XArrForm (GhcPass _) = NoExt type instance XTick (GhcPass _) = NoExt -@@ -831,7 +820,6 @@ type instance XPresent (GhcPass _) = NoExt +@@ -820,6 +831,7 @@ type instance XPresent (GhcPass _) = NoExt type instance XMissing GhcPs = NoExt type instance XMissing GhcRn = NoExt type instance XMissing GhcTc = Type --type instance XMissing GhcSe = NoExt ++type instance XMissing GhcSe = NoExt type instance XXTupArg (GhcPass _) = NoExt -@@ -1405,7 +1393,6 @@ data HsCmd id +@@ -1393,6 +1405,7 @@ data HsCmd id type instance XCmdArrApp GhcPs = NoExt type instance XCmdArrApp GhcRn = NoExt type instance XCmdArrApp GhcTc = Type --type instance XCmdArrApp GhcSe = NoExt ++type instance XCmdArrApp GhcSe = NoExt type instance XCmdArrForm (GhcPass _) = NoExt type instance XCmdApp (GhcPass _) = NoExt -@@ -1418,7 +1405,6 @@ type instance XCmdLet (GhcPass _) = NoExt +@@ -1405,6 +1418,7 @@ type instance XCmdLet (GhcPass _) = NoExt type instance XCmdDo GhcPs = NoExt type instance XCmdDo GhcRn = NoExt type instance XCmdDo GhcTc = Type --type instance XCmdDo GhcSe = NoExt ++type instance XCmdDo GhcSe = NoExt type instance XCmdWrap (GhcPass _) = NoExt type instance XXCmd (GhcPass _) = NoExt -@@ -1450,7 +1436,6 @@ data CmdTopTc +@@ -1436,6 +1450,7 @@ data CmdTopTc type instance XCmdTop GhcPs = NoExt type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] type instance XCmdTop GhcTc = CmdTopTc --type instance XCmdTop GhcSe = NoExt ++type instance XCmdTop GhcSe = NoExt type instance XXCmdTop (GhcPass _) = NoExt -@@ -1601,7 +1586,6 @@ data MatchGroupTc +@@ -1586,6 +1601,7 @@ data MatchGroupTc type instance XMG GhcPs b = NoExt type instance XMG GhcRn b = NoExt type instance XMG GhcTc b = MatchGroupTc --type instance XMG GhcSe b = NoExt ++type instance XMG GhcSe b = NoExt type instance XXMatchGroup (GhcPass _) b = NoExt -@@ -2001,34 +1985,28 @@ type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExt +@@ -1985,28 +2001,34 @@ type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExt type instance XBindStmt (GhcPass _) GhcPs b = NoExt type instance XBindStmt (GhcPass _) GhcRn b = NoExt type instance XBindStmt (GhcPass _) GhcTc b = Type --type instance XBindStmt (GhcPass _) GhcSe b = NoExt ++type instance XBindStmt (GhcPass _) GhcSe b = NoExt type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExt type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExt type instance XApplicativeStmt (GhcPass _) GhcTc b = Type --type instance XApplicativeStmt (GhcPass _) GhcSe b = NoExt ++type instance XApplicativeStmt (GhcPass _) GhcSe b = NoExt type instance XBodyStmt (GhcPass _) GhcPs b = NoExt type instance XBodyStmt (GhcPass _) GhcRn b = NoExt type instance XBodyStmt (GhcPass _) GhcTc b = Type --type instance XBodyStmt (GhcPass _) GhcSe b = NoExt ++type instance XBodyStmt (GhcPass _) GhcSe b = NoExt type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExt type instance XParStmt (GhcPass _) GhcPs b = NoExt type instance XParStmt (GhcPass _) GhcRn b = NoExt type instance XParStmt (GhcPass _) GhcTc b = Type --type instance XParStmt (GhcPass _) GhcSe b = NoExt ++type instance XParStmt (GhcPass _) GhcSe b = NoExt type instance XTransStmt (GhcPass _) GhcPs b = NoExt type instance XTransStmt (GhcPass _) GhcRn b = NoExt type instance XTransStmt (GhcPass _) GhcTc b = Type --type instance XTransStmt (GhcPass _) GhcSe b = NoExt ++type instance XTransStmt (GhcPass _) GhcSe b = NoExt type instance XRecStmt (GhcPass _) GhcPs b = NoExt type instance XRecStmt (GhcPass _) GhcRn b = NoExt type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc --type instance XRecStmt (GhcPass _) GhcSe b = NoExt ++type instance XRecStmt (GhcPass _) GhcSe b = NoExt type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExt -@@ -2727,7 +2705,7 @@ data HsMatchContext id -- Not an extensible tag +@@ -2705,7 +2727,7 @@ data HsMatchContext id -- Not an extensible tag | ThPatSplice -- ^A Template Haskell pattern splice | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration -- deriving (Functor, Foldable, Traversable) -+ deriving Functor +- deriving Functor ++ deriving (Functor, Foldable, Traversable) deriving instance (Data id) => Data (HsMatchContext id) instance OutputableBndr id => Outputable (HsMatchContext id) where -@@ -2744,7 +2722,6 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where +@@ -2722,6 +2744,7 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where ppr ThPatQuote = text "ThPatQuote" ppr PatSyn = text "PatSyn" -- ++ isPatSynCtxt :: HsMatchContext id -> Bool isPatSynCtxt ctxt = case ctxt of -@@ -2765,7 +2742,7 @@ data HsStmtContext id +@@ -2742,7 +2765,7 @@ data HsStmtContext id | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt -- deriving (Functor, Foldable, Traversable) -+ deriving Functor +- deriving Functor ++ deriving (Functor, Foldable, Traversable) deriving instance (Data id) => Data (HsStmtContext id) isListCompExpr :: HsStmtContext id -> Bool diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot -index 4b8c15dfc8..109e9814e5 100644 +index 109e9814e5..4b8c15dfc8 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -5,7 +5,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ExistentialQuantification #-} --{-# LANGUAGE TypeFamilies #-} -- needed to use OutputableBndrId -+{-# LANGUAGE TypeFamilies #-} +-{-# LANGUAGE TypeFamilies #-} ++{-# LANGUAGE TypeFamilies #-} -- needed to use OutputableBndrId module HsExpr where diff --git a/compiler/hsSyn/HsExprBin.hs b/compiler/hsSyn/HsExprBin.hs -deleted file mode 100644 -index 7967f934fb..0000000000 ---- a/compiler/hsSyn/HsExprBin.hs -+++ /dev/null -@@ -1,149 +0,0 @@ --module HsExprBin -- ( getModuleSplicesPath -- , whenSet -- , HsSpliceData(..) -- , nonEmptyHsSpliceData -- , emptyHsSpliceData -- , SpliceResult(..) -- , recordSpliceResult -- , lookupSpliceResult -- , exprSE2PS -- , declSE2PS -- , exprPS2SE -- , declPS2SE -- , handleUnsupported -- ) where -- --import Binary --import GhcPrelude --import HsDecls --import HsExpr --import HsExprBin_Conversions --import qualified HsExprBin_ConversionSE2PS as SE2PS --import qualified HsExprBin_ConversionPS2SE as PS2SE --import HsExprBin_Instances () --import HsExtension --import Module --import Outputable --import SrcLoc --import TcRnTypes -- --import qualified Data.Map.Strict as Map --import System.FilePath -- --{- -- --Note [Serialisable AST phase] -- --There is an AST phase called GhcSe, where 'Se' stands for Serialisable. --It is quite close to GhcPs, in that it mostly represents ASTs the same way, --except for (syntax-level) types and names, which are represented in a way --that is (binary) serialisation friendly. -- --The motivation for this new phase is to be able to serialise ASTs of Haskell --code. (No existing phase has this property.) One use case would be to save --ASTs resulting from the evaluation of Template Haskell code and to reuse them --later, in place of evaluating the Template Haskell code. More generally, --it seems useful to be able to persist or load parsed ASTs, may it be for --IDE-style interactions or plugins. -- --The purpose of the HsExprBin* modules is to define: --- conversions from GhcSe to GhcPs, and back, with the four functions exported -- by this module; --- Binary instances for AST data types, only when "instantiated" at the GhcSe -- phase. -- --The former is done in two modules: HsExprBin_ConversionSE2PS and --HsExprBin_ConversionPS2SE. The latter in HsExprBin_Instances. -- ---} -- ---- * .hs-splice file contents -- --getModuleSplicesPath :: FilePath -> Module -> FilePath --getModuleSplicesPath splicesDir m = splicesDir -- toPath (moduleNameString (moduleName m)) <.> "hs-splice" -- -- where toPath = map (\c -> if c == '.' then '/' else c) -- --whenSet :: Monad m => Maybe a -> (a -> m b) -> m b -> m b --whenSet m j n = maybe n j m -- --newtype HsSpliceData = HsSpliceData { hsSpliceMap :: Map.Map SrcSpan SpliceResult } -- --emptyHsSpliceData :: HsSpliceData --emptyHsSpliceData = HsSpliceData Map.empty -- --nonEmptyHsSpliceData :: HsSpliceData -> Bool --nonEmptyHsSpliceData = not . Map.null . hsSpliceMap -- --data SpliceResult -- = SRExpr (LHsExpr GhcSe) -- | SRDecls [LHsDecl GhcSe] -- TODO: change to HsGroup ? -- -- TODO: add patterns and types? -- --instance Binary SpliceResult where -- put_ bh r = case r of -- SRExpr e -> putByte bh 0 >> put_ bh e -- SRDecls ds -> putByte bh 1 >> put_ bh ds -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> SRExpr <$> get bh -- 1 -> SRDecls <$> get bh -- _ -> panic "Binary SpliceResult: unknown tag" -- --instance Binary HsSpliceData where -- put_ bh (HsSpliceData m) = put_ bh (Map.toList m) -- get bh = (\l -> HsSpliceData (Map.fromList l)) <$> get bh -- --recordSpliceResult :: SrcSpan -> SpliceResult -> HsSpliceData -> HsSpliceData --recordSpliceResult loc res (HsSpliceData m) = HsSpliceData (Map.insert loc res m) -- --lookupSpliceResult :: SrcSpan -> HsSpliceData -> Maybe SpliceResult --lookupSpliceResult loc (HsSpliceData m) = Map.lookup loc m -- ---- * High-level conversion interface -- ---- Converting Se -> Ps -- ---- | Convert a serialisable expression AST to a parsed expression AST --exprSE2PS :: LHsExpr GhcSe -> RnM (ConvResult (LHsExpr GhcPs)) --exprSE2PS = runConv . SE2PS.cvLHsExpr -- ---- | Convert a serialisable declaration AST to a parsed declaration AST --declSE2PS :: LHsDecl GhcSe -> RnM (ConvResult (LHsDecl GhcPs)) --declSE2PS = runConv . SE2PS.cvLHsDecl -- ---- Converting Ps -> Se -- ---- | Convert a parsed expression AST to a serialisable expression AST --exprPS2SE :: LHsExpr GhcPs -> RnM (ConvResult (LHsExpr GhcSe)) --exprPS2SE = runConv . PS2SE.cvLHsExpr -- ---- | Convert a parsed declaration AST to a serialisable expression AST --declPS2SE :: LHsDecl GhcPs -> RnM (ConvResult (LHsDecl GhcSe)) --declPS2SE = runConv . PS2SE.cvLHsDecl -- ---- * Error reporting -- ---- | Panics with a nice error when we encounter an unsupported ---- construct, or returns the actual result if the conversion ---- succeeded. --handleUnsupported -- :: Located SDoc -- ^ TH expression that got evaluated -- -> Maybe SDoc -- ^ code resulting from the evaluation of the 1st arg -- -> ConvResult a -- ^ result of the conversion -- -> RnM a --handleUnsupported (L loc thDoc) resDoc convRes = case convRes of -- ConvOK a -> pure a -- ConvError (ConvUnsupported conName tyName subexprDoc) -> -- pprPanic "HsExprBin.handleUnsupported" . vcat $ -- [ text "GHC encountered a Haskell construct not supported by -{load, save}-splices:" -- , nest 4 $ subexprDoc <> text (" - constructor " ++ conName ++ " of type " ++ tyName) -- , text "while evaluating the following expression from " <> ppr loc <> text ":" -- , nest 4 $ thDoc -- ] ++ -- maybe [] (\d -> [text "which resulted in:" , nest 4 d]) resDoc -- -- ConvError (ConvFailure errorStr) -> panic errorStr +new file mode 100644 +index 0000000000..7967f934fb +--- /dev/null ++++ b/compiler/hsSyn/HsExprBin.hs +@@ -0,0 +1,149 @@ ++module HsExprBin ++ ( getModuleSplicesPath ++ , whenSet ++ , HsSpliceData(..) ++ , nonEmptyHsSpliceData ++ , emptyHsSpliceData ++ , SpliceResult(..) ++ , recordSpliceResult ++ , lookupSpliceResult ++ , exprSE2PS ++ , declSE2PS ++ , exprPS2SE ++ , declPS2SE ++ , handleUnsupported ++ ) where ++ ++import Binary ++import GhcPrelude ++import HsDecls ++import HsExpr ++import HsExprBin_Conversions ++import qualified HsExprBin_ConversionSE2PS as SE2PS ++import qualified HsExprBin_ConversionPS2SE as PS2SE ++import HsExprBin_Instances () ++import HsExtension ++import Module ++import Outputable ++import SrcLoc ++import TcRnTypes ++ ++import qualified Data.Map.Strict as Map ++import System.FilePath ++ ++{- ++ ++Note [Serialisable AST phase] ++ ++There is an AST phase called GhcSe, where 'Se' stands for Serialisable. ++It is quite close to GhcPs, in that it mostly represents ASTs the same way, ++except for (syntax-level) types and names, which are represented in a way ++that is (binary) serialisation friendly. ++ ++The motivation for this new phase is to be able to serialise ASTs of Haskell ++code. (No existing phase has this property.) One use case would be to save ++ASTs resulting from the evaluation of Template Haskell code and to reuse them ++later, in place of evaluating the Template Haskell code. More generally, ++it seems useful to be able to persist or load parsed ASTs, may it be for ++IDE-style interactions or plugins. ++ ++The purpose of the HsExprBin* modules is to define: ++- conversions from GhcSe to GhcPs, and back, with the four functions exported ++ by this module; ++- Binary instances for AST data types, only when "instantiated" at the GhcSe ++ phase. ++ ++The former is done in two modules: HsExprBin_ConversionSE2PS and ++HsExprBin_ConversionPS2SE. The latter in HsExprBin_Instances. ++ ++-} ++ ++-- * .hs-splice file contents ++ ++getModuleSplicesPath :: FilePath -> Module -> FilePath ++getModuleSplicesPath splicesDir m = splicesDir ++ toPath (moduleNameString (moduleName m)) <.> "hs-splice" ++ ++ where toPath = map (\c -> if c == '.' then '/' else c) ++ ++whenSet :: Monad m => Maybe a -> (a -> m b) -> m b -> m b ++whenSet m j n = maybe n j m ++ ++newtype HsSpliceData = HsSpliceData { hsSpliceMap :: Map.Map SrcSpan SpliceResult } ++ ++emptyHsSpliceData :: HsSpliceData ++emptyHsSpliceData = HsSpliceData Map.empty ++ ++nonEmptyHsSpliceData :: HsSpliceData -> Bool ++nonEmptyHsSpliceData = not . Map.null . hsSpliceMap ++ ++data SpliceResult ++ = SRExpr (LHsExpr GhcSe) ++ | SRDecls [LHsDecl GhcSe] -- TODO: change to HsGroup ? ++ -- TODO: add patterns and types? ++ ++instance Binary SpliceResult where ++ put_ bh r = case r of ++ SRExpr e -> putByte bh 0 >> put_ bh e ++ SRDecls ds -> putByte bh 1 >> put_ bh ds ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> SRExpr <$> get bh ++ 1 -> SRDecls <$> get bh ++ _ -> panic "Binary SpliceResult: unknown tag" ++ ++instance Binary HsSpliceData where ++ put_ bh (HsSpliceData m) = put_ bh (Map.toList m) ++ get bh = (\l -> HsSpliceData (Map.fromList l)) <$> get bh ++ ++recordSpliceResult :: SrcSpan -> SpliceResult -> HsSpliceData -> HsSpliceData ++recordSpliceResult loc res (HsSpliceData m) = HsSpliceData (Map.insert loc res m) ++ ++lookupSpliceResult :: SrcSpan -> HsSpliceData -> Maybe SpliceResult ++lookupSpliceResult loc (HsSpliceData m) = Map.lookup loc m ++ ++-- * High-level conversion interface ++ ++-- Converting Se -> Ps ++ ++-- | Convert a serialisable expression AST to a parsed expression AST ++exprSE2PS :: LHsExpr GhcSe -> RnM (ConvResult (LHsExpr GhcPs)) ++exprSE2PS = runConv . SE2PS.cvLHsExpr ++ ++-- | Convert a serialisable declaration AST to a parsed declaration AST ++declSE2PS :: LHsDecl GhcSe -> RnM (ConvResult (LHsDecl GhcPs)) ++declSE2PS = runConv . SE2PS.cvLHsDecl ++ ++-- Converting Ps -> Se ++ ++-- | Convert a parsed expression AST to a serialisable expression AST ++exprPS2SE :: LHsExpr GhcPs -> RnM (ConvResult (LHsExpr GhcSe)) ++exprPS2SE = runConv . PS2SE.cvLHsExpr ++ ++-- | Convert a parsed declaration AST to a serialisable expression AST ++declPS2SE :: LHsDecl GhcPs -> RnM (ConvResult (LHsDecl GhcSe)) ++declPS2SE = runConv . PS2SE.cvLHsDecl ++ ++-- * Error reporting ++ ++-- | Panics with a nice error when we encounter an unsupported ++-- construct, or returns the actual result if the conversion ++-- succeeded. ++handleUnsupported ++ :: Located SDoc -- ^ TH expression that got evaluated ++ -> Maybe SDoc -- ^ code resulting from the evaluation of the 1st arg ++ -> ConvResult a -- ^ result of the conversion ++ -> RnM a ++handleUnsupported (L loc thDoc) resDoc convRes = case convRes of ++ ConvOK a -> pure a ++ ConvError (ConvUnsupported conName tyName subexprDoc) -> ++ pprPanic "HsExprBin.handleUnsupported" . vcat $ ++ [ text "GHC encountered a Haskell construct not supported by -{load, save}-splices:" ++ , nest 4 $ subexprDoc <> text (" - constructor " ++ conName ++ " of type " ++ tyName) ++ , text "while evaluating the following expression from " <> ppr loc <> text ":" ++ , nest 4 $ thDoc ++ ] ++ ++ maybe [] (\d -> [text "which resulted in:" , nest 4 d]) resDoc ++ ++ ConvError (ConvFailure errorStr) -> panic errorStr diff --git a/compiler/hsSyn/HsExprBin.hs-boot b/compiler/hsSyn/HsExprBin.hs-boot -deleted file mode 100644 -index 964847e097..0000000000 ---- a/compiler/hsSyn/HsExprBin.hs-boot -+++ /dev/null -@@ -1,4 +0,0 @@ --module HsExprBin where -- --data HsSpliceData --emptyHsSpliceData :: HsSpliceData +new file mode 100644 +index 0000000000..964847e097 +--- /dev/null ++++ b/compiler/hsSyn/HsExprBin.hs-boot +@@ -0,0 +1,4 @@ ++module HsExprBin where ++ ++data HsSpliceData ++emptyHsSpliceData :: HsSpliceData \ No newline at end of file diff --git a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -deleted file mode 100644 -index 839564fbfe..0000000000 ---- a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -+++ /dev/null -@@ -1,812 +0,0 @@ --{-# LANGUAGE GADTs #-} --module HsExprBin_ConversionPS2SE where -- --import Control.Applicative --import Data.Traversable -- --import Bag (mapBagM) --import Class --import CoreSyn ( Tickish(..) ) --import GhcPrelude --import HsBinds --import HsDecls --import HsExpr --import HsExprBin_Conversions --import HsExtension --import HsLit --import HsPat --import HsTypes -- ---- * Conversion from serialisable ASTs to parsed ASTs -- --cvLHsDecl :: LHsDecl GhcPs -> Conv (LHsDecl GhcSe) --cvLHsDecl = traverse cvHsDecl -- --cvHsDecl :: HsDecl GhcPs -> Conv (HsDecl GhcSe) --cvHsDecl (TyClD a b) = TyClD <$> pure a <*> cvTyClDecl b --cvHsDecl (InstD a b) = InstD <$> pure a <*> cvInstDecl b --cvHsDecl (DerivD a b) = DerivD <$> pure a <*> cvDerivDecl b --cvHsDecl (ValD a b) = ValD <$> pure a <*> cvHsBindLR b --cvHsDecl (SigD a b) = SigD <$> pure a <*> cvSig b --cvHsDecl (DefD a b) = DefD <$> pure a <*> cvDefaultDecl b --cvHsDecl (ForD a b) = ForD <$> pure a <*> cvForeignDecl b --cvHsDecl (WarningD a b) = WarningD <$> pure a <*> cvWarningDecls b --cvHsDecl (RoleAnnotD a b) = RoleAnnotD <$> pure a <*> cvRoleAnnotDecl b --cvHsDecl (AnnD a b) = AnnD <$> pure a <*> cvAnnDecl b --cvHsDecl (RuleD a b) = RuleD <$> pure a <*> cvRuleDecls b --cvHsDecl (SpliceD a b) = SpliceD <$> pure a <*> cvSpliceDecl b --cvHsDecl (DocD a b) = pure (DocD a b) --cvHsDecl (XHsDecl a) = pure (XHsDecl a) -- --cvAnnDecl :: AnnDecl GhcPs -> Conv (AnnDecl GhcSe) --cvAnnDecl (HsAnnotation a b c d) = -- HsAnnotation a b <$> cvAnnProvenance c <*> cvLHsExpr d --cvAnnDecl (XAnnDecl a) = pure (XAnnDecl a) -- --cvInstDecl :: InstDecl GhcPs -> Conv (InstDecl GhcSe) --cvInstDecl (ClsInstD a b) = ClsInstD a <$> cvClsInstDecl b --cvInstDecl (DataFamInstD a b) = DataFamInstD a <$> cvDataFamInstDecl b --cvInstDecl (TyFamInstD a b) = TyFamInstD a <$> cvTyFamInstDecl b --cvInstDecl (XInstDecl a) = pure (XInstDecl a) -- --cvClsInstDecl :: ClsInstDecl GhcPs -> Conv (ClsInstDecl GhcSe) --cvClsInstDecl (ClsInstDecl a b c d e f g) = -- ClsInstDecl a -- <$> cvHsImplicitBndrs (traverse cvType) b -- <*> mapBagM (traverse cvHsBindLR) c -- <*> traverse (traverse cvSig) d -- <*> traverse (traverse cvTyFamInstDecl) e -- <*> traverse (traverse cvDataFamInstDecl) f -- <*> pure g --cvClsInstDecl (XClsInstDecl a) = pure (XClsInstDecl a) -- --cvDerivDecl :: DerivDecl GhcPs -> Conv (DerivDecl GhcSe) --cvDerivDecl (DerivDecl a b c d) = -- DerivDecl a <$> cvHsWildCardBndrs (cvHsImplicitBndrs $ traverse cvType) b -- <*> traverse (traverse cvDerivStrategy) c -- <*> pure d --cvDerivDecl (XDerivDecl a) = pure (XDerivDecl a) -- --cvDerivStrategy -- :: DerivStrategy GhcPs -> Conv (DerivStrategy GhcSe) --cvDerivStrategy StockStrategy = pure StockStrategy --cvDerivStrategy AnyclassStrategy = pure AnyclassStrategy --cvDerivStrategy NewtypeStrategy = pure NewtypeStrategy --cvDerivStrategy (ViaStrategy a) = ViaStrategy -- <$> cvHsImplicitBndrs (traverse cvType) a -- --cvTyClDecl :: TyClDecl GhcPs -> Conv (TyClDecl GhcSe) --cvTyClDecl (FamDecl a b) = FamDecl <$> pure a <*> cvFamilyDecl b --cvTyClDecl (SynDecl a b c d e) = -- SynDecl a -- <$> convertName b -- <*> cvLHsQTyVars c <*> pure d -- <*> traverse cvType e --cvTyClDecl (DataDecl a b c d e) = -- DataDecl a -- <$> convertName b -- <*> cvLHsQTyVars c <*> pure d -- <*> cvHsDataDefn e --cvTyClDecl (ClassDecl a b c d e f g h i j k) = -- ClassDecl a -- <$> traverse (traverse (traverse cvType)) b -- <*> convertName c -- <*> cvLHsQTyVars d -- <*> pure e -- <*> traverse (traverse cvFunDep) f -- <*> traverse (traverse cvSig) g -- <*> mapBagM (traverse cvHsBindLR) h -- <*> traverse (traverse cvFamilyDecl) i -- <*> traverse (traverse $ cvFamEqn cvLHsQTyVars (traverse cvType)) j -- <*> pure k --cvTyClDecl (XTyClDecl a) = pure (XTyClDecl a) -- --cvRoleAnnotDecl :: RoleAnnotDecl GhcPs -> Conv (RoleAnnotDecl GhcSe) --cvRoleAnnotDecl (RoleAnnotDecl a b c) = -- RoleAnnotDecl a <$> convertName b <*> pure c --cvRoleAnnotDecl (XRoleAnnotDecl a) = pure (XRoleAnnotDecl a) -- --cvRuleDecls :: RuleDecls GhcPs -> Conv (RuleDecls GhcSe) --cvRuleDecls (HsRules a b c) = HsRules a b <$> traverse (traverse cvRuleDecl) c --cvRuleDecls (XRuleDecls a) = pure (XRuleDecls a) -- --cvRuleDecl :: RuleDecl GhcPs -> Conv (RuleDecl GhcSe) --cvRuleDecl (HsRule a b c d e f) = -- HsRule a b c <$> traverse (traverse cvRuleBndr) d -- <*> cvLHsExpr e <*> cvLHsExpr f --cvRuleDecl (XRuleDecl a) = pure (XRuleDecl a) -- --cvSpliceDecl :: SpliceDecl GhcPs -> Conv (SpliceDecl GhcSe) --cvSpliceDecl (SpliceDecl a b c) = -- SpliceDecl a <$> traverse cvHsSplice b <*> pure c --cvSpliceDecl (XSpliceDecl a) = pure (XSpliceDecl a) -- --cvHsSplice :: HsSplice GhcPs -> Conv (HsSplice GhcSe) --cvHsSplice (HsTypedSplice a b c d) = -- HsTypedSplice a b <$> convertName c <*> cvLHsExpr d --cvHsSplice (HsUntypedSplice a b c d) = -- HsUntypedSplice a b <$> convertName c <*> cvLHsExpr d --cvHsSplice (HsQuasiQuote a b c d e) = -- HsQuasiQuote a <$> convertName b <*> convertName c <*> pure d <*> pure e --cvHsSplice (HsSpliced {}) = -- unsupported "HsSpliced" "HsSplice" (error "") --cvHsSplice (XSplice a) = pure (XSplice a) -- --cvRuleBndr :: RuleBndr GhcPs -> Conv (RuleBndr GhcSe) --cvRuleBndr (RuleBndr a b) = RuleBndr a <$> convertName b --cvRuleBndr (RuleBndrSig a b c) = -- RuleBndrSig a <$> convertName b <*> cvHsSigWcType c --cvRuleBndr (XRuleBndr a) = pure (XRuleBndr a) -- --cvFamEqn -- :: ( XCFamEqn GhcPs a b ~ XCFamEqn GhcSe c d -- , XXFamEqn GhcPs a b ~ XXFamEqn GhcSe c d -- ) -- => (a -> Conv c) -- -> (b -> Conv d) -- -> FamEqn GhcPs a b -- -> Conv (FamEqn GhcSe c d) --cvFamEqn goPats goRhs (FamEqn a b c d e) = -- FamEqn a <$> convertName b <*> goPats c <*> pure d <*> goRhs e --cvFamEqn _ _ (XFamEqn a) = pure (XFamEqn a) -- --cvFamilyDecl :: FamilyDecl GhcPs -> Conv (FamilyDecl GhcSe) --cvFamilyDecl (FamilyDecl a b c d e f g) = -- FamilyDecl a -- <$> cvFamilyInfo b <*> convertName c -- <*> cvLHsQTyVars d <*> pure e -- <*> traverse cvFamilyResultSig f -- <*> traverse (traverse cvInjectivityAnn) g --cvFamilyDecl (XFamilyDecl a) = pure (XFamilyDecl a) -- --cvAnnProvenance :: ConvertName a b => AnnProvenance a -> Conv (AnnProvenance b) --cvAnnProvenance (ValueAnnProvenance a) = ValueAnnProvenance <$> convertName a --cvAnnProvenance (TypeAnnProvenance a) = TypeAnnProvenance <$> convertName a --cvAnnProvenance ModuleAnnProvenance = pure ModuleAnnProvenance -- --cvInjectivityAnn -- :: InjectivityAnn GhcPs -> Conv (InjectivityAnn GhcSe) --cvInjectivityAnn (InjectivityAnn a b) = -- InjectivityAnn <$> convertName a <*> convertName b -- --cvFamilyResultSig -- :: FamilyResultSig GhcPs -> Conv (FamilyResultSig GhcSe) --cvFamilyResultSig (NoSig a) = pure (NoSig a) --cvFamilyResultSig (KindSig a b) = KindSig a <$> traverse cvType b --cvFamilyResultSig (TyVarSig a b) = TyVarSig a <$> traverse cvHsTyVarBndr b --cvFamilyResultSig (XFamilyResultSig a) = pure (XFamilyResultSig a) -- --cvFamilyInfo -- :: FamilyInfo GhcPs -> Conv (FamilyInfo GhcSe) --cvFamilyInfo DataFamily = pure DataFamily --cvFamilyInfo OpenTypeFamily = pure OpenTypeFamily --cvFamilyInfo (ClosedTypeFamily a) = -- ClosedTypeFamily <$> traverse (traverse (traverse (cvFamInstEqn (traverse cvType)))) a -- --cvFamInstEqn -- :: ( XCFamEqn GhcPs (HsTyPats GhcPs) a -- ~ XCFamEqn GhcSe (HsTyPats GhcSe) b -- , XHsIB GhcPs (FamEqn GhcPs (HsTyPats p) a) -- ~ XHsIB GhcSe (FamEqn GhcSe (HsTyPats GhcSe) b) -- , XXFamEqn GhcPs (HsTyPats GhcPs) a -- ~ XXFamEqn GhcSe (HsTyPats GhcSe) b -- , XXHsImplicitBndrs GhcPs (FamEqn GhcPs (HsTyPats GhcPs) a) -- ~ XXHsImplicitBndrs GhcSe (FamEqn GhcSe (HsTyPats GhcSe) b) -- ) -- => (a -> Conv b) -- -> FamInstEqn GhcPs a -- -> Conv (FamInstEqn GhcSe b) --cvFamInstEqn f = cvHsImplicitBndrs (cvFamEqn (traverse (traverse cvType)) f) -- --cvFunDep :: ConvertName a b => FunDep a -> Conv (FunDep b) --cvFunDep (xs, ys) = (,) <$> convertName xs <*> convertName ys -- --cvLHsQTyVars :: LHsQTyVars GhcPs -> Conv (LHsQTyVars GhcSe) --cvLHsQTyVars (HsQTvs a b) = HsQTvs a <$> traverse (traverse cvHsTyVarBndr) b --cvLHsQTyVars (XLHsQTyVars a) = pure (XLHsQTyVars a) -- --cvForeignDecl :: ForeignDecl GhcPs -> Conv (ForeignDecl GhcSe) --cvForeignDecl (ForeignImport a b c d) = -- ForeignImport a -- <$> convertName b -- <*> cvHsImplicitBndrs (traverse cvType) c -- <*> pure d --cvForeignDecl (ForeignExport a b c d) = -- ForeignExport a -- <$> convertName b -- <*> cvHsImplicitBndrs (traverse cvType) c -- <*> pure d --cvForeignDecl (XForeignDecl a) = pure (XForeignDecl a) -- --cvDefaultDecl :: DefaultDecl GhcPs -> Conv (DefaultDecl GhcSe) --cvDefaultDecl (DefaultDecl a b) = DefaultDecl a <$> traverse (traverse cvType) b --cvDefaultDecl (XDefaultDecl a) = pure (XDefaultDecl a) -- --cvTyFamInstDecl -- :: TyFamInstDecl GhcPs -> Conv (TyFamInstDecl GhcSe) --cvTyFamInstDecl (TyFamInstDecl d) = -- TyFamInstDecl <$> cvFamInstEqn (traverse cvType) d -- --cvDataFamInstDecl -- :: DataFamInstDecl GhcPs -> Conv (DataFamInstDecl GhcSe) --cvDataFamInstDecl (DataFamInstDecl d) = -- DataFamInstDecl <$> cvFamInstEqn cvHsDataDefn d -- --cvHsDataDefn :: HsDataDefn GhcPs -> Conv (HsDataDefn GhcSe) --cvHsDataDefn (HsDataDefn a b c d e f g) = -- HsDataDefn a b -- <$> traverse (traverse (traverse cvType)) c <*> pure d -- <*> traverse (traverse cvType) e -- <*> traverse (traverse cvConDecl) f <*> cvHsDeriving g --cvHsDataDefn (XHsDataDefn a) = pure (XHsDataDefn a) -- --cvConDecl :: ConDecl GhcPs -> Conv (ConDecl GhcSe) --cvConDecl (ConDeclGADT a b c d e f g h) = -- ConDeclGADT a -- <$> convertName b -- <*> pure c -- <*> cvLHsQTyVars d -- <*> traverse (traverse (traverse (traverse cvType))) e -- <*> cvHsConDeclDetails f -- <*> traverse cvType g -- <*> pure h --cvConDecl (ConDeclH98 a b c d e f g) = -- ConDeclH98 a -- <$> convertName b -- <*> pure c -- <*> traverse (traverse cvHsTyVarBndr) d -- <*> traverse (traverse (traverse (traverse cvType))) e -- <*> cvHsConDeclDetails f -- <*> pure g --cvConDecl (XConDecl a) = pure (XConDecl a) -- --cvHsDeriving :: HsDeriving GhcPs -> Conv (HsDeriving GhcSe) --cvHsDeriving = traverse (traverse (traverse cvHsDerivingClause)) -- --cvHsDerivingClause -- :: HsDerivingClause GhcPs -> Conv (HsDerivingClause GhcSe) --cvHsDerivingClause (HsDerivingClause a b c) = -- HsDerivingClause a -- <$> traverse (traverse cvDerivStrategy) b -- <*> traverse (traverse (cvHsImplicitBndrs (traverse cvType))) c --cvHsDerivingClause (XHsDerivingClause a) = pure (XHsDerivingClause a) -- --cvHsConDeclDetails -- :: HsConDeclDetails GhcPs -> Conv (HsConDeclDetails GhcSe) --cvHsConDeclDetails = -- cvHsConDetails (traverse cvType) -- (traverse (traverse (traverse cvConDeclField))) -- --cvHsConDetails -- :: (a -> Conv c) -> (b -> Conv d) -> HsConDetails a b -> Conv (HsConDetails c d) --cvHsConDetails f _ (PrefixCon a) = PrefixCon <$> traverse f a --cvHsConDetails _ g (RecCon a) = RecCon <$> g a --cvHsConDetails f _ (InfixCon a b) = InfixCon <$> f a <*> f b -- --cvConDeclField :: ConDeclField GhcPs -> Conv (ConDeclField GhcSe) --cvConDeclField (ConDeclField a b c d) = -- ConDeclField a <$> traverse (traverse cvFieldOcc) b <*> traverse cvType c -- <*> pure d --cvConDeclField (XConDeclField a) = pure (XConDeclField a) -- --cvWarningDecls :: WarnDecls GhcPs -> Conv (WarnDecls GhcSe) --cvWarningDecls (Warnings a b c) = -- Warnings a b <$> traverse (traverse cvWarningDecl) c --cvWarningDecls (XWarnDecls a) = pure (XWarnDecls a) -- --cvWarningDecl :: WarnDecl GhcPs -> Conv (WarnDecl GhcSe) --cvWarningDecl (Warning a b c) = Warning a <$> convertName b <*> pure c --cvWarningDecl (XWarnDecl a) = pure (XWarnDecl a) -- ---- expressions -- --cvLHsExpr :: LHsExpr GhcPs -> Conv (LHsExpr GhcSe) --cvLHsExpr = traverse cvHsExpr -- --cvHsExpr :: HsExpr GhcPs -> Conv (HsExpr GhcSe) --cvHsExpr e = case e of -- HsVar a b -> HsVar a <$> convertName b -- HsUnboundVar a b -> pure (HsUnboundVar a b) -- HsConLikeOut a b -> pure (HsConLikeOut a b) -- HsRecFld a b -> HsRecFld a <$> cvAFieldOcc b -- HsOverLabel a b c -> HsOverLabel a <$> convertName b <*> pure c -- HsIPVar a b -> pure (HsIPVar a b) -- HsOverLit a b -> HsOverLit a <$> cvOverLit b -- HsLit a b -> HsLit a <$> cvLit b -- HsLam a b -> HsLam a <$> cvMatchGroup cvLHsExpr b -- HsLamCase a b -> HsLamCase a <$> cvMatchGroup cvLHsExpr b -- HsApp a b c -> HsApp a <$> cvLHsExpr b <*> cvLHsExpr c -- HsAppType a b -> HsAppType <$> cvLHsWcType a <*> cvLHsExpr b -- OpApp a b c d -> OpApp a <$> cvLHsExpr b <*> cvLHsExpr c <*> cvLHsExpr d -- NegApp a b c -> NegApp a <$> cvLHsExpr b <*> cvSyntaxExpr c -- HsPar a b -> HsPar a <$> cvLHsExpr b -- SectionL a b c -> SectionL a <$> cvLHsExpr b <*> cvLHsExpr c -- SectionR a b c -> SectionR a <$> cvLHsExpr b <*> cvLHsExpr c -- ExplicitTuple a b c -> ExplicitTuple a <$> traverse (traverse cvHsTupArg) b -- <*> pure c -- ExplicitSum a b c d -> ExplicitSum a b c <$> cvLHsExpr d -- ExplicitList a b c -> ExplicitList a <$> traverse cvSyntaxExpr b <*> traverse cvLHsExpr c -- HsCase a b c -> HsCase a <$> cvLHsExpr b <*> cvMatchGroup cvLHsExpr c -- HsIf a b c d e -> HsIf a <$> traverse cvSyntaxExpr b -- <*> cvLHsExpr c <*> cvLHsExpr d <*> cvLHsExpr e -- HsMultiIf a b -> HsMultiIf a <$> traverse (traverse (cvGRHS cvLHsExpr)) b -- HsLet a b c -> HsLet a <$> traverse cvHsLocalBinds b <*> cvLHsExpr c -- HsDo a b c -> HsDo a -- <$> convertName b <*> traverse (traverse (traverse (cvStmtLR cvLHsExpr))) c -- RecordCon a b c -> RecordCon a <$> convertName b <*> cvRecordBinds c -- RecordUpd a b c -> RecordUpd a <$> cvLHsExpr b -- <*> traverse (traverse cvHsRecUpdField) c -- ExprWithTySig a b -> ExprWithTySig <$> cvHsSigWcType a <*> cvLHsExpr b -- ArithSeq a b c -> ArithSeq a <$> traverse cvSyntaxExpr b <*> cvArithSeqInfo c -- HsSCC a b c d -> HsSCC a b c <$> cvLHsExpr d -- HsCoreAnn a b c d -> HsCoreAnn a b c <$> cvLHsExpr d -- HsStatic a b -> HsStatic a <$> cvLHsExpr b -- EWildPat a -> pure (EWildPat a) -- EAsPat a b c -> EAsPat a <$> convertName b <*> cvLHsExpr c -- EViewPat a b c -> EViewPat a <$> cvLHsExpr b <*> cvLHsExpr c -- ELazyPat a b -> ELazyPat a <$> cvLHsExpr b -- HsProc a b c -> HsProc a <$> traverse cvPat b <*> traverse cvHsCmdTop c -- HsBinTick a b c d -> HsBinTick a b c <$> cvLHsExpr d -- HsTickPragma a b c d e -> HsTickPragma a b c d <$> cvLHsExpr e -- HsSpliceE a b -> HsSpliceE a <$> cvHsSplice b -- HsBracket a b -> HsBracket a <$> cvHsBracket b -- HsTick a b c -> HsTick a <$> cvTickish b <*> cvLHsExpr c -- XExpr a -> pure (XExpr a) -- HsArrApp {} -> unsupported "HsArrApp" "HsExpr" (error "") -- HsArrForm {} -> unsupported "HsArrForm" "HsExpr" (error "") -- HsWrap {} -> unsupported "HsWrap" "HsExpr" (error "") -- HsRnBracketOut {} -> unsupported "HsRnBracketOut" "HsExpr" (error "") -- HsTcBracketOut {} -> unsupported "HsTcBracketOut" "HsExpr" (error "") -- --cvHsBracket :: HsBracket GhcPs -> Conv (HsBracket GhcSe) --cvHsBracket (ExpBr a b) = ExpBr a <$> cvLHsExpr b --cvHsBracket (PatBr a b) = PatBr a <$> traverse cvPat b --cvHsBracket (DecBrL a b) = DecBrL a <$> traverse (traverse cvHsDecl) b --cvHsBracket (DecBrG a b) = DecBrG a <$> cvHsGroup b --cvHsBracket (TypBr a b) = TypBr a <$> traverse cvType b --cvHsBracket (VarBr a b c) = VarBr a b <$> convertName c --cvHsBracket (TExpBr a b) = TExpBr a <$> cvLHsExpr b --cvHsBracket (XBracket a) = pure (XBracket a) -- --cvTickish :: ConvertName a b => Tickish a -> Conv (Tickish b) --cvTickish (ProfNote a b c) = pure (ProfNote a b c) --cvTickish (HpcTick a b) = pure (HpcTick a b) --cvTickish (Breakpoint a b) = Breakpoint a <$> convertName b --cvTickish (SourceNote a b) = pure (SourceNote a b) -- --cvHsGroup :: HsGroup GhcPs -> Conv (HsGroup GhcSe) --cvHsGroup (HsGroup a b c d e f g h i j k l) = HsGroup a -- <$> cvHsValBindsLR b <*> traverse (traverse cvSpliceDecl) c -- <*> traverse cvTyClGroup d -- <*> traverse (traverse cvDerivDecl) e -- <*> traverse (traverse cvFixitySig) f -- <*> traverse (traverse cvDefaultDecl) g -- <*> traverse (traverse cvForeignDecl) h -- <*> traverse (traverse cvWarningDecls) i -- <*> traverse (traverse cvAnnDecl) j -- <*> traverse (traverse cvRuleDecls) k -- <*> pure l --cvHsGroup (XHsGroup a) = pure (XHsGroup a) -- --cvTyClGroup :: TyClGroup GhcPs -> Conv (TyClGroup GhcSe) --cvTyClGroup (TyClGroup a b c d) = TyClGroup a -- <$> traverse (traverse cvTyClDecl) b -- <*> traverse (traverse cvRoleAnnotDecl) c -- <*> traverse (traverse cvInstDecl) d --cvTyClGroup (XTyClGroup a) = pure (XTyClGroup a) -- --cvHsCmdTop :: HsCmdTop GhcPs -> Conv (HsCmdTop GhcSe) --cvHsCmdTop (HsCmdTop a b) = HsCmdTop a <$> traverse cvHsCmd b --cvHsCmdTop (XCmdTop a) = pure (XCmdTop a) -- --cvHsCmd :: HsCmd GhcPs -> Conv (HsCmd GhcSe) --cvHsCmd (HsCmdArrApp a b c d e) = HsCmdArrApp a -- <$> cvLHsExpr b <*> cvLHsExpr c <*> pure d <*> pure e --cvHsCmd (HsCmdArrForm a b c d e) = HsCmdArrForm a -- <$> cvLHsExpr b <*> pure c <*> pure d -- <*> traverse (traverse cvHsCmdTop) e --cvHsCmd (HsCmdApp a b c) = HsCmdApp a <$> traverse cvHsCmd b <*> cvLHsExpr c --cvHsCmd (HsCmdLam a b) = HsCmdLam a <$> cvMatchGroup (traverse cvHsCmd) b --cvHsCmd (HsCmdPar a b) = HsCmdPar a <$> traverse cvHsCmd b --cvHsCmd (HsCmdCase a b c) = HsCmdCase a -- <$> cvLHsExpr b <*> cvMatchGroup (traverse cvHsCmd) c --cvHsCmd (HsCmdIf a b c d e) = HsCmdIf a -- <$> traverse cvSyntaxExpr b -- <*> cvLHsExpr c -- <*> traverse cvHsCmd d -- <*> traverse cvHsCmd e --cvHsCmd (HsCmdLet a b c) = HsCmdLet a -- <$> traverse cvHsLocalBinds b <*> traverse cvHsCmd c --cvHsCmd (HsCmdDo a b) = HsCmdDo a -- <$> traverse (traverse (traverse (cvStmtLR (traverse cvHsCmd)))) b --cvHsCmd (HsCmdWrap {}) = unsupported "HsCmdWrap" "HsCmd" (error "") --cvHsCmd (XCmd a) = pure (XCmd a) -- --cvArithSeqInfo :: ArithSeqInfo GhcPs -> Conv (ArithSeqInfo GhcSe) --cvArithSeqInfo (From e) = From <$> cvLHsExpr e --cvArithSeqInfo (FromThen a b) = FromThen <$> cvLHsExpr a <*> cvLHsExpr b --cvArithSeqInfo (FromTo a b) = FromTo <$> cvLHsExpr a <*> cvLHsExpr b --cvArithSeqInfo (FromThenTo a b c) = FromThenTo <$> cvLHsExpr a <*> cvLHsExpr b <*> cvLHsExpr c -- --cvHsTupArg :: HsTupArg GhcPs -> Conv (HsTupArg GhcSe) --cvHsTupArg (Present a b) = Present a <$> cvLHsExpr b --cvHsTupArg (Missing a) = pure (Missing a) --cvHsTupArg (XTupArg a) = pure (XTupArg a) -- --cvAFieldOcc -- :: AmbiguousFieldOcc GhcPs -> Conv (AmbiguousFieldOcc GhcSe) --cvAFieldOcc (Unambiguous a b) = Unambiguous a <$> convertName b --cvAFieldOcc (Ambiguous a b) = Ambiguous a <$> convertName b --cvAFieldOcc (XAmbiguousFieldOcc a) = pure (XAmbiguousFieldOcc a) -- --cvOverLit :: HsOverLit GhcPs -> Conv (HsOverLit GhcSe) --cvOverLit (OverLit a b c) = OverLit a b <$> cvHsExpr c --cvOverLit (XOverLit a) = pure (XOverLit a) -- --cvLit :: HsLit GhcPs -> Conv (HsLit GhcSe) --cvLit (HsChar a b) = pure (HsChar a b) --cvLit (HsCharPrim a b) = pure (HsCharPrim a b) --cvLit (HsString a b) = pure (HsString a b) --cvLit (HsStringPrim a b) = pure (HsStringPrim a b) --cvLit (HsInt a b) = pure (HsInt a b) --cvLit (HsIntPrim a b) = pure (HsIntPrim a b) --cvLit (HsWordPrim a b) = pure (HsWordPrim a b) --cvLit (HsInt64Prim a b) = pure (HsInt64Prim a b) --cvLit (HsWord64Prim a b) = pure (HsWord64Prim a b) --cvLit (HsInteger a b c) = HsInteger a b <$> convertType c --cvLit (HsRat a b c) = HsRat a b <$> convertType c --cvLit (HsFloatPrim a b) = pure (HsFloatPrim a b) --cvLit (HsDoublePrim a b) = pure (HsDoublePrim a b) --cvLit (XLit a) = pure (XLit a) -- --cvMatchGroup -- :: ( XMG GhcPs a ~ XMG GhcSe b -- , XCMatch GhcPs a ~ XCMatch GhcSe b -- , XCGRHSs GhcPs a ~ XCGRHSs GhcSe b -- , XCGRHS GhcPs a ~ XCGRHS GhcSe b -- , XXMatchGroup GhcPs a ~ XXMatchGroup GhcSe b -- , XXMatch GhcPs a ~ XXMatch GhcSe b -- , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b -- , XXGRHS GhcPs a ~ XXGRHS GhcSe b -- ) -- => (a -> Conv b) -> MatchGroup GhcPs a -> Conv (MatchGroup GhcSe b) --cvMatchGroup f (MG a b c) = MG a -- <$> traverse (traverse (traverse (cvMatch f))) b -- <*> pure c --cvMatchGroup _ (XMatchGroup a) = pure (XMatchGroup a) -- --cvMatch -- :: ( XCMatch GhcPs a ~ XCMatch GhcSe b -- , XCGRHSs GhcPs a ~ XCGRHSs GhcSe b -- , XCGRHS GhcPs a ~ XCGRHS GhcSe b -- , XXMatch GhcPs a ~ XXMatch GhcSe b -- , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b -- , XXGRHS GhcPs a ~ XXGRHS GhcSe b -- ) -- => (a -> Conv b) -> Match GhcPs a -> Conv (Match GhcSe b) --cvMatch f (Match a b c d) = Match a -- <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d --cvMatch _ (XMatch a) = pure (XMatch a) -- --cvPat :: Pat GhcPs -> Conv (Pat GhcSe) --cvPat (WildPat a) = pure (WildPat a) --cvPat (VarPat a b) = VarPat a <$> convertName b --cvPat (LazyPat a b) = LazyPat a <$> traverse cvPat b --cvPat (AsPat a b c) = AsPat a <$> convertName b <*> traverse cvPat c --cvPat (ParPat a b) = ParPat a <$> traverse cvPat b --cvPat (BangPat a b) = BangPat a <$> traverse cvPat b --cvPat (ListPat a b) = ListPat a -- <$> traverse (traverse cvPat) b --cvPat (TuplePat a b c) = TuplePat a -- <$> traverse (traverse cvPat) b -- <*> pure c --cvPat (SumPat a b c d) = SumPat a -- <$> traverse cvPat b -- <*> pure c <*> pure d --cvPat (ConPatIn a b) = ConPatIn <$> convertName a <*> cvHsConPatDetails b --cvPat (ViewPat a b c) = ViewPat a <$> cvLHsExpr b <*> traverse cvPat c --cvPat (LitPat a b) = LitPat a <$> cvLit b --cvPat (NPat a b c d) = NPat a -- <$> traverse cvOverLit b <*> traverse cvSyntaxExpr c -- <*> cvSyntaxExpr d --cvPat (NPlusKPat a b c d e f) = NPlusKPat a -- <$> convertName b -- <*> traverse cvOverLit c <*> cvOverLit d -- <*> cvSyntaxExpr e <*> cvSyntaxExpr f --cvPat (SigPat a b) = SigPat <$> cvHsSigWcType a <*> traverse cvPat b --cvPat (SplicePat a b) = SplicePat a <$> cvHsSplice b --cvPat (CoPat {}) = unsupported "CoPat" "Pat" (error "") --cvPat (ConPatOut {}) = unsupported "ConPatOut" "Pat" (error "") --cvPat (XPat a) = pure (XPat a) -- --cvGRHSs -- :: ( XCGRHSs GhcPs a ~ XCGRHSs GhcSe b -- , XCGRHS GhcPs a ~ XCGRHS GhcSe b -- , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b -- , XXGRHS GhcPs a ~ XXGRHS GhcSe b -- ) -- => (a -> Conv b) -> GRHSs GhcPs a -> Conv (GRHSs GhcSe b) --cvGRHSs f (GRHSs a b c) = GRHSs a -- <$> traverse (traverse (cvGRHS f)) b -- <*> traverse cvHsLocalBinds c --cvGRHSs _ (XGRHSs a) = pure (XGRHSs a) -- --cvGRHS -- :: ( XCGRHS GhcPs a ~ XCGRHS GhcSe b -- , XXGRHS GhcPs a ~ XXGRHS GhcSe b -- ) -- => (a -> Conv b) -> GRHS GhcPs a -> Conv (GRHS GhcSe b) --cvGRHS f (GRHS a b c) = GRHS a -- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> f c --cvGRHS _ (XGRHS a) = pure (XGRHS a) -- --cvHsLocalBinds -- :: HsLocalBinds GhcPs -> Conv (HsLocalBinds GhcSe) --cvHsLocalBinds (HsValBinds a b) = HsValBinds a <$> cvHsValBindsLR b --cvHsLocalBinds (HsIPBinds a b) = HsIPBinds a <$> cvHsIPBinds b --cvHsLocalBinds (EmptyLocalBinds a) = pure (EmptyLocalBinds a) --cvHsLocalBinds (XHsLocalBindsLR a) = pure (XHsLocalBindsLR a) -- --cvHsValBindsLR -- :: HsValBindsLR GhcPs GhcPs -> Conv (HsValBindsLR GhcSe GhcSe) --cvHsValBindsLR (ValBinds a b c) = ValBinds a -- <$> mapBagM (traverse cvHsBindLR) b -- <*> traverse (traverse cvSig) c --cvHsValBindsLR (XValBindsLR _) = -- unsupported "XValBindsLR" "HsValBindsLR" (error "") -- --cvHsConPatDetails -- :: HsConPatDetails GhcPs -> Conv (HsConPatDetails GhcSe) --cvHsConPatDetails (PrefixCon a) = PrefixCon <$> traverse (traverse cvPat) a --cvHsConPatDetails (RecCon a) = RecCon <$> cvHsRecFieldsPat a --cvHsConPatDetails (InfixCon a b) = InfixCon -- <$> traverse cvPat a <*> traverse cvPat b -- --cvHsRecFields -- :: (thing -> Conv thing') -- -> HsRecFields GhcPs thing -- -> Conv (HsRecFields GhcSe thing') --cvHsRecFields f (HsRecFields a b) = -- HsRecFields <$> traverse (traverse (cvHsRecField' cvFieldOcc f)) a <*> pure b -- --cvHsRecField' -- :: (id -> Conv id') -- -> (thing -> Conv thing') -- -> HsRecField' id thing -- -> Conv (HsRecField' id' thing') --cvHsRecField' f g (HsRecField a b c) = -- HsRecField <$> traverse f a <*> g b <*> pure c -- --cvHsRecFieldsPat -- :: HsRecFields GhcPs (LPat GhcPs) -> Conv (HsRecFields GhcSe (LPat GhcSe)) --cvHsRecFieldsPat = cvHsRecFields (traverse cvPat) -- --cvHsRecUpdField -- :: HsRecUpdField GhcPs -> Conv (HsRecUpdField GhcSe) --cvHsRecUpdField = cvHsRecField' cvAFieldOcc cvLHsExpr -- --cvRecordBinds -- :: HsRecordBinds GhcPs -> Conv (HsRecordBinds GhcSe) --cvRecordBinds = cvHsRecFields cvLHsExpr -- --cvFieldOcc :: FieldOcc GhcPs -> Conv (FieldOcc GhcSe) --cvFieldOcc (FieldOcc a b) = FieldOcc a <$> convertName b --cvFieldOcc (XFieldOcc a) = pure (XFieldOcc a) -- --cvStmtLR -- :: ( XLastStmt GhcPs GhcPs a ~ XLastStmt GhcSe GhcSe b -- , XBindStmt GhcPs GhcPs a ~ XBindStmt GhcSe GhcSe b -- , XBodyStmt GhcPs GhcPs a ~ XBodyStmt GhcSe GhcSe b -- , XApplicativeStmt GhcPs GhcPs a ~ XApplicativeStmt GhcSe GhcSe b -- , XLetStmt GhcPs GhcPs a ~ XLetStmt GhcSe GhcSe b -- , XRecStmt GhcPs GhcPs a ~ XRecStmt GhcSe GhcSe b -- , XParStmt GhcPs GhcPs a ~ XParStmt GhcSe GhcSe b -- , XTransStmt GhcPs GhcPs a ~ XTransStmt GhcSe GhcSe b -- , XXStmtLR GhcPs GhcPs a ~ XXStmtLR GhcSe GhcSe b -- ) -- => (a -> Conv b) -> StmtLR GhcPs GhcPs a -> Conv (StmtLR GhcSe GhcSe b) --cvStmtLR k (LastStmt a b c d) = LastStmt a -- <$> k b <*> pure c <*> cvSyntaxExpr d --cvStmtLR k (BindStmt a b c d e) = BindStmt a -- <$> traverse cvPat b <*> k c -- <*> cvSyntaxExpr d <*> cvSyntaxExpr e --cvStmtLR k (BodyStmt a b c d) = BodyStmt a -- <$> k b <*> cvSyntaxExpr c -- <*> cvSyntaxExpr d --cvStmtLR _ (ApplicativeStmt a b c) = ApplicativeStmt a -- <$> traverse -- (\(se, aa) -> (,) <$> cvSyntaxExpr se <*> cvApplicativeArg aa) -- b -- <*> traverse cvSyntaxExpr c --cvStmtLR _ (LetStmt a b) = LetStmt a <$> traverse cvHsLocalBinds b --cvStmtLR k (RecStmt a b c d e f g) = RecStmt a -- <$> traverse (traverse (cvStmtLR k)) b -- <*> convertName c -- <*> convertName d -- <*> cvSyntaxExpr e -- <*> cvSyntaxExpr f -- <*> cvSyntaxExpr g --cvStmtLR _ (ParStmt a b c d) = ParStmt a -- <$> traverse cvParStmtBlock b -- <*> cvHsExpr c -- <*> cvSyntaxExpr d --cvStmtLR _ (TransStmt a b c d e f g h i) = TransStmt a b -- <$> traverse (traverse (cvStmtLR cvLHsExpr)) c -- <*> traverse (\(x, y) -> (,) <$> convertName x <*> convertName y) d -- <*> cvLHsExpr e -- <*> traverse cvLHsExpr f -- <*> cvSyntaxExpr g -- <*> cvSyntaxExpr h -- <*> cvHsExpr i --cvStmtLR _ (XStmtLR a) = pure (XStmtLR a) -- --cvParStmtBlock -- :: ParStmtBlock GhcPs GhcPs -> Conv (ParStmtBlock GhcSe GhcSe) --cvParStmtBlock (ParStmtBlock a b c d) = ParStmtBlock a -- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b -- <*> convertName c -- <*> cvSyntaxExpr d --cvParStmtBlock (XParStmtBlock a) = pure (XParStmtBlock a) -- --cvSyntaxExpr :: SyntaxExpr GhcPs -> Conv (SyntaxExpr GhcSe) --cvSyntaxExpr (SyntaxExpr a b c) = -- SyntaxExpr <$> cvHsExpr a <*> pure b <*> pure c -- --cvHsIPBinds -- :: HsIPBinds GhcPs -> Conv (HsIPBinds GhcSe) --cvHsIPBinds (IPBinds a b) = IPBinds a <$> traverse (traverse cvIPBind) b --cvHsIPBinds (XHsIPBinds a) = pure (XHsIPBinds a) -- --cvIPBind :: IPBind GhcPs -> Conv (IPBind GhcSe) --cvIPBind (IPBind a b c) = IPBind a <$> convertName b <*> cvLHsExpr c --cvIPBind (XIPBind a) = pure (XIPBind a) -- --cvHsBindLR -- :: HsBindLR GhcPs GhcPs -> Conv (HsBindLR GhcSe GhcSe) --cvHsBindLR (FunBind a b c d e) = FunBind a -- <$> convertName b -- <*> cvMatchGroup cvLHsExpr c -- <*> pure d <*> pure e --cvHsBindLR (PatBind a b c d ) = PatBind a -- <$> traverse cvPat b <*> cvGRHSs cvLHsExpr c <*> pure d --cvHsBindLR (VarBind a b c d) = VarBind a -- <$> convertName b <*> cvLHsExpr c <*> pure d --cvHsBindLR (PatSynBind a b) = PatSynBind a <$> cvPatSynBind b --cvHsBindLR (AbsBinds {}) = -- unsupported "AbsBind" "HsBindLR" (error "") --cvHsBindLR (XHsBindsLR a) = pure (XHsBindsLR a) -- --cvHsWildCardBndrs -- :: ( XHsWC GhcPs thing ~ XHsWC GhcSe thing' -- , XXHsWildCardBndrs GhcPs thing ~ XXHsWildCardBndrs GhcSe thing' -- ) -- => (thing -> Conv thing') -- -> HsWildCardBndrs GhcPs thing -- -> Conv (HsWildCardBndrs GhcSe thing') --cvHsWildCardBndrs thingF (HsWC a b) = HsWC a <$> thingF b --cvHsWildCardBndrs _ (XHsWildCardBndrs a) = pure (XHsWildCardBndrs a) -- --cvLHsWcType -- :: LHsWcType GhcPs -> Conv (LHsWcType GhcSe) --cvLHsWcType = cvHsWildCardBndrs (traverse cvType) -- --cvHsSigWcType -- :: LHsSigWcType GhcPs -> Conv (LHsSigWcType GhcSe) --cvHsSigWcType = cvHsWildCardBndrs (cvHsImplicitBndrs (traverse cvType)) -- --cvHsImplicitBndrs -- :: ( XHsIB GhcPs thing ~ XHsIB GhcSe thing' -- , XXHsImplicitBndrs GhcPs thing ~ XXHsImplicitBndrs GhcSe thing' -- ) -- => (thing -> Conv thing') -- -> HsImplicitBndrs GhcPs thing -- -> Conv (HsImplicitBndrs GhcSe thing') --cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b --cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) -- --cvType :: HsType GhcPs -> Conv (HsType GhcSe) --cvType (HsForAllTy a b c) = HsForAllTy a -- <$> traverse (traverse cvHsTyVarBndr) b -- <*> traverse cvType c --cvType (HsQualTy a b c) = HsQualTy a -- <$> traverse (traverse (traverse cvType)) b -- <*> traverse cvType c --cvType (HsTyVar a b c) = HsTyVar a b <$> convertName c --cvType (HsAppTy a b c) = HsAppTy a -- <$> traverse cvType b -- <*> traverse cvType c --cvType (HsFunTy a b c) = HsFunTy a -- <$> traverse cvType b -- <*> traverse cvType c --cvType (HsListTy a b) = HsListTy a <$> traverse cvType b --cvType (HsTupleTy a b c) = HsTupleTy a b <$> traverse (traverse cvType) c --cvType (HsSumTy a b) = HsSumTy a <$> traverse (traverse cvType) b --cvType (HsOpTy a b c d) = HsOpTy a -- <$> traverse cvType b -- <*> convertName c -- <*> traverse cvType d --cvType (HsParTy a b) = HsParTy a <$> traverse cvType b --cvType (HsIParamTy a b c) = HsIParamTy a b <$> traverse cvType c --cvType (HsKindSig a b c) = HsKindSig a -- <$> traverse cvType b -- <*> traverse cvType c --cvType (HsBangTy a b c) = HsBangTy a b <$> traverse cvType c --cvType (HsRecTy a b) = HsRecTy a <$> traverse (traverse cvConDeclField) b --cvType (HsExplicitListTy a b c) = HsExplicitListTy a b -- <$> traverse (traverse cvType) c --cvType (HsExplicitTupleTy a b) = HsExplicitTupleTy a -- <$> traverse (traverse cvType) b --cvType (HsTyLit a b) = pure (HsTyLit a b) --cvType (HsWildCardTy a) = pure (HsWildCardTy a) --cvType (HsDocTy a b c) = HsDocTy a <$> traverse cvType b <*> pure c --cvType (HsSpliceTy a b) = HsSpliceTy a <$> cvHsSplice b --cvType (HsStarTy a b) = pure (HsStarTy a b) --cvType (XHsType a) = pure (XHsType a) -- --cvHsTyVarBndr -- :: HsTyVarBndr GhcPs -> Conv (HsTyVarBndr GhcSe) --cvHsTyVarBndr (UserTyVar a b) = UserTyVar a <$> convertName b --cvHsTyVarBndr (KindedTyVar a b c) = KindedTyVar a -- <$> convertName b -- <*> traverse cvType c --cvHsTyVarBndr (XTyVarBndr a) = pure (XTyVarBndr a) -- --cvApplicativeArg -- :: ApplicativeArg GhcPs -> Conv (ApplicativeArg GhcSe) --cvApplicativeArg (ApplicativeArgOne a b c d) = ApplicativeArgOne a -- <$> traverse cvPat b <*> cvLHsExpr c <*> pure d --cvApplicativeArg (ApplicativeArgMany a b c d) = ApplicativeArgMany a -- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> cvHsExpr c -- <*> traverse cvPat d --cvApplicativeArg (XApplicativeArg a) = pure (XApplicativeArg a) -- --cvSig :: Sig GhcPs -> Conv (Sig GhcSe) --cvSig (TypeSig a b c) = TypeSig a <$> convertName b <*> cvHsSigWcType c --cvSig (PatSynSig a b c) = PatSynSig a -- <$> convertName b <*> cvHsImplicitBndrs (traverse cvType) c --cvSig (ClassOpSig a b c d) = ClassOpSig a b -- <$> convertName c <*> cvHsImplicitBndrs (traverse cvType) d --cvSig (InlineSig a b c) = InlineSig a <$> convertName b <*> pure c --cvSig (FixSig a b) = FixSig a <$> cvFixitySig b --cvSig (SpecSig a b c d) = SpecSig a -- <$> convertName b -- <*> traverse (cvHsImplicitBndrs (traverse cvType)) c -- <*> pure d --cvSig (SpecInstSig a b c) = SpecInstSig a b -- <$> cvHsImplicitBndrs (traverse cvType) c --cvSig (SCCFunSig a b c d) = SCCFunSig a b <$> convertName c <*> pure d --cvSig (CompleteMatchSig a b c d) = CompleteMatchSig a b -- <$> convertName c <*> convertName d --cvSig (MinimalSig a b c) = MinimalSig a b <$> traverse (traverse convertName) c --cvSig (IdSig {}) = unsupported "IdSig" "Sig" (error "") --cvSig (XSig a) = pure (XSig a) -- --cvFixitySig :: FixitySig GhcPs -> Conv (FixitySig GhcSe) --cvFixitySig (FixitySig a b c) = FixitySig a <$> convertName b <*> pure c --cvFixitySig (XFixitySig a) = pure (XFixitySig a) -- --cvPatSynBind :: PatSynBind GhcPs GhcPs -> Conv (PatSynBind GhcSe GhcSe) --cvPatSynBind (PSB a b c d e) = PSB a -- <$> convertName b -- <*> cvHsPatSynDetails convertName c <*> traverse cvPat d -- <*> cvHsPatSynDir e --cvPatSynBind (XPatSynBind a) = pure (XPatSynBind a) -- --cvHsPatSynDetails -- :: (a -> Conv b) -- -> HsPatSynDetails a -- -> Conv (HsPatSynDetails b) --cvHsPatSynDetails f = cvHsConDetails f (traverse (cvRecordPatSynField f)) -- --cvRecordPatSynField -- :: (a -> Conv b) -- -> RecordPatSynField a -- -> Conv (RecordPatSynField b) --cvRecordPatSynField f (RecordPatSynField a b) = -- RecordPatSynField <$> f a <*> f b -- --cvHsPatSynDir :: HsPatSynDir GhcPs -> Conv (HsPatSynDir GhcSe) --cvHsPatSynDir Unidirectional = pure Unidirectional --cvHsPatSynDir ImplicitBidirectional = pure ImplicitBidirectional --cvHsPatSynDir (ExplicitBidirectional a) = ExplicitBidirectional -- <$> cvMatchGroup cvLHsExpr a -diff --git a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -deleted file mode 100644 -index 8fbc941a71..0000000000 ---- a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -+++ /dev/null -@@ -1,813 +0,0 @@ --{-# LANGUAGE GADTs #-} --module HsExprBin_ConversionSE2PS where -- --import Control.Applicative --import Data.Traversable -- --import Bag (mapBagM) --import Class --import CoreSyn ( Tickish(..) ) --import GhcPrelude --import HsBinds --import HsDecls --import HsExpr --import HsExprBin_Conversions --import HsExtension --import HsLit --import HsPat --import HsTypes -- ---- * Conversion from serialisable ASTs to parsed ASTs -- --cvLHsDecl :: LHsDecl GhcSe -> Conv (LHsDecl GhcPs) --cvLHsDecl = traverse cvHsDecl -- --cvHsDecl :: HsDecl GhcSe -> Conv (HsDecl GhcPs) --cvHsDecl (TyClD a b) = TyClD <$> pure a <*> cvTyClDecl b --cvHsDecl (InstD a b) = InstD <$> pure a <*> cvInstDecl b --cvHsDecl (DerivD a b) = DerivD <$> pure a <*> cvDerivDecl b --cvHsDecl (ValD a b) = ValD <$> pure a <*> cvHsBindLR b --cvHsDecl (SigD a b) = SigD <$> pure a <*> cvSig b --cvHsDecl (DefD a b) = DefD <$> pure a <*> cvDefaultDecl b --cvHsDecl (ForD a b) = ForD <$> pure a <*> cvForeignDecl b --cvHsDecl (WarningD a b) = WarningD <$> pure a <*> cvWarningDecls b --cvHsDecl (RoleAnnotD a b) = RoleAnnotD <$> pure a <*> cvRoleAnnotDecl b --cvHsDecl (AnnD a b) = AnnD <$> pure a <*> cvAnnDecl b --cvHsDecl (RuleD a b) = RuleD <$> pure a <*> cvRuleDecls b --cvHsDecl (SpliceD a b) = SpliceD <$> pure a <*> cvSpliceDecl b --cvHsDecl (DocD a b) = pure (DocD a b) --cvHsDecl (XHsDecl a) = pure (XHsDecl a) -- --cvAnnDecl :: AnnDecl GhcSe -> Conv (AnnDecl GhcPs) --cvAnnDecl (HsAnnotation a b c d) = -- HsAnnotation a b <$> cvAnnProvenance c <*> cvLHsExpr d --cvAnnDecl (XAnnDecl a) = pure (XAnnDecl a) -- --cvInstDecl :: InstDecl GhcSe -> Conv (InstDecl GhcPs) --cvInstDecl (ClsInstD a b) = ClsInstD a <$> cvClsInstDecl b --cvInstDecl (DataFamInstD a b) = DataFamInstD a <$> cvDataFamInstDecl b --cvInstDecl (TyFamInstD a b) = TyFamInstD a <$> cvTyFamInstDecl b --cvInstDecl (XInstDecl a) = pure (XInstDecl a) -- --cvClsInstDecl :: ClsInstDecl GhcSe -> Conv (ClsInstDecl GhcPs) --cvClsInstDecl (ClsInstDecl a b c d e f g) = -- ClsInstDecl a -- <$> cvHsImplicitBndrs (traverse cvType) b -- <*> mapBagM (traverse cvHsBindLR) c -- <*> traverse (traverse cvSig) d -- <*> traverse (traverse cvTyFamInstDecl) e -- <*> traverse (traverse cvDataFamInstDecl) f -- <*> pure g --cvClsInstDecl (XClsInstDecl a) = pure (XClsInstDecl a) -- --cvDerivDecl :: DerivDecl GhcSe -> Conv (DerivDecl GhcPs) --cvDerivDecl (DerivDecl a b c d) = -- DerivDecl a <$> cvHsWildCardBndrs (cvHsImplicitBndrs $ traverse cvType) b -- <*> traverse (traverse cvDerivStrategy) c -- <*> pure d --cvDerivDecl (XDerivDecl a) = pure (XDerivDecl a) -- --cvDerivStrategy -- :: DerivStrategy GhcSe -> Conv (DerivStrategy GhcPs) --cvDerivStrategy StockStrategy = pure StockStrategy --cvDerivStrategy AnyclassStrategy = pure AnyclassStrategy --cvDerivStrategy NewtypeStrategy = pure NewtypeStrategy --cvDerivStrategy (ViaStrategy a) = ViaStrategy -- <$> cvHsImplicitBndrs (traverse cvType) a -- --cvTyClDecl :: TyClDecl GhcSe -> Conv (TyClDecl GhcPs) --cvTyClDecl (FamDecl a b) = FamDecl <$> pure a <*> cvFamilyDecl b --cvTyClDecl (SynDecl a b c d e) = -- SynDecl a -- <$> convertName b -- <*> cvLHsQTyVars c <*> pure d -- <*> traverse cvType e --cvTyClDecl (DataDecl a b c d e) = -- DataDecl a -- <$> convertName b -- <*> cvLHsQTyVars c <*> pure d -- <*> cvHsDataDefn e --cvTyClDecl (ClassDecl a b c d e f g h i j k) = -- ClassDecl a -- <$> traverse (traverse (traverse cvType)) b -- <*> convertName c -- <*> cvLHsQTyVars d -- <*> pure e -- <*> traverse (traverse cvFunDep) f -- <*> traverse (traverse cvSig) g -- <*> mapBagM (traverse cvHsBindLR) h -- <*> traverse (traverse cvFamilyDecl) i -- <*> traverse (traverse $ cvFamEqn cvLHsQTyVars (traverse cvType)) j -- <*> pure k --cvTyClDecl (XTyClDecl a) = pure (XTyClDecl a) -- --cvRoleAnnotDecl :: RoleAnnotDecl GhcSe -> Conv (RoleAnnotDecl GhcPs) --cvRoleAnnotDecl (RoleAnnotDecl a b c) = -- RoleAnnotDecl a <$> convertName b <*> pure c --cvRoleAnnotDecl (XRoleAnnotDecl a) = pure (XRoleAnnotDecl a) -- --cvRuleDecls :: RuleDecls GhcSe -> Conv (RuleDecls GhcPs) --cvRuleDecls (HsRules a b c) = HsRules a b <$> traverse (traverse cvRuleDecl) c --cvRuleDecls (XRuleDecls a) = pure (XRuleDecls a) -- --cvRuleDecl :: RuleDecl GhcSe -> Conv (RuleDecl GhcPs) --cvRuleDecl (HsRule a b c d e f) = -- HsRule a b c <$> traverse (traverse cvRuleBndr) d -- <*> cvLHsExpr e <*> cvLHsExpr f --cvRuleDecl (XRuleDecl a) = pure (XRuleDecl a) -- --cvSpliceDecl :: SpliceDecl GhcSe -> Conv (SpliceDecl GhcPs) --cvSpliceDecl (SpliceDecl a b c) = -- SpliceDecl a <$> traverse cvHsSplice b <*> pure c --cvSpliceDecl (XSpliceDecl a) = pure (XSpliceDecl a) -- --cvHsSplice :: HsSplice GhcSe -> Conv (HsSplice GhcPs) --cvHsSplice (HsTypedSplice a b c d) = -- HsTypedSplice a b <$> convertName c <*> cvLHsExpr d --cvHsSplice (HsUntypedSplice a b c d) = -- HsUntypedSplice a b <$> convertName c <*> cvLHsExpr d --cvHsSplice (HsQuasiQuote a b c d e) = -- HsQuasiQuote a <$> convertName b <*> convertName c <*> pure d <*> pure e --cvHsSplice (HsSpliced {}) = -- unsupported "HsSpliced" "HsSplice" (error "") --cvHsSplice (XSplice a) = pure (XSplice a) -- --cvRuleBndr :: RuleBndr GhcSe -> Conv (RuleBndr GhcPs) --cvRuleBndr (RuleBndr a b) = RuleBndr a <$> convertName b --cvRuleBndr (RuleBndrSig a b c) = -- RuleBndrSig a <$> convertName b <*> cvHsSigWcType c --cvRuleBndr (XRuleBndr a) = pure (XRuleBndr a) -- --cvFamEqn -- :: ( XCFamEqn GhcSe a b ~ XCFamEqn GhcPs c d -- , XXFamEqn GhcSe a b ~ XXFamEqn GhcPs c d -- ) -- => (a -> Conv c) -- -> (b -> Conv d) -- -> FamEqn GhcSe a b -- -> Conv (FamEqn GhcPs c d) --cvFamEqn goPats goRhs (FamEqn a b c d e) = -- FamEqn a <$> convertName b <*> goPats c <*> pure d <*> goRhs e --cvFamEqn _ _ (XFamEqn a) = pure (XFamEqn a) -- --cvFamilyDecl :: FamilyDecl GhcSe -> Conv (FamilyDecl GhcPs) --cvFamilyDecl (FamilyDecl a b c d e f g) = -- FamilyDecl a -- <$> cvFamilyInfo b <*> convertName c -- <*> cvLHsQTyVars d <*> pure e -- <*> traverse cvFamilyResultSig f -- <*> traverse (traverse cvInjectivityAnn) g --cvFamilyDecl (XFamilyDecl a) = pure (XFamilyDecl a) -- --cvAnnProvenance :: ConvertName a b => AnnProvenance a -> Conv (AnnProvenance b) --cvAnnProvenance (ValueAnnProvenance a) = ValueAnnProvenance <$> convertName a --cvAnnProvenance (TypeAnnProvenance a) = TypeAnnProvenance <$> convertName a --cvAnnProvenance ModuleAnnProvenance = pure ModuleAnnProvenance -- --cvInjectivityAnn -- :: InjectivityAnn GhcSe -> Conv (InjectivityAnn GhcPs) --cvInjectivityAnn (InjectivityAnn a b) = -- InjectivityAnn <$> convertName a <*> convertName b -- --cvFamilyResultSig -- :: FamilyResultSig GhcSe -> Conv (FamilyResultSig GhcPs) --cvFamilyResultSig (NoSig a) = pure (NoSig a) --cvFamilyResultSig (KindSig a b) = KindSig a <$> traverse cvType b --cvFamilyResultSig (TyVarSig a b) = TyVarSig a <$> traverse cvHsTyVarBndr b --cvFamilyResultSig (XFamilyResultSig a) = pure (XFamilyResultSig a) -- --cvFamilyInfo -- :: FamilyInfo GhcSe -> Conv (FamilyInfo GhcPs) --cvFamilyInfo DataFamily = pure DataFamily --cvFamilyInfo OpenTypeFamily = pure OpenTypeFamily --cvFamilyInfo (ClosedTypeFamily a) = -- ClosedTypeFamily <$> traverse (traverse (traverse (cvFamInstEqn (traverse cvType)))) a -- --cvFamInstEqn -- :: ( XCFamEqn GhcSe (HsTyPats GhcSe) a -- ~ XCFamEqn GhcPs (HsTyPats GhcPs) b -- , XHsIB GhcSe (FamEqn GhcSe (HsTyPats p) a) -- ~ XHsIB GhcPs (FamEqn GhcPs (HsTyPats GhcPs) b) -- , XXFamEqn GhcSe (HsTyPats GhcSe) a -- ~ XXFamEqn GhcPs (HsTyPats GhcPs) b -- , XXHsImplicitBndrs GhcSe (FamEqn GhcSe (HsTyPats GhcSe) a) -- ~ XXHsImplicitBndrs GhcPs (FamEqn GhcPs (HsTyPats GhcPs) b) -- ) -- => (a -> Conv b) -- -> FamInstEqn GhcSe a -- -> Conv (FamInstEqn GhcPs b) --cvFamInstEqn f = cvHsImplicitBndrs (cvFamEqn (traverse (traverse cvType)) f) -- --cvFunDep :: ConvertName a b => FunDep a -> Conv (FunDep b) --cvFunDep (xs, ys) = (,) <$> convertName xs <*> convertName ys -- --cvLHsQTyVars :: LHsQTyVars GhcSe -> Conv (LHsQTyVars GhcPs) --cvLHsQTyVars (HsQTvs a b) = HsQTvs a <$> traverse (traverse cvHsTyVarBndr) b --cvLHsQTyVars (XLHsQTyVars a) = pure (XLHsQTyVars a) -- --cvForeignDecl :: ForeignDecl GhcSe -> Conv (ForeignDecl GhcPs) --cvForeignDecl (ForeignImport a b c d) = -- ForeignImport a -- <$> convertName b -- <*> cvHsImplicitBndrs (traverse cvType) c -- <*> pure d --cvForeignDecl (ForeignExport a b c d) = -- ForeignExport a -- <$> convertName b -- <*> cvHsImplicitBndrs (traverse cvType) c -- <*> pure d --cvForeignDecl (XForeignDecl a) = pure (XForeignDecl a) -- --cvDefaultDecl :: DefaultDecl GhcSe -> Conv (DefaultDecl GhcPs) --cvDefaultDecl (DefaultDecl a b) = DefaultDecl a <$> traverse (traverse cvType) b --cvDefaultDecl (XDefaultDecl a) = pure (XDefaultDecl a) -- --cvTyFamInstDecl -- :: TyFamInstDecl GhcSe -> Conv (TyFamInstDecl GhcPs) --cvTyFamInstDecl (TyFamInstDecl d) = -- TyFamInstDecl <$> cvFamInstEqn (traverse cvType) d -- --cvDataFamInstDecl -- :: DataFamInstDecl GhcSe -> Conv (DataFamInstDecl GhcPs) --cvDataFamInstDecl (DataFamInstDecl d) = -- DataFamInstDecl <$> cvFamInstEqn cvHsDataDefn d -- --cvHsDataDefn :: HsDataDefn GhcSe -> Conv (HsDataDefn GhcPs) --cvHsDataDefn (HsDataDefn a b c d e f g) = -- HsDataDefn a b -- <$> traverse (traverse (traverse cvType)) c <*> pure d -- <*> traverse (traverse cvType) e -- <*> traverse (traverse cvConDecl) f <*> cvHsDeriving g --cvHsDataDefn (XHsDataDefn a) = pure (XHsDataDefn a) -- --cvConDecl :: ConDecl GhcSe -> Conv (ConDecl GhcPs) --cvConDecl (ConDeclGADT a b c d e f g h) = -- ConDeclGADT a -- <$> convertName b -- <*> pure c -- <*> cvLHsQTyVars d -- <*> traverse (traverse (traverse (traverse cvType))) e -- <*> cvHsConDeclDetails f -- <*> traverse cvType g -- <*> pure h --cvConDecl (ConDeclH98 a b c d e f g) = -- ConDeclH98 a -- <$> convertName b -- <*> pure c -- <*> traverse (traverse cvHsTyVarBndr) d -- <*> traverse (traverse (traverse (traverse cvType))) e -- <*> cvHsConDeclDetails f -- <*> pure g --cvConDecl (XConDecl a) = pure (XConDecl a) -- --cvHsDeriving :: HsDeriving GhcSe -> Conv (HsDeriving GhcPs) --cvHsDeriving = traverse (traverse (traverse cvHsDerivingClause)) -- --cvHsDerivingClause -- :: HsDerivingClause GhcSe -> Conv (HsDerivingClause GhcPs) --cvHsDerivingClause (HsDerivingClause a b c) = -- HsDerivingClause a -- <$> traverse (traverse cvDerivStrategy) b -- <*> traverse (traverse (cvHsImplicitBndrs (traverse cvType))) c --cvHsDerivingClause (XHsDerivingClause a) = pure (XHsDerivingClause a) -- --cvHsConDeclDetails -- :: HsConDeclDetails GhcSe -> Conv (HsConDeclDetails GhcPs) --cvHsConDeclDetails = -- cvHsConDetails (traverse cvType) -- (traverse (traverse (traverse cvConDeclField))) -- --cvHsConDetails -- :: (a -> Conv c) -> (b -> Conv d) -> HsConDetails a b -> Conv (HsConDetails c d) --cvHsConDetails f _ (PrefixCon a) = PrefixCon <$> traverse f a --cvHsConDetails _ g (RecCon a) = RecCon <$> g a --cvHsConDetails f _ (InfixCon a b) = InfixCon <$> f a <*> f b -- --cvConDeclField :: ConDeclField GhcSe -> Conv (ConDeclField GhcPs) --cvConDeclField (ConDeclField a b c d) = -- ConDeclField a <$> traverse (traverse cvFieldOcc) b <*> traverse cvType c -- <*> pure d --cvConDeclField (XConDeclField a) = pure (XConDeclField a) -- --cvWarningDecls :: WarnDecls GhcSe -> Conv (WarnDecls GhcPs) --cvWarningDecls (Warnings a b c) = -- Warnings a b <$> traverse (traverse cvWarningDecl) c --cvWarningDecls (XWarnDecls a) = pure (XWarnDecls a) -- --cvWarningDecl :: WarnDecl GhcSe -> Conv (WarnDecl GhcPs) --cvWarningDecl (Warning a b c) = Warning a <$> convertName b <*> pure c --cvWarningDecl (XWarnDecl a) = pure (XWarnDecl a) -- ---- expressions -- --cvLHsExpr :: LHsExpr GhcSe -> Conv (LHsExpr GhcPs) --cvLHsExpr = traverse cvHsExpr -- --cvHsExpr :: HsExpr GhcSe -> Conv (HsExpr GhcPs) --cvHsExpr e = case e of -- HsVar a b -> HsVar a <$> convertName b -- HsUnboundVar a b -> pure (HsUnboundVar a b) -- HsConLikeOut a b -> pure (HsConLikeOut a b) -- HsRecFld a b -> HsRecFld a <$> cvAFieldOcc b -- HsOverLabel a b c -> HsOverLabel a <$> convertName b <*> pure c -- HsIPVar a b -> pure (HsIPVar a b) -- HsOverLit a b -> HsOverLit a <$> cvOverLit b -- HsLit a b -> HsLit a <$> cvLit b -- HsLam a b -> HsLam a <$> cvMatchGroup cvLHsExpr b -- HsLamCase a b -> HsLamCase a <$> cvMatchGroup cvLHsExpr b -- HsApp a b c -> HsApp a <$> cvLHsExpr b <*> cvLHsExpr c -- HsAppType a b -> HsAppType -- <$> cvHsWildCardBndrs (traverse cvType) a <*> cvLHsExpr b -- OpApp a b c d -> OpApp a <$> cvLHsExpr b <*> cvLHsExpr c <*> cvLHsExpr d -- NegApp a b c -> NegApp a <$> cvLHsExpr b <*> cvSyntaxExpr c -- HsPar a b -> HsPar a <$> cvLHsExpr b -- SectionL a b c -> SectionL a <$> cvLHsExpr b <*> cvLHsExpr c -- SectionR a b c -> SectionR a <$> cvLHsExpr b <*> cvLHsExpr c -- ExplicitTuple a b c -> ExplicitTuple a <$> traverse (traverse cvHsTupArg) b -- <*> pure c -- ExplicitSum a b c d -> ExplicitSum a b c <$> cvLHsExpr d -- ExplicitList a b c -> ExplicitList a <$> traverse cvSyntaxExpr b <*> traverse cvLHsExpr c -- HsCase a b c -> HsCase a <$> cvLHsExpr b <*> cvMatchGroup cvLHsExpr c -- HsIf a b c d e -> HsIf a <$> traverse cvSyntaxExpr b -- <*> cvLHsExpr c <*> cvLHsExpr d <*> cvLHsExpr e -- HsMultiIf a b -> HsMultiIf a <$> traverse (traverse (cvGRHS cvLHsExpr)) b -- HsLet a b c -> HsLet a <$> traverse cvHsLocalBinds b <*> cvLHsExpr c -- HsDo a b c -> HsDo a -- <$> convertName b <*> traverse (traverse (traverse (cvStmtLR cvLHsExpr))) c -- RecordCon a b c -> RecordCon a <$> convertName b <*> cvRecordBinds c -- RecordUpd a b c -> RecordUpd a <$> cvLHsExpr b -- <*> traverse (traverse cvHsRecUpdField) c -- ExprWithTySig a b -> ExprWithTySig <$> cvHsSigWcType a <*> cvLHsExpr b -- ArithSeq a b c -> ArithSeq a <$> traverse cvSyntaxExpr b <*> cvArithSeqInfo c -- HsSCC a b c d -> HsSCC a b c <$> cvLHsExpr d -- HsCoreAnn a b c d -> HsCoreAnn a b c <$> cvLHsExpr d -- HsStatic a b -> HsStatic a <$> cvLHsExpr b -- EWildPat a -> pure (EWildPat a) -- EAsPat a b c -> EAsPat a <$> convertName b <*> cvLHsExpr c -- EViewPat a b c -> EViewPat a <$> cvLHsExpr b <*> cvLHsExpr c -- ELazyPat a b -> ELazyPat a <$> cvLHsExpr b -- HsProc a b c -> HsProc a <$> traverse cvPat b <*> traverse cvHsCmdTop c -- HsBinTick a b c d -> HsBinTick a b c <$> cvLHsExpr d -- HsTickPragma a b c d e -> HsTickPragma a b c d <$> cvLHsExpr e -- HsSpliceE a b -> HsSpliceE a <$> cvHsSplice b -- HsBracket a b -> HsBracket a <$> cvHsBracket b -- HsTick a b c -> HsTick a <$> cvTickish b <*> cvLHsExpr c -- XExpr a -> pure (XExpr a) -- HsArrApp {} -> unsupported "HsArrApp" "HsExpr" (error "") -- HsArrForm {} -> unsupported "HsArrForm" "HsExpr" (error "") -- HsWrap {} -> unsupported "HsWrap" "HsExpr" (error "") -- HsRnBracketOut {} -> unsupported "HsRnBracketOut" "HsExpr" (error "") -- HsTcBracketOut {} -> unsupported "HsTcBracketOut" "HsExpr" (error "") -- --cvHsBracket :: HsBracket GhcSe -> Conv (HsBracket GhcPs) --cvHsBracket (ExpBr a b) = ExpBr a <$> cvLHsExpr b --cvHsBracket (PatBr a b) = PatBr a <$> traverse cvPat b --cvHsBracket (DecBrL a b) = DecBrL a <$> traverse (traverse cvHsDecl) b --cvHsBracket (DecBrG a b) = DecBrG a <$> cvHsGroup b --cvHsBracket (TypBr a b) = TypBr a <$> traverse cvType b --cvHsBracket (VarBr a b c) = VarBr a b <$> convertName c --cvHsBracket (TExpBr a b) = TExpBr a <$> cvLHsExpr b --cvHsBracket (XBracket a) = pure (XBracket a) -- --cvTickish :: ConvertName a b => Tickish a -> Conv (Tickish b) --cvTickish (ProfNote a b c) = pure (ProfNote a b c) --cvTickish (HpcTick a b) = pure (HpcTick a b) --cvTickish (Breakpoint a b) = Breakpoint a <$> convertName b --cvTickish (SourceNote a b) = pure (SourceNote a b) -- --cvHsGroup :: HsGroup GhcSe -> Conv (HsGroup GhcPs) --cvHsGroup (HsGroup a b c d e f g h i j k l) = HsGroup a -- <$> cvHsValBindsLR b <*> traverse (traverse cvSpliceDecl) c -- <*> traverse cvTyClGroup d -- <*> traverse (traverse cvDerivDecl) e -- <*> traverse (traverse cvFixitySig) f -- <*> traverse (traverse cvDefaultDecl) g -- <*> traverse (traverse cvForeignDecl) h -- <*> traverse (traverse cvWarningDecls) i -- <*> traverse (traverse cvAnnDecl) j -- <*> traverse (traverse cvRuleDecls) k -- <*> pure l --cvHsGroup (XHsGroup a) = pure (XHsGroup a) -- --cvTyClGroup :: TyClGroup GhcSe -> Conv (TyClGroup GhcPs) --cvTyClGroup (TyClGroup a b c d) = TyClGroup a -- <$> traverse (traverse cvTyClDecl) b -- <*> traverse (traverse cvRoleAnnotDecl) c -- <*> traverse (traverse cvInstDecl) d --cvTyClGroup (XTyClGroup a) = pure (XTyClGroup a) -- --cvHsCmdTop :: HsCmdTop GhcSe -> Conv (HsCmdTop GhcPs) --cvHsCmdTop (HsCmdTop a b) = HsCmdTop a <$> traverse cvHsCmd b --cvHsCmdTop (XCmdTop a) = pure (XCmdTop a) -- --cvHsCmd :: HsCmd GhcSe -> Conv (HsCmd GhcPs) --cvHsCmd (HsCmdArrApp a b c d e) = HsCmdArrApp a -- <$> cvLHsExpr b <*> cvLHsExpr c <*> pure d <*> pure e --cvHsCmd (HsCmdArrForm a b c d e) = HsCmdArrForm a -- <$> cvLHsExpr b <*> pure c <*> pure d -- <*> traverse (traverse cvHsCmdTop) e --cvHsCmd (HsCmdApp a b c) = HsCmdApp a <$> traverse cvHsCmd b <*> cvLHsExpr c --cvHsCmd (HsCmdLam a b) = HsCmdLam a <$> cvMatchGroup (traverse cvHsCmd) b --cvHsCmd (HsCmdPar a b) = HsCmdPar a <$> traverse cvHsCmd b --cvHsCmd (HsCmdCase a b c) = HsCmdCase a -- <$> cvLHsExpr b <*> cvMatchGroup (traverse cvHsCmd) c --cvHsCmd (HsCmdIf a b c d e) = HsCmdIf a -- <$> traverse cvSyntaxExpr b -- <*> cvLHsExpr c -- <*> traverse cvHsCmd d -- <*> traverse cvHsCmd e --cvHsCmd (HsCmdLet a b c) = HsCmdLet a -- <$> traverse cvHsLocalBinds b <*> traverse cvHsCmd c --cvHsCmd (HsCmdDo a b) = HsCmdDo a -- <$> traverse (traverse (traverse (cvStmtLR (traverse cvHsCmd)))) b --cvHsCmd (HsCmdWrap {}) = unsupported "HsCmdWrap" "HsCmd" (error "") --cvHsCmd (XCmd a) = pure (XCmd a) -- --cvArithSeqInfo :: ArithSeqInfo GhcSe -> Conv (ArithSeqInfo GhcPs) --cvArithSeqInfo (From e) = From <$> cvLHsExpr e --cvArithSeqInfo (FromThen a b) = FromThen <$> cvLHsExpr a <*> cvLHsExpr b --cvArithSeqInfo (FromTo a b) = FromTo <$> cvLHsExpr a <*> cvLHsExpr b --cvArithSeqInfo (FromThenTo a b c) = FromThenTo <$> cvLHsExpr a <*> cvLHsExpr b <*> cvLHsExpr c -- --cvHsTupArg :: HsTupArg GhcSe -> Conv (HsTupArg GhcPs) --cvHsTupArg (Present a b) = Present a <$> cvLHsExpr b --cvHsTupArg (Missing a) = pure (Missing a) --cvHsTupArg (XTupArg a) = pure (XTupArg a) -- --cvAFieldOcc -- :: AmbiguousFieldOcc GhcSe -> Conv (AmbiguousFieldOcc GhcPs) --cvAFieldOcc (Unambiguous a b) = Unambiguous a <$> convertName b --cvAFieldOcc (Ambiguous a b) = Ambiguous a <$> convertName b --cvAFieldOcc (XAmbiguousFieldOcc a) = pure (XAmbiguousFieldOcc a) -- --cvOverLit :: HsOverLit GhcSe -> Conv (HsOverLit GhcPs) --cvOverLit (OverLit a b c) = OverLit a b <$> cvHsExpr c --cvOverLit (XOverLit a) = pure (XOverLit a) -- --cvLit :: HsLit GhcSe -> Conv (HsLit GhcPs) --cvLit (HsChar a b) = pure (HsChar a b) --cvLit (HsCharPrim a b) = pure (HsCharPrim a b) --cvLit (HsString a b) = pure (HsString a b) --cvLit (HsStringPrim a b) = pure (HsStringPrim a b) --cvLit (HsInt a b) = pure (HsInt a b) --cvLit (HsIntPrim a b) = pure (HsIntPrim a b) --cvLit (HsWordPrim a b) = pure (HsWordPrim a b) --cvLit (HsInt64Prim a b) = pure (HsInt64Prim a b) --cvLit (HsWord64Prim a b) = pure (HsWord64Prim a b) --cvLit (HsInteger a b c) = HsInteger a b <$> convertType c --cvLit (HsRat a b c) = HsRat a b <$> convertType c --cvLit (HsFloatPrim a b) = pure (HsFloatPrim a b) --cvLit (HsDoublePrim a b) = pure (HsDoublePrim a b) --cvLit (XLit a) = pure (XLit a) -- --cvMatchGroup -- :: ( XMG GhcSe a ~ XMG GhcPs b -- , XCMatch GhcSe a ~ XCMatch GhcPs b -- , XCGRHSs GhcSe a ~ XCGRHSs GhcPs b -- , XCGRHS GhcSe a ~ XCGRHS GhcPs b -- , XXMatchGroup GhcSe a ~ XXMatchGroup GhcPs b -- , XXMatch GhcSe a ~ XXMatch GhcPs b -- , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b -- , XXGRHS GhcSe a ~ XXGRHS GhcPs b -- ) -- => (a -> Conv b) -> MatchGroup GhcSe a -> Conv (MatchGroup GhcPs b) --cvMatchGroup f (MG a b c) = MG a -- <$> traverse (traverse (traverse (cvMatch f))) b -- <*> pure c --cvMatchGroup _ (XMatchGroup a) = pure (XMatchGroup a) -- --cvMatch -- :: ( XCMatch GhcSe a ~ XCMatch GhcPs b -- , XCGRHSs GhcSe a ~ XCGRHSs GhcPs b -- , XCGRHS GhcSe a ~ XCGRHS GhcPs b -- , XXMatch GhcSe a ~ XXMatch GhcPs b -- , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b -- , XXGRHS GhcSe a ~ XXGRHS GhcPs b -- ) -- => (a -> Conv b) -> Match GhcSe a -> Conv (Match GhcPs b) --cvMatch f (Match a b c d) = Match a -- <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d --cvMatch _ (XMatch a) = pure (XMatch a) -- --cvPat :: Pat GhcSe -> Conv (Pat GhcPs) --cvPat (WildPat a) = pure (WildPat a) --cvPat (VarPat a b) = VarPat a <$> convertName b --cvPat (LazyPat a b) = LazyPat a <$> traverse cvPat b --cvPat (AsPat a b c) = AsPat a <$> convertName b <*> traverse cvPat c --cvPat (ParPat a b) = ParPat a <$> traverse cvPat b --cvPat (BangPat a b) = BangPat a <$> traverse cvPat b --cvPat (ListPat a b) = ListPat a -- <$> traverse (traverse cvPat) b --cvPat (TuplePat a b c) = TuplePat a -- <$> traverse (traverse cvPat) b -- <*> pure c --cvPat (SumPat a b c d) = SumPat a -- <$> traverse cvPat b -- <*> pure c <*> pure d --cvPat (ConPatIn a b) = ConPatIn <$> convertName a <*> cvHsConPatDetails b --cvPat (ViewPat a b c) = ViewPat a <$> cvLHsExpr b <*> traverse cvPat c --cvPat (LitPat a b) = LitPat a <$> cvLit b --cvPat (NPat a b c d) = NPat a -- <$> traverse cvOverLit b <*> traverse cvSyntaxExpr c -- <*> cvSyntaxExpr d --cvPat (NPlusKPat a b c d e f) = NPlusKPat a -- <$> convertName b -- <*> traverse cvOverLit c <*> cvOverLit d -- <*> cvSyntaxExpr e <*> cvSyntaxExpr f --cvPat (SigPat a b) = SigPat <$> cvHsSigWcType a <*> traverse cvPat b --cvPat (SplicePat a b) = SplicePat a <$> cvHsSplice b --cvPat (CoPat {}) = unsupported "CoPat" "Pat" (error "") --cvPat (ConPatOut {}) = unsupported "ConPatOut" "Pat" (error "") --cvPat (XPat a) = pure (XPat a) -- --cvGRHSs -- :: ( XCGRHSs GhcSe a ~ XCGRHSs GhcPs b -- , XCGRHS GhcSe a ~ XCGRHS GhcPs b -- , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b -- , XXGRHS GhcSe a ~ XXGRHS GhcPs b -- ) -- => (a -> Conv b) -> GRHSs GhcSe a -> Conv (GRHSs GhcPs b) --cvGRHSs f (GRHSs a b c) = GRHSs a -- <$> traverse (traverse (cvGRHS f)) b -- <*> traverse cvHsLocalBinds c --cvGRHSs _ (XGRHSs a) = pure (XGRHSs a) -- --cvGRHS -- :: ( XCGRHS GhcSe a ~ XCGRHS GhcPs b -- , XXGRHS GhcSe a ~ XXGRHS GhcPs b -- ) -- => (a -> Conv b) -> GRHS GhcSe a -> Conv (GRHS GhcPs b) --cvGRHS f (GRHS a b c) = GRHS a -- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> f c --cvGRHS _ (XGRHS a) = pure (XGRHS a) -- --cvHsLocalBinds -- :: HsLocalBinds GhcSe -> Conv (HsLocalBinds GhcPs) --cvHsLocalBinds (HsValBinds a b) = HsValBinds a <$> cvHsValBindsLR b --cvHsLocalBinds (HsIPBinds a b) = HsIPBinds a <$> cvHsIPBinds b --cvHsLocalBinds (EmptyLocalBinds a) = pure (EmptyLocalBinds a) --cvHsLocalBinds (XHsLocalBindsLR a) = pure (XHsLocalBindsLR a) -- --cvHsValBindsLR -- :: HsValBindsLR GhcSe GhcSe -> Conv (HsValBindsLR GhcPs GhcPs) --cvHsValBindsLR (ValBinds a b c) = ValBinds a -- <$> mapBagM (traverse cvHsBindLR) b -- <*> traverse (traverse cvSig) c --cvHsValBindsLR (XValBindsLR _) = -- unsupported "XValBindsLR" "HsValBindsLR" (error "") -- --cvHsConPatDetails -- :: HsConPatDetails GhcSe -> Conv (HsConPatDetails GhcPs) --cvHsConPatDetails (PrefixCon a) = PrefixCon <$> traverse (traverse cvPat) a --cvHsConPatDetails (RecCon a) = RecCon <$> cvHsRecFieldsPat a --cvHsConPatDetails (InfixCon a b) = InfixCon -- <$> traverse cvPat a <*> traverse cvPat b -- --cvHsRecFields -- :: (thing -> Conv thing') -- -> HsRecFields GhcSe thing -- -> Conv (HsRecFields GhcPs thing') --cvHsRecFields f (HsRecFields a b) = -- HsRecFields <$> traverse (traverse (cvHsRecField' cvFieldOcc f)) a <*> pure b -- --cvHsRecField' -- :: (id -> Conv id') -- -> (thing -> Conv thing') -- -> HsRecField' id thing -- -> Conv (HsRecField' id' thing') --cvHsRecField' f g (HsRecField a b c) = -- HsRecField <$> traverse f a <*> g b <*> pure c -- --cvHsRecFieldsPat -- :: HsRecFields GhcSe (LPat GhcSe) -> Conv (HsRecFields GhcPs (LPat GhcPs)) --cvHsRecFieldsPat = cvHsRecFields (traverse cvPat) -- --cvHsRecUpdField -- :: HsRecUpdField GhcSe -> Conv (HsRecUpdField GhcPs) --cvHsRecUpdField = cvHsRecField' cvAFieldOcc cvLHsExpr -- --cvRecordBinds -- :: HsRecordBinds GhcSe -> Conv (HsRecordBinds GhcPs) --cvRecordBinds = cvHsRecFields cvLHsExpr -- --cvFieldOcc :: FieldOcc GhcSe -> Conv (FieldOcc GhcPs) --cvFieldOcc (FieldOcc a b) = FieldOcc a <$> convertName b --cvFieldOcc (XFieldOcc a) = pure (XFieldOcc a) -- --cvStmtLR -- :: ( XLastStmt GhcSe GhcSe a ~ XLastStmt GhcPs GhcPs b -- , XBindStmt GhcSe GhcSe a ~ XBindStmt GhcPs GhcPs b -- , XBodyStmt GhcSe GhcSe a ~ XBodyStmt GhcPs GhcPs b -- , XApplicativeStmt GhcSe GhcSe a ~ XApplicativeStmt GhcPs GhcPs b -- , XLetStmt GhcSe GhcSe a ~ XLetStmt GhcPs GhcPs b -- , XRecStmt GhcSe GhcSe a ~ XRecStmt GhcPs GhcPs b -- , XParStmt GhcSe GhcSe a ~ XParStmt GhcPs GhcPs b -- , XTransStmt GhcSe GhcSe a ~ XTransStmt GhcPs GhcPs b -- , XXStmtLR GhcSe GhcSe a ~ XXStmtLR GhcPs GhcPs b -- ) -- => (a -> Conv b) -> StmtLR GhcSe GhcSe a -> Conv (StmtLR GhcPs GhcPs b) --cvStmtLR k (LastStmt a b c d) = LastStmt a -- <$> k b <*> pure c <*> cvSyntaxExpr d --cvStmtLR k (BindStmt a b c d e) = BindStmt a -- <$> traverse cvPat b <*> k c -- <*> cvSyntaxExpr d <*> cvSyntaxExpr e --cvStmtLR k (BodyStmt a b c d) = BodyStmt a -- <$> k b <*> cvSyntaxExpr c -- <*> cvSyntaxExpr d --cvStmtLR _ (ApplicativeStmt a b c) = ApplicativeStmt a -- <$> traverse -- (\(se, aa) -> (,) <$> cvSyntaxExpr se <*> cvApplicativeArg aa) -- b -- <*> traverse cvSyntaxExpr c --cvStmtLR _ (LetStmt a b) = LetStmt a <$> traverse cvHsLocalBinds b --cvStmtLR k (RecStmt a b c d e f g) = RecStmt a -- <$> traverse (traverse (cvStmtLR k)) b -- <*> convertName c -- <*> convertName d -- <*> cvSyntaxExpr e -- <*> cvSyntaxExpr f -- <*> cvSyntaxExpr g --cvStmtLR _ (ParStmt a b c d) = ParStmt a -- <$> traverse cvParStmtBlock b -- <*> cvHsExpr c -- <*> cvSyntaxExpr d --cvStmtLR _ (TransStmt a b c d e f g h i) = TransStmt a b -- <$> traverse (traverse (cvStmtLR cvLHsExpr)) c -- <*> traverse (\(x, y) -> (,) <$> convertName x <*> convertName y) d -- <*> cvLHsExpr e -- <*> traverse cvLHsExpr f -- <*> cvSyntaxExpr g -- <*> cvSyntaxExpr h -- <*> cvHsExpr i --cvStmtLR _ (XStmtLR a) = pure (XStmtLR a) -- --cvParStmtBlock -- :: ParStmtBlock GhcSe GhcSe -> Conv (ParStmtBlock GhcPs GhcPs) --cvParStmtBlock (ParStmtBlock a b c d) = ParStmtBlock a -- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b -- <*> convertName c -- <*> cvSyntaxExpr d --cvParStmtBlock (XParStmtBlock a) = pure (XParStmtBlock a) -- --cvSyntaxExpr :: SyntaxExpr GhcSe -> Conv (SyntaxExpr GhcPs) --cvSyntaxExpr (SyntaxExpr a b c) = -- SyntaxExpr <$> cvHsExpr a <*> pure b <*> pure c -- --cvHsIPBinds -- :: HsIPBinds GhcSe -> Conv (HsIPBinds GhcPs) --cvHsIPBinds (IPBinds a b) = IPBinds a <$> traverse (traverse cvIPBind) b --cvHsIPBinds (XHsIPBinds a) = pure (XHsIPBinds a) -- --cvIPBind :: IPBind GhcSe -> Conv (IPBind GhcPs) --cvIPBind (IPBind a b c) = IPBind a <$> convertName b <*> cvLHsExpr c --cvIPBind (XIPBind a) = pure (XIPBind a) -- --cvHsBindLR -- :: HsBindLR GhcSe GhcSe -> Conv (HsBindLR GhcPs GhcPs) --cvHsBindLR (FunBind a b c d e) = FunBind a -- <$> convertName b -- <*> cvMatchGroup cvLHsExpr c -- <*> pure d <*> pure e --cvHsBindLR (PatBind a b c d ) = PatBind a -- <$> traverse cvPat b <*> cvGRHSs cvLHsExpr c <*> pure d --cvHsBindLR (VarBind a b c d) = VarBind a -- <$> convertName b <*> cvLHsExpr c <*> pure d --cvHsBindLR (PatSynBind a b) = PatSynBind a <$> cvPatSynBind b --cvHsBindLR (AbsBinds {}) = -- unsupported "AbsBind" "HsBindLR" (error "") --cvHsBindLR (XHsBindsLR a) = pure (XHsBindsLR a) -- --cvHsWildCardBndrs -- :: ( XHsWC GhcSe thing ~ XHsWC GhcPs thing' -- , XXHsWildCardBndrs GhcSe thing ~ XXHsWildCardBndrs GhcPs thing' -- ) -- => (thing -> Conv thing') -- -> HsWildCardBndrs GhcSe thing -- -> Conv (HsWildCardBndrs GhcPs thing') --cvHsWildCardBndrs thingF (HsWC a b) = HsWC a <$> thingF b --cvHsWildCardBndrs _ (XHsWildCardBndrs a) = pure (XHsWildCardBndrs a) -- --cvLHsWcType -- :: LHsWcType GhcSe -> Conv (LHsWcType GhcPs) --cvLHsWcType = cvHsWildCardBndrs (traverse cvType) -- --cvHsSigWcType -- :: LHsSigWcType GhcSe -> Conv (LHsSigWcType GhcPs) --cvHsSigWcType = cvHsWildCardBndrs (cvHsImplicitBndrs (traverse cvType)) -- --cvHsImplicitBndrs -- :: ( XHsIB GhcSe thing ~ XHsIB GhcPs thing' -- , XXHsImplicitBndrs GhcSe thing ~ XXHsImplicitBndrs GhcPs thing' -- ) -- => (thing -> Conv thing') -- -> HsImplicitBndrs GhcSe thing -- -> Conv (HsImplicitBndrs GhcPs thing') --cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b --cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) -- --cvType :: HsType GhcSe -> Conv (HsType GhcPs) --cvType (HsForAllTy a b c) = HsForAllTy a -- <$> traverse (traverse cvHsTyVarBndr) b -- <*> traverse cvType c --cvType (HsQualTy a b c) = HsQualTy a -- <$> traverse (traverse (traverse cvType)) b -- <*> traverse cvType c --cvType (HsTyVar a b c) = HsTyVar a b <$> convertName c --cvType (HsAppTy a b c) = HsAppTy a -- <$> traverse cvType b -- <*> traverse cvType c --cvType (HsFunTy a b c) = HsFunTy a -- <$> traverse cvType b -- <*> traverse cvType c --cvType (HsListTy a b) = HsListTy a <$> traverse cvType b --cvType (HsTupleTy a b c) = HsTupleTy a b <$> traverse (traverse cvType) c --cvType (HsSumTy a b) = HsSumTy a <$> traverse (traverse cvType) b --cvType (HsOpTy a b c d) = HsOpTy a -- <$> traverse cvType b -- <*> convertName c -- <*> traverse cvType d --cvType (HsParTy a b) = HsParTy a <$> traverse cvType b --cvType (HsIParamTy a b c) = HsIParamTy a b <$> traverse cvType c --cvType (HsKindSig a b c) = HsKindSig a -- <$> traverse cvType b -- <*> traverse cvType c --cvType (HsBangTy a b c) = HsBangTy a b <$> traverse cvType c --cvType (HsRecTy a b) = HsRecTy a <$> traverse (traverse cvConDeclField) b --cvType (HsExplicitListTy a b c) = HsExplicitListTy a b -- <$> traverse (traverse cvType) c --cvType (HsExplicitTupleTy a b) = HsExplicitTupleTy a -- <$> traverse (traverse cvType) b --cvType (HsTyLit a b) = pure (HsTyLit a b) --cvType (HsWildCardTy a) = pure (HsWildCardTy a) --cvType (HsDocTy a b c) = HsDocTy a <$> traverse cvType b <*> pure c --cvType (HsSpliceTy a b) = HsSpliceTy a <$> cvHsSplice b --cvType (HsStarTy a b) = pure (HsStarTy a b) --cvType (XHsType a) = pure (XHsType a) -- --cvHsTyVarBndr -- :: HsTyVarBndr GhcSe -> Conv (HsTyVarBndr GhcPs) --cvHsTyVarBndr (UserTyVar a b) = UserTyVar a <$> convertName b --cvHsTyVarBndr (KindedTyVar a b c) = KindedTyVar a -- <$> convertName b -- <*> traverse cvType c --cvHsTyVarBndr (XTyVarBndr a) = pure (XTyVarBndr a) -- --cvApplicativeArg -- :: ApplicativeArg GhcSe -> Conv (ApplicativeArg GhcPs) --cvApplicativeArg (ApplicativeArgOne a b c d) = ApplicativeArgOne a -- <$> traverse cvPat b <*> cvLHsExpr c <*> pure d --cvApplicativeArg (ApplicativeArgMany a b c d) = ApplicativeArgMany a -- <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> cvHsExpr c -- <*> traverse cvPat d --cvApplicativeArg (XApplicativeArg a) = pure (XApplicativeArg a) -- --cvSig :: Sig GhcSe -> Conv (Sig GhcPs) --cvSig (TypeSig a b c) = TypeSig a <$> convertName b <*> cvHsSigWcType c --cvSig (PatSynSig a b c) = PatSynSig a -- <$> convertName b <*> cvHsImplicitBndrs (traverse cvType) c --cvSig (ClassOpSig a b c d) = ClassOpSig a b -- <$> convertName c <*> cvHsImplicitBndrs (traverse cvType) d --cvSig (InlineSig a b c) = InlineSig a <$> convertName b <*> pure c --cvSig (FixSig a b) = FixSig a <$> cvFixitySig b --cvSig (SpecSig a b c d) = SpecSig a -- <$> convertName b -- <*> traverse (cvHsImplicitBndrs (traverse cvType)) c -- <*> pure d --cvSig (SpecInstSig a b c) = SpecInstSig a b -- <$> cvHsImplicitBndrs (traverse cvType) c --cvSig (SCCFunSig a b c d) = SCCFunSig a b <$> convertName c <*> pure d --cvSig (CompleteMatchSig a b c d) = CompleteMatchSig a b -- <$> convertName c <*> convertName d --cvSig (MinimalSig a b c) = MinimalSig a b <$> traverse (traverse convertName) c --cvSig (IdSig {}) = unsupported "IdSig" "Sig" (error "") --cvSig (XSig a) = pure (XSig a) -- --cvFixitySig :: FixitySig GhcSe -> Conv (FixitySig GhcPs) --cvFixitySig (FixitySig a b c) = FixitySig a <$> convertName b <*> pure c --cvFixitySig (XFixitySig a) = pure (XFixitySig a) -- --cvPatSynBind :: PatSynBind GhcSe GhcSe -> Conv (PatSynBind GhcPs GhcPs) --cvPatSynBind (PSB a b c d e) = PSB a -- <$> convertName b -- <*> cvHsPatSynDetails convertName c <*> traverse cvPat d -- <*> cvHsPatSynDir e --cvPatSynBind (XPatSynBind a) = pure (XPatSynBind a) -- --cvHsPatSynDetails -- :: (a -> Conv b) -- -> HsPatSynDetails a -- -> Conv (HsPatSynDetails b) --cvHsPatSynDetails f = cvHsConDetails f (traverse (cvRecordPatSynField f)) -- --cvRecordPatSynField -- :: (a -> Conv b) -- -> RecordPatSynField a -- -> Conv (RecordPatSynField b) --cvRecordPatSynField f (RecordPatSynField a b) = -- RecordPatSynField <$> f a <*> f b -- --cvHsPatSynDir :: HsPatSynDir GhcSe -> Conv (HsPatSynDir GhcPs) --cvHsPatSynDir Unidirectional = pure Unidirectional --cvHsPatSynDir ImplicitBidirectional = pure ImplicitBidirectional --cvHsPatSynDir (ExplicitBidirectional a) = ExplicitBidirectional -- <$> cvMatchGroup cvLHsExpr a +new file mode 100644 +index 0000000000..839564fbfe +--- /dev/null ++++ b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs +@@ -0,0 +1,812 @@ ++{-# LANGUAGE GADTs #-} ++module HsExprBin_ConversionPS2SE where ++ ++import Control.Applicative ++import Data.Traversable ++ ++import Bag (mapBagM) ++import Class ++import CoreSyn ( Tickish(..) ) ++import GhcPrelude ++import HsBinds ++import HsDecls ++import HsExpr ++import HsExprBin_Conversions ++import HsExtension ++import HsLit ++import HsPat ++import HsTypes ++ ++-- * Conversion from serialisable ASTs to parsed ASTs ++ ++cvLHsDecl :: LHsDecl GhcPs -> Conv (LHsDecl GhcSe) ++cvLHsDecl = traverse cvHsDecl ++ ++cvHsDecl :: HsDecl GhcPs -> Conv (HsDecl GhcSe) ++cvHsDecl (TyClD a b) = TyClD <$> pure a <*> cvTyClDecl b ++cvHsDecl (InstD a b) = InstD <$> pure a <*> cvInstDecl b ++cvHsDecl (DerivD a b) = DerivD <$> pure a <*> cvDerivDecl b ++cvHsDecl (ValD a b) = ValD <$> pure a <*> cvHsBindLR b ++cvHsDecl (SigD a b) = SigD <$> pure a <*> cvSig b ++cvHsDecl (DefD a b) = DefD <$> pure a <*> cvDefaultDecl b ++cvHsDecl (ForD a b) = ForD <$> pure a <*> cvForeignDecl b ++cvHsDecl (WarningD a b) = WarningD <$> pure a <*> cvWarningDecls b ++cvHsDecl (RoleAnnotD a b) = RoleAnnotD <$> pure a <*> cvRoleAnnotDecl b ++cvHsDecl (AnnD a b) = AnnD <$> pure a <*> cvAnnDecl b ++cvHsDecl (RuleD a b) = RuleD <$> pure a <*> cvRuleDecls b ++cvHsDecl (SpliceD a b) = SpliceD <$> pure a <*> cvSpliceDecl b ++cvHsDecl (DocD a b) = pure (DocD a b) ++cvHsDecl (XHsDecl a) = pure (XHsDecl a) ++ ++cvAnnDecl :: AnnDecl GhcPs -> Conv (AnnDecl GhcSe) ++cvAnnDecl (HsAnnotation a b c d) = ++ HsAnnotation a b <$> cvAnnProvenance c <*> cvLHsExpr d ++cvAnnDecl (XAnnDecl a) = pure (XAnnDecl a) ++ ++cvInstDecl :: InstDecl GhcPs -> Conv (InstDecl GhcSe) ++cvInstDecl (ClsInstD a b) = ClsInstD a <$> cvClsInstDecl b ++cvInstDecl (DataFamInstD a b) = DataFamInstD a <$> cvDataFamInstDecl b ++cvInstDecl (TyFamInstD a b) = TyFamInstD a <$> cvTyFamInstDecl b ++cvInstDecl (XInstDecl a) = pure (XInstDecl a) ++ ++cvClsInstDecl :: ClsInstDecl GhcPs -> Conv (ClsInstDecl GhcSe) ++cvClsInstDecl (ClsInstDecl a b c d e f g) = ++ ClsInstDecl a ++ <$> cvHsImplicitBndrs (traverse cvType) b ++ <*> mapBagM (traverse cvHsBindLR) c ++ <*> traverse (traverse cvSig) d ++ <*> traverse (traverse cvTyFamInstDecl) e ++ <*> traverse (traverse cvDataFamInstDecl) f ++ <*> pure g ++cvClsInstDecl (XClsInstDecl a) = pure (XClsInstDecl a) ++ ++cvDerivDecl :: DerivDecl GhcPs -> Conv (DerivDecl GhcSe) ++cvDerivDecl (DerivDecl a b c d) = ++ DerivDecl a <$> cvHsWildCardBndrs (cvHsImplicitBndrs $ traverse cvType) b ++ <*> traverse (traverse cvDerivStrategy) c ++ <*> pure d ++cvDerivDecl (XDerivDecl a) = pure (XDerivDecl a) ++ ++cvDerivStrategy ++ :: DerivStrategy GhcPs -> Conv (DerivStrategy GhcSe) ++cvDerivStrategy StockStrategy = pure StockStrategy ++cvDerivStrategy AnyclassStrategy = pure AnyclassStrategy ++cvDerivStrategy NewtypeStrategy = pure NewtypeStrategy ++cvDerivStrategy (ViaStrategy a) = ViaStrategy ++ <$> cvHsImplicitBndrs (traverse cvType) a ++ ++cvTyClDecl :: TyClDecl GhcPs -> Conv (TyClDecl GhcSe) ++cvTyClDecl (FamDecl a b) = FamDecl <$> pure a <*> cvFamilyDecl b ++cvTyClDecl (SynDecl a b c d e) = ++ SynDecl a ++ <$> convertName b ++ <*> cvLHsQTyVars c <*> pure d ++ <*> traverse cvType e ++cvTyClDecl (DataDecl a b c d e) = ++ DataDecl a ++ <$> convertName b ++ <*> cvLHsQTyVars c <*> pure d ++ <*> cvHsDataDefn e ++cvTyClDecl (ClassDecl a b c d e f g h i j k) = ++ ClassDecl a ++ <$> traverse (traverse (traverse cvType)) b ++ <*> convertName c ++ <*> cvLHsQTyVars d ++ <*> pure e ++ <*> traverse (traverse cvFunDep) f ++ <*> traverse (traverse cvSig) g ++ <*> mapBagM (traverse cvHsBindLR) h ++ <*> traverse (traverse cvFamilyDecl) i ++ <*> traverse (traverse $ cvFamEqn cvLHsQTyVars (traverse cvType)) j ++ <*> pure k ++cvTyClDecl (XTyClDecl a) = pure (XTyClDecl a) ++ ++cvRoleAnnotDecl :: RoleAnnotDecl GhcPs -> Conv (RoleAnnotDecl GhcSe) ++cvRoleAnnotDecl (RoleAnnotDecl a b c) = ++ RoleAnnotDecl a <$> convertName b <*> pure c ++cvRoleAnnotDecl (XRoleAnnotDecl a) = pure (XRoleAnnotDecl a) ++ ++cvRuleDecls :: RuleDecls GhcPs -> Conv (RuleDecls GhcSe) ++cvRuleDecls (HsRules a b c) = HsRules a b <$> traverse (traverse cvRuleDecl) c ++cvRuleDecls (XRuleDecls a) = pure (XRuleDecls a) ++ ++cvRuleDecl :: RuleDecl GhcPs -> Conv (RuleDecl GhcSe) ++cvRuleDecl (HsRule a b c d e f) = ++ HsRule a b c <$> traverse (traverse cvRuleBndr) d ++ <*> cvLHsExpr e <*> cvLHsExpr f ++cvRuleDecl (XRuleDecl a) = pure (XRuleDecl a) ++ ++cvSpliceDecl :: SpliceDecl GhcPs -> Conv (SpliceDecl GhcSe) ++cvSpliceDecl (SpliceDecl a b c) = ++ SpliceDecl a <$> traverse cvHsSplice b <*> pure c ++cvSpliceDecl (XSpliceDecl a) = pure (XSpliceDecl a) ++ ++cvHsSplice :: HsSplice GhcPs -> Conv (HsSplice GhcSe) ++cvHsSplice (HsTypedSplice a b c d) = ++ HsTypedSplice a b <$> convertName c <*> cvLHsExpr d ++cvHsSplice (HsUntypedSplice a b c d) = ++ HsUntypedSplice a b <$> convertName c <*> cvLHsExpr d ++cvHsSplice (HsQuasiQuote a b c d e) = ++ HsQuasiQuote a <$> convertName b <*> convertName c <*> pure d <*> pure e ++cvHsSplice (HsSpliced {}) = ++ unsupported "HsSpliced" "HsSplice" (error "") ++cvHsSplice (XSplice a) = pure (XSplice a) ++ ++cvRuleBndr :: RuleBndr GhcPs -> Conv (RuleBndr GhcSe) ++cvRuleBndr (RuleBndr a b) = RuleBndr a <$> convertName b ++cvRuleBndr (RuleBndrSig a b c) = ++ RuleBndrSig a <$> convertName b <*> cvHsSigWcType c ++cvRuleBndr (XRuleBndr a) = pure (XRuleBndr a) ++ ++cvFamEqn ++ :: ( XCFamEqn GhcPs a b ~ XCFamEqn GhcSe c d ++ , XXFamEqn GhcPs a b ~ XXFamEqn GhcSe c d ++ ) ++ => (a -> Conv c) ++ -> (b -> Conv d) ++ -> FamEqn GhcPs a b ++ -> Conv (FamEqn GhcSe c d) ++cvFamEqn goPats goRhs (FamEqn a b c d e) = ++ FamEqn a <$> convertName b <*> goPats c <*> pure d <*> goRhs e ++cvFamEqn _ _ (XFamEqn a) = pure (XFamEqn a) ++ ++cvFamilyDecl :: FamilyDecl GhcPs -> Conv (FamilyDecl GhcSe) ++cvFamilyDecl (FamilyDecl a b c d e f g) = ++ FamilyDecl a ++ <$> cvFamilyInfo b <*> convertName c ++ <*> cvLHsQTyVars d <*> pure e ++ <*> traverse cvFamilyResultSig f ++ <*> traverse (traverse cvInjectivityAnn) g ++cvFamilyDecl (XFamilyDecl a) = pure (XFamilyDecl a) ++ ++cvAnnProvenance :: ConvertName a b => AnnProvenance a -> Conv (AnnProvenance b) ++cvAnnProvenance (ValueAnnProvenance a) = ValueAnnProvenance <$> convertName a ++cvAnnProvenance (TypeAnnProvenance a) = TypeAnnProvenance <$> convertName a ++cvAnnProvenance ModuleAnnProvenance = pure ModuleAnnProvenance ++ ++cvInjectivityAnn ++ :: InjectivityAnn GhcPs -> Conv (InjectivityAnn GhcSe) ++cvInjectivityAnn (InjectivityAnn a b) = ++ InjectivityAnn <$> convertName a <*> convertName b ++ ++cvFamilyResultSig ++ :: FamilyResultSig GhcPs -> Conv (FamilyResultSig GhcSe) ++cvFamilyResultSig (NoSig a) = pure (NoSig a) ++cvFamilyResultSig (KindSig a b) = KindSig a <$> traverse cvType b ++cvFamilyResultSig (TyVarSig a b) = TyVarSig a <$> traverse cvHsTyVarBndr b ++cvFamilyResultSig (XFamilyResultSig a) = pure (XFamilyResultSig a) ++ ++cvFamilyInfo ++ :: FamilyInfo GhcPs -> Conv (FamilyInfo GhcSe) ++cvFamilyInfo DataFamily = pure DataFamily ++cvFamilyInfo OpenTypeFamily = pure OpenTypeFamily ++cvFamilyInfo (ClosedTypeFamily a) = ++ ClosedTypeFamily <$> traverse (traverse (traverse (cvFamInstEqn (traverse cvType)))) a ++ ++cvFamInstEqn ++ :: ( XCFamEqn GhcPs (HsTyPats GhcPs) a ++ ~ XCFamEqn GhcSe (HsTyPats GhcSe) b ++ , XHsIB GhcPs (FamEqn GhcPs (HsTyPats p) a) ++ ~ XHsIB GhcSe (FamEqn GhcSe (HsTyPats GhcSe) b) ++ , XXFamEqn GhcPs (HsTyPats GhcPs) a ++ ~ XXFamEqn GhcSe (HsTyPats GhcSe) b ++ , XXHsImplicitBndrs GhcPs (FamEqn GhcPs (HsTyPats GhcPs) a) ++ ~ XXHsImplicitBndrs GhcSe (FamEqn GhcSe (HsTyPats GhcSe) b) ++ ) ++ => (a -> Conv b) ++ -> FamInstEqn GhcPs a ++ -> Conv (FamInstEqn GhcSe b) ++cvFamInstEqn f = cvHsImplicitBndrs (cvFamEqn (traverse (traverse cvType)) f) ++ ++cvFunDep :: ConvertName a b => FunDep a -> Conv (FunDep b) ++cvFunDep (xs, ys) = (,) <$> convertName xs <*> convertName ys ++ ++cvLHsQTyVars :: LHsQTyVars GhcPs -> Conv (LHsQTyVars GhcSe) ++cvLHsQTyVars (HsQTvs a b) = HsQTvs a <$> traverse (traverse cvHsTyVarBndr) b ++cvLHsQTyVars (XLHsQTyVars a) = pure (XLHsQTyVars a) ++ ++cvForeignDecl :: ForeignDecl GhcPs -> Conv (ForeignDecl GhcSe) ++cvForeignDecl (ForeignImport a b c d) = ++ ForeignImport a ++ <$> convertName b ++ <*> cvHsImplicitBndrs (traverse cvType) c ++ <*> pure d ++cvForeignDecl (ForeignExport a b c d) = ++ ForeignExport a ++ <$> convertName b ++ <*> cvHsImplicitBndrs (traverse cvType) c ++ <*> pure d ++cvForeignDecl (XForeignDecl a) = pure (XForeignDecl a) ++ ++cvDefaultDecl :: DefaultDecl GhcPs -> Conv (DefaultDecl GhcSe) ++cvDefaultDecl (DefaultDecl a b) = DefaultDecl a <$> traverse (traverse cvType) b ++cvDefaultDecl (XDefaultDecl a) = pure (XDefaultDecl a) ++ ++cvTyFamInstDecl ++ :: TyFamInstDecl GhcPs -> Conv (TyFamInstDecl GhcSe) ++cvTyFamInstDecl (TyFamInstDecl d) = ++ TyFamInstDecl <$> cvFamInstEqn (traverse cvType) d ++ ++cvDataFamInstDecl ++ :: DataFamInstDecl GhcPs -> Conv (DataFamInstDecl GhcSe) ++cvDataFamInstDecl (DataFamInstDecl d) = ++ DataFamInstDecl <$> cvFamInstEqn cvHsDataDefn d ++ ++cvHsDataDefn :: HsDataDefn GhcPs -> Conv (HsDataDefn GhcSe) ++cvHsDataDefn (HsDataDefn a b c d e f g) = ++ HsDataDefn a b ++ <$> traverse (traverse (traverse cvType)) c <*> pure d ++ <*> traverse (traverse cvType) e ++ <*> traverse (traverse cvConDecl) f <*> cvHsDeriving g ++cvHsDataDefn (XHsDataDefn a) = pure (XHsDataDefn a) ++ ++cvConDecl :: ConDecl GhcPs -> Conv (ConDecl GhcSe) ++cvConDecl (ConDeclGADT a b c d e f g h) = ++ ConDeclGADT a ++ <$> convertName b ++ <*> pure c ++ <*> cvLHsQTyVars d ++ <*> traverse (traverse (traverse (traverse cvType))) e ++ <*> cvHsConDeclDetails f ++ <*> traverse cvType g ++ <*> pure h ++cvConDecl (ConDeclH98 a b c d e f g) = ++ ConDeclH98 a ++ <$> convertName b ++ <*> pure c ++ <*> traverse (traverse cvHsTyVarBndr) d ++ <*> traverse (traverse (traverse (traverse cvType))) e ++ <*> cvHsConDeclDetails f ++ <*> pure g ++cvConDecl (XConDecl a) = pure (XConDecl a) ++ ++cvHsDeriving :: HsDeriving GhcPs -> Conv (HsDeriving GhcSe) ++cvHsDeriving = traverse (traverse (traverse cvHsDerivingClause)) ++ ++cvHsDerivingClause ++ :: HsDerivingClause GhcPs -> Conv (HsDerivingClause GhcSe) ++cvHsDerivingClause (HsDerivingClause a b c) = ++ HsDerivingClause a ++ <$> traverse (traverse cvDerivStrategy) b ++ <*> traverse (traverse (cvHsImplicitBndrs (traverse cvType))) c ++cvHsDerivingClause (XHsDerivingClause a) = pure (XHsDerivingClause a) ++ ++cvHsConDeclDetails ++ :: HsConDeclDetails GhcPs -> Conv (HsConDeclDetails GhcSe) ++cvHsConDeclDetails = ++ cvHsConDetails (traverse cvType) ++ (traverse (traverse (traverse cvConDeclField))) ++ ++cvHsConDetails ++ :: (a -> Conv c) -> (b -> Conv d) -> HsConDetails a b -> Conv (HsConDetails c d) ++cvHsConDetails f _ (PrefixCon a) = PrefixCon <$> traverse f a ++cvHsConDetails _ g (RecCon a) = RecCon <$> g a ++cvHsConDetails f _ (InfixCon a b) = InfixCon <$> f a <*> f b ++ ++cvConDeclField :: ConDeclField GhcPs -> Conv (ConDeclField GhcSe) ++cvConDeclField (ConDeclField a b c d) = ++ ConDeclField a <$> traverse (traverse cvFieldOcc) b <*> traverse cvType c ++ <*> pure d ++cvConDeclField (XConDeclField a) = pure (XConDeclField a) ++ ++cvWarningDecls :: WarnDecls GhcPs -> Conv (WarnDecls GhcSe) ++cvWarningDecls (Warnings a b c) = ++ Warnings a b <$> traverse (traverse cvWarningDecl) c ++cvWarningDecls (XWarnDecls a) = pure (XWarnDecls a) ++ ++cvWarningDecl :: WarnDecl GhcPs -> Conv (WarnDecl GhcSe) ++cvWarningDecl (Warning a b c) = Warning a <$> convertName b <*> pure c ++cvWarningDecl (XWarnDecl a) = pure (XWarnDecl a) ++ ++-- expressions ++ ++cvLHsExpr :: LHsExpr GhcPs -> Conv (LHsExpr GhcSe) ++cvLHsExpr = traverse cvHsExpr ++ ++cvHsExpr :: HsExpr GhcPs -> Conv (HsExpr GhcSe) ++cvHsExpr e = case e of ++ HsVar a b -> HsVar a <$> convertName b ++ HsUnboundVar a b -> pure (HsUnboundVar a b) ++ HsConLikeOut a b -> pure (HsConLikeOut a b) ++ HsRecFld a b -> HsRecFld a <$> cvAFieldOcc b ++ HsOverLabel a b c -> HsOverLabel a <$> convertName b <*> pure c ++ HsIPVar a b -> pure (HsIPVar a b) ++ HsOverLit a b -> HsOverLit a <$> cvOverLit b ++ HsLit a b -> HsLit a <$> cvLit b ++ HsLam a b -> HsLam a <$> cvMatchGroup cvLHsExpr b ++ HsLamCase a b -> HsLamCase a <$> cvMatchGroup cvLHsExpr b ++ HsApp a b c -> HsApp a <$> cvLHsExpr b <*> cvLHsExpr c ++ HsAppType a b -> HsAppType <$> cvLHsWcType a <*> cvLHsExpr b ++ OpApp a b c d -> OpApp a <$> cvLHsExpr b <*> cvLHsExpr c <*> cvLHsExpr d ++ NegApp a b c -> NegApp a <$> cvLHsExpr b <*> cvSyntaxExpr c ++ HsPar a b -> HsPar a <$> cvLHsExpr b ++ SectionL a b c -> SectionL a <$> cvLHsExpr b <*> cvLHsExpr c ++ SectionR a b c -> SectionR a <$> cvLHsExpr b <*> cvLHsExpr c ++ ExplicitTuple a b c -> ExplicitTuple a <$> traverse (traverse cvHsTupArg) b ++ <*> pure c ++ ExplicitSum a b c d -> ExplicitSum a b c <$> cvLHsExpr d ++ ExplicitList a b c -> ExplicitList a <$> traverse cvSyntaxExpr b <*> traverse cvLHsExpr c ++ HsCase a b c -> HsCase a <$> cvLHsExpr b <*> cvMatchGroup cvLHsExpr c ++ HsIf a b c d e -> HsIf a <$> traverse cvSyntaxExpr b ++ <*> cvLHsExpr c <*> cvLHsExpr d <*> cvLHsExpr e ++ HsMultiIf a b -> HsMultiIf a <$> traverse (traverse (cvGRHS cvLHsExpr)) b ++ HsLet a b c -> HsLet a <$> traverse cvHsLocalBinds b <*> cvLHsExpr c ++ HsDo a b c -> HsDo a ++ <$> convertName b <*> traverse (traverse (traverse (cvStmtLR cvLHsExpr))) c ++ RecordCon a b c -> RecordCon a <$> convertName b <*> cvRecordBinds c ++ RecordUpd a b c -> RecordUpd a <$> cvLHsExpr b ++ <*> traverse (traverse cvHsRecUpdField) c ++ ExprWithTySig a b -> ExprWithTySig <$> cvHsSigWcType a <*> cvLHsExpr b ++ ArithSeq a b c -> ArithSeq a <$> traverse cvSyntaxExpr b <*> cvArithSeqInfo c ++ HsSCC a b c d -> HsSCC a b c <$> cvLHsExpr d ++ HsCoreAnn a b c d -> HsCoreAnn a b c <$> cvLHsExpr d ++ HsStatic a b -> HsStatic a <$> cvLHsExpr b ++ EWildPat a -> pure (EWildPat a) ++ EAsPat a b c -> EAsPat a <$> convertName b <*> cvLHsExpr c ++ EViewPat a b c -> EViewPat a <$> cvLHsExpr b <*> cvLHsExpr c ++ ELazyPat a b -> ELazyPat a <$> cvLHsExpr b ++ HsProc a b c -> HsProc a <$> traverse cvPat b <*> traverse cvHsCmdTop c ++ HsBinTick a b c d -> HsBinTick a b c <$> cvLHsExpr d ++ HsTickPragma a b c d e -> HsTickPragma a b c d <$> cvLHsExpr e ++ HsSpliceE a b -> HsSpliceE a <$> cvHsSplice b ++ HsBracket a b -> HsBracket a <$> cvHsBracket b ++ HsTick a b c -> HsTick a <$> cvTickish b <*> cvLHsExpr c ++ XExpr a -> pure (XExpr a) ++ HsArrApp {} -> unsupported "HsArrApp" "HsExpr" (error "") ++ HsArrForm {} -> unsupported "HsArrForm" "HsExpr" (error "") ++ HsWrap {} -> unsupported "HsWrap" "HsExpr" (error "") ++ HsRnBracketOut {} -> unsupported "HsRnBracketOut" "HsExpr" (error "") ++ HsTcBracketOut {} -> unsupported "HsTcBracketOut" "HsExpr" (error "") ++ ++cvHsBracket :: HsBracket GhcPs -> Conv (HsBracket GhcSe) ++cvHsBracket (ExpBr a b) = ExpBr a <$> cvLHsExpr b ++cvHsBracket (PatBr a b) = PatBr a <$> traverse cvPat b ++cvHsBracket (DecBrL a b) = DecBrL a <$> traverse (traverse cvHsDecl) b ++cvHsBracket (DecBrG a b) = DecBrG a <$> cvHsGroup b ++cvHsBracket (TypBr a b) = TypBr a <$> traverse cvType b ++cvHsBracket (VarBr a b c) = VarBr a b <$> convertName c ++cvHsBracket (TExpBr a b) = TExpBr a <$> cvLHsExpr b ++cvHsBracket (XBracket a) = pure (XBracket a) ++ ++cvTickish :: ConvertName a b => Tickish a -> Conv (Tickish b) ++cvTickish (ProfNote a b c) = pure (ProfNote a b c) ++cvTickish (HpcTick a b) = pure (HpcTick a b) ++cvTickish (Breakpoint a b) = Breakpoint a <$> convertName b ++cvTickish (SourceNote a b) = pure (SourceNote a b) ++ ++cvHsGroup :: HsGroup GhcPs -> Conv (HsGroup GhcSe) ++cvHsGroup (HsGroup a b c d e f g h i j k l) = HsGroup a ++ <$> cvHsValBindsLR b <*> traverse (traverse cvSpliceDecl) c ++ <*> traverse cvTyClGroup d ++ <*> traverse (traverse cvDerivDecl) e ++ <*> traverse (traverse cvFixitySig) f ++ <*> traverse (traverse cvDefaultDecl) g ++ <*> traverse (traverse cvForeignDecl) h ++ <*> traverse (traverse cvWarningDecls) i ++ <*> traverse (traverse cvAnnDecl) j ++ <*> traverse (traverse cvRuleDecls) k ++ <*> pure l ++cvHsGroup (XHsGroup a) = pure (XHsGroup a) ++ ++cvTyClGroup :: TyClGroup GhcPs -> Conv (TyClGroup GhcSe) ++cvTyClGroup (TyClGroup a b c d) = TyClGroup a ++ <$> traverse (traverse cvTyClDecl) b ++ <*> traverse (traverse cvRoleAnnotDecl) c ++ <*> traverse (traverse cvInstDecl) d ++cvTyClGroup (XTyClGroup a) = pure (XTyClGroup a) ++ ++cvHsCmdTop :: HsCmdTop GhcPs -> Conv (HsCmdTop GhcSe) ++cvHsCmdTop (HsCmdTop a b) = HsCmdTop a <$> traverse cvHsCmd b ++cvHsCmdTop (XCmdTop a) = pure (XCmdTop a) ++ ++cvHsCmd :: HsCmd GhcPs -> Conv (HsCmd GhcSe) ++cvHsCmd (HsCmdArrApp a b c d e) = HsCmdArrApp a ++ <$> cvLHsExpr b <*> cvLHsExpr c <*> pure d <*> pure e ++cvHsCmd (HsCmdArrForm a b c d e) = HsCmdArrForm a ++ <$> cvLHsExpr b <*> pure c <*> pure d ++ <*> traverse (traverse cvHsCmdTop) e ++cvHsCmd (HsCmdApp a b c) = HsCmdApp a <$> traverse cvHsCmd b <*> cvLHsExpr c ++cvHsCmd (HsCmdLam a b) = HsCmdLam a <$> cvMatchGroup (traverse cvHsCmd) b ++cvHsCmd (HsCmdPar a b) = HsCmdPar a <$> traverse cvHsCmd b ++cvHsCmd (HsCmdCase a b c) = HsCmdCase a ++ <$> cvLHsExpr b <*> cvMatchGroup (traverse cvHsCmd) c ++cvHsCmd (HsCmdIf a b c d e) = HsCmdIf a ++ <$> traverse cvSyntaxExpr b ++ <*> cvLHsExpr c ++ <*> traverse cvHsCmd d ++ <*> traverse cvHsCmd e ++cvHsCmd (HsCmdLet a b c) = HsCmdLet a ++ <$> traverse cvHsLocalBinds b <*> traverse cvHsCmd c ++cvHsCmd (HsCmdDo a b) = HsCmdDo a ++ <$> traverse (traverse (traverse (cvStmtLR (traverse cvHsCmd)))) b ++cvHsCmd (HsCmdWrap {}) = unsupported "HsCmdWrap" "HsCmd" (error "") ++cvHsCmd (XCmd a) = pure (XCmd a) ++ ++cvArithSeqInfo :: ArithSeqInfo GhcPs -> Conv (ArithSeqInfo GhcSe) ++cvArithSeqInfo (From e) = From <$> cvLHsExpr e ++cvArithSeqInfo (FromThen a b) = FromThen <$> cvLHsExpr a <*> cvLHsExpr b ++cvArithSeqInfo (FromTo a b) = FromTo <$> cvLHsExpr a <*> cvLHsExpr b ++cvArithSeqInfo (FromThenTo a b c) = FromThenTo <$> cvLHsExpr a <*> cvLHsExpr b <*> cvLHsExpr c ++ ++cvHsTupArg :: HsTupArg GhcPs -> Conv (HsTupArg GhcSe) ++cvHsTupArg (Present a b) = Present a <$> cvLHsExpr b ++cvHsTupArg (Missing a) = pure (Missing a) ++cvHsTupArg (XTupArg a) = pure (XTupArg a) ++ ++cvAFieldOcc ++ :: AmbiguousFieldOcc GhcPs -> Conv (AmbiguousFieldOcc GhcSe) ++cvAFieldOcc (Unambiguous a b) = Unambiguous a <$> convertName b ++cvAFieldOcc (Ambiguous a b) = Ambiguous a <$> convertName b ++cvAFieldOcc (XAmbiguousFieldOcc a) = pure (XAmbiguousFieldOcc a) ++ ++cvOverLit :: HsOverLit GhcPs -> Conv (HsOverLit GhcSe) ++cvOverLit (OverLit a b c) = OverLit a b <$> cvHsExpr c ++cvOverLit (XOverLit a) = pure (XOverLit a) ++ ++cvLit :: HsLit GhcPs -> Conv (HsLit GhcSe) ++cvLit (HsChar a b) = pure (HsChar a b) ++cvLit (HsCharPrim a b) = pure (HsCharPrim a b) ++cvLit (HsString a b) = pure (HsString a b) ++cvLit (HsStringPrim a b) = pure (HsStringPrim a b) ++cvLit (HsInt a b) = pure (HsInt a b) ++cvLit (HsIntPrim a b) = pure (HsIntPrim a b) ++cvLit (HsWordPrim a b) = pure (HsWordPrim a b) ++cvLit (HsInt64Prim a b) = pure (HsInt64Prim a b) ++cvLit (HsWord64Prim a b) = pure (HsWord64Prim a b) ++cvLit (HsInteger a b c) = HsInteger a b <$> convertType c ++cvLit (HsRat a b c) = HsRat a b <$> convertType c ++cvLit (HsFloatPrim a b) = pure (HsFloatPrim a b) ++cvLit (HsDoublePrim a b) = pure (HsDoublePrim a b) ++cvLit (XLit a) = pure (XLit a) ++ ++cvMatchGroup ++ :: ( XMG GhcPs a ~ XMG GhcSe b ++ , XCMatch GhcPs a ~ XCMatch GhcSe b ++ , XCGRHSs GhcPs a ~ XCGRHSs GhcSe b ++ , XCGRHS GhcPs a ~ XCGRHS GhcSe b ++ , XXMatchGroup GhcPs a ~ XXMatchGroup GhcSe b ++ , XXMatch GhcPs a ~ XXMatch GhcSe b ++ , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b ++ , XXGRHS GhcPs a ~ XXGRHS GhcSe b ++ ) ++ => (a -> Conv b) -> MatchGroup GhcPs a -> Conv (MatchGroup GhcSe b) ++cvMatchGroup f (MG a b c) = MG a ++ <$> traverse (traverse (traverse (cvMatch f))) b ++ <*> pure c ++cvMatchGroup _ (XMatchGroup a) = pure (XMatchGroup a) ++ ++cvMatch ++ :: ( XCMatch GhcPs a ~ XCMatch GhcSe b ++ , XCGRHSs GhcPs a ~ XCGRHSs GhcSe b ++ , XCGRHS GhcPs a ~ XCGRHS GhcSe b ++ , XXMatch GhcPs a ~ XXMatch GhcSe b ++ , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b ++ , XXGRHS GhcPs a ~ XXGRHS GhcSe b ++ ) ++ => (a -> Conv b) -> Match GhcPs a -> Conv (Match GhcSe b) ++cvMatch f (Match a b c d) = Match a ++ <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d ++cvMatch _ (XMatch a) = pure (XMatch a) ++ ++cvPat :: Pat GhcPs -> Conv (Pat GhcSe) ++cvPat (WildPat a) = pure (WildPat a) ++cvPat (VarPat a b) = VarPat a <$> convertName b ++cvPat (LazyPat a b) = LazyPat a <$> traverse cvPat b ++cvPat (AsPat a b c) = AsPat a <$> convertName b <*> traverse cvPat c ++cvPat (ParPat a b) = ParPat a <$> traverse cvPat b ++cvPat (BangPat a b) = BangPat a <$> traverse cvPat b ++cvPat (ListPat a b) = ListPat a ++ <$> traverse (traverse cvPat) b ++cvPat (TuplePat a b c) = TuplePat a ++ <$> traverse (traverse cvPat) b ++ <*> pure c ++cvPat (SumPat a b c d) = SumPat a ++ <$> traverse cvPat b ++ <*> pure c <*> pure d ++cvPat (ConPatIn a b) = ConPatIn <$> convertName a <*> cvHsConPatDetails b ++cvPat (ViewPat a b c) = ViewPat a <$> cvLHsExpr b <*> traverse cvPat c ++cvPat (LitPat a b) = LitPat a <$> cvLit b ++cvPat (NPat a b c d) = NPat a ++ <$> traverse cvOverLit b <*> traverse cvSyntaxExpr c ++ <*> cvSyntaxExpr d ++cvPat (NPlusKPat a b c d e f) = NPlusKPat a ++ <$> convertName b ++ <*> traverse cvOverLit c <*> cvOverLit d ++ <*> cvSyntaxExpr e <*> cvSyntaxExpr f ++cvPat (SigPat a b) = SigPat <$> cvHsSigWcType a <*> traverse cvPat b ++cvPat (SplicePat a b) = SplicePat a <$> cvHsSplice b ++cvPat (CoPat {}) = unsupported "CoPat" "Pat" (error "") ++cvPat (ConPatOut {}) = unsupported "ConPatOut" "Pat" (error "") ++cvPat (XPat a) = pure (XPat a) ++ ++cvGRHSs ++ :: ( XCGRHSs GhcPs a ~ XCGRHSs GhcSe b ++ , XCGRHS GhcPs a ~ XCGRHS GhcSe b ++ , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b ++ , XXGRHS GhcPs a ~ XXGRHS GhcSe b ++ ) ++ => (a -> Conv b) -> GRHSs GhcPs a -> Conv (GRHSs GhcSe b) ++cvGRHSs f (GRHSs a b c) = GRHSs a ++ <$> traverse (traverse (cvGRHS f)) b ++ <*> traverse cvHsLocalBinds c ++cvGRHSs _ (XGRHSs a) = pure (XGRHSs a) ++ ++cvGRHS ++ :: ( XCGRHS GhcPs a ~ XCGRHS GhcSe b ++ , XXGRHS GhcPs a ~ XXGRHS GhcSe b ++ ) ++ => (a -> Conv b) -> GRHS GhcPs a -> Conv (GRHS GhcSe b) ++cvGRHS f (GRHS a b c) = GRHS a ++ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> f c ++cvGRHS _ (XGRHS a) = pure (XGRHS a) ++ ++cvHsLocalBinds ++ :: HsLocalBinds GhcPs -> Conv (HsLocalBinds GhcSe) ++cvHsLocalBinds (HsValBinds a b) = HsValBinds a <$> cvHsValBindsLR b ++cvHsLocalBinds (HsIPBinds a b) = HsIPBinds a <$> cvHsIPBinds b ++cvHsLocalBinds (EmptyLocalBinds a) = pure (EmptyLocalBinds a) ++cvHsLocalBinds (XHsLocalBindsLR a) = pure (XHsLocalBindsLR a) ++ ++cvHsValBindsLR ++ :: HsValBindsLR GhcPs GhcPs -> Conv (HsValBindsLR GhcSe GhcSe) ++cvHsValBindsLR (ValBinds a b c) = ValBinds a ++ <$> mapBagM (traverse cvHsBindLR) b ++ <*> traverse (traverse cvSig) c ++cvHsValBindsLR (XValBindsLR _) = ++ unsupported "XValBindsLR" "HsValBindsLR" (error "") ++ ++cvHsConPatDetails ++ :: HsConPatDetails GhcPs -> Conv (HsConPatDetails GhcSe) ++cvHsConPatDetails (PrefixCon a) = PrefixCon <$> traverse (traverse cvPat) a ++cvHsConPatDetails (RecCon a) = RecCon <$> cvHsRecFieldsPat a ++cvHsConPatDetails (InfixCon a b) = InfixCon ++ <$> traverse cvPat a <*> traverse cvPat b ++ ++cvHsRecFields ++ :: (thing -> Conv thing') ++ -> HsRecFields GhcPs thing ++ -> Conv (HsRecFields GhcSe thing') ++cvHsRecFields f (HsRecFields a b) = ++ HsRecFields <$> traverse (traverse (cvHsRecField' cvFieldOcc f)) a <*> pure b ++ ++cvHsRecField' ++ :: (id -> Conv id') ++ -> (thing -> Conv thing') ++ -> HsRecField' id thing ++ -> Conv (HsRecField' id' thing') ++cvHsRecField' f g (HsRecField a b c) = ++ HsRecField <$> traverse f a <*> g b <*> pure c ++ ++cvHsRecFieldsPat ++ :: HsRecFields GhcPs (LPat GhcPs) -> Conv (HsRecFields GhcSe (LPat GhcSe)) ++cvHsRecFieldsPat = cvHsRecFields (traverse cvPat) ++ ++cvHsRecUpdField ++ :: HsRecUpdField GhcPs -> Conv (HsRecUpdField GhcSe) ++cvHsRecUpdField = cvHsRecField' cvAFieldOcc cvLHsExpr ++ ++cvRecordBinds ++ :: HsRecordBinds GhcPs -> Conv (HsRecordBinds GhcSe) ++cvRecordBinds = cvHsRecFields cvLHsExpr ++ ++cvFieldOcc :: FieldOcc GhcPs -> Conv (FieldOcc GhcSe) ++cvFieldOcc (FieldOcc a b) = FieldOcc a <$> convertName b ++cvFieldOcc (XFieldOcc a) = pure (XFieldOcc a) ++ ++cvStmtLR ++ :: ( XLastStmt GhcPs GhcPs a ~ XLastStmt GhcSe GhcSe b ++ , XBindStmt GhcPs GhcPs a ~ XBindStmt GhcSe GhcSe b ++ , XBodyStmt GhcPs GhcPs a ~ XBodyStmt GhcSe GhcSe b ++ , XApplicativeStmt GhcPs GhcPs a ~ XApplicativeStmt GhcSe GhcSe b ++ , XLetStmt GhcPs GhcPs a ~ XLetStmt GhcSe GhcSe b ++ , XRecStmt GhcPs GhcPs a ~ XRecStmt GhcSe GhcSe b ++ , XParStmt GhcPs GhcPs a ~ XParStmt GhcSe GhcSe b ++ , XTransStmt GhcPs GhcPs a ~ XTransStmt GhcSe GhcSe b ++ , XXStmtLR GhcPs GhcPs a ~ XXStmtLR GhcSe GhcSe b ++ ) ++ => (a -> Conv b) -> StmtLR GhcPs GhcPs a -> Conv (StmtLR GhcSe GhcSe b) ++cvStmtLR k (LastStmt a b c d) = LastStmt a ++ <$> k b <*> pure c <*> cvSyntaxExpr d ++cvStmtLR k (BindStmt a b c d e) = BindStmt a ++ <$> traverse cvPat b <*> k c ++ <*> cvSyntaxExpr d <*> cvSyntaxExpr e ++cvStmtLR k (BodyStmt a b c d) = BodyStmt a ++ <$> k b <*> cvSyntaxExpr c ++ <*> cvSyntaxExpr d ++cvStmtLR _ (ApplicativeStmt a b c) = ApplicativeStmt a ++ <$> traverse ++ (\(se, aa) -> (,) <$> cvSyntaxExpr se <*> cvApplicativeArg aa) ++ b ++ <*> traverse cvSyntaxExpr c ++cvStmtLR _ (LetStmt a b) = LetStmt a <$> traverse cvHsLocalBinds b ++cvStmtLR k (RecStmt a b c d e f g) = RecStmt a ++ <$> traverse (traverse (cvStmtLR k)) b ++ <*> convertName c ++ <*> convertName d ++ <*> cvSyntaxExpr e ++ <*> cvSyntaxExpr f ++ <*> cvSyntaxExpr g ++cvStmtLR _ (ParStmt a b c d) = ParStmt a ++ <$> traverse cvParStmtBlock b ++ <*> cvHsExpr c ++ <*> cvSyntaxExpr d ++cvStmtLR _ (TransStmt a b c d e f g h i) = TransStmt a b ++ <$> traverse (traverse (cvStmtLR cvLHsExpr)) c ++ <*> traverse (\(x, y) -> (,) <$> convertName x <*> convertName y) d ++ <*> cvLHsExpr e ++ <*> traverse cvLHsExpr f ++ <*> cvSyntaxExpr g ++ <*> cvSyntaxExpr h ++ <*> cvHsExpr i ++cvStmtLR _ (XStmtLR a) = pure (XStmtLR a) ++ ++cvParStmtBlock ++ :: ParStmtBlock GhcPs GhcPs -> Conv (ParStmtBlock GhcSe GhcSe) ++cvParStmtBlock (ParStmtBlock a b c d) = ParStmtBlock a ++ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b ++ <*> convertName c ++ <*> cvSyntaxExpr d ++cvParStmtBlock (XParStmtBlock a) = pure (XParStmtBlock a) ++ ++cvSyntaxExpr :: SyntaxExpr GhcPs -> Conv (SyntaxExpr GhcSe) ++cvSyntaxExpr (SyntaxExpr a b c) = ++ SyntaxExpr <$> cvHsExpr a <*> pure b <*> pure c ++ ++cvHsIPBinds ++ :: HsIPBinds GhcPs -> Conv (HsIPBinds GhcSe) ++cvHsIPBinds (IPBinds a b) = IPBinds a <$> traverse (traverse cvIPBind) b ++cvHsIPBinds (XHsIPBinds a) = pure (XHsIPBinds a) ++ ++cvIPBind :: IPBind GhcPs -> Conv (IPBind GhcSe) ++cvIPBind (IPBind a b c) = IPBind a <$> convertName b <*> cvLHsExpr c ++cvIPBind (XIPBind a) = pure (XIPBind a) ++ ++cvHsBindLR ++ :: HsBindLR GhcPs GhcPs -> Conv (HsBindLR GhcSe GhcSe) ++cvHsBindLR (FunBind a b c d e) = FunBind a ++ <$> convertName b ++ <*> cvMatchGroup cvLHsExpr c ++ <*> pure d <*> pure e ++cvHsBindLR (PatBind a b c d ) = PatBind a ++ <$> traverse cvPat b <*> cvGRHSs cvLHsExpr c <*> pure d ++cvHsBindLR (VarBind a b c d) = VarBind a ++ <$> convertName b <*> cvLHsExpr c <*> pure d ++cvHsBindLR (PatSynBind a b) = PatSynBind a <$> cvPatSynBind b ++cvHsBindLR (AbsBinds {}) = ++ unsupported "AbsBind" "HsBindLR" (error "") ++cvHsBindLR (XHsBindsLR a) = pure (XHsBindsLR a) ++ ++cvHsWildCardBndrs ++ :: ( XHsWC GhcPs thing ~ XHsWC GhcSe thing' ++ , XXHsWildCardBndrs GhcPs thing ~ XXHsWildCardBndrs GhcSe thing' ++ ) ++ => (thing -> Conv thing') ++ -> HsWildCardBndrs GhcPs thing ++ -> Conv (HsWildCardBndrs GhcSe thing') ++cvHsWildCardBndrs thingF (HsWC a b) = HsWC a <$> thingF b ++cvHsWildCardBndrs _ (XHsWildCardBndrs a) = pure (XHsWildCardBndrs a) ++ ++cvLHsWcType ++ :: LHsWcType GhcPs -> Conv (LHsWcType GhcSe) ++cvLHsWcType = cvHsWildCardBndrs (traverse cvType) ++ ++cvHsSigWcType ++ :: LHsSigWcType GhcPs -> Conv (LHsSigWcType GhcSe) ++cvHsSigWcType = cvHsWildCardBndrs (cvHsImplicitBndrs (traverse cvType)) ++ ++cvHsImplicitBndrs ++ :: ( XHsIB GhcPs thing ~ XHsIB GhcSe thing' ++ , XXHsImplicitBndrs GhcPs thing ~ XXHsImplicitBndrs GhcSe thing' ++ ) ++ => (thing -> Conv thing') ++ -> HsImplicitBndrs GhcPs thing ++ -> Conv (HsImplicitBndrs GhcSe thing') ++cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b ++cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) ++ ++cvType :: HsType GhcPs -> Conv (HsType GhcSe) ++cvType (HsForAllTy a b c) = HsForAllTy a ++ <$> traverse (traverse cvHsTyVarBndr) b ++ <*> traverse cvType c ++cvType (HsQualTy a b c) = HsQualTy a ++ <$> traverse (traverse (traverse cvType)) b ++ <*> traverse cvType c ++cvType (HsTyVar a b c) = HsTyVar a b <$> convertName c ++cvType (HsAppTy a b c) = HsAppTy a ++ <$> traverse cvType b ++ <*> traverse cvType c ++cvType (HsFunTy a b c) = HsFunTy a ++ <$> traverse cvType b ++ <*> traverse cvType c ++cvType (HsListTy a b) = HsListTy a <$> traverse cvType b ++cvType (HsTupleTy a b c) = HsTupleTy a b <$> traverse (traverse cvType) c ++cvType (HsSumTy a b) = HsSumTy a <$> traverse (traverse cvType) b ++cvType (HsOpTy a b c d) = HsOpTy a ++ <$> traverse cvType b ++ <*> convertName c ++ <*> traverse cvType d ++cvType (HsParTy a b) = HsParTy a <$> traverse cvType b ++cvType (HsIParamTy a b c) = HsIParamTy a b <$> traverse cvType c ++cvType (HsKindSig a b c) = HsKindSig a ++ <$> traverse cvType b ++ <*> traverse cvType c ++cvType (HsBangTy a b c) = HsBangTy a b <$> traverse cvType c ++cvType (HsRecTy a b) = HsRecTy a <$> traverse (traverse cvConDeclField) b ++cvType (HsExplicitListTy a b c) = HsExplicitListTy a b ++ <$> traverse (traverse cvType) c ++cvType (HsExplicitTupleTy a b) = HsExplicitTupleTy a ++ <$> traverse (traverse cvType) b ++cvType (HsTyLit a b) = pure (HsTyLit a b) ++cvType (HsWildCardTy a) = pure (HsWildCardTy a) ++cvType (HsDocTy a b c) = HsDocTy a <$> traverse cvType b <*> pure c ++cvType (HsSpliceTy a b) = HsSpliceTy a <$> cvHsSplice b ++cvType (HsStarTy a b) = pure (HsStarTy a b) ++cvType (XHsType a) = pure (XHsType a) ++ ++cvHsTyVarBndr ++ :: HsTyVarBndr GhcPs -> Conv (HsTyVarBndr GhcSe) ++cvHsTyVarBndr (UserTyVar a b) = UserTyVar a <$> convertName b ++cvHsTyVarBndr (KindedTyVar a b c) = KindedTyVar a ++ <$> convertName b ++ <*> traverse cvType c ++cvHsTyVarBndr (XTyVarBndr a) = pure (XTyVarBndr a) ++ ++cvApplicativeArg ++ :: ApplicativeArg GhcPs -> Conv (ApplicativeArg GhcSe) ++cvApplicativeArg (ApplicativeArgOne a b c d) = ApplicativeArgOne a ++ <$> traverse cvPat b <*> cvLHsExpr c <*> pure d ++cvApplicativeArg (ApplicativeArgMany a b c d) = ApplicativeArgMany a ++ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> cvHsExpr c ++ <*> traverse cvPat d ++cvApplicativeArg (XApplicativeArg a) = pure (XApplicativeArg a) ++ ++cvSig :: Sig GhcPs -> Conv (Sig GhcSe) ++cvSig (TypeSig a b c) = TypeSig a <$> convertName b <*> cvHsSigWcType c ++cvSig (PatSynSig a b c) = PatSynSig a ++ <$> convertName b <*> cvHsImplicitBndrs (traverse cvType) c ++cvSig (ClassOpSig a b c d) = ClassOpSig a b ++ <$> convertName c <*> cvHsImplicitBndrs (traverse cvType) d ++cvSig (InlineSig a b c) = InlineSig a <$> convertName b <*> pure c ++cvSig (FixSig a b) = FixSig a <$> cvFixitySig b ++cvSig (SpecSig a b c d) = SpecSig a ++ <$> convertName b ++ <*> traverse (cvHsImplicitBndrs (traverse cvType)) c ++ <*> pure d ++cvSig (SpecInstSig a b c) = SpecInstSig a b ++ <$> cvHsImplicitBndrs (traverse cvType) c ++cvSig (SCCFunSig a b c d) = SCCFunSig a b <$> convertName c <*> pure d ++cvSig (CompleteMatchSig a b c d) = CompleteMatchSig a b ++ <$> convertName c <*> convertName d ++cvSig (MinimalSig a b c) = MinimalSig a b <$> traverse (traverse convertName) c ++cvSig (IdSig {}) = unsupported "IdSig" "Sig" (error "") ++cvSig (XSig a) = pure (XSig a) ++ ++cvFixitySig :: FixitySig GhcPs -> Conv (FixitySig GhcSe) ++cvFixitySig (FixitySig a b c) = FixitySig a <$> convertName b <*> pure c ++cvFixitySig (XFixitySig a) = pure (XFixitySig a) ++ ++cvPatSynBind :: PatSynBind GhcPs GhcPs -> Conv (PatSynBind GhcSe GhcSe) ++cvPatSynBind (PSB a b c d e) = PSB a ++ <$> convertName b ++ <*> cvHsPatSynDetails convertName c <*> traverse cvPat d ++ <*> cvHsPatSynDir e ++cvPatSynBind (XPatSynBind a) = pure (XPatSynBind a) ++ ++cvHsPatSynDetails ++ :: (a -> Conv b) ++ -> HsPatSynDetails a ++ -> Conv (HsPatSynDetails b) ++cvHsPatSynDetails f = cvHsConDetails f (traverse (cvRecordPatSynField f)) ++ ++cvRecordPatSynField ++ :: (a -> Conv b) ++ -> RecordPatSynField a ++ -> Conv (RecordPatSynField b) ++cvRecordPatSynField f (RecordPatSynField a b) = ++ RecordPatSynField <$> f a <*> f b ++ ++cvHsPatSynDir :: HsPatSynDir GhcPs -> Conv (HsPatSynDir GhcSe) ++cvHsPatSynDir Unidirectional = pure Unidirectional ++cvHsPatSynDir ImplicitBidirectional = pure ImplicitBidirectional ++cvHsPatSynDir (ExplicitBidirectional a) = ExplicitBidirectional ++ <$> cvMatchGroup cvLHsExpr a +diff --git a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs +new file mode 100644 +index 0000000000..8fbc941a71 +--- /dev/null ++++ b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs +@@ -0,0 +1,813 @@ ++{-# LANGUAGE GADTs #-} ++module HsExprBin_ConversionSE2PS where ++ ++import Control.Applicative ++import Data.Traversable ++ ++import Bag (mapBagM) ++import Class ++import CoreSyn ( Tickish(..) ) ++import GhcPrelude ++import HsBinds ++import HsDecls ++import HsExpr ++import HsExprBin_Conversions ++import HsExtension ++import HsLit ++import HsPat ++import HsTypes ++ ++-- * Conversion from serialisable ASTs to parsed ASTs ++ ++cvLHsDecl :: LHsDecl GhcSe -> Conv (LHsDecl GhcPs) ++cvLHsDecl = traverse cvHsDecl ++ ++cvHsDecl :: HsDecl GhcSe -> Conv (HsDecl GhcPs) ++cvHsDecl (TyClD a b) = TyClD <$> pure a <*> cvTyClDecl b ++cvHsDecl (InstD a b) = InstD <$> pure a <*> cvInstDecl b ++cvHsDecl (DerivD a b) = DerivD <$> pure a <*> cvDerivDecl b ++cvHsDecl (ValD a b) = ValD <$> pure a <*> cvHsBindLR b ++cvHsDecl (SigD a b) = SigD <$> pure a <*> cvSig b ++cvHsDecl (DefD a b) = DefD <$> pure a <*> cvDefaultDecl b ++cvHsDecl (ForD a b) = ForD <$> pure a <*> cvForeignDecl b ++cvHsDecl (WarningD a b) = WarningD <$> pure a <*> cvWarningDecls b ++cvHsDecl (RoleAnnotD a b) = RoleAnnotD <$> pure a <*> cvRoleAnnotDecl b ++cvHsDecl (AnnD a b) = AnnD <$> pure a <*> cvAnnDecl b ++cvHsDecl (RuleD a b) = RuleD <$> pure a <*> cvRuleDecls b ++cvHsDecl (SpliceD a b) = SpliceD <$> pure a <*> cvSpliceDecl b ++cvHsDecl (DocD a b) = pure (DocD a b) ++cvHsDecl (XHsDecl a) = pure (XHsDecl a) ++ ++cvAnnDecl :: AnnDecl GhcSe -> Conv (AnnDecl GhcPs) ++cvAnnDecl (HsAnnotation a b c d) = ++ HsAnnotation a b <$> cvAnnProvenance c <*> cvLHsExpr d ++cvAnnDecl (XAnnDecl a) = pure (XAnnDecl a) ++ ++cvInstDecl :: InstDecl GhcSe -> Conv (InstDecl GhcPs) ++cvInstDecl (ClsInstD a b) = ClsInstD a <$> cvClsInstDecl b ++cvInstDecl (DataFamInstD a b) = DataFamInstD a <$> cvDataFamInstDecl b ++cvInstDecl (TyFamInstD a b) = TyFamInstD a <$> cvTyFamInstDecl b ++cvInstDecl (XInstDecl a) = pure (XInstDecl a) ++ ++cvClsInstDecl :: ClsInstDecl GhcSe -> Conv (ClsInstDecl GhcPs) ++cvClsInstDecl (ClsInstDecl a b c d e f g) = ++ ClsInstDecl a ++ <$> cvHsImplicitBndrs (traverse cvType) b ++ <*> mapBagM (traverse cvHsBindLR) c ++ <*> traverse (traverse cvSig) d ++ <*> traverse (traverse cvTyFamInstDecl) e ++ <*> traverse (traverse cvDataFamInstDecl) f ++ <*> pure g ++cvClsInstDecl (XClsInstDecl a) = pure (XClsInstDecl a) ++ ++cvDerivDecl :: DerivDecl GhcSe -> Conv (DerivDecl GhcPs) ++cvDerivDecl (DerivDecl a b c d) = ++ DerivDecl a <$> cvHsWildCardBndrs (cvHsImplicitBndrs $ traverse cvType) b ++ <*> traverse (traverse cvDerivStrategy) c ++ <*> pure d ++cvDerivDecl (XDerivDecl a) = pure (XDerivDecl a) ++ ++cvDerivStrategy ++ :: DerivStrategy GhcSe -> Conv (DerivStrategy GhcPs) ++cvDerivStrategy StockStrategy = pure StockStrategy ++cvDerivStrategy AnyclassStrategy = pure AnyclassStrategy ++cvDerivStrategy NewtypeStrategy = pure NewtypeStrategy ++cvDerivStrategy (ViaStrategy a) = ViaStrategy ++ <$> cvHsImplicitBndrs (traverse cvType) a ++ ++cvTyClDecl :: TyClDecl GhcSe -> Conv (TyClDecl GhcPs) ++cvTyClDecl (FamDecl a b) = FamDecl <$> pure a <*> cvFamilyDecl b ++cvTyClDecl (SynDecl a b c d e) = ++ SynDecl a ++ <$> convertName b ++ <*> cvLHsQTyVars c <*> pure d ++ <*> traverse cvType e ++cvTyClDecl (DataDecl a b c d e) = ++ DataDecl a ++ <$> convertName b ++ <*> cvLHsQTyVars c <*> pure d ++ <*> cvHsDataDefn e ++cvTyClDecl (ClassDecl a b c d e f g h i j k) = ++ ClassDecl a ++ <$> traverse (traverse (traverse cvType)) b ++ <*> convertName c ++ <*> cvLHsQTyVars d ++ <*> pure e ++ <*> traverse (traverse cvFunDep) f ++ <*> traverse (traverse cvSig) g ++ <*> mapBagM (traverse cvHsBindLR) h ++ <*> traverse (traverse cvFamilyDecl) i ++ <*> traverse (traverse $ cvFamEqn cvLHsQTyVars (traverse cvType)) j ++ <*> pure k ++cvTyClDecl (XTyClDecl a) = pure (XTyClDecl a) ++ ++cvRoleAnnotDecl :: RoleAnnotDecl GhcSe -> Conv (RoleAnnotDecl GhcPs) ++cvRoleAnnotDecl (RoleAnnotDecl a b c) = ++ RoleAnnotDecl a <$> convertName b <*> pure c ++cvRoleAnnotDecl (XRoleAnnotDecl a) = pure (XRoleAnnotDecl a) ++ ++cvRuleDecls :: RuleDecls GhcSe -> Conv (RuleDecls GhcPs) ++cvRuleDecls (HsRules a b c) = HsRules a b <$> traverse (traverse cvRuleDecl) c ++cvRuleDecls (XRuleDecls a) = pure (XRuleDecls a) ++ ++cvRuleDecl :: RuleDecl GhcSe -> Conv (RuleDecl GhcPs) ++cvRuleDecl (HsRule a b c d e f) = ++ HsRule a b c <$> traverse (traverse cvRuleBndr) d ++ <*> cvLHsExpr e <*> cvLHsExpr f ++cvRuleDecl (XRuleDecl a) = pure (XRuleDecl a) ++ ++cvSpliceDecl :: SpliceDecl GhcSe -> Conv (SpliceDecl GhcPs) ++cvSpliceDecl (SpliceDecl a b c) = ++ SpliceDecl a <$> traverse cvHsSplice b <*> pure c ++cvSpliceDecl (XSpliceDecl a) = pure (XSpliceDecl a) ++ ++cvHsSplice :: HsSplice GhcSe -> Conv (HsSplice GhcPs) ++cvHsSplice (HsTypedSplice a b c d) = ++ HsTypedSplice a b <$> convertName c <*> cvLHsExpr d ++cvHsSplice (HsUntypedSplice a b c d) = ++ HsUntypedSplice a b <$> convertName c <*> cvLHsExpr d ++cvHsSplice (HsQuasiQuote a b c d e) = ++ HsQuasiQuote a <$> convertName b <*> convertName c <*> pure d <*> pure e ++cvHsSplice (HsSpliced {}) = ++ unsupported "HsSpliced" "HsSplice" (error "") ++cvHsSplice (XSplice a) = pure (XSplice a) ++ ++cvRuleBndr :: RuleBndr GhcSe -> Conv (RuleBndr GhcPs) ++cvRuleBndr (RuleBndr a b) = RuleBndr a <$> convertName b ++cvRuleBndr (RuleBndrSig a b c) = ++ RuleBndrSig a <$> convertName b <*> cvHsSigWcType c ++cvRuleBndr (XRuleBndr a) = pure (XRuleBndr a) ++ ++cvFamEqn ++ :: ( XCFamEqn GhcSe a b ~ XCFamEqn GhcPs c d ++ , XXFamEqn GhcSe a b ~ XXFamEqn GhcPs c d ++ ) ++ => (a -> Conv c) ++ -> (b -> Conv d) ++ -> FamEqn GhcSe a b ++ -> Conv (FamEqn GhcPs c d) ++cvFamEqn goPats goRhs (FamEqn a b c d e) = ++ FamEqn a <$> convertName b <*> goPats c <*> pure d <*> goRhs e ++cvFamEqn _ _ (XFamEqn a) = pure (XFamEqn a) ++ ++cvFamilyDecl :: FamilyDecl GhcSe -> Conv (FamilyDecl GhcPs) ++cvFamilyDecl (FamilyDecl a b c d e f g) = ++ FamilyDecl a ++ <$> cvFamilyInfo b <*> convertName c ++ <*> cvLHsQTyVars d <*> pure e ++ <*> traverse cvFamilyResultSig f ++ <*> traverse (traverse cvInjectivityAnn) g ++cvFamilyDecl (XFamilyDecl a) = pure (XFamilyDecl a) ++ ++cvAnnProvenance :: ConvertName a b => AnnProvenance a -> Conv (AnnProvenance b) ++cvAnnProvenance (ValueAnnProvenance a) = ValueAnnProvenance <$> convertName a ++cvAnnProvenance (TypeAnnProvenance a) = TypeAnnProvenance <$> convertName a ++cvAnnProvenance ModuleAnnProvenance = pure ModuleAnnProvenance ++ ++cvInjectivityAnn ++ :: InjectivityAnn GhcSe -> Conv (InjectivityAnn GhcPs) ++cvInjectivityAnn (InjectivityAnn a b) = ++ InjectivityAnn <$> convertName a <*> convertName b ++ ++cvFamilyResultSig ++ :: FamilyResultSig GhcSe -> Conv (FamilyResultSig GhcPs) ++cvFamilyResultSig (NoSig a) = pure (NoSig a) ++cvFamilyResultSig (KindSig a b) = KindSig a <$> traverse cvType b ++cvFamilyResultSig (TyVarSig a b) = TyVarSig a <$> traverse cvHsTyVarBndr b ++cvFamilyResultSig (XFamilyResultSig a) = pure (XFamilyResultSig a) ++ ++cvFamilyInfo ++ :: FamilyInfo GhcSe -> Conv (FamilyInfo GhcPs) ++cvFamilyInfo DataFamily = pure DataFamily ++cvFamilyInfo OpenTypeFamily = pure OpenTypeFamily ++cvFamilyInfo (ClosedTypeFamily a) = ++ ClosedTypeFamily <$> traverse (traverse (traverse (cvFamInstEqn (traverse cvType)))) a ++ ++cvFamInstEqn ++ :: ( XCFamEqn GhcSe (HsTyPats GhcSe) a ++ ~ XCFamEqn GhcPs (HsTyPats GhcPs) b ++ , XHsIB GhcSe (FamEqn GhcSe (HsTyPats p) a) ++ ~ XHsIB GhcPs (FamEqn GhcPs (HsTyPats GhcPs) b) ++ , XXFamEqn GhcSe (HsTyPats GhcSe) a ++ ~ XXFamEqn GhcPs (HsTyPats GhcPs) b ++ , XXHsImplicitBndrs GhcSe (FamEqn GhcSe (HsTyPats GhcSe) a) ++ ~ XXHsImplicitBndrs GhcPs (FamEqn GhcPs (HsTyPats GhcPs) b) ++ ) ++ => (a -> Conv b) ++ -> FamInstEqn GhcSe a ++ -> Conv (FamInstEqn GhcPs b) ++cvFamInstEqn f = cvHsImplicitBndrs (cvFamEqn (traverse (traverse cvType)) f) ++ ++cvFunDep :: ConvertName a b => FunDep a -> Conv (FunDep b) ++cvFunDep (xs, ys) = (,) <$> convertName xs <*> convertName ys ++ ++cvLHsQTyVars :: LHsQTyVars GhcSe -> Conv (LHsQTyVars GhcPs) ++cvLHsQTyVars (HsQTvs a b) = HsQTvs a <$> traverse (traverse cvHsTyVarBndr) b ++cvLHsQTyVars (XLHsQTyVars a) = pure (XLHsQTyVars a) ++ ++cvForeignDecl :: ForeignDecl GhcSe -> Conv (ForeignDecl GhcPs) ++cvForeignDecl (ForeignImport a b c d) = ++ ForeignImport a ++ <$> convertName b ++ <*> cvHsImplicitBndrs (traverse cvType) c ++ <*> pure d ++cvForeignDecl (ForeignExport a b c d) = ++ ForeignExport a ++ <$> convertName b ++ <*> cvHsImplicitBndrs (traverse cvType) c ++ <*> pure d ++cvForeignDecl (XForeignDecl a) = pure (XForeignDecl a) ++ ++cvDefaultDecl :: DefaultDecl GhcSe -> Conv (DefaultDecl GhcPs) ++cvDefaultDecl (DefaultDecl a b) = DefaultDecl a <$> traverse (traverse cvType) b ++cvDefaultDecl (XDefaultDecl a) = pure (XDefaultDecl a) ++ ++cvTyFamInstDecl ++ :: TyFamInstDecl GhcSe -> Conv (TyFamInstDecl GhcPs) ++cvTyFamInstDecl (TyFamInstDecl d) = ++ TyFamInstDecl <$> cvFamInstEqn (traverse cvType) d ++ ++cvDataFamInstDecl ++ :: DataFamInstDecl GhcSe -> Conv (DataFamInstDecl GhcPs) ++cvDataFamInstDecl (DataFamInstDecl d) = ++ DataFamInstDecl <$> cvFamInstEqn cvHsDataDefn d ++ ++cvHsDataDefn :: HsDataDefn GhcSe -> Conv (HsDataDefn GhcPs) ++cvHsDataDefn (HsDataDefn a b c d e f g) = ++ HsDataDefn a b ++ <$> traverse (traverse (traverse cvType)) c <*> pure d ++ <*> traverse (traverse cvType) e ++ <*> traverse (traverse cvConDecl) f <*> cvHsDeriving g ++cvHsDataDefn (XHsDataDefn a) = pure (XHsDataDefn a) ++ ++cvConDecl :: ConDecl GhcSe -> Conv (ConDecl GhcPs) ++cvConDecl (ConDeclGADT a b c d e f g h) = ++ ConDeclGADT a ++ <$> convertName b ++ <*> pure c ++ <*> cvLHsQTyVars d ++ <*> traverse (traverse (traverse (traverse cvType))) e ++ <*> cvHsConDeclDetails f ++ <*> traverse cvType g ++ <*> pure h ++cvConDecl (ConDeclH98 a b c d e f g) = ++ ConDeclH98 a ++ <$> convertName b ++ <*> pure c ++ <*> traverse (traverse cvHsTyVarBndr) d ++ <*> traverse (traverse (traverse (traverse cvType))) e ++ <*> cvHsConDeclDetails f ++ <*> pure g ++cvConDecl (XConDecl a) = pure (XConDecl a) ++ ++cvHsDeriving :: HsDeriving GhcSe -> Conv (HsDeriving GhcPs) ++cvHsDeriving = traverse (traverse (traverse cvHsDerivingClause)) ++ ++cvHsDerivingClause ++ :: HsDerivingClause GhcSe -> Conv (HsDerivingClause GhcPs) ++cvHsDerivingClause (HsDerivingClause a b c) = ++ HsDerivingClause a ++ <$> traverse (traverse cvDerivStrategy) b ++ <*> traverse (traverse (cvHsImplicitBndrs (traverse cvType))) c ++cvHsDerivingClause (XHsDerivingClause a) = pure (XHsDerivingClause a) ++ ++cvHsConDeclDetails ++ :: HsConDeclDetails GhcSe -> Conv (HsConDeclDetails GhcPs) ++cvHsConDeclDetails = ++ cvHsConDetails (traverse cvType) ++ (traverse (traverse (traverse cvConDeclField))) ++ ++cvHsConDetails ++ :: (a -> Conv c) -> (b -> Conv d) -> HsConDetails a b -> Conv (HsConDetails c d) ++cvHsConDetails f _ (PrefixCon a) = PrefixCon <$> traverse f a ++cvHsConDetails _ g (RecCon a) = RecCon <$> g a ++cvHsConDetails f _ (InfixCon a b) = InfixCon <$> f a <*> f b ++ ++cvConDeclField :: ConDeclField GhcSe -> Conv (ConDeclField GhcPs) ++cvConDeclField (ConDeclField a b c d) = ++ ConDeclField a <$> traverse (traverse cvFieldOcc) b <*> traverse cvType c ++ <*> pure d ++cvConDeclField (XConDeclField a) = pure (XConDeclField a) ++ ++cvWarningDecls :: WarnDecls GhcSe -> Conv (WarnDecls GhcPs) ++cvWarningDecls (Warnings a b c) = ++ Warnings a b <$> traverse (traverse cvWarningDecl) c ++cvWarningDecls (XWarnDecls a) = pure (XWarnDecls a) ++ ++cvWarningDecl :: WarnDecl GhcSe -> Conv (WarnDecl GhcPs) ++cvWarningDecl (Warning a b c) = Warning a <$> convertName b <*> pure c ++cvWarningDecl (XWarnDecl a) = pure (XWarnDecl a) ++ ++-- expressions ++ ++cvLHsExpr :: LHsExpr GhcSe -> Conv (LHsExpr GhcPs) ++cvLHsExpr = traverse cvHsExpr ++ ++cvHsExpr :: HsExpr GhcSe -> Conv (HsExpr GhcPs) ++cvHsExpr e = case e of ++ HsVar a b -> HsVar a <$> convertName b ++ HsUnboundVar a b -> pure (HsUnboundVar a b) ++ HsConLikeOut a b -> pure (HsConLikeOut a b) ++ HsRecFld a b -> HsRecFld a <$> cvAFieldOcc b ++ HsOverLabel a b c -> HsOverLabel a <$> convertName b <*> pure c ++ HsIPVar a b -> pure (HsIPVar a b) ++ HsOverLit a b -> HsOverLit a <$> cvOverLit b ++ HsLit a b -> HsLit a <$> cvLit b ++ HsLam a b -> HsLam a <$> cvMatchGroup cvLHsExpr b ++ HsLamCase a b -> HsLamCase a <$> cvMatchGroup cvLHsExpr b ++ HsApp a b c -> HsApp a <$> cvLHsExpr b <*> cvLHsExpr c ++ HsAppType a b -> HsAppType ++ <$> cvHsWildCardBndrs (traverse cvType) a <*> cvLHsExpr b ++ OpApp a b c d -> OpApp a <$> cvLHsExpr b <*> cvLHsExpr c <*> cvLHsExpr d ++ NegApp a b c -> NegApp a <$> cvLHsExpr b <*> cvSyntaxExpr c ++ HsPar a b -> HsPar a <$> cvLHsExpr b ++ SectionL a b c -> SectionL a <$> cvLHsExpr b <*> cvLHsExpr c ++ SectionR a b c -> SectionR a <$> cvLHsExpr b <*> cvLHsExpr c ++ ExplicitTuple a b c -> ExplicitTuple a <$> traverse (traverse cvHsTupArg) b ++ <*> pure c ++ ExplicitSum a b c d -> ExplicitSum a b c <$> cvLHsExpr d ++ ExplicitList a b c -> ExplicitList a <$> traverse cvSyntaxExpr b <*> traverse cvLHsExpr c ++ HsCase a b c -> HsCase a <$> cvLHsExpr b <*> cvMatchGroup cvLHsExpr c ++ HsIf a b c d e -> HsIf a <$> traverse cvSyntaxExpr b ++ <*> cvLHsExpr c <*> cvLHsExpr d <*> cvLHsExpr e ++ HsMultiIf a b -> HsMultiIf a <$> traverse (traverse (cvGRHS cvLHsExpr)) b ++ HsLet a b c -> HsLet a <$> traverse cvHsLocalBinds b <*> cvLHsExpr c ++ HsDo a b c -> HsDo a ++ <$> convertName b <*> traverse (traverse (traverse (cvStmtLR cvLHsExpr))) c ++ RecordCon a b c -> RecordCon a <$> convertName b <*> cvRecordBinds c ++ RecordUpd a b c -> RecordUpd a <$> cvLHsExpr b ++ <*> traverse (traverse cvHsRecUpdField) c ++ ExprWithTySig a b -> ExprWithTySig <$> cvHsSigWcType a <*> cvLHsExpr b ++ ArithSeq a b c -> ArithSeq a <$> traverse cvSyntaxExpr b <*> cvArithSeqInfo c ++ HsSCC a b c d -> HsSCC a b c <$> cvLHsExpr d ++ HsCoreAnn a b c d -> HsCoreAnn a b c <$> cvLHsExpr d ++ HsStatic a b -> HsStatic a <$> cvLHsExpr b ++ EWildPat a -> pure (EWildPat a) ++ EAsPat a b c -> EAsPat a <$> convertName b <*> cvLHsExpr c ++ EViewPat a b c -> EViewPat a <$> cvLHsExpr b <*> cvLHsExpr c ++ ELazyPat a b -> ELazyPat a <$> cvLHsExpr b ++ HsProc a b c -> HsProc a <$> traverse cvPat b <*> traverse cvHsCmdTop c ++ HsBinTick a b c d -> HsBinTick a b c <$> cvLHsExpr d ++ HsTickPragma a b c d e -> HsTickPragma a b c d <$> cvLHsExpr e ++ HsSpliceE a b -> HsSpliceE a <$> cvHsSplice b ++ HsBracket a b -> HsBracket a <$> cvHsBracket b ++ HsTick a b c -> HsTick a <$> cvTickish b <*> cvLHsExpr c ++ XExpr a -> pure (XExpr a) ++ HsArrApp {} -> unsupported "HsArrApp" "HsExpr" (error "") ++ HsArrForm {} -> unsupported "HsArrForm" "HsExpr" (error "") ++ HsWrap {} -> unsupported "HsWrap" "HsExpr" (error "") ++ HsRnBracketOut {} -> unsupported "HsRnBracketOut" "HsExpr" (error "") ++ HsTcBracketOut {} -> unsupported "HsTcBracketOut" "HsExpr" (error "") ++ ++cvHsBracket :: HsBracket GhcSe -> Conv (HsBracket GhcPs) ++cvHsBracket (ExpBr a b) = ExpBr a <$> cvLHsExpr b ++cvHsBracket (PatBr a b) = PatBr a <$> traverse cvPat b ++cvHsBracket (DecBrL a b) = DecBrL a <$> traverse (traverse cvHsDecl) b ++cvHsBracket (DecBrG a b) = DecBrG a <$> cvHsGroup b ++cvHsBracket (TypBr a b) = TypBr a <$> traverse cvType b ++cvHsBracket (VarBr a b c) = VarBr a b <$> convertName c ++cvHsBracket (TExpBr a b) = TExpBr a <$> cvLHsExpr b ++cvHsBracket (XBracket a) = pure (XBracket a) ++ ++cvTickish :: ConvertName a b => Tickish a -> Conv (Tickish b) ++cvTickish (ProfNote a b c) = pure (ProfNote a b c) ++cvTickish (HpcTick a b) = pure (HpcTick a b) ++cvTickish (Breakpoint a b) = Breakpoint a <$> convertName b ++cvTickish (SourceNote a b) = pure (SourceNote a b) ++ ++cvHsGroup :: HsGroup GhcSe -> Conv (HsGroup GhcPs) ++cvHsGroup (HsGroup a b c d e f g h i j k l) = HsGroup a ++ <$> cvHsValBindsLR b <*> traverse (traverse cvSpliceDecl) c ++ <*> traverse cvTyClGroup d ++ <*> traverse (traverse cvDerivDecl) e ++ <*> traverse (traverse cvFixitySig) f ++ <*> traverse (traverse cvDefaultDecl) g ++ <*> traverse (traverse cvForeignDecl) h ++ <*> traverse (traverse cvWarningDecls) i ++ <*> traverse (traverse cvAnnDecl) j ++ <*> traverse (traverse cvRuleDecls) k ++ <*> pure l ++cvHsGroup (XHsGroup a) = pure (XHsGroup a) ++ ++cvTyClGroup :: TyClGroup GhcSe -> Conv (TyClGroup GhcPs) ++cvTyClGroup (TyClGroup a b c d) = TyClGroup a ++ <$> traverse (traverse cvTyClDecl) b ++ <*> traverse (traverse cvRoleAnnotDecl) c ++ <*> traverse (traverse cvInstDecl) d ++cvTyClGroup (XTyClGroup a) = pure (XTyClGroup a) ++ ++cvHsCmdTop :: HsCmdTop GhcSe -> Conv (HsCmdTop GhcPs) ++cvHsCmdTop (HsCmdTop a b) = HsCmdTop a <$> traverse cvHsCmd b ++cvHsCmdTop (XCmdTop a) = pure (XCmdTop a) ++ ++cvHsCmd :: HsCmd GhcSe -> Conv (HsCmd GhcPs) ++cvHsCmd (HsCmdArrApp a b c d e) = HsCmdArrApp a ++ <$> cvLHsExpr b <*> cvLHsExpr c <*> pure d <*> pure e ++cvHsCmd (HsCmdArrForm a b c d e) = HsCmdArrForm a ++ <$> cvLHsExpr b <*> pure c <*> pure d ++ <*> traverse (traverse cvHsCmdTop) e ++cvHsCmd (HsCmdApp a b c) = HsCmdApp a <$> traverse cvHsCmd b <*> cvLHsExpr c ++cvHsCmd (HsCmdLam a b) = HsCmdLam a <$> cvMatchGroup (traverse cvHsCmd) b ++cvHsCmd (HsCmdPar a b) = HsCmdPar a <$> traverse cvHsCmd b ++cvHsCmd (HsCmdCase a b c) = HsCmdCase a ++ <$> cvLHsExpr b <*> cvMatchGroup (traverse cvHsCmd) c ++cvHsCmd (HsCmdIf a b c d e) = HsCmdIf a ++ <$> traverse cvSyntaxExpr b ++ <*> cvLHsExpr c ++ <*> traverse cvHsCmd d ++ <*> traverse cvHsCmd e ++cvHsCmd (HsCmdLet a b c) = HsCmdLet a ++ <$> traverse cvHsLocalBinds b <*> traverse cvHsCmd c ++cvHsCmd (HsCmdDo a b) = HsCmdDo a ++ <$> traverse (traverse (traverse (cvStmtLR (traverse cvHsCmd)))) b ++cvHsCmd (HsCmdWrap {}) = unsupported "HsCmdWrap" "HsCmd" (error "") ++cvHsCmd (XCmd a) = pure (XCmd a) ++ ++cvArithSeqInfo :: ArithSeqInfo GhcSe -> Conv (ArithSeqInfo GhcPs) ++cvArithSeqInfo (From e) = From <$> cvLHsExpr e ++cvArithSeqInfo (FromThen a b) = FromThen <$> cvLHsExpr a <*> cvLHsExpr b ++cvArithSeqInfo (FromTo a b) = FromTo <$> cvLHsExpr a <*> cvLHsExpr b ++cvArithSeqInfo (FromThenTo a b c) = FromThenTo <$> cvLHsExpr a <*> cvLHsExpr b <*> cvLHsExpr c ++ ++cvHsTupArg :: HsTupArg GhcSe -> Conv (HsTupArg GhcPs) ++cvHsTupArg (Present a b) = Present a <$> cvLHsExpr b ++cvHsTupArg (Missing a) = pure (Missing a) ++cvHsTupArg (XTupArg a) = pure (XTupArg a) ++ ++cvAFieldOcc ++ :: AmbiguousFieldOcc GhcSe -> Conv (AmbiguousFieldOcc GhcPs) ++cvAFieldOcc (Unambiguous a b) = Unambiguous a <$> convertName b ++cvAFieldOcc (Ambiguous a b) = Ambiguous a <$> convertName b ++cvAFieldOcc (XAmbiguousFieldOcc a) = pure (XAmbiguousFieldOcc a) ++ ++cvOverLit :: HsOverLit GhcSe -> Conv (HsOverLit GhcPs) ++cvOverLit (OverLit a b c) = OverLit a b <$> cvHsExpr c ++cvOverLit (XOverLit a) = pure (XOverLit a) ++ ++cvLit :: HsLit GhcSe -> Conv (HsLit GhcPs) ++cvLit (HsChar a b) = pure (HsChar a b) ++cvLit (HsCharPrim a b) = pure (HsCharPrim a b) ++cvLit (HsString a b) = pure (HsString a b) ++cvLit (HsStringPrim a b) = pure (HsStringPrim a b) ++cvLit (HsInt a b) = pure (HsInt a b) ++cvLit (HsIntPrim a b) = pure (HsIntPrim a b) ++cvLit (HsWordPrim a b) = pure (HsWordPrim a b) ++cvLit (HsInt64Prim a b) = pure (HsInt64Prim a b) ++cvLit (HsWord64Prim a b) = pure (HsWord64Prim a b) ++cvLit (HsInteger a b c) = HsInteger a b <$> convertType c ++cvLit (HsRat a b c) = HsRat a b <$> convertType c ++cvLit (HsFloatPrim a b) = pure (HsFloatPrim a b) ++cvLit (HsDoublePrim a b) = pure (HsDoublePrim a b) ++cvLit (XLit a) = pure (XLit a) ++ ++cvMatchGroup ++ :: ( XMG GhcSe a ~ XMG GhcPs b ++ , XCMatch GhcSe a ~ XCMatch GhcPs b ++ , XCGRHSs GhcSe a ~ XCGRHSs GhcPs b ++ , XCGRHS GhcSe a ~ XCGRHS GhcPs b ++ , XXMatchGroup GhcSe a ~ XXMatchGroup GhcPs b ++ , XXMatch GhcSe a ~ XXMatch GhcPs b ++ , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b ++ , XXGRHS GhcSe a ~ XXGRHS GhcPs b ++ ) ++ => (a -> Conv b) -> MatchGroup GhcSe a -> Conv (MatchGroup GhcPs b) ++cvMatchGroup f (MG a b c) = MG a ++ <$> traverse (traverse (traverse (cvMatch f))) b ++ <*> pure c ++cvMatchGroup _ (XMatchGroup a) = pure (XMatchGroup a) ++ ++cvMatch ++ :: ( XCMatch GhcSe a ~ XCMatch GhcPs b ++ , XCGRHSs GhcSe a ~ XCGRHSs GhcPs b ++ , XCGRHS GhcSe a ~ XCGRHS GhcPs b ++ , XXMatch GhcSe a ~ XXMatch GhcPs b ++ , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b ++ , XXGRHS GhcSe a ~ XXGRHS GhcPs b ++ ) ++ => (a -> Conv b) -> Match GhcSe a -> Conv (Match GhcPs b) ++cvMatch f (Match a b c d) = Match a ++ <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d ++cvMatch _ (XMatch a) = pure (XMatch a) ++ ++cvPat :: Pat GhcSe -> Conv (Pat GhcPs) ++cvPat (WildPat a) = pure (WildPat a) ++cvPat (VarPat a b) = VarPat a <$> convertName b ++cvPat (LazyPat a b) = LazyPat a <$> traverse cvPat b ++cvPat (AsPat a b c) = AsPat a <$> convertName b <*> traverse cvPat c ++cvPat (ParPat a b) = ParPat a <$> traverse cvPat b ++cvPat (BangPat a b) = BangPat a <$> traverse cvPat b ++cvPat (ListPat a b) = ListPat a ++ <$> traverse (traverse cvPat) b ++cvPat (TuplePat a b c) = TuplePat a ++ <$> traverse (traverse cvPat) b ++ <*> pure c ++cvPat (SumPat a b c d) = SumPat a ++ <$> traverse cvPat b ++ <*> pure c <*> pure d ++cvPat (ConPatIn a b) = ConPatIn <$> convertName a <*> cvHsConPatDetails b ++cvPat (ViewPat a b c) = ViewPat a <$> cvLHsExpr b <*> traverse cvPat c ++cvPat (LitPat a b) = LitPat a <$> cvLit b ++cvPat (NPat a b c d) = NPat a ++ <$> traverse cvOverLit b <*> traverse cvSyntaxExpr c ++ <*> cvSyntaxExpr d ++cvPat (NPlusKPat a b c d e f) = NPlusKPat a ++ <$> convertName b ++ <*> traverse cvOverLit c <*> cvOverLit d ++ <*> cvSyntaxExpr e <*> cvSyntaxExpr f ++cvPat (SigPat a b) = SigPat <$> cvHsSigWcType a <*> traverse cvPat b ++cvPat (SplicePat a b) = SplicePat a <$> cvHsSplice b ++cvPat (CoPat {}) = unsupported "CoPat" "Pat" (error "") ++cvPat (ConPatOut {}) = unsupported "ConPatOut" "Pat" (error "") ++cvPat (XPat a) = pure (XPat a) ++ ++cvGRHSs ++ :: ( XCGRHSs GhcSe a ~ XCGRHSs GhcPs b ++ , XCGRHS GhcSe a ~ XCGRHS GhcPs b ++ , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b ++ , XXGRHS GhcSe a ~ XXGRHS GhcPs b ++ ) ++ => (a -> Conv b) -> GRHSs GhcSe a -> Conv (GRHSs GhcPs b) ++cvGRHSs f (GRHSs a b c) = GRHSs a ++ <$> traverse (traverse (cvGRHS f)) b ++ <*> traverse cvHsLocalBinds c ++cvGRHSs _ (XGRHSs a) = pure (XGRHSs a) ++ ++cvGRHS ++ :: ( XCGRHS GhcSe a ~ XCGRHS GhcPs b ++ , XXGRHS GhcSe a ~ XXGRHS GhcPs b ++ ) ++ => (a -> Conv b) -> GRHS GhcSe a -> Conv (GRHS GhcPs b) ++cvGRHS f (GRHS a b c) = GRHS a ++ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> f c ++cvGRHS _ (XGRHS a) = pure (XGRHS a) ++ ++cvHsLocalBinds ++ :: HsLocalBinds GhcSe -> Conv (HsLocalBinds GhcPs) ++cvHsLocalBinds (HsValBinds a b) = HsValBinds a <$> cvHsValBindsLR b ++cvHsLocalBinds (HsIPBinds a b) = HsIPBinds a <$> cvHsIPBinds b ++cvHsLocalBinds (EmptyLocalBinds a) = pure (EmptyLocalBinds a) ++cvHsLocalBinds (XHsLocalBindsLR a) = pure (XHsLocalBindsLR a) ++ ++cvHsValBindsLR ++ :: HsValBindsLR GhcSe GhcSe -> Conv (HsValBindsLR GhcPs GhcPs) ++cvHsValBindsLR (ValBinds a b c) = ValBinds a ++ <$> mapBagM (traverse cvHsBindLR) b ++ <*> traverse (traverse cvSig) c ++cvHsValBindsLR (XValBindsLR _) = ++ unsupported "XValBindsLR" "HsValBindsLR" (error "") ++ ++cvHsConPatDetails ++ :: HsConPatDetails GhcSe -> Conv (HsConPatDetails GhcPs) ++cvHsConPatDetails (PrefixCon a) = PrefixCon <$> traverse (traverse cvPat) a ++cvHsConPatDetails (RecCon a) = RecCon <$> cvHsRecFieldsPat a ++cvHsConPatDetails (InfixCon a b) = InfixCon ++ <$> traverse cvPat a <*> traverse cvPat b ++ ++cvHsRecFields ++ :: (thing -> Conv thing') ++ -> HsRecFields GhcSe thing ++ -> Conv (HsRecFields GhcPs thing') ++cvHsRecFields f (HsRecFields a b) = ++ HsRecFields <$> traverse (traverse (cvHsRecField' cvFieldOcc f)) a <*> pure b ++ ++cvHsRecField' ++ :: (id -> Conv id') ++ -> (thing -> Conv thing') ++ -> HsRecField' id thing ++ -> Conv (HsRecField' id' thing') ++cvHsRecField' f g (HsRecField a b c) = ++ HsRecField <$> traverse f a <*> g b <*> pure c ++ ++cvHsRecFieldsPat ++ :: HsRecFields GhcSe (LPat GhcSe) -> Conv (HsRecFields GhcPs (LPat GhcPs)) ++cvHsRecFieldsPat = cvHsRecFields (traverse cvPat) ++ ++cvHsRecUpdField ++ :: HsRecUpdField GhcSe -> Conv (HsRecUpdField GhcPs) ++cvHsRecUpdField = cvHsRecField' cvAFieldOcc cvLHsExpr ++ ++cvRecordBinds ++ :: HsRecordBinds GhcSe -> Conv (HsRecordBinds GhcPs) ++cvRecordBinds = cvHsRecFields cvLHsExpr ++ ++cvFieldOcc :: FieldOcc GhcSe -> Conv (FieldOcc GhcPs) ++cvFieldOcc (FieldOcc a b) = FieldOcc a <$> convertName b ++cvFieldOcc (XFieldOcc a) = pure (XFieldOcc a) ++ ++cvStmtLR ++ :: ( XLastStmt GhcSe GhcSe a ~ XLastStmt GhcPs GhcPs b ++ , XBindStmt GhcSe GhcSe a ~ XBindStmt GhcPs GhcPs b ++ , XBodyStmt GhcSe GhcSe a ~ XBodyStmt GhcPs GhcPs b ++ , XApplicativeStmt GhcSe GhcSe a ~ XApplicativeStmt GhcPs GhcPs b ++ , XLetStmt GhcSe GhcSe a ~ XLetStmt GhcPs GhcPs b ++ , XRecStmt GhcSe GhcSe a ~ XRecStmt GhcPs GhcPs b ++ , XParStmt GhcSe GhcSe a ~ XParStmt GhcPs GhcPs b ++ , XTransStmt GhcSe GhcSe a ~ XTransStmt GhcPs GhcPs b ++ , XXStmtLR GhcSe GhcSe a ~ XXStmtLR GhcPs GhcPs b ++ ) ++ => (a -> Conv b) -> StmtLR GhcSe GhcSe a -> Conv (StmtLR GhcPs GhcPs b) ++cvStmtLR k (LastStmt a b c d) = LastStmt a ++ <$> k b <*> pure c <*> cvSyntaxExpr d ++cvStmtLR k (BindStmt a b c d e) = BindStmt a ++ <$> traverse cvPat b <*> k c ++ <*> cvSyntaxExpr d <*> cvSyntaxExpr e ++cvStmtLR k (BodyStmt a b c d) = BodyStmt a ++ <$> k b <*> cvSyntaxExpr c ++ <*> cvSyntaxExpr d ++cvStmtLR _ (ApplicativeStmt a b c) = ApplicativeStmt a ++ <$> traverse ++ (\(se, aa) -> (,) <$> cvSyntaxExpr se <*> cvApplicativeArg aa) ++ b ++ <*> traverse cvSyntaxExpr c ++cvStmtLR _ (LetStmt a b) = LetStmt a <$> traverse cvHsLocalBinds b ++cvStmtLR k (RecStmt a b c d e f g) = RecStmt a ++ <$> traverse (traverse (cvStmtLR k)) b ++ <*> convertName c ++ <*> convertName d ++ <*> cvSyntaxExpr e ++ <*> cvSyntaxExpr f ++ <*> cvSyntaxExpr g ++cvStmtLR _ (ParStmt a b c d) = ParStmt a ++ <$> traverse cvParStmtBlock b ++ <*> cvHsExpr c ++ <*> cvSyntaxExpr d ++cvStmtLR _ (TransStmt a b c d e f g h i) = TransStmt a b ++ <$> traverse (traverse (cvStmtLR cvLHsExpr)) c ++ <*> traverse (\(x, y) -> (,) <$> convertName x <*> convertName y) d ++ <*> cvLHsExpr e ++ <*> traverse cvLHsExpr f ++ <*> cvSyntaxExpr g ++ <*> cvSyntaxExpr h ++ <*> cvHsExpr i ++cvStmtLR _ (XStmtLR a) = pure (XStmtLR a) ++ ++cvParStmtBlock ++ :: ParStmtBlock GhcSe GhcSe -> Conv (ParStmtBlock GhcPs GhcPs) ++cvParStmtBlock (ParStmtBlock a b c d) = ParStmtBlock a ++ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b ++ <*> convertName c ++ <*> cvSyntaxExpr d ++cvParStmtBlock (XParStmtBlock a) = pure (XParStmtBlock a) ++ ++cvSyntaxExpr :: SyntaxExpr GhcSe -> Conv (SyntaxExpr GhcPs) ++cvSyntaxExpr (SyntaxExpr a b c) = ++ SyntaxExpr <$> cvHsExpr a <*> pure b <*> pure c ++ ++cvHsIPBinds ++ :: HsIPBinds GhcSe -> Conv (HsIPBinds GhcPs) ++cvHsIPBinds (IPBinds a b) = IPBinds a <$> traverse (traverse cvIPBind) b ++cvHsIPBinds (XHsIPBinds a) = pure (XHsIPBinds a) ++ ++cvIPBind :: IPBind GhcSe -> Conv (IPBind GhcPs) ++cvIPBind (IPBind a b c) = IPBind a <$> convertName b <*> cvLHsExpr c ++cvIPBind (XIPBind a) = pure (XIPBind a) ++ ++cvHsBindLR ++ :: HsBindLR GhcSe GhcSe -> Conv (HsBindLR GhcPs GhcPs) ++cvHsBindLR (FunBind a b c d e) = FunBind a ++ <$> convertName b ++ <*> cvMatchGroup cvLHsExpr c ++ <*> pure d <*> pure e ++cvHsBindLR (PatBind a b c d ) = PatBind a ++ <$> traverse cvPat b <*> cvGRHSs cvLHsExpr c <*> pure d ++cvHsBindLR (VarBind a b c d) = VarBind a ++ <$> convertName b <*> cvLHsExpr c <*> pure d ++cvHsBindLR (PatSynBind a b) = PatSynBind a <$> cvPatSynBind b ++cvHsBindLR (AbsBinds {}) = ++ unsupported "AbsBind" "HsBindLR" (error "") ++cvHsBindLR (XHsBindsLR a) = pure (XHsBindsLR a) ++ ++cvHsWildCardBndrs ++ :: ( XHsWC GhcSe thing ~ XHsWC GhcPs thing' ++ , XXHsWildCardBndrs GhcSe thing ~ XXHsWildCardBndrs GhcPs thing' ++ ) ++ => (thing -> Conv thing') ++ -> HsWildCardBndrs GhcSe thing ++ -> Conv (HsWildCardBndrs GhcPs thing') ++cvHsWildCardBndrs thingF (HsWC a b) = HsWC a <$> thingF b ++cvHsWildCardBndrs _ (XHsWildCardBndrs a) = pure (XHsWildCardBndrs a) ++ ++cvLHsWcType ++ :: LHsWcType GhcSe -> Conv (LHsWcType GhcPs) ++cvLHsWcType = cvHsWildCardBndrs (traverse cvType) ++ ++cvHsSigWcType ++ :: LHsSigWcType GhcSe -> Conv (LHsSigWcType GhcPs) ++cvHsSigWcType = cvHsWildCardBndrs (cvHsImplicitBndrs (traverse cvType)) ++ ++cvHsImplicitBndrs ++ :: ( XHsIB GhcSe thing ~ XHsIB GhcPs thing' ++ , XXHsImplicitBndrs GhcSe thing ~ XXHsImplicitBndrs GhcPs thing' ++ ) ++ => (thing -> Conv thing') ++ -> HsImplicitBndrs GhcSe thing ++ -> Conv (HsImplicitBndrs GhcPs thing') ++cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b ++cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) ++ ++cvType :: HsType GhcSe -> Conv (HsType GhcPs) ++cvType (HsForAllTy a b c) = HsForAllTy a ++ <$> traverse (traverse cvHsTyVarBndr) b ++ <*> traverse cvType c ++cvType (HsQualTy a b c) = HsQualTy a ++ <$> traverse (traverse (traverse cvType)) b ++ <*> traverse cvType c ++cvType (HsTyVar a b c) = HsTyVar a b <$> convertName c ++cvType (HsAppTy a b c) = HsAppTy a ++ <$> traverse cvType b ++ <*> traverse cvType c ++cvType (HsFunTy a b c) = HsFunTy a ++ <$> traverse cvType b ++ <*> traverse cvType c ++cvType (HsListTy a b) = HsListTy a <$> traverse cvType b ++cvType (HsTupleTy a b c) = HsTupleTy a b <$> traverse (traverse cvType) c ++cvType (HsSumTy a b) = HsSumTy a <$> traverse (traverse cvType) b ++cvType (HsOpTy a b c d) = HsOpTy a ++ <$> traverse cvType b ++ <*> convertName c ++ <*> traverse cvType d ++cvType (HsParTy a b) = HsParTy a <$> traverse cvType b ++cvType (HsIParamTy a b c) = HsIParamTy a b <$> traverse cvType c ++cvType (HsKindSig a b c) = HsKindSig a ++ <$> traverse cvType b ++ <*> traverse cvType c ++cvType (HsBangTy a b c) = HsBangTy a b <$> traverse cvType c ++cvType (HsRecTy a b) = HsRecTy a <$> traverse (traverse cvConDeclField) b ++cvType (HsExplicitListTy a b c) = HsExplicitListTy a b ++ <$> traverse (traverse cvType) c ++cvType (HsExplicitTupleTy a b) = HsExplicitTupleTy a ++ <$> traverse (traverse cvType) b ++cvType (HsTyLit a b) = pure (HsTyLit a b) ++cvType (HsWildCardTy a) = pure (HsWildCardTy a) ++cvType (HsDocTy a b c) = HsDocTy a <$> traverse cvType b <*> pure c ++cvType (HsSpliceTy a b) = HsSpliceTy a <$> cvHsSplice b ++cvType (HsStarTy a b) = pure (HsStarTy a b) ++cvType (XHsType a) = pure (XHsType a) ++ ++cvHsTyVarBndr ++ :: HsTyVarBndr GhcSe -> Conv (HsTyVarBndr GhcPs) ++cvHsTyVarBndr (UserTyVar a b) = UserTyVar a <$> convertName b ++cvHsTyVarBndr (KindedTyVar a b c) = KindedTyVar a ++ <$> convertName b ++ <*> traverse cvType c ++cvHsTyVarBndr (XTyVarBndr a) = pure (XTyVarBndr a) ++ ++cvApplicativeArg ++ :: ApplicativeArg GhcSe -> Conv (ApplicativeArg GhcPs) ++cvApplicativeArg (ApplicativeArgOne a b c d) = ApplicativeArgOne a ++ <$> traverse cvPat b <*> cvLHsExpr c <*> pure d ++cvApplicativeArg (ApplicativeArgMany a b c d) = ApplicativeArgMany a ++ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> cvHsExpr c ++ <*> traverse cvPat d ++cvApplicativeArg (XApplicativeArg a) = pure (XApplicativeArg a) ++ ++cvSig :: Sig GhcSe -> Conv (Sig GhcPs) ++cvSig (TypeSig a b c) = TypeSig a <$> convertName b <*> cvHsSigWcType c ++cvSig (PatSynSig a b c) = PatSynSig a ++ <$> convertName b <*> cvHsImplicitBndrs (traverse cvType) c ++cvSig (ClassOpSig a b c d) = ClassOpSig a b ++ <$> convertName c <*> cvHsImplicitBndrs (traverse cvType) d ++cvSig (InlineSig a b c) = InlineSig a <$> convertName b <*> pure c ++cvSig (FixSig a b) = FixSig a <$> cvFixitySig b ++cvSig (SpecSig a b c d) = SpecSig a ++ <$> convertName b ++ <*> traverse (cvHsImplicitBndrs (traverse cvType)) c ++ <*> pure d ++cvSig (SpecInstSig a b c) = SpecInstSig a b ++ <$> cvHsImplicitBndrs (traverse cvType) c ++cvSig (SCCFunSig a b c d) = SCCFunSig a b <$> convertName c <*> pure d ++cvSig (CompleteMatchSig a b c d) = CompleteMatchSig a b ++ <$> convertName c <*> convertName d ++cvSig (MinimalSig a b c) = MinimalSig a b <$> traverse (traverse convertName) c ++cvSig (IdSig {}) = unsupported "IdSig" "Sig" (error "") ++cvSig (XSig a) = pure (XSig a) ++ ++cvFixitySig :: FixitySig GhcSe -> Conv (FixitySig GhcPs) ++cvFixitySig (FixitySig a b c) = FixitySig a <$> convertName b <*> pure c ++cvFixitySig (XFixitySig a) = pure (XFixitySig a) ++ ++cvPatSynBind :: PatSynBind GhcSe GhcSe -> Conv (PatSynBind GhcPs GhcPs) ++cvPatSynBind (PSB a b c d e) = PSB a ++ <$> convertName b ++ <*> cvHsPatSynDetails convertName c <*> traverse cvPat d ++ <*> cvHsPatSynDir e ++cvPatSynBind (XPatSynBind a) = pure (XPatSynBind a) ++ ++cvHsPatSynDetails ++ :: (a -> Conv b) ++ -> HsPatSynDetails a ++ -> Conv (HsPatSynDetails b) ++cvHsPatSynDetails f = cvHsConDetails f (traverse (cvRecordPatSynField f)) ++ ++cvRecordPatSynField ++ :: (a -> Conv b) ++ -> RecordPatSynField a ++ -> Conv (RecordPatSynField b) ++cvRecordPatSynField f (RecordPatSynField a b) = ++ RecordPatSynField <$> f a <*> f b ++ ++cvHsPatSynDir :: HsPatSynDir GhcSe -> Conv (HsPatSynDir GhcPs) ++cvHsPatSynDir Unidirectional = pure Unidirectional ++cvHsPatSynDir ImplicitBidirectional = pure ImplicitBidirectional ++cvHsPatSynDir (ExplicitBidirectional a) = ExplicitBidirectional ++ <$> cvMatchGroup cvLHsExpr a diff --git a/compiler/hsSyn/HsExprBin_Conversions.hs b/compiler/hsSyn/HsExprBin_Conversions.hs -deleted file mode 100644 -index df2d8f929a..0000000000 ---- a/compiler/hsSyn/HsExprBin_Conversions.hs -+++ /dev/null -@@ -1,211 +0,0 @@ --{-# LANGUAGE ConstraintKinds, DeriveFunctor #-} --{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} --{-# LANGUAGE MultiParamTypeClasses #-} --{-# LANGUAGE TypeFamilies, TypeSynonymInstances #-} --module HsExprBin_Conversions where -- --import Control.Applicative --import Control.Monad --import Control.Monad.IO.Class --import Data.Char (isDigit) --import Data.List (intercalate) --import Data.Maybe --import Data.Traversable -- --import DynFlags --import FastString --import GhcPrelude --import HsExpr --import Module --import Name --import Outputable --import PackageConfig --import Packages --import RdrName --import SeName --import SrcLoc --import TcRnTypes --import IfaceType --import ToIface (toIfaceType) --import TyCoRep (Type(..), TyLit(..)) -- --data ConvError -- = ConvUnsupported String String SDoc -- -- constructor name, type name, text rendering -- -- of the unsupported subexpression -- | ConvFailure String -- --data ConvResult a -- = ConvError ConvError -- | ConvOK a -- deriving Functor ---- * Conversion utilities -- --newtype Conv a = Conv { runConv :: RnM (ConvResult a) } -- --instance Functor Conv where -- fmap f (Conv k) = Conv (fmap (fmap f) k) -- --instance Applicative Conv where -- pure = Conv . return . ConvOK -- (<*>) = ap -- --instance Monad Conv where -- return = pure -- -- Conv mx >>= f = Conv $ mx >>= \cvx -> case cvx of -- ConvOK x -> runConv (f x) -- ConvError e -> pure (ConvError e) -- --unsupported :: String -- ^ constructor name -- -> String -- ^ type name -- -> SDoc -- ^ textual rendering of the unsupported subexpression -- -> Conv a --unsupported con ty subexpr = Conv $ -- pure (ConvError $ ConvUnsupported con ty subexpr) -- --badInput :: String -> Conv a --badInput str = Conv $ pure (ConvError $ ConvFailure str) -- --liftRn :: RnM a -> Conv a --liftRn = Conv . fmap ConvOK -- --class ConvertType t u where -- convertType :: t -> Conv u -- --class ConvertName a b where -- convertName :: a -> Conv b -- --instance ConvertName a b => ConvertName (Located a) (Located b) where -- convertName = traverse convertName -- --instance ConvertName a b => ConvertName [a] [b] where -- convertName = traverse convertName -- --instance ConvertName a b => ConvertName (Either e a) (Either e b) where -- convertName = traverse convertName -- --instance ConvertName a b => ConvertName (HsMatchContext a) (HsMatchContext b) where -- convertName = traverse convertName -- --instance ConvertName a b => ConvertName (HsStmtContext a) (HsStmtContext b) where -- convertName = traverse convertName -- --instance ConvertName a b => ConvertName (Maybe a) (Maybe b) where -- convertName = traverse convertName -- --instance ConvertType a a where -- convertType = pure -- --instance ConvertType Type IfaceType where -- convertType = pure . toIfaceType -- --instance ConvertType IfaceType Type where -- convertType (IfaceLitTy n) = pure $ LitTy (go n) -- where go (IfaceNumTyLit a) = NumTyLit a -- go (IfaceStrTyLit a) = StrTyLit a -- convertType e@(IfaceFreeTyVar {}) = unsupported "IfaceFreeTyVar" "IfaceType" (ppr e) -- convertType e@(IfaceTyVar {}) = unsupported "IfaceTyVar" "IfaceType" (ppr e) -- convertType e@(IfaceAppTy {}) = unsupported "IfaceAppTy" "IfaceType" (ppr e) -- convertType e@(IfaceFunTy {}) = unsupported "IfaceFunTy" "IfaceType" (ppr e) -- convertType e@(IfaceDFunTy {}) = unsupported "IfaceDFunTy" "IfaceType" (ppr e) -- convertType e@(IfaceForAllTy {}) = unsupported "IfaceForAllTy" "IfaceType" (ppr e) -- convertType e@(IfaceTyConApp {}) = unsupported "IfaceTyConApp" "IfaceType" (ppr e) -- convertType e@(IfaceCastTy {}) = unsupported "IfaceCastTy" "IfaceType" (ppr e) -- convertType e@(IfaceCoercionTy {}) = unsupported "IfaceCoercion" "IfaceType" (ppr e) -- convertType e@(IfaceTupleTy {}) = unsupported "IfaceTupleTy" "IfaceType" (ppr e) -- -- --instance ConvertName RdrName SeName where -- convertName = pure . mkSeName -- --instance ConvertName SeName RdrName where -- convertName (SeName n) = case n of -- Orig mod occn -> do -- -- TODO: introduce some caching here, to avoid doing the -- -- searchPackageId dance too often. -- currentMod <- liftRn getModule -- -- if samePackages currentMod mod -- then let newMod = mod { moduleUnitId = moduleUnitId currentMod } in -- pure (Orig newMod occn) -- else do mnewmod <- liftRn (findEquivalentModule mod) -- case mnewmod of -- Nothing -> pure (Orig mod occn) -- Just mod' -> pure (Orig mod' occn) -- -- _ -> pure n -- -- where samePackages mod1 mod2 = fromMaybe False $ do -- maybe monad -- let str1 = unitIdString (moduleUnitId mod1) -- str2 = unitIdString (moduleUnitId mod2) -- (pkg1, ver1, _mhash1) <- parseUnitId' str1 -- (pkg2, ver2, _mhash2) <- parseUnitId' str2 -- return (pkg1 == pkg2 && ver1 == ver2) -- --instance ConvertName Name SeName where -- convertName n = pure $ mkSeName (nameRdrName n) -- --instance ConvertName SeName Name where -- convertName (SeName n) = case isExact_maybe n of -- Just a -> pure a -- _ -> badInput "convertName :: SeName -> Name: non exact RdrName in SeName" -- ---- * Looking up modules/packages for Orig names -- ---- this rejects wired in packages, because we want to leave them untouched --parseUnitId' :: String -> Maybe (String, String, Maybe String) --parseUnitId' = parse -- -- where -- parse s = case splitOn '-' (reverse s) of -- ("":_) -> Nothing -- xs | length xs >= 1 && last xs == "" -> Nothing -- (hash:ver:name) | isVersion ver -> -- Just (intercalate "-" (reverse name), ver, Just hash) -- (ver:name) | isVersion ver -> -- Just (intercalate "-" (reverse name), ver, Nothing) -- _ -> Nothing -- splitOn c = go [] -- where go acc (x:xs) -- | x == c = acc : go "" xs -- | otherwise = go (x:acc) xs -- go acc [] = [acc] -- isVersion = go False -- -- True: waiting for digit or dot (we've seen a digit last) -- -- False: waiting for digit (we've just seen a dot) -- where go False (c:cs) -- | isDigit c = go True cs -- | otherwise = False -- go True (c:cs) -- | isDigit c = go True cs -- | c == '.' = go False cs -- | otherwise = False -- go b [] = b -- if we've seen a dot last (False), we fail -- -- otherwise, the version number can end here -- ---- | Look up the module from the same package, but built by the ---- current compiler, therefore with a slightly different hash ---- in the unit id than the input Module, which was built by some ---- non-cross-compiling GHC. --findEquivalentModule :: Module -> RnM (Maybe Module) --findEquivalentModule mod = do -- liftIO $ putStrLn ("Looking for equivalent to: " ++ unitIdStr) -- case parseUnitId' unitIdStr of -- Nothing -> return Nothing -- Just (pkg, ver, _mhash) -> do -- muid <- lookFor pkg ver -- maybe (pure Nothing) (\uid -> return $ Just (mod { moduleUnitId = uid })) muid -- -- where unitIdStr = unitIdString (moduleUnitId mod) -- --lookFor :: String -> String -> RnM (Maybe UnitId) --lookFor pkg ver = do -- dflags <- getDynFlags -- let pkgid = mkFastString (pkg ++ "-" ++ ver) -- pkgs = searchPackageId dflags (SourcePackageId pkgid) -- liftIO $ putStrLn ("Looking for: " ++ pkg ++ "-" ++ ver) -- liftIO . putStrLn . unwords $ -- [ "Found", show (length pkgs), "pkgs:" ] ++ -- [ unitIdString (packageConfigId p) | p <- pkgs ] -- if null pkgs then pure Nothing else pure (Just $ packageConfigId (head pkgs)) +new file mode 100644 +index 0000000000..df2d8f929a +--- /dev/null ++++ b/compiler/hsSyn/HsExprBin_Conversions.hs +@@ -0,0 +1,211 @@ ++{-# LANGUAGE ConstraintKinds, DeriveFunctor #-} ++{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} ++{-# LANGUAGE MultiParamTypeClasses #-} ++{-# LANGUAGE TypeFamilies, TypeSynonymInstances #-} ++module HsExprBin_Conversions where ++ ++import Control.Applicative ++import Control.Monad ++import Control.Monad.IO.Class ++import Data.Char (isDigit) ++import Data.List (intercalate) ++import Data.Maybe ++import Data.Traversable ++ ++import DynFlags ++import FastString ++import GhcPrelude ++import HsExpr ++import Module ++import Name ++import Outputable ++import PackageConfig ++import Packages ++import RdrName ++import SeName ++import SrcLoc ++import TcRnTypes ++import IfaceType ++import ToIface (toIfaceType) ++import TyCoRep (Type(..), TyLit(..)) ++ ++data ConvError ++ = ConvUnsupported String String SDoc ++ -- constructor name, type name, text rendering ++ -- of the unsupported subexpression ++ | ConvFailure String ++ ++data ConvResult a ++ = ConvError ConvError ++ | ConvOK a ++ deriving Functor ++-- * Conversion utilities ++ ++newtype Conv a = Conv { runConv :: RnM (ConvResult a) } ++ ++instance Functor Conv where ++ fmap f (Conv k) = Conv (fmap (fmap f) k) ++ ++instance Applicative Conv where ++ pure = Conv . return . ConvOK ++ (<*>) = ap ++ ++instance Monad Conv where ++ return = pure ++ ++ Conv mx >>= f = Conv $ mx >>= \cvx -> case cvx of ++ ConvOK x -> runConv (f x) ++ ConvError e -> pure (ConvError e) ++ ++unsupported :: String -- ^ constructor name ++ -> String -- ^ type name ++ -> SDoc -- ^ textual rendering of the unsupported subexpression ++ -> Conv a ++unsupported con ty subexpr = Conv $ ++ pure (ConvError $ ConvUnsupported con ty subexpr) ++ ++badInput :: String -> Conv a ++badInput str = Conv $ pure (ConvError $ ConvFailure str) ++ ++liftRn :: RnM a -> Conv a ++liftRn = Conv . fmap ConvOK ++ ++class ConvertType t u where ++ convertType :: t -> Conv u ++ ++class ConvertName a b where ++ convertName :: a -> Conv b ++ ++instance ConvertName a b => ConvertName (Located a) (Located b) where ++ convertName = traverse convertName ++ ++instance ConvertName a b => ConvertName [a] [b] where ++ convertName = traverse convertName ++ ++instance ConvertName a b => ConvertName (Either e a) (Either e b) where ++ convertName = traverse convertName ++ ++instance ConvertName a b => ConvertName (HsMatchContext a) (HsMatchContext b) where ++ convertName = traverse convertName ++ ++instance ConvertName a b => ConvertName (HsStmtContext a) (HsStmtContext b) where ++ convertName = traverse convertName ++ ++instance ConvertName a b => ConvertName (Maybe a) (Maybe b) where ++ convertName = traverse convertName ++ ++instance ConvertType a a where ++ convertType = pure ++ ++instance ConvertType Type IfaceType where ++ convertType = pure . toIfaceType ++ ++instance ConvertType IfaceType Type where ++ convertType (IfaceLitTy n) = pure $ LitTy (go n) ++ where go (IfaceNumTyLit a) = NumTyLit a ++ go (IfaceStrTyLit a) = StrTyLit a ++ convertType e@(IfaceFreeTyVar {}) = unsupported "IfaceFreeTyVar" "IfaceType" (ppr e) ++ convertType e@(IfaceTyVar {}) = unsupported "IfaceTyVar" "IfaceType" (ppr e) ++ convertType e@(IfaceAppTy {}) = unsupported "IfaceAppTy" "IfaceType" (ppr e) ++ convertType e@(IfaceFunTy {}) = unsupported "IfaceFunTy" "IfaceType" (ppr e) ++ convertType e@(IfaceDFunTy {}) = unsupported "IfaceDFunTy" "IfaceType" (ppr e) ++ convertType e@(IfaceForAllTy {}) = unsupported "IfaceForAllTy" "IfaceType" (ppr e) ++ convertType e@(IfaceTyConApp {}) = unsupported "IfaceTyConApp" "IfaceType" (ppr e) ++ convertType e@(IfaceCastTy {}) = unsupported "IfaceCastTy" "IfaceType" (ppr e) ++ convertType e@(IfaceCoercionTy {}) = unsupported "IfaceCoercion" "IfaceType" (ppr e) ++ convertType e@(IfaceTupleTy {}) = unsupported "IfaceTupleTy" "IfaceType" (ppr e) ++ ++ ++instance ConvertName RdrName SeName where ++ convertName = pure . mkSeName ++ ++instance ConvertName SeName RdrName where ++ convertName (SeName n) = case n of ++ Orig mod occn -> do ++ -- TODO: introduce some caching here, to avoid doing the ++ -- searchPackageId dance too often. ++ currentMod <- liftRn getModule ++ ++ if samePackages currentMod mod ++ then let newMod = mod { moduleUnitId = moduleUnitId currentMod } in ++ pure (Orig newMod occn) ++ else do mnewmod <- liftRn (findEquivalentModule mod) ++ case mnewmod of ++ Nothing -> pure (Orig mod occn) ++ Just mod' -> pure (Orig mod' occn) ++ ++ _ -> pure n ++ ++ where samePackages mod1 mod2 = fromMaybe False $ do -- maybe monad ++ let str1 = unitIdString (moduleUnitId mod1) ++ str2 = unitIdString (moduleUnitId mod2) ++ (pkg1, ver1, _mhash1) <- parseUnitId' str1 ++ (pkg2, ver2, _mhash2) <- parseUnitId' str2 ++ return (pkg1 == pkg2 && ver1 == ver2) ++ ++instance ConvertName Name SeName where ++ convertName n = pure $ mkSeName (nameRdrName n) ++ ++instance ConvertName SeName Name where ++ convertName (SeName n) = case isExact_maybe n of ++ Just a -> pure a ++ _ -> badInput "convertName :: SeName -> Name: non exact RdrName in SeName" ++ ++-- * Looking up modules/packages for Orig names ++ ++-- this rejects wired in packages, because we want to leave them untouched ++parseUnitId' :: String -> Maybe (String, String, Maybe String) ++parseUnitId' = parse ++ ++ where ++ parse s = case splitOn '-' (reverse s) of ++ ("":_) -> Nothing ++ xs | length xs >= 1 && last xs == "" -> Nothing ++ (hash:ver:name) | isVersion ver -> ++ Just (intercalate "-" (reverse name), ver, Just hash) ++ (ver:name) | isVersion ver -> ++ Just (intercalate "-" (reverse name), ver, Nothing) ++ _ -> Nothing ++ splitOn c = go [] ++ where go acc (x:xs) ++ | x == c = acc : go "" xs ++ | otherwise = go (x:acc) xs ++ go acc [] = [acc] ++ isVersion = go False ++ -- True: waiting for digit or dot (we've seen a digit last) ++ -- False: waiting for digit (we've just seen a dot) ++ where go False (c:cs) ++ | isDigit c = go True cs ++ | otherwise = False ++ go True (c:cs) ++ | isDigit c = go True cs ++ | c == '.' = go False cs ++ | otherwise = False ++ go b [] = b -- if we've seen a dot last (False), we fail ++ -- otherwise, the version number can end here ++ ++-- | Look up the module from the same package, but built by the ++-- current compiler, therefore with a slightly different hash ++-- in the unit id than the input Module, which was built by some ++-- non-cross-compiling GHC. ++findEquivalentModule :: Module -> RnM (Maybe Module) ++findEquivalentModule mod = do ++ liftIO $ putStrLn ("Looking for equivalent to: " ++ unitIdStr) ++ case parseUnitId' unitIdStr of ++ Nothing -> return Nothing ++ Just (pkg, ver, _mhash) -> do ++ muid <- lookFor pkg ver ++ maybe (pure Nothing) (\uid -> return $ Just (mod { moduleUnitId = uid })) muid ++ ++ where unitIdStr = unitIdString (moduleUnitId mod) ++ ++lookFor :: String -> String -> RnM (Maybe UnitId) ++lookFor pkg ver = do ++ dflags <- getDynFlags ++ let pkgid = mkFastString (pkg ++ "-" ++ ver) ++ pkgs = searchPackageId dflags (SourcePackageId pkgid) ++ liftIO $ putStrLn ("Looking for: " ++ pkg ++ "-" ++ ver) ++ liftIO . putStrLn . unwords $ ++ [ "Found", show (length pkgs), "pkgs:" ] ++ ++ [ unitIdString (packageConfigId p) | p <- pkgs ] ++ if null pkgs then pure Nothing else pure (Just $ packageConfigId (head pkgs)) diff --git a/compiler/hsSyn/HsExprBin_Instances.hs b/compiler/hsSyn/HsExprBin_Instances.hs -deleted file mode 100644 -index 24abf8d69a..0000000000 ---- a/compiler/hsSyn/HsExprBin_Instances.hs -+++ /dev/null -@@ -1,1665 +0,0 @@ ---- too noisy during development... --{-# OPTIONS_GHC -fno-warn-orphans #-} --{-# LANGUAGE GeneralizedNewtypeDeriving #-} --{-# LANGUAGE StandaloneDeriving #-} --{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} --module HsExprBin_Instances where -- --import Control.Applicative --import Control.Monad -- --import BasicTypes --import Binary --import CoreSyn ( Tickish(..) ) --import GhcPrelude --import HsBinds --import HsDecls --import HsExpr --import HsExtension --import HsLit --import HsPat --import HsTypes --import Name --import Outputable --import RdrName --import SeName --import SrcLoc --import TcEvidence (HsWrapper(WpHole)) -- ---- * Utilities -- --putPanic :: String -> String -> a --putPanic tyName conName = -- panic ("Binary " ++ tyName ++ ".put: " ++ conName ++ " not supported") -- --getPanic :: String -> a --getPanic tyName = -- panic ("Binary " ++ tyName ++ ".get: unknown (or unsupported) tag") -- ---- * Binary instances -- --instance Binary (HsExpr GhcSe) where -- put_ bh e = case e of -- HsVar a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- HsUnboundVar a b -> -- putByte bh 1 >> put_ bh a >> put_ bh b -- HsRecFld a b -> -- putByte bh 2 >> put_ bh a >> put_ bh b -- HsOverLabel a b c -> -- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -- HsIPVar a b -> -- putByte bh 4 >> put_ bh a >> put_ bh b -- HsOverLit a b -> -- putByte bh 5 >> put_ bh a >> put_ bh b -- HsLit a b -> -- putByte bh 6 >> put_ bh a >> put_ bh b -- HsLam a b -> -- putByte bh 7 >> put_ bh a >> put_ bh b -- HsLamCase a b -> -- putByte bh 8 >> put_ bh a >> put_ bh b -- HsApp a b c -> -- putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c -- HsAppType a b -> -- putByte bh 10 >> put_ bh a >> put_ bh b -- OpApp a b c d -> -- putByte bh 11 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d -- NegApp a b c -> -- putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c -- HsPar a b -> -- putByte bh 13 >> put_ bh a >> put_ bh b -- SectionL a b c -> -- putByte bh 14 >> put_ bh a >> put_ bh b >> put_ bh c -- SectionR a b c -> -- putByte bh 15 >> put_ bh a >> put_ bh b >> put_ bh c -- ExplicitTuple a b c -> -- putByte bh 16 >> put_ bh a >> put_ bh b >> put_ bh c -- ExplicitSum a b c d -> -- putByte bh 17 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d -- HsCase a b c -> -- putByte bh 18 >> put_ bh a >> put_ bh b >> put_ bh c -- HsIf a b c d e -> -- putByte bh 19 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d >> put_ bh e -- HsMultiIf a b -> -- putByte bh 20 >> put_ bh a >> put_ bh b -- HsLet a b c -> -- putByte bh 21 >> put_ bh a >> put_ bh b >> put_ bh c -- HsDo a b c -> -- putByte bh 22 >> put_ bh a >> put_ bh b >> put_ bh c -- ExplicitList a b c -> -- putByte bh 23 >> put_ bh a >> put_ bh b >> put_ bh c -- RecordCon a b c -> -- putByte bh 24 >> put_ bh a >> put_ bh b >> put_ bh c -- RecordUpd a b c -> -- putByte bh 25 >> put_ bh a >> put_ bh b >> put_ bh c -- ExprWithTySig a b -> -- putByte bh 26 >> put_ bh a >> put_ bh b -- ArithSeq a b c -> -- putByte bh 27 >> put_ bh a >> put_ bh b >> put_ bh c -- EWildPat a -> -- putByte bh 28 >> put_ bh a -- EAsPat a b c -> -- putByte bh 29 >> put_ bh a >> put_ bh b >> put_ bh c -- EViewPat a b c -> -- putByte bh 30 >> put_ bh a >> put_ bh b >> put_ bh c -- ELazyPat a b -> -- putByte bh 31 >> put_ bh a >> put_ bh b -- HsStatic a b -> -- putByte bh 32 >> put_ bh a >> put_ bh b -- HsProc a b c -> -- putByte bh 33 >> put_ bh a >> put_ bh b >> put_ bh c -- HsBinTick a b c d -> -- putByte bh 34 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d -- HsTickPragma a b c d e -> -- putByte bh 35 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d >> put_ bh e -- HsSpliceE a b -> -- putByte bh 36 >> put_ bh a >> put_ bh b -- HsSCC a b c d -> -- putByte bh 37 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d -- HsCoreAnn a b c d -> -- putByte bh 38 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d -- HsBracket a b -> -- putByte bh 39 >> put_ bh a >> put_ bh b -- XExpr a -> -- putByte bh 40 >> put_ bh a -- HsConLikeOut {} -> putPanic "HsExpr" "HsConLikeOut" -- HsRnBracketOut {} -> putPanic "HsExpr" "HsRnBracketOut" -- HsTcBracketOut {} -> putPanic "HsExpr" "HsTcBracketOut" -- HsArrApp {} -> putPanic "HsExpr" "HsArrApp" -- HsArrForm {} -> putPanic "HsExpr" "HsArrForm" -- HsTick {} -> putPanic "HsExpr" "HsTick" -- HsWrap {} -> putPanic "HsExpr" "HsWrap" -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsVar <$> get bh <*> get bh -- 1 -> HsUnboundVar <$> get bh <*> get bh -- 2 -> HsRecFld <$> get bh <*> get bh -- 3 -> HsOverLabel <$> get bh <*> get bh <*> get bh -- 4 -> HsIPVar <$> get bh <*> get bh -- 5 -> HsOverLit <$> get bh <*> get bh -- 6 -> HsLit <$> get bh <*> get bh -- 7 -> HsLam <$> get bh <*> get bh -- 8 -> HsLamCase <$> get bh <*> get bh -- 9 -> HsApp <$> get bh <*> get bh <*> get bh -- 10 -> HsAppType <$> get bh <*> get bh -- 11 -> OpApp <$> get bh <*> get bh <*> get bh <*> get bh -- 12 -> NegApp <$> get bh <*> get bh <*> get bh -- 13 -> HsPar <$> get bh <*> get bh -- 14 -> SectionL <$> get bh <*> get bh <*> get bh -- 15 -> SectionR <$> get bh <*> get bh <*> get bh -- 16 -> ExplicitTuple <$> get bh <*> get bh <*> get bh -- 17 -> ExplicitSum <$> get bh <*> get bh <*> get bh <*> get bh -- 18 -> HsCase <$> get bh <*> get bh <*> get bh -- 19 -> HsIf <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -- 20 -> HsMultiIf <$> get bh <*> get bh -- 21 -> HsLet <$> get bh <*> get bh <*> get bh -- 22 -> HsDo <$> get bh <*> get bh <*> get bh -- 23 -> ExplicitList <$> get bh <*> get bh <*> get bh -- 24 -> RecordCon <$> get bh <*> get bh <*> get bh -- 25 -> RecordUpd <$> get bh <*> get bh <*> get bh -- 26 -> ExprWithTySig <$> get bh <*> get bh -- 27 -> ArithSeq <$> get bh <*> get bh <*> get bh -- 28 -> EWildPat <$> get bh -- 29 -> EAsPat <$> get bh <*> get bh <*> get bh -- 30 -> EViewPat <$> get bh <*> get bh <*> get bh -- 31 -> ELazyPat <$> get bh <*> get bh -- 32 -> HsStatic <$> get bh <*> get bh -- 33 -> HsProc <$> get bh <*> get bh <*> get bh -- 34 -> HsBinTick <$> get bh <*> get bh <*> get bh <*> get bh -- 35 -> HsTickPragma <$> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh -- 36 -> HsSpliceE <$> get bh <*> get bh -- 37 -> HsSCC <$> get bh <*> get bh <*> get bh <*> get bh -- 38 -> HsCoreAnn <$> get bh <*> get bh <*> get bh <*> get bh -- 39 -> HsBracket <$> get bh <*> get bh -- 40 -> XExpr <$> get bh -- _ -> getPanic "HsExpr" -- --instance Binary (HsBracket GhcSe) where -- put_ bh b = case b of -- ExpBr a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- PatBr a b -> -- putByte bh 1 >> put_ bh a >> put_ bh b -- DecBrL a b -> -- putByte bh 2 >> put_ bh a >> put_ bh b -- DecBrG a b -> -- putByte bh 3 >> put_ bh a >> put_ bh b -- TypBr a b -> -- putByte bh 4 >> put_ bh a >> put_ bh b -- VarBr a b c -> -- putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c -- TExpBr a b -> -- putByte bh 6 >> put_ bh a >> put_ bh b -- XBracket a -> -- putByte bh 7 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ExpBr <$> get bh <*> get bh -- 1 -> PatBr <$> get bh <*> get bh -- 2 -> DecBrL <$> get bh <*> get bh -- 3 -> DecBrG <$> get bh <*> get bh -- 4 -> TypBr <$> get bh <*> get bh -- 5 -> VarBr <$> get bh <*> get bh <*> get bh -- 6 -> TExpBr <$> get bh <*> get bh -- 7 -> XBracket <$> get bh -- _ -> getPanic "HsBracket" -- --instance Binary SeName where -- put_ bh (SeName n) = put_ bh n -- get bh = mkSeName <$> get bh -- --instance Binary UnboundVar where -- put_ bh v = case v of -- OutOfScope a b -> putByte bh 0 >> put_ bh a >> put_ bh b -- TrueExprHole a -> putByte bh 1 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> OutOfScope <$> get bh <*> get bh -- 1 -> TrueExprHole <$> get bh -- _ -> getPanic "UnboundVar" -- --instance Binary a => Binary (StmtLR GhcSe GhcSe a) where -- put_ bh s = case s of -- LastStmt a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- BindStmt a b c d e -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e -- ApplicativeStmt a b c -> -- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -- BodyStmt a b c d -> -- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- LetStmt a b -> -- putByte bh 4 >> put_ bh a >> put_ bh b -- ParStmt a b c d -> -- putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- RecStmt a b c d e f g -> -- putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f >> put_ bh g -- TransStmt a b c d e f g h i -> -- putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h -- >> put_ bh i -- XStmtLR a -> -- putByte bh 8 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> LastStmt <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> BindStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -- 2 -> ApplicativeStmt <$> get bh <*> get bh <*> get bh -- 3 -> BodyStmt <$> get bh <*> get bh <*> get bh <*> get bh -- 4 -> LetStmt <$> get bh <*> get bh -- 5 -> ParStmt <$> get bh <*> get bh <*> get bh <*> get bh -- 6 -> RecStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh -- 7 -> TransStmt <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh -- 8 -> XStmtLR <$> get bh -- _ -> getPanic "StmtLR" -- --instance Binary (HsGroup GhcSe) where -- put_ bh x = case x of -- HsGroup a b c d e f g h i j k l -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h -- >> put_ bh i >> put_ bh j >> put_ bh k >> put_ bh l -- XHsGroup a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsGroup <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh <*> get bh <*> get bh -- 1 -> XHsGroup <$> get bh -- _ -> getPanic "HsGroup" -- --instance Binary (TyClGroup GhcSe) where -- put_ bh g = case g of -- TyClGroup a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- XTyClGroup a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> TyClGroup <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> XTyClGroup <$> get bh -- _ -> getPanic "TyClGroup" -- --instance Binary (HsCmdTop GhcSe) where -- put_ bh c = case c of -- HsCmdTop a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- XCmdTop a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsCmdTop <$> get bh <*> get bh -- 1 -> XCmdTop <$> get bh -- _ -> getPanic "HsCmdTop" -- --instance Binary (HsCmd GhcSe) where -- put_ bh c = case c of -- HsCmdArrApp a b c d e -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d >> put_ bh e -- HsCmdArrForm a b c d e -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d >> put_ bh e -- HsCmdApp a b c -> -- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -- HsCmdLam a b -> -- putByte bh 3 >> put_ bh a >> put_ bh b -- HsCmdPar a b -> -- putByte bh 4 >> put_ bh a >> put_ bh b -- HsCmdCase a b c -> -- putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c -- HsCmdIf a b c d e -> -- putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d >> put_ bh e -- HsCmdLet a b c -> -- putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c -- HsCmdDo a b -> -- putByte bh 8 >> put_ bh a >> put_ bh b -- XCmd a -> -- putByte bh 9 >> put_ bh a -- HsCmdWrap {} -> -- putPanic "HsCmdWrap" "HsCmd" -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsCmdArrApp <$> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh -- 1 -> HsCmdArrForm <$> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh -- 2 -> HsCmdApp <$> get bh <*> get bh <*> get bh -- 3 -> HsCmdLam <$> get bh <*> get bh -- 4 -> HsCmdPar <$> get bh <*> get bh -- 5 -> HsCmdCase <$> get bh <*> get bh <*> get bh -- 6 -> HsCmdIf <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -- 7 -> HsCmdLet <$> get bh <*> get bh <*> get bh -- 8 -> HsCmdDo <$> get bh <*> get bh -- 9 -> XCmd <$> get bh -- _ -> getPanic "HsCmd" -- --instance Binary HsArrAppType where -- put_ bh t = putByte bh $ case t of -- HsHigherOrderApp -> 0 -- HsFirstOrderApp -> 1 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure HsHigherOrderApp -- 1 -> pure HsFirstOrderApp -- _ -> getPanic "HsArrAppType" -- --instance Binary TransForm where -- put_ bh f = putByte bh $ case f of -- ThenForm -> 0 -- GroupForm -> 1 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure ThenForm -- 1 -> pure GroupForm -- _ -> getPanic "TransForm" -- --instance Binary (ApplicativeArg GhcSe) where -- put_ bh a = case a of -- ApplicativeArgOne a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- ApplicativeArgMany a b c d -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- XApplicativeArg a -> -- putByte bh 2 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ApplicativeArgOne <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> ApplicativeArgMany <$> get bh <*> get bh <*> get bh <*> get bh -- 2 -> XApplicativeArg <$> get bh -- _ -> getPanic "ApplicativeArg" -- --instance Binary (ParStmtBlock GhcSe GhcSe) where -- put_ bh b = case b of -- ParStmtBlock a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- XParStmtBlock a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ParStmtBlock <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> XParStmtBlock <$> get bh -- _ -> getPanic "ParStmtBlock" -- --instance Binary (SyntaxExpr GhcSe) where -- put_ bh (SyntaxExpr a [] WpHole) = put_ bh a -- put_ _ _ = panic "Binary SyntaxExpr.put: wrappers should be empty" -- get bh = SyntaxExpr <$> get bh <*> pure [] <*> pure WpHole -- --instance Binary a => Binary (GRHSs GhcSe a) where -- put_ bh g = case g of -- GRHSs a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XGRHSs a -> putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> GRHSs <$> get bh <*> get bh <*> get bh -- 1 -> XGRHSs <$> get bh -- _ -> getPanic "GRHSs" -- --instance Binary a => Binary (GRHS GhcSe a) where -- put_ bh g = case g of -- GRHS a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XGRHS a -> putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> GRHS <$> get bh <*> get bh <*> get bh -- 1 -> XGRHS <$> get bh -- _ -> getPanic "GRHS" -- --instance Binary a => Binary (MatchGroup GhcSe a) where -- put_ bh g = case g of -- MG a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XMatchGroup a -> putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> MG <$> get bh <*> get bh <*> get bh -- 1 -> XMatchGroup <$> get bh -- _ -> getPanic "MatchGroup" -- --instance Binary a => Binary (Match GhcSe a) where -- put_ bh m = case m of -- Match a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- XMatch a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> Match <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> XMatch <$> get bh -- _ -> getPanic "Match" -- --instance Binary (HsMatchContext SeName) where -- put_ bh c = case c of -- FunRhs a b c -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- LambdaExpr -> -- putByte bh 1 -- CaseAlt -> -- putByte bh 2 -- IfAlt -> -- putByte bh 3 -- ProcExpr -> -- putByte bh 4 -- PatBindRhs -> -- putByte bh 5 -- RecUpd -> -- putByte bh 6 -- StmtCtxt a -> -- putByte bh 7 >> put_ bh a -- ThPatSplice -> -- putByte bh 8 -- ThPatQuote -> -- putByte bh 9 -- PatSyn -> -- putByte bh 10 -- PatBindGuards -> -- putByte bh 11 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> FunRhs <$> get bh <*> get bh <*> get bh -- 1 -> pure LambdaExpr -- 2 -> pure CaseAlt -- 3 -> pure IfAlt -- 4 -> pure ProcExpr -- 5 -> pure PatBindRhs -- 6 -> pure RecUpd -- 7 -> StmtCtxt <$> get bh -- 8 -> pure ThPatSplice -- 9 -> pure ThPatQuote -- 10 -> pure PatSyn -- 11 -> pure PatBindGuards -- _ -> getPanic "HsMatchContext" -- --instance Binary (HsStmtContext SeName) where -- put_ bh c = case c of -- ListComp -> putByte bh 0 -- MonadComp -> putByte bh 1 -- DoExpr -> putByte bh 3 -- MDoExpr -> putByte bh 4 -- ArrowExpr -> putByte bh 5 -- GhciStmtCtxt -> putByte bh 6 -- PatGuard a -> putByte bh 7 >> put_ bh a -- ParStmtCtxt a -> putByte bh 8 >> put_ bh a -- TransStmtCtxt a -> putByte bh 9 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure ListComp -- 1 -> pure MonadComp -- 3 -> pure DoExpr -- 4 -> pure MDoExpr -- 5 -> pure ArrowExpr -- 6 -> pure GhciStmtCtxt -- 7 -> PatGuard <$> get bh -- 8 -> ParStmtCtxt <$> get bh -- 9 -> TransStmtCtxt <$> get bh -- _ -> getPanic "HsStmtContext" -- --instance Binary (ArithSeqInfo GhcSe) where -- put_ bh i = case i of -- From a -> -- putByte bh 0 >> put_ bh a -- FromThen a b -> -- putByte bh 1 >> put_ bh a >> put_ bh b -- FromTo a b -> -- putByte bh 2 >> put_ bh a >> put_ bh b -- FromThenTo a b c -> -- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> From <$> get bh -- 1 -> FromThen <$> get bh <*> get bh -- 2 -> FromTo <$> get bh <*> get bh -- 3 -> FromThenTo <$> get bh <*> get bh <*> get bh -- _ -> getPanic "ArithSeqInfo" -- --instance Binary (HsTupArg GhcSe) where -- put_ bh a = case a of -- Present a b -> putByte bh 0 >> put_ bh a >> put_ bh b -- Missing a -> putByte bh 1 >> put_ bh a -- XTupArg a -> putByte bh 2 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> Present <$> get bh <*> get bh -- 1 -> Missing <$> get bh -- 2 -> XTupArg <$> get bh -- _ -> getPanic "HsTupArg" -- --instance Binary (Pat GhcSe) where -- put_ bh p = case p of -- WildPat a -> -- putByte bh 0 >> put_ bh a -- VarPat a b -> -- putByte bh 1 >> put_ bh a >> put_ bh b -- LazyPat a b -> -- putByte bh 2 >> put_ bh a >> put_ bh b -- AsPat a b c -> -- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -- ParPat a b -> -- putByte bh 4 >> put_ bh a >> put_ bh b -- BangPat a b -> -- putByte bh 5 >> put_ bh a >> put_ bh b -- ListPat a b -> -- putByte bh 6 >> put_ bh a >> put_ bh b -- TuplePat a b c -> -- putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c -- SumPat a b c d -> -- putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- ConPatIn a b -> -- putByte bh 9 >> put_ bh a >> put_ bh b -- ViewPat a b c -> -- putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -- LitPat a b -> -- putByte bh 11 >> put_ bh a >> put_ bh b -- NPat a b c d -> -- putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- NPlusKPat a b c d e f -> -- putByte bh 13 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f -- SigPat a b -> -- putByte bh 14 >> put_ bh a >> put_ bh b -- SplicePat a b -> -- putByte bh 15 >> put_ bh a >> put_ bh b -- XPat a -> -- putByte bh 16 >> put_ bh a -- ConPatOut {} -> putPanic "Pat" "ConPatOut" -- CoPat {} -> putPanic "Pat" "CoPat" -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> WildPat <$> get bh -- 1 -> VarPat <$> get bh <*> get bh -- 2 -> LazyPat <$> get bh <*> get bh -- 3 -> AsPat <$> get bh <*> get bh <*> get bh -- 4 -> ParPat <$> get bh <*> get bh -- 5 -> BangPat <$> get bh <*> get bh -- 6 -> ListPat <$> get bh <*> get bh -- 7 -> TuplePat <$> get bh <*> get bh <*> get bh -- 8 -> SumPat <$> get bh <*> get bh <*> get bh <*> get bh -- 9 -> ConPatIn <$> get bh <*> get bh -- 10 -> ViewPat <$> get bh <*> get bh <*> get bh -- 11 -> LitPat <$> get bh <*> get bh -- 12 -> NPat <$> get bh <*> get bh <*> get bh <*> get bh -- 13 -> NPlusKPat <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh -- 14 -> SigPat <$> get bh <*> get bh -- 15 -> SplicePat <$> get bh <*> get bh -- 16 -> XPat <$> get bh -- _ -> getPanic "HsPat" -- --instance Binary NoExt where -- put_ _ NoExt = return () -- get _ = pure NoExt -- --instance (Binary (FieldOcc a), Binary b) => Binary (HsRecFields a b) where -- put_ bh (HsRecFields a b) = put_ bh a >> put_ bh b -- get bh = HsRecFields <$> get bh <*> get bh -- --instance (Binary id, Binary arg) => Binary (HsRecField' id arg) where -- put_ bh (HsRecField a b c) = put_ bh a >> put_ bh b >> put_ bh c -- get bh = HsRecField <$> get bh <*> get bh <*> get bh -- --instance Binary (HsType GhcSe) where -- put_ bh t = case t of -- HsForAllTy a b c -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- HsQualTy a b c -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -- HsTyVar a b c -> -- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -- HsAppTy a b c -> -- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -- HsFunTy a b c -> -- putByte bh 4 >> put_ bh a >> put_ bh b >> put_ bh c -- HsListTy a b -> -- putByte bh 5 >> put_ bh a >> put_ bh b -- HsTupleTy a b c -> -- putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c -- HsSumTy a b -> -- putByte bh 7 >> put_ bh a >> put_ bh b -- HsOpTy a b c d -> -- putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- HsParTy a b -> -- putByte bh 9 >> put_ bh a >> put_ bh b -- HsIParamTy a b c -> -- putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -- HsKindSig a b c -> -- putByte bh 11 >> put_ bh a >> put_ bh b >> put_ bh c -- HsBangTy a b c -> -- putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c -- HsRecTy a b -> -- putByte bh 13 >> put_ bh a >> put_ bh b -- HsExplicitListTy a b c -> -- putByte bh 14 >> put_ bh a >> put_ bh b >> put_ bh c -- HsExplicitTupleTy a b -> -- putByte bh 15 >> put_ bh a >> put_ bh b -- HsTyLit a b -> -- putByte bh 16 >> put_ bh a >> put_ bh b -- HsWildCardTy a -> -- putByte bh 17 >> put_ bh a -- HsDocTy a b c -> -- putByte bh 18 >> put_ bh a >> put_ bh b >> put_ bh c -- HsSpliceTy a b -> -- putByte bh 19 >> put_ bh a >> put_ bh b -- HsStarTy a b -> -- putByte bh 20 >> put_ bh a >> put_ bh b -- XHsType _ -> -- putPanic "XHsType" "HsType" -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsForAllTy <$> get bh <*> get bh <*> get bh -- 1 -> HsQualTy <$> get bh <*> get bh <*> get bh -- 2 -> HsTyVar <$> get bh <*> get bh <*> get bh -- 3 -> HsAppTy <$> get bh <*> get bh <*> get bh -- 4 -> HsFunTy <$> get bh <*> get bh <*> get bh -- 5 -> HsListTy <$> get bh <*> get bh -- 6 -> HsTupleTy <$> get bh <*> get bh <*> get bh -- 7 -> HsSumTy <$> get bh <*> get bh -- 8 -> HsOpTy <$> get bh <*> get bh <*> get bh <*> get bh -- 9 -> HsParTy <$> get bh <*> get bh -- 10 -> HsIParamTy <$> get bh <*> get bh <*> get bh -- 11 -> HsKindSig <$> get bh <*> get bh <*> get bh -- 12 -> HsBangTy <$> get bh <*> get bh <*> get bh -- 13 -> HsRecTy <$> get bh <*> get bh -- 14 -> HsExplicitListTy <$> get bh <*> get bh <*> get bh -- 15 -> HsExplicitTupleTy <$> get bh <*> get bh -- 16 -> HsTyLit <$> get bh <*> get bh -- 17 -> HsWildCardTy <$> get bh -- 18 -> HsDocTy <$> get bh <*> get bh <*> get bh -- 19 -> HsSpliceTy <$> get bh <*> get bh -- 20 -> HsStarTy <$> get bh <*> get bh -- _ -> getPanic "HsType" -- --instance Binary HsTyLit where -- put_ bh l = case l of -- HsNumTy a b -> putByte bh 0 >> put_ bh a >> put_ bh b -- HsStrTy a b -> putByte bh 1 >> put_ bh a >> put_ bh b -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsNumTy <$> get bh <*> get bh -- 1 -> HsStrTy <$> get bh <*> get bh -- _ -> getPanic "HsTyLit" -- --instance Binary a => Binary (HsWildCardBndrs GhcSe a) where -- put_ bh w = case w of -- HsWC a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- XHsWildCardBndrs a -> -- putByte bh 1 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsWC <$> get bh <*> get bh -- 1 -> XHsWildCardBndrs <$> get bh -- _ -> getPanic "HsWildCardBndrs" -- --instance Binary a => Binary (HsImplicitBndrs GhcSe a) where -- put_ bh b = case b of -- HsIB a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- XHsImplicitBndrs a -> -- putByte bh 1 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsIB <$> get bh <*> get bh -- 1 -> XHsImplicitBndrs <$> get bh -- _ -> getPanic "HsImplicitBndrs" -- --instance Binary HsTupleSort where -- put_ bh s = putByte bh (case s of -- HsUnboxedTuple -> 0 -- HsBoxedTuple -> 1 -- HsConstraintTuple -> 2 -- HsBoxedOrConstraintTuple -> 3) -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure HsUnboxedTuple -- 1 -> pure HsBoxedTuple -- 2 -> pure HsConstraintTuple -- 3 -> pure HsBoxedOrConstraintTuple -- _ -> getPanic "HsTupleSort" -- --instance Binary (ConDeclField GhcSe) where -- put_ bh f = case f of -- ConDeclField a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- XConDeclField a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ConDeclField <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> XConDeclField <$> get bh -- _ -> getPanic "ConDeclField" -- --instance Binary (FieldOcc GhcSe) where -- put_ bh o = case o of -- FieldOcc a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- XFieldOcc a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> FieldOcc <$> get bh <*> get bh -- 1 -> XFieldOcc <$> get bh -- _ -> getPanic "FieldOcc" -- --instance Binary (HsTyVarBndr GhcSe) where -- put_ bh v = case v of -- UserTyVar a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- KindedTyVar a b c -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -- XTyVarBndr a -> -- putByte bh 2 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> UserTyVar <$> get bh <*> get bh -- 1 -> KindedTyVar <$> get bh <*> get bh <*> get bh -- 2 -> XTyVarBndr <$> get bh -- _ -> getPanic "HsTyVarBndr" -- --instance (Binary a, Binary b) => Binary (HsConDetails a b) where -- put_ bh c = case c of -- PrefixCon a -> putByte bh 0 >> put_ bh a -- RecCon a -> putByte bh 1 >> put_ bh a -- InfixCon a b -> putByte bh 2 >> put_ bh a >> put_ bh b -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> PrefixCon <$> get bh -- 1 -> RecCon <$> get bh -- 2 -> InfixCon <$> get bh <*> get bh -- _ -> getPanic "HsConDetails" -- --instance Binary (AmbiguousFieldOcc GhcSe) where -- put_ bh o = case o of -- Unambiguous a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- Ambiguous a b -> -- putByte bh 1 >> put_ bh a >> put_ bh b -- XAmbiguousFieldOcc a -> -- putByte bh 2 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> Unambiguous <$> get bh <*> get bh -- 1 -> Ambiguous <$> get bh <*> get bh -- 2 -> XAmbiguousFieldOcc <$> get bh -- _ -> getPanic "AmbiguousOccField" -- --instance Binary (LHsQTyVars GhcSe) where -- put_ bh v = case v of -- HsQTvs a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- XLHsQTyVars a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsQTvs <$> get bh <*> get bh -- 1 -> XLHsQTyVars <$> get bh -- _ -> getPanic "LHsQTyVars" -- --instance Binary (Sig GhcSe) where -- put_ bh s = case s of -- TypeSig a b c -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- PatSynSig a b c -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -- ClassOpSig a b c d -> -- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- IdSig a b -> -- putByte bh 3 >> put_ bh a >> put_ bh b -- FixSig a b -> -- putByte bh 4 >> put_ bh a >> put_ bh b -- InlineSig a b c -> -- putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c -- SpecSig a b c d -> -- putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- SpecInstSig a b c -> -- putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c -- SCCFunSig a b c d -> -- putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- CompleteMatchSig a b c d -> -- putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- MinimalSig a b c -> -- putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -- XSig a -> -- putByte bh 11 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> TypeSig <$> get bh <*> get bh <*> get bh -- 1 -> PatSynSig <$> get bh <*> get bh <*> get bh -- 2 -> ClassOpSig <$> get bh <*> get bh <*> get bh <*> get bh -- 3 -> IdSig <$> get bh <*> get bh -- 4 -> FixSig <$> get bh <*> get bh -- 5 -> InlineSig <$> get bh <*> get bh <*> get bh -- 6 -> SpecSig <$> get bh <*> get bh <*> get bh <*> get bh -- 7 -> SpecInstSig <$> get bh <*> get bh <*> get bh -- 8 -> SCCFunSig <$> get bh <*> get bh <*> get bh <*> get bh -- 9 -> CompleteMatchSig <$> get bh <*> get bh <*> get bh <*> get bh -- 10 -> MinimalSig <$> get bh <*> get bh <*> get bh -- 11 -> XSig <$> get bh -- _ -> getPanic "Sig" -- --instance Binary (FixitySig GhcSe) where -- put_ bh s = case s of -- FixitySig a b c -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XFixitySig a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> FixitySig <$> get bh <*> get bh <*> get bh -- 1 -> XFixitySig <$> get bh -- _ -> getPanic "FixitySig" -- --instance Binary (HsBindLR GhcSe GhcSe) where -- put_ bh b = case b of -- -- TODO: we drop the "fun_co_fn" field, as it seems -- -- to always be WpHole in the places where the binary -- -- serialisation instances will be used. -- -- TODO: we drop the "fun_tick" field, as it is unlikely -- -- to be used in our immediate use cases. Let's -- -- return to parametrising away the 'Id' in that -- -- field's type. -- FunBind a b c d _ -> case d of -- WpHole -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- _ -> -- panic "Binary HsBindLR: FunBind with non-WpHole value in fun_co_fn" -- -- TODO: same as for FunBind, we drop pat_ticks -- PatBind a b c _ -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -- VarBind a b c d -> -- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- PatSynBind a b -> -- putByte bh 3 >> put_ bh a >> put_ bh b -- XHsBindsLR a -> -- putByte bh 4 >> put_ bh a -- AbsBinds {} -> putPanic "HsBindsLR" "AbsBinds" -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> FunBind <$> get bh <*> get bh <*> get bh <*> pure WpHole <*> pure [] -- 1 -> PatBind <$> get bh <*> get bh <*> get bh <*> pure ([], []) -- 2 -> VarBind <$> get bh <*> get bh <*> get bh <*> get bh -- 3 -> PatSynBind <$> get bh <*> get bh -- 4 -> XHsBindsLR <$> get bh -- _ -> getPanic "HsBindsLR" -- --instance Binary (HsLocalBindsLR GhcSe GhcSe) where -- put_ bh b = case b of -- HsValBinds a b -> putByte bh 0 >> put_ bh a >> put_ bh b -- EmptyLocalBinds a -> putByte bh 1 >> put_ bh a -- XHsLocalBindsLR a -> putByte bh 2 >> put_ bh a -- HsIPBinds {} -> putPanic "HsLocalBindsLR" "HsIPBinds" -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsValBinds <$> get bh <*> get bh -- 1 -> EmptyLocalBinds <$> get bh -- 2 -> XHsLocalBindsLR <$> get bh -- _ -> getPanic "HsLocalBindsLR" -- --instance Binary (HsValBindsLR GhcSe GhcSe) where -- put_ bh b = case b of -- ValBinds a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XValBindsLR {} -> putPanic "HsValBindsLR" "ValBindsOut" -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ValBinds <$> get bh <*> get bh <*> get bh -- _ -> getPanic "HsValBindsLR" -- --instance Binary (PatSynBind GhcSe GhcSe) where -- put_ bh b = case b of -- PSB a b c d e -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e -- XPatSynBind a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> PSB <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -- 1 -> XPatSynBind <$> get bh -- _ -> getPanic "PatSynBind" -- --instance Binary (HsPatSynDir GhcSe) where -- put_ bh d = case d of -- Unidirectional -> putByte bh 0 -- ImplicitBidirectional -> putByte bh 1 -- ExplicitBidirectional a -> putByte bh 2 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure Unidirectional -- 1 -> pure ImplicitBidirectional -- 2 -> ExplicitBidirectional <$> get bh -- _ -> getPanic "HsPatSynDir" -- --instance Binary a => Binary (RecordPatSynField a) where -- put_ bh (RecordPatSynField a b) = put_ bh a >> put_ bh b -- get bh = RecordPatSynField <$> get bh <*> get bh -- --instance Binary (IPBind GhcSe) where -- put_ bh i = case i of -- IPBind a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XIPBind a -> putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> IPBind <$> get bh <*> get bh <*> get bh -- 1 -> XIPBind <$> get bh -- _ -> getPanic "IPBind" -- ---- * HsDecls -- --instance Binary (HsDecl GhcSe) where -- put_ bh d = case d of -- TyClD a b -> putByte bh 0 >> put_ bh a >> put_ bh b -- InstD a b -> putByte bh 1 >> put_ bh a >> put_ bh b -- DerivD a b -> putByte bh 2 >> put_ bh a >> put_ bh b -- ValD a b -> putByte bh 3 >> put_ bh a >> put_ bh b -- SigD a b -> putByte bh 4 >> put_ bh a >> put_ bh b -- DefD a b -> putByte bh 5 >> put_ bh a >> put_ bh b -- ForD a b -> putByte bh 6 >> put_ bh a >> put_ bh b -- WarningD a b -> putByte bh 7 >> put_ bh a >> put_ bh b -- RoleAnnotD a b -> putByte bh 8 >> put_ bh a >> put_ bh b -- RuleD a b -> putByte bh 9 >> put_ bh a >> put_ bh b -- AnnD a b -> putByte bh 10 >> put_ bh a >> put_ bh b -- SpliceD a b -> putByte bh 11 >> put_ bh a >> put_ bh b -- DocD a b -> putByte bh 12 >> put_ bh a >> put_ bh b -- XHsDecl a -> putByte bh 13 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> TyClD <$> get bh <*> get bh -- 1 -> InstD <$> get bh <*> get bh -- 2 -> DerivD <$> get bh <*> get bh -- 3 -> ValD <$> get bh <*> get bh -- 4 -> SigD <$> get bh <*> get bh -- 5 -> DefD <$> get bh <*> get bh -- 6 -> ForD <$> get bh <*> get bh -- 7 -> WarningD <$> get bh <*> get bh -- 8 -> RoleAnnotD <$> get bh <*> get bh -- 9 -> RuleD <$> get bh <*> get bh -- 10 -> AnnD <$> get bh <*> get bh -- 11 -> SpliceD <$> get bh <*> get bh -- 12 -> DocD <$> get bh <*> get bh -- 13 -> XHsDecl <$> get bh -- _ -> getPanic "HsDecl" -- --instance Binary (ForeignDecl GhcSe) where -- put_ bh d = case d of -- ForeignImport a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d -- ForeignExport a b c d -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d -- XForeignDecl a -> -- putByte bh 2 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ForeignImport <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> ForeignExport <$> get bh <*> get bh <*> get bh <*> get bh -- 2 -> XForeignDecl <$> get bh -- _ -> getPanic "ForeignDecl" -- --instance Binary (DefaultDecl GhcSe) where -- put_ bh d = case d of -- DefaultDecl a b -> putByte bh 0 >> put_ bh a >> put_ bh b -- XDefaultDecl a -> putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> DefaultDecl <$> get bh <*> get bh -- 1 -> XDefaultDecl <$> get bh -- _ -> getPanic "DefaultDecl" -- --instance Binary (TyClDecl GhcSe) where -- put_ bh d = case d of -- FamDecl a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- SynDecl a b c d e -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d >> put_ bh e -- DataDecl a b c d e -> -- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d >> put_ bh e -- ClassDecl a b c d e f g h i j k -> -- putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -- >> put_ bh d >> put_ bh e >> put_ bh f -- >> put_ bh g >> put_ bh h >> put_ bh i -- >> put_ bh j >> put_ bh k -- XTyClDecl a -> -- putByte bh 4 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> FamDecl <$> get bh <*> get bh -- 1 -> SynDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -- 2 -> DataDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -- 3 -> ClassDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh -- 4 -> XTyClDecl <$> get bh -- _ -> getPanic "TyClDecl" -- --instance Binary DocDecl where -- put_ bh d = case d of -- DocCommentNext a -> putByte bh 0 >> put_ bh a -- DocCommentPrev a -> putByte bh 1 >> put_ bh a -- DocCommentNamed a b -> putByte bh 2 >> put_ bh a >> put_ bh b -- DocGroup a b -> putByte bh 3 >> put_ bh a >> put_ bh b -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> DocCommentNext <$> get bh -- 1 -> DocCommentPrev <$> get bh -- 2 -> DocCommentNamed <$> get bh <*> get bh -- 3 -> DocGroup <$> get bh <*> get bh -- _ -> getPanic "DocDecl" -- --instance Binary (WarnDecls GhcSe) where -- put_ bh d = case d of -- Warnings a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XWarnDecls a -> putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> Warnings <$> get bh <*> get bh <*> get bh -- 1 -> XWarnDecls <$> get bh -- _ -> getPanic "WarnDecls" -- --instance Binary (WarnDecl GhcSe) where -- put_ bh d = case d of -- Warning a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XWarnDecl a -> putByte bh 1 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> Warning <$> get bh <*> get bh <*> get bh -- 1 -> XWarnDecl <$> get bh -- _ -> getPanic "WarnDecl" -- --instance Binary (RoleAnnotDecl GhcSe) where -- put_ bh d = case d of -- RoleAnnotDecl a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XRoleAnnotDecl a -> putByte bh 1 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> RoleAnnotDecl <$> get bh <*> get bh <*> get bh -- 1 -> XRoleAnnotDecl <$> get bh -- _ -> getPanic "RoleAnnotDecl" -- --instance Binary (RuleDecls GhcSe) where -- put_ bh d = case d of -- HsRules a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XRuleDecls a -> putByte bh 1 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsRules <$> get bh <*> get bh <*> get bh -- 1 -> XRuleDecls <$> get bh -- _ -> getPanic "RuleDecls" -- --instance Binary (RuleDecl GhcSe) where -- put_ bh decl = case decl of -- HsRule a b c d e f -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f -- XRuleDecl a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsRule <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh -- 1 -> XRuleDecl <$> get bh -- _ -> getPanic "RuleDecl" -- --instance Binary (AnnDecl GhcSe) where -- put_ bh decl = case decl of -- HsAnnotation a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- XAnnDecl a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsAnnotation <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> XAnnDecl <$> get bh -- _ -> getPanic "AnnDecl" -- --instance Binary (SpliceDecl GhcSe) where -- put_ bh d = case d of -- SpliceDecl a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XSpliceDecl a -> putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> SpliceDecl <$> get bh <*> get bh <*> get bh -- 1 -> XSpliceDecl <$> get bh -- _ -> getPanic "SpliceDecl" -- --instance Binary a => Binary (Tickish a) where -- put_ bh t = case t of -- ProfNote a b c -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- HpcTick a b -> -- putByte bh 1 >> put_ bh a >> put_ bh b -- Breakpoint a b -> -- putByte bh 2 >> put_ bh a >> put_ bh b -- SourceNote a b -> -- putByte bh 3 >> put_ bh a >> put_ bh b -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ProfNote <$> get bh <*> get bh <*> get bh -- 1 -> HpcTick <$> get bh <*> get bh -- 2 -> Breakpoint <$> get bh <*> get bh -- 3 -> SourceNote <$> get bh <*> get bh -- _ -> getPanic "Tickish" -- --instance Binary SpliceExplicitFlag where -- put_ bh f = putByte bh $ case f of -- ExplicitSplice -> 0 -- ImplicitSplice -> 1 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure ExplicitSplice -- 1 -> pure ImplicitSplice -- _ -> getPanic "SpliceExplicitFlag" -- --instance Binary SpliceDecoration where -- put_ bh d = putByte bh $ case d of -- HasParens -> 0 -- HasDollar -> 1 -- NoParens -> 2 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure HasParens -- 1 -> pure HasDollar -- 2 -> pure NoParens -- _ -> getPanic "SpliceDecoration" -- --instance Binary (HsSplice GhcSe) where -- put_ bh s = case s of -- HsTypedSplice a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- HsUntypedSplice a b c d -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- HsQuasiQuote a b c d e -> -- putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e -- XSplice a -> -- putByte bh 3 >> put_ bh a -- HsSpliced {} -> putPanic "HsSplice" "HsSpliced" -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsTypedSplice <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> HsUntypedSplice <$> get bh <*> get bh <*> get bh <*> get bh -- 2 -> HsQuasiQuote <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh -- 3 -> XSplice <$> get bh -- _ -> getPanic "HsSplice" -- --instance Binary (AnnProvenance SeName) where -- put_ bh p = case p of -- ValueAnnProvenance a -> putByte bh 0 >> put_ bh a -- TypeAnnProvenance a -> putByte bh 1 >> put_ bh a -- ModuleAnnProvenance -> putByte bh 2 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ValueAnnProvenance <$> get bh -- 1 -> TypeAnnProvenance <$> get bh -- 2 -> pure ModuleAnnProvenance -- _ -> getPanic "AnnProvenance" -- --instance Binary ForeignImport where -- put_ bh (CImport a b c d e) = -- put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e -- get bh = CImport <$> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh -- --instance Binary CImportSpec where -- put_ bh s = case s of -- CLabel a -> putByte bh 0 >> put_ bh a -- CFunction a -> putByte bh 1 >> put_ bh a -- CWrapper -> putByte bh 2 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> CLabel <$> get bh -- 1 -> CFunction <$> get bh -- 2 -> pure CWrapper -- _ -> getPanic "CImportSpec" -- --instance Binary ForeignExport where -- put_ bh (CExport a b) = put_ bh a >> put_ bh b -- get bh = CExport <$> get bh <*> get bh -- --instance Binary (RuleBndr GhcSe) where -- put_ bh b = case b of -- RuleBndr a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- RuleBndrSig a b c -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -- XRuleBndr a -> -- putByte bh 2 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> RuleBndr <$> get bh <*> get bh -- 1 -> RuleBndrSig <$> get bh <*> get bh <*> get bh -- 2 -> XRuleBndr <$> get bh -- _ -> getPanic "RuleBndr" -- --instance (Binary a, Binary b) => Binary (FamEqn GhcSe a b) where -- put_ bh e = case e of -- FamEqn a b c d e -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e -- XFamEqn a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> FamEqn <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh -- 1 -> XFamEqn <$> get bh -- _ -> getPanic "FamEqn" -- --instance Binary (HsDataDefn GhcSe) where -- put_ bh d = case d of -- HsDataDefn a b c d e f g -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f >> put_ bh g -- XHsDataDefn a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsDataDefn <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh <*> get bh -- 1 -> XHsDataDefn <$> get bh -- _ -> getPanic "HsDataDefn" -- --instance Binary NewOrData where -- put_ bh a = putByte bh (case a of -- NewType -> 0 -- DataType -> 1) -- get bh = getByte bh >>= \b -> case b of -- 0 -> pure NewType -- 1 -> pure DataType -- _ -> getPanic "NewOrData" -- --instance Binary (HsDerivingClause GhcSe) where -- put_ bh c = case c of -- HsDerivingClause a b c -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XHsDerivingClause a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsDerivingClause <$> get bh <*> get bh <*> get bh -- 1 -> XHsDerivingClause <$> get bh -- _ -> getPanic "HsDerivingClause" -- --instance Binary (ConDecl GhcSe) where -- put_ bh d = case d of -- ConDeclGADT a b c d e f g h -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h -- ConDeclH98 a b c d e f g -> -- putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f >> put_ bh g -- XConDecl a -> -- putByte bh 2 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ConDeclGADT <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh <*> get bh <*> get bh -- 1 -> ConDeclH98 <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh <*> get bh -- 2 -> XConDecl <$> get bh -- _ -> getPanic "ConDecl" -- -- --instance Binary (FamilyDecl GhcSe) where -- put_ bh d = case d of -- FamilyDecl a b c d e f g -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f >> put_ bh g -- XFamilyDecl a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> FamilyDecl <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh <*> get bh -- 1 -> XFamilyDecl <$> get bh -- _ -> getPanic "FamilyDecl" -- --instance Binary (InjectivityAnn GhcSe) where -- put_ bh a = case a of -- InjectivityAnn a b -> put_ bh a >> put_ bh b -- get bh = InjectivityAnn <$> get bh <*> get bh -- --instance Binary (FamilyInfo GhcSe) where -- put_ bh i = case i of -- DataFamily -> -- putByte bh 0 -- OpenTypeFamily -> -- putByte bh 1 -- ClosedTypeFamily a -> -- putByte bh 2 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure DataFamily -- 1 -> pure OpenTypeFamily -- 2 -> ClosedTypeFamily <$> get bh -- _ -> getPanic "FamilyInfo" -- --instance Binary (FamilyResultSig GhcSe) where -- put_ bh s = case s of -- NoSig a -> -- putByte bh 0 >> put_ bh a -- KindSig a b -> -- putByte bh 1 >> put_ bh a >> put_ bh b -- TyVarSig a b -> -- putByte bh 2 >> put_ bh a >> put_ bh b -- XFamilyResultSig a -> -- putByte bh 3 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> NoSig <$> get bh -- 1 -> KindSig <$> get bh <*> get bh -- 2 -> TyVarSig <$> get bh <*> get bh -- 3 -> XFamilyResultSig <$> get bh -- _ -> getPanic "FamilyResultSig" -- --instance Binary (InstDecl GhcSe) where -- put_ bh d = case d of -- ClsInstD a b -> -- putByte bh 0 >> put_ bh a >> put_ bh b -- DataFamInstD a b -> -- putByte bh 1 >> put_ bh a >> put_ bh b -- TyFamInstD a b -> -- putByte bh 2 >> put_ bh a >> put_ bh b -- XInstDecl a -> -- putByte bh 3 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ClsInstD <$> get bh <*> get bh -- 1 -> DataFamInstD <$> get bh <*> get bh -- 2 -> TyFamInstD <$> get bh <*> get bh -- 3 -> XInstDecl <$> get bh -- _ -> getPanic "InstDecl" -- --instance Binary (ClsInstDecl GhcSe) where -- put_ bh d = case d of -- ClsInstDecl a b c d e f g -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- >> put_ bh e >> put_ bh f >> put_ bh g -- XClsInstDecl a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ClsInstDecl <$> get bh <*> get bh <*> get bh <*> get bh -- <*> get bh <*> get bh <*> get bh -- 1 -> XClsInstDecl <$> get bh -- _ -> getPanic "ClsInstDecl" -- --instance Binary (DataFamInstDecl GhcSe) where -- put_ bh (DataFamInstDecl a) = put_ bh a -- get bh = DataFamInstDecl <$> get bh -- --instance Binary (TyFamInstDecl GhcSe) where -- put_ bh (TyFamInstDecl a) = put_ bh a -- get bh = TyFamInstDecl <$> get bh -- --instance Binary (DerivDecl GhcSe) where -- put_ bh d = case d of -- DerivDecl a b c d -> -- putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -- XDerivDecl a -> -- putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> DerivDecl <$> get bh <*> get bh <*> get bh <*> get bh -- 1 -> XDerivDecl <$> get bh -- _ -> getPanic "DerivDecl" -- --instance Binary (DerivStrategy GhcSe) where -- put_ bh s = case s of -- StockStrategy -> putByte bh 0 -- AnyclassStrategy -> putByte bh 1 -- NewtypeStrategy -> putByte bh 2 -- ViaStrategy a -> putByte bh 3 >> put_ bh a -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure StockStrategy -- 1 -> pure AnyclassStrategy -- 2 -> pure NewtypeStrategy -- 3 -> ViaStrategy <$> get bh -- _ -> getPanic "DerivStrategy" -- --instance Binary HsSrcBang where -- put_ bh (HsSrcBang a b c) = -- put_ bh a >> put_ bh b >> put_ bh c -- get bh = HsSrcBang <$> get bh <*> get bh <*> get bh -- --instance Binary RdrName where -- put_ bh n = case n of -- Unqual a -> putByte bh 0 >> put_ bh a -- Qual a b -> putByte bh 1 >> put_ bh a >> put_ bh b -- Orig a b -> putByte bh 2 >> put_ bh a >> put_ bh b -- Exact a -- | isExternalName a -> putByte bh 3 >> put_ bh a -- | otherwise -> putByte bh (if isSystemName a then 4 else 5) -- >> put_ bh (nameUnique a) >> put_ bh (nameOccName a) -- >> put_ bh (nameSrcSpan a) -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> Unqual <$> get bh -- 1 -> Qual <$> get bh <*> get bh -- 2 -> Orig <$> get bh <*> get bh -- 3 -> Exact <$> get bh -- 4 -> fmap Exact (mkSystemNameAt <$> get bh <*> get bh <*> get bh) -- 5 -> fmap Exact (mkInternalName <$> get bh <*> get bh <*> get bh) -- _ -> getPanic "RdrName" -- ---- * HsLit -- --instance Binary (HsLit GhcSe) where -- put_ bh lit -- = case lit of -- HsChar a b -> putByte bh 0 >> put_ bh a >> put_ bh b -- HsCharPrim a b -> putByte bh 1 >> put_ bh a >> put_ bh b -- HsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b -- HsStringPrim a b -> putByte bh 3 >> put_ bh a >> put_ bh b -- HsInt a b -> putByte bh 4 >> put_ bh a >> put_ bh b -- HsIntPrim a b -> putByte bh 5 >> put_ bh a >> put_ bh b -- HsWordPrim a b -> putByte bh 6 >> put_ bh a >> put_ bh b -- HsInt64Prim a b -> putByte bh 7 >> put_ bh a >> put_ bh b -- HsWord64Prim a b -> putByte bh 8 >> put_ bh a >> put_ bh b -- HsInteger a b c -> putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c -- HsRat a b c -> putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -- HsFloatPrim a b -> putByte bh 11 >> put_ bh a >> put_ bh b -- HsDoublePrim a b -> putByte bh 12 >> put_ bh a >> put_ bh b -- XLit a -> putByte bh 13 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsChar <$> get bh <*> get bh -- 1 -> HsCharPrim <$> get bh <*> get bh -- 2 -> HsString <$> get bh <*> get bh -- 3 -> HsStringPrim <$> get bh <*> get bh -- 4 -> HsInt <$> get bh <*> get bh -- 5 -> HsIntPrim <$> get bh <*> get bh -- 6 -> HsWordPrim <$> get bh <*> get bh -- 7 -> HsInt64Prim <$> get bh <*> get bh -- 8 -> HsWord64Prim <$> get bh <*> get bh -- 9 -> HsInteger <$> get bh <*> get bh <*> get bh -- 10 -> HsRat <$> get bh <*> get bh <*> get bh -- 11 -> HsFloatPrim <$> get bh <*> get bh -- 12 -> HsDoublePrim <$> get bh <*> get bh -- 13 -> XLit <$> get bh -- _ -> getPanic "HsLit" -- --instance Binary (HsOverLit GhcSe) where -- put_ bh lit = case lit of -- OverLit a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -- XOverLit a -> putByte bh 1 >> put_ bh a -- -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> OverLit <$> get bh <*> get bh <*> get bh -- 1 -> XOverLit <$> get bh -- _ -> getPanic "HsOverLit" -- --instance Binary Promoted where -- get bh = getByte bh >>= \tag -> case tag of -- 0 -> pure Promoted -- 1 -> pure NotPromoted -- _ -> getPanic "Promoted" -- -- put_ bh p = putByte bh $ case p of -- Promoted -> 0 -- NotPromoted -> 1 -- --instance Binary RealSrcLoc where -- put_ bh l = do -- put_ bh (srcLocFile l) -- put_ bh (srcLocLine l) -- put_ bh (srcLocCol l) -- -- get bh = mkRealSrcLoc <$> get bh <*> get bh <*> get bh -- --instance Binary RealSrcSpan where -- put_ bh s = put_ bh (realSrcSpanStart s) >> put_ bh (realSrcSpanEnd s) -- -- get bh = do -- loc1 <- get bh -- loc2 <- get bh -- return (mkRealSrcSpan loc1 loc2) -- --instance Binary OverLitVal where -- put_ bh v -- = case v of -- HsIntegral a -> putByte bh 0 >> put_ bh a -- HsFractional a -> putByte bh 1 >> put_ bh a -- HsIsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> HsIntegral <$> get bh -- 1 -> HsFractional <$> get bh -- 2 -> HsIsString <$> get bh <*> get bh -- _ -> getPanic "OverLitVal" +new file mode 100644 +index 0000000000..24abf8d69a +--- /dev/null ++++ b/compiler/hsSyn/HsExprBin_Instances.hs +@@ -0,0 +1,1665 @@ ++-- too noisy during development... ++{-# OPTIONS_GHC -fno-warn-orphans #-} ++{-# LANGUAGE GeneralizedNewtypeDeriving #-} ++{-# LANGUAGE StandaloneDeriving #-} ++{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} ++module HsExprBin_Instances where ++ ++import Control.Applicative ++import Control.Monad ++ ++import BasicTypes ++import Binary ++import CoreSyn ( Tickish(..) ) ++import GhcPrelude ++import HsBinds ++import HsDecls ++import HsExpr ++import HsExtension ++import HsLit ++import HsPat ++import HsTypes ++import Name ++import Outputable ++import RdrName ++import SeName ++import SrcLoc ++import TcEvidence (HsWrapper(WpHole)) ++ ++-- * Utilities ++ ++putPanic :: String -> String -> a ++putPanic tyName conName = ++ panic ("Binary " ++ tyName ++ ".put: " ++ conName ++ " not supported") ++ ++getPanic :: String -> a ++getPanic tyName = ++ panic ("Binary " ++ tyName ++ ".get: unknown (or unsupported) tag") ++ ++-- * Binary instances ++ ++instance Binary (HsExpr GhcSe) where ++ put_ bh e = case e of ++ HsVar a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ HsUnboundVar a b -> ++ putByte bh 1 >> put_ bh a >> put_ bh b ++ HsRecFld a b -> ++ putByte bh 2 >> put_ bh a >> put_ bh b ++ HsOverLabel a b c -> ++ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsIPVar a b -> ++ putByte bh 4 >> put_ bh a >> put_ bh b ++ HsOverLit a b -> ++ putByte bh 5 >> put_ bh a >> put_ bh b ++ HsLit a b -> ++ putByte bh 6 >> put_ bh a >> put_ bh b ++ HsLam a b -> ++ putByte bh 7 >> put_ bh a >> put_ bh b ++ HsLamCase a b -> ++ putByte bh 8 >> put_ bh a >> put_ bh b ++ HsApp a b c -> ++ putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsAppType a b -> ++ putByte bh 10 >> put_ bh a >> put_ bh b ++ OpApp a b c d -> ++ putByte bh 11 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d ++ NegApp a b c -> ++ putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsPar a b -> ++ putByte bh 13 >> put_ bh a >> put_ bh b ++ SectionL a b c -> ++ putByte bh 14 >> put_ bh a >> put_ bh b >> put_ bh c ++ SectionR a b c -> ++ putByte bh 15 >> put_ bh a >> put_ bh b >> put_ bh c ++ ExplicitTuple a b c -> ++ putByte bh 16 >> put_ bh a >> put_ bh b >> put_ bh c ++ ExplicitSum a b c d -> ++ putByte bh 17 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d ++ HsCase a b c -> ++ putByte bh 18 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsIf a b c d e -> ++ putByte bh 19 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d >> put_ bh e ++ HsMultiIf a b -> ++ putByte bh 20 >> put_ bh a >> put_ bh b ++ HsLet a b c -> ++ putByte bh 21 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsDo a b c -> ++ putByte bh 22 >> put_ bh a >> put_ bh b >> put_ bh c ++ ExplicitList a b c -> ++ putByte bh 23 >> put_ bh a >> put_ bh b >> put_ bh c ++ RecordCon a b c -> ++ putByte bh 24 >> put_ bh a >> put_ bh b >> put_ bh c ++ RecordUpd a b c -> ++ putByte bh 25 >> put_ bh a >> put_ bh b >> put_ bh c ++ ExprWithTySig a b -> ++ putByte bh 26 >> put_ bh a >> put_ bh b ++ ArithSeq a b c -> ++ putByte bh 27 >> put_ bh a >> put_ bh b >> put_ bh c ++ EWildPat a -> ++ putByte bh 28 >> put_ bh a ++ EAsPat a b c -> ++ putByte bh 29 >> put_ bh a >> put_ bh b >> put_ bh c ++ EViewPat a b c -> ++ putByte bh 30 >> put_ bh a >> put_ bh b >> put_ bh c ++ ELazyPat a b -> ++ putByte bh 31 >> put_ bh a >> put_ bh b ++ HsStatic a b -> ++ putByte bh 32 >> put_ bh a >> put_ bh b ++ HsProc a b c -> ++ putByte bh 33 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsBinTick a b c d -> ++ putByte bh 34 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d ++ HsTickPragma a b c d e -> ++ putByte bh 35 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d >> put_ bh e ++ HsSpliceE a b -> ++ putByte bh 36 >> put_ bh a >> put_ bh b ++ HsSCC a b c d -> ++ putByte bh 37 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d ++ HsCoreAnn a b c d -> ++ putByte bh 38 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d ++ HsBracket a b -> ++ putByte bh 39 >> put_ bh a >> put_ bh b ++ XExpr a -> ++ putByte bh 40 >> put_ bh a ++ HsConLikeOut {} -> putPanic "HsExpr" "HsConLikeOut" ++ HsRnBracketOut {} -> putPanic "HsExpr" "HsRnBracketOut" ++ HsTcBracketOut {} -> putPanic "HsExpr" "HsTcBracketOut" ++ HsArrApp {} -> putPanic "HsExpr" "HsArrApp" ++ HsArrForm {} -> putPanic "HsExpr" "HsArrForm" ++ HsTick {} -> putPanic "HsExpr" "HsTick" ++ HsWrap {} -> putPanic "HsExpr" "HsWrap" ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsVar <$> get bh <*> get bh ++ 1 -> HsUnboundVar <$> get bh <*> get bh ++ 2 -> HsRecFld <$> get bh <*> get bh ++ 3 -> HsOverLabel <$> get bh <*> get bh <*> get bh ++ 4 -> HsIPVar <$> get bh <*> get bh ++ 5 -> HsOverLit <$> get bh <*> get bh ++ 6 -> HsLit <$> get bh <*> get bh ++ 7 -> HsLam <$> get bh <*> get bh ++ 8 -> HsLamCase <$> get bh <*> get bh ++ 9 -> HsApp <$> get bh <*> get bh <*> get bh ++ 10 -> HsAppType <$> get bh <*> get bh ++ 11 -> OpApp <$> get bh <*> get bh <*> get bh <*> get bh ++ 12 -> NegApp <$> get bh <*> get bh <*> get bh ++ 13 -> HsPar <$> get bh <*> get bh ++ 14 -> SectionL <$> get bh <*> get bh <*> get bh ++ 15 -> SectionR <$> get bh <*> get bh <*> get bh ++ 16 -> ExplicitTuple <$> get bh <*> get bh <*> get bh ++ 17 -> ExplicitSum <$> get bh <*> get bh <*> get bh <*> get bh ++ 18 -> HsCase <$> get bh <*> get bh <*> get bh ++ 19 -> HsIf <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh ++ 20 -> HsMultiIf <$> get bh <*> get bh ++ 21 -> HsLet <$> get bh <*> get bh <*> get bh ++ 22 -> HsDo <$> get bh <*> get bh <*> get bh ++ 23 -> ExplicitList <$> get bh <*> get bh <*> get bh ++ 24 -> RecordCon <$> get bh <*> get bh <*> get bh ++ 25 -> RecordUpd <$> get bh <*> get bh <*> get bh ++ 26 -> ExprWithTySig <$> get bh <*> get bh ++ 27 -> ArithSeq <$> get bh <*> get bh <*> get bh ++ 28 -> EWildPat <$> get bh ++ 29 -> EAsPat <$> get bh <*> get bh <*> get bh ++ 30 -> EViewPat <$> get bh <*> get bh <*> get bh ++ 31 -> ELazyPat <$> get bh <*> get bh ++ 32 -> HsStatic <$> get bh <*> get bh ++ 33 -> HsProc <$> get bh <*> get bh <*> get bh ++ 34 -> HsBinTick <$> get bh <*> get bh <*> get bh <*> get bh ++ 35 -> HsTickPragma <$> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh ++ 36 -> HsSpliceE <$> get bh <*> get bh ++ 37 -> HsSCC <$> get bh <*> get bh <*> get bh <*> get bh ++ 38 -> HsCoreAnn <$> get bh <*> get bh <*> get bh <*> get bh ++ 39 -> HsBracket <$> get bh <*> get bh ++ 40 -> XExpr <$> get bh ++ _ -> getPanic "HsExpr" ++ ++instance Binary (HsBracket GhcSe) where ++ put_ bh b = case b of ++ ExpBr a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ PatBr a b -> ++ putByte bh 1 >> put_ bh a >> put_ bh b ++ DecBrL a b -> ++ putByte bh 2 >> put_ bh a >> put_ bh b ++ DecBrG a b -> ++ putByte bh 3 >> put_ bh a >> put_ bh b ++ TypBr a b -> ++ putByte bh 4 >> put_ bh a >> put_ bh b ++ VarBr a b c -> ++ putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c ++ TExpBr a b -> ++ putByte bh 6 >> put_ bh a >> put_ bh b ++ XBracket a -> ++ putByte bh 7 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ExpBr <$> get bh <*> get bh ++ 1 -> PatBr <$> get bh <*> get bh ++ 2 -> DecBrL <$> get bh <*> get bh ++ 3 -> DecBrG <$> get bh <*> get bh ++ 4 -> TypBr <$> get bh <*> get bh ++ 5 -> VarBr <$> get bh <*> get bh <*> get bh ++ 6 -> TExpBr <$> get bh <*> get bh ++ 7 -> XBracket <$> get bh ++ _ -> getPanic "HsBracket" ++ ++instance Binary SeName where ++ put_ bh (SeName n) = put_ bh n ++ get bh = mkSeName <$> get bh ++ ++instance Binary UnboundVar where ++ put_ bh v = case v of ++ OutOfScope a b -> putByte bh 0 >> put_ bh a >> put_ bh b ++ TrueExprHole a -> putByte bh 1 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> OutOfScope <$> get bh <*> get bh ++ 1 -> TrueExprHole <$> get bh ++ _ -> getPanic "UnboundVar" ++ ++instance Binary a => Binary (StmtLR GhcSe GhcSe a) where ++ put_ bh s = case s of ++ LastStmt a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ BindStmt a b c d e -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e ++ ApplicativeStmt a b c -> ++ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c ++ BodyStmt a b c d -> ++ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ LetStmt a b -> ++ putByte bh 4 >> put_ bh a >> put_ bh b ++ ParStmt a b c d -> ++ putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ RecStmt a b c d e f g -> ++ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f >> put_ bh g ++ TransStmt a b c d e f g h i -> ++ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h ++ >> put_ bh i ++ XStmtLR a -> ++ putByte bh 8 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> LastStmt <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> BindStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh ++ 2 -> ApplicativeStmt <$> get bh <*> get bh <*> get bh ++ 3 -> BodyStmt <$> get bh <*> get bh <*> get bh <*> get bh ++ 4 -> LetStmt <$> get bh <*> get bh ++ 5 -> ParStmt <$> get bh <*> get bh <*> get bh <*> get bh ++ 6 -> RecStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh ++ 7 -> TransStmt <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh ++ 8 -> XStmtLR <$> get bh ++ _ -> getPanic "StmtLR" ++ ++instance Binary (HsGroup GhcSe) where ++ put_ bh x = case x of ++ HsGroup a b c d e f g h i j k l -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h ++ >> put_ bh i >> put_ bh j >> put_ bh k >> put_ bh l ++ XHsGroup a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsGroup <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> XHsGroup <$> get bh ++ _ -> getPanic "HsGroup" ++ ++instance Binary (TyClGroup GhcSe) where ++ put_ bh g = case g of ++ TyClGroup a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ XTyClGroup a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> TyClGroup <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> XTyClGroup <$> get bh ++ _ -> getPanic "TyClGroup" ++ ++instance Binary (HsCmdTop GhcSe) where ++ put_ bh c = case c of ++ HsCmdTop a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ XCmdTop a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsCmdTop <$> get bh <*> get bh ++ 1 -> XCmdTop <$> get bh ++ _ -> getPanic "HsCmdTop" ++ ++instance Binary (HsCmd GhcSe) where ++ put_ bh c = case c of ++ HsCmdArrApp a b c d e -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d >> put_ bh e ++ HsCmdArrForm a b c d e -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d >> put_ bh e ++ HsCmdApp a b c -> ++ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsCmdLam a b -> ++ putByte bh 3 >> put_ bh a >> put_ bh b ++ HsCmdPar a b -> ++ putByte bh 4 >> put_ bh a >> put_ bh b ++ HsCmdCase a b c -> ++ putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsCmdIf a b c d e -> ++ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d >> put_ bh e ++ HsCmdLet a b c -> ++ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsCmdDo a b -> ++ putByte bh 8 >> put_ bh a >> put_ bh b ++ XCmd a -> ++ putByte bh 9 >> put_ bh a ++ HsCmdWrap {} -> ++ putPanic "HsCmdWrap" "HsCmd" ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsCmdArrApp <$> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh ++ 1 -> HsCmdArrForm <$> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh ++ 2 -> HsCmdApp <$> get bh <*> get bh <*> get bh ++ 3 -> HsCmdLam <$> get bh <*> get bh ++ 4 -> HsCmdPar <$> get bh <*> get bh ++ 5 -> HsCmdCase <$> get bh <*> get bh <*> get bh ++ 6 -> HsCmdIf <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh ++ 7 -> HsCmdLet <$> get bh <*> get bh <*> get bh ++ 8 -> HsCmdDo <$> get bh <*> get bh ++ 9 -> XCmd <$> get bh ++ _ -> getPanic "HsCmd" ++ ++instance Binary HsArrAppType where ++ put_ bh t = putByte bh $ case t of ++ HsHigherOrderApp -> 0 ++ HsFirstOrderApp -> 1 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure HsHigherOrderApp ++ 1 -> pure HsFirstOrderApp ++ _ -> getPanic "HsArrAppType" ++ ++instance Binary TransForm where ++ put_ bh f = putByte bh $ case f of ++ ThenForm -> 0 ++ GroupForm -> 1 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure ThenForm ++ 1 -> pure GroupForm ++ _ -> getPanic "TransForm" ++ ++instance Binary (ApplicativeArg GhcSe) where ++ put_ bh a = case a of ++ ApplicativeArgOne a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ ApplicativeArgMany a b c d -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ XApplicativeArg a -> ++ putByte bh 2 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ApplicativeArgOne <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> ApplicativeArgMany <$> get bh <*> get bh <*> get bh <*> get bh ++ 2 -> XApplicativeArg <$> get bh ++ _ -> getPanic "ApplicativeArg" ++ ++instance Binary (ParStmtBlock GhcSe GhcSe) where ++ put_ bh b = case b of ++ ParStmtBlock a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ XParStmtBlock a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ParStmtBlock <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> XParStmtBlock <$> get bh ++ _ -> getPanic "ParStmtBlock" ++ ++instance Binary (SyntaxExpr GhcSe) where ++ put_ bh (SyntaxExpr a [] WpHole) = put_ bh a ++ put_ _ _ = panic "Binary SyntaxExpr.put: wrappers should be empty" ++ get bh = SyntaxExpr <$> get bh <*> pure [] <*> pure WpHole ++ ++instance Binary a => Binary (GRHSs GhcSe a) where ++ put_ bh g = case g of ++ GRHSs a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XGRHSs a -> putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> GRHSs <$> get bh <*> get bh <*> get bh ++ 1 -> XGRHSs <$> get bh ++ _ -> getPanic "GRHSs" ++ ++instance Binary a => Binary (GRHS GhcSe a) where ++ put_ bh g = case g of ++ GRHS a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XGRHS a -> putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> GRHS <$> get bh <*> get bh <*> get bh ++ 1 -> XGRHS <$> get bh ++ _ -> getPanic "GRHS" ++ ++instance Binary a => Binary (MatchGroup GhcSe a) where ++ put_ bh g = case g of ++ MG a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XMatchGroup a -> putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> MG <$> get bh <*> get bh <*> get bh ++ 1 -> XMatchGroup <$> get bh ++ _ -> getPanic "MatchGroup" ++ ++instance Binary a => Binary (Match GhcSe a) where ++ put_ bh m = case m of ++ Match a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ XMatch a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> Match <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> XMatch <$> get bh ++ _ -> getPanic "Match" ++ ++instance Binary (HsMatchContext SeName) where ++ put_ bh c = case c of ++ FunRhs a b c -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ LambdaExpr -> ++ putByte bh 1 ++ CaseAlt -> ++ putByte bh 2 ++ IfAlt -> ++ putByte bh 3 ++ ProcExpr -> ++ putByte bh 4 ++ PatBindRhs -> ++ putByte bh 5 ++ RecUpd -> ++ putByte bh 6 ++ StmtCtxt a -> ++ putByte bh 7 >> put_ bh a ++ ThPatSplice -> ++ putByte bh 8 ++ ThPatQuote -> ++ putByte bh 9 ++ PatSyn -> ++ putByte bh 10 ++ PatBindGuards -> ++ putByte bh 11 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> FunRhs <$> get bh <*> get bh <*> get bh ++ 1 -> pure LambdaExpr ++ 2 -> pure CaseAlt ++ 3 -> pure IfAlt ++ 4 -> pure ProcExpr ++ 5 -> pure PatBindRhs ++ 6 -> pure RecUpd ++ 7 -> StmtCtxt <$> get bh ++ 8 -> pure ThPatSplice ++ 9 -> pure ThPatQuote ++ 10 -> pure PatSyn ++ 11 -> pure PatBindGuards ++ _ -> getPanic "HsMatchContext" ++ ++instance Binary (HsStmtContext SeName) where ++ put_ bh c = case c of ++ ListComp -> putByte bh 0 ++ MonadComp -> putByte bh 1 ++ DoExpr -> putByte bh 3 ++ MDoExpr -> putByte bh 4 ++ ArrowExpr -> putByte bh 5 ++ GhciStmtCtxt -> putByte bh 6 ++ PatGuard a -> putByte bh 7 >> put_ bh a ++ ParStmtCtxt a -> putByte bh 8 >> put_ bh a ++ TransStmtCtxt a -> putByte bh 9 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure ListComp ++ 1 -> pure MonadComp ++ 3 -> pure DoExpr ++ 4 -> pure MDoExpr ++ 5 -> pure ArrowExpr ++ 6 -> pure GhciStmtCtxt ++ 7 -> PatGuard <$> get bh ++ 8 -> ParStmtCtxt <$> get bh ++ 9 -> TransStmtCtxt <$> get bh ++ _ -> getPanic "HsStmtContext" ++ ++instance Binary (ArithSeqInfo GhcSe) where ++ put_ bh i = case i of ++ From a -> ++ putByte bh 0 >> put_ bh a ++ FromThen a b -> ++ putByte bh 1 >> put_ bh a >> put_ bh b ++ FromTo a b -> ++ putByte bh 2 >> put_ bh a >> put_ bh b ++ FromThenTo a b c -> ++ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> From <$> get bh ++ 1 -> FromThen <$> get bh <*> get bh ++ 2 -> FromTo <$> get bh <*> get bh ++ 3 -> FromThenTo <$> get bh <*> get bh <*> get bh ++ _ -> getPanic "ArithSeqInfo" ++ ++instance Binary (HsTupArg GhcSe) where ++ put_ bh a = case a of ++ Present a b -> putByte bh 0 >> put_ bh a >> put_ bh b ++ Missing a -> putByte bh 1 >> put_ bh a ++ XTupArg a -> putByte bh 2 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> Present <$> get bh <*> get bh ++ 1 -> Missing <$> get bh ++ 2 -> XTupArg <$> get bh ++ _ -> getPanic "HsTupArg" ++ ++instance Binary (Pat GhcSe) where ++ put_ bh p = case p of ++ WildPat a -> ++ putByte bh 0 >> put_ bh a ++ VarPat a b -> ++ putByte bh 1 >> put_ bh a >> put_ bh b ++ LazyPat a b -> ++ putByte bh 2 >> put_ bh a >> put_ bh b ++ AsPat a b c -> ++ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c ++ ParPat a b -> ++ putByte bh 4 >> put_ bh a >> put_ bh b ++ BangPat a b -> ++ putByte bh 5 >> put_ bh a >> put_ bh b ++ ListPat a b -> ++ putByte bh 6 >> put_ bh a >> put_ bh b ++ TuplePat a b c -> ++ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c ++ SumPat a b c d -> ++ putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ ConPatIn a b -> ++ putByte bh 9 >> put_ bh a >> put_ bh b ++ ViewPat a b c -> ++ putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c ++ LitPat a b -> ++ putByte bh 11 >> put_ bh a >> put_ bh b ++ NPat a b c d -> ++ putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ NPlusKPat a b c d e f -> ++ putByte bh 13 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f ++ SigPat a b -> ++ putByte bh 14 >> put_ bh a >> put_ bh b ++ SplicePat a b -> ++ putByte bh 15 >> put_ bh a >> put_ bh b ++ XPat a -> ++ putByte bh 16 >> put_ bh a ++ ConPatOut {} -> putPanic "Pat" "ConPatOut" ++ CoPat {} -> putPanic "Pat" "CoPat" ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> WildPat <$> get bh ++ 1 -> VarPat <$> get bh <*> get bh ++ 2 -> LazyPat <$> get bh <*> get bh ++ 3 -> AsPat <$> get bh <*> get bh <*> get bh ++ 4 -> ParPat <$> get bh <*> get bh ++ 5 -> BangPat <$> get bh <*> get bh ++ 6 -> ListPat <$> get bh <*> get bh ++ 7 -> TuplePat <$> get bh <*> get bh <*> get bh ++ 8 -> SumPat <$> get bh <*> get bh <*> get bh <*> get bh ++ 9 -> ConPatIn <$> get bh <*> get bh ++ 10 -> ViewPat <$> get bh <*> get bh <*> get bh ++ 11 -> LitPat <$> get bh <*> get bh ++ 12 -> NPat <$> get bh <*> get bh <*> get bh <*> get bh ++ 13 -> NPlusKPat <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh ++ 14 -> SigPat <$> get bh <*> get bh ++ 15 -> SplicePat <$> get bh <*> get bh ++ 16 -> XPat <$> get bh ++ _ -> getPanic "HsPat" ++ ++instance Binary NoExt where ++ put_ _ NoExt = return () ++ get _ = pure NoExt ++ ++instance (Binary (FieldOcc a), Binary b) => Binary (HsRecFields a b) where ++ put_ bh (HsRecFields a b) = put_ bh a >> put_ bh b ++ get bh = HsRecFields <$> get bh <*> get bh ++ ++instance (Binary id, Binary arg) => Binary (HsRecField' id arg) where ++ put_ bh (HsRecField a b c) = put_ bh a >> put_ bh b >> put_ bh c ++ get bh = HsRecField <$> get bh <*> get bh <*> get bh ++ ++instance Binary (HsType GhcSe) where ++ put_ bh t = case t of ++ HsForAllTy a b c -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsQualTy a b c -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsTyVar a b c -> ++ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsAppTy a b c -> ++ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsFunTy a b c -> ++ putByte bh 4 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsListTy a b -> ++ putByte bh 5 >> put_ bh a >> put_ bh b ++ HsTupleTy a b c -> ++ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsSumTy a b -> ++ putByte bh 7 >> put_ bh a >> put_ bh b ++ HsOpTy a b c d -> ++ putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ HsParTy a b -> ++ putByte bh 9 >> put_ bh a >> put_ bh b ++ HsIParamTy a b c -> ++ putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsKindSig a b c -> ++ putByte bh 11 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsBangTy a b c -> ++ putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsRecTy a b -> ++ putByte bh 13 >> put_ bh a >> put_ bh b ++ HsExplicitListTy a b c -> ++ putByte bh 14 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsExplicitTupleTy a b -> ++ putByte bh 15 >> put_ bh a >> put_ bh b ++ HsTyLit a b -> ++ putByte bh 16 >> put_ bh a >> put_ bh b ++ HsWildCardTy a -> ++ putByte bh 17 >> put_ bh a ++ HsDocTy a b c -> ++ putByte bh 18 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsSpliceTy a b -> ++ putByte bh 19 >> put_ bh a >> put_ bh b ++ HsStarTy a b -> ++ putByte bh 20 >> put_ bh a >> put_ bh b ++ XHsType _ -> ++ putPanic "XHsType" "HsType" ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsForAllTy <$> get bh <*> get bh <*> get bh ++ 1 -> HsQualTy <$> get bh <*> get bh <*> get bh ++ 2 -> HsTyVar <$> get bh <*> get bh <*> get bh ++ 3 -> HsAppTy <$> get bh <*> get bh <*> get bh ++ 4 -> HsFunTy <$> get bh <*> get bh <*> get bh ++ 5 -> HsListTy <$> get bh <*> get bh ++ 6 -> HsTupleTy <$> get bh <*> get bh <*> get bh ++ 7 -> HsSumTy <$> get bh <*> get bh ++ 8 -> HsOpTy <$> get bh <*> get bh <*> get bh <*> get bh ++ 9 -> HsParTy <$> get bh <*> get bh ++ 10 -> HsIParamTy <$> get bh <*> get bh <*> get bh ++ 11 -> HsKindSig <$> get bh <*> get bh <*> get bh ++ 12 -> HsBangTy <$> get bh <*> get bh <*> get bh ++ 13 -> HsRecTy <$> get bh <*> get bh ++ 14 -> HsExplicitListTy <$> get bh <*> get bh <*> get bh ++ 15 -> HsExplicitTupleTy <$> get bh <*> get bh ++ 16 -> HsTyLit <$> get bh <*> get bh ++ 17 -> HsWildCardTy <$> get bh ++ 18 -> HsDocTy <$> get bh <*> get bh <*> get bh ++ 19 -> HsSpliceTy <$> get bh <*> get bh ++ 20 -> HsStarTy <$> get bh <*> get bh ++ _ -> getPanic "HsType" ++ ++instance Binary HsTyLit where ++ put_ bh l = case l of ++ HsNumTy a b -> putByte bh 0 >> put_ bh a >> put_ bh b ++ HsStrTy a b -> putByte bh 1 >> put_ bh a >> put_ bh b ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsNumTy <$> get bh <*> get bh ++ 1 -> HsStrTy <$> get bh <*> get bh ++ _ -> getPanic "HsTyLit" ++ ++instance Binary a => Binary (HsWildCardBndrs GhcSe a) where ++ put_ bh w = case w of ++ HsWC a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ XHsWildCardBndrs a -> ++ putByte bh 1 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsWC <$> get bh <*> get bh ++ 1 -> XHsWildCardBndrs <$> get bh ++ _ -> getPanic "HsWildCardBndrs" ++ ++instance Binary a => Binary (HsImplicitBndrs GhcSe a) where ++ put_ bh b = case b of ++ HsIB a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ XHsImplicitBndrs a -> ++ putByte bh 1 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsIB <$> get bh <*> get bh ++ 1 -> XHsImplicitBndrs <$> get bh ++ _ -> getPanic "HsImplicitBndrs" ++ ++instance Binary HsTupleSort where ++ put_ bh s = putByte bh (case s of ++ HsUnboxedTuple -> 0 ++ HsBoxedTuple -> 1 ++ HsConstraintTuple -> 2 ++ HsBoxedOrConstraintTuple -> 3) ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure HsUnboxedTuple ++ 1 -> pure HsBoxedTuple ++ 2 -> pure HsConstraintTuple ++ 3 -> pure HsBoxedOrConstraintTuple ++ _ -> getPanic "HsTupleSort" ++ ++instance Binary (ConDeclField GhcSe) where ++ put_ bh f = case f of ++ ConDeclField a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ XConDeclField a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ConDeclField <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> XConDeclField <$> get bh ++ _ -> getPanic "ConDeclField" ++ ++instance Binary (FieldOcc GhcSe) where ++ put_ bh o = case o of ++ FieldOcc a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ XFieldOcc a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> FieldOcc <$> get bh <*> get bh ++ 1 -> XFieldOcc <$> get bh ++ _ -> getPanic "FieldOcc" ++ ++instance Binary (HsTyVarBndr GhcSe) where ++ put_ bh v = case v of ++ UserTyVar a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ KindedTyVar a b c -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c ++ XTyVarBndr a -> ++ putByte bh 2 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> UserTyVar <$> get bh <*> get bh ++ 1 -> KindedTyVar <$> get bh <*> get bh <*> get bh ++ 2 -> XTyVarBndr <$> get bh ++ _ -> getPanic "HsTyVarBndr" ++ ++instance (Binary a, Binary b) => Binary (HsConDetails a b) where ++ put_ bh c = case c of ++ PrefixCon a -> putByte bh 0 >> put_ bh a ++ RecCon a -> putByte bh 1 >> put_ bh a ++ InfixCon a b -> putByte bh 2 >> put_ bh a >> put_ bh b ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> PrefixCon <$> get bh ++ 1 -> RecCon <$> get bh ++ 2 -> InfixCon <$> get bh <*> get bh ++ _ -> getPanic "HsConDetails" ++ ++instance Binary (AmbiguousFieldOcc GhcSe) where ++ put_ bh o = case o of ++ Unambiguous a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ Ambiguous a b -> ++ putByte bh 1 >> put_ bh a >> put_ bh b ++ XAmbiguousFieldOcc a -> ++ putByte bh 2 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> Unambiguous <$> get bh <*> get bh ++ 1 -> Ambiguous <$> get bh <*> get bh ++ 2 -> XAmbiguousFieldOcc <$> get bh ++ _ -> getPanic "AmbiguousOccField" ++ ++instance Binary (LHsQTyVars GhcSe) where ++ put_ bh v = case v of ++ HsQTvs a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ XLHsQTyVars a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsQTvs <$> get bh <*> get bh ++ 1 -> XLHsQTyVars <$> get bh ++ _ -> getPanic "LHsQTyVars" ++ ++instance Binary (Sig GhcSe) where ++ put_ bh s = case s of ++ TypeSig a b c -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ PatSynSig a b c -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c ++ ClassOpSig a b c d -> ++ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ IdSig a b -> ++ putByte bh 3 >> put_ bh a >> put_ bh b ++ FixSig a b -> ++ putByte bh 4 >> put_ bh a >> put_ bh b ++ InlineSig a b c -> ++ putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c ++ SpecSig a b c d -> ++ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ SpecInstSig a b c -> ++ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c ++ SCCFunSig a b c d -> ++ putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ CompleteMatchSig a b c d -> ++ putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ MinimalSig a b c -> ++ putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c ++ XSig a -> ++ putByte bh 11 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> TypeSig <$> get bh <*> get bh <*> get bh ++ 1 -> PatSynSig <$> get bh <*> get bh <*> get bh ++ 2 -> ClassOpSig <$> get bh <*> get bh <*> get bh <*> get bh ++ 3 -> IdSig <$> get bh <*> get bh ++ 4 -> FixSig <$> get bh <*> get bh ++ 5 -> InlineSig <$> get bh <*> get bh <*> get bh ++ 6 -> SpecSig <$> get bh <*> get bh <*> get bh <*> get bh ++ 7 -> SpecInstSig <$> get bh <*> get bh <*> get bh ++ 8 -> SCCFunSig <$> get bh <*> get bh <*> get bh <*> get bh ++ 9 -> CompleteMatchSig <$> get bh <*> get bh <*> get bh <*> get bh ++ 10 -> MinimalSig <$> get bh <*> get bh <*> get bh ++ 11 -> XSig <$> get bh ++ _ -> getPanic "Sig" ++ ++instance Binary (FixitySig GhcSe) where ++ put_ bh s = case s of ++ FixitySig a b c -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XFixitySig a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> FixitySig <$> get bh <*> get bh <*> get bh ++ 1 -> XFixitySig <$> get bh ++ _ -> getPanic "FixitySig" ++ ++instance Binary (HsBindLR GhcSe GhcSe) where ++ put_ bh b = case b of ++ -- TODO: we drop the "fun_co_fn" field, as it seems ++ -- to always be WpHole in the places where the binary ++ -- serialisation instances will be used. ++ -- TODO: we drop the "fun_tick" field, as it is unlikely ++ -- to be used in our immediate use cases. Let's ++ -- return to parametrising away the 'Id' in that ++ -- field's type. ++ FunBind a b c d _ -> case d of ++ WpHole -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ _ -> ++ panic "Binary HsBindLR: FunBind with non-WpHole value in fun_co_fn" ++ -- TODO: same as for FunBind, we drop pat_ticks ++ PatBind a b c _ -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c ++ VarBind a b c d -> ++ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ PatSynBind a b -> ++ putByte bh 3 >> put_ bh a >> put_ bh b ++ XHsBindsLR a -> ++ putByte bh 4 >> put_ bh a ++ AbsBinds {} -> putPanic "HsBindsLR" "AbsBinds" ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> FunBind <$> get bh <*> get bh <*> get bh <*> pure WpHole <*> pure [] ++ 1 -> PatBind <$> get bh <*> get bh <*> get bh <*> pure ([], []) ++ 2 -> VarBind <$> get bh <*> get bh <*> get bh <*> get bh ++ 3 -> PatSynBind <$> get bh <*> get bh ++ 4 -> XHsBindsLR <$> get bh ++ _ -> getPanic "HsBindsLR" ++ ++instance Binary (HsLocalBindsLR GhcSe GhcSe) where ++ put_ bh b = case b of ++ HsValBinds a b -> putByte bh 0 >> put_ bh a >> put_ bh b ++ EmptyLocalBinds a -> putByte bh 1 >> put_ bh a ++ XHsLocalBindsLR a -> putByte bh 2 >> put_ bh a ++ HsIPBinds {} -> putPanic "HsLocalBindsLR" "HsIPBinds" ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsValBinds <$> get bh <*> get bh ++ 1 -> EmptyLocalBinds <$> get bh ++ 2 -> XHsLocalBindsLR <$> get bh ++ _ -> getPanic "HsLocalBindsLR" ++ ++instance Binary (HsValBindsLR GhcSe GhcSe) where ++ put_ bh b = case b of ++ ValBinds a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XValBindsLR {} -> putPanic "HsValBindsLR" "ValBindsOut" ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ValBinds <$> get bh <*> get bh <*> get bh ++ _ -> getPanic "HsValBindsLR" ++ ++instance Binary (PatSynBind GhcSe GhcSe) where ++ put_ bh b = case b of ++ PSB a b c d e -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e ++ XPatSynBind a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> PSB <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> XPatSynBind <$> get bh ++ _ -> getPanic "PatSynBind" ++ ++instance Binary (HsPatSynDir GhcSe) where ++ put_ bh d = case d of ++ Unidirectional -> putByte bh 0 ++ ImplicitBidirectional -> putByte bh 1 ++ ExplicitBidirectional a -> putByte bh 2 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure Unidirectional ++ 1 -> pure ImplicitBidirectional ++ 2 -> ExplicitBidirectional <$> get bh ++ _ -> getPanic "HsPatSynDir" ++ ++instance Binary a => Binary (RecordPatSynField a) where ++ put_ bh (RecordPatSynField a b) = put_ bh a >> put_ bh b ++ get bh = RecordPatSynField <$> get bh <*> get bh ++ ++instance Binary (IPBind GhcSe) where ++ put_ bh i = case i of ++ IPBind a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XIPBind a -> putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> IPBind <$> get bh <*> get bh <*> get bh ++ 1 -> XIPBind <$> get bh ++ _ -> getPanic "IPBind" ++ ++-- * HsDecls ++ ++instance Binary (HsDecl GhcSe) where ++ put_ bh d = case d of ++ TyClD a b -> putByte bh 0 >> put_ bh a >> put_ bh b ++ InstD a b -> putByte bh 1 >> put_ bh a >> put_ bh b ++ DerivD a b -> putByte bh 2 >> put_ bh a >> put_ bh b ++ ValD a b -> putByte bh 3 >> put_ bh a >> put_ bh b ++ SigD a b -> putByte bh 4 >> put_ bh a >> put_ bh b ++ DefD a b -> putByte bh 5 >> put_ bh a >> put_ bh b ++ ForD a b -> putByte bh 6 >> put_ bh a >> put_ bh b ++ WarningD a b -> putByte bh 7 >> put_ bh a >> put_ bh b ++ RoleAnnotD a b -> putByte bh 8 >> put_ bh a >> put_ bh b ++ RuleD a b -> putByte bh 9 >> put_ bh a >> put_ bh b ++ AnnD a b -> putByte bh 10 >> put_ bh a >> put_ bh b ++ SpliceD a b -> putByte bh 11 >> put_ bh a >> put_ bh b ++ DocD a b -> putByte bh 12 >> put_ bh a >> put_ bh b ++ XHsDecl a -> putByte bh 13 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> TyClD <$> get bh <*> get bh ++ 1 -> InstD <$> get bh <*> get bh ++ 2 -> DerivD <$> get bh <*> get bh ++ 3 -> ValD <$> get bh <*> get bh ++ 4 -> SigD <$> get bh <*> get bh ++ 5 -> DefD <$> get bh <*> get bh ++ 6 -> ForD <$> get bh <*> get bh ++ 7 -> WarningD <$> get bh <*> get bh ++ 8 -> RoleAnnotD <$> get bh <*> get bh ++ 9 -> RuleD <$> get bh <*> get bh ++ 10 -> AnnD <$> get bh <*> get bh ++ 11 -> SpliceD <$> get bh <*> get bh ++ 12 -> DocD <$> get bh <*> get bh ++ 13 -> XHsDecl <$> get bh ++ _ -> getPanic "HsDecl" ++ ++instance Binary (ForeignDecl GhcSe) where ++ put_ bh d = case d of ++ ForeignImport a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d ++ ForeignExport a b c d -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d ++ XForeignDecl a -> ++ putByte bh 2 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ForeignImport <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> ForeignExport <$> get bh <*> get bh <*> get bh <*> get bh ++ 2 -> XForeignDecl <$> get bh ++ _ -> getPanic "ForeignDecl" ++ ++instance Binary (DefaultDecl GhcSe) where ++ put_ bh d = case d of ++ DefaultDecl a b -> putByte bh 0 >> put_ bh a >> put_ bh b ++ XDefaultDecl a -> putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> DefaultDecl <$> get bh <*> get bh ++ 1 -> XDefaultDecl <$> get bh ++ _ -> getPanic "DefaultDecl" ++ ++instance Binary (TyClDecl GhcSe) where ++ put_ bh d = case d of ++ FamDecl a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ SynDecl a b c d e -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d >> put_ bh e ++ DataDecl a b c d e -> ++ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d >> put_ bh e ++ ClassDecl a b c d e f g h i j k -> ++ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c ++ >> put_ bh d >> put_ bh e >> put_ bh f ++ >> put_ bh g >> put_ bh h >> put_ bh i ++ >> put_ bh j >> put_ bh k ++ XTyClDecl a -> ++ putByte bh 4 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> FamDecl <$> get bh <*> get bh ++ 1 -> SynDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh ++ 2 -> DataDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh ++ 3 -> ClassDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh ++ 4 -> XTyClDecl <$> get bh ++ _ -> getPanic "TyClDecl" ++ ++instance Binary DocDecl where ++ put_ bh d = case d of ++ DocCommentNext a -> putByte bh 0 >> put_ bh a ++ DocCommentPrev a -> putByte bh 1 >> put_ bh a ++ DocCommentNamed a b -> putByte bh 2 >> put_ bh a >> put_ bh b ++ DocGroup a b -> putByte bh 3 >> put_ bh a >> put_ bh b ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> DocCommentNext <$> get bh ++ 1 -> DocCommentPrev <$> get bh ++ 2 -> DocCommentNamed <$> get bh <*> get bh ++ 3 -> DocGroup <$> get bh <*> get bh ++ _ -> getPanic "DocDecl" ++ ++instance Binary (WarnDecls GhcSe) where ++ put_ bh d = case d of ++ Warnings a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XWarnDecls a -> putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> Warnings <$> get bh <*> get bh <*> get bh ++ 1 -> XWarnDecls <$> get bh ++ _ -> getPanic "WarnDecls" ++ ++instance Binary (WarnDecl GhcSe) where ++ put_ bh d = case d of ++ Warning a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XWarnDecl a -> putByte bh 1 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> Warning <$> get bh <*> get bh <*> get bh ++ 1 -> XWarnDecl <$> get bh ++ _ -> getPanic "WarnDecl" ++ ++instance Binary (RoleAnnotDecl GhcSe) where ++ put_ bh d = case d of ++ RoleAnnotDecl a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XRoleAnnotDecl a -> putByte bh 1 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> RoleAnnotDecl <$> get bh <*> get bh <*> get bh ++ 1 -> XRoleAnnotDecl <$> get bh ++ _ -> getPanic "RoleAnnotDecl" ++ ++instance Binary (RuleDecls GhcSe) where ++ put_ bh d = case d of ++ HsRules a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XRuleDecls a -> putByte bh 1 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsRules <$> get bh <*> get bh <*> get bh ++ 1 -> XRuleDecls <$> get bh ++ _ -> getPanic "RuleDecls" ++ ++instance Binary (RuleDecl GhcSe) where ++ put_ bh decl = case decl of ++ HsRule a b c d e f -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f ++ XRuleDecl a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsRule <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh ++ 1 -> XRuleDecl <$> get bh ++ _ -> getPanic "RuleDecl" ++ ++instance Binary (AnnDecl GhcSe) where ++ put_ bh decl = case decl of ++ HsAnnotation a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ XAnnDecl a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsAnnotation <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> XAnnDecl <$> get bh ++ _ -> getPanic "AnnDecl" ++ ++instance Binary (SpliceDecl GhcSe) where ++ put_ bh d = case d of ++ SpliceDecl a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XSpliceDecl a -> putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> SpliceDecl <$> get bh <*> get bh <*> get bh ++ 1 -> XSpliceDecl <$> get bh ++ _ -> getPanic "SpliceDecl" ++ ++instance Binary a => Binary (Tickish a) where ++ put_ bh t = case t of ++ ProfNote a b c -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ HpcTick a b -> ++ putByte bh 1 >> put_ bh a >> put_ bh b ++ Breakpoint a b -> ++ putByte bh 2 >> put_ bh a >> put_ bh b ++ SourceNote a b -> ++ putByte bh 3 >> put_ bh a >> put_ bh b ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ProfNote <$> get bh <*> get bh <*> get bh ++ 1 -> HpcTick <$> get bh <*> get bh ++ 2 -> Breakpoint <$> get bh <*> get bh ++ 3 -> SourceNote <$> get bh <*> get bh ++ _ -> getPanic "Tickish" ++ ++instance Binary SpliceExplicitFlag where ++ put_ bh f = putByte bh $ case f of ++ ExplicitSplice -> 0 ++ ImplicitSplice -> 1 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure ExplicitSplice ++ 1 -> pure ImplicitSplice ++ _ -> getPanic "SpliceExplicitFlag" ++ ++instance Binary SpliceDecoration where ++ put_ bh d = putByte bh $ case d of ++ HasParens -> 0 ++ HasDollar -> 1 ++ NoParens -> 2 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure HasParens ++ 1 -> pure HasDollar ++ 2 -> pure NoParens ++ _ -> getPanic "SpliceDecoration" ++ ++instance Binary (HsSplice GhcSe) where ++ put_ bh s = case s of ++ HsTypedSplice a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ HsUntypedSplice a b c d -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ HsQuasiQuote a b c d e -> ++ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e ++ XSplice a -> ++ putByte bh 3 >> put_ bh a ++ HsSpliced {} -> putPanic "HsSplice" "HsSpliced" ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsTypedSplice <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> HsUntypedSplice <$> get bh <*> get bh <*> get bh <*> get bh ++ 2 -> HsQuasiQuote <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh ++ 3 -> XSplice <$> get bh ++ _ -> getPanic "HsSplice" ++ ++instance Binary (AnnProvenance SeName) where ++ put_ bh p = case p of ++ ValueAnnProvenance a -> putByte bh 0 >> put_ bh a ++ TypeAnnProvenance a -> putByte bh 1 >> put_ bh a ++ ModuleAnnProvenance -> putByte bh 2 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ValueAnnProvenance <$> get bh ++ 1 -> TypeAnnProvenance <$> get bh ++ 2 -> pure ModuleAnnProvenance ++ _ -> getPanic "AnnProvenance" ++ ++instance Binary ForeignImport where ++ put_ bh (CImport a b c d e) = ++ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e ++ get bh = CImport <$> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh ++ ++instance Binary CImportSpec where ++ put_ bh s = case s of ++ CLabel a -> putByte bh 0 >> put_ bh a ++ CFunction a -> putByte bh 1 >> put_ bh a ++ CWrapper -> putByte bh 2 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> CLabel <$> get bh ++ 1 -> CFunction <$> get bh ++ 2 -> pure CWrapper ++ _ -> getPanic "CImportSpec" ++ ++instance Binary ForeignExport where ++ put_ bh (CExport a b) = put_ bh a >> put_ bh b ++ get bh = CExport <$> get bh <*> get bh ++ ++instance Binary (RuleBndr GhcSe) where ++ put_ bh b = case b of ++ RuleBndr a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ RuleBndrSig a b c -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c ++ XRuleBndr a -> ++ putByte bh 2 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> RuleBndr <$> get bh <*> get bh ++ 1 -> RuleBndrSig <$> get bh <*> get bh <*> get bh ++ 2 -> XRuleBndr <$> get bh ++ _ -> getPanic "RuleBndr" ++ ++instance (Binary a, Binary b) => Binary (FamEqn GhcSe a b) where ++ put_ bh e = case e of ++ FamEqn a b c d e -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e ++ XFamEqn a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> FamEqn <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh ++ 1 -> XFamEqn <$> get bh ++ _ -> getPanic "FamEqn" ++ ++instance Binary (HsDataDefn GhcSe) where ++ put_ bh d = case d of ++ HsDataDefn a b c d e f g -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f >> put_ bh g ++ XHsDataDefn a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsDataDefn <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh <*> get bh ++ 1 -> XHsDataDefn <$> get bh ++ _ -> getPanic "HsDataDefn" ++ ++instance Binary NewOrData where ++ put_ bh a = putByte bh (case a of ++ NewType -> 0 ++ DataType -> 1) ++ get bh = getByte bh >>= \b -> case b of ++ 0 -> pure NewType ++ 1 -> pure DataType ++ _ -> getPanic "NewOrData" ++ ++instance Binary (HsDerivingClause GhcSe) where ++ put_ bh c = case c of ++ HsDerivingClause a b c -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XHsDerivingClause a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsDerivingClause <$> get bh <*> get bh <*> get bh ++ 1 -> XHsDerivingClause <$> get bh ++ _ -> getPanic "HsDerivingClause" ++ ++instance Binary (ConDecl GhcSe) where ++ put_ bh d = case d of ++ ConDeclGADT a b c d e f g h -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h ++ ConDeclH98 a b c d e f g -> ++ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f >> put_ bh g ++ XConDecl a -> ++ putByte bh 2 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ConDeclGADT <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> ConDeclH98 <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh <*> get bh ++ 2 -> XConDecl <$> get bh ++ _ -> getPanic "ConDecl" ++ ++ ++instance Binary (FamilyDecl GhcSe) where ++ put_ bh d = case d of ++ FamilyDecl a b c d e f g -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f >> put_ bh g ++ XFamilyDecl a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> FamilyDecl <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh <*> get bh ++ 1 -> XFamilyDecl <$> get bh ++ _ -> getPanic "FamilyDecl" ++ ++instance Binary (InjectivityAnn GhcSe) where ++ put_ bh a = case a of ++ InjectivityAnn a b -> put_ bh a >> put_ bh b ++ get bh = InjectivityAnn <$> get bh <*> get bh ++ ++instance Binary (FamilyInfo GhcSe) where ++ put_ bh i = case i of ++ DataFamily -> ++ putByte bh 0 ++ OpenTypeFamily -> ++ putByte bh 1 ++ ClosedTypeFamily a -> ++ putByte bh 2 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure DataFamily ++ 1 -> pure OpenTypeFamily ++ 2 -> ClosedTypeFamily <$> get bh ++ _ -> getPanic "FamilyInfo" ++ ++instance Binary (FamilyResultSig GhcSe) where ++ put_ bh s = case s of ++ NoSig a -> ++ putByte bh 0 >> put_ bh a ++ KindSig a b -> ++ putByte bh 1 >> put_ bh a >> put_ bh b ++ TyVarSig a b -> ++ putByte bh 2 >> put_ bh a >> put_ bh b ++ XFamilyResultSig a -> ++ putByte bh 3 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> NoSig <$> get bh ++ 1 -> KindSig <$> get bh <*> get bh ++ 2 -> TyVarSig <$> get bh <*> get bh ++ 3 -> XFamilyResultSig <$> get bh ++ _ -> getPanic "FamilyResultSig" ++ ++instance Binary (InstDecl GhcSe) where ++ put_ bh d = case d of ++ ClsInstD a b -> ++ putByte bh 0 >> put_ bh a >> put_ bh b ++ DataFamInstD a b -> ++ putByte bh 1 >> put_ bh a >> put_ bh b ++ TyFamInstD a b -> ++ putByte bh 2 >> put_ bh a >> put_ bh b ++ XInstDecl a -> ++ putByte bh 3 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ClsInstD <$> get bh <*> get bh ++ 1 -> DataFamInstD <$> get bh <*> get bh ++ 2 -> TyFamInstD <$> get bh <*> get bh ++ 3 -> XInstDecl <$> get bh ++ _ -> getPanic "InstDecl" ++ ++instance Binary (ClsInstDecl GhcSe) where ++ put_ bh d = case d of ++ ClsInstDecl a b c d e f g -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ >> put_ bh e >> put_ bh f >> put_ bh g ++ XClsInstDecl a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ClsInstDecl <$> get bh <*> get bh <*> get bh <*> get bh ++ <*> get bh <*> get bh <*> get bh ++ 1 -> XClsInstDecl <$> get bh ++ _ -> getPanic "ClsInstDecl" ++ ++instance Binary (DataFamInstDecl GhcSe) where ++ put_ bh (DataFamInstDecl a) = put_ bh a ++ get bh = DataFamInstDecl <$> get bh ++ ++instance Binary (TyFamInstDecl GhcSe) where ++ put_ bh (TyFamInstDecl a) = put_ bh a ++ get bh = TyFamInstDecl <$> get bh ++ ++instance Binary (DerivDecl GhcSe) where ++ put_ bh d = case d of ++ DerivDecl a b c d -> ++ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d ++ XDerivDecl a -> ++ putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> DerivDecl <$> get bh <*> get bh <*> get bh <*> get bh ++ 1 -> XDerivDecl <$> get bh ++ _ -> getPanic "DerivDecl" ++ ++instance Binary (DerivStrategy GhcSe) where ++ put_ bh s = case s of ++ StockStrategy -> putByte bh 0 ++ AnyclassStrategy -> putByte bh 1 ++ NewtypeStrategy -> putByte bh 2 ++ ViaStrategy a -> putByte bh 3 >> put_ bh a ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure StockStrategy ++ 1 -> pure AnyclassStrategy ++ 2 -> pure NewtypeStrategy ++ 3 -> ViaStrategy <$> get bh ++ _ -> getPanic "DerivStrategy" ++ ++instance Binary HsSrcBang where ++ put_ bh (HsSrcBang a b c) = ++ put_ bh a >> put_ bh b >> put_ bh c ++ get bh = HsSrcBang <$> get bh <*> get bh <*> get bh ++ ++instance Binary RdrName where ++ put_ bh n = case n of ++ Unqual a -> putByte bh 0 >> put_ bh a ++ Qual a b -> putByte bh 1 >> put_ bh a >> put_ bh b ++ Orig a b -> putByte bh 2 >> put_ bh a >> put_ bh b ++ Exact a ++ | isExternalName a -> putByte bh 3 >> put_ bh a ++ | otherwise -> putByte bh (if isSystemName a then 4 else 5) ++ >> put_ bh (nameUnique a) >> put_ bh (nameOccName a) ++ >> put_ bh (nameSrcSpan a) ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> Unqual <$> get bh ++ 1 -> Qual <$> get bh <*> get bh ++ 2 -> Orig <$> get bh <*> get bh ++ 3 -> Exact <$> get bh ++ 4 -> fmap Exact (mkSystemNameAt <$> get bh <*> get bh <*> get bh) ++ 5 -> fmap Exact (mkInternalName <$> get bh <*> get bh <*> get bh) ++ _ -> getPanic "RdrName" ++ ++-- * HsLit ++ ++instance Binary (HsLit GhcSe) where ++ put_ bh lit ++ = case lit of ++ HsChar a b -> putByte bh 0 >> put_ bh a >> put_ bh b ++ HsCharPrim a b -> putByte bh 1 >> put_ bh a >> put_ bh b ++ HsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b ++ HsStringPrim a b -> putByte bh 3 >> put_ bh a >> put_ bh b ++ HsInt a b -> putByte bh 4 >> put_ bh a >> put_ bh b ++ HsIntPrim a b -> putByte bh 5 >> put_ bh a >> put_ bh b ++ HsWordPrim a b -> putByte bh 6 >> put_ bh a >> put_ bh b ++ HsInt64Prim a b -> putByte bh 7 >> put_ bh a >> put_ bh b ++ HsWord64Prim a b -> putByte bh 8 >> put_ bh a >> put_ bh b ++ HsInteger a b c -> putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsRat a b c -> putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c ++ HsFloatPrim a b -> putByte bh 11 >> put_ bh a >> put_ bh b ++ HsDoublePrim a b -> putByte bh 12 >> put_ bh a >> put_ bh b ++ XLit a -> putByte bh 13 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsChar <$> get bh <*> get bh ++ 1 -> HsCharPrim <$> get bh <*> get bh ++ 2 -> HsString <$> get bh <*> get bh ++ 3 -> HsStringPrim <$> get bh <*> get bh ++ 4 -> HsInt <$> get bh <*> get bh ++ 5 -> HsIntPrim <$> get bh <*> get bh ++ 6 -> HsWordPrim <$> get bh <*> get bh ++ 7 -> HsInt64Prim <$> get bh <*> get bh ++ 8 -> HsWord64Prim <$> get bh <*> get bh ++ 9 -> HsInteger <$> get bh <*> get bh <*> get bh ++ 10 -> HsRat <$> get bh <*> get bh <*> get bh ++ 11 -> HsFloatPrim <$> get bh <*> get bh ++ 12 -> HsDoublePrim <$> get bh <*> get bh ++ 13 -> XLit <$> get bh ++ _ -> getPanic "HsLit" ++ ++instance Binary (HsOverLit GhcSe) where ++ put_ bh lit = case lit of ++ OverLit a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c ++ XOverLit a -> putByte bh 1 >> put_ bh a ++ ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> OverLit <$> get bh <*> get bh <*> get bh ++ 1 -> XOverLit <$> get bh ++ _ -> getPanic "HsOverLit" ++ ++instance Binary Promoted where ++ get bh = getByte bh >>= \tag -> case tag of ++ 0 -> pure Promoted ++ 1 -> pure NotPromoted ++ _ -> getPanic "Promoted" ++ ++ put_ bh p = putByte bh $ case p of ++ Promoted -> 0 ++ NotPromoted -> 1 ++ ++instance Binary RealSrcLoc where ++ put_ bh l = do ++ put_ bh (srcLocFile l) ++ put_ bh (srcLocLine l) ++ put_ bh (srcLocCol l) ++ ++ get bh = mkRealSrcLoc <$> get bh <*> get bh <*> get bh ++ ++instance Binary RealSrcSpan where ++ put_ bh s = put_ bh (realSrcSpanStart s) >> put_ bh (realSrcSpanEnd s) ++ ++ get bh = do ++ loc1 <- get bh ++ loc2 <- get bh ++ return (mkRealSrcSpan loc1 loc2) ++ ++instance Binary OverLitVal where ++ put_ bh v ++ = case v of ++ HsIntegral a -> putByte bh 0 >> put_ bh a ++ HsFractional a -> putByte bh 1 >> put_ bh a ++ HsIsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> HsIntegral <$> get bh ++ 1 -> HsFractional <$> get bh ++ 2 -> HsIsString <$> get bh <*> get bh ++ _ -> getPanic "OverLitVal" diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs -index a488da00a7..a7c467dce4 100644 +index a7c467dce4..a488da00a7 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs -@@ -23,15 +23,10 @@ import Data.Data hiding ( Fixity ) +@@ -23,10 +23,15 @@ import Data.Data hiding ( Fixity ) import PlaceHolder import Name import RdrName --import SeName ++import SeName import Var --import IfaceType ( IfaceType ) ++import IfaceType ( IfaceType ) import Outputable import SrcLoc (Located) --import Data.Kind --import qualified Type -- ++import Data.Kind ++import qualified Type ++ {- Note [Trees that grow] ~~~~~~~~~~~~~~~~~~~~~~ -@@ -73,22 +68,20 @@ data GhcPass (c :: Pass) +@@ -68,20 +73,22 @@ data GhcPass (c :: Pass) deriving instance Eq (GhcPass c) deriving instance Typeable c => Data (GhcPass c) --data Pass = Parsed | Renamed | Typechecked | Serialisable -+data Pass = Parsed | Renamed | Typechecked +-data Pass = Parsed | Renamed | Typechecked ++data Pass = Parsed | Renamed | Typechecked | Serialisable deriving (Data) -- Type synonyms as a shorthand for tagging --type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param --type GhcRn = GhcPass 'Renamed -- Old 'Name' type param --type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, --type GhcSe = GhcPass 'Serialisable -- New pass, with serialisable AST representations --type GhcTcId = GhcTc -- Old 'TcId' type param -+type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param -+type GhcRn = GhcPass 'Renamed -- Old 'Name' type param -+type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, -+type GhcTcId = GhcTc -- Old 'TcId' type param +-type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param +-type GhcRn = GhcPass 'Renamed -- Old 'Name' type param +-type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, +-type GhcTcId = GhcTc -- Old 'TcId' type param ++type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param ++type GhcRn = GhcPass 'Renamed -- Old 'Name' type param ++type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, ++type GhcSe = GhcPass 'Serialisable -- New pass, with serialisable AST representations ++type GhcTcId = GhcTc -- Old 'TcId' type param -- | Maps the "normal" id type for a given pass type family IdP p type instance IdP GhcPs = RdrName type instance IdP GhcRn = Name type instance IdP GhcTc = Id --type instance IdP GhcSe = SeName ++type instance IdP GhcSe = SeName type LIdP p = Located (IdP p) -@@ -1112,34 +1105,4 @@ type OutputableBndrId id = +@@ -1105,4 +1112,34 @@ type OutputableBndrId id = ( OutputableBndr (NameOrRdrName (IdP id)) , OutputableBndr (IdP id) , OutputableX id -- , OutputableBndr (RdrOrSeName id) -- , OutputableBndr (IdSigId id) -- , VarType (IdSigId id) ++ , OutputableBndr (RdrOrSeName id) ++ , OutputableBndr (IdSigId id) ++ , VarType (IdSigId id) ) -- --class VarType a where -- getVarType :: a -> Maybe Type.Type -- --instance VarType Var where -- getVarType = Just . varType -- --instance VarType SeName where -- getVarType _ = Nothing -- --type family IdSigId pass where -- IdSigId GhcSe = SeName -- IdSigId (GhcPass _) = Id -- --type family LitType x where -- LitType (GhcPass 'Serialisable) = IfaceType -- LitType a = Type.Type -- --type family DoName pass where -- DoName GhcSe = SeName -- DoName (GhcPass _) = Name -- --type family RdrOrSeName pass --type instance RdrOrSeName GhcSe = SeName --type instance RdrOrSeName GhcRn = RdrName --type instance RdrOrSeName GhcTc = RdrName --type instance RdrOrSeName GhcPs = RdrName ++ ++class VarType a where ++ getVarType :: a -> Maybe Type.Type ++ ++instance VarType Var where ++ getVarType = Just . varType ++ ++instance VarType SeName where ++ getVarType _ = Nothing ++ ++type family IdSigId pass where ++ IdSigId GhcSe = SeName ++ IdSigId (GhcPass _) = Id ++ ++type family LitType x where ++ LitType (GhcPass 'Serialisable) = IfaceType ++ LitType a = Type.Type ++ ++type family DoName pass where ++ DoName GhcSe = SeName ++ DoName (GhcPass _) = Name ++ ++type family RdrOrSeName pass ++type instance RdrOrSeName GhcSe = SeName ++type instance RdrOrSeName GhcRn = RdrName ++type instance RdrOrSeName GhcTc = RdrName ++type instance RdrOrSeName GhcPs = RdrName diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs -index 9da47f62f1..39bd9b7e18 100644 +index 39bd9b7e18..9da47f62f1 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs -@@ -12,7 +12,6 @@ HsImpExp: Abstract syntax: imports, exports, interfaces +@@ -12,6 +12,7 @@ HsImpExp: Abstract syntax: imports, exports, interfaces {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder --{-# LANGUAGE TypeFamilies #-} ++{-# LANGUAGE TypeFamilies #-} module HsImpExp where diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs -index 9546b0de30..d1411bd750 100644 +index d1411bd750..9546b0de30 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -13,7 +13,7 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} --{-# LANGUAGE DataKinds #-} -+ +- ++{-# LANGUAGE DataKinds #-} module HsLit where #include "HsVersions.h" @@ -4341,409 +4341,409 @@ index 9546b0de30..d1411bd750 100644 -- ^ literal @Int64#@ | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer -- ^ literal @Word64#@ -- | HsInteger (XHsInteger x) {- SourceText -} Integer (LitType x) -+ | HsInteger (XHsInteger x) {- SourceText -} Integer Type +- | HsInteger (XHsInteger x) {- SourceText -} Integer Type ++ | HsInteger (XHsInteger x) {- SourceText -} Integer (LitType x) -- ^ Genuinely an integer; arises only -- from TRANSLATION (overloaded -- literals are done with HsOverLit) -- | HsRat (XHsRat x) FractionalLit (LitType x) -+ | HsRat (XHsRat x) FractionalLit Type +- | HsRat (XHsRat x) FractionalLit Type ++ | HsRat (XHsRat x) FractionalLit (LitType x) -- ^ Genuinely a rational; arises only from -- TRANSLATION (overloaded literals are -- done with HsOverLit) -@@ -128,7 +128,6 @@ data OverLitTc +@@ -128,6 +128,7 @@ data OverLitTc type instance XOverLit GhcPs = NoExt type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] type instance XOverLit GhcTc = OverLitTc --type instance XOverLit GhcSe = NoExt ++type instance XOverLit GhcSe = NoExt type instance XXOverLit (GhcPass _) = NoExt -@@ -152,7 +151,7 @@ overLitType XOverLit{} = panic "overLitType" +@@ -151,7 +152,7 @@ overLitType XOverLit{} = panic "overLitType" -- | Convert a literal from one index type to another, updating the annotations -- according to the relevant 'Convertable' instance --convertLit :: (ConvertIdX a b, LitType a ~ LitType b) => HsLit a -> HsLit b -+convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b +-convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b ++convertLit :: (ConvertIdX a b, LitType a ~ LitType b) => HsLit a -> HsLit b convertLit (HsChar a x) = (HsChar (convert a) x) convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x) convertLit (HsString a x) = (HsString (convert a) x) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs -index aa7e9989a2..6f65487411 100644 +index 6f65487411..aa7e9989a2 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs -@@ -282,7 +282,6 @@ data ListPatTc +@@ -282,6 +282,7 @@ data ListPatTc type instance XWildPat GhcPs = NoExt type instance XWildPat GhcRn = NoExt type instance XWildPat GhcTc = Type --type instance XWildPat GhcSe = NoExt ++type instance XWildPat GhcSe = NoExt type instance XVarPat (GhcPass _) = NoExt type instance XLazyPat (GhcPass _) = NoExt -@@ -296,22 +295,18 @@ type instance XBangPat (GhcPass _) = NoExt +@@ -295,18 +296,22 @@ type instance XBangPat (GhcPass _) = NoExt type instance XListPat GhcPs = NoExt type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) type instance XListPat GhcTc = ListPatTc --type instance XListPat GhcSe = NoExt ++type instance XListPat GhcSe = NoExt type instance XTuplePat GhcPs = NoExt type instance XTuplePat GhcRn = NoExt type instance XTuplePat GhcTc = [Type] --type instance XTuplePat GhcSe = NoExt ++type instance XTuplePat GhcSe = NoExt type instance XSumPat GhcPs = NoExt type instance XSumPat GhcRn = NoExt type instance XSumPat GhcTc = [Type] --type instance XSumPat GhcSe = NoExt ++type instance XSumPat GhcSe = NoExt type instance XViewPat GhcPs = NoExt type instance XViewPat GhcRn = NoExt type instance XViewPat GhcTc = Type --type instance XViewPat GhcSe = NoExt ++type instance XViewPat GhcSe = NoExt type instance XSplicePat (GhcPass _) = NoExt type instance XLitPat (GhcPass _) = NoExt -@@ -319,17 +314,14 @@ type instance XLitPat (GhcPass _) = NoExt +@@ -314,14 +319,17 @@ type instance XLitPat (GhcPass _) = NoExt type instance XNPat GhcPs = NoExt type instance XNPat GhcRn = NoExt type instance XNPat GhcTc = Type --type instance XNPat GhcSe = NoExt ++type instance XNPat GhcSe = NoExt type instance XNPlusKPat GhcPs = NoExt type instance XNPlusKPat GhcRn = NoExt type instance XNPlusKPat GhcTc = Type --type instance XNPlusKPat GhcSe = NoExt ++type instance XNPlusKPat GhcSe = NoExt type instance XSigPat GhcPs = (LHsSigWcType GhcPs) type instance XSigPat GhcRn = (LHsSigWcType GhcRn) type instance XSigPat GhcTc = Type --type instance XSigPat GhcSe = (LHsSigWcType GhcSe) ++type instance XSigPat GhcSe = (LHsSigWcType GhcSe) type instance XCoPat (GhcPass _) = NoExt type instance XXPat (GhcPass _) = NoExt -@@ -465,9 +457,7 @@ hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl +@@ -457,7 +465,9 @@ hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl hsRecFieldId :: HsRecField GhcTc arg -> Located Id hsRecFieldId = hsRecFieldSel --hsRecUpdFieldRdr -- :: RdrOrSeName (GhcPass p) ~ RdrName -- => HsRecUpdField (GhcPass p) -> Located RdrName -+hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName +-hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName ++hsRecUpdFieldRdr ++ :: RdrOrSeName (GhcPass p) ~ RdrName ++ => HsRecUpdField (GhcPass p) -> Located RdrName hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id -@@ -567,7 +557,7 @@ pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 +@@ -557,7 +567,7 @@ pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats) = ppr rpats --instance (Outputable arg, Outputable (RdrOrSeName p)) -+instance (Outputable arg) +-instance (Outputable arg) ++instance (Outputable arg, Outputable (RdrOrSeName p)) => Outputable (HsRecFields p arg) where ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) = braces (fsep (punctuate comma (map ppr flds))) diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot -index d56a992207..b7efb1c28c 100644 +index b7efb1c28c..d56a992207 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -4,7 +4,7 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} --{-# LANGUAGE TypeFamilies #-} -- needed to use OutputableBndrId -+{-# LANGUAGE TypeFamilies #-} +-{-# LANGUAGE TypeFamilies #-} ++{-# LANGUAGE TypeFamilies #-} -- needed to use OutputableBndrId module HsPat where import SrcLoc( Located ) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs -index 2366df1d28..3512bf7a7c 100644 +index 3512bf7a7c..2366df1d28 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs -@@ -9,7 +9,6 @@ HsTypes: Abstract syntax: user-defined types +@@ -9,6 +9,7 @@ HsTypes: Abstract syntax: user-defined types {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} --{-# LANGUAGE TypeFamilies #-} ++{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder -@@ -39,7 +38,7 @@ module HsTypes ( +@@ -38,7 +39,7 @@ module HsTypes ( HsConDetails(..), -- FieldOcc(..), LFieldOcc, mkFieldOcc, fieldOccRdrName, -+ FieldOcc(..), LFieldOcc, mkFieldOcc, +- FieldOcc(..), LFieldOcc, mkFieldOcc, ++ FieldOcc(..), LFieldOcc, mkFieldOcc, fieldOccRdrName, AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, -@@ -86,7 +85,6 @@ import TysPrim( funTyConName ) +@@ -85,6 +86,7 @@ import TysPrim( funTyConName ) import Type import HsDoc import BasicTypes --import Binary ++import Binary import SrcLoc import Outputable import FastString -@@ -279,7 +277,6 @@ data HsQTvsRn +@@ -277,6 +279,7 @@ data HsQTvsRn type instance XHsQTvs GhcPs = NoExt type instance XHsQTvs GhcRn = HsQTvsRn type instance XHsQTvs GhcTc = HsQTvsRn --type instance XHsQTvs GhcSe = NoExt ++type instance XHsQTvs GhcSe = NoExt type instance XXLHsQTyVars (GhcPass _) = NoExt -@@ -319,7 +316,6 @@ data HsIBRn +@@ -316,6 +319,7 @@ data HsIBRn type instance XHsIB GhcPs _ = NoExt type instance XHsIB GhcRn _ = HsIBRn type instance XHsIB GhcTc _ = HsIBRn --type instance XHsIB GhcSe _ = NoExt ++type instance XHsIB GhcSe _ = NoExt type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt -@@ -341,7 +337,6 @@ data HsWildCardBndrs pass thing +@@ -337,6 +341,7 @@ data HsWildCardBndrs pass thing type instance XHsWC GhcPs b = NoExt type instance XHsWC GhcRn b = [Name] type instance XHsWC GhcTc b = [Name] --type instance XHsWC GhcSe b = NoExt ++type instance XHsWC GhcSe b = NoExt type instance XXHsWildCardBndrs (GhcPass _) b = NoExt -@@ -420,10 +415,6 @@ newtype HsIPName = HsIPName FastString +@@ -415,6 +420,10 @@ newtype HsIPName = HsIPName FastString hsIPNameFS :: HsIPName -> FastString hsIPNameFS (HsIPName n) = n --instance Binary HsIPName where -- put_ bh (HsIPName s) = put_ bh s -- get bh = HsIPName <$> get bh -- ++instance Binary HsIPName where ++ put_ bh (HsIPName s) = put_ bh s ++ get bh = HsIPName <$> get bh ++ instance Outputable HsIPName where ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters -@@ -668,7 +659,6 @@ type instance XKindSig (GhcPass _) = NoExt +@@ -659,6 +668,7 @@ type instance XKindSig (GhcPass _) = NoExt type instance XSpliceTy GhcPs = NoExt type instance XSpliceTy GhcRn = NoExt type instance XSpliceTy GhcTc = Kind --type instance XSpliceTy GhcSe = NoExt ++type instance XSpliceTy GhcSe = NoExt type instance XDocTy (GhcPass _) = NoExt type instance XBangTy (GhcPass _) = NoExt -@@ -677,19 +667,16 @@ type instance XRecTy (GhcPass _) = NoExt +@@ -667,16 +677,19 @@ type instance XRecTy (GhcPass _) = NoExt type instance XExplicitListTy GhcPs = NoExt type instance XExplicitListTy GhcRn = NoExt type instance XExplicitListTy GhcTc = Kind --type instance XExplicitListTy GhcSe = NoExt ++type instance XExplicitListTy GhcSe = NoExt type instance XExplicitTupleTy GhcPs = NoExt type instance XExplicitTupleTy GhcRn = NoExt type instance XExplicitTupleTy GhcTc = [Kind] --type instance XExplicitTupleTy GhcSe = NoExt ++type instance XExplicitTupleTy GhcSe = NoExt type instance XTyLit (GhcPass _) = NoExt type instance XWildCardTy GhcPs = NoExt type instance XWildCardTy GhcRn = HsWildCardInfo type instance XWildCardTy GhcTc = HsWildCardInfo --type instance XWildCardTy GhcSe = NoExt ++type instance XWildCardTy GhcSe = NoExt type instance XXType (GhcPass _) = NewHsTypeX -@@ -1150,32 +1137,27 @@ type LFieldOcc pass = Located (FieldOcc pass) +@@ -1137,27 +1150,32 @@ type LFieldOcc pass = Located (FieldOcc pass) -- both the 'RdrName' the user originally wrote, and after the -- renamer, the selector function. data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass -- , rdrNameFieldOcc :: Located (RdrOrSeName pass) -+ , rdrNameFieldOcc :: Located RdrName +- , rdrNameFieldOcc :: Located RdrName ++ , rdrNameFieldOcc :: Located (RdrOrSeName pass) -- ^ See Note [Located RdrNames] in HsExpr } | XFieldOcc (XXFieldOcc pass) --deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p), Eq (RdrOrSeName p)) -- => Eq (FieldOcc p) --deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p), Ord (RdrOrSeName p)) -- => Ord (FieldOcc p) -+deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p) -+deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p) +-deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p) +-deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p) ++deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p), Eq (RdrOrSeName p)) ++ => Eq (FieldOcc p) ++deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p), Ord (RdrOrSeName p)) ++ => Ord (FieldOcc p) type instance XCFieldOcc GhcPs = NoExt type instance XCFieldOcc GhcRn = Name type instance XCFieldOcc GhcTc = Id --type instance XCFieldOcc GhcSe = NoExt ++type instance XCFieldOcc GhcSe = NoExt type instance XXFieldOcc (GhcPass _) = NoExt --instance Outputable (RdrOrSeName pass) => Outputable (FieldOcc pass) where -+instance Outputable (FieldOcc pass) where +-instance Outputable (FieldOcc pass) where ++instance Outputable (RdrOrSeName pass) => Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc mkFieldOcc :: Located RdrName -> FieldOcc GhcPs mkFieldOcc rdr = FieldOcc noExt rdr --fieldOccRdrName :: RdrOrSeName pass ~ RdrName => FieldOcc pass -> Located RdrName --fieldOccRdrName = rdrNameFieldOcc ++fieldOccRdrName :: RdrOrSeName pass ~ RdrName => FieldOcc pass -> Located RdrName ++fieldOccRdrName = rdrNameFieldOcc -- | Ambiguous Field Occurrence -- -@@ -1190,36 +1172,31 @@ fieldOccRdrName = rdrNameFieldOcc +@@ -1172,31 +1190,36 @@ mkFieldOcc rdr = FieldOcc noExt rdr -- Note [Disambiguating record fields] in TcExpr. -- See Note [Located RdrNames] in HsExpr data AmbiguousFieldOcc pass -- = Unambiguous (XUnambiguous pass) (Located (RdrOrSeName pass)) -- | Ambiguous (XAmbiguous pass) (Located (RdrOrSeName pass)) -+ = Unambiguous (XUnambiguous pass) (Located RdrName) -+ | Ambiguous (XAmbiguous pass) (Located RdrName) +- = Unambiguous (XUnambiguous pass) (Located RdrName) +- | Ambiguous (XAmbiguous pass) (Located RdrName) ++ = Unambiguous (XUnambiguous pass) (Located (RdrOrSeName pass)) ++ | Ambiguous (XAmbiguous pass) (Located (RdrOrSeName pass)) | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) type instance XUnambiguous GhcPs = NoExt type instance XUnambiguous GhcRn = Name type instance XUnambiguous GhcTc = Id --type instance XUnambiguous GhcSe = NoExt ++type instance XUnambiguous GhcSe = NoExt type instance XAmbiguous GhcPs = NoExt type instance XAmbiguous GhcRn = NoExt type instance XAmbiguous GhcTc = Id --type instance XAmbiguous GhcSe = NoExt ++type instance XAmbiguous GhcSe = NoExt type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt --instance (p ~ GhcPass pass, Outputable (RdrOrSeName p)) -- => Outputable (AmbiguousFieldOcc p) where -+instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where +-instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where ++instance (p ~ GhcPass pass, Outputable (RdrOrSeName p)) ++ => Outputable (AmbiguousFieldOcc p) where ppr = ppr . rdrNameAmbiguousFieldOcc --instance (p ~ GhcPass pass, OutputableBndr (RdrOrSeName p)) -- => OutputableBndr (AmbiguousFieldOcc p) where -+instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where +-instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where ++instance (p ~ GhcPass pass, OutputableBndr (RdrOrSeName p)) ++ => OutputableBndr (AmbiguousFieldOcc p) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr --rdrNameAmbiguousFieldOcc -- :: AmbiguousFieldOcc (GhcPass p) -> RdrOrSeName (GhcPass p) -+rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName +-rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName ++rdrNameAmbiguousFieldOcc ++ :: AmbiguousFieldOcc (GhcPass p) -> RdrOrSeName (GhcPass p) rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs -index be0a5281ab..eba21cf1e2 100644 +index eba21cf1e2..be0a5281ab 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs -@@ -1133,9 +1133,8 @@ hsTyClForeignBinders tycl_decls foreign_decls +@@ -1133,8 +1133,9 @@ hsTyClForeignBinders tycl_decls foreign_decls getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs ------------------- --hsLTyClDeclBinders -- :: RdrOrSeName pass ~ RdrName -- => Located (TyClDecl pass) -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsLTyClDeclBinders :: Located (TyClDecl pass) -+ -> ([Located (IdP pass)], [LFieldOcc pass]) +-hsLTyClDeclBinders :: Located (TyClDecl pass) +- -> ([Located (IdP pass)], [LFieldOcc pass]) ++hsLTyClDeclBinders ++ :: RdrOrSeName pass ~ RdrName ++ => Located (TyClDecl pass) -> ([Located (IdP pass)], [LFieldOcc pass]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second -@@ -1189,8 +1188,7 @@ getPatSynBinds binds +@@ -1188,7 +1189,8 @@ getPatSynBinds binds , L _ (PatSynBind _ psb) <- bagToList lbinds ] ------------------- --hsLInstDeclBinders :: RdrOrSeName (GhcPass p) ~ RdrName -- => LInstDecl (GhcPass p) -+hsLInstDeclBinders :: LInstDecl (GhcPass p) +-hsLInstDeclBinders :: LInstDecl (GhcPass p) ++hsLInstDeclBinders :: RdrOrSeName (GhcPass p) ~ RdrName ++ => LInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) = foldMap (hsDataFamInstBinders . unLoc) dfis -@@ -1204,9 +1202,8 @@ hsLInstDeclBinders (L _ (XInstDecl _)) +@@ -1202,8 +1204,9 @@ hsLInstDeclBinders (L _ (XInstDecl _)) ------------------- -- the SrcLoc returned are for the whole declarations, not just the names --hsDataFamInstBinders -- :: RdrOrSeName pass ~ RdrName -- => DataFamInstDecl pass -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsDataFamInstBinders :: DataFamInstDecl pass -+ -> ([Located (IdP pass)], [LFieldOcc pass]) +-hsDataFamInstBinders :: DataFamInstDecl pass +- -> ([Located (IdP pass)], [LFieldOcc pass]) ++hsDataFamInstBinders ++ :: RdrOrSeName pass ~ RdrName ++ => DataFamInstDecl pass -> ([Located (IdP pass)], [LFieldOcc pass]) hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = defn }}}) = hsDataDefnBinders defn -@@ -1219,9 +1216,7 @@ hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _)) +@@ -1216,7 +1219,9 @@ hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _)) ------------------- -- the SrcLoc returned are for the whole declarations, not just the names --hsDataDefnBinders -- :: RdrOrSeName pass ~ RdrName -- => HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) +-hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) ++hsDataDefnBinders ++ :: RdrOrSeName pass ~ RdrName ++ => HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] -@@ -1231,9 +1226,7 @@ hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders" +@@ -1226,7 +1231,9 @@ hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders" type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass] -- Filters out ones that have already been seen --hsConDeclsBinders -- :: forall pass. RdrOrSeName pass ~ RdrName -- => [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) +-hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) ++hsConDeclsBinders ++ :: forall pass. RdrOrSeName pass ~ RdrName ++ => [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs -index e05dfc3a33..244243a82f 100644 +index 244243a82f..e05dfc3a33 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs -@@ -9,7 +9,6 @@ module PlaceHolder where +@@ -9,6 +9,7 @@ module PlaceHolder where import Name import NameSet import RdrName --import SeName ++import SeName import Var -@@ -69,4 +68,3 @@ type family NameOrRdrName id where +@@ -68,3 +69,4 @@ type family NameOrRdrName id where NameOrRdrName Id = Name NameOrRdrName Name = Name NameOrRdrName RdrName = RdrName -- NameOrRdrName SeName = SeName ++ NameOrRdrName SeName = SeName diff --git a/compiler/hsSyn/SeName.hs b/compiler/hsSyn/SeName.hs -deleted file mode 100644 -index f8bca59243..0000000000 ---- a/compiler/hsSyn/SeName.hs -+++ /dev/null -@@ -1,13 +0,0 @@ --{-# LANGUAGE GeneralizedNewtypeDeriving #-} --module SeName (SeName(..), mkSeName) where -- --import Outputable --import RdrName -- ---- TODO: make this smarter, so as to check whether ---- the name is local or not. --newtype SeName = SeName RdrName -- deriving (Outputable, OutputableBndr) -- --mkSeName :: RdrName -> SeName --mkSeName = SeName +new file mode 100644 +index 0000000000..f8bca59243 +--- /dev/null ++++ b/compiler/hsSyn/SeName.hs +@@ -0,0 +1,13 @@ ++{-# LANGUAGE GeneralizedNewtypeDeriving #-} ++module SeName (SeName(..), mkSeName) where ++ ++import Outputable ++import RdrName ++ ++-- TODO: make this smarter, so as to check whether ++-- the name is local or not. ++newtype SeName = SeName RdrName ++ deriving (Outputable, OutputableBndr) ++ ++mkSeName :: RdrName -> SeName ++mkSeName = SeName diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs -index 2d6047d7cc..00bcaa77f1 100644 +index 00bcaa77f1..2d6047d7cc 100644 --- a/compiler/iface/IfaceEnv.hs +++ b/compiler/iface/IfaceEnv.hs @@ -16,7 +16,7 @@ module IfaceEnv ( ifaceExportNames, -- Name-cache stuff -- allocateGlobalBinder, updNameCacheTc, updNameCacheIO, -+ allocateGlobalBinder, updNameCacheTc, +- allocateGlobalBinder, updNameCacheTc, ++ allocateGlobalBinder, updNameCacheTc, updNameCacheIO, mkNameCacheUpdater, NameCacheUpdater(..), ) where diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs -index 15a19b117f..5a7f761d32 100644 +index 5a7f761d32..15a19b117f 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -139,7 +139,7 @@ type IfaceContext = [IfacePredType] data IfaceTyLit = IfaceNumTyLit Integer | IfaceStrTyLit FastString -- deriving Eq -+ deriving (Eq) +- deriving (Eq) ++ deriving Eq type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag @@ -4751,8 +4751,8 @@ index 15a19b117f..5a7f761d32 100644 -- properly. data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName , ifaceTyConInfo :: IfaceTyConInfo } -- deriving Eq -+ deriving (Eq) +- deriving (Eq) ++ deriving Eq -- | Is a TyCon a promoted data constructor or just a normal type constructor? data IsPromoted = IsNotPromoted | IsPromoted @@ -4760,8 +4760,8 @@ index 15a19b117f..5a7f761d32 100644 -- that is actually being applied to two types -- of the same kind. This affects pretty-printing -- only: see Note [Equality predicates in IfaceType] -- deriving Eq -+ deriving (Eq) +- deriving (Eq) ++ deriving Eq {- Note [Free tyvars in IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -4769,780 +4769,780 @@ index 15a19b117f..5a7f761d32 100644 -- and to disambiguate D from 'D (they share a name) = IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted , ifaceTyConSort :: IfaceTyConSort } -- deriving Eq -+ deriving (Eq) +- deriving (Eq) ++ deriving Eq data IfaceCoercion = IfaceReflCo Role IfaceType -@@ -1650,7 +1650,6 @@ instance Binary IfaceUnivCoProv where +@@ -1650,6 +1650,7 @@ instance Binary IfaceUnivCoProv where _ -> panic ("get IfaceUnivCoProv " ++ show tag) --{- ++{- instance Binary (DefMethSpec IfaceType) where put_ bh VanillaDM = putByte bh 0 put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t -@@ -1659,4 +1658,3 @@ instance Binary (DefMethSpec IfaceType) where +@@ -1658,3 +1659,4 @@ instance Binary (DefMethSpec IfaceType) where case h of 0 -> return VanillaDM _ -> do { t <- get bh; return (GenericDM t) } ---} ++-} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs -index 5f217a6a8f..539132653e 100644 +index 539132653e..5f217a6a8f 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs -@@ -916,8 +916,6 @@ data DynFlags = DynFlags { +@@ -916,6 +916,8 @@ data DynFlags = DynFlags { hiDir :: Maybe String, stubDir :: Maybe String, dumpDir :: Maybe String, -- saveSplicesDir :: Maybe String, -- loadSplicesDir :: Maybe String, ++ saveSplicesDir :: Maybe String, ++ loadSplicesDir :: Maybe String, objectSuf :: String, hcSuf :: String, -@@ -1799,8 +1797,6 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) = +@@ -1797,6 +1799,8 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) = hiDir = Nothing, stubDir = Nothing, dumpDir = Nothing, -- saveSplicesDir = Nothing, -- loadSplicesDir = Nothing, ++ saveSplicesDir = Nothing, ++ loadSplicesDir = Nothing, objectSuf = phaseInputExt StopLn, hcSuf = phaseInputExt HCc, -@@ -2375,7 +2371,6 @@ getVerbFlags dflags +@@ -2371,6 +2375,7 @@ getVerbFlags dflags | otherwise = [] setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, -- setSaveSplicesDir, setLoadSplicesDir, ++ setSaveSplicesDir, setLoadSplicesDir, setDynObjectSuf, setDynHiSuf, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, -@@ -2395,8 +2390,6 @@ setStubDir f d = d { stubDir = Just f +@@ -2390,6 +2395,8 @@ setStubDir f d = d { stubDir = Just f -- builds). setDumpDir f d = d { dumpDir = Just f} setOutputDir f = setObjectDir f . setHiDir f . setStubDir f . setDumpDir f --setSaveSplicesDir f d = d { saveSplicesDir = Just f} --setLoadSplicesDir f d = d { loadSplicesDir = Just f} ++setSaveSplicesDir f d = d { saveSplicesDir = Just f} ++setLoadSplicesDir f d = d { loadSplicesDir = Just f} setDylibInstallName f d = d { dylibInstallName = Just f} setObjectSuf f d = d { objectSuf = f} -@@ -2955,8 +2948,6 @@ dynamic_flags_deps = [ +@@ -2948,6 +2955,8 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) -- , make_ord_flag defGhcFlag "save-splices" (hasArg setSaveSplicesDir) -- , make_ord_flag defGhcFlag "load-splices" (hasArg setLoadSplicesDir) ++ , make_ord_flag defGhcFlag "save-splices" (hasArg setSaveSplicesDir) ++ , make_ord_flag defGhcFlag "load-splices" (hasArg setLoadSplicesDir) , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) , make_ord_flag defGhcFlag "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) diff --git a/compiler/prelude/PrimOp.hs-boot b/compiler/prelude/PrimOp.hs-boot -index 6d759bb961..f10ef44972 100644 +index f10ef44972..6d759bb961 100644 --- a/compiler/prelude/PrimOp.hs-boot +++ b/compiler/prelude/PrimOp.hs-boot -@@ -1,7 +1,5 @@ +@@ -1,5 +1,7 @@ module PrimOp where --import GhcPrelude (Int) -+import GhcPrelude () +-import GhcPrelude () ++import GhcPrelude (Int) data PrimOp --primOpTag :: PrimOp -> Int --allThePrimOps :: [PrimOp] ++primOpTag :: PrimOp -> Int ++allThePrimOps :: [PrimOp] diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs -index 63c471d3ef..6195309cab 100644 +index 6195309cab..63c471d3ef 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -743,7 +743,7 @@ rnHsRecUpdFields flds getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds --getFieldLbls :: RdrOrSeName id ~ RdrName => [LHsRecField id arg] -> [RdrName] -+getFieldLbls :: [LHsRecField id arg] -> [RdrName] +-getFieldLbls :: [LHsRecField id arg] -> [RdrName] ++getFieldLbls :: RdrOrSeName id ~ RdrName => [LHsRecField id arg] -> [RdrName] getFieldLbls flds = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs -index 91d88087f8..f8f3bbe191 100644 +index f8f3bbe191..91d88087f8 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -7,7 +7,7 @@ The @Inst@ type: dictionaries or method instances -} {-# LANGUAGE CPP, MultiWayIf, TupleSections #-} --{-# LANGUAGE FlexibleContexts, TypeFamilies #-} -+{-# LANGUAGE FlexibleContexts #-} +-{-# LANGUAGE FlexibleContexts #-} ++{-# LANGUAGE FlexibleContexts, TypeFamilies #-} module Inst ( deeplySkolemise, diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs -index 00dcf26f09..b42557259e 100644 +index b42557259e..00dcf26f09 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE CPP, FlexibleInstances #-} --{-# LANGUAGE FlexibleContexts, GADTs #-} -+{-# LANGUAGE FlexibleContexts #-} +-{-# LANGUAGE FlexibleContexts #-} ++{-# LANGUAGE FlexibleContexts, GADTs #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an -- orphan {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs -index 1cca6f5589..986047bded 100644 +index 986047bded..1cca6f5589 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -114,7 +114,7 @@ hsPatType (NPlusKPat ty _ _ _ _ _) = ty hsPatType (CoPat _ _ _ ty) = ty hsPatType p = pprPanic "hsPatType" (ppr p) --hsLitType :: LitType (GhcPass p) ~ TcType => HsLit (GhcPass p) -> TcType -+hsLitType :: HsLit (GhcPass p) -> TcType +-hsLitType :: HsLit (GhcPass p) -> TcType ++hsLitType :: LitType (GhcPass p) ~ TcType => HsLit (GhcPass p) -> TcType hsLitType (HsChar _ _) = charTy hsLitType (HsCharPrim _ _) = charPrimTy hsLitType (HsString _ _) = stringTy diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs -index 5a048d0c4b..2f81e07990 100644 +index 2f81e07990..5a048d0c4b 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -47,7 +47,7 @@ module TcRnDriver ( import GhcPrelude --import {-# SOURCE #-} TcSplice( finishTH, writeHsSpliceData ) -+import {-# SOURCE #-} TcSplice ( finishTH ) +-import {-# SOURCE #-} TcSplice ( finishTH ) ++import {-# SOURCE #-} TcSplice( finishTH, writeHsSpliceData ) import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import IfaceEnv( externaliseName ) import TcHsType -@@ -114,7 +114,6 @@ import Avail +@@ -114,6 +114,7 @@ import Avail import TyCon import SrcLoc import HscTypes --import HsExprBin ++import HsExprBin import ListSetOps import Outputable import ConLike -@@ -138,8 +137,6 @@ import qualified Data.Set as S +@@ -137,6 +138,8 @@ import qualified Data.Set as S import Control.DeepSeq import Control.Monad --import System.Directory --import System.FilePath (takeDirectory) ++import System.Directory ++import System.FilePath (takeDirectory) #include "HsVersions.h" -@@ -424,17 +421,6 @@ tcRnSrcDecls explicit_mod_hdr decls +@@ -421,6 +424,17 @@ tcRnSrcDecls explicit_mod_hdr decls -- Finalizers must run after constraints are simplified, or some types -- might not be complete when using reify (see #12777). ; (tcg_env, tcl_env) <- setGblEnv tcg_env run_th_modfinalizers -- -- ; dynflags <- getDynFlags -- ; whenSet (saveSplicesDir dynflags) -- (\splicesDir -> do -- moduleSplicesPath <- getModuleSplicesPath splicesDir <$> getModule -- hs_splice_data <- readTcRef (tcg_hs_splice_data tcg_env) -- liftIO $ createDirectoryIfMissing True (takeDirectory moduleSplicesPath) -- writeHsSpliceData moduleSplicesPath hs_splice_data -- ) -- (pure ()) -- ++ ++ ; dynflags <- getDynFlags ++ ; whenSet (saveSplicesDir dynflags) ++ (\splicesDir -> do ++ moduleSplicesPath <- getModuleSplicesPath splicesDir <$> getModule ++ hs_splice_data <- readTcRef (tcg_hs_splice_data tcg_env) ++ liftIO $ createDirectoryIfMissing True (takeDirectory moduleSplicesPath) ++ writeHsSpliceData moduleSplicesPath hs_splice_data ++ ) ++ (pure ()) ++ ; setEnvs (tcg_env, tcl_env) $ do { ; finishTH diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs -index 83449f1631..e0989ae331 100644 +index e0989ae331..83449f1631 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs -@@ -145,7 +145,6 @@ import IOEnv -- Re-export all +@@ -145,6 +145,7 @@ import IOEnv -- Re-export all import TcEvidence import HsSyn hiding (LIE) --import HsExprBin ++import HsExprBin import HscTypes import Module import RdrName -@@ -183,7 +182,7 @@ import Control.Monad +@@ -182,7 +183,7 @@ import Control.Monad import Data.Set ( Set ) import qualified Data.Set as Set --import {-# SOURCE #-} TcSplice ( readHsSpliceData, runRemoteModFinalizers ) -+import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers ) +-import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers ) ++import {-# SOURCE #-} TcSplice ( readHsSpliceData, runRemoteModFinalizers ) import {-# SOURCE #-} TcEnv ( tcInitTidyEnv ) import qualified Data.Map as Map -@@ -229,16 +228,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this +@@ -228,9 +229,16 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this th_coreplugins_var <- newIORef [] ; th_state_var <- newIORef Map.empty ; th_remote_state_var <- newIORef Nothing ; -- dflags <- pure (hsc_dflags hsc_env) ; -- hs_splice_data <- newIORef =<< whenSet (loadSplicesDir dflags) -- (\splicesDir -> do -- if moduleUnitId mod == interactiveUnitId -- then return emptyHsSpliceData -- else do let moduleSplicesPath = getModuleSplicesPath splicesDir mod -- readHsSpliceData hsc_env moduleSplicesPath -- ) -- (pure emptyHsSpliceData) ; ++ dflags <- pure (hsc_dflags hsc_env) ; ++ hs_splice_data <- newIORef =<< whenSet (loadSplicesDir dflags) ++ (\splicesDir -> do ++ if moduleUnitId mod == interactiveUnitId ++ then return emptyHsSpliceData ++ else do let moduleSplicesPath = getModuleSplicesPath splicesDir mod ++ readHsSpliceData hsc_env moduleSplicesPath ++ ) ++ (pure emptyHsSpliceData) ; let { -+ dflags = hsc_dflags hsc_env ; -+ +- dflags = hsc_dflags hsc_env ; +- maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val | dopt Opt_D_dump_rn_ast dflags = Just empty_val -@@ -318,8 +310,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this +@@ -310,7 +318,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_top_loc = loc, tcg_static_wc = static_wc_var, tcg_complete_matches = [], -- tcg_cc_st = cc_st_var, -- tcg_hs_splice_data = hs_splice_data -+ tcg_cc_st = cc_st_var +- tcg_cc_st = cc_st_var ++ tcg_cc_st = cc_st_var, ++ tcg_hs_splice_data = hs_splice_data } ; } ; diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs -index 08ed9f151d..2a4b808f54 100644 +index 2a4b808f54..08ed9f151d 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs -@@ -160,7 +160,6 @@ import TyCoRep ( CoercionHole(..), coHoleCoVar ) +@@ -160,6 +160,7 @@ import TyCoRep ( CoercionHole(..), coHoleCoVar ) import Coercion ( Coercion, mkHoleCo ) import ConLike ( ConLike(..) ) import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) --import {-# SOURCE #-} HsExprBin ++import {-# SOURCE #-} HsExprBin import PatSyn ( PatSyn, pprPatSynType ) import Id ( idType, idName ) import FieldLabel ( FieldLabel ) -@@ -690,19 +689,7 @@ data TcGblEnv +@@ -689,7 +690,19 @@ data TcGblEnv tcg_complete_matches :: [CompleteMatch], -- ^ Tracking indices for cost centre annotations -- tcg_cc_st :: TcRef CostCentreState, -- -- ^ Splice evaluation results -- -- -- -- When @-save-splices@ is passed, we will -- -- record splice results in this field and write -- -- them all to an .hs-splice file when we are done -- -- processing the module. -- -- -- -- When @-load-splices@ is passed, we will read -- -- the .hs-splice file before we start processing a -- -- module (when it exists) and store all its contents -- -- in this field. -- tcg_hs_splice_data :: TcRef HsSpliceData -+ tcg_cc_st :: TcRef CostCentreState +- tcg_cc_st :: TcRef CostCentreState ++ tcg_cc_st :: TcRef CostCentreState, ++ -- ^ Splice evaluation results ++ -- ++ -- When @-save-splices@ is passed, we will ++ -- record splice results in this field and write ++ -- them all to an .hs-splice file when we are done ++ -- processing the module. ++ -- ++ -- When @-load-splices@ is passed, we will read ++ -- the .hs-splice file before we start processing a ++ -- module (when it exists) and store all its contents ++ -- in this field. ++ tcg_hs_splice_data :: TcRef HsSpliceData } -- NB: topModIdentity, not topModSemantic! diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs -index c6dd542937..737ddccfbd 100644 +index 737ddccfbd..c6dd542937 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs -@@ -26,7 +26,6 @@ module TcSplice( +@@ -26,6 +26,7 @@ module TcSplice( runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, tcTopSpliceExpr, lookupThName_maybe, defaultRunMeta, runMeta', runRemoteModFinalizers, -- readHsSpliceData, writeHsSpliceData, ++ readHsSpliceData, writeHsSpliceData, finishTH ) where -@@ -35,7 +34,6 @@ module TcSplice( +@@ -34,6 +35,7 @@ module TcSplice( import GhcPrelude import HsSyn --import HsExprBin ++import HsExprBin import Annotations import Finder import Name -@@ -112,9 +110,6 @@ import Maybes( MaybeErr(..) ) +@@ -110,6 +112,9 @@ import Maybes( MaybeErr(..) ) import DynFlags import Panic import Lexeme --import BinIface ( getWithUserData, putWithUserData ) --import IfaceEnv ( NameCacheUpdater(..) ) --import qualified Binary as Bin ++import BinIface ( getWithUserData, putWithUserData ) ++import IfaceEnv ( NameCacheUpdater(..) ) ++import qualified Binary as Bin import qualified EnumSet import Plugins import Bag -@@ -137,7 +132,6 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) +@@ -132,6 +137,7 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) import GHC.Exts ( unsafeCoerce# ) --import System.Directory ( doesFileExist ) ++import System.Directory ( doesFileExist ) {- ************************************************************************ -@@ -678,26 +672,12 @@ runQResult show_th f runQ expr_span hval +@@ -672,12 +678,26 @@ runQResult show_th f runQ expr_span hval ----------------- -- ++ runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) -- -> (LHsExpr GhcTc -> TcM hs_syn) -- -- ^ function to load the result of the given expression from -- -- an .hs-splice file's data -- -> (LHsExpr GhcTc -> hs_syn -> TcM ()) -- -- ^ function to "save" the result (hs_syn) of evaluating the given -- -- LHsExpr ++ -> (LHsExpr GhcTc -> TcM hs_syn) ++ -- ^ function to load the result of the given expression from ++ -- an .hs-splice file's data ++ -> (LHsExpr GhcTc -> hs_syn -> TcM ()) ++ -- ^ function to "save" the result (hs_syn) of evaluating the given ++ -- LHsExpr -> LHsExpr GhcTc -> TcM hs_syn --runMeta unwrap loadSpliceFun saveSpliceFun e -- = do { dflags <- getDynFlags -- ; whenSet (loadSplicesDir dflags) -- (\_ -> loadSpliceFun e) -- (do { h <- getHooked runMetaHook defaultRunMeta -- ; res <- unwrap h e -- ; whenSet (saveSplicesDir dflags) -- (\_ -> saveSpliceFun e res) -- (return ()) -- ; return res }) } -+runMeta unwrap e -+ = do { h <- getHooked runMetaHook defaultRunMeta -+ ; unwrap h e } +-runMeta unwrap e +- = do { h <- getHooked runMetaHook defaultRunMeta +- ; unwrap h e } ++runMeta unwrap loadSpliceFun saveSpliceFun e ++ = do { dflags <- getDynFlags ++ ; whenSet (loadSplicesDir dflags) ++ (\_ -> loadSpliceFun e) ++ (do { h <- getHooked runMetaHook defaultRunMeta ++ ; res <- unwrap h e ++ ; whenSet (saveSplicesDir dflags) ++ (\_ -> saveSpliceFun e res) ++ (return ()) ++ ; return res }) } defaultRunMeta :: MetaHook TcM defaultRunMeta (MetaE r) -@@ -714,110 +694,29 @@ defaultRunMeta (MetaAW r) +@@ -694,29 +714,110 @@ defaultRunMeta (MetaAW r) -- the toAnnotationWrapper function that we slap around the user's code ---------------- -- --readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData --readHsSpliceData hsc_env hsSpliceFile = do -- let ncu = NCU (updNameCache hsc_env) -- exists <- doesFileExist hsSpliceFile -- if exists -- then do bh <- Bin.readBinMem hsSpliceFile -- getWithUserData ncu bh -- else pure emptyHsSpliceData -- --writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () --writeHsSpliceData hsSpliceFile hsSpliceData = -- when (nonEmptyHsSpliceData hsSpliceData) $ do -- dflags <- getDynFlags -- liftIO $ do -- bh <- Bin.openBinMem (100 * 1024) -- -- ^^^ FIXME: how should we compute an approximation of size? -- putWithUserData (debugTraceMsg dflags 3) bh hsSpliceData -- Bin.writeBinMem bh hsSpliceFile -- ---- | Update the splice data from the TcGblEnv using the given ---- function. Used when -save-splices is passed, to record ---- the splice results as we evaluate them and dump them ---- to an .hs-splice file. --modifyHsSpliceData :: (HsSpliceData -> HsSpliceData) -> TcM () --modifyHsSpliceData f = do -- spliceDataRef <- tcg_hs_splice_data <$> getGblEnv -- updTcRef spliceDataRef f -- ---- | Record the result (second argument) of evaluating the expression splice ---- represented by the first argument. --addSpliceExprResult :: LHsExpr GhcTc -> LHsExpr GhcPs -> TcM () --addSpliceExprResult th@(L l _) resultE = do -- serialExpr <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) -- =<< exprPS2SE resultE -- modifyHsSpliceData $ recordSpliceResult l (SRExpr serialExpr) -- ---- | Record the result (second argument) of evaluating the declaration splice ---- represented by the first argument. --addSpliceDeclsResult :: LHsExpr GhcTc -> [LHsDecl GhcPs] -> TcM () --addSpliceDeclsResult th@(L l _) resultDs = do -- serialDecls <- traverse -- (declPS2SE >=> handleUnsupported (fmap ppr th) (Just $ ppr resultDs)) -- resultDs -- modifyHsSpliceData $ recordSpliceResult l (SRDecls serialDecls) -- ---- | Look up the result of evaluating the splice represented by the first ---- argument in an .hs-splice file, using the given function to extract ---- the result in question (when found). --getSpliceResult :: LHsExpr GhcTc -> (SpliceResult -> TcM a) -> TcM a --getSpliceResult (L l _) f = do -- gblEnv <- getGblEnv -- hs_splice_data <- readTcRef (tcg_hs_splice_data gblEnv) -- case lookupSpliceResult l hs_splice_data of -- Nothing -> panic ("Could not find splice result for source span " ++ show l) -- Just r -> f r -- ---- | Look up the result of evaluating an expression splice. --getSpliceExprResult :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs) --getSpliceExprResult spliceE = getSpliceResult spliceE $ \res -> case res of -- SRExpr e -> exprSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing -- SRDecls _ -> panic ("Expected an expression splice but found a declaration one") -- ---- | Look up the result of evaluating a declaration splice. --getSpliceDeclsResult :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] --getSpliceDeclsResult spliceE = getSpliceResult spliceE $ \res -> case res of -- SRExpr _ -> panic ("Expected a declaration splice result but found an expression one") -- SRDecls ds -> traverse -- (declSE2PS >=> handleUnsupported (fmap ppr spliceE) Nothing) -- ds -- ++ ++readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData ++readHsSpliceData hsc_env hsSpliceFile = do ++ let ncu = NCU (updNameCache hsc_env) ++ exists <- doesFileExist hsSpliceFile ++ if exists ++ then do bh <- Bin.readBinMem hsSpliceFile ++ getWithUserData ncu bh ++ else pure emptyHsSpliceData ++ ++writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () ++writeHsSpliceData hsSpliceFile hsSpliceData = ++ when (nonEmptyHsSpliceData hsSpliceData) $ do ++ dflags <- getDynFlags ++ liftIO $ do ++ bh <- Bin.openBinMem (100 * 1024) ++ -- ^^^ FIXME: how should we compute an approximation of size? ++ putWithUserData (debugTraceMsg dflags 3) bh hsSpliceData ++ Bin.writeBinMem bh hsSpliceFile ++ ++-- | Update the splice data from the TcGblEnv using the given ++-- function. Used when -save-splices is passed, to record ++-- the splice results as we evaluate them and dump them ++-- to an .hs-splice file. ++modifyHsSpliceData :: (HsSpliceData -> HsSpliceData) -> TcM () ++modifyHsSpliceData f = do ++ spliceDataRef <- tcg_hs_splice_data <$> getGblEnv ++ updTcRef spliceDataRef f ++ ++-- | Record the result (second argument) of evaluating the expression splice ++-- represented by the first argument. ++addSpliceExprResult :: LHsExpr GhcTc -> LHsExpr GhcPs -> TcM () ++addSpliceExprResult th@(L l _) resultE = do ++ serialExpr <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) ++ =<< exprPS2SE resultE ++ modifyHsSpliceData $ recordSpliceResult l (SRExpr serialExpr) ++ ++-- | Record the result (second argument) of evaluating the declaration splice ++-- represented by the first argument. ++addSpliceDeclsResult :: LHsExpr GhcTc -> [LHsDecl GhcPs] -> TcM () ++addSpliceDeclsResult th@(L l _) resultDs = do ++ serialDecls <- traverse ++ (declPS2SE >=> handleUnsupported (fmap ppr th) (Just $ ppr resultDs)) ++ resultDs ++ modifyHsSpliceData $ recordSpliceResult l (SRDecls serialDecls) ++ ++-- | Look up the result of evaluating the splice represented by the first ++-- argument in an .hs-splice file, using the given function to extract ++-- the result in question (when found). ++getSpliceResult :: LHsExpr GhcTc -> (SpliceResult -> TcM a) -> TcM a ++getSpliceResult (L l _) f = do ++ gblEnv <- getGblEnv ++ hs_splice_data <- readTcRef (tcg_hs_splice_data gblEnv) ++ case lookupSpliceResult l hs_splice_data of ++ Nothing -> panic ("Could not find splice result for source span " ++ show l) ++ Just r -> f r ++ ++-- | Look up the result of evaluating an expression splice. ++getSpliceExprResult :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs) ++getSpliceExprResult spliceE = getSpliceResult spliceE $ \res -> case res of ++ SRExpr e -> exprSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing ++ SRDecls _ -> panic ("Expected an expression splice but found a declaration one") ++ ++-- | Look up the result of evaluating a declaration splice. ++getSpliceDeclsResult :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] ++getSpliceDeclsResult spliceE = getSpliceResult spliceE $ \res -> case res of ++ SRExpr _ -> panic ("Expected a declaration splice result but found an expression one") ++ SRDecls ds -> traverse ++ (declSE2PS >=> handleUnsupported (fmap ppr spliceE) Nothing) ++ ds ++ runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper -> TcM Serialized runMetaAW = runMeta metaRequestAW -- -- We cannot process annotations as they use the same -- -- mechanism as TH. Instead, we ignore them when -- -- doing a -save-splices pass, and we pretend we -- -- read {-# ANN () #-} when doing a -load-splices pass. -- (\_ -> pure $ toSerialized serializeWithData ()) -- (\_ _ -> pure ()) ++ -- We cannot process annotations as they use the same ++ -- mechanism as TH. Instead, we ignore them when ++ -- doing a -save-splices pass, and we pretend we ++ -- read {-# ANN () #-} when doing a -load-splices pass. ++ (\_ -> pure $ toSerialized serializeWithData ()) ++ (\_ _ -> pure ()) runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) -> TcM (LHsExpr GhcPs) --runMetaE = runMeta metaRequestE getSpliceExprResult addSpliceExprResult -+runMetaE = runMeta metaRequestE +-runMetaE = runMeta metaRequestE ++runMetaE = runMeta metaRequestE getSpliceExprResult addSpliceExprResult runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) -> TcM (LPat GhcPs) runMetaP = runMeta metaRequestP -- (panic "runMetaP doesn't support splice caching (read)") -- (panic "runMetaP doesn't support splice caching (write)") ++ (panic "runMetaP doesn't support splice caching (read)") ++ (panic "runMetaP doesn't support splice caching (write)") runMetaT :: LHsExpr GhcTc -- Of type (Q Type) -> TcM (LHsType GhcPs) runMetaT = runMeta metaRequestT -- (panic "runMetaT doesn't support splice caching (read)") -- (panic "runMetaT doesn't support splice caching (write)") ++ (panic "runMetaT doesn't support splice caching (read)") ++ (panic "runMetaT doesn't support splice caching (write)") runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] -> TcM [LHsDecl GhcPs] --runMetaD = runMeta metaRequestD getSpliceDeclsResult addSpliceDeclsResult -+runMetaD = runMeta metaRequestD +-runMetaD = runMeta metaRequestD ++runMetaD = runMeta metaRequestD getSpliceDeclsResult addSpliceDeclsResult --------------- runMeta' :: Bool -- Whether code should be printed in the exception message -- -> (hs_syn -> SDoc) -- how to print the code -+ -> (hs_syn -> SDoc) -- how to print the code +- -> (hs_syn -> SDoc) -- how to print the code ++ -> (hs_syn -> SDoc) -- how to print the code -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or -- something like that -@@ -828,7 +727,7 @@ runMeta' show_code ppr_hs run_and_convert expr +@@ -727,7 +828,7 @@ runMeta' show_code ppr_hs run_and_convert expr -- we catch all kinds of splices and annotations. -- Check that we've had no errors of any sort so far. -- -- For example, if we fouénd an error in an earlier defn f, but -+ -- For example, if we found an error in an earlier defn f, but +- -- For example, if we found an error in an earlier defn f, but ++ -- For example, if we fouénd an error in an earlier defn f, but -- recovered giving it type f :: forall a.a, it'd be very dodgy -- to carry ont. Mind you, the staging restrictions mean we won't -- actually run f, but it still seems wrong. And, more concretely, diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot -index 277dc95c8d..be2c67d887 100644 +index be2c67d887..277dc95c8d 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot -@@ -10,8 +10,6 @@ import TcRnTypes( TcM , SpliceType ) +@@ -10,6 +10,8 @@ import TcRnTypes( TcM , SpliceType ) import TcType ( ExpRhoType ) import Annotations ( Annotation, CoreAnnTarget ) import HsExtension ( GhcTcId, GhcRn, GhcPs ) --import HscTypes ( HscEnv ) --import HsExprBin ( HsSpliceData ) ++import HscTypes ( HscEnv ) ++import HsExprBin ( HsSpliceData ) import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers ) -@@ -44,6 +42,3 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +@@ -42,3 +44,6 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a runRemoteModFinalizers :: ThModFinalizers -> TcM () finishTH :: TcM () -- --readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData --writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () ++ ++readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData ++writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () \ No newline at end of file diff --git a/compiler/typecheck/TcType.hs-boot b/compiler/typecheck/TcType.hs-boot -index 1b014c2d2a..2bc14735f1 100644 +index 2bc14735f1..1b014c2d2a 100644 --- a/compiler/typecheck/TcType.hs-boot +++ b/compiler/typecheck/TcType.hs-boot -@@ -4,6 +4,5 @@ import Outputable( SDoc ) +@@ -4,5 +4,6 @@ import Outputable( SDoc ) data MetaDetails data TcTyVarDetails -- ++ pprTcTyVarDetails :: TcTyVarDetails -> SDoc vanillaSkolemTv :: TcTyVarDetails diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs -index c8334ddd42..63c21627c8 100644 +index 63c21627c8..c8334ddd42 100644 --- a/compiler/types/CoAxiom.hs +++ b/compiler/types/CoAxiom.hs @@ -39,9 +39,9 @@ import Name import Unique import Var import Util -+import Binary +-import Binary import Pair import BasicTypes --import Binary ++import Binary import Data.Typeable ( Typeable ) import SrcLoc import qualified Data.Data as Data -@@ -440,16 +440,15 @@ instance Outputable Role where +@@ -440,15 +440,16 @@ instance Outputable Role where ppr = ftext . fsFromRole instance Binary Role where -- put_ bh r = putByte bh $ case r of -- Nominal -> 0 -- Representational -> 1 -- Phantom -> 2 -- get bh = do -- tag <- getByte bh -- pure $ case tag of -- 0 -> Nominal -- 1 -> Representational -- _ -> Phantom -+ put_ bh Nominal = putByte bh 1 -+ put_ bh Representational = putByte bh 2 -+ put_ bh Phantom = putByte bh 3 -+ -+ get bh = do tag <- getByte bh -+ case tag of 1 -> return Nominal -+ 2 -> return Representational -+ 3 -> return Phantom -+ _ -> panic ("get Role " ++ show tag) +- put_ bh Nominal = putByte bh 1 +- put_ bh Representational = putByte bh 2 +- put_ bh Phantom = putByte bh 3 +- +- get bh = do tag <- getByte bh +- case tag of 1 -> return Nominal +- 2 -> return Representational +- 3 -> return Phantom +- _ -> panic ("get Role " ++ show tag) ++ put_ bh r = putByte bh $ case r of ++ Nominal -> 0 ++ Representational -> 1 ++ Phantom -> 2 ++ get bh = do ++ tag <- getByte bh ++ pure $ case tag of ++ 0 -> Nominal ++ 1 -> Representational ++ _ -> Phantom {- ************************************************************************ -@@ -502,6 +501,7 @@ instance Ord CoAxiomRule where +@@ -501,7 +502,6 @@ instance Ord CoAxiomRule where instance Outputable CoAxiomRule where ppr = ppr . coaxrName -+ +- -- Type checking of built-in families data BuiltInSynFamily = BuiltInSynFamily { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs -index 786e77ef63..82c9082ac1 100644 +index 82c9082ac1..786e77ef63 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs -@@ -584,6 +584,7 @@ instance Binary TyConBndrVis where +@@ -584,7 +584,6 @@ instance Binary TyConBndrVis where 0 -> return AnonTCB _ -> do { vis <- get bh; return (NamedTCB vis) } } -+ +- {- ********************************************************************* * * The TyCon type diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs -index a84624d24c..447317ca47 100644 +index 447317ca47..a84624d24c 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs -@@ -63,16 +63,12 @@ module Binary +@@ -63,12 +63,16 @@ module Binary import GhcPrelude import {-# SOURCE #-} Name (Name) --import Bag ++import Bag import FastString import Panic --import Unique ++import Unique import UniqFM --import UniqSet ++import UniqSet import FastMutInt import Fingerprint import BasicTypes --import {-# SOURCE #-} PrimOp ++import {-# SOURCE #-} PrimOp import SrcLoc import Foreign -@@ -80,17 +76,14 @@ import Data.Array +@@ -76,14 +80,17 @@ import Data.Array import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS --import qualified Data.IntMap as IM ++import qualified Data.IntMap as IM import Data.IORef import Data.Char ( ord, chr ) --import Data.List ( find ) ++import Data.List ( find ) import Data.Time import Type.Reflection import Type.Reflection.Unsafe import Data.Kind (Type) import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) --import Data.Typeable ( ) --import Control.Monad ( when, replicateM ) -+import Control.Monad ( when ) +-import Control.Monad ( when ) ++import Data.Typeable ( ) ++import Control.Monad ( when, replicateM ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) -@@ -387,8 +380,8 @@ instance Binary () where +@@ -380,8 +387,8 @@ instance Binary () where get _ = return () instance Binary Bool where -- put_ bh b = putByte bh (if b then 1 else 0) -- get bh = do x <- getByte bh; return $! if x == 0 then False else True -+ put_ bh b = putByte bh (fromIntegral (fromEnum b)) -+ get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) +- put_ bh b = putByte bh (fromIntegral (fromEnum b)) +- get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) ++ put_ bh b = putByte bh (if b then 1 else 0) ++ get bh = do x <- getByte bh; return $! if x == 0 then False else True instance Binary Char where put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) -@@ -1180,121 +1173,3 @@ instance Binary SourceText where +@@ -1173,3 +1180,121 @@ instance Binary SourceText where s <- get bh return (SourceText s) _ -> panic $ "Binary SourceText:" ++ show h -- --instance Binary IntegralLit where -- put_ bh (IL a b c) = put_ bh a >> put_ bh b >> put_ bh c -- get bh = IL <$> get bh <*> get bh <*> get bh -- --instance Binary FractionalLit where -- put_ bh (FL a b c) = put_ bh a >> put_ bh b >> put_ bh c -- get bh = FL <$> get bh <*> get bh <*> get bh -- --instance Binary Boxity where -- put_ bh b = case b of -- Boxed -> putByte bh 0 -- Unboxed -> putByte bh 1 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure Boxed -- _ -> pure Unboxed -- --instance Binary Unique where -- put_ bh u = put_ bh (getKey u) -- get bh = mkUniqueGrimily <$> get bh -- --instance Binary ty => Binary (DefMethSpec ty) where -- put_ bh s -- = case s of -- VanillaDM -> putByte bh 0 -- GenericDM t -> putByte bh 1 >> put_ bh t -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure VanillaDM -- _ -> GenericDM <$> get bh -- --instance Binary a => Binary (IM.IntMap a) where -- put_ bh m = put_ bh (IM.toAscList m) -- get bh = IM.fromAscList <$> get bh -- --instance Binary PrimOp where -- put_ bh primop = put_ bh (primOpTag primop) -- -- FIXME: inefficient. -- get bh = do -- tag <- getTag -- case find (\p -> primOpTag p == tag) allThePrimOps of -- Nothing -> error "Binary PrimOp.get: unknown primop tag" -- Just p -> pure p -- -- where getTag :: IO Int -- getTag = get bh -- --instance Binary OccInfo where -- put_ bh i -- = case i of -- ManyOccs a -> putByte bh 0 >> put_ bh a -- IAmDead -> putByte bh 1 -- OneOcc a b c d -> putByte bh 2 >> put_ bh a >> put_ bh b -- >> put_ bh c >> put_ bh d -- IAmALoopBreaker a b -> putByte bh 3 >> put_ bh a >> put_ bh b -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> ManyOccs <$> get bh -- 1 -> pure IAmDead -- 2 -> OneOcc <$> get bh <*> get bh <*> get bh <*> get bh -- _ -> IAmALoopBreaker <$> get bh <*> get bh -- --instance Binary TailCallInfo where -- put_ bh i -- = case i of -- AlwaysTailCalled a -> putByte bh 0 >> put_ bh a -- NoTailCallInfo -> putByte bh 1 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> AlwaysTailCalled <$> get bh -- _ -> pure NoTailCallInfo -- --instance Binary OneShotInfo where -- put_ bh i -- = case i of -- NoOneShotInfo -> putByte bh 0 -- OneShotLam -> putByte bh 1 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure NoOneShotInfo -- _ -> pure OneShotLam -- --instance Binary LexicalFixity where -- put_ bh f = case f of -- Prefix -> putByte bh 0 -- Infix -> putByte bh 1 -- get bh = do -- tag <- getByte bh -- case tag of -- 0 -> pure Prefix -- _ -> pure Infix -- --instance Binary ele => Binary (UniqFM ele) where -- put_ bh ufm = put_ bh (ufmToIntMap ufm) -- get bh = intMapToUFM <$> get bh -- --instance Binary a => Binary (UniqSet a) where -- put_ bh s = put_ bh (getUniqSet s) -- get bh = unsafeUFMToUniqSet <$> get bh -- --instance Binary a => Binary (Bag a) where -- put_ bh b = put_ bh (bagToList b) -- get bh = listToBag <$> get bh -- --instance Binary Origin where -- put_ bh o = putByte bh $ case o of -- FromSource -> 0 -- Generated -> 1 -- get bh = getByte bh >>= \n -> case n of -- 0 -> pure FromSource -- 1 -> pure Generated -- _ -> panic "Binary Origin.get: unknown tag" ++ ++instance Binary IntegralLit where ++ put_ bh (IL a b c) = put_ bh a >> put_ bh b >> put_ bh c ++ get bh = IL <$> get bh <*> get bh <*> get bh ++ ++instance Binary FractionalLit where ++ put_ bh (FL a b c) = put_ bh a >> put_ bh b >> put_ bh c ++ get bh = FL <$> get bh <*> get bh <*> get bh ++ ++instance Binary Boxity where ++ put_ bh b = case b of ++ Boxed -> putByte bh 0 ++ Unboxed -> putByte bh 1 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure Boxed ++ _ -> pure Unboxed ++ ++instance Binary Unique where ++ put_ bh u = put_ bh (getKey u) ++ get bh = mkUniqueGrimily <$> get bh ++ ++instance Binary ty => Binary (DefMethSpec ty) where ++ put_ bh s ++ = case s of ++ VanillaDM -> putByte bh 0 ++ GenericDM t -> putByte bh 1 >> put_ bh t ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure VanillaDM ++ _ -> GenericDM <$> get bh ++ ++instance Binary a => Binary (IM.IntMap a) where ++ put_ bh m = put_ bh (IM.toAscList m) ++ get bh = IM.fromAscList <$> get bh ++ ++instance Binary PrimOp where ++ put_ bh primop = put_ bh (primOpTag primop) ++ -- FIXME: inefficient. ++ get bh = do ++ tag <- getTag ++ case find (\p -> primOpTag p == tag) allThePrimOps of ++ Nothing -> error "Binary PrimOp.get: unknown primop tag" ++ Just p -> pure p ++ ++ where getTag :: IO Int ++ getTag = get bh ++ ++instance Binary OccInfo where ++ put_ bh i ++ = case i of ++ ManyOccs a -> putByte bh 0 >> put_ bh a ++ IAmDead -> putByte bh 1 ++ OneOcc a b c d -> putByte bh 2 >> put_ bh a >> put_ bh b ++ >> put_ bh c >> put_ bh d ++ IAmALoopBreaker a b -> putByte bh 3 >> put_ bh a >> put_ bh b ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> ManyOccs <$> get bh ++ 1 -> pure IAmDead ++ 2 -> OneOcc <$> get bh <*> get bh <*> get bh <*> get bh ++ _ -> IAmALoopBreaker <$> get bh <*> get bh ++ ++instance Binary TailCallInfo where ++ put_ bh i ++ = case i of ++ AlwaysTailCalled a -> putByte bh 0 >> put_ bh a ++ NoTailCallInfo -> putByte bh 1 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> AlwaysTailCalled <$> get bh ++ _ -> pure NoTailCallInfo ++ ++instance Binary OneShotInfo where ++ put_ bh i ++ = case i of ++ NoOneShotInfo -> putByte bh 0 ++ OneShotLam -> putByte bh 1 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure NoOneShotInfo ++ _ -> pure OneShotLam ++ ++instance Binary LexicalFixity where ++ put_ bh f = case f of ++ Prefix -> putByte bh 0 ++ Infix -> putByte bh 1 ++ get bh = do ++ tag <- getByte bh ++ case tag of ++ 0 -> pure Prefix ++ _ -> pure Infix ++ ++instance Binary ele => Binary (UniqFM ele) where ++ put_ bh ufm = put_ bh (ufmToIntMap ufm) ++ get bh = intMapToUFM <$> get bh ++ ++instance Binary a => Binary (UniqSet a) where ++ put_ bh s = put_ bh (getUniqSet s) ++ get bh = unsafeUFMToUniqSet <$> get bh ++ ++instance Binary a => Binary (Bag a) where ++ put_ bh b = put_ bh (bagToList b) ++ get bh = listToBag <$> get bh ++ ++instance Binary Origin where ++ put_ bh o = putByte bh $ case o of ++ FromSource -> 0 ++ Generated -> 1 ++ get bh = getByte bh >>= \n -> case n of ++ 0 -> pure FromSource ++ 1 -> pure Generated ++ _ -> panic "Binary Origin.get: unknown tag" diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs -index 90389da0d1..715600ddb8 100644 +index 715600ddb8..90389da0d1 100644 --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs -@@ -62,7 +62,6 @@ module UniqDFM ( +@@ -62,6 +62,7 @@ module UniqDFM ( import GhcPrelude import Unique ( Uniquable(..), Unique, getKey ) --import Binary ++import Binary import Outputable import qualified Data.IntMap as M -@@ -129,10 +128,6 @@ instance Eq val => Eq (TaggedVal val) where +@@ -128,6 +129,10 @@ instance Eq val => Eq (TaggedVal val) where instance Functor TaggedVal where fmap f (TaggedVal val i) = TaggedVal (f val) i --instance Binary val => Binary (TaggedVal val) where -- put_ bh (TaggedVal a b) = put_ bh a >> put_ bh b -- get bh = TaggedVal <$> get bh <*> get bh -- ++instance Binary val => Binary (TaggedVal val) where ++ put_ bh (TaggedVal a b) = put_ bh a >> put_ bh b ++ get bh = TaggedVal <$> get bh <*> get bh ++ -- | Type of unique deterministic finite maps data UniqDFM ele = UDFM -@@ -144,10 +139,6 @@ data UniqDFM ele = +@@ -139,6 +144,10 @@ data UniqDFM ele = -- time. See Note [Overflow on plusUDFM] deriving (Data, Functor) --instance Binary ele => Binary (UniqDFM ele) where -- put_ bh (UDFM a b) = put_ bh a >> put_ bh b -- get bh = UDFM <$> get bh <*> get bh -- ++instance Binary ele => Binary (UniqDFM ele) where ++ put_ bh (UDFM a b) = put_ bh a >> put_ bh b ++ get bh = UDFM <$> get bh <*> get bh ++ emptyUDFM :: UniqDFM elt emptyUDFM = UDFM M.empty 0 diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs -index 7a7c40ecfc..a80880f4e5 100644 +index a80880f4e5..7a7c40ecfc 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -66,7 +66,7 @@ module UniqFM ( lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, nonDetEltsUFM, eltsUFM, nonDetKeysUFM, ufmToSet_Directly, -- nonDetUFMToList, ufmToIntMap, intMapToUFM, -+ nonDetUFMToList, ufmToIntMap, +- nonDetUFMToList, ufmToIntMap, ++ nonDetUFMToList, ufmToIntMap, intMapToUFM, pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM ) where -@@ -338,10 +338,7 @@ nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m +@@ -338,7 +338,10 @@ nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m ufmToIntMap :: UniqFM elt -> M.IntMap elt ufmToIntMap (UFM m) = m --intMapToUFM :: M.IntMap elt -> UniqFM elt --intMapToUFM = UFM -- ---- Determines whether two 'UniqFM's contain the same keys. -+-- Determines whether two 'UniqFm's contain the same keys. +--- Determines whether two 'UniqFm's contain the same keys. ++intMapToUFM :: M.IntMap elt -> UniqFM elt ++intMapToUFM = UFM ++ ++-- Determines whether two 'UniqFM's contain the same keys. equalKeysUFM :: UniqFM a -> UniqFM b -> Bool equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 From d1f070f70b2d5874a46aeb13538a6eb325e80367 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 9 Jul 2019 23:40:11 -0400 Subject: [PATCH 22/55] Remove commented out overrides --- haskell-overlays/any-8.6.nix | 25 ------------------------- 1 file changed, 25 deletions(-) diff --git a/haskell-overlays/any-8.6.nix b/haskell-overlays/any-8.6.nix index cff6339d6..1e9d9ef54 100644 --- a/haskell-overlays/any-8.6.nix +++ b/haskell-overlays/any-8.6.nix @@ -6,29 +6,4 @@ self: super: { haddock-library-ghcjs = dontCheck super.haddock-library-ghcjs; haddock-api-ghcjs = dontCheck super.haddock-api-ghcjs; algebraic-graphs = doJailbreak super.algebraic-graphs; - - # Broken in master - # PR is https://github.com/vincenthz/hit/pull/37 - # hit = dontCheck (self.callCabal2nix "hit" (fetchFromGitHub { - # owner = "vincenthz"; - # repo = "hit"; - # rev = "e93b01a295d5b4ca51b32b928b37ae040366e317"; - # sha256 = "1vfxqc3kffls11dzxq0gk62ky8rjm455cnh0nv31x43g3pmhh7sp"; - # }) {}); - - # doctests: doctests: could not execute: markdown-unlit - # Test suite doctests: FAIL - # rank2classes = dontCheck super.rank2classes; - # entropy = self.callHackage "entropy" "0.4.1.4" {}; - # cryptohash-sha256 = doJailbreak super.cryptohash-sha256; - # czipwith = doJailbreak super.czipwith; - # haddock-library = doJailbreak (self.callHackage "haddock-library" "1.7.0" {}); - # basement = self.callHackage "basement" "0.0.10" {}; - # keycode = doJailbreak (self.callCabal2nix "hit" (fetchFromGitHub { - # owner = "RyanGlScott"; - # repo = "keycode"; - # rev = "beecb745750de7b0b470ae5af9f2fe506f54dd31"; - # sha256 = "03zm21f134cpg13fhnm541hawz649ynwmcwwmaz358gdnd2fypgv"; - # }) {}); - # polyparse = self.callHackage "polyparse" "1.12.1" {}; } From 7347e595694b3a9632fd542d5a12a18db060d44a Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 10 Jul 2019 00:06:25 -0400 Subject: [PATCH 23/55] fix typo --- haskell-overlays/text-jsstring/default.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-overlays/text-jsstring/default.nix b/haskell-overlays/text-jsstring/default.nix index cefc3a20f..d02ce7140 100644 --- a/haskell-overlays/text-jsstring/default.nix +++ b/haskell-overlays/text-jsstring/default.nix @@ -21,7 +21,7 @@ self: super: { self.ghcjs-prim ]; }); - # TODO remove dontCheck from attoparsec - not sure why it semeingly hangs + # TODO remove dontCheck from attoparsec - not sure why it hangs attoparsec = dontCheck (doJailbreak (self.callCabal2nix "attoparsec" (fetchFromGitHub { owner = "obsidiansystems"; repo = "attoparsec"; From 086ffd9311a4cb2834a47e5a13a02a7d732655f6 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 10 Jul 2019 00:15:17 -0400 Subject: [PATCH 24/55] Remove more commented out overrides --- haskell-overlays/any-8.nix | 7 ------- 1 file changed, 7 deletions(-) diff --git a/haskell-overlays/any-8.nix b/haskell-overlays/any-8.nix index 04e1a2679..9a5432d68 100644 --- a/haskell-overlays/any-8.nix +++ b/haskell-overlays/any-8.nix @@ -1,11 +1,4 @@ { lib, haskellLib, getGhcVersion }: with haskellLib; self: super: lib.optionalAttrs (lib.versionOlder (getGhcVersion super.ghc) "8.6.0") { - # TODO document why - # concurrent-output = haskellLib.doJailbreak super.concurrent-output; - # # Newer versions cause some sort of issues with multiple `(<>)` definitions. - # # Seems to be that semigroup-monoid stuff is being CPP'd incorrectly. - # base-compat= self.callHackage "base-compat" "0.9.3" {}; - # haddock-library = doJailbreak (self.callHackage "haddock-library" "1.7.0" {}); - # entropy = self.callHackage "entropy" "0.4.1.4" {}; } From e3c9279c383bd48344197b21aa30a26eb5a4e6c8 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 10 Jul 2019 00:15:59 -0400 Subject: [PATCH 25/55] Remove more commented out overrides --- haskell-overlays/ghcjs.nix | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/haskell-overlays/ghcjs.nix b/haskell-overlays/ghcjs.nix index 6ae1c017c..07fa461ac 100644 --- a/haskell-overlays/ghcjs.nix +++ b/haskell-overlays/ghcjs.nix @@ -48,19 +48,4 @@ self: super: { # Convenience: tests take long to finish megaparsec = dontCheck super.megaparsec; - # Need newer version of colour for some reason. - # colour = dontCheck (super.colour.overrideAttrs (drv: { - # src = nixpkgs.buildPackages.fetchurl { - # url = "http://hackage.haskell.org/package/colour-2.3.4/colour-2.3.4.tar.gz"; - # sha256 = "1sy51nz096sv91nxqk6yk7b92b5a40axv9183xakvki2nc09yhqg"; - # }; - # })); - stringsearch = doJailbreak super.stringsearch; - # entropy = super.entropy.overrideAttrs (drv: { - # src = nixpkgs.buildPackages.fetchurl { - # url = "http://hackage.haskell.org/package/entropy-0.4.1.4/entropy-0.4.1.4.tar.gz"; - # sha256 = "1fgf47l9klwn1xssbcbq6by651vikd8hlfxhiwd5bqzxr1jnlgrf"; - # }; - # version = "0.4.1.4"; - # }); } From 749553c58cd6b4a3a796fb67b4aacb3471c1f59e Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 10 Jul 2019 00:27:46 -0400 Subject: [PATCH 26/55] Remove references to the "a" package that has been deleted --- release.nix | 4 ---- 1 file changed, 4 deletions(-) diff --git a/release.nix b/release.nix index 5fd3080cb..b1fba7427 100644 --- a/release.nix +++ b/release.nix @@ -59,11 +59,9 @@ let } // lib.optionalAttrs (reflex-platform.androidSupport) { inherit (reflex-platform-profiled) androidReflexTodomvc; inherit (reflex-platform-profiled) androidReflexTodomvc-8_6; - a = reflex-platform-profiled.ghcAndroidAarch64.a; } // lib.optionalAttrs (reflex-platform.iosSupport) { inherit (reflex-platform-profiled) iosReflexTodomvc; inherit (reflex-platform-profiled) iosReflexTodomvc-8_6; - a = reflex-platform-profiled.ghcIosAarch64.a; }; skeleton-test-ghc = skeleton-test.ghc; skeleton-test-ghcjs = skeleton-test.ghcjs; @@ -74,12 +72,10 @@ let } // lib.optionalAttrs (reflex-platform.androidSupport) { inherit (reflex-platform) androidReflexTodomvc; inherit (reflex-platform) androidReflexTodomvc-8_6; - a = reflex-platform.ghcAndroidAarch64.a; skeleton-test-project-android = skeleton-test.project.android; } // lib.optionalAttrs (reflex-platform.iosSupport) { inherit (reflex-platform) iosReflexTodomvc; inherit (reflex-platform) iosReflexTodomvc-8_6; - a = reflex-platform.ghcIosAarch64.a; skeleton-test-project-ios = skeleton-test.project.ios; } // drvListToAttrs otherDeps // drvListToAttrs (lib.filter lib.isDerivation reflex-platform.cachePackages) # TODO no filter From 9bc2100016a97ad30d4a226385262c28c45d98fd Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 10 Jul 2019 08:54:54 -0400 Subject: [PATCH 27/55] Remove deprecated android platforms --- default.nix | 5 ----- 1 file changed, 5 deletions(-) diff --git a/default.nix b/default.nix index 82fb08736..0a5f12c57 100644 --- a/default.nix +++ b/default.nix @@ -109,11 +109,6 @@ let iosSupport = system == "x86_64-darwin"; sdkVer = "22"; }; }; - # Back compat - arm64 = lib.warn "nixpkgsCross.android.arm64 has been deprecated, using nixpkgsCross.android.aarch64 instead." aarch64; - armv7a = lib.warn "nixpkgsCross.android.armv7a has been deprecated, using nixpkgsCross.android.aarch32 instead." aarch32; - arm64Impure = lib.warn "nixpkgsCross.android.arm64Impure has been deprecated, using nixpkgsCross.android.aarch64 instead." aarch64; - armv7aImpure = lib.warn "nixpkgsCross.android.armv7aImpure has been deprecated, using nixpkgsCross.android.aarch32 instead." aarch32; }; ios = lib.mapAttrs (_: args: nixpkgsFunc (nixpkgsArgs // args)) rec { simulator64 = { From 5e166c170fe78cb1ff2dcb55feb44fb6e90cc347 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 10 Jul 2019 11:12:03 -0400 Subject: [PATCH 28/55] Add new haddock patch for splices-load-save; Move splices stuff to one directory --- default.nix | 2 +- haddock.patch | 33 ------------------- haskell-overlays/default.nix | 4 +-- .../splices-load-save/ghc.patch | 0 .../splices-load-save/haddock.patch | 13 ++++++++ .../{ => splices-load-save}/load-splices.nix | 4 +++ .../{ => splices-load-save}/save-splices.nix | 4 +++ 7 files changed, 24 insertions(+), 36 deletions(-) delete mode 100644 haddock.patch rename splices-load-save.patch => haskell-overlays/splices-load-save/ghc.patch (100%) create mode 100644 haskell-overlays/splices-load-save/haddock.patch rename haskell-overlays/{ => splices-load-save}/load-splices.nix (93%) rename haskell-overlays/{ => splices-load-save}/save-splices.nix (88%) diff --git a/default.nix b/default.nix index 0a5f12c57..403fca977 100644 --- a/default.nix +++ b/default.nix @@ -21,7 +21,7 @@ let iosSupport = system == "x86_64-darwin"; ghcSplices-8_6 = super.haskell.compiler.ghc865.overrideAttrs (drv: { enableParallelBuilding = false; patches = (drv.patches or []) - ++ [ ./splices-load-save.patch ]; + ++ [ ./haskell-overlays/splices-load-save/ghc.patch ]; }); }; packages = super.haskell.packages // { diff --git a/haddock.patch b/haddock.patch deleted file mode 100644 index ad43f645c..000000000 --- a/haddock.patch +++ /dev/null @@ -1,33 +0,0 @@ -diff --git a/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs b/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs -index e002b602..11ea8ab7 100644 ---- a/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs -+++ b/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs -@@ -1,4 +1,4 @@ --{-# LANGUAGE FlexibleContexts #-} -+{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - ----------------------------------------------------------------------------- - -- | - -- Module : Haddock.Backends.Hoogle -diff --git a/utils/haddock/haddock-api/src/Haddock/Convert.hs b/utils/haddock/haddock-api/src/Haddock/Convert.hs -index 8b227c50..364d1669 100644 ---- a/utils/haddock/haddock-api/src/Haddock/Convert.hs -+++ b/utils/haddock/haddock-api/src/Haddock/Convert.hs -@@ -1,4 +1,4 @@ --{-# LANGUAGE CPP, PatternGuards #-} -+{-# LANGUAGE CPP, PatternGuards, GADTs #-} - ----------------------------------------------------------------------------- - -- | - -- Module : Haddock.Convert -diff --git a/utils/haddock/haddock-api/src/Haddock/Types.hs b/utils/haddock/haddock-api/src/Haddock/Types.hs -index 36ed7baf..d1a02669 100644 ---- a/utils/haddock/haddock-api/src/Haddock/Types.hs -+++ b/utils/haddock/haddock-api/src/Haddock/Types.hs -@@ -300,7 +300,7 @@ data DocName - data DocNameI - - type instance IdP DocNameI = DocName -- -+type instance RdrOrSeName DocNameI = RdrName - - instance NamedThing DocName where - getName (Documented name _) = name diff --git a/haskell-overlays/default.nix b/haskell-overlays/default.nix index 0111a84cd..f45ef8c44 100644 --- a/haskell-overlays/default.nix +++ b/haskell-overlays/default.nix @@ -101,11 +101,11 @@ rec { ghc-8_6 = _: _: {}; ghc-head = _: _: {}; - saveSplices = import ./save-splices.nix { + saveSplices = import ./splices-load-save/save-splices.nix { inherit lib haskellLib fetchFromGitHub; }; - loadSplices = import ./load-splices.nix { + loadSplices = import ./splices-load-save/load-splices.nix { inherit lib haskellLib fetchFromGitHub; splicedHaskellPackages = ghcSavedSplices; }; diff --git a/splices-load-save.patch b/haskell-overlays/splices-load-save/ghc.patch similarity index 100% rename from splices-load-save.patch rename to haskell-overlays/splices-load-save/ghc.patch diff --git a/haskell-overlays/splices-load-save/haddock.patch b/haskell-overlays/splices-load-save/haddock.patch new file mode 100644 index 000000000..f46c95a5a --- /dev/null +++ b/haskell-overlays/splices-load-save/haddock.patch @@ -0,0 +1,13 @@ +diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs +index a4ef5f82..faa9e1c9 100644 +--- a/haddock-api/src/Haddock/Types.hs ++++ b/haddock-api/src/Haddock/Types.hs +@@ -298,7 +298,7 @@ data DocName + data DocNameI + + type instance IdP DocNameI = DocName +- ++type instance RdrOrSeName DocNameI = RdrName + + instance NamedThing DocName where + getName (Documented name _) = name diff --git a/haskell-overlays/load-splices.nix b/haskell-overlays/splices-load-save/load-splices.nix similarity index 93% rename from haskell-overlays/load-splices.nix rename to haskell-overlays/splices-load-save/load-splices.nix index 3967302cb..379f20eba 100644 --- a/haskell-overlays/load-splices.nix +++ b/haskell-overlays/splices-load-save/load-splices.nix @@ -41,4 +41,8 @@ in { ''; }); + haddock = super.haddock.overrideAttrs (drv: { + patches = (drv.patches or []) ++ [ ./haddock.patch ]; + }); + } diff --git a/haskell-overlays/save-splices.nix b/haskell-overlays/splices-load-save/save-splices.nix similarity index 88% rename from haskell-overlays/save-splices.nix rename to haskell-overlays/splices-load-save/save-splices.nix index 7ebb247c0..a9c329f24 100644 --- a/haskell-overlays/save-splices.nix +++ b/haskell-overlays/splices-load-save/save-splices.nix @@ -21,6 +21,10 @@ self: super: { // { inherit SPLICE_DIR; }) else super.mkDerivation attrs; + haddock = super.haddock.overrideAttrs (drv: { + patches = (drv.patches or []) ++ [ ./haddock.patch ]; + }); + vector-th-unbox = haskellLib.dontCheck super.vector-th-unbox; lens = haskellLib.dontCheck super.lens; From b48d70cb82f236252e2f0ef48fb80fdf78af4c45 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 10 Jul 2019 11:24:39 -0400 Subject: [PATCH 29/55] Apply haddock patch at ghcSplices build time --- default.nix | 6 ++++-- haskell-overlays/splices-load-save/haddock.patch | 6 +++--- haskell-overlays/splices-load-save/load-splices.nix | 4 ---- haskell-overlays/splices-load-save/save-splices.nix | 4 ---- 4 files changed, 7 insertions(+), 13 deletions(-) diff --git a/default.nix b/default.nix index 403fca977..c782ab744 100644 --- a/default.nix +++ b/default.nix @@ -20,8 +20,10 @@ let iosSupport = system == "x86_64-darwin"; compiler = super.haskell.compiler // { ghcSplices-8_6 = super.haskell.compiler.ghc865.overrideAttrs (drv: { enableParallelBuilding = false; - patches = (drv.patches or []) - ++ [ ./haskell-overlays/splices-load-save/ghc.patch ]; + patches = (drv.patches or []) ++ [ + ./haskell-overlays/splices-load-save/ghc.patch + ./haskell-overlays/splices-load-save/haddock.patch + ]; }); }; packages = super.haskell.packages // { diff --git a/haskell-overlays/splices-load-save/haddock.patch b/haskell-overlays/splices-load-save/haddock.patch index f46c95a5a..14dad87c3 100644 --- a/haskell-overlays/splices-load-save/haddock.patch +++ b/haskell-overlays/splices-load-save/haddock.patch @@ -1,7 +1,7 @@ -diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs +diff --git a/utils/haddock/haddock-api/src/Haddock/Types.hs b/utils/haddock/haddock-api/src/Haddock/Types.hs index a4ef5f82..faa9e1c9 100644 ---- a/haddock-api/src/Haddock/Types.hs -+++ b/haddock-api/src/Haddock/Types.hs +--- a/utils/haddock/haddock-api/src/Haddock/Types.hs ++++ b/utils/haddock/haddock-api/src/Haddock/Types.hs @@ -298,7 +298,7 @@ data DocName data DocNameI diff --git a/haskell-overlays/splices-load-save/load-splices.nix b/haskell-overlays/splices-load-save/load-splices.nix index 379f20eba..3967302cb 100644 --- a/haskell-overlays/splices-load-save/load-splices.nix +++ b/haskell-overlays/splices-load-save/load-splices.nix @@ -41,8 +41,4 @@ in { ''; }); - haddock = super.haddock.overrideAttrs (drv: { - patches = (drv.patches or []) ++ [ ./haddock.patch ]; - }); - } diff --git a/haskell-overlays/splices-load-save/save-splices.nix b/haskell-overlays/splices-load-save/save-splices.nix index a9c329f24..7ebb247c0 100644 --- a/haskell-overlays/splices-load-save/save-splices.nix +++ b/haskell-overlays/splices-load-save/save-splices.nix @@ -21,10 +21,6 @@ self: super: { // { inherit SPLICE_DIR; }) else super.mkDerivation attrs; - haddock = super.haddock.overrideAttrs (drv: { - patches = (drv.patches or []) ++ [ ./haddock.patch ]; - }); - vector-th-unbox = haskellLib.dontCheck super.vector-th-unbox; lens = haskellLib.dontCheck super.lens; From 0e1c1f790f32f35f3b09891d8dca310c7700b32e Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 10 Jul 2019 17:56:52 -0400 Subject: [PATCH 30/55] Update force-relocation patch ghc version; Temporarily check in a patch to nixpkgs while we wait to see if it fixes android builds --- nixpkgs-disable-pie.diff | 30 +++++++++++++++++++ .../android-patches/force-relocation.patch | 0 nixpkgs-overlays/mobile-ghc/default.nix | 4 +-- 3 files changed, 32 insertions(+), 2 deletions(-) create mode 100644 nixpkgs-disable-pie.diff rename nixpkgs-overlays/mobile-ghc/{8.4.y => 8.6.y}/android-patches/force-relocation.patch (100%) diff --git a/nixpkgs-disable-pie.diff b/nixpkgs-disable-pie.diff new file mode 100644 index 000000000..43fc2ec7c --- /dev/null +++ b/nixpkgs-disable-pie.diff @@ -0,0 +1,30 @@ +diff --git a/pkgs/build-support/bintools-wrapper/default.nix b/pkgs/build-support/bintools-wrapper/default.nix +index 59a7ded4bdd8..8d81e0af9029 100644 +--- a/pkgs/build-support/bintools-wrapper/default.nix ++++ b/pkgs/build-support/bintools-wrapper/default.nix +@@ -303,6 +303,10 @@ stdenv.mkDerivation { + done + '' + ++ + optionalString targetPlatform.useAndroidPrebuilt '' ++ hardening_unsupported_flags+=" pie" ++ '' ++ + + '' + set +u + substituteAll ${./add-flags.sh} $out/nix-support/add-flags.sh +diff --git a/pkgs/build-support/cc-wrapper/default.nix b/pkgs/build-support/cc-wrapper/default.nix +index 176df51cbd9a..46a85132b95b 100644 +--- a/pkgs/build-support/cc-wrapper/default.nix ++++ b/pkgs/build-support/cc-wrapper/default.nix +@@ -295,6 +295,10 @@ stdenv.mkDerivation { + hardening_unsupported_flags+=" stackprotector fortify pie pic" + '' + ++ + optionalString targetPlatform.useAndroidPrebuilt '' ++ hardening_unsupported_flags+=" pie" ++ '' ++ + + optionalString (libc != null && targetPlatform.isAvr) '' + for isa in avr5 avr3 avr4 avr6 avr25 avr31 avr35 avr51 avrxmega2 avrxmega4 avrxmega5 avrxmega6 avrxmega7 tiny-stack; do + echo "-B${getLib libc}/avr/lib/$isa" >> $out/nix-support/libc-cflags diff --git a/nixpkgs-overlays/mobile-ghc/8.4.y/android-patches/force-relocation.patch b/nixpkgs-overlays/mobile-ghc/8.6.y/android-patches/force-relocation.patch similarity index 100% rename from nixpkgs-overlays/mobile-ghc/8.4.y/android-patches/force-relocation.patch rename to nixpkgs-overlays/mobile-ghc/8.6.y/android-patches/force-relocation.patch diff --git a/nixpkgs-overlays/mobile-ghc/default.nix b/nixpkgs-overlays/mobile-ghc/default.nix index aaebe8bd7..024b64e87 100644 --- a/nixpkgs-overlays/mobile-ghc/default.nix +++ b/nixpkgs-overlays/mobile-ghc/default.nix @@ -4,8 +4,8 @@ self: super: { haskell = super.haskell // { compiler = super.haskell.compiler // lib.mapAttrs (n: v: v.overrideAttrs (drv: { patches = (drv.patches or []) ++ lib.optionals self.stdenv.targetPlatform.useAndroidPrebuilt [ - ./8.4.y/android-patches/force-relocation.patch + ./8.6.y/android-patches/force-relocation.patch ]; - })) { inherit (super.haskell.compiler) ghc844 ghcHEAD ghcSplices; }; + })) { inherit (super.haskell.compiler) ghc865 ghcSplices; }; }; } From 0ff2eedf4244751b568d7583dcfb99b8e9d1be9a Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 11 Jul 2019 11:24:07 -0400 Subject: [PATCH 31/55] Backport fix for ghc #16331 to allow TH splices in place of GHC compiler capability --- default.nix | 1 + ...c-backport-issue16331-mr885-e172a6d1.patch | 31 +++++++++++++++++++ 2 files changed, 32 insertions(+) create mode 100644 haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch diff --git a/default.nix b/default.nix index c782ab744..2b42d08e8 100644 --- a/default.nix +++ b/default.nix @@ -22,6 +22,7 @@ let iosSupport = system == "x86_64-darwin"; enableParallelBuilding = false; patches = (drv.patches or []) ++ [ ./haskell-overlays/splices-load-save/ghc.patch + ./haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch ./haskell-overlays/splices-load-save/haddock.patch ]; }); diff --git a/haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch b/haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch new file mode 100644 index 000000000..e371206be --- /dev/null +++ b/haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch @@ -0,0 +1,31 @@ +diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs +index 92e3455..a165218 100644 +--- a/compiler/main/DriverPipeline.hs ++++ b/compiler/main/DriverPipeline.hs +@@ -255,6 +255,13 @@ compileOne' m_tc_result mHscMessage + not isDynWay && not isProfWay && needsLinker + then gopt_set dflags0 Opt_BuildDynamicToo + else dflags0 ++ -- #16331 - when no "internal interpreter" is available but we ++ -- need to process some TemplateHaskell or QuasiQuotes, we automatically ++ -- turn on -fexternal-interpreter. ++ dflags2 = if not internalInterpreter && needsLinker ++ then gopt_set dflags1 Opt_ExternalInterpreter ++ else dflags1 ++ + + basename = dropExtension input_fn + +@@ -262,10 +269,10 @@ compileOne' m_tc_result mHscMessage + -- path. This is needed when we try to compile the .hc file later, if it + -- imports a _stub.h file that we created here. + current_dir = takeDirectory basename +- old_paths = includePaths dflags1 ++ old_paths = includePaths dflags2 + prevailing_dflags = hsc_dflags hsc_env0 + dflags = +- dflags1 { includePaths = addQuoteInclude old_paths [current_dir] ++ dflags2 { includePaths = addQuoteInclude old_paths [current_dir] + , log_action = log_action prevailing_dflags } + -- use the prevailing log_action / log_finaliser, + -- not the one cached in the summary. This is so From e416e1ee0aa32107f01b528e2a794e87543c524f Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 11 Jul 2019 11:33:38 -0400 Subject: [PATCH 32/55] Update ghcSplices to support pattern and type splices --- default.nix | 1 + .../ghc-pattern-splices-1229eee8.patch | 193 ++++++++++++++++++ 2 files changed, 194 insertions(+) create mode 100644 haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch diff --git a/default.nix b/default.nix index 2b42d08e8..3f49dfef5 100644 --- a/default.nix +++ b/default.nix @@ -23,6 +23,7 @@ let iosSupport = system == "x86_64-darwin"; patches = (drv.patches or []) ++ [ ./haskell-overlays/splices-load-save/ghc.patch ./haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch + ./haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch ./haskell-overlays/splices-load-save/haddock.patch ]; }); diff --git a/haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch b/haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch new file mode 100644 index 000000000..dc7106cc3 --- /dev/null +++ b/haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch @@ -0,0 +1,193 @@ +diff --git a/compiler/hsSyn/HsExprBin.hs b/compiler/hsSyn/HsExprBin.hs +index 7967f934fb123c9507b5e8cc147868427f483794..eb2eb2766200475a88dee8249b394d1052cc83eb 100644 +--- a/compiler/hsSyn/HsExprBin.hs ++++ b/compiler/hsSyn/HsExprBin.hs +@@ -80,17 +80,22 @@ nonEmptyHsSpliceData = not . Map.null . hsSpliceMap + data SpliceResult + = SRExpr (LHsExpr GhcSe) + | SRDecls [LHsDecl GhcSe] -- TODO: change to HsGroup ? +- -- TODO: add patterns and types? ++ | SRPat (LHsPat GhcSe) ++ | SRTy (LHsType GhcSe) + + instance Binary SpliceResult where + put_ bh r = case r of + SRExpr e -> putByte bh 0 >> put_ bh e + SRDecls ds -> putByte bh 1 >> put_ bh ds ++ SRPat p -> putByte bh 2 >> put_ bh p ++ SRTy t -> putByte bh 3 >> put_ bh t + get bh = do + tag <- getByte bh + case tag of + 0 -> SRExpr <$> get bh + 1 -> SRDecls <$> get bh ++ 2 -> SRPat <$> get bh ++ 3 -> SRTy <$> get bh + _ -> panic "Binary SpliceResult: unknown tag" + + instance Binary HsSpliceData where +@@ -115,6 +120,14 @@ exprSE2PS = runConv . SE2PS.cvLHsExpr + declSE2PS :: LHsDecl GhcSe -> RnM (ConvResult (LHsDecl GhcPs)) + declSE2PS = runConv . SE2PS.cvLHsDecl + ++-- | Convert a serialisable pattern AST to a parsed pattern AST ++patSE2PS :: LHsPat GhcSe -> RnM (ConvResult (LHsPat GhcPs)) ++patSE2PS = runConv . SE2PS.cvLHsPat ++ ++-- | Convert a serialisable type AST to a parsed type ST ++tySE2PS :: LHsType GhcSe -> RnM (ConvResult (LHsType GhcPs)) ++tySE2PS = runConv . SE2PS.cvLHsType ++ + -- Converting Ps -> Se + + -- | Convert a parsed expression AST to a serialisable expression AST +@@ -125,6 +138,14 @@ exprPS2SE = runConv . PS2SE.cvLHsExpr + declPS2SE :: LHsDecl GhcPs -> RnM (ConvResult (LHsDecl GhcSe)) + declPS2SE = runConv . PS2SE.cvLHsDecl + ++-- | Convert a serialisable pattern AST to a parsed pattern AST ++patPS2SE :: LHsPat GhcPs -> RnM (ConvResult (LHsPat GhcSe)) ++patPS2SE = runConv . PS2SE.cvLHsPat ++ ++-- | Convert a serialisable type AST to a parsed type ST ++tyPS2SE :: LHsType GhcPs -> RnM (ConvResult (LHsType GhcSe)) ++tyPS2SE = runConv . PS2SE.cvLHsType ++ + -- * Error reporting + + -- | Panics with a nice error when we encounter an unsupported +diff --git a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs +index 839564fbfe21ceabcb180b4b1eb4cd71ac1bf95a..401f431b77c1e409766c70683114ef4f0ef85f34 100644 +--- a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs ++++ b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs +@@ -488,6 +488,9 @@ cvMatch f (Match a b c d) = Match a + <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d + cvMatch _ (XMatch a) = pure (XMatch a) + ++cvLHsPat :: LHsPat GhcPs -> Conv (LHsPat GhcSe) ++cvLHsPat = traverse cvPat ++ + cvPat :: Pat GhcPs -> Conv (Pat GhcSe) + cvPat (WildPat a) = pure (WildPat a) + cvPat (VarPat a b) = VarPat a <$> convertName b +@@ -704,6 +707,9 @@ cvHsImplicitBndrs + cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b + cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) + ++cvLHsType :: LHsType GhcPs -> Conv (HsType GhcSe) ++cvLHsType = traverse cvType ++ + cvType :: HsType GhcPs -> Conv (HsType GhcSe) + cvType (HsForAllTy a b c) = HsForAllTy a + <$> traverse (traverse cvHsTyVarBndr) b +diff --git a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs +index 8fbc941a71339ea1154b8fb1cab4c18c0f094172..cea4c619605cde2a288840c782bba1c3076b8cac 100644 +--- a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs ++++ b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs +@@ -489,6 +489,9 @@ cvMatch f (Match a b c d) = Match a + <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d + cvMatch _ (XMatch a) = pure (XMatch a) + ++cvLHsPat :: LHsPat GhcSe -> Conv (LHsPat GhcPs) ++cvLHsPat = traverse cvPat ++ + cvPat :: Pat GhcSe -> Conv (Pat GhcPs) + cvPat (WildPat a) = pure (WildPat a) + cvPat (VarPat a b) = VarPat a <$> convertName b +@@ -705,6 +708,9 @@ cvHsImplicitBndrs + cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b + cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) + ++cvLHsType :: LHsType GhcSe -> Conv (LHsType GhcPs) ++cvLHsType = traverse cvType ++ + cvType :: HsType GhcSe -> Conv (HsType GhcPs) + cvType (HsForAllTy a b c) = HsForAllTy a + <$> traverse (traverse cvHsTyVarBndr) b +diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs +index c6dd542937c3b706a39343100ce858571b1b1dd6..be3443cba8737eea6e9c3a25b9b0a86db86dbb87 100644 +--- a/compiler/typecheck/TcSplice.hs ++++ b/compiler/typecheck/TcSplice.hs +@@ -760,6 +760,22 @@ addSpliceDeclsResult th@(L l _) resultDs = do + resultDs + modifyHsSpliceData $ recordSpliceResult l (SRDecls serialDecls) + ++-- | Record the result (second argument) of evaluating the pattern splice ++-- represented by the first argument. ++addSplicePatResult :: LHsExpr GhcTc -> LHsPat GhcPs -> TcM () ++addSplicePatResult th@(L l _) resultE = do ++ serialPat <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) ++ =<< patPS2SE resultE ++ modifyHsSpliceData $ recordSpliceResult l (SRExpr serialPat) ++ ++-- | Record the result (second argument) of evaluating the type splice ++-- represented by the first argument. ++addSpliceTypeResult :: LHsExpr GhcTc -> LHsType GhcPs -> TcM () ++addSpliceTypeResult th@(L l _) resultE = do ++ serialTy <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) ++ =<< tyPS2SE resultE ++ modifyHsSpliceData $ recordSpliceResult l (SRExpr serialTy) ++ + -- | Look up the result of evaluating the splice represented by the first + -- argument in an .hs-splice file, using the given function to extract + -- the result in question (when found). +@@ -775,16 +791,39 @@ getSpliceResult (L l _) f = do + getSpliceExprResult :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs) + getSpliceExprResult spliceE = getSpliceResult spliceE $ \res -> case res of + SRExpr e -> exprSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing +- SRDecls _ -> panic ("Expected an expression splice but found a declaration one") ++ SRPat _ -> expectedFoundSplice "expression" "pattern" ++ SRTy _ -> expectedFoundSplice "expression" "type" ++ SRDecls _ -> expectedFoundSplice "expression" "declarations" ++ ++-- | Look up the result of evaluating a pattern splice. ++getSplicePatResult :: LHsExpr GhcTc -> TcM (LHsPat GhcPs) ++getSplicePatResult spliceE = getSpliceResult spliceE $ \res -> case res of ++ SRPat e -> patSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing ++ SRExpr _ -> expectedFoundSplice "pattern" "expression" ++ SRTy _ -> expectedFoundSplice "pattern" "type" ++ SRDecls _ -> expectedFoundSplice "pattern" "declarations" ++ ++-- | Look up the result of evaluating a type splice. ++getSpliceTypeResult :: LHsExpr GhcTc -> TcM (LHsType GhcPs) ++getSpliceTypeResult spliceE = getSpliceResult spliceE $ \res -> case res of ++ SRTy e -> tySE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing ++ SRExpr _ -> expectedFoundSplice "type" "expression" ++ SRPat _ -> expectedFoundSplice "type" "pattern" ++ SRDecls _ -> expectedFoundSplice "type" "declarations" + + -- | Look up the result of evaluating a declaration splice. + getSpliceDeclsResult :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] + getSpliceDeclsResult spliceE = getSpliceResult spliceE $ \res -> case res of +- SRExpr _ -> panic ("Expected a declaration splice result but found an expression one") ++ SRExpr _ -> expectedFoundSplice "declarations" "expression" ++ SRPat _ -> expectedFoundSplice "declarations" "pattern" ++ SRTy _ -> expectedFoundSplice "delcarations" "type" + SRDecls ds -> traverse + (declSE2PS >=> handleUnsupported (fmap ppr spliceE) Nothing) + ds + ++expectedFoundSplice exp found = ++ panic ("Expected a " ++ exp ++ " splice result but found: " ++ found) ++ + runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper + -> TcM Serialized + runMetaAW = runMeta metaRequestAW +@@ -801,15 +840,11 @@ runMetaE = runMeta metaRequestE getSpliceExprResult addSpliceExprResult + + runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) + -> TcM (LPat GhcPs) +-runMetaP = runMeta metaRequestP +- (panic "runMetaP doesn't support splice caching (read)") +- (panic "runMetaP doesn't support splice caching (write)") ++runMetaP = runMeta metaRequestP getSplicePatResult addSplicePatResult + + runMetaT :: LHsExpr GhcTc -- Of type (Q Type) + -> TcM (LHsType GhcPs) +-runMetaT = runMeta metaRequestT +- (panic "runMetaT doesn't support splice caching (read)") +- (panic "runMetaT doesn't support splice caching (write)") ++runMetaT = runMeta metaRequestT getSpliceTypeResult addSpliceTypeResult + + runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] + -> TcM [LHsDecl GhcPs] From 0db4fb540cd6f39ca8aa2756ef0ea3aadc69d3a4 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 11 Jul 2019 21:58:40 -0400 Subject: [PATCH 33/55] Newer ghcSplices patches --- default.nix | 2 ++ .../ghc-pattern-splices-33647e08.patch | 26 +++++++++++++++++++ .../ghc-pattern-splices-f1384f4d.patch | 17 ++++++++++++ 3 files changed, 45 insertions(+) create mode 100644 haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch create mode 100644 haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch diff --git a/default.nix b/default.nix index 3f49dfef5..3e39b334f 100644 --- a/default.nix +++ b/default.nix @@ -24,6 +24,8 @@ let iosSupport = system == "x86_64-darwin"; ./haskell-overlays/splices-load-save/ghc.patch ./haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch ./haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch + ./haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch + ./haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch ./haskell-overlays/splices-load-save/haddock.patch ]; }); diff --git a/haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch b/haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch new file mode 100644 index 000000000..2d83b54f9 --- /dev/null +++ b/haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch @@ -0,0 +1,26 @@ +diff --git a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs +index 401f431b77c1e409766c70683114ef4f0ef85f34..7e2b6e957a66afdec89ef5bae525acfe2a834688 100644 +--- a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs ++++ b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs +@@ -488,7 +488,7 @@ cvMatch f (Match a b c d) = Match a + <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d + cvMatch _ (XMatch a) = pure (XMatch a) + +-cvLHsPat :: LHsPat GhcPs -> Conv (LHsPat GhcSe) ++cvLHsPat :: LPat GhcPs -> Conv (LPat GhcSe) + cvLHsPat = traverse cvPat + + cvPat :: Pat GhcPs -> Conv (Pat GhcSe) +diff --git a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs +index cea4c619605cde2a288840c782bba1c3076b8cac..cf39727f10224dfd74283d4a6d22fd64005e676b 100644 +--- a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs ++++ b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs +@@ -489,7 +489,7 @@ cvMatch f (Match a b c d) = Match a + <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d + cvMatch _ (XMatch a) = pure (XMatch a) + +-cvLHsPat :: LHsPat GhcSe -> Conv (LHsPat GhcPs) ++cvLHsPat :: LPat GhcSe -> Conv (LPat GhcPs) + cvLHsPat = traverse cvPat + + cvPat :: Pat GhcSe -> Conv (Pat GhcPs) diff --git a/haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch b/haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch new file mode 100644 index 000000000..f6ecb7899 --- /dev/null +++ b/haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch @@ -0,0 +1,17 @@ +diff --git a/compiler/hsSyn/HsExprBin.hs b/compiler/hsSyn/HsExprBin.hs +index eb2eb2766200475a88dee8249b394d1052cc83eb..affecc7e1489a60538f7a9ace3c2c21059170d14 100644 +--- a/compiler/hsSyn/HsExprBin.hs ++++ b/compiler/hsSyn/HsExprBin.hs +@@ -9,8 +9,12 @@ module HsExprBin + , lookupSpliceResult + , exprSE2PS + , declSE2PS ++ , patSE2PS ++ , tySE2PS + , exprPS2SE + , declPS2SE ++ , patPS2SE ++ , tyPS2SE + , handleUnsupported + ) where + From e0a909aa97e31d0dcbbe0634eb9689fb5dd51a7a Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 11 Jul 2019 23:26:47 -0400 Subject: [PATCH 34/55] Some fixes to ghcSplices patching resulting from changes to support pattern and type splices --- default.nix | 1 + .../splices-load-save/ghc-lpat-fix.patch | 98 +++++++++++++++++++ 2 files changed, 99 insertions(+) create mode 100644 haskell-overlays/splices-load-save/ghc-lpat-fix.patch diff --git a/default.nix b/default.nix index 3e39b334f..77ce68c87 100644 --- a/default.nix +++ b/default.nix @@ -26,6 +26,7 @@ let iosSupport = system == "x86_64-darwin"; ./haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch ./haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch ./haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch + ./haskell-overlays/splices-load-save/ghc-lpat-fix.patch ./haskell-overlays/splices-load-save/haddock.patch ]; }); diff --git a/haskell-overlays/splices-load-save/ghc-lpat-fix.patch b/haskell-overlays/splices-load-save/ghc-lpat-fix.patch new file mode 100644 index 000000000..14adc13eb --- /dev/null +++ b/haskell-overlays/splices-load-save/ghc-lpat-fix.patch @@ -0,0 +1,98 @@ +diff --git a/compiler/hsSyn/HsExprBin.hs b/compiler/hsSyn/HsExprBin.hs +index affecc7e14..1cc77688d5 100644 +--- a/compiler/hsSyn/HsExprBin.hs ++++ b/compiler/hsSyn/HsExprBin.hs +@@ -27,6 +27,8 @@ import qualified HsExprBin_ConversionSE2PS as SE2PS + import qualified HsExprBin_ConversionPS2SE as PS2SE + import HsExprBin_Instances () + import HsExtension ++import HsPat ++import HsTypes + import Module + import Outputable + import SrcLoc +@@ -84,7 +86,7 @@ nonEmptyHsSpliceData = not . Map.null . hsSpliceMap + data SpliceResult + = SRExpr (LHsExpr GhcSe) + | SRDecls [LHsDecl GhcSe] -- TODO: change to HsGroup ? +- | SRPat (LHsPat GhcSe) ++ | SRPat (LPat GhcSe) + | SRTy (LHsType GhcSe) + + instance Binary SpliceResult where +@@ -125,7 +127,7 @@ declSE2PS :: LHsDecl GhcSe -> RnM (ConvResult (LHsDecl GhcPs)) + declSE2PS = runConv . SE2PS.cvLHsDecl + + -- | Convert a serialisable pattern AST to a parsed pattern AST +-patSE2PS :: LHsPat GhcSe -> RnM (ConvResult (LHsPat GhcPs)) ++patSE2PS :: LPat GhcSe -> RnM (ConvResult (LPat GhcPs)) + patSE2PS = runConv . SE2PS.cvLHsPat + + -- | Convert a serialisable type AST to a parsed type ST +@@ -143,7 +145,7 @@ declPS2SE :: LHsDecl GhcPs -> RnM (ConvResult (LHsDecl GhcSe)) + declPS2SE = runConv . PS2SE.cvLHsDecl + + -- | Convert a serialisable pattern AST to a parsed pattern AST +-patPS2SE :: LHsPat GhcPs -> RnM (ConvResult (LHsPat GhcSe)) ++patPS2SE :: LPat GhcPs -> RnM (ConvResult (LPat GhcSe)) + patPS2SE = runConv . PS2SE.cvLHsPat + + -- | Convert a serialisable type AST to a parsed type ST +diff --git a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs +index 7e2b6e957a..e60c3ba5a3 100644 +--- a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs ++++ b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs +@@ -707,7 +707,8 @@ cvHsImplicitBndrs + cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b + cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) + +-cvLHsType :: LHsType GhcPs -> Conv (HsType GhcSe) ++-- cvLHsType :: LHsType GhcPs -> Conv (HsType GhcSe) ++cvLHsType :: Traversable t => t (HsType GhcPs) -> Conv (t (HsType GhcSe)) + cvLHsType = traverse cvType + + cvType :: HsType GhcPs -> Conv (HsType GhcSe) +diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs +index be3443cba8..7f4064617c 100644 +--- a/compiler/typecheck/TcSplice.hs ++++ b/compiler/typecheck/TcSplice.hs +@@ -762,11 +762,11 @@ addSpliceDeclsResult th@(L l _) resultDs = do + + -- | Record the result (second argument) of evaluating the pattern splice + -- represented by the first argument. +-addSplicePatResult :: LHsExpr GhcTc -> LHsPat GhcPs -> TcM () ++addSplicePatResult :: LHsExpr GhcTc -> LPat GhcPs -> TcM () + addSplicePatResult th@(L l _) resultE = do + serialPat <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) + =<< patPS2SE resultE +- modifyHsSpliceData $ recordSpliceResult l (SRExpr serialPat) ++ modifyHsSpliceData $ recordSpliceResult l (SRPat serialPat) + + -- | Record the result (second argument) of evaluating the type splice + -- represented by the first argument. +@@ -774,7 +774,7 @@ addSpliceTypeResult :: LHsExpr GhcTc -> LHsType GhcPs -> TcM () + addSpliceTypeResult th@(L l _) resultE = do + serialTy <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) + =<< tyPS2SE resultE +- modifyHsSpliceData $ recordSpliceResult l (SRExpr serialTy) ++ modifyHsSpliceData $ recordSpliceResult l (SRTy serialTy) + + -- | Look up the result of evaluating the splice represented by the first + -- argument in an .hs-splice file, using the given function to extract +@@ -796,7 +796,7 @@ getSpliceExprResult spliceE = getSpliceResult spliceE $ \res -> case res of + SRDecls _ -> expectedFoundSplice "expression" "declarations" + + -- | Look up the result of evaluating a pattern splice. +-getSplicePatResult :: LHsExpr GhcTc -> TcM (LHsPat GhcPs) ++getSplicePatResult :: LHsExpr GhcTc -> TcM (LPat GhcPs) + getSplicePatResult spliceE = getSpliceResult spliceE $ \res -> case res of + SRPat e -> patSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing + SRExpr _ -> expectedFoundSplice "pattern" "expression" +@@ -821,6 +821,7 @@ getSpliceDeclsResult spliceE = getSpliceResult spliceE $ \res -> case res of + (declSE2PS >=> handleUnsupported (fmap ppr spliceE) Nothing) + ds + ++expectedFoundSplice :: String -> String -> a + expectedFoundSplice exp found = + panic ("Expected a " ++ exp ++ " splice result but found: " ++ found) + From 7a1f79a9a8be449c604cf7c1d22328224262f50c Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 12 Jul 2019 19:58:30 -0400 Subject: [PATCH 35/55] Use a thunk for ghcSplices --- default.nix | 14 +- .../splices-load-save/dep/ghc/git.json | 6 + ...c-backport-issue16331-mr885-e172a6d1.patch | 31 - .../splices-load-save/ghc-lpat-fix.patch | 98 - .../ghc-pattern-splices-1229eee8.patch | 193 - .../ghc-pattern-splices-33647e08.patch | 26 - .../ghc-pattern-splices-f1384f4d.patch | 17 - haskell-overlays/splices-load-save/ghc.patch | 5548 ----------------- .../splices-load-save/haddock.patch | 13 - 9 files changed, 11 insertions(+), 5935 deletions(-) create mode 100644 haskell-overlays/splices-load-save/dep/ghc/git.json delete mode 100644 haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch delete mode 100644 haskell-overlays/splices-load-save/ghc-lpat-fix.patch delete mode 100644 haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch delete mode 100644 haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch delete mode 100644 haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch delete mode 100644 haskell-overlays/splices-load-save/ghc.patch delete mode 100644 haskell-overlays/splices-load-save/haddock.patch diff --git a/default.nix b/default.nix index 77ce68c87..14b7d1527 100644 --- a/default.nix +++ b/default.nix @@ -20,15 +20,11 @@ let iosSupport = system == "x86_64-darwin"; compiler = super.haskell.compiler // { ghcSplices-8_6 = super.haskell.compiler.ghc865.overrideAttrs (drv: { enableParallelBuilding = false; - patches = (drv.patches or []) ++ [ - ./haskell-overlays/splices-load-save/ghc.patch - ./haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch - ./haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch - ./haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch - ./haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch - ./haskell-overlays/splices-load-save/ghc-lpat-fix.patch - ./haskell-overlays/splices-load-save/haddock.patch - ]; + src = nixpkgs.hackGet ./haskell-overlays/splices-load-save/dep/ghc; + preConfigure= '' + echo ${drv.version} >VERSION + ./boot + '' + drv.preConfigure or ""; }); }; packages = super.haskell.packages // { diff --git a/haskell-overlays/splices-load-save/dep/ghc/git.json b/haskell-overlays/splices-load-save/dep/ghc/git.json new file mode 100644 index 000000000..66d0fab71 --- /dev/null +++ b/haskell-overlays/splices-load-save/dep/ghc/git.json @@ -0,0 +1,6 @@ +{ + "url": "git@gitlab.haskell.org:obsidiansystems/ghc", + "rev": "c832deafcabe36022abe217538d4347ace6abee2", + "sha256": "0i024m5skvii7q9hyj87zra625ws5ss5knq7lrcbcs3fhaa6pq5j", + "fetchSubmodules": true +} diff --git a/haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch b/haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch deleted file mode 100644 index e371206be..000000000 --- a/haskell-overlays/splices-load-save/ghc-backport-issue16331-mr885-e172a6d1.patch +++ /dev/null @@ -1,31 +0,0 @@ -diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs -index 92e3455..a165218 100644 ---- a/compiler/main/DriverPipeline.hs -+++ b/compiler/main/DriverPipeline.hs -@@ -255,6 +255,13 @@ compileOne' m_tc_result mHscMessage - not isDynWay && not isProfWay && needsLinker - then gopt_set dflags0 Opt_BuildDynamicToo - else dflags0 -+ -- #16331 - when no "internal interpreter" is available but we -+ -- need to process some TemplateHaskell or QuasiQuotes, we automatically -+ -- turn on -fexternal-interpreter. -+ dflags2 = if not internalInterpreter && needsLinker -+ then gopt_set dflags1 Opt_ExternalInterpreter -+ else dflags1 -+ - - basename = dropExtension input_fn - -@@ -262,10 +269,10 @@ compileOne' m_tc_result mHscMessage - -- path. This is needed when we try to compile the .hc file later, if it - -- imports a _stub.h file that we created here. - current_dir = takeDirectory basename -- old_paths = includePaths dflags1 -+ old_paths = includePaths dflags2 - prevailing_dflags = hsc_dflags hsc_env0 - dflags = -- dflags1 { includePaths = addQuoteInclude old_paths [current_dir] -+ dflags2 { includePaths = addQuoteInclude old_paths [current_dir] - , log_action = log_action prevailing_dflags } - -- use the prevailing log_action / log_finaliser, - -- not the one cached in the summary. This is so diff --git a/haskell-overlays/splices-load-save/ghc-lpat-fix.patch b/haskell-overlays/splices-load-save/ghc-lpat-fix.patch deleted file mode 100644 index 14adc13eb..000000000 --- a/haskell-overlays/splices-load-save/ghc-lpat-fix.patch +++ /dev/null @@ -1,98 +0,0 @@ -diff --git a/compiler/hsSyn/HsExprBin.hs b/compiler/hsSyn/HsExprBin.hs -index affecc7e14..1cc77688d5 100644 ---- a/compiler/hsSyn/HsExprBin.hs -+++ b/compiler/hsSyn/HsExprBin.hs -@@ -27,6 +27,8 @@ import qualified HsExprBin_ConversionSE2PS as SE2PS - import qualified HsExprBin_ConversionPS2SE as PS2SE - import HsExprBin_Instances () - import HsExtension -+import HsPat -+import HsTypes - import Module - import Outputable - import SrcLoc -@@ -84,7 +86,7 @@ nonEmptyHsSpliceData = not . Map.null . hsSpliceMap - data SpliceResult - = SRExpr (LHsExpr GhcSe) - | SRDecls [LHsDecl GhcSe] -- TODO: change to HsGroup ? -- | SRPat (LHsPat GhcSe) -+ | SRPat (LPat GhcSe) - | SRTy (LHsType GhcSe) - - instance Binary SpliceResult where -@@ -125,7 +127,7 @@ declSE2PS :: LHsDecl GhcSe -> RnM (ConvResult (LHsDecl GhcPs)) - declSE2PS = runConv . SE2PS.cvLHsDecl - - -- | Convert a serialisable pattern AST to a parsed pattern AST --patSE2PS :: LHsPat GhcSe -> RnM (ConvResult (LHsPat GhcPs)) -+patSE2PS :: LPat GhcSe -> RnM (ConvResult (LPat GhcPs)) - patSE2PS = runConv . SE2PS.cvLHsPat - - -- | Convert a serialisable type AST to a parsed type ST -@@ -143,7 +145,7 @@ declPS2SE :: LHsDecl GhcPs -> RnM (ConvResult (LHsDecl GhcSe)) - declPS2SE = runConv . PS2SE.cvLHsDecl - - -- | Convert a serialisable pattern AST to a parsed pattern AST --patPS2SE :: LHsPat GhcPs -> RnM (ConvResult (LHsPat GhcSe)) -+patPS2SE :: LPat GhcPs -> RnM (ConvResult (LPat GhcSe)) - patPS2SE = runConv . PS2SE.cvLHsPat - - -- | Convert a serialisable type AST to a parsed type ST -diff --git a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -index 7e2b6e957a..e60c3ba5a3 100644 ---- a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -+++ b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -@@ -707,7 +707,8 @@ cvHsImplicitBndrs - cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b - cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) - --cvLHsType :: LHsType GhcPs -> Conv (HsType GhcSe) -+-- cvLHsType :: LHsType GhcPs -> Conv (HsType GhcSe) -+cvLHsType :: Traversable t => t (HsType GhcPs) -> Conv (t (HsType GhcSe)) - cvLHsType = traverse cvType - - cvType :: HsType GhcPs -> Conv (HsType GhcSe) -diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs -index be3443cba8..7f4064617c 100644 ---- a/compiler/typecheck/TcSplice.hs -+++ b/compiler/typecheck/TcSplice.hs -@@ -762,11 +762,11 @@ addSpliceDeclsResult th@(L l _) resultDs = do - - -- | Record the result (second argument) of evaluating the pattern splice - -- represented by the first argument. --addSplicePatResult :: LHsExpr GhcTc -> LHsPat GhcPs -> TcM () -+addSplicePatResult :: LHsExpr GhcTc -> LPat GhcPs -> TcM () - addSplicePatResult th@(L l _) resultE = do - serialPat <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) - =<< patPS2SE resultE -- modifyHsSpliceData $ recordSpliceResult l (SRExpr serialPat) -+ modifyHsSpliceData $ recordSpliceResult l (SRPat serialPat) - - -- | Record the result (second argument) of evaluating the type splice - -- represented by the first argument. -@@ -774,7 +774,7 @@ addSpliceTypeResult :: LHsExpr GhcTc -> LHsType GhcPs -> TcM () - addSpliceTypeResult th@(L l _) resultE = do - serialTy <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) - =<< tyPS2SE resultE -- modifyHsSpliceData $ recordSpliceResult l (SRExpr serialTy) -+ modifyHsSpliceData $ recordSpliceResult l (SRTy serialTy) - - -- | Look up the result of evaluating the splice represented by the first - -- argument in an .hs-splice file, using the given function to extract -@@ -796,7 +796,7 @@ getSpliceExprResult spliceE = getSpliceResult spliceE $ \res -> case res of - SRDecls _ -> expectedFoundSplice "expression" "declarations" - - -- | Look up the result of evaluating a pattern splice. --getSplicePatResult :: LHsExpr GhcTc -> TcM (LHsPat GhcPs) -+getSplicePatResult :: LHsExpr GhcTc -> TcM (LPat GhcPs) - getSplicePatResult spliceE = getSpliceResult spliceE $ \res -> case res of - SRPat e -> patSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing - SRExpr _ -> expectedFoundSplice "pattern" "expression" -@@ -821,6 +821,7 @@ getSpliceDeclsResult spliceE = getSpliceResult spliceE $ \res -> case res of - (declSE2PS >=> handleUnsupported (fmap ppr spliceE) Nothing) - ds - -+expectedFoundSplice :: String -> String -> a - expectedFoundSplice exp found = - panic ("Expected a " ++ exp ++ " splice result but found: " ++ found) - diff --git a/haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch b/haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch deleted file mode 100644 index dc7106cc3..000000000 --- a/haskell-overlays/splices-load-save/ghc-pattern-splices-1229eee8.patch +++ /dev/null @@ -1,193 +0,0 @@ -diff --git a/compiler/hsSyn/HsExprBin.hs b/compiler/hsSyn/HsExprBin.hs -index 7967f934fb123c9507b5e8cc147868427f483794..eb2eb2766200475a88dee8249b394d1052cc83eb 100644 ---- a/compiler/hsSyn/HsExprBin.hs -+++ b/compiler/hsSyn/HsExprBin.hs -@@ -80,17 +80,22 @@ nonEmptyHsSpliceData = not . Map.null . hsSpliceMap - data SpliceResult - = SRExpr (LHsExpr GhcSe) - | SRDecls [LHsDecl GhcSe] -- TODO: change to HsGroup ? -- -- TODO: add patterns and types? -+ | SRPat (LHsPat GhcSe) -+ | SRTy (LHsType GhcSe) - - instance Binary SpliceResult where - put_ bh r = case r of - SRExpr e -> putByte bh 0 >> put_ bh e - SRDecls ds -> putByte bh 1 >> put_ bh ds -+ SRPat p -> putByte bh 2 >> put_ bh p -+ SRTy t -> putByte bh 3 >> put_ bh t - get bh = do - tag <- getByte bh - case tag of - 0 -> SRExpr <$> get bh - 1 -> SRDecls <$> get bh -+ 2 -> SRPat <$> get bh -+ 3 -> SRTy <$> get bh - _ -> panic "Binary SpliceResult: unknown tag" - - instance Binary HsSpliceData where -@@ -115,6 +120,14 @@ exprSE2PS = runConv . SE2PS.cvLHsExpr - declSE2PS :: LHsDecl GhcSe -> RnM (ConvResult (LHsDecl GhcPs)) - declSE2PS = runConv . SE2PS.cvLHsDecl - -+-- | Convert a serialisable pattern AST to a parsed pattern AST -+patSE2PS :: LHsPat GhcSe -> RnM (ConvResult (LHsPat GhcPs)) -+patSE2PS = runConv . SE2PS.cvLHsPat -+ -+-- | Convert a serialisable type AST to a parsed type ST -+tySE2PS :: LHsType GhcSe -> RnM (ConvResult (LHsType GhcPs)) -+tySE2PS = runConv . SE2PS.cvLHsType -+ - -- Converting Ps -> Se - - -- | Convert a parsed expression AST to a serialisable expression AST -@@ -125,6 +138,14 @@ exprPS2SE = runConv . PS2SE.cvLHsExpr - declPS2SE :: LHsDecl GhcPs -> RnM (ConvResult (LHsDecl GhcSe)) - declPS2SE = runConv . PS2SE.cvLHsDecl - -+-- | Convert a serialisable pattern AST to a parsed pattern AST -+patPS2SE :: LHsPat GhcPs -> RnM (ConvResult (LHsPat GhcSe)) -+patPS2SE = runConv . PS2SE.cvLHsPat -+ -+-- | Convert a serialisable type AST to a parsed type ST -+tyPS2SE :: LHsType GhcPs -> RnM (ConvResult (LHsType GhcSe)) -+tyPS2SE = runConv . PS2SE.cvLHsType -+ - -- * Error reporting - - -- | Panics with a nice error when we encounter an unsupported -diff --git a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -index 839564fbfe21ceabcb180b4b1eb4cd71ac1bf95a..401f431b77c1e409766c70683114ef4f0ef85f34 100644 ---- a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -+++ b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -@@ -488,6 +488,9 @@ cvMatch f (Match a b c d) = Match a - <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d - cvMatch _ (XMatch a) = pure (XMatch a) - -+cvLHsPat :: LHsPat GhcPs -> Conv (LHsPat GhcSe) -+cvLHsPat = traverse cvPat -+ - cvPat :: Pat GhcPs -> Conv (Pat GhcSe) - cvPat (WildPat a) = pure (WildPat a) - cvPat (VarPat a b) = VarPat a <$> convertName b -@@ -704,6 +707,9 @@ cvHsImplicitBndrs - cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b - cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) - -+cvLHsType :: LHsType GhcPs -> Conv (HsType GhcSe) -+cvLHsType = traverse cvType -+ - cvType :: HsType GhcPs -> Conv (HsType GhcSe) - cvType (HsForAllTy a b c) = HsForAllTy a - <$> traverse (traverse cvHsTyVarBndr) b -diff --git a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -index 8fbc941a71339ea1154b8fb1cab4c18c0f094172..cea4c619605cde2a288840c782bba1c3076b8cac 100644 ---- a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -+++ b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -@@ -489,6 +489,9 @@ cvMatch f (Match a b c d) = Match a - <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d - cvMatch _ (XMatch a) = pure (XMatch a) - -+cvLHsPat :: LHsPat GhcSe -> Conv (LHsPat GhcPs) -+cvLHsPat = traverse cvPat -+ - cvPat :: Pat GhcSe -> Conv (Pat GhcPs) - cvPat (WildPat a) = pure (WildPat a) - cvPat (VarPat a b) = VarPat a <$> convertName b -@@ -705,6 +708,9 @@ cvHsImplicitBndrs - cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b - cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) - -+cvLHsType :: LHsType GhcSe -> Conv (LHsType GhcPs) -+cvLHsType = traverse cvType -+ - cvType :: HsType GhcSe -> Conv (HsType GhcPs) - cvType (HsForAllTy a b c) = HsForAllTy a - <$> traverse (traverse cvHsTyVarBndr) b -diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs -index c6dd542937c3b706a39343100ce858571b1b1dd6..be3443cba8737eea6e9c3a25b9b0a86db86dbb87 100644 ---- a/compiler/typecheck/TcSplice.hs -+++ b/compiler/typecheck/TcSplice.hs -@@ -760,6 +760,22 @@ addSpliceDeclsResult th@(L l _) resultDs = do - resultDs - modifyHsSpliceData $ recordSpliceResult l (SRDecls serialDecls) - -+-- | Record the result (second argument) of evaluating the pattern splice -+-- represented by the first argument. -+addSplicePatResult :: LHsExpr GhcTc -> LHsPat GhcPs -> TcM () -+addSplicePatResult th@(L l _) resultE = do -+ serialPat <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) -+ =<< patPS2SE resultE -+ modifyHsSpliceData $ recordSpliceResult l (SRExpr serialPat) -+ -+-- | Record the result (second argument) of evaluating the type splice -+-- represented by the first argument. -+addSpliceTypeResult :: LHsExpr GhcTc -> LHsType GhcPs -> TcM () -+addSpliceTypeResult th@(L l _) resultE = do -+ serialTy <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) -+ =<< tyPS2SE resultE -+ modifyHsSpliceData $ recordSpliceResult l (SRExpr serialTy) -+ - -- | Look up the result of evaluating the splice represented by the first - -- argument in an .hs-splice file, using the given function to extract - -- the result in question (when found). -@@ -775,16 +791,39 @@ getSpliceResult (L l _) f = do - getSpliceExprResult :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs) - getSpliceExprResult spliceE = getSpliceResult spliceE $ \res -> case res of - SRExpr e -> exprSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing -- SRDecls _ -> panic ("Expected an expression splice but found a declaration one") -+ SRPat _ -> expectedFoundSplice "expression" "pattern" -+ SRTy _ -> expectedFoundSplice "expression" "type" -+ SRDecls _ -> expectedFoundSplice "expression" "declarations" -+ -+-- | Look up the result of evaluating a pattern splice. -+getSplicePatResult :: LHsExpr GhcTc -> TcM (LHsPat GhcPs) -+getSplicePatResult spliceE = getSpliceResult spliceE $ \res -> case res of -+ SRPat e -> patSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing -+ SRExpr _ -> expectedFoundSplice "pattern" "expression" -+ SRTy _ -> expectedFoundSplice "pattern" "type" -+ SRDecls _ -> expectedFoundSplice "pattern" "declarations" -+ -+-- | Look up the result of evaluating a type splice. -+getSpliceTypeResult :: LHsExpr GhcTc -> TcM (LHsType GhcPs) -+getSpliceTypeResult spliceE = getSpliceResult spliceE $ \res -> case res of -+ SRTy e -> tySE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing -+ SRExpr _ -> expectedFoundSplice "type" "expression" -+ SRPat _ -> expectedFoundSplice "type" "pattern" -+ SRDecls _ -> expectedFoundSplice "type" "declarations" - - -- | Look up the result of evaluating a declaration splice. - getSpliceDeclsResult :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] - getSpliceDeclsResult spliceE = getSpliceResult spliceE $ \res -> case res of -- SRExpr _ -> panic ("Expected a declaration splice result but found an expression one") -+ SRExpr _ -> expectedFoundSplice "declarations" "expression" -+ SRPat _ -> expectedFoundSplice "declarations" "pattern" -+ SRTy _ -> expectedFoundSplice "delcarations" "type" - SRDecls ds -> traverse - (declSE2PS >=> handleUnsupported (fmap ppr spliceE) Nothing) - ds - -+expectedFoundSplice exp found = -+ panic ("Expected a " ++ exp ++ " splice result but found: " ++ found) -+ - runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper - -> TcM Serialized - runMetaAW = runMeta metaRequestAW -@@ -801,15 +840,11 @@ runMetaE = runMeta metaRequestE getSpliceExprResult addSpliceExprResult - - runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) - -> TcM (LPat GhcPs) --runMetaP = runMeta metaRequestP -- (panic "runMetaP doesn't support splice caching (read)") -- (panic "runMetaP doesn't support splice caching (write)") -+runMetaP = runMeta metaRequestP getSplicePatResult addSplicePatResult - - runMetaT :: LHsExpr GhcTc -- Of type (Q Type) - -> TcM (LHsType GhcPs) --runMetaT = runMeta metaRequestT -- (panic "runMetaT doesn't support splice caching (read)") -- (panic "runMetaT doesn't support splice caching (write)") -+runMetaT = runMeta metaRequestT getSpliceTypeResult addSpliceTypeResult - - runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] - -> TcM [LHsDecl GhcPs] diff --git a/haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch b/haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch deleted file mode 100644 index 2d83b54f9..000000000 --- a/haskell-overlays/splices-load-save/ghc-pattern-splices-33647e08.patch +++ /dev/null @@ -1,26 +0,0 @@ -diff --git a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -index 401f431b77c1e409766c70683114ef4f0ef85f34..7e2b6e957a66afdec89ef5bae525acfe2a834688 100644 ---- a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -+++ b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -@@ -488,7 +488,7 @@ cvMatch f (Match a b c d) = Match a - <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d - cvMatch _ (XMatch a) = pure (XMatch a) - --cvLHsPat :: LHsPat GhcPs -> Conv (LHsPat GhcSe) -+cvLHsPat :: LPat GhcPs -> Conv (LPat GhcSe) - cvLHsPat = traverse cvPat - - cvPat :: Pat GhcPs -> Conv (Pat GhcSe) -diff --git a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -index cea4c619605cde2a288840c782bba1c3076b8cac..cf39727f10224dfd74283d4a6d22fd64005e676b 100644 ---- a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -+++ b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -@@ -489,7 +489,7 @@ cvMatch f (Match a b c d) = Match a - <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d - cvMatch _ (XMatch a) = pure (XMatch a) - --cvLHsPat :: LHsPat GhcSe -> Conv (LHsPat GhcPs) -+cvLHsPat :: LPat GhcSe -> Conv (LPat GhcPs) - cvLHsPat = traverse cvPat - - cvPat :: Pat GhcSe -> Conv (Pat GhcPs) diff --git a/haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch b/haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch deleted file mode 100644 index f6ecb7899..000000000 --- a/haskell-overlays/splices-load-save/ghc-pattern-splices-f1384f4d.patch +++ /dev/null @@ -1,17 +0,0 @@ -diff --git a/compiler/hsSyn/HsExprBin.hs b/compiler/hsSyn/HsExprBin.hs -index eb2eb2766200475a88dee8249b394d1052cc83eb..affecc7e1489a60538f7a9ace3c2c21059170d14 100644 ---- a/compiler/hsSyn/HsExprBin.hs -+++ b/compiler/hsSyn/HsExprBin.hs -@@ -9,8 +9,12 @@ module HsExprBin - , lookupSpliceResult - , exprSE2PS - , declSE2PS -+ , patSE2PS -+ , tySE2PS - , exprPS2SE - , declPS2SE -+ , patPS2SE -+ , tyPS2SE - , handleUnsupported - ) where - diff --git a/haskell-overlays/splices-load-save/ghc.patch b/haskell-overlays/splices-load-save/ghc.patch deleted file mode 100644 index a3078852f..000000000 --- a/haskell-overlays/splices-load-save/ghc.patch +++ /dev/null @@ -1,5548 +0,0 @@ -diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs -index 3dd7e14b12..efcb26d047 100644 ---- a/compiler/basicTypes/DataCon.hs -+++ b/compiler/basicTypes/DataCon.hs -@@ -811,6 +811,7 @@ instance Binary SrcUnpackedness where - 1 -> return SrcUnpack - _ -> return NoSrcUnpack - -+ - -- | Compare strictness annotations - eqHsBang :: HsImplBang -> HsImplBang -> Bool - eqHsBang HsLazy HsLazy = True -diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs -index f6febaf4dc..aed09b6a42 100644 ---- a/compiler/basicTypes/IdInfo.hs -+++ b/compiler/basicTypes/IdInfo.hs -@@ -18,7 +18,7 @@ module IdInfo ( - RecSelParent(..), - - -- * The IdInfo type -- IdInfo, -- Abstract -+ IdInfo, - vanillaIdInfo, noCafIdInfo, - - -- ** The OneShotInfo type -diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot -index cacfe6af2e..229ff9abb0 100644 ---- a/compiler/basicTypes/IdInfo.hs-boot -+++ b/compiler/basicTypes/IdInfo.hs-boot -@@ -1,6 +1,7 @@ - module IdInfo where - import GhcPrelude - import Outputable -+ - data IdInfo - data IdDetails - -@@ -8,4 +9,3 @@ vanillaIdInfo :: IdInfo - coVarDetails :: IdDetails - isCoVarDetails :: IdDetails -> Bool - pprIdDetails :: IdDetails -> SDoc -- -diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs -index 1af53fb3dc..fa54967e8a 100644 ---- a/compiler/basicTypes/OccName.hs -+++ b/compiler/basicTypes/OccName.hs -@@ -394,6 +394,10 @@ instance Uniquable OccName where - newtype OccEnv a = A (UniqFM a) - deriving Data - -+instance Binary a => Binary (OccEnv a) where -+ put_ bh (A a) = put_ bh a -+ get bh = A <$> get bh -+ - emptyOccEnv :: OccEnv a - unitOccEnv :: OccName -> a -> OccEnv a - extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a -diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs -index 2e838d6b82..76b93e4224 100644 ---- a/compiler/basicTypes/PatSyn.hs -+++ b/compiler/basicTypes/PatSyn.hs -@@ -32,6 +32,7 @@ import Outputable - import Unique - import Util - import BasicTypes -+import Binary - import Var - import FieldLabel - -@@ -328,6 +329,10 @@ instance Data.Data PatSyn where - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "PatSyn" - -+instance Binary PatSyn where -+ put = error "Binary PatSyn: not implemented yet" -+ get = error "Binary PatSyn: not implemented yet" -+ - {- - ************************************************************************ - * * -diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs -index 610233ed9a..a4f1a68e65 100644 ---- a/compiler/basicTypes/RdrName.hs -+++ b/compiler/basicTypes/RdrName.hs -@@ -75,6 +75,7 @@ import GhcPrelude - import Module - import Name - import Avail -+import Binary - import NameSet - import Maybes - import SrcLoc -@@ -466,6 +467,10 @@ data GlobalRdrElt - -- INVARIANT: either gre_lcl = True or gre_imp is non-empty - -- See Note [GlobalRdrElt provenance] - -+instance Binary GlobalRdrElt where -+ put_ bh (GRE a b c d) = put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ get bh = GRE <$> get bh <*> get bh <*> get bh <*> get bh -+ - -- | The children of a Name are the things that are abbreviated by the ".." - -- notation in export lists. See Note [Parents] - data Parent = NoParent -@@ -474,6 +479,18 @@ data Parent = NoParent - -- ^ See Note [Parents for record fields] - deriving (Eq, Data) - -+instance Binary Parent where -+ put_ bh p = case p of -+ NoParent -> putByte bh 0 -+ ParentIs p -> putByte bh 1 >> put_ bh p -+ FldParent a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure NoParent -+ 1 -> ParentIs <$> get bh -+ _ -> FldParent <$> get bh <*> get bh -+ - instance Outputable Parent where - ppr NoParent = empty - ppr (ParentIs n) = text "parent:" <> ppr n -@@ -1134,6 +1151,10 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } - deriving( Eq, Ord, Data ) - -+instance Binary ImportSpec where -+ put_ bh (ImpSpec a b) = put_ bh a >> put_ bh b -+ get bh = ImpSpec <$> get bh <*> get bh -+ - -- | Import Declaration Specification - -- - -- Describes a particular import declaration and is -@@ -1151,6 +1172,11 @@ data ImpDeclSpec - is_dloc :: SrcSpan -- ^ The location of the entire import declaration - } deriving Data - -+instance Binary ImpDeclSpec where -+ put_ bh (ImpDeclSpec a b c d) = -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ get bh = ImpDeclSpec <$> get bh <*> get bh <*> get bh <*> get bh -+ - -- | Import Item Specification - -- - -- Describes import info a particular Name -@@ -1172,6 +1198,16 @@ data ImpItemSpec - -- only @T@ is named explicitly. - deriving Data - -+instance Binary ImpItemSpec where -+ put_ bh s = case s of -+ ImpAll -> putByte bh 0 -+ ImpSome a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure ImpAll -+ _ -> ImpSome <$> get bh <*> get bh -+ - instance Eq ImpDeclSpec where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in -index 01628dcad1..3521bdc06c 100644 ---- a/compiler/ghc.cabal.in -+++ b/compiler/ghc.cabal.in -@@ -210,6 +210,7 @@ Library - NameSet - OccName - RdrName -+ SeName - NameCache - SrcLoc - UniqSupply -@@ -318,6 +319,11 @@ Library - HsDecls - HsDoc - HsExpr -+ HsExprBin -+ HsExprBin_ConversionPS2SE -+ HsExprBin_ConversionSE2PS -+ HsExprBin_Conversions -+ HsExprBin_Instances - HsImpExp - HsLit - PlaceHolder -diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs -index 98f503b0d9..9c3665f025 100644 ---- a/compiler/hsSyn/HsBinds.hs -+++ b/compiler/hsSyn/HsBinds.hs -@@ -12,6 +12,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. - {-# LANGUAGE FlexibleContexts #-} - {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -+{-# LANGUAGE TypeFamilies #-} - {-# LANGUAGE ConstraintKinds #-} - {-# LANGUAGE BangPatterns #-} - {-# LANGUAGE TypeFamilies #-} -@@ -322,10 +323,12 @@ data NPatBindTc = NPatBindTc { - type instance XFunBind (GhcPass pL) GhcPs = NoExt - type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables - type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables -+type instance XFunBind (GhcPass pL) GhcSe = NoExt - - type instance XPatBind GhcPs (GhcPass pR) = NoExt - type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables - type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc -+type instance XPatBind GhcSe (GhcPass pR) = NoExt - - type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt - type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt -@@ -382,6 +385,7 @@ data PatSynBind idL idR - type instance XPSB (GhcPass idL) GhcPs = NoExt - type instance XPSB (GhcPass idL) GhcRn = NameSet - type instance XPSB (GhcPass idL) GhcTc = NameSet -+type instance XPSB (GhcPass idL) GhcSe = NoExt - - type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt - -@@ -828,6 +832,7 @@ type instance XIPBinds GhcPs = NoExt - type instance XIPBinds GhcRn = NoExt - type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the - -- implicit parameters -+type instance XIPBinds GhcSe = NoExt - - - type instance XXHsIPBinds (GhcPass p) = NoExt -@@ -948,7 +953,7 @@ data Sig pass - -- the desired Id itself, replete with its name, type - -- and IdDetails. Otherwise it's just like a type - -- signature: there should be an accompanying binding -- | IdSig (XIdSig pass) Id -+ | IdSig (XIdSig pass) (IdSigId pass) - - -- | An ordinary fixity declaration - -- -@@ -1177,7 +1182,9 @@ ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) - ppr_sig (ClassOpSig _ is_deflt vars ty) - | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) - | otherwise = pprVarSig (map unLoc vars) (ppr ty) --ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) -+ppr_sig (IdSig _ id) = case getVarType id of -+ Nothing -> ppr id -+ Just t -> pprVarSig [id] (ppr t) - ppr_sig (FixSig _ fix_sig) = ppr fix_sig - ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) - = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) -diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs -index f84fcfd5ec..db5510c706 100644 ---- a/compiler/hsSyn/HsDecls.hs -+++ b/compiler/hsSyn/HsDecls.hs -@@ -10,6 +10,7 @@ - {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder - {-# LANGUAGE ConstraintKinds #-} -+{-# LANGUAGE FlexibleInstances #-} - {-# LANGUAGE TypeFamilies #-} - - -- | Abstract syntax of global declarations. -@@ -577,14 +578,17 @@ type instance XFamDecl (GhcPass _) = NoExt - type instance XSynDecl GhcPs = NoExt - type instance XSynDecl GhcRn = NameSet -- FVs - type instance XSynDecl GhcTc = NameSet -- FVs -+type instance XSynDecl GhcSe = NoExt - - type instance XDataDecl GhcPs = NoExt - type instance XDataDecl GhcRn = DataDeclRn - type instance XDataDecl GhcTc = DataDeclRn -+type instance XDataDecl GhcSe = NoExt - - type instance XClassDecl GhcPs = NoExt - type instance XClassDecl GhcRn = NameSet -- FVs - type instance XClassDecl GhcTc = NameSet -- FVs -+type instance XClassDecl GhcSe = NoExt - - type instance XXTyClDecl (GhcPass _) = NoExt - -@@ -695,7 +699,6 @@ hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk" - -- ~~~~~~~~~~~~~~~~~~~~~~~~ - - instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where -- - ppr (FamDecl { tcdFam = decl }) = ppr decl - ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity - , tcdRhs = rhs }) -@@ -1868,6 +1871,7 @@ data DerivStrategy pass - type instance XViaStrategy GhcPs = LHsSigType GhcPs - type instance XViaStrategy GhcRn = LHsSigType GhcRn - type instance XViaStrategy GhcTc = Type -+type instance XViaStrategy GhcSe = LHsSigType GhcSe - - instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (DerivStrategy p) where -@@ -1968,10 +1972,12 @@ data ForeignDecl pass - type instance XForeignImport GhcPs = NoExt - type instance XForeignImport GhcRn = NoExt - type instance XForeignImport GhcTc = Coercion -+type instance XForeignImport GhcSe = NoExt - - type instance XForeignExport GhcPs = NoExt - type instance XForeignExport GhcRn = NoExt - type instance XForeignExport GhcTc = Coercion -+type instance XForeignExport GhcSe = NoExt - - type instance XXForeignDecl (GhcPass _) = NoExt - -@@ -2114,6 +2120,7 @@ data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS - type instance XHsRule GhcPs = NoExt - type instance XHsRule GhcRn = HsRuleRn - type instance XHsRule GhcTc = HsRuleRn -+type instance XHsRule GhcSe = NoExt - - type instance XXRuleDecl (GhcPass _) = NoExt - -diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs -index 6ca37e07ce..72042690cd 100644 ---- a/compiler/hsSyn/HsExpr.hs -+++ b/compiler/hsSyn/HsExpr.hs -@@ -10,7 +10,7 @@ - -- in module PlaceHolder - {-# LANGUAGE ConstraintKinds #-} - {-# LANGUAGE ExistentialQuantification #-} --{-# LANGUAGE DeriveFunctor #-} -+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} - {-# LANGUAGE TypeFamilies #-} - - -- | Abstract Haskell syntax for expressions. -@@ -442,11 +442,11 @@ data HsExpr p - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation -- | HsDo (XDo p) -- Type of the whole expression -- (HsStmtContext Name) -- The parameterisation is unimportant -- -- because in this context we never use -- -- the PatGuard or ParStmt variant -- (Located [ExprLStmt p]) -- "do":one or more stmts -+ | HsDo (XDo p) -- Type of the whole expression -+ (HsStmtContext (DoName p)) -- The parameterisation is unimportant -+ -- because in this context we never use -+ -- the PatGuard or ParStmt variant -+ (Located [ExprLStmt p]) -- "do":one or more stmts - - -- | Syntactic list: [a,b,c,...] - -- -@@ -476,7 +476,6 @@ data HsExpr p - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ -- - -- For details on above see note [Api annotations] in ApiAnnotation - | RecordUpd - { rupd_ext :: XRecordUpd p -@@ -719,10 +718,12 @@ type instance XApp (GhcPass _) = NoExt - type instance XAppTypeE GhcPs = LHsWcType GhcPs - type instance XAppTypeE GhcRn = LHsWcType GhcRn - type instance XAppTypeE GhcTc = LHsWcType GhcRn -+type instance XAppTypeE GhcSe = LHsWcType GhcSe - - type instance XOpApp GhcPs = NoExt - type instance XOpApp GhcRn = Fixity - type instance XOpApp GhcTc = Fixity -+type instance XOpApp GhcSe = NoExt - - type instance XNegApp (GhcPass _) = NoExt - type instance XPar (GhcPass _) = NoExt -@@ -733,6 +734,7 @@ type instance XExplicitTuple (GhcPass _) = NoExt - type instance XExplicitSum GhcPs = NoExt - type instance XExplicitSum GhcRn = NoExt - type instance XExplicitSum GhcTc = [Type] -+type instance XExplicitSum GhcSe = NoExt - - type instance XCase (GhcPass _) = NoExt - type instance XIf (GhcPass _) = NoExt -@@ -740,32 +742,39 @@ type instance XIf (GhcPass _) = NoExt - type instance XMultiIf GhcPs = NoExt - type instance XMultiIf GhcRn = NoExt - type instance XMultiIf GhcTc = Type -+type instance XMultiIf GhcSe = NoExt - - type instance XLet (GhcPass _) = NoExt - - type instance XDo GhcPs = NoExt - type instance XDo GhcRn = NoExt - type instance XDo GhcTc = Type -+type instance XDo GhcSe = NoExt - - type instance XExplicitList GhcPs = NoExt - type instance XExplicitList GhcRn = NoExt - type instance XExplicitList GhcTc = Type -+type instance XExplicitList GhcSe = NoExt - - type instance XRecordCon GhcPs = NoExt - type instance XRecordCon GhcRn = NoExt - type instance XRecordCon GhcTc = RecordConTc -+type instance XRecordCon GhcSe = NoExt - - type instance XRecordUpd GhcPs = NoExt - type instance XRecordUpd GhcRn = NoExt - type instance XRecordUpd GhcTc = RecordUpdTc -+type instance XRecordUpd GhcSe = NoExt - - type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs) - type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn) - type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn) -+type instance XExprWithTySig GhcSe = (LHsSigWcType GhcSe) - - type instance XArithSeq GhcPs = NoExt - type instance XArithSeq GhcRn = NoExt - type instance XArithSeq GhcTc = PostTcExpr -+type instance XArithSeq GhcSe = NoExt - - type instance XSCC (GhcPass _) = NoExt - type instance XCoreAnn (GhcPass _) = NoExt -@@ -780,10 +789,12 @@ type instance XProc (GhcPass _) = NoExt - type instance XStatic GhcPs = NoExt - type instance XStatic GhcRn = NameSet - type instance XStatic GhcTc = NameSet -+type instance XStatic GhcSe = NoExt - - type instance XArrApp GhcPs = NoExt - type instance XArrApp GhcRn = NoExt - type instance XArrApp GhcTc = Type -+type instance XArrApp GhcSe = NoExt - - type instance XArrForm (GhcPass _) = NoExt - type instance XTick (GhcPass _) = NoExt -@@ -820,6 +831,7 @@ type instance XPresent (GhcPass _) = NoExt - type instance XMissing GhcPs = NoExt - type instance XMissing GhcRn = NoExt - type instance XMissing GhcTc = Type -+type instance XMissing GhcSe = NoExt - - type instance XXTupArg (GhcPass _) = NoExt - -@@ -1393,6 +1405,7 @@ data HsCmd id - type instance XCmdArrApp GhcPs = NoExt - type instance XCmdArrApp GhcRn = NoExt - type instance XCmdArrApp GhcTc = Type -+type instance XCmdArrApp GhcSe = NoExt - - type instance XCmdArrForm (GhcPass _) = NoExt - type instance XCmdApp (GhcPass _) = NoExt -@@ -1405,6 +1418,7 @@ type instance XCmdLet (GhcPass _) = NoExt - type instance XCmdDo GhcPs = NoExt - type instance XCmdDo GhcRn = NoExt - type instance XCmdDo GhcTc = Type -+type instance XCmdDo GhcSe = NoExt - - type instance XCmdWrap (GhcPass _) = NoExt - type instance XXCmd (GhcPass _) = NoExt -@@ -1436,6 +1450,7 @@ data CmdTopTc - type instance XCmdTop GhcPs = NoExt - type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] - type instance XCmdTop GhcTc = CmdTopTc -+type instance XCmdTop GhcSe = NoExt - - type instance XXCmdTop (GhcPass _) = NoExt - -@@ -1586,6 +1601,7 @@ data MatchGroupTc - type instance XMG GhcPs b = NoExt - type instance XMG GhcRn b = NoExt - type instance XMG GhcTc b = MatchGroupTc -+type instance XMG GhcSe b = NoExt - - type instance XXMatchGroup (GhcPass _) b = NoExt - -@@ -1985,28 +2001,34 @@ type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExt - type instance XBindStmt (GhcPass _) GhcPs b = NoExt - type instance XBindStmt (GhcPass _) GhcRn b = NoExt - type instance XBindStmt (GhcPass _) GhcTc b = Type -+type instance XBindStmt (GhcPass _) GhcSe b = NoExt - - type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExt - type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExt - type instance XApplicativeStmt (GhcPass _) GhcTc b = Type -+type instance XApplicativeStmt (GhcPass _) GhcSe b = NoExt - - type instance XBodyStmt (GhcPass _) GhcPs b = NoExt - type instance XBodyStmt (GhcPass _) GhcRn b = NoExt - type instance XBodyStmt (GhcPass _) GhcTc b = Type -+type instance XBodyStmt (GhcPass _) GhcSe b = NoExt - - type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExt - - type instance XParStmt (GhcPass _) GhcPs b = NoExt - type instance XParStmt (GhcPass _) GhcRn b = NoExt - type instance XParStmt (GhcPass _) GhcTc b = Type -+type instance XParStmt (GhcPass _) GhcSe b = NoExt - - type instance XTransStmt (GhcPass _) GhcPs b = NoExt - type instance XTransStmt (GhcPass _) GhcRn b = NoExt - type instance XTransStmt (GhcPass _) GhcTc b = Type -+type instance XTransStmt (GhcPass _) GhcSe b = NoExt - - type instance XRecStmt (GhcPass _) GhcPs b = NoExt - type instance XRecStmt (GhcPass _) GhcRn b = NoExt - type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc -+type instance XRecStmt (GhcPass _) GhcSe b = NoExt - - type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExt - -@@ -2705,7 +2727,7 @@ data HsMatchContext id -- Not an extensible tag - | ThPatSplice -- ^A Template Haskell pattern splice - | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] - | PatSyn -- ^A pattern synonym declaration -- deriving Functor -+ deriving (Functor, Foldable, Traversable) - deriving instance (Data id) => Data (HsMatchContext id) - - instance OutputableBndr id => Outputable (HsMatchContext id) where -@@ -2722,6 +2744,7 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where - ppr ThPatQuote = text "ThPatQuote" - ppr PatSyn = text "PatSyn" - -+ - isPatSynCtxt :: HsMatchContext id -> Bool - isPatSynCtxt ctxt = - case ctxt of -@@ -2742,7 +2765,7 @@ data HsStmtContext id - | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing - | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt - | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt -- deriving Functor -+ deriving (Functor, Foldable, Traversable) - deriving instance (Data id) => Data (HsStmtContext id) - - isListCompExpr :: HsStmtContext id -> Bool -diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot -index 109e9814e5..4b8c15dfc8 100644 ---- a/compiler/hsSyn/HsExpr.hs-boot -+++ b/compiler/hsSyn/HsExpr.hs-boot -@@ -5,7 +5,7 @@ - {-# LANGUAGE ConstraintKinds #-} - {-# LANGUAGE RoleAnnotations #-} - {-# LANGUAGE ExistentialQuantification #-} --{-# LANGUAGE TypeFamilies #-} -+{-# LANGUAGE TypeFamilies #-} -- needed to use OutputableBndrId - - module HsExpr where - -diff --git a/compiler/hsSyn/HsExprBin.hs b/compiler/hsSyn/HsExprBin.hs -new file mode 100644 -index 0000000000..7967f934fb ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin.hs -@@ -0,0 +1,149 @@ -+module HsExprBin -+ ( getModuleSplicesPath -+ , whenSet -+ , HsSpliceData(..) -+ , nonEmptyHsSpliceData -+ , emptyHsSpliceData -+ , SpliceResult(..) -+ , recordSpliceResult -+ , lookupSpliceResult -+ , exprSE2PS -+ , declSE2PS -+ , exprPS2SE -+ , declPS2SE -+ , handleUnsupported -+ ) where -+ -+import Binary -+import GhcPrelude -+import HsDecls -+import HsExpr -+import HsExprBin_Conversions -+import qualified HsExprBin_ConversionSE2PS as SE2PS -+import qualified HsExprBin_ConversionPS2SE as PS2SE -+import HsExprBin_Instances () -+import HsExtension -+import Module -+import Outputable -+import SrcLoc -+import TcRnTypes -+ -+import qualified Data.Map.Strict as Map -+import System.FilePath -+ -+{- -+ -+Note [Serialisable AST phase] -+ -+There is an AST phase called GhcSe, where 'Se' stands for Serialisable. -+It is quite close to GhcPs, in that it mostly represents ASTs the same way, -+except for (syntax-level) types and names, which are represented in a way -+that is (binary) serialisation friendly. -+ -+The motivation for this new phase is to be able to serialise ASTs of Haskell -+code. (No existing phase has this property.) One use case would be to save -+ASTs resulting from the evaluation of Template Haskell code and to reuse them -+later, in place of evaluating the Template Haskell code. More generally, -+it seems useful to be able to persist or load parsed ASTs, may it be for -+IDE-style interactions or plugins. -+ -+The purpose of the HsExprBin* modules is to define: -+- conversions from GhcSe to GhcPs, and back, with the four functions exported -+ by this module; -+- Binary instances for AST data types, only when "instantiated" at the GhcSe -+ phase. -+ -+The former is done in two modules: HsExprBin_ConversionSE2PS and -+HsExprBin_ConversionPS2SE. The latter in HsExprBin_Instances. -+ -+-} -+ -+-- * .hs-splice file contents -+ -+getModuleSplicesPath :: FilePath -> Module -> FilePath -+getModuleSplicesPath splicesDir m = splicesDir -+ toPath (moduleNameString (moduleName m)) <.> "hs-splice" -+ -+ where toPath = map (\c -> if c == '.' then '/' else c) -+ -+whenSet :: Monad m => Maybe a -> (a -> m b) -> m b -> m b -+whenSet m j n = maybe n j m -+ -+newtype HsSpliceData = HsSpliceData { hsSpliceMap :: Map.Map SrcSpan SpliceResult } -+ -+emptyHsSpliceData :: HsSpliceData -+emptyHsSpliceData = HsSpliceData Map.empty -+ -+nonEmptyHsSpliceData :: HsSpliceData -> Bool -+nonEmptyHsSpliceData = not . Map.null . hsSpliceMap -+ -+data SpliceResult -+ = SRExpr (LHsExpr GhcSe) -+ | SRDecls [LHsDecl GhcSe] -- TODO: change to HsGroup ? -+ -- TODO: add patterns and types? -+ -+instance Binary SpliceResult where -+ put_ bh r = case r of -+ SRExpr e -> putByte bh 0 >> put_ bh e -+ SRDecls ds -> putByte bh 1 >> put_ bh ds -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> SRExpr <$> get bh -+ 1 -> SRDecls <$> get bh -+ _ -> panic "Binary SpliceResult: unknown tag" -+ -+instance Binary HsSpliceData where -+ put_ bh (HsSpliceData m) = put_ bh (Map.toList m) -+ get bh = (\l -> HsSpliceData (Map.fromList l)) <$> get bh -+ -+recordSpliceResult :: SrcSpan -> SpliceResult -> HsSpliceData -> HsSpliceData -+recordSpliceResult loc res (HsSpliceData m) = HsSpliceData (Map.insert loc res m) -+ -+lookupSpliceResult :: SrcSpan -> HsSpliceData -> Maybe SpliceResult -+lookupSpliceResult loc (HsSpliceData m) = Map.lookup loc m -+ -+-- * High-level conversion interface -+ -+-- Converting Se -> Ps -+ -+-- | Convert a serialisable expression AST to a parsed expression AST -+exprSE2PS :: LHsExpr GhcSe -> RnM (ConvResult (LHsExpr GhcPs)) -+exprSE2PS = runConv . SE2PS.cvLHsExpr -+ -+-- | Convert a serialisable declaration AST to a parsed declaration AST -+declSE2PS :: LHsDecl GhcSe -> RnM (ConvResult (LHsDecl GhcPs)) -+declSE2PS = runConv . SE2PS.cvLHsDecl -+ -+-- Converting Ps -> Se -+ -+-- | Convert a parsed expression AST to a serialisable expression AST -+exprPS2SE :: LHsExpr GhcPs -> RnM (ConvResult (LHsExpr GhcSe)) -+exprPS2SE = runConv . PS2SE.cvLHsExpr -+ -+-- | Convert a parsed declaration AST to a serialisable expression AST -+declPS2SE :: LHsDecl GhcPs -> RnM (ConvResult (LHsDecl GhcSe)) -+declPS2SE = runConv . PS2SE.cvLHsDecl -+ -+-- * Error reporting -+ -+-- | Panics with a nice error when we encounter an unsupported -+-- construct, or returns the actual result if the conversion -+-- succeeded. -+handleUnsupported -+ :: Located SDoc -- ^ TH expression that got evaluated -+ -> Maybe SDoc -- ^ code resulting from the evaluation of the 1st arg -+ -> ConvResult a -- ^ result of the conversion -+ -> RnM a -+handleUnsupported (L loc thDoc) resDoc convRes = case convRes of -+ ConvOK a -> pure a -+ ConvError (ConvUnsupported conName tyName subexprDoc) -> -+ pprPanic "HsExprBin.handleUnsupported" . vcat $ -+ [ text "GHC encountered a Haskell construct not supported by -{load, save}-splices:" -+ , nest 4 $ subexprDoc <> text (" - constructor " ++ conName ++ " of type " ++ tyName) -+ , text "while evaluating the following expression from " <> ppr loc <> text ":" -+ , nest 4 $ thDoc -+ ] ++ -+ maybe [] (\d -> [text "which resulted in:" , nest 4 d]) resDoc -+ -+ ConvError (ConvFailure errorStr) -> panic errorStr -diff --git a/compiler/hsSyn/HsExprBin.hs-boot b/compiler/hsSyn/HsExprBin.hs-boot -new file mode 100644 -index 0000000000..964847e097 ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin.hs-boot -@@ -0,0 +1,4 @@ -+module HsExprBin where -+ -+data HsSpliceData -+emptyHsSpliceData :: HsSpliceData -\ No newline at end of file -diff --git a/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -new file mode 100644 -index 0000000000..839564fbfe ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin_ConversionPS2SE.hs -@@ -0,0 +1,812 @@ -+{-# LANGUAGE GADTs #-} -+module HsExprBin_ConversionPS2SE where -+ -+import Control.Applicative -+import Data.Traversable -+ -+import Bag (mapBagM) -+import Class -+import CoreSyn ( Tickish(..) ) -+import GhcPrelude -+import HsBinds -+import HsDecls -+import HsExpr -+import HsExprBin_Conversions -+import HsExtension -+import HsLit -+import HsPat -+import HsTypes -+ -+-- * Conversion from serialisable ASTs to parsed ASTs -+ -+cvLHsDecl :: LHsDecl GhcPs -> Conv (LHsDecl GhcSe) -+cvLHsDecl = traverse cvHsDecl -+ -+cvHsDecl :: HsDecl GhcPs -> Conv (HsDecl GhcSe) -+cvHsDecl (TyClD a b) = TyClD <$> pure a <*> cvTyClDecl b -+cvHsDecl (InstD a b) = InstD <$> pure a <*> cvInstDecl b -+cvHsDecl (DerivD a b) = DerivD <$> pure a <*> cvDerivDecl b -+cvHsDecl (ValD a b) = ValD <$> pure a <*> cvHsBindLR b -+cvHsDecl (SigD a b) = SigD <$> pure a <*> cvSig b -+cvHsDecl (DefD a b) = DefD <$> pure a <*> cvDefaultDecl b -+cvHsDecl (ForD a b) = ForD <$> pure a <*> cvForeignDecl b -+cvHsDecl (WarningD a b) = WarningD <$> pure a <*> cvWarningDecls b -+cvHsDecl (RoleAnnotD a b) = RoleAnnotD <$> pure a <*> cvRoleAnnotDecl b -+cvHsDecl (AnnD a b) = AnnD <$> pure a <*> cvAnnDecl b -+cvHsDecl (RuleD a b) = RuleD <$> pure a <*> cvRuleDecls b -+cvHsDecl (SpliceD a b) = SpliceD <$> pure a <*> cvSpliceDecl b -+cvHsDecl (DocD a b) = pure (DocD a b) -+cvHsDecl (XHsDecl a) = pure (XHsDecl a) -+ -+cvAnnDecl :: AnnDecl GhcPs -> Conv (AnnDecl GhcSe) -+cvAnnDecl (HsAnnotation a b c d) = -+ HsAnnotation a b <$> cvAnnProvenance c <*> cvLHsExpr d -+cvAnnDecl (XAnnDecl a) = pure (XAnnDecl a) -+ -+cvInstDecl :: InstDecl GhcPs -> Conv (InstDecl GhcSe) -+cvInstDecl (ClsInstD a b) = ClsInstD a <$> cvClsInstDecl b -+cvInstDecl (DataFamInstD a b) = DataFamInstD a <$> cvDataFamInstDecl b -+cvInstDecl (TyFamInstD a b) = TyFamInstD a <$> cvTyFamInstDecl b -+cvInstDecl (XInstDecl a) = pure (XInstDecl a) -+ -+cvClsInstDecl :: ClsInstDecl GhcPs -> Conv (ClsInstDecl GhcSe) -+cvClsInstDecl (ClsInstDecl a b c d e f g) = -+ ClsInstDecl a -+ <$> cvHsImplicitBndrs (traverse cvType) b -+ <*> mapBagM (traverse cvHsBindLR) c -+ <*> traverse (traverse cvSig) d -+ <*> traverse (traverse cvTyFamInstDecl) e -+ <*> traverse (traverse cvDataFamInstDecl) f -+ <*> pure g -+cvClsInstDecl (XClsInstDecl a) = pure (XClsInstDecl a) -+ -+cvDerivDecl :: DerivDecl GhcPs -> Conv (DerivDecl GhcSe) -+cvDerivDecl (DerivDecl a b c d) = -+ DerivDecl a <$> cvHsWildCardBndrs (cvHsImplicitBndrs $ traverse cvType) b -+ <*> traverse (traverse cvDerivStrategy) c -+ <*> pure d -+cvDerivDecl (XDerivDecl a) = pure (XDerivDecl a) -+ -+cvDerivStrategy -+ :: DerivStrategy GhcPs -> Conv (DerivStrategy GhcSe) -+cvDerivStrategy StockStrategy = pure StockStrategy -+cvDerivStrategy AnyclassStrategy = pure AnyclassStrategy -+cvDerivStrategy NewtypeStrategy = pure NewtypeStrategy -+cvDerivStrategy (ViaStrategy a) = ViaStrategy -+ <$> cvHsImplicitBndrs (traverse cvType) a -+ -+cvTyClDecl :: TyClDecl GhcPs -> Conv (TyClDecl GhcSe) -+cvTyClDecl (FamDecl a b) = FamDecl <$> pure a <*> cvFamilyDecl b -+cvTyClDecl (SynDecl a b c d e) = -+ SynDecl a -+ <$> convertName b -+ <*> cvLHsQTyVars c <*> pure d -+ <*> traverse cvType e -+cvTyClDecl (DataDecl a b c d e) = -+ DataDecl a -+ <$> convertName b -+ <*> cvLHsQTyVars c <*> pure d -+ <*> cvHsDataDefn e -+cvTyClDecl (ClassDecl a b c d e f g h i j k) = -+ ClassDecl a -+ <$> traverse (traverse (traverse cvType)) b -+ <*> convertName c -+ <*> cvLHsQTyVars d -+ <*> pure e -+ <*> traverse (traverse cvFunDep) f -+ <*> traverse (traverse cvSig) g -+ <*> mapBagM (traverse cvHsBindLR) h -+ <*> traverse (traverse cvFamilyDecl) i -+ <*> traverse (traverse $ cvFamEqn cvLHsQTyVars (traverse cvType)) j -+ <*> pure k -+cvTyClDecl (XTyClDecl a) = pure (XTyClDecl a) -+ -+cvRoleAnnotDecl :: RoleAnnotDecl GhcPs -> Conv (RoleAnnotDecl GhcSe) -+cvRoleAnnotDecl (RoleAnnotDecl a b c) = -+ RoleAnnotDecl a <$> convertName b <*> pure c -+cvRoleAnnotDecl (XRoleAnnotDecl a) = pure (XRoleAnnotDecl a) -+ -+cvRuleDecls :: RuleDecls GhcPs -> Conv (RuleDecls GhcSe) -+cvRuleDecls (HsRules a b c) = HsRules a b <$> traverse (traverse cvRuleDecl) c -+cvRuleDecls (XRuleDecls a) = pure (XRuleDecls a) -+ -+cvRuleDecl :: RuleDecl GhcPs -> Conv (RuleDecl GhcSe) -+cvRuleDecl (HsRule a b c d e f) = -+ HsRule a b c <$> traverse (traverse cvRuleBndr) d -+ <*> cvLHsExpr e <*> cvLHsExpr f -+cvRuleDecl (XRuleDecl a) = pure (XRuleDecl a) -+ -+cvSpliceDecl :: SpliceDecl GhcPs -> Conv (SpliceDecl GhcSe) -+cvSpliceDecl (SpliceDecl a b c) = -+ SpliceDecl a <$> traverse cvHsSplice b <*> pure c -+cvSpliceDecl (XSpliceDecl a) = pure (XSpliceDecl a) -+ -+cvHsSplice :: HsSplice GhcPs -> Conv (HsSplice GhcSe) -+cvHsSplice (HsTypedSplice a b c d) = -+ HsTypedSplice a b <$> convertName c <*> cvLHsExpr d -+cvHsSplice (HsUntypedSplice a b c d) = -+ HsUntypedSplice a b <$> convertName c <*> cvLHsExpr d -+cvHsSplice (HsQuasiQuote a b c d e) = -+ HsQuasiQuote a <$> convertName b <*> convertName c <*> pure d <*> pure e -+cvHsSplice (HsSpliced {}) = -+ unsupported "HsSpliced" "HsSplice" (error "") -+cvHsSplice (XSplice a) = pure (XSplice a) -+ -+cvRuleBndr :: RuleBndr GhcPs -> Conv (RuleBndr GhcSe) -+cvRuleBndr (RuleBndr a b) = RuleBndr a <$> convertName b -+cvRuleBndr (RuleBndrSig a b c) = -+ RuleBndrSig a <$> convertName b <*> cvHsSigWcType c -+cvRuleBndr (XRuleBndr a) = pure (XRuleBndr a) -+ -+cvFamEqn -+ :: ( XCFamEqn GhcPs a b ~ XCFamEqn GhcSe c d -+ , XXFamEqn GhcPs a b ~ XXFamEqn GhcSe c d -+ ) -+ => (a -> Conv c) -+ -> (b -> Conv d) -+ -> FamEqn GhcPs a b -+ -> Conv (FamEqn GhcSe c d) -+cvFamEqn goPats goRhs (FamEqn a b c d e) = -+ FamEqn a <$> convertName b <*> goPats c <*> pure d <*> goRhs e -+cvFamEqn _ _ (XFamEqn a) = pure (XFamEqn a) -+ -+cvFamilyDecl :: FamilyDecl GhcPs -> Conv (FamilyDecl GhcSe) -+cvFamilyDecl (FamilyDecl a b c d e f g) = -+ FamilyDecl a -+ <$> cvFamilyInfo b <*> convertName c -+ <*> cvLHsQTyVars d <*> pure e -+ <*> traverse cvFamilyResultSig f -+ <*> traverse (traverse cvInjectivityAnn) g -+cvFamilyDecl (XFamilyDecl a) = pure (XFamilyDecl a) -+ -+cvAnnProvenance :: ConvertName a b => AnnProvenance a -> Conv (AnnProvenance b) -+cvAnnProvenance (ValueAnnProvenance a) = ValueAnnProvenance <$> convertName a -+cvAnnProvenance (TypeAnnProvenance a) = TypeAnnProvenance <$> convertName a -+cvAnnProvenance ModuleAnnProvenance = pure ModuleAnnProvenance -+ -+cvInjectivityAnn -+ :: InjectivityAnn GhcPs -> Conv (InjectivityAnn GhcSe) -+cvInjectivityAnn (InjectivityAnn a b) = -+ InjectivityAnn <$> convertName a <*> convertName b -+ -+cvFamilyResultSig -+ :: FamilyResultSig GhcPs -> Conv (FamilyResultSig GhcSe) -+cvFamilyResultSig (NoSig a) = pure (NoSig a) -+cvFamilyResultSig (KindSig a b) = KindSig a <$> traverse cvType b -+cvFamilyResultSig (TyVarSig a b) = TyVarSig a <$> traverse cvHsTyVarBndr b -+cvFamilyResultSig (XFamilyResultSig a) = pure (XFamilyResultSig a) -+ -+cvFamilyInfo -+ :: FamilyInfo GhcPs -> Conv (FamilyInfo GhcSe) -+cvFamilyInfo DataFamily = pure DataFamily -+cvFamilyInfo OpenTypeFamily = pure OpenTypeFamily -+cvFamilyInfo (ClosedTypeFamily a) = -+ ClosedTypeFamily <$> traverse (traverse (traverse (cvFamInstEqn (traverse cvType)))) a -+ -+cvFamInstEqn -+ :: ( XCFamEqn GhcPs (HsTyPats GhcPs) a -+ ~ XCFamEqn GhcSe (HsTyPats GhcSe) b -+ , XHsIB GhcPs (FamEqn GhcPs (HsTyPats p) a) -+ ~ XHsIB GhcSe (FamEqn GhcSe (HsTyPats GhcSe) b) -+ , XXFamEqn GhcPs (HsTyPats GhcPs) a -+ ~ XXFamEqn GhcSe (HsTyPats GhcSe) b -+ , XXHsImplicitBndrs GhcPs (FamEqn GhcPs (HsTyPats GhcPs) a) -+ ~ XXHsImplicitBndrs GhcSe (FamEqn GhcSe (HsTyPats GhcSe) b) -+ ) -+ => (a -> Conv b) -+ -> FamInstEqn GhcPs a -+ -> Conv (FamInstEqn GhcSe b) -+cvFamInstEqn f = cvHsImplicitBndrs (cvFamEqn (traverse (traverse cvType)) f) -+ -+cvFunDep :: ConvertName a b => FunDep a -> Conv (FunDep b) -+cvFunDep (xs, ys) = (,) <$> convertName xs <*> convertName ys -+ -+cvLHsQTyVars :: LHsQTyVars GhcPs -> Conv (LHsQTyVars GhcSe) -+cvLHsQTyVars (HsQTvs a b) = HsQTvs a <$> traverse (traverse cvHsTyVarBndr) b -+cvLHsQTyVars (XLHsQTyVars a) = pure (XLHsQTyVars a) -+ -+cvForeignDecl :: ForeignDecl GhcPs -> Conv (ForeignDecl GhcSe) -+cvForeignDecl (ForeignImport a b c d) = -+ ForeignImport a -+ <$> convertName b -+ <*> cvHsImplicitBndrs (traverse cvType) c -+ <*> pure d -+cvForeignDecl (ForeignExport a b c d) = -+ ForeignExport a -+ <$> convertName b -+ <*> cvHsImplicitBndrs (traverse cvType) c -+ <*> pure d -+cvForeignDecl (XForeignDecl a) = pure (XForeignDecl a) -+ -+cvDefaultDecl :: DefaultDecl GhcPs -> Conv (DefaultDecl GhcSe) -+cvDefaultDecl (DefaultDecl a b) = DefaultDecl a <$> traverse (traverse cvType) b -+cvDefaultDecl (XDefaultDecl a) = pure (XDefaultDecl a) -+ -+cvTyFamInstDecl -+ :: TyFamInstDecl GhcPs -> Conv (TyFamInstDecl GhcSe) -+cvTyFamInstDecl (TyFamInstDecl d) = -+ TyFamInstDecl <$> cvFamInstEqn (traverse cvType) d -+ -+cvDataFamInstDecl -+ :: DataFamInstDecl GhcPs -> Conv (DataFamInstDecl GhcSe) -+cvDataFamInstDecl (DataFamInstDecl d) = -+ DataFamInstDecl <$> cvFamInstEqn cvHsDataDefn d -+ -+cvHsDataDefn :: HsDataDefn GhcPs -> Conv (HsDataDefn GhcSe) -+cvHsDataDefn (HsDataDefn a b c d e f g) = -+ HsDataDefn a b -+ <$> traverse (traverse (traverse cvType)) c <*> pure d -+ <*> traverse (traverse cvType) e -+ <*> traverse (traverse cvConDecl) f <*> cvHsDeriving g -+cvHsDataDefn (XHsDataDefn a) = pure (XHsDataDefn a) -+ -+cvConDecl :: ConDecl GhcPs -> Conv (ConDecl GhcSe) -+cvConDecl (ConDeclGADT a b c d e f g h) = -+ ConDeclGADT a -+ <$> convertName b -+ <*> pure c -+ <*> cvLHsQTyVars d -+ <*> traverse (traverse (traverse (traverse cvType))) e -+ <*> cvHsConDeclDetails f -+ <*> traverse cvType g -+ <*> pure h -+cvConDecl (ConDeclH98 a b c d e f g) = -+ ConDeclH98 a -+ <$> convertName b -+ <*> pure c -+ <*> traverse (traverse cvHsTyVarBndr) d -+ <*> traverse (traverse (traverse (traverse cvType))) e -+ <*> cvHsConDeclDetails f -+ <*> pure g -+cvConDecl (XConDecl a) = pure (XConDecl a) -+ -+cvHsDeriving :: HsDeriving GhcPs -> Conv (HsDeriving GhcSe) -+cvHsDeriving = traverse (traverse (traverse cvHsDerivingClause)) -+ -+cvHsDerivingClause -+ :: HsDerivingClause GhcPs -> Conv (HsDerivingClause GhcSe) -+cvHsDerivingClause (HsDerivingClause a b c) = -+ HsDerivingClause a -+ <$> traverse (traverse cvDerivStrategy) b -+ <*> traverse (traverse (cvHsImplicitBndrs (traverse cvType))) c -+cvHsDerivingClause (XHsDerivingClause a) = pure (XHsDerivingClause a) -+ -+cvHsConDeclDetails -+ :: HsConDeclDetails GhcPs -> Conv (HsConDeclDetails GhcSe) -+cvHsConDeclDetails = -+ cvHsConDetails (traverse cvType) -+ (traverse (traverse (traverse cvConDeclField))) -+ -+cvHsConDetails -+ :: (a -> Conv c) -> (b -> Conv d) -> HsConDetails a b -> Conv (HsConDetails c d) -+cvHsConDetails f _ (PrefixCon a) = PrefixCon <$> traverse f a -+cvHsConDetails _ g (RecCon a) = RecCon <$> g a -+cvHsConDetails f _ (InfixCon a b) = InfixCon <$> f a <*> f b -+ -+cvConDeclField :: ConDeclField GhcPs -> Conv (ConDeclField GhcSe) -+cvConDeclField (ConDeclField a b c d) = -+ ConDeclField a <$> traverse (traverse cvFieldOcc) b <*> traverse cvType c -+ <*> pure d -+cvConDeclField (XConDeclField a) = pure (XConDeclField a) -+ -+cvWarningDecls :: WarnDecls GhcPs -> Conv (WarnDecls GhcSe) -+cvWarningDecls (Warnings a b c) = -+ Warnings a b <$> traverse (traverse cvWarningDecl) c -+cvWarningDecls (XWarnDecls a) = pure (XWarnDecls a) -+ -+cvWarningDecl :: WarnDecl GhcPs -> Conv (WarnDecl GhcSe) -+cvWarningDecl (Warning a b c) = Warning a <$> convertName b <*> pure c -+cvWarningDecl (XWarnDecl a) = pure (XWarnDecl a) -+ -+-- expressions -+ -+cvLHsExpr :: LHsExpr GhcPs -> Conv (LHsExpr GhcSe) -+cvLHsExpr = traverse cvHsExpr -+ -+cvHsExpr :: HsExpr GhcPs -> Conv (HsExpr GhcSe) -+cvHsExpr e = case e of -+ HsVar a b -> HsVar a <$> convertName b -+ HsUnboundVar a b -> pure (HsUnboundVar a b) -+ HsConLikeOut a b -> pure (HsConLikeOut a b) -+ HsRecFld a b -> HsRecFld a <$> cvAFieldOcc b -+ HsOverLabel a b c -> HsOverLabel a <$> convertName b <*> pure c -+ HsIPVar a b -> pure (HsIPVar a b) -+ HsOverLit a b -> HsOverLit a <$> cvOverLit b -+ HsLit a b -> HsLit a <$> cvLit b -+ HsLam a b -> HsLam a <$> cvMatchGroup cvLHsExpr b -+ HsLamCase a b -> HsLamCase a <$> cvMatchGroup cvLHsExpr b -+ HsApp a b c -> HsApp a <$> cvLHsExpr b <*> cvLHsExpr c -+ HsAppType a b -> HsAppType <$> cvLHsWcType a <*> cvLHsExpr b -+ OpApp a b c d -> OpApp a <$> cvLHsExpr b <*> cvLHsExpr c <*> cvLHsExpr d -+ NegApp a b c -> NegApp a <$> cvLHsExpr b <*> cvSyntaxExpr c -+ HsPar a b -> HsPar a <$> cvLHsExpr b -+ SectionL a b c -> SectionL a <$> cvLHsExpr b <*> cvLHsExpr c -+ SectionR a b c -> SectionR a <$> cvLHsExpr b <*> cvLHsExpr c -+ ExplicitTuple a b c -> ExplicitTuple a <$> traverse (traverse cvHsTupArg) b -+ <*> pure c -+ ExplicitSum a b c d -> ExplicitSum a b c <$> cvLHsExpr d -+ ExplicitList a b c -> ExplicitList a <$> traverse cvSyntaxExpr b <*> traverse cvLHsExpr c -+ HsCase a b c -> HsCase a <$> cvLHsExpr b <*> cvMatchGroup cvLHsExpr c -+ HsIf a b c d e -> HsIf a <$> traverse cvSyntaxExpr b -+ <*> cvLHsExpr c <*> cvLHsExpr d <*> cvLHsExpr e -+ HsMultiIf a b -> HsMultiIf a <$> traverse (traverse (cvGRHS cvLHsExpr)) b -+ HsLet a b c -> HsLet a <$> traverse cvHsLocalBinds b <*> cvLHsExpr c -+ HsDo a b c -> HsDo a -+ <$> convertName b <*> traverse (traverse (traverse (cvStmtLR cvLHsExpr))) c -+ RecordCon a b c -> RecordCon a <$> convertName b <*> cvRecordBinds c -+ RecordUpd a b c -> RecordUpd a <$> cvLHsExpr b -+ <*> traverse (traverse cvHsRecUpdField) c -+ ExprWithTySig a b -> ExprWithTySig <$> cvHsSigWcType a <*> cvLHsExpr b -+ ArithSeq a b c -> ArithSeq a <$> traverse cvSyntaxExpr b <*> cvArithSeqInfo c -+ HsSCC a b c d -> HsSCC a b c <$> cvLHsExpr d -+ HsCoreAnn a b c d -> HsCoreAnn a b c <$> cvLHsExpr d -+ HsStatic a b -> HsStatic a <$> cvLHsExpr b -+ EWildPat a -> pure (EWildPat a) -+ EAsPat a b c -> EAsPat a <$> convertName b <*> cvLHsExpr c -+ EViewPat a b c -> EViewPat a <$> cvLHsExpr b <*> cvLHsExpr c -+ ELazyPat a b -> ELazyPat a <$> cvLHsExpr b -+ HsProc a b c -> HsProc a <$> traverse cvPat b <*> traverse cvHsCmdTop c -+ HsBinTick a b c d -> HsBinTick a b c <$> cvLHsExpr d -+ HsTickPragma a b c d e -> HsTickPragma a b c d <$> cvLHsExpr e -+ HsSpliceE a b -> HsSpliceE a <$> cvHsSplice b -+ HsBracket a b -> HsBracket a <$> cvHsBracket b -+ HsTick a b c -> HsTick a <$> cvTickish b <*> cvLHsExpr c -+ XExpr a -> pure (XExpr a) -+ HsArrApp {} -> unsupported "HsArrApp" "HsExpr" (error "") -+ HsArrForm {} -> unsupported "HsArrForm" "HsExpr" (error "") -+ HsWrap {} -> unsupported "HsWrap" "HsExpr" (error "") -+ HsRnBracketOut {} -> unsupported "HsRnBracketOut" "HsExpr" (error "") -+ HsTcBracketOut {} -> unsupported "HsTcBracketOut" "HsExpr" (error "") -+ -+cvHsBracket :: HsBracket GhcPs -> Conv (HsBracket GhcSe) -+cvHsBracket (ExpBr a b) = ExpBr a <$> cvLHsExpr b -+cvHsBracket (PatBr a b) = PatBr a <$> traverse cvPat b -+cvHsBracket (DecBrL a b) = DecBrL a <$> traverse (traverse cvHsDecl) b -+cvHsBracket (DecBrG a b) = DecBrG a <$> cvHsGroup b -+cvHsBracket (TypBr a b) = TypBr a <$> traverse cvType b -+cvHsBracket (VarBr a b c) = VarBr a b <$> convertName c -+cvHsBracket (TExpBr a b) = TExpBr a <$> cvLHsExpr b -+cvHsBracket (XBracket a) = pure (XBracket a) -+ -+cvTickish :: ConvertName a b => Tickish a -> Conv (Tickish b) -+cvTickish (ProfNote a b c) = pure (ProfNote a b c) -+cvTickish (HpcTick a b) = pure (HpcTick a b) -+cvTickish (Breakpoint a b) = Breakpoint a <$> convertName b -+cvTickish (SourceNote a b) = pure (SourceNote a b) -+ -+cvHsGroup :: HsGroup GhcPs -> Conv (HsGroup GhcSe) -+cvHsGroup (HsGroup a b c d e f g h i j k l) = HsGroup a -+ <$> cvHsValBindsLR b <*> traverse (traverse cvSpliceDecl) c -+ <*> traverse cvTyClGroup d -+ <*> traverse (traverse cvDerivDecl) e -+ <*> traverse (traverse cvFixitySig) f -+ <*> traverse (traverse cvDefaultDecl) g -+ <*> traverse (traverse cvForeignDecl) h -+ <*> traverse (traverse cvWarningDecls) i -+ <*> traverse (traverse cvAnnDecl) j -+ <*> traverse (traverse cvRuleDecls) k -+ <*> pure l -+cvHsGroup (XHsGroup a) = pure (XHsGroup a) -+ -+cvTyClGroup :: TyClGroup GhcPs -> Conv (TyClGroup GhcSe) -+cvTyClGroup (TyClGroup a b c d) = TyClGroup a -+ <$> traverse (traverse cvTyClDecl) b -+ <*> traverse (traverse cvRoleAnnotDecl) c -+ <*> traverse (traverse cvInstDecl) d -+cvTyClGroup (XTyClGroup a) = pure (XTyClGroup a) -+ -+cvHsCmdTop :: HsCmdTop GhcPs -> Conv (HsCmdTop GhcSe) -+cvHsCmdTop (HsCmdTop a b) = HsCmdTop a <$> traverse cvHsCmd b -+cvHsCmdTop (XCmdTop a) = pure (XCmdTop a) -+ -+cvHsCmd :: HsCmd GhcPs -> Conv (HsCmd GhcSe) -+cvHsCmd (HsCmdArrApp a b c d e) = HsCmdArrApp a -+ <$> cvLHsExpr b <*> cvLHsExpr c <*> pure d <*> pure e -+cvHsCmd (HsCmdArrForm a b c d e) = HsCmdArrForm a -+ <$> cvLHsExpr b <*> pure c <*> pure d -+ <*> traverse (traverse cvHsCmdTop) e -+cvHsCmd (HsCmdApp a b c) = HsCmdApp a <$> traverse cvHsCmd b <*> cvLHsExpr c -+cvHsCmd (HsCmdLam a b) = HsCmdLam a <$> cvMatchGroup (traverse cvHsCmd) b -+cvHsCmd (HsCmdPar a b) = HsCmdPar a <$> traverse cvHsCmd b -+cvHsCmd (HsCmdCase a b c) = HsCmdCase a -+ <$> cvLHsExpr b <*> cvMatchGroup (traverse cvHsCmd) c -+cvHsCmd (HsCmdIf a b c d e) = HsCmdIf a -+ <$> traverse cvSyntaxExpr b -+ <*> cvLHsExpr c -+ <*> traverse cvHsCmd d -+ <*> traverse cvHsCmd e -+cvHsCmd (HsCmdLet a b c) = HsCmdLet a -+ <$> traverse cvHsLocalBinds b <*> traverse cvHsCmd c -+cvHsCmd (HsCmdDo a b) = HsCmdDo a -+ <$> traverse (traverse (traverse (cvStmtLR (traverse cvHsCmd)))) b -+cvHsCmd (HsCmdWrap {}) = unsupported "HsCmdWrap" "HsCmd" (error "") -+cvHsCmd (XCmd a) = pure (XCmd a) -+ -+cvArithSeqInfo :: ArithSeqInfo GhcPs -> Conv (ArithSeqInfo GhcSe) -+cvArithSeqInfo (From e) = From <$> cvLHsExpr e -+cvArithSeqInfo (FromThen a b) = FromThen <$> cvLHsExpr a <*> cvLHsExpr b -+cvArithSeqInfo (FromTo a b) = FromTo <$> cvLHsExpr a <*> cvLHsExpr b -+cvArithSeqInfo (FromThenTo a b c) = FromThenTo <$> cvLHsExpr a <*> cvLHsExpr b <*> cvLHsExpr c -+ -+cvHsTupArg :: HsTupArg GhcPs -> Conv (HsTupArg GhcSe) -+cvHsTupArg (Present a b) = Present a <$> cvLHsExpr b -+cvHsTupArg (Missing a) = pure (Missing a) -+cvHsTupArg (XTupArg a) = pure (XTupArg a) -+ -+cvAFieldOcc -+ :: AmbiguousFieldOcc GhcPs -> Conv (AmbiguousFieldOcc GhcSe) -+cvAFieldOcc (Unambiguous a b) = Unambiguous a <$> convertName b -+cvAFieldOcc (Ambiguous a b) = Ambiguous a <$> convertName b -+cvAFieldOcc (XAmbiguousFieldOcc a) = pure (XAmbiguousFieldOcc a) -+ -+cvOverLit :: HsOverLit GhcPs -> Conv (HsOverLit GhcSe) -+cvOverLit (OverLit a b c) = OverLit a b <$> cvHsExpr c -+cvOverLit (XOverLit a) = pure (XOverLit a) -+ -+cvLit :: HsLit GhcPs -> Conv (HsLit GhcSe) -+cvLit (HsChar a b) = pure (HsChar a b) -+cvLit (HsCharPrim a b) = pure (HsCharPrim a b) -+cvLit (HsString a b) = pure (HsString a b) -+cvLit (HsStringPrim a b) = pure (HsStringPrim a b) -+cvLit (HsInt a b) = pure (HsInt a b) -+cvLit (HsIntPrim a b) = pure (HsIntPrim a b) -+cvLit (HsWordPrim a b) = pure (HsWordPrim a b) -+cvLit (HsInt64Prim a b) = pure (HsInt64Prim a b) -+cvLit (HsWord64Prim a b) = pure (HsWord64Prim a b) -+cvLit (HsInteger a b c) = HsInteger a b <$> convertType c -+cvLit (HsRat a b c) = HsRat a b <$> convertType c -+cvLit (HsFloatPrim a b) = pure (HsFloatPrim a b) -+cvLit (HsDoublePrim a b) = pure (HsDoublePrim a b) -+cvLit (XLit a) = pure (XLit a) -+ -+cvMatchGroup -+ :: ( XMG GhcPs a ~ XMG GhcSe b -+ , XCMatch GhcPs a ~ XCMatch GhcSe b -+ , XCGRHSs GhcPs a ~ XCGRHSs GhcSe b -+ , XCGRHS GhcPs a ~ XCGRHS GhcSe b -+ , XXMatchGroup GhcPs a ~ XXMatchGroup GhcSe b -+ , XXMatch GhcPs a ~ XXMatch GhcSe b -+ , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b -+ , XXGRHS GhcPs a ~ XXGRHS GhcSe b -+ ) -+ => (a -> Conv b) -> MatchGroup GhcPs a -> Conv (MatchGroup GhcSe b) -+cvMatchGroup f (MG a b c) = MG a -+ <$> traverse (traverse (traverse (cvMatch f))) b -+ <*> pure c -+cvMatchGroup _ (XMatchGroup a) = pure (XMatchGroup a) -+ -+cvMatch -+ :: ( XCMatch GhcPs a ~ XCMatch GhcSe b -+ , XCGRHSs GhcPs a ~ XCGRHSs GhcSe b -+ , XCGRHS GhcPs a ~ XCGRHS GhcSe b -+ , XXMatch GhcPs a ~ XXMatch GhcSe b -+ , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b -+ , XXGRHS GhcPs a ~ XXGRHS GhcSe b -+ ) -+ => (a -> Conv b) -> Match GhcPs a -> Conv (Match GhcSe b) -+cvMatch f (Match a b c d) = Match a -+ <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d -+cvMatch _ (XMatch a) = pure (XMatch a) -+ -+cvPat :: Pat GhcPs -> Conv (Pat GhcSe) -+cvPat (WildPat a) = pure (WildPat a) -+cvPat (VarPat a b) = VarPat a <$> convertName b -+cvPat (LazyPat a b) = LazyPat a <$> traverse cvPat b -+cvPat (AsPat a b c) = AsPat a <$> convertName b <*> traverse cvPat c -+cvPat (ParPat a b) = ParPat a <$> traverse cvPat b -+cvPat (BangPat a b) = BangPat a <$> traverse cvPat b -+cvPat (ListPat a b) = ListPat a -+ <$> traverse (traverse cvPat) b -+cvPat (TuplePat a b c) = TuplePat a -+ <$> traverse (traverse cvPat) b -+ <*> pure c -+cvPat (SumPat a b c d) = SumPat a -+ <$> traverse cvPat b -+ <*> pure c <*> pure d -+cvPat (ConPatIn a b) = ConPatIn <$> convertName a <*> cvHsConPatDetails b -+cvPat (ViewPat a b c) = ViewPat a <$> cvLHsExpr b <*> traverse cvPat c -+cvPat (LitPat a b) = LitPat a <$> cvLit b -+cvPat (NPat a b c d) = NPat a -+ <$> traverse cvOverLit b <*> traverse cvSyntaxExpr c -+ <*> cvSyntaxExpr d -+cvPat (NPlusKPat a b c d e f) = NPlusKPat a -+ <$> convertName b -+ <*> traverse cvOverLit c <*> cvOverLit d -+ <*> cvSyntaxExpr e <*> cvSyntaxExpr f -+cvPat (SigPat a b) = SigPat <$> cvHsSigWcType a <*> traverse cvPat b -+cvPat (SplicePat a b) = SplicePat a <$> cvHsSplice b -+cvPat (CoPat {}) = unsupported "CoPat" "Pat" (error "") -+cvPat (ConPatOut {}) = unsupported "ConPatOut" "Pat" (error "") -+cvPat (XPat a) = pure (XPat a) -+ -+cvGRHSs -+ :: ( XCGRHSs GhcPs a ~ XCGRHSs GhcSe b -+ , XCGRHS GhcPs a ~ XCGRHS GhcSe b -+ , XXGRHSs GhcPs a ~ XXGRHSs GhcSe b -+ , XXGRHS GhcPs a ~ XXGRHS GhcSe b -+ ) -+ => (a -> Conv b) -> GRHSs GhcPs a -> Conv (GRHSs GhcSe b) -+cvGRHSs f (GRHSs a b c) = GRHSs a -+ <$> traverse (traverse (cvGRHS f)) b -+ <*> traverse cvHsLocalBinds c -+cvGRHSs _ (XGRHSs a) = pure (XGRHSs a) -+ -+cvGRHS -+ :: ( XCGRHS GhcPs a ~ XCGRHS GhcSe b -+ , XXGRHS GhcPs a ~ XXGRHS GhcSe b -+ ) -+ => (a -> Conv b) -> GRHS GhcPs a -> Conv (GRHS GhcSe b) -+cvGRHS f (GRHS a b c) = GRHS a -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> f c -+cvGRHS _ (XGRHS a) = pure (XGRHS a) -+ -+cvHsLocalBinds -+ :: HsLocalBinds GhcPs -> Conv (HsLocalBinds GhcSe) -+cvHsLocalBinds (HsValBinds a b) = HsValBinds a <$> cvHsValBindsLR b -+cvHsLocalBinds (HsIPBinds a b) = HsIPBinds a <$> cvHsIPBinds b -+cvHsLocalBinds (EmptyLocalBinds a) = pure (EmptyLocalBinds a) -+cvHsLocalBinds (XHsLocalBindsLR a) = pure (XHsLocalBindsLR a) -+ -+cvHsValBindsLR -+ :: HsValBindsLR GhcPs GhcPs -> Conv (HsValBindsLR GhcSe GhcSe) -+cvHsValBindsLR (ValBinds a b c) = ValBinds a -+ <$> mapBagM (traverse cvHsBindLR) b -+ <*> traverse (traverse cvSig) c -+cvHsValBindsLR (XValBindsLR _) = -+ unsupported "XValBindsLR" "HsValBindsLR" (error "") -+ -+cvHsConPatDetails -+ :: HsConPatDetails GhcPs -> Conv (HsConPatDetails GhcSe) -+cvHsConPatDetails (PrefixCon a) = PrefixCon <$> traverse (traverse cvPat) a -+cvHsConPatDetails (RecCon a) = RecCon <$> cvHsRecFieldsPat a -+cvHsConPatDetails (InfixCon a b) = InfixCon -+ <$> traverse cvPat a <*> traverse cvPat b -+ -+cvHsRecFields -+ :: (thing -> Conv thing') -+ -> HsRecFields GhcPs thing -+ -> Conv (HsRecFields GhcSe thing') -+cvHsRecFields f (HsRecFields a b) = -+ HsRecFields <$> traverse (traverse (cvHsRecField' cvFieldOcc f)) a <*> pure b -+ -+cvHsRecField' -+ :: (id -> Conv id') -+ -> (thing -> Conv thing') -+ -> HsRecField' id thing -+ -> Conv (HsRecField' id' thing') -+cvHsRecField' f g (HsRecField a b c) = -+ HsRecField <$> traverse f a <*> g b <*> pure c -+ -+cvHsRecFieldsPat -+ :: HsRecFields GhcPs (LPat GhcPs) -> Conv (HsRecFields GhcSe (LPat GhcSe)) -+cvHsRecFieldsPat = cvHsRecFields (traverse cvPat) -+ -+cvHsRecUpdField -+ :: HsRecUpdField GhcPs -> Conv (HsRecUpdField GhcSe) -+cvHsRecUpdField = cvHsRecField' cvAFieldOcc cvLHsExpr -+ -+cvRecordBinds -+ :: HsRecordBinds GhcPs -> Conv (HsRecordBinds GhcSe) -+cvRecordBinds = cvHsRecFields cvLHsExpr -+ -+cvFieldOcc :: FieldOcc GhcPs -> Conv (FieldOcc GhcSe) -+cvFieldOcc (FieldOcc a b) = FieldOcc a <$> convertName b -+cvFieldOcc (XFieldOcc a) = pure (XFieldOcc a) -+ -+cvStmtLR -+ :: ( XLastStmt GhcPs GhcPs a ~ XLastStmt GhcSe GhcSe b -+ , XBindStmt GhcPs GhcPs a ~ XBindStmt GhcSe GhcSe b -+ , XBodyStmt GhcPs GhcPs a ~ XBodyStmt GhcSe GhcSe b -+ , XApplicativeStmt GhcPs GhcPs a ~ XApplicativeStmt GhcSe GhcSe b -+ , XLetStmt GhcPs GhcPs a ~ XLetStmt GhcSe GhcSe b -+ , XRecStmt GhcPs GhcPs a ~ XRecStmt GhcSe GhcSe b -+ , XParStmt GhcPs GhcPs a ~ XParStmt GhcSe GhcSe b -+ , XTransStmt GhcPs GhcPs a ~ XTransStmt GhcSe GhcSe b -+ , XXStmtLR GhcPs GhcPs a ~ XXStmtLR GhcSe GhcSe b -+ ) -+ => (a -> Conv b) -> StmtLR GhcPs GhcPs a -> Conv (StmtLR GhcSe GhcSe b) -+cvStmtLR k (LastStmt a b c d) = LastStmt a -+ <$> k b <*> pure c <*> cvSyntaxExpr d -+cvStmtLR k (BindStmt a b c d e) = BindStmt a -+ <$> traverse cvPat b <*> k c -+ <*> cvSyntaxExpr d <*> cvSyntaxExpr e -+cvStmtLR k (BodyStmt a b c d) = BodyStmt a -+ <$> k b <*> cvSyntaxExpr c -+ <*> cvSyntaxExpr d -+cvStmtLR _ (ApplicativeStmt a b c) = ApplicativeStmt a -+ <$> traverse -+ (\(se, aa) -> (,) <$> cvSyntaxExpr se <*> cvApplicativeArg aa) -+ b -+ <*> traverse cvSyntaxExpr c -+cvStmtLR _ (LetStmt a b) = LetStmt a <$> traverse cvHsLocalBinds b -+cvStmtLR k (RecStmt a b c d e f g) = RecStmt a -+ <$> traverse (traverse (cvStmtLR k)) b -+ <*> convertName c -+ <*> convertName d -+ <*> cvSyntaxExpr e -+ <*> cvSyntaxExpr f -+ <*> cvSyntaxExpr g -+cvStmtLR _ (ParStmt a b c d) = ParStmt a -+ <$> traverse cvParStmtBlock b -+ <*> cvHsExpr c -+ <*> cvSyntaxExpr d -+cvStmtLR _ (TransStmt a b c d e f g h i) = TransStmt a b -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) c -+ <*> traverse (\(x, y) -> (,) <$> convertName x <*> convertName y) d -+ <*> cvLHsExpr e -+ <*> traverse cvLHsExpr f -+ <*> cvSyntaxExpr g -+ <*> cvSyntaxExpr h -+ <*> cvHsExpr i -+cvStmtLR _ (XStmtLR a) = pure (XStmtLR a) -+ -+cvParStmtBlock -+ :: ParStmtBlock GhcPs GhcPs -> Conv (ParStmtBlock GhcSe GhcSe) -+cvParStmtBlock (ParStmtBlock a b c d) = ParStmtBlock a -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b -+ <*> convertName c -+ <*> cvSyntaxExpr d -+cvParStmtBlock (XParStmtBlock a) = pure (XParStmtBlock a) -+ -+cvSyntaxExpr :: SyntaxExpr GhcPs -> Conv (SyntaxExpr GhcSe) -+cvSyntaxExpr (SyntaxExpr a b c) = -+ SyntaxExpr <$> cvHsExpr a <*> pure b <*> pure c -+ -+cvHsIPBinds -+ :: HsIPBinds GhcPs -> Conv (HsIPBinds GhcSe) -+cvHsIPBinds (IPBinds a b) = IPBinds a <$> traverse (traverse cvIPBind) b -+cvHsIPBinds (XHsIPBinds a) = pure (XHsIPBinds a) -+ -+cvIPBind :: IPBind GhcPs -> Conv (IPBind GhcSe) -+cvIPBind (IPBind a b c) = IPBind a <$> convertName b <*> cvLHsExpr c -+cvIPBind (XIPBind a) = pure (XIPBind a) -+ -+cvHsBindLR -+ :: HsBindLR GhcPs GhcPs -> Conv (HsBindLR GhcSe GhcSe) -+cvHsBindLR (FunBind a b c d e) = FunBind a -+ <$> convertName b -+ <*> cvMatchGroup cvLHsExpr c -+ <*> pure d <*> pure e -+cvHsBindLR (PatBind a b c d ) = PatBind a -+ <$> traverse cvPat b <*> cvGRHSs cvLHsExpr c <*> pure d -+cvHsBindLR (VarBind a b c d) = VarBind a -+ <$> convertName b <*> cvLHsExpr c <*> pure d -+cvHsBindLR (PatSynBind a b) = PatSynBind a <$> cvPatSynBind b -+cvHsBindLR (AbsBinds {}) = -+ unsupported "AbsBind" "HsBindLR" (error "") -+cvHsBindLR (XHsBindsLR a) = pure (XHsBindsLR a) -+ -+cvHsWildCardBndrs -+ :: ( XHsWC GhcPs thing ~ XHsWC GhcSe thing' -+ , XXHsWildCardBndrs GhcPs thing ~ XXHsWildCardBndrs GhcSe thing' -+ ) -+ => (thing -> Conv thing') -+ -> HsWildCardBndrs GhcPs thing -+ -> Conv (HsWildCardBndrs GhcSe thing') -+cvHsWildCardBndrs thingF (HsWC a b) = HsWC a <$> thingF b -+cvHsWildCardBndrs _ (XHsWildCardBndrs a) = pure (XHsWildCardBndrs a) -+ -+cvLHsWcType -+ :: LHsWcType GhcPs -> Conv (LHsWcType GhcSe) -+cvLHsWcType = cvHsWildCardBndrs (traverse cvType) -+ -+cvHsSigWcType -+ :: LHsSigWcType GhcPs -> Conv (LHsSigWcType GhcSe) -+cvHsSigWcType = cvHsWildCardBndrs (cvHsImplicitBndrs (traverse cvType)) -+ -+cvHsImplicitBndrs -+ :: ( XHsIB GhcPs thing ~ XHsIB GhcSe thing' -+ , XXHsImplicitBndrs GhcPs thing ~ XXHsImplicitBndrs GhcSe thing' -+ ) -+ => (thing -> Conv thing') -+ -> HsImplicitBndrs GhcPs thing -+ -> Conv (HsImplicitBndrs GhcSe thing') -+cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b -+cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) -+ -+cvType :: HsType GhcPs -> Conv (HsType GhcSe) -+cvType (HsForAllTy a b c) = HsForAllTy a -+ <$> traverse (traverse cvHsTyVarBndr) b -+ <*> traverse cvType c -+cvType (HsQualTy a b c) = HsQualTy a -+ <$> traverse (traverse (traverse cvType)) b -+ <*> traverse cvType c -+cvType (HsTyVar a b c) = HsTyVar a b <$> convertName c -+cvType (HsAppTy a b c) = HsAppTy a -+ <$> traverse cvType b -+ <*> traverse cvType c -+cvType (HsFunTy a b c) = HsFunTy a -+ <$> traverse cvType b -+ <*> traverse cvType c -+cvType (HsListTy a b) = HsListTy a <$> traverse cvType b -+cvType (HsTupleTy a b c) = HsTupleTy a b <$> traverse (traverse cvType) c -+cvType (HsSumTy a b) = HsSumTy a <$> traverse (traverse cvType) b -+cvType (HsOpTy a b c d) = HsOpTy a -+ <$> traverse cvType b -+ <*> convertName c -+ <*> traverse cvType d -+cvType (HsParTy a b) = HsParTy a <$> traverse cvType b -+cvType (HsIParamTy a b c) = HsIParamTy a b <$> traverse cvType c -+cvType (HsKindSig a b c) = HsKindSig a -+ <$> traverse cvType b -+ <*> traverse cvType c -+cvType (HsBangTy a b c) = HsBangTy a b <$> traverse cvType c -+cvType (HsRecTy a b) = HsRecTy a <$> traverse (traverse cvConDeclField) b -+cvType (HsExplicitListTy a b c) = HsExplicitListTy a b -+ <$> traverse (traverse cvType) c -+cvType (HsExplicitTupleTy a b) = HsExplicitTupleTy a -+ <$> traverse (traverse cvType) b -+cvType (HsTyLit a b) = pure (HsTyLit a b) -+cvType (HsWildCardTy a) = pure (HsWildCardTy a) -+cvType (HsDocTy a b c) = HsDocTy a <$> traverse cvType b <*> pure c -+cvType (HsSpliceTy a b) = HsSpliceTy a <$> cvHsSplice b -+cvType (HsStarTy a b) = pure (HsStarTy a b) -+cvType (XHsType a) = pure (XHsType a) -+ -+cvHsTyVarBndr -+ :: HsTyVarBndr GhcPs -> Conv (HsTyVarBndr GhcSe) -+cvHsTyVarBndr (UserTyVar a b) = UserTyVar a <$> convertName b -+cvHsTyVarBndr (KindedTyVar a b c) = KindedTyVar a -+ <$> convertName b -+ <*> traverse cvType c -+cvHsTyVarBndr (XTyVarBndr a) = pure (XTyVarBndr a) -+ -+cvApplicativeArg -+ :: ApplicativeArg GhcPs -> Conv (ApplicativeArg GhcSe) -+cvApplicativeArg (ApplicativeArgOne a b c d) = ApplicativeArgOne a -+ <$> traverse cvPat b <*> cvLHsExpr c <*> pure d -+cvApplicativeArg (ApplicativeArgMany a b c d) = ApplicativeArgMany a -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> cvHsExpr c -+ <*> traverse cvPat d -+cvApplicativeArg (XApplicativeArg a) = pure (XApplicativeArg a) -+ -+cvSig :: Sig GhcPs -> Conv (Sig GhcSe) -+cvSig (TypeSig a b c) = TypeSig a <$> convertName b <*> cvHsSigWcType c -+cvSig (PatSynSig a b c) = PatSynSig a -+ <$> convertName b <*> cvHsImplicitBndrs (traverse cvType) c -+cvSig (ClassOpSig a b c d) = ClassOpSig a b -+ <$> convertName c <*> cvHsImplicitBndrs (traverse cvType) d -+cvSig (InlineSig a b c) = InlineSig a <$> convertName b <*> pure c -+cvSig (FixSig a b) = FixSig a <$> cvFixitySig b -+cvSig (SpecSig a b c d) = SpecSig a -+ <$> convertName b -+ <*> traverse (cvHsImplicitBndrs (traverse cvType)) c -+ <*> pure d -+cvSig (SpecInstSig a b c) = SpecInstSig a b -+ <$> cvHsImplicitBndrs (traverse cvType) c -+cvSig (SCCFunSig a b c d) = SCCFunSig a b <$> convertName c <*> pure d -+cvSig (CompleteMatchSig a b c d) = CompleteMatchSig a b -+ <$> convertName c <*> convertName d -+cvSig (MinimalSig a b c) = MinimalSig a b <$> traverse (traverse convertName) c -+cvSig (IdSig {}) = unsupported "IdSig" "Sig" (error "") -+cvSig (XSig a) = pure (XSig a) -+ -+cvFixitySig :: FixitySig GhcPs -> Conv (FixitySig GhcSe) -+cvFixitySig (FixitySig a b c) = FixitySig a <$> convertName b <*> pure c -+cvFixitySig (XFixitySig a) = pure (XFixitySig a) -+ -+cvPatSynBind :: PatSynBind GhcPs GhcPs -> Conv (PatSynBind GhcSe GhcSe) -+cvPatSynBind (PSB a b c d e) = PSB a -+ <$> convertName b -+ <*> cvHsPatSynDetails convertName c <*> traverse cvPat d -+ <*> cvHsPatSynDir e -+cvPatSynBind (XPatSynBind a) = pure (XPatSynBind a) -+ -+cvHsPatSynDetails -+ :: (a -> Conv b) -+ -> HsPatSynDetails a -+ -> Conv (HsPatSynDetails b) -+cvHsPatSynDetails f = cvHsConDetails f (traverse (cvRecordPatSynField f)) -+ -+cvRecordPatSynField -+ :: (a -> Conv b) -+ -> RecordPatSynField a -+ -> Conv (RecordPatSynField b) -+cvRecordPatSynField f (RecordPatSynField a b) = -+ RecordPatSynField <$> f a <*> f b -+ -+cvHsPatSynDir :: HsPatSynDir GhcPs -> Conv (HsPatSynDir GhcSe) -+cvHsPatSynDir Unidirectional = pure Unidirectional -+cvHsPatSynDir ImplicitBidirectional = pure ImplicitBidirectional -+cvHsPatSynDir (ExplicitBidirectional a) = ExplicitBidirectional -+ <$> cvMatchGroup cvLHsExpr a -diff --git a/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -new file mode 100644 -index 0000000000..8fbc941a71 ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin_ConversionSE2PS.hs -@@ -0,0 +1,813 @@ -+{-# LANGUAGE GADTs #-} -+module HsExprBin_ConversionSE2PS where -+ -+import Control.Applicative -+import Data.Traversable -+ -+import Bag (mapBagM) -+import Class -+import CoreSyn ( Tickish(..) ) -+import GhcPrelude -+import HsBinds -+import HsDecls -+import HsExpr -+import HsExprBin_Conversions -+import HsExtension -+import HsLit -+import HsPat -+import HsTypes -+ -+-- * Conversion from serialisable ASTs to parsed ASTs -+ -+cvLHsDecl :: LHsDecl GhcSe -> Conv (LHsDecl GhcPs) -+cvLHsDecl = traverse cvHsDecl -+ -+cvHsDecl :: HsDecl GhcSe -> Conv (HsDecl GhcPs) -+cvHsDecl (TyClD a b) = TyClD <$> pure a <*> cvTyClDecl b -+cvHsDecl (InstD a b) = InstD <$> pure a <*> cvInstDecl b -+cvHsDecl (DerivD a b) = DerivD <$> pure a <*> cvDerivDecl b -+cvHsDecl (ValD a b) = ValD <$> pure a <*> cvHsBindLR b -+cvHsDecl (SigD a b) = SigD <$> pure a <*> cvSig b -+cvHsDecl (DefD a b) = DefD <$> pure a <*> cvDefaultDecl b -+cvHsDecl (ForD a b) = ForD <$> pure a <*> cvForeignDecl b -+cvHsDecl (WarningD a b) = WarningD <$> pure a <*> cvWarningDecls b -+cvHsDecl (RoleAnnotD a b) = RoleAnnotD <$> pure a <*> cvRoleAnnotDecl b -+cvHsDecl (AnnD a b) = AnnD <$> pure a <*> cvAnnDecl b -+cvHsDecl (RuleD a b) = RuleD <$> pure a <*> cvRuleDecls b -+cvHsDecl (SpliceD a b) = SpliceD <$> pure a <*> cvSpliceDecl b -+cvHsDecl (DocD a b) = pure (DocD a b) -+cvHsDecl (XHsDecl a) = pure (XHsDecl a) -+ -+cvAnnDecl :: AnnDecl GhcSe -> Conv (AnnDecl GhcPs) -+cvAnnDecl (HsAnnotation a b c d) = -+ HsAnnotation a b <$> cvAnnProvenance c <*> cvLHsExpr d -+cvAnnDecl (XAnnDecl a) = pure (XAnnDecl a) -+ -+cvInstDecl :: InstDecl GhcSe -> Conv (InstDecl GhcPs) -+cvInstDecl (ClsInstD a b) = ClsInstD a <$> cvClsInstDecl b -+cvInstDecl (DataFamInstD a b) = DataFamInstD a <$> cvDataFamInstDecl b -+cvInstDecl (TyFamInstD a b) = TyFamInstD a <$> cvTyFamInstDecl b -+cvInstDecl (XInstDecl a) = pure (XInstDecl a) -+ -+cvClsInstDecl :: ClsInstDecl GhcSe -> Conv (ClsInstDecl GhcPs) -+cvClsInstDecl (ClsInstDecl a b c d e f g) = -+ ClsInstDecl a -+ <$> cvHsImplicitBndrs (traverse cvType) b -+ <*> mapBagM (traverse cvHsBindLR) c -+ <*> traverse (traverse cvSig) d -+ <*> traverse (traverse cvTyFamInstDecl) e -+ <*> traverse (traverse cvDataFamInstDecl) f -+ <*> pure g -+cvClsInstDecl (XClsInstDecl a) = pure (XClsInstDecl a) -+ -+cvDerivDecl :: DerivDecl GhcSe -> Conv (DerivDecl GhcPs) -+cvDerivDecl (DerivDecl a b c d) = -+ DerivDecl a <$> cvHsWildCardBndrs (cvHsImplicitBndrs $ traverse cvType) b -+ <*> traverse (traverse cvDerivStrategy) c -+ <*> pure d -+cvDerivDecl (XDerivDecl a) = pure (XDerivDecl a) -+ -+cvDerivStrategy -+ :: DerivStrategy GhcSe -> Conv (DerivStrategy GhcPs) -+cvDerivStrategy StockStrategy = pure StockStrategy -+cvDerivStrategy AnyclassStrategy = pure AnyclassStrategy -+cvDerivStrategy NewtypeStrategy = pure NewtypeStrategy -+cvDerivStrategy (ViaStrategy a) = ViaStrategy -+ <$> cvHsImplicitBndrs (traverse cvType) a -+ -+cvTyClDecl :: TyClDecl GhcSe -> Conv (TyClDecl GhcPs) -+cvTyClDecl (FamDecl a b) = FamDecl <$> pure a <*> cvFamilyDecl b -+cvTyClDecl (SynDecl a b c d e) = -+ SynDecl a -+ <$> convertName b -+ <*> cvLHsQTyVars c <*> pure d -+ <*> traverse cvType e -+cvTyClDecl (DataDecl a b c d e) = -+ DataDecl a -+ <$> convertName b -+ <*> cvLHsQTyVars c <*> pure d -+ <*> cvHsDataDefn e -+cvTyClDecl (ClassDecl a b c d e f g h i j k) = -+ ClassDecl a -+ <$> traverse (traverse (traverse cvType)) b -+ <*> convertName c -+ <*> cvLHsQTyVars d -+ <*> pure e -+ <*> traverse (traverse cvFunDep) f -+ <*> traverse (traverse cvSig) g -+ <*> mapBagM (traverse cvHsBindLR) h -+ <*> traverse (traverse cvFamilyDecl) i -+ <*> traverse (traverse $ cvFamEqn cvLHsQTyVars (traverse cvType)) j -+ <*> pure k -+cvTyClDecl (XTyClDecl a) = pure (XTyClDecl a) -+ -+cvRoleAnnotDecl :: RoleAnnotDecl GhcSe -> Conv (RoleAnnotDecl GhcPs) -+cvRoleAnnotDecl (RoleAnnotDecl a b c) = -+ RoleAnnotDecl a <$> convertName b <*> pure c -+cvRoleAnnotDecl (XRoleAnnotDecl a) = pure (XRoleAnnotDecl a) -+ -+cvRuleDecls :: RuleDecls GhcSe -> Conv (RuleDecls GhcPs) -+cvRuleDecls (HsRules a b c) = HsRules a b <$> traverse (traverse cvRuleDecl) c -+cvRuleDecls (XRuleDecls a) = pure (XRuleDecls a) -+ -+cvRuleDecl :: RuleDecl GhcSe -> Conv (RuleDecl GhcPs) -+cvRuleDecl (HsRule a b c d e f) = -+ HsRule a b c <$> traverse (traverse cvRuleBndr) d -+ <*> cvLHsExpr e <*> cvLHsExpr f -+cvRuleDecl (XRuleDecl a) = pure (XRuleDecl a) -+ -+cvSpliceDecl :: SpliceDecl GhcSe -> Conv (SpliceDecl GhcPs) -+cvSpliceDecl (SpliceDecl a b c) = -+ SpliceDecl a <$> traverse cvHsSplice b <*> pure c -+cvSpliceDecl (XSpliceDecl a) = pure (XSpliceDecl a) -+ -+cvHsSplice :: HsSplice GhcSe -> Conv (HsSplice GhcPs) -+cvHsSplice (HsTypedSplice a b c d) = -+ HsTypedSplice a b <$> convertName c <*> cvLHsExpr d -+cvHsSplice (HsUntypedSplice a b c d) = -+ HsUntypedSplice a b <$> convertName c <*> cvLHsExpr d -+cvHsSplice (HsQuasiQuote a b c d e) = -+ HsQuasiQuote a <$> convertName b <*> convertName c <*> pure d <*> pure e -+cvHsSplice (HsSpliced {}) = -+ unsupported "HsSpliced" "HsSplice" (error "") -+cvHsSplice (XSplice a) = pure (XSplice a) -+ -+cvRuleBndr :: RuleBndr GhcSe -> Conv (RuleBndr GhcPs) -+cvRuleBndr (RuleBndr a b) = RuleBndr a <$> convertName b -+cvRuleBndr (RuleBndrSig a b c) = -+ RuleBndrSig a <$> convertName b <*> cvHsSigWcType c -+cvRuleBndr (XRuleBndr a) = pure (XRuleBndr a) -+ -+cvFamEqn -+ :: ( XCFamEqn GhcSe a b ~ XCFamEqn GhcPs c d -+ , XXFamEqn GhcSe a b ~ XXFamEqn GhcPs c d -+ ) -+ => (a -> Conv c) -+ -> (b -> Conv d) -+ -> FamEqn GhcSe a b -+ -> Conv (FamEqn GhcPs c d) -+cvFamEqn goPats goRhs (FamEqn a b c d e) = -+ FamEqn a <$> convertName b <*> goPats c <*> pure d <*> goRhs e -+cvFamEqn _ _ (XFamEqn a) = pure (XFamEqn a) -+ -+cvFamilyDecl :: FamilyDecl GhcSe -> Conv (FamilyDecl GhcPs) -+cvFamilyDecl (FamilyDecl a b c d e f g) = -+ FamilyDecl a -+ <$> cvFamilyInfo b <*> convertName c -+ <*> cvLHsQTyVars d <*> pure e -+ <*> traverse cvFamilyResultSig f -+ <*> traverse (traverse cvInjectivityAnn) g -+cvFamilyDecl (XFamilyDecl a) = pure (XFamilyDecl a) -+ -+cvAnnProvenance :: ConvertName a b => AnnProvenance a -> Conv (AnnProvenance b) -+cvAnnProvenance (ValueAnnProvenance a) = ValueAnnProvenance <$> convertName a -+cvAnnProvenance (TypeAnnProvenance a) = TypeAnnProvenance <$> convertName a -+cvAnnProvenance ModuleAnnProvenance = pure ModuleAnnProvenance -+ -+cvInjectivityAnn -+ :: InjectivityAnn GhcSe -> Conv (InjectivityAnn GhcPs) -+cvInjectivityAnn (InjectivityAnn a b) = -+ InjectivityAnn <$> convertName a <*> convertName b -+ -+cvFamilyResultSig -+ :: FamilyResultSig GhcSe -> Conv (FamilyResultSig GhcPs) -+cvFamilyResultSig (NoSig a) = pure (NoSig a) -+cvFamilyResultSig (KindSig a b) = KindSig a <$> traverse cvType b -+cvFamilyResultSig (TyVarSig a b) = TyVarSig a <$> traverse cvHsTyVarBndr b -+cvFamilyResultSig (XFamilyResultSig a) = pure (XFamilyResultSig a) -+ -+cvFamilyInfo -+ :: FamilyInfo GhcSe -> Conv (FamilyInfo GhcPs) -+cvFamilyInfo DataFamily = pure DataFamily -+cvFamilyInfo OpenTypeFamily = pure OpenTypeFamily -+cvFamilyInfo (ClosedTypeFamily a) = -+ ClosedTypeFamily <$> traverse (traverse (traverse (cvFamInstEqn (traverse cvType)))) a -+ -+cvFamInstEqn -+ :: ( XCFamEqn GhcSe (HsTyPats GhcSe) a -+ ~ XCFamEqn GhcPs (HsTyPats GhcPs) b -+ , XHsIB GhcSe (FamEqn GhcSe (HsTyPats p) a) -+ ~ XHsIB GhcPs (FamEqn GhcPs (HsTyPats GhcPs) b) -+ , XXFamEqn GhcSe (HsTyPats GhcSe) a -+ ~ XXFamEqn GhcPs (HsTyPats GhcPs) b -+ , XXHsImplicitBndrs GhcSe (FamEqn GhcSe (HsTyPats GhcSe) a) -+ ~ XXHsImplicitBndrs GhcPs (FamEqn GhcPs (HsTyPats GhcPs) b) -+ ) -+ => (a -> Conv b) -+ -> FamInstEqn GhcSe a -+ -> Conv (FamInstEqn GhcPs b) -+cvFamInstEqn f = cvHsImplicitBndrs (cvFamEqn (traverse (traverse cvType)) f) -+ -+cvFunDep :: ConvertName a b => FunDep a -> Conv (FunDep b) -+cvFunDep (xs, ys) = (,) <$> convertName xs <*> convertName ys -+ -+cvLHsQTyVars :: LHsQTyVars GhcSe -> Conv (LHsQTyVars GhcPs) -+cvLHsQTyVars (HsQTvs a b) = HsQTvs a <$> traverse (traverse cvHsTyVarBndr) b -+cvLHsQTyVars (XLHsQTyVars a) = pure (XLHsQTyVars a) -+ -+cvForeignDecl :: ForeignDecl GhcSe -> Conv (ForeignDecl GhcPs) -+cvForeignDecl (ForeignImport a b c d) = -+ ForeignImport a -+ <$> convertName b -+ <*> cvHsImplicitBndrs (traverse cvType) c -+ <*> pure d -+cvForeignDecl (ForeignExport a b c d) = -+ ForeignExport a -+ <$> convertName b -+ <*> cvHsImplicitBndrs (traverse cvType) c -+ <*> pure d -+cvForeignDecl (XForeignDecl a) = pure (XForeignDecl a) -+ -+cvDefaultDecl :: DefaultDecl GhcSe -> Conv (DefaultDecl GhcPs) -+cvDefaultDecl (DefaultDecl a b) = DefaultDecl a <$> traverse (traverse cvType) b -+cvDefaultDecl (XDefaultDecl a) = pure (XDefaultDecl a) -+ -+cvTyFamInstDecl -+ :: TyFamInstDecl GhcSe -> Conv (TyFamInstDecl GhcPs) -+cvTyFamInstDecl (TyFamInstDecl d) = -+ TyFamInstDecl <$> cvFamInstEqn (traverse cvType) d -+ -+cvDataFamInstDecl -+ :: DataFamInstDecl GhcSe -> Conv (DataFamInstDecl GhcPs) -+cvDataFamInstDecl (DataFamInstDecl d) = -+ DataFamInstDecl <$> cvFamInstEqn cvHsDataDefn d -+ -+cvHsDataDefn :: HsDataDefn GhcSe -> Conv (HsDataDefn GhcPs) -+cvHsDataDefn (HsDataDefn a b c d e f g) = -+ HsDataDefn a b -+ <$> traverse (traverse (traverse cvType)) c <*> pure d -+ <*> traverse (traverse cvType) e -+ <*> traverse (traverse cvConDecl) f <*> cvHsDeriving g -+cvHsDataDefn (XHsDataDefn a) = pure (XHsDataDefn a) -+ -+cvConDecl :: ConDecl GhcSe -> Conv (ConDecl GhcPs) -+cvConDecl (ConDeclGADT a b c d e f g h) = -+ ConDeclGADT a -+ <$> convertName b -+ <*> pure c -+ <*> cvLHsQTyVars d -+ <*> traverse (traverse (traverse (traverse cvType))) e -+ <*> cvHsConDeclDetails f -+ <*> traverse cvType g -+ <*> pure h -+cvConDecl (ConDeclH98 a b c d e f g) = -+ ConDeclH98 a -+ <$> convertName b -+ <*> pure c -+ <*> traverse (traverse cvHsTyVarBndr) d -+ <*> traverse (traverse (traverse (traverse cvType))) e -+ <*> cvHsConDeclDetails f -+ <*> pure g -+cvConDecl (XConDecl a) = pure (XConDecl a) -+ -+cvHsDeriving :: HsDeriving GhcSe -> Conv (HsDeriving GhcPs) -+cvHsDeriving = traverse (traverse (traverse cvHsDerivingClause)) -+ -+cvHsDerivingClause -+ :: HsDerivingClause GhcSe -> Conv (HsDerivingClause GhcPs) -+cvHsDerivingClause (HsDerivingClause a b c) = -+ HsDerivingClause a -+ <$> traverse (traverse cvDerivStrategy) b -+ <*> traverse (traverse (cvHsImplicitBndrs (traverse cvType))) c -+cvHsDerivingClause (XHsDerivingClause a) = pure (XHsDerivingClause a) -+ -+cvHsConDeclDetails -+ :: HsConDeclDetails GhcSe -> Conv (HsConDeclDetails GhcPs) -+cvHsConDeclDetails = -+ cvHsConDetails (traverse cvType) -+ (traverse (traverse (traverse cvConDeclField))) -+ -+cvHsConDetails -+ :: (a -> Conv c) -> (b -> Conv d) -> HsConDetails a b -> Conv (HsConDetails c d) -+cvHsConDetails f _ (PrefixCon a) = PrefixCon <$> traverse f a -+cvHsConDetails _ g (RecCon a) = RecCon <$> g a -+cvHsConDetails f _ (InfixCon a b) = InfixCon <$> f a <*> f b -+ -+cvConDeclField :: ConDeclField GhcSe -> Conv (ConDeclField GhcPs) -+cvConDeclField (ConDeclField a b c d) = -+ ConDeclField a <$> traverse (traverse cvFieldOcc) b <*> traverse cvType c -+ <*> pure d -+cvConDeclField (XConDeclField a) = pure (XConDeclField a) -+ -+cvWarningDecls :: WarnDecls GhcSe -> Conv (WarnDecls GhcPs) -+cvWarningDecls (Warnings a b c) = -+ Warnings a b <$> traverse (traverse cvWarningDecl) c -+cvWarningDecls (XWarnDecls a) = pure (XWarnDecls a) -+ -+cvWarningDecl :: WarnDecl GhcSe -> Conv (WarnDecl GhcPs) -+cvWarningDecl (Warning a b c) = Warning a <$> convertName b <*> pure c -+cvWarningDecl (XWarnDecl a) = pure (XWarnDecl a) -+ -+-- expressions -+ -+cvLHsExpr :: LHsExpr GhcSe -> Conv (LHsExpr GhcPs) -+cvLHsExpr = traverse cvHsExpr -+ -+cvHsExpr :: HsExpr GhcSe -> Conv (HsExpr GhcPs) -+cvHsExpr e = case e of -+ HsVar a b -> HsVar a <$> convertName b -+ HsUnboundVar a b -> pure (HsUnboundVar a b) -+ HsConLikeOut a b -> pure (HsConLikeOut a b) -+ HsRecFld a b -> HsRecFld a <$> cvAFieldOcc b -+ HsOverLabel a b c -> HsOverLabel a <$> convertName b <*> pure c -+ HsIPVar a b -> pure (HsIPVar a b) -+ HsOverLit a b -> HsOverLit a <$> cvOverLit b -+ HsLit a b -> HsLit a <$> cvLit b -+ HsLam a b -> HsLam a <$> cvMatchGroup cvLHsExpr b -+ HsLamCase a b -> HsLamCase a <$> cvMatchGroup cvLHsExpr b -+ HsApp a b c -> HsApp a <$> cvLHsExpr b <*> cvLHsExpr c -+ HsAppType a b -> HsAppType -+ <$> cvHsWildCardBndrs (traverse cvType) a <*> cvLHsExpr b -+ OpApp a b c d -> OpApp a <$> cvLHsExpr b <*> cvLHsExpr c <*> cvLHsExpr d -+ NegApp a b c -> NegApp a <$> cvLHsExpr b <*> cvSyntaxExpr c -+ HsPar a b -> HsPar a <$> cvLHsExpr b -+ SectionL a b c -> SectionL a <$> cvLHsExpr b <*> cvLHsExpr c -+ SectionR a b c -> SectionR a <$> cvLHsExpr b <*> cvLHsExpr c -+ ExplicitTuple a b c -> ExplicitTuple a <$> traverse (traverse cvHsTupArg) b -+ <*> pure c -+ ExplicitSum a b c d -> ExplicitSum a b c <$> cvLHsExpr d -+ ExplicitList a b c -> ExplicitList a <$> traverse cvSyntaxExpr b <*> traverse cvLHsExpr c -+ HsCase a b c -> HsCase a <$> cvLHsExpr b <*> cvMatchGroup cvLHsExpr c -+ HsIf a b c d e -> HsIf a <$> traverse cvSyntaxExpr b -+ <*> cvLHsExpr c <*> cvLHsExpr d <*> cvLHsExpr e -+ HsMultiIf a b -> HsMultiIf a <$> traverse (traverse (cvGRHS cvLHsExpr)) b -+ HsLet a b c -> HsLet a <$> traverse cvHsLocalBinds b <*> cvLHsExpr c -+ HsDo a b c -> HsDo a -+ <$> convertName b <*> traverse (traverse (traverse (cvStmtLR cvLHsExpr))) c -+ RecordCon a b c -> RecordCon a <$> convertName b <*> cvRecordBinds c -+ RecordUpd a b c -> RecordUpd a <$> cvLHsExpr b -+ <*> traverse (traverse cvHsRecUpdField) c -+ ExprWithTySig a b -> ExprWithTySig <$> cvHsSigWcType a <*> cvLHsExpr b -+ ArithSeq a b c -> ArithSeq a <$> traverse cvSyntaxExpr b <*> cvArithSeqInfo c -+ HsSCC a b c d -> HsSCC a b c <$> cvLHsExpr d -+ HsCoreAnn a b c d -> HsCoreAnn a b c <$> cvLHsExpr d -+ HsStatic a b -> HsStatic a <$> cvLHsExpr b -+ EWildPat a -> pure (EWildPat a) -+ EAsPat a b c -> EAsPat a <$> convertName b <*> cvLHsExpr c -+ EViewPat a b c -> EViewPat a <$> cvLHsExpr b <*> cvLHsExpr c -+ ELazyPat a b -> ELazyPat a <$> cvLHsExpr b -+ HsProc a b c -> HsProc a <$> traverse cvPat b <*> traverse cvHsCmdTop c -+ HsBinTick a b c d -> HsBinTick a b c <$> cvLHsExpr d -+ HsTickPragma a b c d e -> HsTickPragma a b c d <$> cvLHsExpr e -+ HsSpliceE a b -> HsSpliceE a <$> cvHsSplice b -+ HsBracket a b -> HsBracket a <$> cvHsBracket b -+ HsTick a b c -> HsTick a <$> cvTickish b <*> cvLHsExpr c -+ XExpr a -> pure (XExpr a) -+ HsArrApp {} -> unsupported "HsArrApp" "HsExpr" (error "") -+ HsArrForm {} -> unsupported "HsArrForm" "HsExpr" (error "") -+ HsWrap {} -> unsupported "HsWrap" "HsExpr" (error "") -+ HsRnBracketOut {} -> unsupported "HsRnBracketOut" "HsExpr" (error "") -+ HsTcBracketOut {} -> unsupported "HsTcBracketOut" "HsExpr" (error "") -+ -+cvHsBracket :: HsBracket GhcSe -> Conv (HsBracket GhcPs) -+cvHsBracket (ExpBr a b) = ExpBr a <$> cvLHsExpr b -+cvHsBracket (PatBr a b) = PatBr a <$> traverse cvPat b -+cvHsBracket (DecBrL a b) = DecBrL a <$> traverse (traverse cvHsDecl) b -+cvHsBracket (DecBrG a b) = DecBrG a <$> cvHsGroup b -+cvHsBracket (TypBr a b) = TypBr a <$> traverse cvType b -+cvHsBracket (VarBr a b c) = VarBr a b <$> convertName c -+cvHsBracket (TExpBr a b) = TExpBr a <$> cvLHsExpr b -+cvHsBracket (XBracket a) = pure (XBracket a) -+ -+cvTickish :: ConvertName a b => Tickish a -> Conv (Tickish b) -+cvTickish (ProfNote a b c) = pure (ProfNote a b c) -+cvTickish (HpcTick a b) = pure (HpcTick a b) -+cvTickish (Breakpoint a b) = Breakpoint a <$> convertName b -+cvTickish (SourceNote a b) = pure (SourceNote a b) -+ -+cvHsGroup :: HsGroup GhcSe -> Conv (HsGroup GhcPs) -+cvHsGroup (HsGroup a b c d e f g h i j k l) = HsGroup a -+ <$> cvHsValBindsLR b <*> traverse (traverse cvSpliceDecl) c -+ <*> traverse cvTyClGroup d -+ <*> traverse (traverse cvDerivDecl) e -+ <*> traverse (traverse cvFixitySig) f -+ <*> traverse (traverse cvDefaultDecl) g -+ <*> traverse (traverse cvForeignDecl) h -+ <*> traverse (traverse cvWarningDecls) i -+ <*> traverse (traverse cvAnnDecl) j -+ <*> traverse (traverse cvRuleDecls) k -+ <*> pure l -+cvHsGroup (XHsGroup a) = pure (XHsGroup a) -+ -+cvTyClGroup :: TyClGroup GhcSe -> Conv (TyClGroup GhcPs) -+cvTyClGroup (TyClGroup a b c d) = TyClGroup a -+ <$> traverse (traverse cvTyClDecl) b -+ <*> traverse (traverse cvRoleAnnotDecl) c -+ <*> traverse (traverse cvInstDecl) d -+cvTyClGroup (XTyClGroup a) = pure (XTyClGroup a) -+ -+cvHsCmdTop :: HsCmdTop GhcSe -> Conv (HsCmdTop GhcPs) -+cvHsCmdTop (HsCmdTop a b) = HsCmdTop a <$> traverse cvHsCmd b -+cvHsCmdTop (XCmdTop a) = pure (XCmdTop a) -+ -+cvHsCmd :: HsCmd GhcSe -> Conv (HsCmd GhcPs) -+cvHsCmd (HsCmdArrApp a b c d e) = HsCmdArrApp a -+ <$> cvLHsExpr b <*> cvLHsExpr c <*> pure d <*> pure e -+cvHsCmd (HsCmdArrForm a b c d e) = HsCmdArrForm a -+ <$> cvLHsExpr b <*> pure c <*> pure d -+ <*> traverse (traverse cvHsCmdTop) e -+cvHsCmd (HsCmdApp a b c) = HsCmdApp a <$> traverse cvHsCmd b <*> cvLHsExpr c -+cvHsCmd (HsCmdLam a b) = HsCmdLam a <$> cvMatchGroup (traverse cvHsCmd) b -+cvHsCmd (HsCmdPar a b) = HsCmdPar a <$> traverse cvHsCmd b -+cvHsCmd (HsCmdCase a b c) = HsCmdCase a -+ <$> cvLHsExpr b <*> cvMatchGroup (traverse cvHsCmd) c -+cvHsCmd (HsCmdIf a b c d e) = HsCmdIf a -+ <$> traverse cvSyntaxExpr b -+ <*> cvLHsExpr c -+ <*> traverse cvHsCmd d -+ <*> traverse cvHsCmd e -+cvHsCmd (HsCmdLet a b c) = HsCmdLet a -+ <$> traverse cvHsLocalBinds b <*> traverse cvHsCmd c -+cvHsCmd (HsCmdDo a b) = HsCmdDo a -+ <$> traverse (traverse (traverse (cvStmtLR (traverse cvHsCmd)))) b -+cvHsCmd (HsCmdWrap {}) = unsupported "HsCmdWrap" "HsCmd" (error "") -+cvHsCmd (XCmd a) = pure (XCmd a) -+ -+cvArithSeqInfo :: ArithSeqInfo GhcSe -> Conv (ArithSeqInfo GhcPs) -+cvArithSeqInfo (From e) = From <$> cvLHsExpr e -+cvArithSeqInfo (FromThen a b) = FromThen <$> cvLHsExpr a <*> cvLHsExpr b -+cvArithSeqInfo (FromTo a b) = FromTo <$> cvLHsExpr a <*> cvLHsExpr b -+cvArithSeqInfo (FromThenTo a b c) = FromThenTo <$> cvLHsExpr a <*> cvLHsExpr b <*> cvLHsExpr c -+ -+cvHsTupArg :: HsTupArg GhcSe -> Conv (HsTupArg GhcPs) -+cvHsTupArg (Present a b) = Present a <$> cvLHsExpr b -+cvHsTupArg (Missing a) = pure (Missing a) -+cvHsTupArg (XTupArg a) = pure (XTupArg a) -+ -+cvAFieldOcc -+ :: AmbiguousFieldOcc GhcSe -> Conv (AmbiguousFieldOcc GhcPs) -+cvAFieldOcc (Unambiguous a b) = Unambiguous a <$> convertName b -+cvAFieldOcc (Ambiguous a b) = Ambiguous a <$> convertName b -+cvAFieldOcc (XAmbiguousFieldOcc a) = pure (XAmbiguousFieldOcc a) -+ -+cvOverLit :: HsOverLit GhcSe -> Conv (HsOverLit GhcPs) -+cvOverLit (OverLit a b c) = OverLit a b <$> cvHsExpr c -+cvOverLit (XOverLit a) = pure (XOverLit a) -+ -+cvLit :: HsLit GhcSe -> Conv (HsLit GhcPs) -+cvLit (HsChar a b) = pure (HsChar a b) -+cvLit (HsCharPrim a b) = pure (HsCharPrim a b) -+cvLit (HsString a b) = pure (HsString a b) -+cvLit (HsStringPrim a b) = pure (HsStringPrim a b) -+cvLit (HsInt a b) = pure (HsInt a b) -+cvLit (HsIntPrim a b) = pure (HsIntPrim a b) -+cvLit (HsWordPrim a b) = pure (HsWordPrim a b) -+cvLit (HsInt64Prim a b) = pure (HsInt64Prim a b) -+cvLit (HsWord64Prim a b) = pure (HsWord64Prim a b) -+cvLit (HsInteger a b c) = HsInteger a b <$> convertType c -+cvLit (HsRat a b c) = HsRat a b <$> convertType c -+cvLit (HsFloatPrim a b) = pure (HsFloatPrim a b) -+cvLit (HsDoublePrim a b) = pure (HsDoublePrim a b) -+cvLit (XLit a) = pure (XLit a) -+ -+cvMatchGroup -+ :: ( XMG GhcSe a ~ XMG GhcPs b -+ , XCMatch GhcSe a ~ XCMatch GhcPs b -+ , XCGRHSs GhcSe a ~ XCGRHSs GhcPs b -+ , XCGRHS GhcSe a ~ XCGRHS GhcPs b -+ , XXMatchGroup GhcSe a ~ XXMatchGroup GhcPs b -+ , XXMatch GhcSe a ~ XXMatch GhcPs b -+ , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b -+ , XXGRHS GhcSe a ~ XXGRHS GhcPs b -+ ) -+ => (a -> Conv b) -> MatchGroup GhcSe a -> Conv (MatchGroup GhcPs b) -+cvMatchGroup f (MG a b c) = MG a -+ <$> traverse (traverse (traverse (cvMatch f))) b -+ <*> pure c -+cvMatchGroup _ (XMatchGroup a) = pure (XMatchGroup a) -+ -+cvMatch -+ :: ( XCMatch GhcSe a ~ XCMatch GhcPs b -+ , XCGRHSs GhcSe a ~ XCGRHSs GhcPs b -+ , XCGRHS GhcSe a ~ XCGRHS GhcPs b -+ , XXMatch GhcSe a ~ XXMatch GhcPs b -+ , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b -+ , XXGRHS GhcSe a ~ XXGRHS GhcPs b -+ ) -+ => (a -> Conv b) -> Match GhcSe a -> Conv (Match GhcPs b) -+cvMatch f (Match a b c d) = Match a -+ <$> convertName b <*> traverse (traverse cvPat) c <*> cvGRHSs f d -+cvMatch _ (XMatch a) = pure (XMatch a) -+ -+cvPat :: Pat GhcSe -> Conv (Pat GhcPs) -+cvPat (WildPat a) = pure (WildPat a) -+cvPat (VarPat a b) = VarPat a <$> convertName b -+cvPat (LazyPat a b) = LazyPat a <$> traverse cvPat b -+cvPat (AsPat a b c) = AsPat a <$> convertName b <*> traverse cvPat c -+cvPat (ParPat a b) = ParPat a <$> traverse cvPat b -+cvPat (BangPat a b) = BangPat a <$> traverse cvPat b -+cvPat (ListPat a b) = ListPat a -+ <$> traverse (traverse cvPat) b -+cvPat (TuplePat a b c) = TuplePat a -+ <$> traverse (traverse cvPat) b -+ <*> pure c -+cvPat (SumPat a b c d) = SumPat a -+ <$> traverse cvPat b -+ <*> pure c <*> pure d -+cvPat (ConPatIn a b) = ConPatIn <$> convertName a <*> cvHsConPatDetails b -+cvPat (ViewPat a b c) = ViewPat a <$> cvLHsExpr b <*> traverse cvPat c -+cvPat (LitPat a b) = LitPat a <$> cvLit b -+cvPat (NPat a b c d) = NPat a -+ <$> traverse cvOverLit b <*> traverse cvSyntaxExpr c -+ <*> cvSyntaxExpr d -+cvPat (NPlusKPat a b c d e f) = NPlusKPat a -+ <$> convertName b -+ <*> traverse cvOverLit c <*> cvOverLit d -+ <*> cvSyntaxExpr e <*> cvSyntaxExpr f -+cvPat (SigPat a b) = SigPat <$> cvHsSigWcType a <*> traverse cvPat b -+cvPat (SplicePat a b) = SplicePat a <$> cvHsSplice b -+cvPat (CoPat {}) = unsupported "CoPat" "Pat" (error "") -+cvPat (ConPatOut {}) = unsupported "ConPatOut" "Pat" (error "") -+cvPat (XPat a) = pure (XPat a) -+ -+cvGRHSs -+ :: ( XCGRHSs GhcSe a ~ XCGRHSs GhcPs b -+ , XCGRHS GhcSe a ~ XCGRHS GhcPs b -+ , XXGRHSs GhcSe a ~ XXGRHSs GhcPs b -+ , XXGRHS GhcSe a ~ XXGRHS GhcPs b -+ ) -+ => (a -> Conv b) -> GRHSs GhcSe a -> Conv (GRHSs GhcPs b) -+cvGRHSs f (GRHSs a b c) = GRHSs a -+ <$> traverse (traverse (cvGRHS f)) b -+ <*> traverse cvHsLocalBinds c -+cvGRHSs _ (XGRHSs a) = pure (XGRHSs a) -+ -+cvGRHS -+ :: ( XCGRHS GhcSe a ~ XCGRHS GhcPs b -+ , XXGRHS GhcSe a ~ XXGRHS GhcPs b -+ ) -+ => (a -> Conv b) -> GRHS GhcSe a -> Conv (GRHS GhcPs b) -+cvGRHS f (GRHS a b c) = GRHS a -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> f c -+cvGRHS _ (XGRHS a) = pure (XGRHS a) -+ -+cvHsLocalBinds -+ :: HsLocalBinds GhcSe -> Conv (HsLocalBinds GhcPs) -+cvHsLocalBinds (HsValBinds a b) = HsValBinds a <$> cvHsValBindsLR b -+cvHsLocalBinds (HsIPBinds a b) = HsIPBinds a <$> cvHsIPBinds b -+cvHsLocalBinds (EmptyLocalBinds a) = pure (EmptyLocalBinds a) -+cvHsLocalBinds (XHsLocalBindsLR a) = pure (XHsLocalBindsLR a) -+ -+cvHsValBindsLR -+ :: HsValBindsLR GhcSe GhcSe -> Conv (HsValBindsLR GhcPs GhcPs) -+cvHsValBindsLR (ValBinds a b c) = ValBinds a -+ <$> mapBagM (traverse cvHsBindLR) b -+ <*> traverse (traverse cvSig) c -+cvHsValBindsLR (XValBindsLR _) = -+ unsupported "XValBindsLR" "HsValBindsLR" (error "") -+ -+cvHsConPatDetails -+ :: HsConPatDetails GhcSe -> Conv (HsConPatDetails GhcPs) -+cvHsConPatDetails (PrefixCon a) = PrefixCon <$> traverse (traverse cvPat) a -+cvHsConPatDetails (RecCon a) = RecCon <$> cvHsRecFieldsPat a -+cvHsConPatDetails (InfixCon a b) = InfixCon -+ <$> traverse cvPat a <*> traverse cvPat b -+ -+cvHsRecFields -+ :: (thing -> Conv thing') -+ -> HsRecFields GhcSe thing -+ -> Conv (HsRecFields GhcPs thing') -+cvHsRecFields f (HsRecFields a b) = -+ HsRecFields <$> traverse (traverse (cvHsRecField' cvFieldOcc f)) a <*> pure b -+ -+cvHsRecField' -+ :: (id -> Conv id') -+ -> (thing -> Conv thing') -+ -> HsRecField' id thing -+ -> Conv (HsRecField' id' thing') -+cvHsRecField' f g (HsRecField a b c) = -+ HsRecField <$> traverse f a <*> g b <*> pure c -+ -+cvHsRecFieldsPat -+ :: HsRecFields GhcSe (LPat GhcSe) -> Conv (HsRecFields GhcPs (LPat GhcPs)) -+cvHsRecFieldsPat = cvHsRecFields (traverse cvPat) -+ -+cvHsRecUpdField -+ :: HsRecUpdField GhcSe -> Conv (HsRecUpdField GhcPs) -+cvHsRecUpdField = cvHsRecField' cvAFieldOcc cvLHsExpr -+ -+cvRecordBinds -+ :: HsRecordBinds GhcSe -> Conv (HsRecordBinds GhcPs) -+cvRecordBinds = cvHsRecFields cvLHsExpr -+ -+cvFieldOcc :: FieldOcc GhcSe -> Conv (FieldOcc GhcPs) -+cvFieldOcc (FieldOcc a b) = FieldOcc a <$> convertName b -+cvFieldOcc (XFieldOcc a) = pure (XFieldOcc a) -+ -+cvStmtLR -+ :: ( XLastStmt GhcSe GhcSe a ~ XLastStmt GhcPs GhcPs b -+ , XBindStmt GhcSe GhcSe a ~ XBindStmt GhcPs GhcPs b -+ , XBodyStmt GhcSe GhcSe a ~ XBodyStmt GhcPs GhcPs b -+ , XApplicativeStmt GhcSe GhcSe a ~ XApplicativeStmt GhcPs GhcPs b -+ , XLetStmt GhcSe GhcSe a ~ XLetStmt GhcPs GhcPs b -+ , XRecStmt GhcSe GhcSe a ~ XRecStmt GhcPs GhcPs b -+ , XParStmt GhcSe GhcSe a ~ XParStmt GhcPs GhcPs b -+ , XTransStmt GhcSe GhcSe a ~ XTransStmt GhcPs GhcPs b -+ , XXStmtLR GhcSe GhcSe a ~ XXStmtLR GhcPs GhcPs b -+ ) -+ => (a -> Conv b) -> StmtLR GhcSe GhcSe a -> Conv (StmtLR GhcPs GhcPs b) -+cvStmtLR k (LastStmt a b c d) = LastStmt a -+ <$> k b <*> pure c <*> cvSyntaxExpr d -+cvStmtLR k (BindStmt a b c d e) = BindStmt a -+ <$> traverse cvPat b <*> k c -+ <*> cvSyntaxExpr d <*> cvSyntaxExpr e -+cvStmtLR k (BodyStmt a b c d) = BodyStmt a -+ <$> k b <*> cvSyntaxExpr c -+ <*> cvSyntaxExpr d -+cvStmtLR _ (ApplicativeStmt a b c) = ApplicativeStmt a -+ <$> traverse -+ (\(se, aa) -> (,) <$> cvSyntaxExpr se <*> cvApplicativeArg aa) -+ b -+ <*> traverse cvSyntaxExpr c -+cvStmtLR _ (LetStmt a b) = LetStmt a <$> traverse cvHsLocalBinds b -+cvStmtLR k (RecStmt a b c d e f g) = RecStmt a -+ <$> traverse (traverse (cvStmtLR k)) b -+ <*> convertName c -+ <*> convertName d -+ <*> cvSyntaxExpr e -+ <*> cvSyntaxExpr f -+ <*> cvSyntaxExpr g -+cvStmtLR _ (ParStmt a b c d) = ParStmt a -+ <$> traverse cvParStmtBlock b -+ <*> cvHsExpr c -+ <*> cvSyntaxExpr d -+cvStmtLR _ (TransStmt a b c d e f g h i) = TransStmt a b -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) c -+ <*> traverse (\(x, y) -> (,) <$> convertName x <*> convertName y) d -+ <*> cvLHsExpr e -+ <*> traverse cvLHsExpr f -+ <*> cvSyntaxExpr g -+ <*> cvSyntaxExpr h -+ <*> cvHsExpr i -+cvStmtLR _ (XStmtLR a) = pure (XStmtLR a) -+ -+cvParStmtBlock -+ :: ParStmtBlock GhcSe GhcSe -> Conv (ParStmtBlock GhcPs GhcPs) -+cvParStmtBlock (ParStmtBlock a b c d) = ParStmtBlock a -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b -+ <*> convertName c -+ <*> cvSyntaxExpr d -+cvParStmtBlock (XParStmtBlock a) = pure (XParStmtBlock a) -+ -+cvSyntaxExpr :: SyntaxExpr GhcSe -> Conv (SyntaxExpr GhcPs) -+cvSyntaxExpr (SyntaxExpr a b c) = -+ SyntaxExpr <$> cvHsExpr a <*> pure b <*> pure c -+ -+cvHsIPBinds -+ :: HsIPBinds GhcSe -> Conv (HsIPBinds GhcPs) -+cvHsIPBinds (IPBinds a b) = IPBinds a <$> traverse (traverse cvIPBind) b -+cvHsIPBinds (XHsIPBinds a) = pure (XHsIPBinds a) -+ -+cvIPBind :: IPBind GhcSe -> Conv (IPBind GhcPs) -+cvIPBind (IPBind a b c) = IPBind a <$> convertName b <*> cvLHsExpr c -+cvIPBind (XIPBind a) = pure (XIPBind a) -+ -+cvHsBindLR -+ :: HsBindLR GhcSe GhcSe -> Conv (HsBindLR GhcPs GhcPs) -+cvHsBindLR (FunBind a b c d e) = FunBind a -+ <$> convertName b -+ <*> cvMatchGroup cvLHsExpr c -+ <*> pure d <*> pure e -+cvHsBindLR (PatBind a b c d ) = PatBind a -+ <$> traverse cvPat b <*> cvGRHSs cvLHsExpr c <*> pure d -+cvHsBindLR (VarBind a b c d) = VarBind a -+ <$> convertName b <*> cvLHsExpr c <*> pure d -+cvHsBindLR (PatSynBind a b) = PatSynBind a <$> cvPatSynBind b -+cvHsBindLR (AbsBinds {}) = -+ unsupported "AbsBind" "HsBindLR" (error "") -+cvHsBindLR (XHsBindsLR a) = pure (XHsBindsLR a) -+ -+cvHsWildCardBndrs -+ :: ( XHsWC GhcSe thing ~ XHsWC GhcPs thing' -+ , XXHsWildCardBndrs GhcSe thing ~ XXHsWildCardBndrs GhcPs thing' -+ ) -+ => (thing -> Conv thing') -+ -> HsWildCardBndrs GhcSe thing -+ -> Conv (HsWildCardBndrs GhcPs thing') -+cvHsWildCardBndrs thingF (HsWC a b) = HsWC a <$> thingF b -+cvHsWildCardBndrs _ (XHsWildCardBndrs a) = pure (XHsWildCardBndrs a) -+ -+cvLHsWcType -+ :: LHsWcType GhcSe -> Conv (LHsWcType GhcPs) -+cvLHsWcType = cvHsWildCardBndrs (traverse cvType) -+ -+cvHsSigWcType -+ :: LHsSigWcType GhcSe -> Conv (LHsSigWcType GhcPs) -+cvHsSigWcType = cvHsWildCardBndrs (cvHsImplicitBndrs (traverse cvType)) -+ -+cvHsImplicitBndrs -+ :: ( XHsIB GhcSe thing ~ XHsIB GhcPs thing' -+ , XXHsImplicitBndrs GhcSe thing ~ XXHsImplicitBndrs GhcPs thing' -+ ) -+ => (thing -> Conv thing') -+ -> HsImplicitBndrs GhcSe thing -+ -> Conv (HsImplicitBndrs GhcPs thing') -+cvHsImplicitBndrs f (HsIB a b) = HsIB a <$> f b -+cvHsImplicitBndrs _ (XHsImplicitBndrs a) = pure (XHsImplicitBndrs a) -+ -+cvType :: HsType GhcSe -> Conv (HsType GhcPs) -+cvType (HsForAllTy a b c) = HsForAllTy a -+ <$> traverse (traverse cvHsTyVarBndr) b -+ <*> traverse cvType c -+cvType (HsQualTy a b c) = HsQualTy a -+ <$> traverse (traverse (traverse cvType)) b -+ <*> traverse cvType c -+cvType (HsTyVar a b c) = HsTyVar a b <$> convertName c -+cvType (HsAppTy a b c) = HsAppTy a -+ <$> traverse cvType b -+ <*> traverse cvType c -+cvType (HsFunTy a b c) = HsFunTy a -+ <$> traverse cvType b -+ <*> traverse cvType c -+cvType (HsListTy a b) = HsListTy a <$> traverse cvType b -+cvType (HsTupleTy a b c) = HsTupleTy a b <$> traverse (traverse cvType) c -+cvType (HsSumTy a b) = HsSumTy a <$> traverse (traverse cvType) b -+cvType (HsOpTy a b c d) = HsOpTy a -+ <$> traverse cvType b -+ <*> convertName c -+ <*> traverse cvType d -+cvType (HsParTy a b) = HsParTy a <$> traverse cvType b -+cvType (HsIParamTy a b c) = HsIParamTy a b <$> traverse cvType c -+cvType (HsKindSig a b c) = HsKindSig a -+ <$> traverse cvType b -+ <*> traverse cvType c -+cvType (HsBangTy a b c) = HsBangTy a b <$> traverse cvType c -+cvType (HsRecTy a b) = HsRecTy a <$> traverse (traverse cvConDeclField) b -+cvType (HsExplicitListTy a b c) = HsExplicitListTy a b -+ <$> traverse (traverse cvType) c -+cvType (HsExplicitTupleTy a b) = HsExplicitTupleTy a -+ <$> traverse (traverse cvType) b -+cvType (HsTyLit a b) = pure (HsTyLit a b) -+cvType (HsWildCardTy a) = pure (HsWildCardTy a) -+cvType (HsDocTy a b c) = HsDocTy a <$> traverse cvType b <*> pure c -+cvType (HsSpliceTy a b) = HsSpliceTy a <$> cvHsSplice b -+cvType (HsStarTy a b) = pure (HsStarTy a b) -+cvType (XHsType a) = pure (XHsType a) -+ -+cvHsTyVarBndr -+ :: HsTyVarBndr GhcSe -> Conv (HsTyVarBndr GhcPs) -+cvHsTyVarBndr (UserTyVar a b) = UserTyVar a <$> convertName b -+cvHsTyVarBndr (KindedTyVar a b c) = KindedTyVar a -+ <$> convertName b -+ <*> traverse cvType c -+cvHsTyVarBndr (XTyVarBndr a) = pure (XTyVarBndr a) -+ -+cvApplicativeArg -+ :: ApplicativeArg GhcSe -> Conv (ApplicativeArg GhcPs) -+cvApplicativeArg (ApplicativeArgOne a b c d) = ApplicativeArgOne a -+ <$> traverse cvPat b <*> cvLHsExpr c <*> pure d -+cvApplicativeArg (ApplicativeArgMany a b c d) = ApplicativeArgMany a -+ <$> traverse (traverse (cvStmtLR cvLHsExpr)) b <*> cvHsExpr c -+ <*> traverse cvPat d -+cvApplicativeArg (XApplicativeArg a) = pure (XApplicativeArg a) -+ -+cvSig :: Sig GhcSe -> Conv (Sig GhcPs) -+cvSig (TypeSig a b c) = TypeSig a <$> convertName b <*> cvHsSigWcType c -+cvSig (PatSynSig a b c) = PatSynSig a -+ <$> convertName b <*> cvHsImplicitBndrs (traverse cvType) c -+cvSig (ClassOpSig a b c d) = ClassOpSig a b -+ <$> convertName c <*> cvHsImplicitBndrs (traverse cvType) d -+cvSig (InlineSig a b c) = InlineSig a <$> convertName b <*> pure c -+cvSig (FixSig a b) = FixSig a <$> cvFixitySig b -+cvSig (SpecSig a b c d) = SpecSig a -+ <$> convertName b -+ <*> traverse (cvHsImplicitBndrs (traverse cvType)) c -+ <*> pure d -+cvSig (SpecInstSig a b c) = SpecInstSig a b -+ <$> cvHsImplicitBndrs (traverse cvType) c -+cvSig (SCCFunSig a b c d) = SCCFunSig a b <$> convertName c <*> pure d -+cvSig (CompleteMatchSig a b c d) = CompleteMatchSig a b -+ <$> convertName c <*> convertName d -+cvSig (MinimalSig a b c) = MinimalSig a b <$> traverse (traverse convertName) c -+cvSig (IdSig {}) = unsupported "IdSig" "Sig" (error "") -+cvSig (XSig a) = pure (XSig a) -+ -+cvFixitySig :: FixitySig GhcSe -> Conv (FixitySig GhcPs) -+cvFixitySig (FixitySig a b c) = FixitySig a <$> convertName b <*> pure c -+cvFixitySig (XFixitySig a) = pure (XFixitySig a) -+ -+cvPatSynBind :: PatSynBind GhcSe GhcSe -> Conv (PatSynBind GhcPs GhcPs) -+cvPatSynBind (PSB a b c d e) = PSB a -+ <$> convertName b -+ <*> cvHsPatSynDetails convertName c <*> traverse cvPat d -+ <*> cvHsPatSynDir e -+cvPatSynBind (XPatSynBind a) = pure (XPatSynBind a) -+ -+cvHsPatSynDetails -+ :: (a -> Conv b) -+ -> HsPatSynDetails a -+ -> Conv (HsPatSynDetails b) -+cvHsPatSynDetails f = cvHsConDetails f (traverse (cvRecordPatSynField f)) -+ -+cvRecordPatSynField -+ :: (a -> Conv b) -+ -> RecordPatSynField a -+ -> Conv (RecordPatSynField b) -+cvRecordPatSynField f (RecordPatSynField a b) = -+ RecordPatSynField <$> f a <*> f b -+ -+cvHsPatSynDir :: HsPatSynDir GhcSe -> Conv (HsPatSynDir GhcPs) -+cvHsPatSynDir Unidirectional = pure Unidirectional -+cvHsPatSynDir ImplicitBidirectional = pure ImplicitBidirectional -+cvHsPatSynDir (ExplicitBidirectional a) = ExplicitBidirectional -+ <$> cvMatchGroup cvLHsExpr a -diff --git a/compiler/hsSyn/HsExprBin_Conversions.hs b/compiler/hsSyn/HsExprBin_Conversions.hs -new file mode 100644 -index 0000000000..df2d8f929a ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin_Conversions.hs -@@ -0,0 +1,211 @@ -+{-# LANGUAGE ConstraintKinds, DeriveFunctor #-} -+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} -+{-# LANGUAGE MultiParamTypeClasses #-} -+{-# LANGUAGE TypeFamilies, TypeSynonymInstances #-} -+module HsExprBin_Conversions where -+ -+import Control.Applicative -+import Control.Monad -+import Control.Monad.IO.Class -+import Data.Char (isDigit) -+import Data.List (intercalate) -+import Data.Maybe -+import Data.Traversable -+ -+import DynFlags -+import FastString -+import GhcPrelude -+import HsExpr -+import Module -+import Name -+import Outputable -+import PackageConfig -+import Packages -+import RdrName -+import SeName -+import SrcLoc -+import TcRnTypes -+import IfaceType -+import ToIface (toIfaceType) -+import TyCoRep (Type(..), TyLit(..)) -+ -+data ConvError -+ = ConvUnsupported String String SDoc -+ -- constructor name, type name, text rendering -+ -- of the unsupported subexpression -+ | ConvFailure String -+ -+data ConvResult a -+ = ConvError ConvError -+ | ConvOK a -+ deriving Functor -+-- * Conversion utilities -+ -+newtype Conv a = Conv { runConv :: RnM (ConvResult a) } -+ -+instance Functor Conv where -+ fmap f (Conv k) = Conv (fmap (fmap f) k) -+ -+instance Applicative Conv where -+ pure = Conv . return . ConvOK -+ (<*>) = ap -+ -+instance Monad Conv where -+ return = pure -+ -+ Conv mx >>= f = Conv $ mx >>= \cvx -> case cvx of -+ ConvOK x -> runConv (f x) -+ ConvError e -> pure (ConvError e) -+ -+unsupported :: String -- ^ constructor name -+ -> String -- ^ type name -+ -> SDoc -- ^ textual rendering of the unsupported subexpression -+ -> Conv a -+unsupported con ty subexpr = Conv $ -+ pure (ConvError $ ConvUnsupported con ty subexpr) -+ -+badInput :: String -> Conv a -+badInput str = Conv $ pure (ConvError $ ConvFailure str) -+ -+liftRn :: RnM a -> Conv a -+liftRn = Conv . fmap ConvOK -+ -+class ConvertType t u where -+ convertType :: t -> Conv u -+ -+class ConvertName a b where -+ convertName :: a -> Conv b -+ -+instance ConvertName a b => ConvertName (Located a) (Located b) where -+ convertName = traverse convertName -+ -+instance ConvertName a b => ConvertName [a] [b] where -+ convertName = traverse convertName -+ -+instance ConvertName a b => ConvertName (Either e a) (Either e b) where -+ convertName = traverse convertName -+ -+instance ConvertName a b => ConvertName (HsMatchContext a) (HsMatchContext b) where -+ convertName = traverse convertName -+ -+instance ConvertName a b => ConvertName (HsStmtContext a) (HsStmtContext b) where -+ convertName = traverse convertName -+ -+instance ConvertName a b => ConvertName (Maybe a) (Maybe b) where -+ convertName = traverse convertName -+ -+instance ConvertType a a where -+ convertType = pure -+ -+instance ConvertType Type IfaceType where -+ convertType = pure . toIfaceType -+ -+instance ConvertType IfaceType Type where -+ convertType (IfaceLitTy n) = pure $ LitTy (go n) -+ where go (IfaceNumTyLit a) = NumTyLit a -+ go (IfaceStrTyLit a) = StrTyLit a -+ convertType e@(IfaceFreeTyVar {}) = unsupported "IfaceFreeTyVar" "IfaceType" (ppr e) -+ convertType e@(IfaceTyVar {}) = unsupported "IfaceTyVar" "IfaceType" (ppr e) -+ convertType e@(IfaceAppTy {}) = unsupported "IfaceAppTy" "IfaceType" (ppr e) -+ convertType e@(IfaceFunTy {}) = unsupported "IfaceFunTy" "IfaceType" (ppr e) -+ convertType e@(IfaceDFunTy {}) = unsupported "IfaceDFunTy" "IfaceType" (ppr e) -+ convertType e@(IfaceForAllTy {}) = unsupported "IfaceForAllTy" "IfaceType" (ppr e) -+ convertType e@(IfaceTyConApp {}) = unsupported "IfaceTyConApp" "IfaceType" (ppr e) -+ convertType e@(IfaceCastTy {}) = unsupported "IfaceCastTy" "IfaceType" (ppr e) -+ convertType e@(IfaceCoercionTy {}) = unsupported "IfaceCoercion" "IfaceType" (ppr e) -+ convertType e@(IfaceTupleTy {}) = unsupported "IfaceTupleTy" "IfaceType" (ppr e) -+ -+ -+instance ConvertName RdrName SeName where -+ convertName = pure . mkSeName -+ -+instance ConvertName SeName RdrName where -+ convertName (SeName n) = case n of -+ Orig mod occn -> do -+ -- TODO: introduce some caching here, to avoid doing the -+ -- searchPackageId dance too often. -+ currentMod <- liftRn getModule -+ -+ if samePackages currentMod mod -+ then let newMod = mod { moduleUnitId = moduleUnitId currentMod } in -+ pure (Orig newMod occn) -+ else do mnewmod <- liftRn (findEquivalentModule mod) -+ case mnewmod of -+ Nothing -> pure (Orig mod occn) -+ Just mod' -> pure (Orig mod' occn) -+ -+ _ -> pure n -+ -+ where samePackages mod1 mod2 = fromMaybe False $ do -- maybe monad -+ let str1 = unitIdString (moduleUnitId mod1) -+ str2 = unitIdString (moduleUnitId mod2) -+ (pkg1, ver1, _mhash1) <- parseUnitId' str1 -+ (pkg2, ver2, _mhash2) <- parseUnitId' str2 -+ return (pkg1 == pkg2 && ver1 == ver2) -+ -+instance ConvertName Name SeName where -+ convertName n = pure $ mkSeName (nameRdrName n) -+ -+instance ConvertName SeName Name where -+ convertName (SeName n) = case isExact_maybe n of -+ Just a -> pure a -+ _ -> badInput "convertName :: SeName -> Name: non exact RdrName in SeName" -+ -+-- * Looking up modules/packages for Orig names -+ -+-- this rejects wired in packages, because we want to leave them untouched -+parseUnitId' :: String -> Maybe (String, String, Maybe String) -+parseUnitId' = parse -+ -+ where -+ parse s = case splitOn '-' (reverse s) of -+ ("":_) -> Nothing -+ xs | length xs >= 1 && last xs == "" -> Nothing -+ (hash:ver:name) | isVersion ver -> -+ Just (intercalate "-" (reverse name), ver, Just hash) -+ (ver:name) | isVersion ver -> -+ Just (intercalate "-" (reverse name), ver, Nothing) -+ _ -> Nothing -+ splitOn c = go [] -+ where go acc (x:xs) -+ | x == c = acc : go "" xs -+ | otherwise = go (x:acc) xs -+ go acc [] = [acc] -+ isVersion = go False -+ -- True: waiting for digit or dot (we've seen a digit last) -+ -- False: waiting for digit (we've just seen a dot) -+ where go False (c:cs) -+ | isDigit c = go True cs -+ | otherwise = False -+ go True (c:cs) -+ | isDigit c = go True cs -+ | c == '.' = go False cs -+ | otherwise = False -+ go b [] = b -- if we've seen a dot last (False), we fail -+ -- otherwise, the version number can end here -+ -+-- | Look up the module from the same package, but built by the -+-- current compiler, therefore with a slightly different hash -+-- in the unit id than the input Module, which was built by some -+-- non-cross-compiling GHC. -+findEquivalentModule :: Module -> RnM (Maybe Module) -+findEquivalentModule mod = do -+ liftIO $ putStrLn ("Looking for equivalent to: " ++ unitIdStr) -+ case parseUnitId' unitIdStr of -+ Nothing -> return Nothing -+ Just (pkg, ver, _mhash) -> do -+ muid <- lookFor pkg ver -+ maybe (pure Nothing) (\uid -> return $ Just (mod { moduleUnitId = uid })) muid -+ -+ where unitIdStr = unitIdString (moduleUnitId mod) -+ -+lookFor :: String -> String -> RnM (Maybe UnitId) -+lookFor pkg ver = do -+ dflags <- getDynFlags -+ let pkgid = mkFastString (pkg ++ "-" ++ ver) -+ pkgs = searchPackageId dflags (SourcePackageId pkgid) -+ liftIO $ putStrLn ("Looking for: " ++ pkg ++ "-" ++ ver) -+ liftIO . putStrLn . unwords $ -+ [ "Found", show (length pkgs), "pkgs:" ] ++ -+ [ unitIdString (packageConfigId p) | p <- pkgs ] -+ if null pkgs then pure Nothing else pure (Just $ packageConfigId (head pkgs)) -diff --git a/compiler/hsSyn/HsExprBin_Instances.hs b/compiler/hsSyn/HsExprBin_Instances.hs -new file mode 100644 -index 0000000000..24abf8d69a ---- /dev/null -+++ b/compiler/hsSyn/HsExprBin_Instances.hs -@@ -0,0 +1,1665 @@ -+-- too noisy during development... -+{-# OPTIONS_GHC -fno-warn-orphans #-} -+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -+{-# LANGUAGE StandaloneDeriving #-} -+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} -+module HsExprBin_Instances where -+ -+import Control.Applicative -+import Control.Monad -+ -+import BasicTypes -+import Binary -+import CoreSyn ( Tickish(..) ) -+import GhcPrelude -+import HsBinds -+import HsDecls -+import HsExpr -+import HsExtension -+import HsLit -+import HsPat -+import HsTypes -+import Name -+import Outputable -+import RdrName -+import SeName -+import SrcLoc -+import TcEvidence (HsWrapper(WpHole)) -+ -+-- * Utilities -+ -+putPanic :: String -> String -> a -+putPanic tyName conName = -+ panic ("Binary " ++ tyName ++ ".put: " ++ conName ++ " not supported") -+ -+getPanic :: String -> a -+getPanic tyName = -+ panic ("Binary " ++ tyName ++ ".get: unknown (or unsupported) tag") -+ -+-- * Binary instances -+ -+instance Binary (HsExpr GhcSe) where -+ put_ bh e = case e of -+ HsVar a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ HsUnboundVar a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ HsRecFld a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ HsOverLabel a b c -> -+ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsIPVar a b -> -+ putByte bh 4 >> put_ bh a >> put_ bh b -+ HsOverLit a b -> -+ putByte bh 5 >> put_ bh a >> put_ bh b -+ HsLit a b -> -+ putByte bh 6 >> put_ bh a >> put_ bh b -+ HsLam a b -> -+ putByte bh 7 >> put_ bh a >> put_ bh b -+ HsLamCase a b -> -+ putByte bh 8 >> put_ bh a >> put_ bh b -+ HsApp a b c -> -+ putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsAppType a b -> -+ putByte bh 10 >> put_ bh a >> put_ bh b -+ OpApp a b c d -> -+ putByte bh 11 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ NegApp a b c -> -+ putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsPar a b -> -+ putByte bh 13 >> put_ bh a >> put_ bh b -+ SectionL a b c -> -+ putByte bh 14 >> put_ bh a >> put_ bh b >> put_ bh c -+ SectionR a b c -> -+ putByte bh 15 >> put_ bh a >> put_ bh b >> put_ bh c -+ ExplicitTuple a b c -> -+ putByte bh 16 >> put_ bh a >> put_ bh b >> put_ bh c -+ ExplicitSum a b c d -> -+ putByte bh 17 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsCase a b c -> -+ putByte bh 18 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsIf a b c d e -> -+ putByte bh 19 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ HsMultiIf a b -> -+ putByte bh 20 >> put_ bh a >> put_ bh b -+ HsLet a b c -> -+ putByte bh 21 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsDo a b c -> -+ putByte bh 22 >> put_ bh a >> put_ bh b >> put_ bh c -+ ExplicitList a b c -> -+ putByte bh 23 >> put_ bh a >> put_ bh b >> put_ bh c -+ RecordCon a b c -> -+ putByte bh 24 >> put_ bh a >> put_ bh b >> put_ bh c -+ RecordUpd a b c -> -+ putByte bh 25 >> put_ bh a >> put_ bh b >> put_ bh c -+ ExprWithTySig a b -> -+ putByte bh 26 >> put_ bh a >> put_ bh b -+ ArithSeq a b c -> -+ putByte bh 27 >> put_ bh a >> put_ bh b >> put_ bh c -+ EWildPat a -> -+ putByte bh 28 >> put_ bh a -+ EAsPat a b c -> -+ putByte bh 29 >> put_ bh a >> put_ bh b >> put_ bh c -+ EViewPat a b c -> -+ putByte bh 30 >> put_ bh a >> put_ bh b >> put_ bh c -+ ELazyPat a b -> -+ putByte bh 31 >> put_ bh a >> put_ bh b -+ HsStatic a b -> -+ putByte bh 32 >> put_ bh a >> put_ bh b -+ HsProc a b c -> -+ putByte bh 33 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsBinTick a b c d -> -+ putByte bh 34 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsTickPragma a b c d e -> -+ putByte bh 35 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ HsSpliceE a b -> -+ putByte bh 36 >> put_ bh a >> put_ bh b -+ HsSCC a b c d -> -+ putByte bh 37 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsCoreAnn a b c d -> -+ putByte bh 38 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ HsBracket a b -> -+ putByte bh 39 >> put_ bh a >> put_ bh b -+ XExpr a -> -+ putByte bh 40 >> put_ bh a -+ HsConLikeOut {} -> putPanic "HsExpr" "HsConLikeOut" -+ HsRnBracketOut {} -> putPanic "HsExpr" "HsRnBracketOut" -+ HsTcBracketOut {} -> putPanic "HsExpr" "HsTcBracketOut" -+ HsArrApp {} -> putPanic "HsExpr" "HsArrApp" -+ HsArrForm {} -> putPanic "HsExpr" "HsArrForm" -+ HsTick {} -> putPanic "HsExpr" "HsTick" -+ HsWrap {} -> putPanic "HsExpr" "HsWrap" -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsVar <$> get bh <*> get bh -+ 1 -> HsUnboundVar <$> get bh <*> get bh -+ 2 -> HsRecFld <$> get bh <*> get bh -+ 3 -> HsOverLabel <$> get bh <*> get bh <*> get bh -+ 4 -> HsIPVar <$> get bh <*> get bh -+ 5 -> HsOverLit <$> get bh <*> get bh -+ 6 -> HsLit <$> get bh <*> get bh -+ 7 -> HsLam <$> get bh <*> get bh -+ 8 -> HsLamCase <$> get bh <*> get bh -+ 9 -> HsApp <$> get bh <*> get bh <*> get bh -+ 10 -> HsAppType <$> get bh <*> get bh -+ 11 -> OpApp <$> get bh <*> get bh <*> get bh <*> get bh -+ 12 -> NegApp <$> get bh <*> get bh <*> get bh -+ 13 -> HsPar <$> get bh <*> get bh -+ 14 -> SectionL <$> get bh <*> get bh <*> get bh -+ 15 -> SectionR <$> get bh <*> get bh <*> get bh -+ 16 -> ExplicitTuple <$> get bh <*> get bh <*> get bh -+ 17 -> ExplicitSum <$> get bh <*> get bh <*> get bh <*> get bh -+ 18 -> HsCase <$> get bh <*> get bh <*> get bh -+ 19 -> HsIf <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ 20 -> HsMultiIf <$> get bh <*> get bh -+ 21 -> HsLet <$> get bh <*> get bh <*> get bh -+ 22 -> HsDo <$> get bh <*> get bh <*> get bh -+ 23 -> ExplicitList <$> get bh <*> get bh <*> get bh -+ 24 -> RecordCon <$> get bh <*> get bh <*> get bh -+ 25 -> RecordUpd <$> get bh <*> get bh <*> get bh -+ 26 -> ExprWithTySig <$> get bh <*> get bh -+ 27 -> ArithSeq <$> get bh <*> get bh <*> get bh -+ 28 -> EWildPat <$> get bh -+ 29 -> EAsPat <$> get bh <*> get bh <*> get bh -+ 30 -> EViewPat <$> get bh <*> get bh <*> get bh -+ 31 -> ELazyPat <$> get bh <*> get bh -+ 32 -> HsStatic <$> get bh <*> get bh -+ 33 -> HsProc <$> get bh <*> get bh <*> get bh -+ 34 -> HsBinTick <$> get bh <*> get bh <*> get bh <*> get bh -+ 35 -> HsTickPragma <$> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ 36 -> HsSpliceE <$> get bh <*> get bh -+ 37 -> HsSCC <$> get bh <*> get bh <*> get bh <*> get bh -+ 38 -> HsCoreAnn <$> get bh <*> get bh <*> get bh <*> get bh -+ 39 -> HsBracket <$> get bh <*> get bh -+ 40 -> XExpr <$> get bh -+ _ -> getPanic "HsExpr" -+ -+instance Binary (HsBracket GhcSe) where -+ put_ bh b = case b of -+ ExpBr a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ PatBr a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ DecBrL a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ DecBrG a b -> -+ putByte bh 3 >> put_ bh a >> put_ bh b -+ TypBr a b -> -+ putByte bh 4 >> put_ bh a >> put_ bh b -+ VarBr a b c -> -+ putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c -+ TExpBr a b -> -+ putByte bh 6 >> put_ bh a >> put_ bh b -+ XBracket a -> -+ putByte bh 7 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ExpBr <$> get bh <*> get bh -+ 1 -> PatBr <$> get bh <*> get bh -+ 2 -> DecBrL <$> get bh <*> get bh -+ 3 -> DecBrG <$> get bh <*> get bh -+ 4 -> TypBr <$> get bh <*> get bh -+ 5 -> VarBr <$> get bh <*> get bh <*> get bh -+ 6 -> TExpBr <$> get bh <*> get bh -+ 7 -> XBracket <$> get bh -+ _ -> getPanic "HsBracket" -+ -+instance Binary SeName where -+ put_ bh (SeName n) = put_ bh n -+ get bh = mkSeName <$> get bh -+ -+instance Binary UnboundVar where -+ put_ bh v = case v of -+ OutOfScope a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ TrueExprHole a -> putByte bh 1 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> OutOfScope <$> get bh <*> get bh -+ 1 -> TrueExprHole <$> get bh -+ _ -> getPanic "UnboundVar" -+ -+instance Binary a => Binary (StmtLR GhcSe GhcSe a) where -+ put_ bh s = case s of -+ LastStmt a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ BindStmt a b c d e -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e -+ ApplicativeStmt a b c -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -+ BodyStmt a b c d -> -+ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ LetStmt a b -> -+ putByte bh 4 >> put_ bh a >> put_ bh b -+ ParStmt a b c d -> -+ putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ RecStmt a b c d e f g -> -+ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g -+ TransStmt a b c d e f g h i -> -+ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h -+ >> put_ bh i -+ XStmtLR a -> -+ putByte bh 8 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> LastStmt <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> BindStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ 2 -> ApplicativeStmt <$> get bh <*> get bh <*> get bh -+ 3 -> BodyStmt <$> get bh <*> get bh <*> get bh <*> get bh -+ 4 -> LetStmt <$> get bh <*> get bh -+ 5 -> ParStmt <$> get bh <*> get bh <*> get bh <*> get bh -+ 6 -> RecStmt <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ 7 -> TransStmt <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh -+ 8 -> XStmtLR <$> get bh -+ _ -> getPanic "StmtLR" -+ -+instance Binary (HsGroup GhcSe) where -+ put_ bh x = case x of -+ HsGroup a b c d e f g h i j k l -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h -+ >> put_ bh i >> put_ bh j >> put_ bh k >> put_ bh l -+ XHsGroup a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsGroup <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> XHsGroup <$> get bh -+ _ -> getPanic "HsGroup" -+ -+instance Binary (TyClGroup GhcSe) where -+ put_ bh g = case g of -+ TyClGroup a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ XTyClGroup a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> TyClGroup <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> XTyClGroup <$> get bh -+ _ -> getPanic "TyClGroup" -+ -+instance Binary (HsCmdTop GhcSe) where -+ put_ bh c = case c of -+ HsCmdTop a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ XCmdTop a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsCmdTop <$> get bh <*> get bh -+ 1 -> XCmdTop <$> get bh -+ _ -> getPanic "HsCmdTop" -+ -+instance Binary (HsCmd GhcSe) where -+ put_ bh c = case c of -+ HsCmdArrApp a b c d e -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ HsCmdArrForm a b c d e -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ HsCmdApp a b c -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsCmdLam a b -> -+ putByte bh 3 >> put_ bh a >> put_ bh b -+ HsCmdPar a b -> -+ putByte bh 4 >> put_ bh a >> put_ bh b -+ HsCmdCase a b c -> -+ putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsCmdIf a b c d e -> -+ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ HsCmdLet a b c -> -+ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsCmdDo a b -> -+ putByte bh 8 >> put_ bh a >> put_ bh b -+ XCmd a -> -+ putByte bh 9 >> put_ bh a -+ HsCmdWrap {} -> -+ putPanic "HsCmdWrap" "HsCmd" -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsCmdArrApp <$> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ 1 -> HsCmdArrForm <$> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ 2 -> HsCmdApp <$> get bh <*> get bh <*> get bh -+ 3 -> HsCmdLam <$> get bh <*> get bh -+ 4 -> HsCmdPar <$> get bh <*> get bh -+ 5 -> HsCmdCase <$> get bh <*> get bh <*> get bh -+ 6 -> HsCmdIf <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ 7 -> HsCmdLet <$> get bh <*> get bh <*> get bh -+ 8 -> HsCmdDo <$> get bh <*> get bh -+ 9 -> XCmd <$> get bh -+ _ -> getPanic "HsCmd" -+ -+instance Binary HsArrAppType where -+ put_ bh t = putByte bh $ case t of -+ HsHigherOrderApp -> 0 -+ HsFirstOrderApp -> 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure HsHigherOrderApp -+ 1 -> pure HsFirstOrderApp -+ _ -> getPanic "HsArrAppType" -+ -+instance Binary TransForm where -+ put_ bh f = putByte bh $ case f of -+ ThenForm -> 0 -+ GroupForm -> 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure ThenForm -+ 1 -> pure GroupForm -+ _ -> getPanic "TransForm" -+ -+instance Binary (ApplicativeArg GhcSe) where -+ put_ bh a = case a of -+ ApplicativeArgOne a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ ApplicativeArgMany a b c d -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ XApplicativeArg a -> -+ putByte bh 2 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ApplicativeArgOne <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> ApplicativeArgMany <$> get bh <*> get bh <*> get bh <*> get bh -+ 2 -> XApplicativeArg <$> get bh -+ _ -> getPanic "ApplicativeArg" -+ -+instance Binary (ParStmtBlock GhcSe GhcSe) where -+ put_ bh b = case b of -+ ParStmtBlock a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ XParStmtBlock a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ParStmtBlock <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> XParStmtBlock <$> get bh -+ _ -> getPanic "ParStmtBlock" -+ -+instance Binary (SyntaxExpr GhcSe) where -+ put_ bh (SyntaxExpr a [] WpHole) = put_ bh a -+ put_ _ _ = panic "Binary SyntaxExpr.put: wrappers should be empty" -+ get bh = SyntaxExpr <$> get bh <*> pure [] <*> pure WpHole -+ -+instance Binary a => Binary (GRHSs GhcSe a) where -+ put_ bh g = case g of -+ GRHSs a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XGRHSs a -> putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> GRHSs <$> get bh <*> get bh <*> get bh -+ 1 -> XGRHSs <$> get bh -+ _ -> getPanic "GRHSs" -+ -+instance Binary a => Binary (GRHS GhcSe a) where -+ put_ bh g = case g of -+ GRHS a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XGRHS a -> putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> GRHS <$> get bh <*> get bh <*> get bh -+ 1 -> XGRHS <$> get bh -+ _ -> getPanic "GRHS" -+ -+instance Binary a => Binary (MatchGroup GhcSe a) where -+ put_ bh g = case g of -+ MG a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XMatchGroup a -> putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> MG <$> get bh <*> get bh <*> get bh -+ 1 -> XMatchGroup <$> get bh -+ _ -> getPanic "MatchGroup" -+ -+instance Binary a => Binary (Match GhcSe a) where -+ put_ bh m = case m of -+ Match a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ XMatch a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> Match <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> XMatch <$> get bh -+ _ -> getPanic "Match" -+ -+instance Binary (HsMatchContext SeName) where -+ put_ bh c = case c of -+ FunRhs a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ LambdaExpr -> -+ putByte bh 1 -+ CaseAlt -> -+ putByte bh 2 -+ IfAlt -> -+ putByte bh 3 -+ ProcExpr -> -+ putByte bh 4 -+ PatBindRhs -> -+ putByte bh 5 -+ RecUpd -> -+ putByte bh 6 -+ StmtCtxt a -> -+ putByte bh 7 >> put_ bh a -+ ThPatSplice -> -+ putByte bh 8 -+ ThPatQuote -> -+ putByte bh 9 -+ PatSyn -> -+ putByte bh 10 -+ PatBindGuards -> -+ putByte bh 11 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FunRhs <$> get bh <*> get bh <*> get bh -+ 1 -> pure LambdaExpr -+ 2 -> pure CaseAlt -+ 3 -> pure IfAlt -+ 4 -> pure ProcExpr -+ 5 -> pure PatBindRhs -+ 6 -> pure RecUpd -+ 7 -> StmtCtxt <$> get bh -+ 8 -> pure ThPatSplice -+ 9 -> pure ThPatQuote -+ 10 -> pure PatSyn -+ 11 -> pure PatBindGuards -+ _ -> getPanic "HsMatchContext" -+ -+instance Binary (HsStmtContext SeName) where -+ put_ bh c = case c of -+ ListComp -> putByte bh 0 -+ MonadComp -> putByte bh 1 -+ DoExpr -> putByte bh 3 -+ MDoExpr -> putByte bh 4 -+ ArrowExpr -> putByte bh 5 -+ GhciStmtCtxt -> putByte bh 6 -+ PatGuard a -> putByte bh 7 >> put_ bh a -+ ParStmtCtxt a -> putByte bh 8 >> put_ bh a -+ TransStmtCtxt a -> putByte bh 9 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure ListComp -+ 1 -> pure MonadComp -+ 3 -> pure DoExpr -+ 4 -> pure MDoExpr -+ 5 -> pure ArrowExpr -+ 6 -> pure GhciStmtCtxt -+ 7 -> PatGuard <$> get bh -+ 8 -> ParStmtCtxt <$> get bh -+ 9 -> TransStmtCtxt <$> get bh -+ _ -> getPanic "HsStmtContext" -+ -+instance Binary (ArithSeqInfo GhcSe) where -+ put_ bh i = case i of -+ From a -> -+ putByte bh 0 >> put_ bh a -+ FromThen a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ FromTo a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ FromThenTo a b c -> -+ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> From <$> get bh -+ 1 -> FromThen <$> get bh <*> get bh -+ 2 -> FromTo <$> get bh <*> get bh -+ 3 -> FromThenTo <$> get bh <*> get bh <*> get bh -+ _ -> getPanic "ArithSeqInfo" -+ -+instance Binary (HsTupArg GhcSe) where -+ put_ bh a = case a of -+ Present a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ Missing a -> putByte bh 1 >> put_ bh a -+ XTupArg a -> putByte bh 2 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> Present <$> get bh <*> get bh -+ 1 -> Missing <$> get bh -+ 2 -> XTupArg <$> get bh -+ _ -> getPanic "HsTupArg" -+ -+instance Binary (Pat GhcSe) where -+ put_ bh p = case p of -+ WildPat a -> -+ putByte bh 0 >> put_ bh a -+ VarPat a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ LazyPat a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ AsPat a b c -> -+ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -+ ParPat a b -> -+ putByte bh 4 >> put_ bh a >> put_ bh b -+ BangPat a b -> -+ putByte bh 5 >> put_ bh a >> put_ bh b -+ ListPat a b -> -+ putByte bh 6 >> put_ bh a >> put_ bh b -+ TuplePat a b c -> -+ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c -+ SumPat a b c d -> -+ putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ ConPatIn a b -> -+ putByte bh 9 >> put_ bh a >> put_ bh b -+ ViewPat a b c -> -+ putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -+ LitPat a b -> -+ putByte bh 11 >> put_ bh a >> put_ bh b -+ NPat a b c d -> -+ putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ NPlusKPat a b c d e f -> -+ putByte bh 13 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f -+ SigPat a b -> -+ putByte bh 14 >> put_ bh a >> put_ bh b -+ SplicePat a b -> -+ putByte bh 15 >> put_ bh a >> put_ bh b -+ XPat a -> -+ putByte bh 16 >> put_ bh a -+ ConPatOut {} -> putPanic "Pat" "ConPatOut" -+ CoPat {} -> putPanic "Pat" "CoPat" -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> WildPat <$> get bh -+ 1 -> VarPat <$> get bh <*> get bh -+ 2 -> LazyPat <$> get bh <*> get bh -+ 3 -> AsPat <$> get bh <*> get bh <*> get bh -+ 4 -> ParPat <$> get bh <*> get bh -+ 5 -> BangPat <$> get bh <*> get bh -+ 6 -> ListPat <$> get bh <*> get bh -+ 7 -> TuplePat <$> get bh <*> get bh <*> get bh -+ 8 -> SumPat <$> get bh <*> get bh <*> get bh <*> get bh -+ 9 -> ConPatIn <$> get bh <*> get bh -+ 10 -> ViewPat <$> get bh <*> get bh <*> get bh -+ 11 -> LitPat <$> get bh <*> get bh -+ 12 -> NPat <$> get bh <*> get bh <*> get bh <*> get bh -+ 13 -> NPlusKPat <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ 14 -> SigPat <$> get bh <*> get bh -+ 15 -> SplicePat <$> get bh <*> get bh -+ 16 -> XPat <$> get bh -+ _ -> getPanic "HsPat" -+ -+instance Binary NoExt where -+ put_ _ NoExt = return () -+ get _ = pure NoExt -+ -+instance (Binary (FieldOcc a), Binary b) => Binary (HsRecFields a b) where -+ put_ bh (HsRecFields a b) = put_ bh a >> put_ bh b -+ get bh = HsRecFields <$> get bh <*> get bh -+ -+instance (Binary id, Binary arg) => Binary (HsRecField' id arg) where -+ put_ bh (HsRecField a b c) = put_ bh a >> put_ bh b >> put_ bh c -+ get bh = HsRecField <$> get bh <*> get bh <*> get bh -+ -+instance Binary (HsType GhcSe) where -+ put_ bh t = case t of -+ HsForAllTy a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsQualTy a b c -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsTyVar a b c -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsAppTy a b c -> -+ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsFunTy a b c -> -+ putByte bh 4 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsListTy a b -> -+ putByte bh 5 >> put_ bh a >> put_ bh b -+ HsTupleTy a b c -> -+ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsSumTy a b -> -+ putByte bh 7 >> put_ bh a >> put_ bh b -+ HsOpTy a b c d -> -+ putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ HsParTy a b -> -+ putByte bh 9 >> put_ bh a >> put_ bh b -+ HsIParamTy a b c -> -+ putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsKindSig a b c -> -+ putByte bh 11 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsBangTy a b c -> -+ putByte bh 12 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsRecTy a b -> -+ putByte bh 13 >> put_ bh a >> put_ bh b -+ HsExplicitListTy a b c -> -+ putByte bh 14 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsExplicitTupleTy a b -> -+ putByte bh 15 >> put_ bh a >> put_ bh b -+ HsTyLit a b -> -+ putByte bh 16 >> put_ bh a >> put_ bh b -+ HsWildCardTy a -> -+ putByte bh 17 >> put_ bh a -+ HsDocTy a b c -> -+ putByte bh 18 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsSpliceTy a b -> -+ putByte bh 19 >> put_ bh a >> put_ bh b -+ HsStarTy a b -> -+ putByte bh 20 >> put_ bh a >> put_ bh b -+ XHsType _ -> -+ putPanic "XHsType" "HsType" -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsForAllTy <$> get bh <*> get bh <*> get bh -+ 1 -> HsQualTy <$> get bh <*> get bh <*> get bh -+ 2 -> HsTyVar <$> get bh <*> get bh <*> get bh -+ 3 -> HsAppTy <$> get bh <*> get bh <*> get bh -+ 4 -> HsFunTy <$> get bh <*> get bh <*> get bh -+ 5 -> HsListTy <$> get bh <*> get bh -+ 6 -> HsTupleTy <$> get bh <*> get bh <*> get bh -+ 7 -> HsSumTy <$> get bh <*> get bh -+ 8 -> HsOpTy <$> get bh <*> get bh <*> get bh <*> get bh -+ 9 -> HsParTy <$> get bh <*> get bh -+ 10 -> HsIParamTy <$> get bh <*> get bh <*> get bh -+ 11 -> HsKindSig <$> get bh <*> get bh <*> get bh -+ 12 -> HsBangTy <$> get bh <*> get bh <*> get bh -+ 13 -> HsRecTy <$> get bh <*> get bh -+ 14 -> HsExplicitListTy <$> get bh <*> get bh <*> get bh -+ 15 -> HsExplicitTupleTy <$> get bh <*> get bh -+ 16 -> HsTyLit <$> get bh <*> get bh -+ 17 -> HsWildCardTy <$> get bh -+ 18 -> HsDocTy <$> get bh <*> get bh <*> get bh -+ 19 -> HsSpliceTy <$> get bh <*> get bh -+ 20 -> HsStarTy <$> get bh <*> get bh -+ _ -> getPanic "HsType" -+ -+instance Binary HsTyLit where -+ put_ bh l = case l of -+ HsNumTy a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ HsStrTy a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsNumTy <$> get bh <*> get bh -+ 1 -> HsStrTy <$> get bh <*> get bh -+ _ -> getPanic "HsTyLit" -+ -+instance Binary a => Binary (HsWildCardBndrs GhcSe a) where -+ put_ bh w = case w of -+ HsWC a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ XHsWildCardBndrs a -> -+ putByte bh 1 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsWC <$> get bh <*> get bh -+ 1 -> XHsWildCardBndrs <$> get bh -+ _ -> getPanic "HsWildCardBndrs" -+ -+instance Binary a => Binary (HsImplicitBndrs GhcSe a) where -+ put_ bh b = case b of -+ HsIB a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ XHsImplicitBndrs a -> -+ putByte bh 1 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsIB <$> get bh <*> get bh -+ 1 -> XHsImplicitBndrs <$> get bh -+ _ -> getPanic "HsImplicitBndrs" -+ -+instance Binary HsTupleSort where -+ put_ bh s = putByte bh (case s of -+ HsUnboxedTuple -> 0 -+ HsBoxedTuple -> 1 -+ HsConstraintTuple -> 2 -+ HsBoxedOrConstraintTuple -> 3) -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure HsUnboxedTuple -+ 1 -> pure HsBoxedTuple -+ 2 -> pure HsConstraintTuple -+ 3 -> pure HsBoxedOrConstraintTuple -+ _ -> getPanic "HsTupleSort" -+ -+instance Binary (ConDeclField GhcSe) where -+ put_ bh f = case f of -+ ConDeclField a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ XConDeclField a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ConDeclField <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> XConDeclField <$> get bh -+ _ -> getPanic "ConDeclField" -+ -+instance Binary (FieldOcc GhcSe) where -+ put_ bh o = case o of -+ FieldOcc a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ XFieldOcc a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FieldOcc <$> get bh <*> get bh -+ 1 -> XFieldOcc <$> get bh -+ _ -> getPanic "FieldOcc" -+ -+instance Binary (HsTyVarBndr GhcSe) where -+ put_ bh v = case v of -+ UserTyVar a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ KindedTyVar a b c -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ XTyVarBndr a -> -+ putByte bh 2 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> UserTyVar <$> get bh <*> get bh -+ 1 -> KindedTyVar <$> get bh <*> get bh <*> get bh -+ 2 -> XTyVarBndr <$> get bh -+ _ -> getPanic "HsTyVarBndr" -+ -+instance (Binary a, Binary b) => Binary (HsConDetails a b) where -+ put_ bh c = case c of -+ PrefixCon a -> putByte bh 0 >> put_ bh a -+ RecCon a -> putByte bh 1 >> put_ bh a -+ InfixCon a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> PrefixCon <$> get bh -+ 1 -> RecCon <$> get bh -+ 2 -> InfixCon <$> get bh <*> get bh -+ _ -> getPanic "HsConDetails" -+ -+instance Binary (AmbiguousFieldOcc GhcSe) where -+ put_ bh o = case o of -+ Unambiguous a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ Ambiguous a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ XAmbiguousFieldOcc a -> -+ putByte bh 2 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> Unambiguous <$> get bh <*> get bh -+ 1 -> Ambiguous <$> get bh <*> get bh -+ 2 -> XAmbiguousFieldOcc <$> get bh -+ _ -> getPanic "AmbiguousOccField" -+ -+instance Binary (LHsQTyVars GhcSe) where -+ put_ bh v = case v of -+ HsQTvs a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ XLHsQTyVars a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsQTvs <$> get bh <*> get bh -+ 1 -> XLHsQTyVars <$> get bh -+ _ -> getPanic "LHsQTyVars" -+ -+instance Binary (Sig GhcSe) where -+ put_ bh s = case s of -+ TypeSig a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ PatSynSig a b c -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ ClassOpSig a b c d -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ IdSig a b -> -+ putByte bh 3 >> put_ bh a >> put_ bh b -+ FixSig a b -> -+ putByte bh 4 >> put_ bh a >> put_ bh b -+ InlineSig a b c -> -+ putByte bh 5 >> put_ bh a >> put_ bh b >> put_ bh c -+ SpecSig a b c d -> -+ putByte bh 6 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ SpecInstSig a b c -> -+ putByte bh 7 >> put_ bh a >> put_ bh b >> put_ bh c -+ SCCFunSig a b c d -> -+ putByte bh 8 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ CompleteMatchSig a b c d -> -+ putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ MinimalSig a b c -> -+ putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -+ XSig a -> -+ putByte bh 11 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> TypeSig <$> get bh <*> get bh <*> get bh -+ 1 -> PatSynSig <$> get bh <*> get bh <*> get bh -+ 2 -> ClassOpSig <$> get bh <*> get bh <*> get bh <*> get bh -+ 3 -> IdSig <$> get bh <*> get bh -+ 4 -> FixSig <$> get bh <*> get bh -+ 5 -> InlineSig <$> get bh <*> get bh <*> get bh -+ 6 -> SpecSig <$> get bh <*> get bh <*> get bh <*> get bh -+ 7 -> SpecInstSig <$> get bh <*> get bh <*> get bh -+ 8 -> SCCFunSig <$> get bh <*> get bh <*> get bh <*> get bh -+ 9 -> CompleteMatchSig <$> get bh <*> get bh <*> get bh <*> get bh -+ 10 -> MinimalSig <$> get bh <*> get bh <*> get bh -+ 11 -> XSig <$> get bh -+ _ -> getPanic "Sig" -+ -+instance Binary (FixitySig GhcSe) where -+ put_ bh s = case s of -+ FixitySig a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XFixitySig a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FixitySig <$> get bh <*> get bh <*> get bh -+ 1 -> XFixitySig <$> get bh -+ _ -> getPanic "FixitySig" -+ -+instance Binary (HsBindLR GhcSe GhcSe) where -+ put_ bh b = case b of -+ -- TODO: we drop the "fun_co_fn" field, as it seems -+ -- to always be WpHole in the places where the binary -+ -- serialisation instances will be used. -+ -- TODO: we drop the "fun_tick" field, as it is unlikely -+ -- to be used in our immediate use cases. Let's -+ -- return to parametrising away the 'Id' in that -+ -- field's type. -+ FunBind a b c d _ -> case d of -+ WpHole -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ _ -> -+ panic "Binary HsBindLR: FunBind with non-WpHole value in fun_co_fn" -+ -- TODO: same as for FunBind, we drop pat_ticks -+ PatBind a b c _ -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ VarBind a b c d -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ PatSynBind a b -> -+ putByte bh 3 >> put_ bh a >> put_ bh b -+ XHsBindsLR a -> -+ putByte bh 4 >> put_ bh a -+ AbsBinds {} -> putPanic "HsBindsLR" "AbsBinds" -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FunBind <$> get bh <*> get bh <*> get bh <*> pure WpHole <*> pure [] -+ 1 -> PatBind <$> get bh <*> get bh <*> get bh <*> pure ([], []) -+ 2 -> VarBind <$> get bh <*> get bh <*> get bh <*> get bh -+ 3 -> PatSynBind <$> get bh <*> get bh -+ 4 -> XHsBindsLR <$> get bh -+ _ -> getPanic "HsBindsLR" -+ -+instance Binary (HsLocalBindsLR GhcSe GhcSe) where -+ put_ bh b = case b of -+ HsValBinds a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ EmptyLocalBinds a -> putByte bh 1 >> put_ bh a -+ XHsLocalBindsLR a -> putByte bh 2 >> put_ bh a -+ HsIPBinds {} -> putPanic "HsLocalBindsLR" "HsIPBinds" -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsValBinds <$> get bh <*> get bh -+ 1 -> EmptyLocalBinds <$> get bh -+ 2 -> XHsLocalBindsLR <$> get bh -+ _ -> getPanic "HsLocalBindsLR" -+ -+instance Binary (HsValBindsLR GhcSe GhcSe) where -+ put_ bh b = case b of -+ ValBinds a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XValBindsLR {} -> putPanic "HsValBindsLR" "ValBindsOut" -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ValBinds <$> get bh <*> get bh <*> get bh -+ _ -> getPanic "HsValBindsLR" -+ -+instance Binary (PatSynBind GhcSe GhcSe) where -+ put_ bh b = case b of -+ PSB a b c d e -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e -+ XPatSynBind a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> PSB <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> XPatSynBind <$> get bh -+ _ -> getPanic "PatSynBind" -+ -+instance Binary (HsPatSynDir GhcSe) where -+ put_ bh d = case d of -+ Unidirectional -> putByte bh 0 -+ ImplicitBidirectional -> putByte bh 1 -+ ExplicitBidirectional a -> putByte bh 2 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure Unidirectional -+ 1 -> pure ImplicitBidirectional -+ 2 -> ExplicitBidirectional <$> get bh -+ _ -> getPanic "HsPatSynDir" -+ -+instance Binary a => Binary (RecordPatSynField a) where -+ put_ bh (RecordPatSynField a b) = put_ bh a >> put_ bh b -+ get bh = RecordPatSynField <$> get bh <*> get bh -+ -+instance Binary (IPBind GhcSe) where -+ put_ bh i = case i of -+ IPBind a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XIPBind a -> putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> IPBind <$> get bh <*> get bh <*> get bh -+ 1 -> XIPBind <$> get bh -+ _ -> getPanic "IPBind" -+ -+-- * HsDecls -+ -+instance Binary (HsDecl GhcSe) where -+ put_ bh d = case d of -+ TyClD a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ InstD a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ DerivD a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ ValD a b -> putByte bh 3 >> put_ bh a >> put_ bh b -+ SigD a b -> putByte bh 4 >> put_ bh a >> put_ bh b -+ DefD a b -> putByte bh 5 >> put_ bh a >> put_ bh b -+ ForD a b -> putByte bh 6 >> put_ bh a >> put_ bh b -+ WarningD a b -> putByte bh 7 >> put_ bh a >> put_ bh b -+ RoleAnnotD a b -> putByte bh 8 >> put_ bh a >> put_ bh b -+ RuleD a b -> putByte bh 9 >> put_ bh a >> put_ bh b -+ AnnD a b -> putByte bh 10 >> put_ bh a >> put_ bh b -+ SpliceD a b -> putByte bh 11 >> put_ bh a >> put_ bh b -+ DocD a b -> putByte bh 12 >> put_ bh a >> put_ bh b -+ XHsDecl a -> putByte bh 13 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> TyClD <$> get bh <*> get bh -+ 1 -> InstD <$> get bh <*> get bh -+ 2 -> DerivD <$> get bh <*> get bh -+ 3 -> ValD <$> get bh <*> get bh -+ 4 -> SigD <$> get bh <*> get bh -+ 5 -> DefD <$> get bh <*> get bh -+ 6 -> ForD <$> get bh <*> get bh -+ 7 -> WarningD <$> get bh <*> get bh -+ 8 -> RoleAnnotD <$> get bh <*> get bh -+ 9 -> RuleD <$> get bh <*> get bh -+ 10 -> AnnD <$> get bh <*> get bh -+ 11 -> SpliceD <$> get bh <*> get bh -+ 12 -> DocD <$> get bh <*> get bh -+ 13 -> XHsDecl <$> get bh -+ _ -> getPanic "HsDecl" -+ -+instance Binary (ForeignDecl GhcSe) where -+ put_ bh d = case d of -+ ForeignImport a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ ForeignExport a b c d -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d -+ XForeignDecl a -> -+ putByte bh 2 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ForeignImport <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> ForeignExport <$> get bh <*> get bh <*> get bh <*> get bh -+ 2 -> XForeignDecl <$> get bh -+ _ -> getPanic "ForeignDecl" -+ -+instance Binary (DefaultDecl GhcSe) where -+ put_ bh d = case d of -+ DefaultDecl a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ XDefaultDecl a -> putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> DefaultDecl <$> get bh <*> get bh -+ 1 -> XDefaultDecl <$> get bh -+ _ -> getPanic "DefaultDecl" -+ -+instance Binary (TyClDecl GhcSe) where -+ put_ bh d = case d of -+ FamDecl a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ SynDecl a b c d e -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ DataDecl a b c d e -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e -+ ClassDecl a b c d e f g h i j k -> -+ putByte bh 3 >> put_ bh a >> put_ bh b >> put_ bh c -+ >> put_ bh d >> put_ bh e >> put_ bh f -+ >> put_ bh g >> put_ bh h >> put_ bh i -+ >> put_ bh j >> put_ bh k -+ XTyClDecl a -> -+ putByte bh 4 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FamDecl <$> get bh <*> get bh -+ 1 -> SynDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ 2 -> DataDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ 3 -> ClassDecl <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh -+ 4 -> XTyClDecl <$> get bh -+ _ -> getPanic "TyClDecl" -+ -+instance Binary DocDecl where -+ put_ bh d = case d of -+ DocCommentNext a -> putByte bh 0 >> put_ bh a -+ DocCommentPrev a -> putByte bh 1 >> put_ bh a -+ DocCommentNamed a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ DocGroup a b -> putByte bh 3 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> DocCommentNext <$> get bh -+ 1 -> DocCommentPrev <$> get bh -+ 2 -> DocCommentNamed <$> get bh <*> get bh -+ 3 -> DocGroup <$> get bh <*> get bh -+ _ -> getPanic "DocDecl" -+ -+instance Binary (WarnDecls GhcSe) where -+ put_ bh d = case d of -+ Warnings a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XWarnDecls a -> putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> Warnings <$> get bh <*> get bh <*> get bh -+ 1 -> XWarnDecls <$> get bh -+ _ -> getPanic "WarnDecls" -+ -+instance Binary (WarnDecl GhcSe) where -+ put_ bh d = case d of -+ Warning a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XWarnDecl a -> putByte bh 1 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> Warning <$> get bh <*> get bh <*> get bh -+ 1 -> XWarnDecl <$> get bh -+ _ -> getPanic "WarnDecl" -+ -+instance Binary (RoleAnnotDecl GhcSe) where -+ put_ bh d = case d of -+ RoleAnnotDecl a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XRoleAnnotDecl a -> putByte bh 1 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> RoleAnnotDecl <$> get bh <*> get bh <*> get bh -+ 1 -> XRoleAnnotDecl <$> get bh -+ _ -> getPanic "RoleAnnotDecl" -+ -+instance Binary (RuleDecls GhcSe) where -+ put_ bh d = case d of -+ HsRules a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XRuleDecls a -> putByte bh 1 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsRules <$> get bh <*> get bh <*> get bh -+ 1 -> XRuleDecls <$> get bh -+ _ -> getPanic "RuleDecls" -+ -+instance Binary (RuleDecl GhcSe) where -+ put_ bh decl = case decl of -+ HsRule a b c d e f -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f -+ XRuleDecl a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsRule <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ 1 -> XRuleDecl <$> get bh -+ _ -> getPanic "RuleDecl" -+ -+instance Binary (AnnDecl GhcSe) where -+ put_ bh decl = case decl of -+ HsAnnotation a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ XAnnDecl a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsAnnotation <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> XAnnDecl <$> get bh -+ _ -> getPanic "AnnDecl" -+ -+instance Binary (SpliceDecl GhcSe) where -+ put_ bh d = case d of -+ SpliceDecl a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XSpliceDecl a -> putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> SpliceDecl <$> get bh <*> get bh <*> get bh -+ 1 -> XSpliceDecl <$> get bh -+ _ -> getPanic "SpliceDecl" -+ -+instance Binary a => Binary (Tickish a) where -+ put_ bh t = case t of -+ ProfNote a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ HpcTick a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ Breakpoint a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ SourceNote a b -> -+ putByte bh 3 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ProfNote <$> get bh <*> get bh <*> get bh -+ 1 -> HpcTick <$> get bh <*> get bh -+ 2 -> Breakpoint <$> get bh <*> get bh -+ 3 -> SourceNote <$> get bh <*> get bh -+ _ -> getPanic "Tickish" -+ -+instance Binary SpliceExplicitFlag where -+ put_ bh f = putByte bh $ case f of -+ ExplicitSplice -> 0 -+ ImplicitSplice -> 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure ExplicitSplice -+ 1 -> pure ImplicitSplice -+ _ -> getPanic "SpliceExplicitFlag" -+ -+instance Binary SpliceDecoration where -+ put_ bh d = putByte bh $ case d of -+ HasParens -> 0 -+ HasDollar -> 1 -+ NoParens -> 2 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure HasParens -+ 1 -> pure HasDollar -+ 2 -> pure NoParens -+ _ -> getPanic "SpliceDecoration" -+ -+instance Binary (HsSplice GhcSe) where -+ put_ bh s = case s of -+ HsTypedSplice a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ HsUntypedSplice a b c d -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ HsQuasiQuote a b c d e -> -+ putByte bh 2 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e -+ XSplice a -> -+ putByte bh 3 >> put_ bh a -+ HsSpliced {} -> putPanic "HsSplice" "HsSpliced" -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsTypedSplice <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> HsUntypedSplice <$> get bh <*> get bh <*> get bh <*> get bh -+ 2 -> HsQuasiQuote <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh -+ 3 -> XSplice <$> get bh -+ _ -> getPanic "HsSplice" -+ -+instance Binary (AnnProvenance SeName) where -+ put_ bh p = case p of -+ ValueAnnProvenance a -> putByte bh 0 >> put_ bh a -+ TypeAnnProvenance a -> putByte bh 1 >> put_ bh a -+ ModuleAnnProvenance -> putByte bh 2 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ValueAnnProvenance <$> get bh -+ 1 -> TypeAnnProvenance <$> get bh -+ 2 -> pure ModuleAnnProvenance -+ _ -> getPanic "AnnProvenance" -+ -+instance Binary ForeignImport where -+ put_ bh (CImport a b c d e) = -+ put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e -+ get bh = CImport <$> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh -+ -+instance Binary CImportSpec where -+ put_ bh s = case s of -+ CLabel a -> putByte bh 0 >> put_ bh a -+ CFunction a -> putByte bh 1 >> put_ bh a -+ CWrapper -> putByte bh 2 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> CLabel <$> get bh -+ 1 -> CFunction <$> get bh -+ 2 -> pure CWrapper -+ _ -> getPanic "CImportSpec" -+ -+instance Binary ForeignExport where -+ put_ bh (CExport a b) = put_ bh a >> put_ bh b -+ get bh = CExport <$> get bh <*> get bh -+ -+instance Binary (RuleBndr GhcSe) where -+ put_ bh b = case b of -+ RuleBndr a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ RuleBndrSig a b c -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c -+ XRuleBndr a -> -+ putByte bh 2 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> RuleBndr <$> get bh <*> get bh -+ 1 -> RuleBndrSig <$> get bh <*> get bh <*> get bh -+ 2 -> XRuleBndr <$> get bh -+ _ -> getPanic "RuleBndr" -+ -+instance (Binary a, Binary b) => Binary (FamEqn GhcSe a b) where -+ put_ bh e = case e of -+ FamEqn a b c d e -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e -+ XFamEqn a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FamEqn <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh -+ 1 -> XFamEqn <$> get bh -+ _ -> getPanic "FamEqn" -+ -+instance Binary (HsDataDefn GhcSe) where -+ put_ bh d = case d of -+ HsDataDefn a b c d e f g -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g -+ XHsDataDefn a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsDataDefn <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh -+ 1 -> XHsDataDefn <$> get bh -+ _ -> getPanic "HsDataDefn" -+ -+instance Binary NewOrData where -+ put_ bh a = putByte bh (case a of -+ NewType -> 0 -+ DataType -> 1) -+ get bh = getByte bh >>= \b -> case b of -+ 0 -> pure NewType -+ 1 -> pure DataType -+ _ -> getPanic "NewOrData" -+ -+instance Binary (HsDerivingClause GhcSe) where -+ put_ bh c = case c of -+ HsDerivingClause a b c -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XHsDerivingClause a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsDerivingClause <$> get bh <*> get bh <*> get bh -+ 1 -> XHsDerivingClause <$> get bh -+ _ -> getPanic "HsDerivingClause" -+ -+instance Binary (ConDecl GhcSe) where -+ put_ bh d = case d of -+ ConDeclGADT a b c d e f g h -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g >> put_ bh h -+ ConDeclH98 a b c d e f g -> -+ putByte bh 1 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g -+ XConDecl a -> -+ putByte bh 2 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ConDeclGADT <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> ConDeclH98 <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh -+ 2 -> XConDecl <$> get bh -+ _ -> getPanic "ConDecl" -+ -+ -+instance Binary (FamilyDecl GhcSe) where -+ put_ bh d = case d of -+ FamilyDecl a b c d e f g -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g -+ XFamilyDecl a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> FamilyDecl <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh -+ 1 -> XFamilyDecl <$> get bh -+ _ -> getPanic "FamilyDecl" -+ -+instance Binary (InjectivityAnn GhcSe) where -+ put_ bh a = case a of -+ InjectivityAnn a b -> put_ bh a >> put_ bh b -+ get bh = InjectivityAnn <$> get bh <*> get bh -+ -+instance Binary (FamilyInfo GhcSe) where -+ put_ bh i = case i of -+ DataFamily -> -+ putByte bh 0 -+ OpenTypeFamily -> -+ putByte bh 1 -+ ClosedTypeFamily a -> -+ putByte bh 2 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure DataFamily -+ 1 -> pure OpenTypeFamily -+ 2 -> ClosedTypeFamily <$> get bh -+ _ -> getPanic "FamilyInfo" -+ -+instance Binary (FamilyResultSig GhcSe) where -+ put_ bh s = case s of -+ NoSig a -> -+ putByte bh 0 >> put_ bh a -+ KindSig a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ TyVarSig a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ XFamilyResultSig a -> -+ putByte bh 3 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> NoSig <$> get bh -+ 1 -> KindSig <$> get bh <*> get bh -+ 2 -> TyVarSig <$> get bh <*> get bh -+ 3 -> XFamilyResultSig <$> get bh -+ _ -> getPanic "FamilyResultSig" -+ -+instance Binary (InstDecl GhcSe) where -+ put_ bh d = case d of -+ ClsInstD a b -> -+ putByte bh 0 >> put_ bh a >> put_ bh b -+ DataFamInstD a b -> -+ putByte bh 1 >> put_ bh a >> put_ bh b -+ TyFamInstD a b -> -+ putByte bh 2 >> put_ bh a >> put_ bh b -+ XInstDecl a -> -+ putByte bh 3 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ClsInstD <$> get bh <*> get bh -+ 1 -> DataFamInstD <$> get bh <*> get bh -+ 2 -> TyFamInstD <$> get bh <*> get bh -+ 3 -> XInstDecl <$> get bh -+ _ -> getPanic "InstDecl" -+ -+instance Binary (ClsInstDecl GhcSe) where -+ put_ bh d = case d of -+ ClsInstDecl a b c d e f g -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ >> put_ bh e >> put_ bh f >> put_ bh g -+ XClsInstDecl a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ClsInstDecl <$> get bh <*> get bh <*> get bh <*> get bh -+ <*> get bh <*> get bh <*> get bh -+ 1 -> XClsInstDecl <$> get bh -+ _ -> getPanic "ClsInstDecl" -+ -+instance Binary (DataFamInstDecl GhcSe) where -+ put_ bh (DataFamInstDecl a) = put_ bh a -+ get bh = DataFamInstDecl <$> get bh -+ -+instance Binary (TyFamInstDecl GhcSe) where -+ put_ bh (TyFamInstDecl a) = put_ bh a -+ get bh = TyFamInstDecl <$> get bh -+ -+instance Binary (DerivDecl GhcSe) where -+ put_ bh d = case d of -+ DerivDecl a b c d -> -+ putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c >> put_ bh d -+ XDerivDecl a -> -+ putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> DerivDecl <$> get bh <*> get bh <*> get bh <*> get bh -+ 1 -> XDerivDecl <$> get bh -+ _ -> getPanic "DerivDecl" -+ -+instance Binary (DerivStrategy GhcSe) where -+ put_ bh s = case s of -+ StockStrategy -> putByte bh 0 -+ AnyclassStrategy -> putByte bh 1 -+ NewtypeStrategy -> putByte bh 2 -+ ViaStrategy a -> putByte bh 3 >> put_ bh a -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure StockStrategy -+ 1 -> pure AnyclassStrategy -+ 2 -> pure NewtypeStrategy -+ 3 -> ViaStrategy <$> get bh -+ _ -> getPanic "DerivStrategy" -+ -+instance Binary HsSrcBang where -+ put_ bh (HsSrcBang a b c) = -+ put_ bh a >> put_ bh b >> put_ bh c -+ get bh = HsSrcBang <$> get bh <*> get bh <*> get bh -+ -+instance Binary RdrName where -+ put_ bh n = case n of -+ Unqual a -> putByte bh 0 >> put_ bh a -+ Qual a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ Orig a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ Exact a -+ | isExternalName a -> putByte bh 3 >> put_ bh a -+ | otherwise -> putByte bh (if isSystemName a then 4 else 5) -+ >> put_ bh (nameUnique a) >> put_ bh (nameOccName a) -+ >> put_ bh (nameSrcSpan a) -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> Unqual <$> get bh -+ 1 -> Qual <$> get bh <*> get bh -+ 2 -> Orig <$> get bh <*> get bh -+ 3 -> Exact <$> get bh -+ 4 -> fmap Exact (mkSystemNameAt <$> get bh <*> get bh <*> get bh) -+ 5 -> fmap Exact (mkInternalName <$> get bh <*> get bh <*> get bh) -+ _ -> getPanic "RdrName" -+ -+-- * HsLit -+ -+instance Binary (HsLit GhcSe) where -+ put_ bh lit -+ = case lit of -+ HsChar a b -> putByte bh 0 >> put_ bh a >> put_ bh b -+ HsCharPrim a b -> putByte bh 1 >> put_ bh a >> put_ bh b -+ HsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ HsStringPrim a b -> putByte bh 3 >> put_ bh a >> put_ bh b -+ HsInt a b -> putByte bh 4 >> put_ bh a >> put_ bh b -+ HsIntPrim a b -> putByte bh 5 >> put_ bh a >> put_ bh b -+ HsWordPrim a b -> putByte bh 6 >> put_ bh a >> put_ bh b -+ HsInt64Prim a b -> putByte bh 7 >> put_ bh a >> put_ bh b -+ HsWord64Prim a b -> putByte bh 8 >> put_ bh a >> put_ bh b -+ HsInteger a b c -> putByte bh 9 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsRat a b c -> putByte bh 10 >> put_ bh a >> put_ bh b >> put_ bh c -+ HsFloatPrim a b -> putByte bh 11 >> put_ bh a >> put_ bh b -+ HsDoublePrim a b -> putByte bh 12 >> put_ bh a >> put_ bh b -+ XLit a -> putByte bh 13 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsChar <$> get bh <*> get bh -+ 1 -> HsCharPrim <$> get bh <*> get bh -+ 2 -> HsString <$> get bh <*> get bh -+ 3 -> HsStringPrim <$> get bh <*> get bh -+ 4 -> HsInt <$> get bh <*> get bh -+ 5 -> HsIntPrim <$> get bh <*> get bh -+ 6 -> HsWordPrim <$> get bh <*> get bh -+ 7 -> HsInt64Prim <$> get bh <*> get bh -+ 8 -> HsWord64Prim <$> get bh <*> get bh -+ 9 -> HsInteger <$> get bh <*> get bh <*> get bh -+ 10 -> HsRat <$> get bh <*> get bh <*> get bh -+ 11 -> HsFloatPrim <$> get bh <*> get bh -+ 12 -> HsDoublePrim <$> get bh <*> get bh -+ 13 -> XLit <$> get bh -+ _ -> getPanic "HsLit" -+ -+instance Binary (HsOverLit GhcSe) where -+ put_ bh lit = case lit of -+ OverLit a b c -> putByte bh 0 >> put_ bh a >> put_ bh b >> put_ bh c -+ XOverLit a -> putByte bh 1 >> put_ bh a -+ -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> OverLit <$> get bh <*> get bh <*> get bh -+ 1 -> XOverLit <$> get bh -+ _ -> getPanic "HsOverLit" -+ -+instance Binary Promoted where -+ get bh = getByte bh >>= \tag -> case tag of -+ 0 -> pure Promoted -+ 1 -> pure NotPromoted -+ _ -> getPanic "Promoted" -+ -+ put_ bh p = putByte bh $ case p of -+ Promoted -> 0 -+ NotPromoted -> 1 -+ -+instance Binary RealSrcLoc where -+ put_ bh l = do -+ put_ bh (srcLocFile l) -+ put_ bh (srcLocLine l) -+ put_ bh (srcLocCol l) -+ -+ get bh = mkRealSrcLoc <$> get bh <*> get bh <*> get bh -+ -+instance Binary RealSrcSpan where -+ put_ bh s = put_ bh (realSrcSpanStart s) >> put_ bh (realSrcSpanEnd s) -+ -+ get bh = do -+ loc1 <- get bh -+ loc2 <- get bh -+ return (mkRealSrcSpan loc1 loc2) -+ -+instance Binary OverLitVal where -+ put_ bh v -+ = case v of -+ HsIntegral a -> putByte bh 0 >> put_ bh a -+ HsFractional a -> putByte bh 1 >> put_ bh a -+ HsIsString a b -> putByte bh 2 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> HsIntegral <$> get bh -+ 1 -> HsFractional <$> get bh -+ 2 -> HsIsString <$> get bh <*> get bh -+ _ -> getPanic "OverLitVal" -diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs -index a7c467dce4..a488da00a7 100644 ---- a/compiler/hsSyn/HsExtension.hs -+++ b/compiler/hsSyn/HsExtension.hs -@@ -23,10 +23,15 @@ import Data.Data hiding ( Fixity ) - import PlaceHolder - import Name - import RdrName -+import SeName - import Var -+import IfaceType ( IfaceType ) - import Outputable - import SrcLoc (Located) - -+import Data.Kind -+import qualified Type -+ - {- - Note [Trees that grow] - ~~~~~~~~~~~~~~~~~~~~~~ -@@ -68,20 +73,22 @@ data GhcPass (c :: Pass) - deriving instance Eq (GhcPass c) - deriving instance Typeable c => Data (GhcPass c) - --data Pass = Parsed | Renamed | Typechecked -+data Pass = Parsed | Renamed | Typechecked | Serialisable - deriving (Data) - - -- Type synonyms as a shorthand for tagging --type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param --type GhcRn = GhcPass 'Renamed -- Old 'Name' type param --type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, --type GhcTcId = GhcTc -- Old 'TcId' type param -+type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param -+type GhcRn = GhcPass 'Renamed -- Old 'Name' type param -+type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, -+type GhcSe = GhcPass 'Serialisable -- New pass, with serialisable AST representations -+type GhcTcId = GhcTc -- Old 'TcId' type param - - -- | Maps the "normal" id type for a given pass - type family IdP p - type instance IdP GhcPs = RdrName - type instance IdP GhcRn = Name - type instance IdP GhcTc = Id -+type instance IdP GhcSe = SeName - - type LIdP p = Located (IdP p) - -@@ -1105,4 +1112,34 @@ type OutputableBndrId id = - ( OutputableBndr (NameOrRdrName (IdP id)) - , OutputableBndr (IdP id) - , OutputableX id -+ , OutputableBndr (RdrOrSeName id) -+ , OutputableBndr (IdSigId id) -+ , VarType (IdSigId id) - ) -+ -+class VarType a where -+ getVarType :: a -> Maybe Type.Type -+ -+instance VarType Var where -+ getVarType = Just . varType -+ -+instance VarType SeName where -+ getVarType _ = Nothing -+ -+type family IdSigId pass where -+ IdSigId GhcSe = SeName -+ IdSigId (GhcPass _) = Id -+ -+type family LitType x where -+ LitType (GhcPass 'Serialisable) = IfaceType -+ LitType a = Type.Type -+ -+type family DoName pass where -+ DoName GhcSe = SeName -+ DoName (GhcPass _) = Name -+ -+type family RdrOrSeName pass -+type instance RdrOrSeName GhcSe = SeName -+type instance RdrOrSeName GhcRn = RdrName -+type instance RdrOrSeName GhcTc = RdrName -+type instance RdrOrSeName GhcPs = RdrName -diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs -index 39bd9b7e18..9da47f62f1 100644 ---- a/compiler/hsSyn/HsImpExp.hs -+++ b/compiler/hsSyn/HsImpExp.hs -@@ -12,6 +12,7 @@ HsImpExp: Abstract syntax: imports, exports, interfaces - {-# LANGUAGE TypeFamilies #-} - {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -+{-# LANGUAGE TypeFamilies #-} - - module HsImpExp where - -diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs -index d1411bd750..9546b0de30 100644 ---- a/compiler/hsSyn/HsLit.hs -+++ b/compiler/hsSyn/HsLit.hs -@@ -13,7 +13,7 @@ - -- in module PlaceHolder - {-# LANGUAGE ConstraintKinds #-} - {-# LANGUAGE TypeFamilies #-} -- -+{-# LANGUAGE DataKinds #-} - module HsLit where - - #include "HsVersions.h" -@@ -63,11 +63,11 @@ data HsLit x - -- ^ literal @Int64#@ - | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer - -- ^ literal @Word64#@ -- | HsInteger (XHsInteger x) {- SourceText -} Integer Type -+ | HsInteger (XHsInteger x) {- SourceText -} Integer (LitType x) - -- ^ Genuinely an integer; arises only - -- from TRANSLATION (overloaded - -- literals are done with HsOverLit) -- | HsRat (XHsRat x) FractionalLit Type -+ | HsRat (XHsRat x) FractionalLit (LitType x) - -- ^ Genuinely a rational; arises only from - -- TRANSLATION (overloaded literals are - -- done with HsOverLit) -@@ -128,6 +128,7 @@ data OverLitTc - type instance XOverLit GhcPs = NoExt - type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] - type instance XOverLit GhcTc = OverLitTc -+type instance XOverLit GhcSe = NoExt - - type instance XXOverLit (GhcPass _) = NoExt - -@@ -151,7 +152,7 @@ overLitType XOverLit{} = panic "overLitType" - - -- | Convert a literal from one index type to another, updating the annotations - -- according to the relevant 'Convertable' instance --convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b -+convertLit :: (ConvertIdX a b, LitType a ~ LitType b) => HsLit a -> HsLit b - convertLit (HsChar a x) = (HsChar (convert a) x) - convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x) - convertLit (HsString a x) = (HsString (convert a) x) -diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs -index 6f65487411..aa7e9989a2 100644 ---- a/compiler/hsSyn/HsPat.hs -+++ b/compiler/hsSyn/HsPat.hs -@@ -282,6 +282,7 @@ data ListPatTc - type instance XWildPat GhcPs = NoExt - type instance XWildPat GhcRn = NoExt - type instance XWildPat GhcTc = Type -+type instance XWildPat GhcSe = NoExt - - type instance XVarPat (GhcPass _) = NoExt - type instance XLazyPat (GhcPass _) = NoExt -@@ -295,18 +296,22 @@ type instance XBangPat (GhcPass _) = NoExt - type instance XListPat GhcPs = NoExt - type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) - type instance XListPat GhcTc = ListPatTc -+type instance XListPat GhcSe = NoExt - - type instance XTuplePat GhcPs = NoExt - type instance XTuplePat GhcRn = NoExt - type instance XTuplePat GhcTc = [Type] -+type instance XTuplePat GhcSe = NoExt - - type instance XSumPat GhcPs = NoExt - type instance XSumPat GhcRn = NoExt - type instance XSumPat GhcTc = [Type] -+type instance XSumPat GhcSe = NoExt - - type instance XViewPat GhcPs = NoExt - type instance XViewPat GhcRn = NoExt - type instance XViewPat GhcTc = Type -+type instance XViewPat GhcSe = NoExt - - type instance XSplicePat (GhcPass _) = NoExt - type instance XLitPat (GhcPass _) = NoExt -@@ -314,14 +319,17 @@ type instance XLitPat (GhcPass _) = NoExt - type instance XNPat GhcPs = NoExt - type instance XNPat GhcRn = NoExt - type instance XNPat GhcTc = Type -+type instance XNPat GhcSe = NoExt - - type instance XNPlusKPat GhcPs = NoExt - type instance XNPlusKPat GhcRn = NoExt - type instance XNPlusKPat GhcTc = Type -+type instance XNPlusKPat GhcSe = NoExt - - type instance XSigPat GhcPs = (LHsSigWcType GhcPs) - type instance XSigPat GhcRn = (LHsSigWcType GhcRn) - type instance XSigPat GhcTc = Type -+type instance XSigPat GhcSe = (LHsSigWcType GhcSe) - - type instance XCoPat (GhcPass _) = NoExt - type instance XXPat (GhcPass _) = NoExt -@@ -457,7 +465,9 @@ hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl - hsRecFieldId :: HsRecField GhcTc arg -> Located Id - hsRecFieldId = hsRecFieldSel - --hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName -+hsRecUpdFieldRdr -+ :: RdrOrSeName (GhcPass p) ~ RdrName -+ => HsRecUpdField (GhcPass p) -> Located RdrName - hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl - - hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id -@@ -557,7 +567,7 @@ pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 - , pprParendLPat appPrec p2 ] - pprConArgs (RecCon rpats) = ppr rpats - --instance (Outputable arg) -+instance (Outputable arg, Outputable (RdrOrSeName p)) - => Outputable (HsRecFields p arg) where - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) - = braces (fsep (punctuate comma (map ppr flds))) -diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot -index b7efb1c28c..d56a992207 100644 ---- a/compiler/hsSyn/HsPat.hs-boot -+++ b/compiler/hsSyn/HsPat.hs-boot -@@ -4,7 +4,7 @@ - -- in module PlaceHolder - {-# LANGUAGE ConstraintKinds #-} - {-# LANGUAGE RoleAnnotations #-} --{-# LANGUAGE TypeFamilies #-} -+{-# LANGUAGE TypeFamilies #-} -- needed to use OutputableBndrId - - module HsPat where - import SrcLoc( Located ) -diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs -index 3512bf7a7c..2366df1d28 100644 ---- a/compiler/hsSyn/HsTypes.hs -+++ b/compiler/hsSyn/HsTypes.hs -@@ -9,6 +9,7 @@ HsTypes: Abstract syntax: user-defined types - {-# LANGUAGE DeriveDataTypeable #-} - {-# LANGUAGE FlexibleContexts #-} - {-# LANGUAGE StandaloneDeriving #-} -+{-# LANGUAGE TypeFamilies #-} - {-# LANGUAGE TypeSynonymInstances #-} - {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -@@ -38,7 +39,7 @@ module HsTypes ( - - HsConDetails(..), - -- FieldOcc(..), LFieldOcc, mkFieldOcc, -+ FieldOcc(..), LFieldOcc, mkFieldOcc, fieldOccRdrName, - AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, - rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, - unambiguousFieldOcc, ambiguousFieldOcc, -@@ -85,6 +86,7 @@ import TysPrim( funTyConName ) - import Type - import HsDoc - import BasicTypes -+import Binary - import SrcLoc - import Outputable - import FastString -@@ -277,6 +279,7 @@ data HsQTvsRn - type instance XHsQTvs GhcPs = NoExt - type instance XHsQTvs GhcRn = HsQTvsRn - type instance XHsQTvs GhcTc = HsQTvsRn -+type instance XHsQTvs GhcSe = NoExt - - type instance XXLHsQTyVars (GhcPass _) = NoExt - -@@ -316,6 +319,7 @@ data HsIBRn - type instance XHsIB GhcPs _ = NoExt - type instance XHsIB GhcRn _ = HsIBRn - type instance XHsIB GhcTc _ = HsIBRn -+type instance XHsIB GhcSe _ = NoExt - - type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt - -@@ -337,6 +341,7 @@ data HsWildCardBndrs pass thing - type instance XHsWC GhcPs b = NoExt - type instance XHsWC GhcRn b = [Name] - type instance XHsWC GhcTc b = [Name] -+type instance XHsWC GhcSe b = NoExt - - type instance XXHsWildCardBndrs (GhcPass _) b = NoExt - -@@ -415,6 +420,10 @@ newtype HsIPName = HsIPName FastString - hsIPNameFS :: HsIPName -> FastString - hsIPNameFS (HsIPName n) = n - -+instance Binary HsIPName where -+ put_ bh (HsIPName s) = put_ bh s -+ get bh = HsIPName <$> get bh -+ - instance Outputable HsIPName where - ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters - -@@ -659,6 +668,7 @@ type instance XKindSig (GhcPass _) = NoExt - type instance XSpliceTy GhcPs = NoExt - type instance XSpliceTy GhcRn = NoExt - type instance XSpliceTy GhcTc = Kind -+type instance XSpliceTy GhcSe = NoExt - - type instance XDocTy (GhcPass _) = NoExt - type instance XBangTy (GhcPass _) = NoExt -@@ -667,16 +677,19 @@ type instance XRecTy (GhcPass _) = NoExt - type instance XExplicitListTy GhcPs = NoExt - type instance XExplicitListTy GhcRn = NoExt - type instance XExplicitListTy GhcTc = Kind -+type instance XExplicitListTy GhcSe = NoExt - - type instance XExplicitTupleTy GhcPs = NoExt - type instance XExplicitTupleTy GhcRn = NoExt - type instance XExplicitTupleTy GhcTc = [Kind] -+type instance XExplicitTupleTy GhcSe = NoExt - - type instance XTyLit (GhcPass _) = NoExt - - type instance XWildCardTy GhcPs = NoExt - type instance XWildCardTy GhcRn = HsWildCardInfo - type instance XWildCardTy GhcTc = HsWildCardInfo -+type instance XWildCardTy GhcSe = NoExt - - type instance XXType (GhcPass _) = NewHsTypeX - -@@ -1137,27 +1150,32 @@ type LFieldOcc pass = Located (FieldOcc pass) - -- both the 'RdrName' the user originally wrote, and after the - -- renamer, the selector function. - data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass -- , rdrNameFieldOcc :: Located RdrName -+ , rdrNameFieldOcc :: Located (RdrOrSeName pass) - -- ^ See Note [Located RdrNames] in HsExpr - } - - | XFieldOcc - (XXFieldOcc pass) --deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p) --deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p) -+deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p), Eq (RdrOrSeName p)) -+ => Eq (FieldOcc p) -+deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p), Ord (RdrOrSeName p)) -+ => Ord (FieldOcc p) - - type instance XCFieldOcc GhcPs = NoExt - type instance XCFieldOcc GhcRn = Name - type instance XCFieldOcc GhcTc = Id -+type instance XCFieldOcc GhcSe = NoExt - - type instance XXFieldOcc (GhcPass _) = NoExt - --instance Outputable (FieldOcc pass) where -+instance Outputable (RdrOrSeName pass) => Outputable (FieldOcc pass) where - ppr = ppr . rdrNameFieldOcc - - mkFieldOcc :: Located RdrName -> FieldOcc GhcPs - mkFieldOcc rdr = FieldOcc noExt rdr - -+fieldOccRdrName :: RdrOrSeName pass ~ RdrName => FieldOcc pass -> Located RdrName -+fieldOccRdrName = rdrNameFieldOcc - - -- | Ambiguous Field Occurrence - -- -@@ -1172,31 +1190,36 @@ mkFieldOcc rdr = FieldOcc noExt rdr - -- Note [Disambiguating record fields] in TcExpr. - -- See Note [Located RdrNames] in HsExpr - data AmbiguousFieldOcc pass -- = Unambiguous (XUnambiguous pass) (Located RdrName) -- | Ambiguous (XAmbiguous pass) (Located RdrName) -+ = Unambiguous (XUnambiguous pass) (Located (RdrOrSeName pass)) -+ | Ambiguous (XAmbiguous pass) (Located (RdrOrSeName pass)) - | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) - - type instance XUnambiguous GhcPs = NoExt - type instance XUnambiguous GhcRn = Name - type instance XUnambiguous GhcTc = Id -+type instance XUnambiguous GhcSe = NoExt - - type instance XAmbiguous GhcPs = NoExt - type instance XAmbiguous GhcRn = NoExt - type instance XAmbiguous GhcTc = Id -+type instance XAmbiguous GhcSe = NoExt - - type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt - --instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where -+instance (p ~ GhcPass pass, Outputable (RdrOrSeName p)) -+ => Outputable (AmbiguousFieldOcc p) where - ppr = ppr . rdrNameAmbiguousFieldOcc - --instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where -+instance (p ~ GhcPass pass, OutputableBndr (RdrOrSeName p)) -+ => OutputableBndr (AmbiguousFieldOcc p) where - pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc - pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc - - mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs - mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr - --rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName -+rdrNameAmbiguousFieldOcc -+ :: AmbiguousFieldOcc (GhcPass p) -> RdrOrSeName (GhcPass p) - rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr - rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr - rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _) -diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs -index eba21cf1e2..be0a5281ab 100644 ---- a/compiler/hsSyn/HsUtils.hs -+++ b/compiler/hsSyn/HsUtils.hs -@@ -1133,8 +1133,9 @@ hsTyClForeignBinders tycl_decls foreign_decls - getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs - - ------------------- --hsLTyClDeclBinders :: Located (TyClDecl pass) -- -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsLTyClDeclBinders -+ :: RdrOrSeName pass ~ RdrName -+ => Located (TyClDecl pass) -> ([Located (IdP pass)], [LFieldOcc pass]) - -- ^ Returns all the /binding/ names of the decl. The first one is - -- guaranteed to be the name of the decl. The first component - -- represents all binding names except record fields; the second -@@ -1188,7 +1189,8 @@ getPatSynBinds binds - , L _ (PatSynBind _ psb) <- bagToList lbinds ] - - ------------------- --hsLInstDeclBinders :: LInstDecl (GhcPass p) -+hsLInstDeclBinders :: RdrOrSeName (GhcPass p) ~ RdrName -+ => LInstDecl (GhcPass p) - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) - hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) - = foldMap (hsDataFamInstBinders . unLoc) dfis -@@ -1202,8 +1204,9 @@ hsLInstDeclBinders (L _ (XInstDecl _)) - - ------------------- - -- the SrcLoc returned are for the whole declarations, not just the names --hsDataFamInstBinders :: DataFamInstDecl pass -- -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsDataFamInstBinders -+ :: RdrOrSeName pass ~ RdrName -+ => DataFamInstDecl pass -> ([Located (IdP pass)], [LFieldOcc pass]) - hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = defn }}}) - = hsDataDefnBinders defn -@@ -1216,7 +1219,9 @@ hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _)) - - ------------------- - -- the SrcLoc returned are for the whole declarations, not just the names --hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsDataDefnBinders -+ :: RdrOrSeName pass ~ RdrName -+ => HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) - hsDataDefnBinders (HsDataDefn { dd_cons = cons }) - = hsConDeclsBinders cons - -- See Note [Binders in family instances] -@@ -1226,7 +1231,9 @@ hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders" - type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass] - -- Filters out ones that have already been seen - --hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) -+hsConDeclsBinders -+ :: forall pass. RdrOrSeName pass ~ RdrName -+ => [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) - -- See hsLTyClDeclBinders for what this does - -- The function is boringly complicated because of the records - -- And since we only have equality, we have to be a little careful -diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs -index 244243a82f..e05dfc3a33 100644 ---- a/compiler/hsSyn/PlaceHolder.hs -+++ b/compiler/hsSyn/PlaceHolder.hs -@@ -9,6 +9,7 @@ module PlaceHolder where - import Name - import NameSet - import RdrName -+import SeName - import Var - - -@@ -68,3 +69,4 @@ type family NameOrRdrName id where - NameOrRdrName Id = Name - NameOrRdrName Name = Name - NameOrRdrName RdrName = RdrName -+ NameOrRdrName SeName = SeName -diff --git a/compiler/hsSyn/SeName.hs b/compiler/hsSyn/SeName.hs -new file mode 100644 -index 0000000000..f8bca59243 ---- /dev/null -+++ b/compiler/hsSyn/SeName.hs -@@ -0,0 +1,13 @@ -+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -+module SeName (SeName(..), mkSeName) where -+ -+import Outputable -+import RdrName -+ -+-- TODO: make this smarter, so as to check whether -+-- the name is local or not. -+newtype SeName = SeName RdrName -+ deriving (Outputable, OutputableBndr) -+ -+mkSeName :: RdrName -> SeName -+mkSeName = SeName -diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs -index 00bcaa77f1..2d6047d7cc 100644 ---- a/compiler/iface/IfaceEnv.hs -+++ b/compiler/iface/IfaceEnv.hs -@@ -16,7 +16,7 @@ module IfaceEnv ( - ifaceExportNames, - - -- Name-cache stuff -- allocateGlobalBinder, updNameCacheTc, -+ allocateGlobalBinder, updNameCacheTc, updNameCacheIO, - mkNameCacheUpdater, NameCacheUpdater(..), - ) where - -diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs -index 5a7f761d32..15a19b117f 100644 ---- a/compiler/iface/IfaceType.hs -+++ b/compiler/iface/IfaceType.hs -@@ -139,7 +139,7 @@ type IfaceContext = [IfacePredType] - data IfaceTyLit - = IfaceNumTyLit Integer - | IfaceStrTyLit FastString -- deriving (Eq) -+ deriving Eq - - type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis - type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag -@@ -170,7 +170,7 @@ instance Monoid IfaceTcArgs where - -- properly. - data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName - , ifaceTyConInfo :: IfaceTyConInfo } -- deriving (Eq) -+ deriving Eq - - -- | Is a TyCon a promoted data constructor or just a normal type constructor? - data IsPromoted = IsNotPromoted | IsPromoted -@@ -194,7 +194,7 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon - -- that is actually being applied to two types - -- of the same kind. This affects pretty-printing - -- only: see Note [Equality predicates in IfaceType] -- deriving (Eq) -+ deriving Eq - - {- Note [Free tyvars in IfaceType] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -@@ -278,7 +278,7 @@ data IfaceTyConInfo -- Used to guide pretty-printing - -- and to disambiguate D from 'D (they share a name) - = IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted - , ifaceTyConSort :: IfaceTyConSort } -- deriving (Eq) -+ deriving Eq - - data IfaceCoercion - = IfaceReflCo Role IfaceType -@@ -1650,6 +1650,7 @@ instance Binary IfaceUnivCoProv where - _ -> panic ("get IfaceUnivCoProv " ++ show tag) - - -+{- - instance Binary (DefMethSpec IfaceType) where - put_ bh VanillaDM = putByte bh 0 - put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t -@@ -1658,3 +1659,4 @@ instance Binary (DefMethSpec IfaceType) where - case h of - 0 -> return VanillaDM - _ -> do { t <- get bh; return (GenericDM t) } -+-} -diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs -index 539132653e..5f217a6a8f 100644 ---- a/compiler/main/DynFlags.hs -+++ b/compiler/main/DynFlags.hs -@@ -916,6 +916,8 @@ data DynFlags = DynFlags { - hiDir :: Maybe String, - stubDir :: Maybe String, - dumpDir :: Maybe String, -+ saveSplicesDir :: Maybe String, -+ loadSplicesDir :: Maybe String, - - objectSuf :: String, - hcSuf :: String, -@@ -1797,6 +1799,8 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) = - hiDir = Nothing, - stubDir = Nothing, - dumpDir = Nothing, -+ saveSplicesDir = Nothing, -+ loadSplicesDir = Nothing, - - objectSuf = phaseInputExt StopLn, - hcSuf = phaseInputExt HCc, -@@ -2371,6 +2375,7 @@ getVerbFlags dflags - | otherwise = [] - - setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, -+ setSaveSplicesDir, setLoadSplicesDir, - setDynObjectSuf, setDynHiSuf, - setDylibInstallName, - setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, -@@ -2390,6 +2395,8 @@ setStubDir f d = d { stubDir = Just f - -- builds). - setDumpDir f d = d { dumpDir = Just f} - setOutputDir f = setObjectDir f . setHiDir f . setStubDir f . setDumpDir f -+setSaveSplicesDir f d = d { saveSplicesDir = Just f} -+setLoadSplicesDir f d = d { loadSplicesDir = Just f} - setDylibInstallName f d = d { dylibInstallName = Just f} - - setObjectSuf f d = d { objectSuf = f} -@@ -2948,6 +2955,8 @@ dynamic_flags_deps = [ - , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) - , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) - , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) -+ , make_ord_flag defGhcFlag "save-splices" (hasArg setSaveSplicesDir) -+ , make_ord_flag defGhcFlag "load-splices" (hasArg setLoadSplicesDir) - , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) - , make_ord_flag defGhcFlag "ddump-file-prefix" - (hasArg (setDumpPrefixForce . Just)) -diff --git a/compiler/prelude/PrimOp.hs-boot b/compiler/prelude/PrimOp.hs-boot -index f10ef44972..6d759bb961 100644 ---- a/compiler/prelude/PrimOp.hs-boot -+++ b/compiler/prelude/PrimOp.hs-boot -@@ -1,5 +1,7 @@ - module PrimOp where - --import GhcPrelude () -+import GhcPrelude (Int) - - data PrimOp -+primOpTag :: PrimOp -> Int -+allThePrimOps :: [PrimOp] -diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs -index 6195309cab..63c471d3ef 100644 ---- a/compiler/rename/RnPat.hs -+++ b/compiler/rename/RnPat.hs -@@ -743,7 +743,7 @@ rnHsRecUpdFields flds - getFieldIds :: [LHsRecField GhcRn arg] -> [Name] - getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds - --getFieldLbls :: [LHsRecField id arg] -> [RdrName] -+getFieldLbls :: RdrOrSeName id ~ RdrName => [LHsRecField id arg] -> [RdrName] - getFieldLbls flds - = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds - -diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs -index f8f3bbe191..91d88087f8 100644 ---- a/compiler/typecheck/Inst.hs -+++ b/compiler/typecheck/Inst.hs -@@ -7,7 +7,7 @@ The @Inst@ type: dictionaries or method instances - -} - - {-# LANGUAGE CPP, MultiWayIf, TupleSections #-} --{-# LANGUAGE FlexibleContexts #-} -+{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - - module Inst ( - deeplySkolemise, -diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs -index b42557259e..00dcf26f09 100644 ---- a/compiler/typecheck/TcEnv.hs -+++ b/compiler/typecheck/TcEnv.hs -@@ -1,6 +1,6 @@ - -- (c) The University of Glasgow 2006 - {-# LANGUAGE CPP, FlexibleInstances #-} --{-# LANGUAGE FlexibleContexts #-} -+{-# LANGUAGE FlexibleContexts, GADTs #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an - -- orphan - {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs -index 986047bded..1cca6f5589 100644 ---- a/compiler/typecheck/TcHsSyn.hs -+++ b/compiler/typecheck/TcHsSyn.hs -@@ -114,7 +114,7 @@ hsPatType (NPlusKPat ty _ _ _ _ _) = ty - hsPatType (CoPat _ _ _ ty) = ty - hsPatType p = pprPanic "hsPatType" (ppr p) - --hsLitType :: HsLit (GhcPass p) -> TcType -+hsLitType :: LitType (GhcPass p) ~ TcType => HsLit (GhcPass p) -> TcType - hsLitType (HsChar _ _) = charTy - hsLitType (HsCharPrim _ _) = charPrimTy - hsLitType (HsString _ _) = stringTy -diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs -index 2f81e07990..5a048d0c4b 100644 ---- a/compiler/typecheck/TcRnDriver.hs -+++ b/compiler/typecheck/TcRnDriver.hs -@@ -47,7 +47,7 @@ module TcRnDriver ( - - import GhcPrelude - --import {-# SOURCE #-} TcSplice ( finishTH ) -+import {-# SOURCE #-} TcSplice( finishTH, writeHsSpliceData ) - import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) - import IfaceEnv( externaliseName ) - import TcHsType -@@ -114,6 +114,7 @@ import Avail - import TyCon - import SrcLoc - import HscTypes -+import HsExprBin - import ListSetOps - import Outputable - import ConLike -@@ -137,6 +138,8 @@ import qualified Data.Set as S - - import Control.DeepSeq - import Control.Monad -+import System.Directory -+import System.FilePath (takeDirectory) - - #include "HsVersions.h" - -@@ -421,6 +424,17 @@ tcRnSrcDecls explicit_mod_hdr decls - -- Finalizers must run after constraints are simplified, or some types - -- might not be complete when using reify (see #12777). - ; (tcg_env, tcl_env) <- setGblEnv tcg_env run_th_modfinalizers -+ -+ ; dynflags <- getDynFlags -+ ; whenSet (saveSplicesDir dynflags) -+ (\splicesDir -> do -+ moduleSplicesPath <- getModuleSplicesPath splicesDir <$> getModule -+ hs_splice_data <- readTcRef (tcg_hs_splice_data tcg_env) -+ liftIO $ createDirectoryIfMissing True (takeDirectory moduleSplicesPath) -+ writeHsSpliceData moduleSplicesPath hs_splice_data -+ ) -+ (pure ()) -+ - ; setEnvs (tcg_env, tcl_env) $ do { - - ; finishTH -diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs -index e0989ae331..83449f1631 100644 ---- a/compiler/typecheck/TcRnMonad.hs -+++ b/compiler/typecheck/TcRnMonad.hs -@@ -145,6 +145,7 @@ import IOEnv -- Re-export all - import TcEvidence - - import HsSyn hiding (LIE) -+import HsExprBin - import HscTypes - import Module - import RdrName -@@ -182,7 +183,7 @@ import Control.Monad - import Data.Set ( Set ) - import qualified Data.Set as Set - --import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers ) -+import {-# SOURCE #-} TcSplice ( readHsSpliceData, runRemoteModFinalizers ) - import {-# SOURCE #-} TcEnv ( tcInitTidyEnv ) - - import qualified Data.Map as Map -@@ -228,9 +229,16 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this - th_coreplugins_var <- newIORef [] ; - th_state_var <- newIORef Map.empty ; - th_remote_state_var <- newIORef Nothing ; -+ dflags <- pure (hsc_dflags hsc_env) ; -+ hs_splice_data <- newIORef =<< whenSet (loadSplicesDir dflags) -+ (\splicesDir -> do -+ if moduleUnitId mod == interactiveUnitId -+ then return emptyHsSpliceData -+ else do let moduleSplicesPath = getModuleSplicesPath splicesDir mod -+ readHsSpliceData hsc_env moduleSplicesPath -+ ) -+ (pure emptyHsSpliceData) ; - let { -- dflags = hsc_dflags hsc_env ; -- - maybe_rn_syntax :: forall a. a -> Maybe a ; - maybe_rn_syntax empty_val - | dopt Opt_D_dump_rn_ast dflags = Just empty_val -@@ -310,7 +318,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this - tcg_top_loc = loc, - tcg_static_wc = static_wc_var, - tcg_complete_matches = [], -- tcg_cc_st = cc_st_var -+ tcg_cc_st = cc_st_var, -+ tcg_hs_splice_data = hs_splice_data - } ; - } ; - -diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs -index 2a4b808f54..08ed9f151d 100644 ---- a/compiler/typecheck/TcRnTypes.hs -+++ b/compiler/typecheck/TcRnTypes.hs -@@ -160,6 +160,7 @@ import TyCoRep ( CoercionHole(..), coHoleCoVar ) - import Coercion ( Coercion, mkHoleCo ) - import ConLike ( ConLike(..) ) - import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) -+import {-# SOURCE #-} HsExprBin - import PatSyn ( PatSyn, pprPatSynType ) - import Id ( idType, idName ) - import FieldLabel ( FieldLabel ) -@@ -689,7 +690,19 @@ data TcGblEnv - tcg_complete_matches :: [CompleteMatch], - - -- ^ Tracking indices for cost centre annotations -- tcg_cc_st :: TcRef CostCentreState -+ tcg_cc_st :: TcRef CostCentreState, -+ -- ^ Splice evaluation results -+ -- -+ -- When @-save-splices@ is passed, we will -+ -- record splice results in this field and write -+ -- them all to an .hs-splice file when we are done -+ -- processing the module. -+ -- -+ -- When @-load-splices@ is passed, we will read -+ -- the .hs-splice file before we start processing a -+ -- module (when it exists) and store all its contents -+ -- in this field. -+ tcg_hs_splice_data :: TcRef HsSpliceData - } - - -- NB: topModIdentity, not topModSemantic! -diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs -index 737ddccfbd..c6dd542937 100644 ---- a/compiler/typecheck/TcSplice.hs -+++ b/compiler/typecheck/TcSplice.hs -@@ -26,6 +26,7 @@ module TcSplice( - runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, - tcTopSpliceExpr, lookupThName_maybe, - defaultRunMeta, runMeta', runRemoteModFinalizers, -+ readHsSpliceData, writeHsSpliceData, - finishTH - ) where - -@@ -34,6 +35,7 @@ module TcSplice( - import GhcPrelude - - import HsSyn -+import HsExprBin - import Annotations - import Finder - import Name -@@ -110,6 +112,9 @@ import Maybes( MaybeErr(..) ) - import DynFlags - import Panic - import Lexeme -+import BinIface ( getWithUserData, putWithUserData ) -+import IfaceEnv ( NameCacheUpdater(..) ) -+import qualified Binary as Bin - import qualified EnumSet - import Plugins - import Bag -@@ -132,6 +137,7 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) - import Data.Data (Data) - import Data.Proxy ( Proxy (..) ) - import GHC.Exts ( unsafeCoerce# ) -+import System.Directory ( doesFileExist ) - - {- - ************************************************************************ -@@ -672,12 +678,26 @@ runQResult show_th f runQ expr_span hval - - - ----------------- -+ - runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) -+ -> (LHsExpr GhcTc -> TcM hs_syn) -+ -- ^ function to load the result of the given expression from -+ -- an .hs-splice file's data -+ -> (LHsExpr GhcTc -> hs_syn -> TcM ()) -+ -- ^ function to "save" the result (hs_syn) of evaluating the given -+ -- LHsExpr - -> LHsExpr GhcTc - -> TcM hs_syn --runMeta unwrap e -- = do { h <- getHooked runMetaHook defaultRunMeta -- ; unwrap h e } -+runMeta unwrap loadSpliceFun saveSpliceFun e -+ = do { dflags <- getDynFlags -+ ; whenSet (loadSplicesDir dflags) -+ (\_ -> loadSpliceFun e) -+ (do { h <- getHooked runMetaHook defaultRunMeta -+ ; res <- unwrap h e -+ ; whenSet (saveSplicesDir dflags) -+ (\_ -> saveSpliceFun e res) -+ (return ()) -+ ; return res }) } - - defaultRunMeta :: MetaHook TcM - defaultRunMeta (MetaE r) -@@ -694,29 +714,110 @@ defaultRunMeta (MetaAW r) - -- the toAnnotationWrapper function that we slap around the user's code - - ---------------- -+ -+readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData -+readHsSpliceData hsc_env hsSpliceFile = do -+ let ncu = NCU (updNameCache hsc_env) -+ exists <- doesFileExist hsSpliceFile -+ if exists -+ then do bh <- Bin.readBinMem hsSpliceFile -+ getWithUserData ncu bh -+ else pure emptyHsSpliceData -+ -+writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () -+writeHsSpliceData hsSpliceFile hsSpliceData = -+ when (nonEmptyHsSpliceData hsSpliceData) $ do -+ dflags <- getDynFlags -+ liftIO $ do -+ bh <- Bin.openBinMem (100 * 1024) -+ -- ^^^ FIXME: how should we compute an approximation of size? -+ putWithUserData (debugTraceMsg dflags 3) bh hsSpliceData -+ Bin.writeBinMem bh hsSpliceFile -+ -+-- | Update the splice data from the TcGblEnv using the given -+-- function. Used when -save-splices is passed, to record -+-- the splice results as we evaluate them and dump them -+-- to an .hs-splice file. -+modifyHsSpliceData :: (HsSpliceData -> HsSpliceData) -> TcM () -+modifyHsSpliceData f = do -+ spliceDataRef <- tcg_hs_splice_data <$> getGblEnv -+ updTcRef spliceDataRef f -+ -+-- | Record the result (second argument) of evaluating the expression splice -+-- represented by the first argument. -+addSpliceExprResult :: LHsExpr GhcTc -> LHsExpr GhcPs -> TcM () -+addSpliceExprResult th@(L l _) resultE = do -+ serialExpr <- handleUnsupported (fmap ppr th) (Just $ ppr resultE) -+ =<< exprPS2SE resultE -+ modifyHsSpliceData $ recordSpliceResult l (SRExpr serialExpr) -+ -+-- | Record the result (second argument) of evaluating the declaration splice -+-- represented by the first argument. -+addSpliceDeclsResult :: LHsExpr GhcTc -> [LHsDecl GhcPs] -> TcM () -+addSpliceDeclsResult th@(L l _) resultDs = do -+ serialDecls <- traverse -+ (declPS2SE >=> handleUnsupported (fmap ppr th) (Just $ ppr resultDs)) -+ resultDs -+ modifyHsSpliceData $ recordSpliceResult l (SRDecls serialDecls) -+ -+-- | Look up the result of evaluating the splice represented by the first -+-- argument in an .hs-splice file, using the given function to extract -+-- the result in question (when found). -+getSpliceResult :: LHsExpr GhcTc -> (SpliceResult -> TcM a) -> TcM a -+getSpliceResult (L l _) f = do -+ gblEnv <- getGblEnv -+ hs_splice_data <- readTcRef (tcg_hs_splice_data gblEnv) -+ case lookupSpliceResult l hs_splice_data of -+ Nothing -> panic ("Could not find splice result for source span " ++ show l) -+ Just r -> f r -+ -+-- | Look up the result of evaluating an expression splice. -+getSpliceExprResult :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs) -+getSpliceExprResult spliceE = getSpliceResult spliceE $ \res -> case res of -+ SRExpr e -> exprSE2PS e >>= handleUnsupported (fmap ppr spliceE) Nothing -+ SRDecls _ -> panic ("Expected an expression splice but found a declaration one") -+ -+-- | Look up the result of evaluating a declaration splice. -+getSpliceDeclsResult :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] -+getSpliceDeclsResult spliceE = getSpliceResult spliceE $ \res -> case res of -+ SRExpr _ -> panic ("Expected a declaration splice result but found an expression one") -+ SRDecls ds -> traverse -+ (declSE2PS >=> handleUnsupported (fmap ppr spliceE) Nothing) -+ ds -+ - runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper - -> TcM Serialized - runMetaAW = runMeta metaRequestAW -+ -- We cannot process annotations as they use the same -+ -- mechanism as TH. Instead, we ignore them when -+ -- doing a -save-splices pass, and we pretend we -+ -- read {-# ANN () #-} when doing a -load-splices pass. -+ (\_ -> pure $ toSerialized serializeWithData ()) -+ (\_ _ -> pure ()) - - runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) - -> TcM (LHsExpr GhcPs) --runMetaE = runMeta metaRequestE -+runMetaE = runMeta metaRequestE getSpliceExprResult addSpliceExprResult - - runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) - -> TcM (LPat GhcPs) - runMetaP = runMeta metaRequestP -+ (panic "runMetaP doesn't support splice caching (read)") -+ (panic "runMetaP doesn't support splice caching (write)") - - runMetaT :: LHsExpr GhcTc -- Of type (Q Type) - -> TcM (LHsType GhcPs) - runMetaT = runMeta metaRequestT -+ (panic "runMetaT doesn't support splice caching (read)") -+ (panic "runMetaT doesn't support splice caching (write)") - - runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] - -> TcM [LHsDecl GhcPs] --runMetaD = runMeta metaRequestD -+runMetaD = runMeta metaRequestD getSpliceDeclsResult addSpliceDeclsResult - - --------------- - runMeta' :: Bool -- Whether code should be printed in the exception message -- -> (hs_syn -> SDoc) -- how to print the code -+ -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x - -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or - -- something like that -@@ -727,7 +828,7 @@ runMeta' show_code ppr_hs run_and_convert expr - -- we catch all kinds of splices and annotations. - - -- Check that we've had no errors of any sort so far. -- -- For example, if we found an error in an earlier defn f, but -+ -- For example, if we fouénd an error in an earlier defn f, but - -- recovered giving it type f :: forall a.a, it'd be very dodgy - -- to carry ont. Mind you, the staging restrictions mean we won't - -- actually run f, but it still seems wrong. And, more concretely, -diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot -index be2c67d887..277dc95c8d 100644 ---- a/compiler/typecheck/TcSplice.hs-boot -+++ b/compiler/typecheck/TcSplice.hs-boot -@@ -10,6 +10,8 @@ import TcRnTypes( TcM , SpliceType ) - import TcType ( ExpRhoType ) - import Annotations ( Annotation, CoreAnnTarget ) - import HsExtension ( GhcTcId, GhcRn, GhcPs ) -+import HscTypes ( HscEnv ) -+import HsExprBin ( HsSpliceData ) - - import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, - LHsDecl, ThModFinalizers ) -@@ -42,3 +44,6 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name) - runQuasi :: TH.Q a -> TcM a - runRemoteModFinalizers :: ThModFinalizers -> TcM () - finishTH :: TcM () -+ -+readHsSpliceData :: HscEnv -> FilePath -> IO HsSpliceData -+writeHsSpliceData :: FilePath -> HsSpliceData -> TcM () -\ No newline at end of file -diff --git a/compiler/typecheck/TcType.hs-boot b/compiler/typecheck/TcType.hs-boot -index 2bc14735f1..1b014c2d2a 100644 ---- a/compiler/typecheck/TcType.hs-boot -+++ b/compiler/typecheck/TcType.hs-boot -@@ -4,5 +4,6 @@ import Outputable( SDoc ) - data MetaDetails - - data TcTyVarDetails -+ - pprTcTyVarDetails :: TcTyVarDetails -> SDoc - vanillaSkolemTv :: TcTyVarDetails -diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs -index 63c21627c8..c8334ddd42 100644 ---- a/compiler/types/CoAxiom.hs -+++ b/compiler/types/CoAxiom.hs -@@ -39,9 +39,9 @@ import Name - import Unique - import Var - import Util --import Binary - import Pair - import BasicTypes -+import Binary - import Data.Typeable ( Typeable ) - import SrcLoc - import qualified Data.Data as Data -@@ -440,15 +440,16 @@ instance Outputable Role where - ppr = ftext . fsFromRole - - instance Binary Role where -- put_ bh Nominal = putByte bh 1 -- put_ bh Representational = putByte bh 2 -- put_ bh Phantom = putByte bh 3 -- -- get bh = do tag <- getByte bh -- case tag of 1 -> return Nominal -- 2 -> return Representational -- 3 -> return Phantom -- _ -> panic ("get Role " ++ show tag) -+ put_ bh r = putByte bh $ case r of -+ Nominal -> 0 -+ Representational -> 1 -+ Phantom -> 2 -+ get bh = do -+ tag <- getByte bh -+ pure $ case tag of -+ 0 -> Nominal -+ 1 -> Representational -+ _ -> Phantom - - {- - ************************************************************************ -@@ -501,7 +502,6 @@ instance Ord CoAxiomRule where - instance Outputable CoAxiomRule where - ppr = ppr . coaxrName - -- - -- Type checking of built-in families - data BuiltInSynFamily = BuiltInSynFamily - { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs -index 82c9082ac1..786e77ef63 100644 ---- a/compiler/types/TyCon.hs -+++ b/compiler/types/TyCon.hs -@@ -584,7 +584,6 @@ instance Binary TyConBndrVis where - 0 -> return AnonTCB - _ -> do { vis <- get bh; return (NamedTCB vis) } } - -- - {- ********************************************************************* - * * - The TyCon type -diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs -index 447317ca47..a84624d24c 100644 ---- a/compiler/utils/Binary.hs -+++ b/compiler/utils/Binary.hs -@@ -63,12 +63,16 @@ module Binary - import GhcPrelude - - import {-# SOURCE #-} Name (Name) -+import Bag - import FastString - import Panic -+import Unique - import UniqFM -+import UniqSet - import FastMutInt - import Fingerprint - import BasicTypes -+import {-# SOURCE #-} PrimOp - import SrcLoc - - import Foreign -@@ -76,14 +80,17 @@ import Data.Array - import Data.ByteString (ByteString) - import qualified Data.ByteString.Internal as BS - import qualified Data.ByteString.Unsafe as BS -+import qualified Data.IntMap as IM - import Data.IORef - import Data.Char ( ord, chr ) -+import Data.List ( find ) - import Data.Time - import Type.Reflection - import Type.Reflection.Unsafe - import Data.Kind (Type) - import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) --import Control.Monad ( when ) -+import Data.Typeable ( ) -+import Control.Monad ( when, replicateM ) - import System.IO as IO - import System.IO.Unsafe ( unsafeInterleaveIO ) - import System.IO.Error ( mkIOError, eofErrorType ) -@@ -380,8 +387,8 @@ instance Binary () where - get _ = return () - - instance Binary Bool where -- put_ bh b = putByte bh (fromIntegral (fromEnum b)) -- get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) -+ put_ bh b = putByte bh (if b then 1 else 0) -+ get bh = do x <- getByte bh; return $! if x == 0 then False else True - - instance Binary Char where - put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) -@@ -1173,3 +1180,121 @@ instance Binary SourceText where - s <- get bh - return (SourceText s) - _ -> panic $ "Binary SourceText:" ++ show h -+ -+instance Binary IntegralLit where -+ put_ bh (IL a b c) = put_ bh a >> put_ bh b >> put_ bh c -+ get bh = IL <$> get bh <*> get bh <*> get bh -+ -+instance Binary FractionalLit where -+ put_ bh (FL a b c) = put_ bh a >> put_ bh b >> put_ bh c -+ get bh = FL <$> get bh <*> get bh <*> get bh -+ -+instance Binary Boxity where -+ put_ bh b = case b of -+ Boxed -> putByte bh 0 -+ Unboxed -> putByte bh 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure Boxed -+ _ -> pure Unboxed -+ -+instance Binary Unique where -+ put_ bh u = put_ bh (getKey u) -+ get bh = mkUniqueGrimily <$> get bh -+ -+instance Binary ty => Binary (DefMethSpec ty) where -+ put_ bh s -+ = case s of -+ VanillaDM -> putByte bh 0 -+ GenericDM t -> putByte bh 1 >> put_ bh t -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure VanillaDM -+ _ -> GenericDM <$> get bh -+ -+instance Binary a => Binary (IM.IntMap a) where -+ put_ bh m = put_ bh (IM.toAscList m) -+ get bh = IM.fromAscList <$> get bh -+ -+instance Binary PrimOp where -+ put_ bh primop = put_ bh (primOpTag primop) -+ -- FIXME: inefficient. -+ get bh = do -+ tag <- getTag -+ case find (\p -> primOpTag p == tag) allThePrimOps of -+ Nothing -> error "Binary PrimOp.get: unknown primop tag" -+ Just p -> pure p -+ -+ where getTag :: IO Int -+ getTag = get bh -+ -+instance Binary OccInfo where -+ put_ bh i -+ = case i of -+ ManyOccs a -> putByte bh 0 >> put_ bh a -+ IAmDead -> putByte bh 1 -+ OneOcc a b c d -> putByte bh 2 >> put_ bh a >> put_ bh b -+ >> put_ bh c >> put_ bh d -+ IAmALoopBreaker a b -> putByte bh 3 >> put_ bh a >> put_ bh b -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> ManyOccs <$> get bh -+ 1 -> pure IAmDead -+ 2 -> OneOcc <$> get bh <*> get bh <*> get bh <*> get bh -+ _ -> IAmALoopBreaker <$> get bh <*> get bh -+ -+instance Binary TailCallInfo where -+ put_ bh i -+ = case i of -+ AlwaysTailCalled a -> putByte bh 0 >> put_ bh a -+ NoTailCallInfo -> putByte bh 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> AlwaysTailCalled <$> get bh -+ _ -> pure NoTailCallInfo -+ -+instance Binary OneShotInfo where -+ put_ bh i -+ = case i of -+ NoOneShotInfo -> putByte bh 0 -+ OneShotLam -> putByte bh 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure NoOneShotInfo -+ _ -> pure OneShotLam -+ -+instance Binary LexicalFixity where -+ put_ bh f = case f of -+ Prefix -> putByte bh 0 -+ Infix -> putByte bh 1 -+ get bh = do -+ tag <- getByte bh -+ case tag of -+ 0 -> pure Prefix -+ _ -> pure Infix -+ -+instance Binary ele => Binary (UniqFM ele) where -+ put_ bh ufm = put_ bh (ufmToIntMap ufm) -+ get bh = intMapToUFM <$> get bh -+ -+instance Binary a => Binary (UniqSet a) where -+ put_ bh s = put_ bh (getUniqSet s) -+ get bh = unsafeUFMToUniqSet <$> get bh -+ -+instance Binary a => Binary (Bag a) where -+ put_ bh b = put_ bh (bagToList b) -+ get bh = listToBag <$> get bh -+ -+instance Binary Origin where -+ put_ bh o = putByte bh $ case o of -+ FromSource -> 0 -+ Generated -> 1 -+ get bh = getByte bh >>= \n -> case n of -+ 0 -> pure FromSource -+ 1 -> pure Generated -+ _ -> panic "Binary Origin.get: unknown tag" -diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs -index 715600ddb8..90389da0d1 100644 ---- a/compiler/utils/UniqDFM.hs -+++ b/compiler/utils/UniqDFM.hs -@@ -62,6 +62,7 @@ module UniqDFM ( - import GhcPrelude - - import Unique ( Uniquable(..), Unique, getKey ) -+import Binary - import Outputable - - import qualified Data.IntMap as M -@@ -128,6 +129,10 @@ instance Eq val => Eq (TaggedVal val) where - instance Functor TaggedVal where - fmap f (TaggedVal val i) = TaggedVal (f val) i - -+instance Binary val => Binary (TaggedVal val) where -+ put_ bh (TaggedVal a b) = put_ bh a >> put_ bh b -+ get bh = TaggedVal <$> get bh <*> get bh -+ - -- | Type of unique deterministic finite maps - data UniqDFM ele = - UDFM -@@ -139,6 +144,10 @@ data UniqDFM ele = - -- time. See Note [Overflow on plusUDFM] - deriving (Data, Functor) - -+instance Binary ele => Binary (UniqDFM ele) where -+ put_ bh (UDFM a b) = put_ bh a >> put_ bh b -+ get bh = UDFM <$> get bh <*> get bh -+ - emptyUDFM :: UniqDFM elt - emptyUDFM = UDFM M.empty 0 - -diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs -index a80880f4e5..7a7c40ecfc 100644 ---- a/compiler/utils/UniqFM.hs -+++ b/compiler/utils/UniqFM.hs -@@ -66,7 +66,7 @@ module UniqFM ( - lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, - nonDetEltsUFM, eltsUFM, nonDetKeysUFM, - ufmToSet_Directly, -- nonDetUFMToList, ufmToIntMap, -+ nonDetUFMToList, ufmToIntMap, intMapToUFM, - pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM - ) where - -@@ -338,7 +338,10 @@ nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m - ufmToIntMap :: UniqFM elt -> M.IntMap elt - ufmToIntMap (UFM m) = m - ---- Determines whether two 'UniqFm's contain the same keys. -+intMapToUFM :: M.IntMap elt -> UniqFM elt -+intMapToUFM = UFM -+ -+-- Determines whether two 'UniqFM's contain the same keys. - equalKeysUFM :: UniqFM a -> UniqFM b -> Bool - equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 - diff --git a/haskell-overlays/splices-load-save/haddock.patch b/haskell-overlays/splices-load-save/haddock.patch deleted file mode 100644 index 14dad87c3..000000000 --- a/haskell-overlays/splices-load-save/haddock.patch +++ /dev/null @@ -1,13 +0,0 @@ -diff --git a/utils/haddock/haddock-api/src/Haddock/Types.hs b/utils/haddock/haddock-api/src/Haddock/Types.hs -index a4ef5f82..faa9e1c9 100644 ---- a/utils/haddock/haddock-api/src/Haddock/Types.hs -+++ b/utils/haddock/haddock-api/src/Haddock/Types.hs -@@ -298,7 +298,7 @@ data DocName - data DocNameI - - type instance IdP DocNameI = DocName -- -+type instance RdrOrSeName DocNameI = RdrName - - instance NamedThing DocName where - getName (Documented name _) = name From df6df06f8f79494c83e1fe86898597f453bdacf8 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 12 Jul 2019 20:01:36 -0400 Subject: [PATCH 36/55] Remove unused nixpkgs --disable-pie patch --- nixpkgs-disable-pie.diff | 30 ------------------------------ 1 file changed, 30 deletions(-) delete mode 100644 nixpkgs-disable-pie.diff diff --git a/nixpkgs-disable-pie.diff b/nixpkgs-disable-pie.diff deleted file mode 100644 index 43fc2ec7c..000000000 --- a/nixpkgs-disable-pie.diff +++ /dev/null @@ -1,30 +0,0 @@ -diff --git a/pkgs/build-support/bintools-wrapper/default.nix b/pkgs/build-support/bintools-wrapper/default.nix -index 59a7ded4bdd8..8d81e0af9029 100644 ---- a/pkgs/build-support/bintools-wrapper/default.nix -+++ b/pkgs/build-support/bintools-wrapper/default.nix -@@ -303,6 +303,10 @@ stdenv.mkDerivation { - done - '' - -+ + optionalString targetPlatform.useAndroidPrebuilt '' -+ hardening_unsupported_flags+=" pie" -+ '' -+ - + '' - set +u - substituteAll ${./add-flags.sh} $out/nix-support/add-flags.sh -diff --git a/pkgs/build-support/cc-wrapper/default.nix b/pkgs/build-support/cc-wrapper/default.nix -index 176df51cbd9a..46a85132b95b 100644 ---- a/pkgs/build-support/cc-wrapper/default.nix -+++ b/pkgs/build-support/cc-wrapper/default.nix -@@ -295,6 +295,10 @@ stdenv.mkDerivation { - hardening_unsupported_flags+=" stackprotector fortify pie pic" - '' - -+ + optionalString targetPlatform.useAndroidPrebuilt '' -+ hardening_unsupported_flags+=" pie" -+ '' -+ - + optionalString (libc != null && targetPlatform.isAvr) '' - for isa in avr5 avr3 avr4 avr6 avr25 avr31 avr35 avr51 avrxmega2 avrxmega4 avrxmega5 avrxmega6 avrxmega7 tiny-stack; do - echo "-B${getLib libc}/avr/lib/$isa" >> $out/nix-support/libc-cflags From d75e67ccddc8df12c919ec71db13aa5351a1fe87 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 12 Jul 2019 20:34:16 -0400 Subject: [PATCH 37/55] Update changelog --- ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 443566814..9c1dd04f4 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,6 +5,8 @@ This project's release branch is `master`. This log is written from the perspect ## Unreleased * Document how to accept android sdk license agreement and pass acceptance through to android infrastructure. +* Update to GHC(JS) 8.6.5 +* Update to the nixos-19.03 nixpkgs channel ## v0.1.0.0 - 2019-04-03 From 937e0cc315f3fbd01debff16ab4fdaa2e2c197bd Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 12 Jul 2019 22:40:25 -0400 Subject: [PATCH 38/55] Removed some obsolete scripts --- nixpkgs-overlays/call-hackage-direct.nix | 7 ------- scripts/update | 16 ---------------- 2 files changed, 23 deletions(-) delete mode 100644 nixpkgs-overlays/call-hackage-direct.nix delete mode 100755 scripts/update diff --git a/nixpkgs-overlays/call-hackage-direct.nix b/nixpkgs-overlays/call-hackage-direct.nix deleted file mode 100644 index 61943e022..000000000 --- a/nixpkgs-overlays/call-hackage-direct.nix +++ /dev/null @@ -1,7 +0,0 @@ -{nixpkgs}: -{pkg, ver, sha256}: - let pkgver = "${pkg}-${ver}"; - in nixpkgs.haskellPackages.callCabal2nix pkg (nixpkgs.fetchzip { - url = "mirror://hackage/${pkgver}/${pkgver}.tar.gz"; - inherit sha256; - }) diff --git a/scripts/update b/scripts/update deleted file mode 100755 index 021e6f734..000000000 --- a/scripts/update +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/bin/env bash -set -euo pipefail - -DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )/.." && pwd ) - -. "$DIR/scripts/common-setup.sh" - -cd $DIR - -NIX_PREFETCH_GIT="$(nix-build "$DIR/nixpkgs" -A nix-prefetch-scripts)/bin/nix-prefetch-git" - -$NIX_PREFETCH_GIT git://github.com/ghcjs/shims > shims/git.json -$NIX_PREFETCH_GIT git://github.com/ghcjs/ghcjs > ghcjs/git.json -$NIX_PREFETCH_GIT --fetch-submodules git://github.com/ghcjs/ghcjs-boot > ghcjs-boot/git.json - -./scripts/test From 2c12e126e097b6d442f87d97871aa1e301c026a7 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sat, 13 Jul 2019 11:49:27 -0400 Subject: [PATCH 39/55] Remove reflex-dom(-core) overrides --- default.nix | 3 +++ haskell-overlays/reflex-packages/dep/reflex-dom/github.json | 4 ++-- haskell-overlays/untriaged.nix | 4 +--- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/default.nix b/default.nix index 14b7d1527..6a71a0456 100644 --- a/default.nix +++ b/default.nix @@ -21,6 +21,9 @@ let iosSupport = system == "x86_64-darwin"; ghcSplices-8_6 = super.haskell.compiler.ghc865.overrideAttrs (drv: { enableParallelBuilding = false; src = nixpkgs.hackGet ./haskell-overlays/splices-load-save/dep/ghc; + # When building from the ghc git repo, ./boot must be run before configuring, whereas + # in the distribution tarball on the haskell.org downloads page, ./boot has already been + # run. preConfigure= '' echo ${drv.version} >VERSION ./boot diff --git a/haskell-overlays/reflex-packages/dep/reflex-dom/github.json b/haskell-overlays/reflex-packages/dep/reflex-dom/github.json index 93711ba67..d28404967 100644 --- a/haskell-overlays/reflex-packages/dep/reflex-dom/github.json +++ b/haskell-overlays/reflex-packages/dep/reflex-dom/github.json @@ -1,6 +1,6 @@ { "owner": "reflex-frp", "repo": "reflex-dom", - "rev": "01faad072dae6700c31c536d3f2b4449f4216069", - "sha256": "0qbi32g10r3l8vwk82cy8rrg0x2c33gm0h22fb19j8f9n6qjrirw" + "rev": "c71b6bcfe9a776fd141ce3d14cd38cef65afec38", + "sha256": "16bh13acrk63v2h0zcz1dgq4zgycf7bimq1pr8lkchpiqxcmswwp" } diff --git a/haskell-overlays/untriaged.nix b/haskell-overlays/untriaged.nix index 833d300c6..a964c1c54 100644 --- a/haskell-overlays/untriaged.nix +++ b/haskell-overlays/untriaged.nix @@ -18,8 +18,6 @@ let addGIDeps = p: extraBuildInputs: girSearchPathPackages: p.overrideAttrs (drv in self: super: { # TODO - reflex-dom-core = dontCheck super.reflex-dom-core; - reflex-dom = doJailbreak super.reflex-dom; jsaddle-webkit2gtk = doJailbreak super.jsaddle-webkit2gtk; # Recently uploaded to hackage: @@ -30,7 +28,7 @@ in self: super: { } {}; # Update hlint and add new dependency - hlint = self.callHackage "hlint" "2.1.26" {}; + hlint = self.callHackage "hlint" "2.2" {}; ghc-lib-parser = self.callHackage "ghc-lib-parser" "8.8.0.20190424" {}; haskell-src-exts = super.haskell-src-exts_1_21_0; haskell-src-exts-util = self.callHackage "haskell-src-exts-util" "0.2.5" {}; From f29c2354684f68b4f1516e8cd4c2488e2efb1c31 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sat, 13 Jul 2019 11:58:01 -0400 Subject: [PATCH 40/55] Document addGIDeps; Remove override for jsaddle-webkit2gtk --- haskell-overlays/untriaged.nix | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/haskell-overlays/untriaged.nix b/haskell-overlays/untriaged.nix index a964c1c54..674abf5b1 100644 --- a/haskell-overlays/untriaged.nix +++ b/haskell-overlays/untriaged.nix @@ -4,7 +4,10 @@ , nixpkgs }: with haskellLib; -let addGIDeps = p: extraBuildInputs: girSearchPathPackages: p.overrideAttrs (drv: { +let # Adds additional arguments to 'buildInputs' and the 'HASKELL_GI_GIR_SEARCH_PATH' environment variable + # used by haskell-gi to specify non-standard locations .gir file locations + # addGIDeps :: haskellPackage -> [nixPackage] -> [nixPackage] -> haskellPackage + addGIDeps = p: extraBuildInputs: girSearchPathPackages: p.overrideAttrs (drv: { # cabal2nix puts these deps in libraryPkgconfigDepends but that doesn't seem to suffice. buildInputs = with nixpkgs; drv.buildInputs or [] ++ [ pkgconfig gobjectIntrospection ] ++ extraBuildInputs; libraryPkgconfigDepends = drv.libraryPkgconfigDepends or [] ++ [nixpkgs.gobject-introspection]; @@ -17,9 +20,6 @@ let addGIDeps = p: extraBuildInputs: girSearchPathPackages: p.overrideAttrs (drv }); in self: super: { - # TODO - jsaddle-webkit2gtk = doJailbreak super.jsaddle-webkit2gtk; - # Recently uploaded to hackage: haven = self.callHackageDirect { pkg = "haven"; @@ -44,7 +44,7 @@ in self: super: { webkit2gtk3-javascriptcore = self.callHackage "webkit2gtk3-javascriptcore" "0.14.2.1" {}; haskell-gi = self.callHackage "haskell-gi" "0.22.6" {}; - # Overrides for gi-* family of libraries + # Overrides for gi-* family of libraries. See addGIDeps, above. haskell-gi-base = addGIDeps (self.callHackage "haskell-gi-base" "0.22.2" {}) [nixpkgs.glib] []; gi-glib = addGIDeps (self.callHackage "gi-glib" "2.0.19" {}) [] []; gi-cairo = addGIDeps (self.callHackage "gi-cairo" "1.0.19" {}) [nixpkgs.cairo] []; From 1a85f8002263b2623f9ad90bd13288e65e4c7877 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sat, 13 Jul 2019 16:35:53 -0400 Subject: [PATCH 41/55] Add reflex-project-skeleton thunk --- examples/project/reflex-project-skeleton/git.json | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 examples/project/reflex-project-skeleton/git.json diff --git a/examples/project/reflex-project-skeleton/git.json b/examples/project/reflex-project-skeleton/git.json new file mode 100644 index 000000000..709b30d55 --- /dev/null +++ b/examples/project/reflex-project-skeleton/git.json @@ -0,0 +1,6 @@ +{ + "url": "git@github.com:obsidiansystems/reflex-project-skeleton", + "rev": "30d29322d74e98d189b755c3d25fffecfee32fe1", + "sha256": "14vcmi3bdmlcj228wj0hzjyqmixyfrd0ch8qzp2655kzik7dbgga", + "fetchSubmodules": false +} From 3300d27d761dd4937e03f5ccff45ef106806d233 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 14 Jul 2019 16:03:56 -0400 Subject: [PATCH 42/55] Add build-gradle-app; Add project example; Update android-activity --- android/build-gradle-app.nix | 108 ++++++++++++++++++ android/impl.nix | 20 ++-- examples/project/default.nix | 7 ++ .../reflex-project-skeleton/default.nix | 1 + .../{git.json => github.json} | 6 +- .../android/dep/android-activity/default.nix | 1 + .../android/dep/android-activity/github.json | 4 +- 7 files changed, 135 insertions(+), 12 deletions(-) create mode 100644 android/build-gradle-app.nix create mode 100644 examples/project/default.nix create mode 100644 examples/project/reflex-project-skeleton/default.nix rename examples/project/reflex-project-skeleton/{git.json => github.json} (55%) create mode 100644 haskell-overlays/android/dep/android-activity/default.nix diff --git a/android/build-gradle-app.nix b/android/build-gradle-app.nix new file mode 100644 index 000000000..5984b47c8 --- /dev/null +++ b/android/build-gradle-app.nix @@ -0,0 +1,108 @@ +{ stdenv, androidenv, jdk, gnumake, gawk, file +, which, gradle, fetchurl, buildEnv, runCommand }: + +args@{ name, src, platformVersions ? [ "8" ], useGoogleAPIs ? false + # , useExtraSupportLibs ? false, useGooglePlayServices ? false + , release ? false, keyStore ? null, keyAlias ? null + , keyStorePassword ? null, keyAliasPassword ? null + , useNDK ? false, buildInputs ? [], mavenDeps, gradleTask + , buildDirectory ? "./.", acceptAndroidSdkLicenses ? false }: + +assert release -> keyStore != null; +assert release -> keyAlias != null; +assert release -> keyStorePassword != null; +assert release -> keyAliasPassword != null; +assert acceptAndroidSdkLicenses; + +let + inherit (stdenv.lib) optionalString; + + m2install = { repo, version, artifactId, groupId + , jarSha256, pomSha256, aarSha256, suffix ? "" }: + let m2Name = "${artifactId}-${version}"; + m2Path = "${builtins.replaceStrings ["."] ["/"] groupId}/${artifactId}/${version}"; + in runCommand m2Name {} ('' + mkdir -p $out/m2/${m2Path} + '' + optionalString (jarSha256 != null) '' + install -D ${fetchurl { + url = "${repo}${m2Path}/${m2Name}${suffix}.jar"; + sha256 = jarSha256; + }} $out/m2/${m2Path}/${m2Name}${suffix}.jar + '' + optionalString (pomSha256 != null) '' + install -D ${fetchurl { + url = "${repo}${m2Path}/${m2Name}${suffix}.pom"; + sha256 = pomSha256; + }} $out/m2/${m2Path}/${m2Name}${suffix}.pom + '' + optionalString (aarSha256 != null) '' + install -D ${fetchurl { + url = "${repo}${m2Path}/${m2Name}${suffix}.aar"; + sha256 = aarSha256; + }} $out/m2/${m2Path}/${m2Name}${suffix}.aar + ''); + + androidsdkComposition = androidenv.composeAndroidPackages { + inherit platformVersions useGoogleAPIs; + }; +in +stdenv.mkDerivation ({ + inherit src; + name = builtins.replaceStrings [" "] [""] args.name; + + ANDROID_HOME = "${androidsdkComposition.androidsdk}/libexec"; + # ANDROID_NDK_HOME = "${androidsdkComposition.ndk-bundle}/libexec/android-sdk/android-ndk"; + + buildInputs = [ jdk gradle ]; + # ++ + # stdenv.lib.optional useNDK [ androidsdkComposition.ndk-bundle gnumake gawk file which ] ++ + # args.buildInputs; + + DEPENDENCIES = buildEnv { name = "${name}-maven-deps"; + paths = map m2install mavenDeps; + }; + + buildPhase = '' + ${optionalString release '' + # Provide key signing attributes + ( echo "RELEASE_STORE_FILE=${keyStore}" + echo "RELEASE_KEY_ALIAS=${keyAlias}" + echo "RELEASE_STORE_PASSWORD=${keyStorePassword}" + echo "RELEASE_KEY_PASSWORD=${keyAliasPassword}" + ) >> gradle.properties + ''} + buildDir=`pwd` + cp -r $ANDROID_HOME $buildDir/local_sdk + chmod -R 755 local_sdk + export ANDROID_HOME=$buildDir/local_sdk + # Key files cannot be stored in the user's home directory. This + # overrides it. + export ANDROID_SDK_HOME=`pwd` + + mkdir -p "$ANDROID_HOME/licenses" + echo -e "\n8933bad161af4178b1185d1a37fbf41ea5269c55" > "$ANDROID_HOME/licenses/android-sdk-license" + echo -e "\n84831b9409646a918e30573bab4c9c91346d8abd" > "$ANDROID_HOME/licenses/android-sdk-preview-license" + + export APP_HOME=`pwd` + + mkdir -p .m2/repository + if [ -d "$DEPENDENCIES/m2" ] ; then + cp -RL "$DEPENDENCIES"/m2/* .m2/repository/ + fi + chmod -R 755 .m2 + mkdir -p .m2/repository/com/android/support + cp -RL local_sdk/extras/android/m2repository/com/android/support/* .m2/repository/com/android/support/ + cp -RL local_sdk/extras/google/m2repository/* .m2/repository/ + gradle ${gradleTask} --offline --no-daemon -g ./tmp -Dmaven.repo.local=`pwd`/.m2/repository + ''; + + installPhase = '' + mkdir -p $out + mv ${buildDirectory}/build/outputs/apk/*.apk $out + + mkdir -p $out/nix-support + echo "file binary-dist \"$(echo $out/*.apk)\"" > $out/nix-support/hydra-build-products + ''; + + meta = { + license = stdenv.lib.licenses.unfree; + }; +}) # // builtins.removeAttrs args ["name" "mavenDeps"]) diff --git a/android/impl.nix b/android/impl.nix index 791c9e23c..3935012a7 100644 --- a/android/impl.nix +++ b/android/impl.nix @@ -4,6 +4,7 @@ let overrideAndroidCabal = package: overrideCabal package (drv: { sed -i 's%^executable *\(.*\)$%executable lib\1.so\n cc-options: -shared -fPIC\n ld-options: -shared -Wl,--gc-sections,--version-script=${./haskellActivity.version},-u,Java_systems_obsidian_HaskellActivity_haskellStartMain,-u,hs_main\n ghc-options: -shared -fPIC -threaded -no-hs-main -lHSrts_thr -lCffi -lm -llog%i' *.cabal ''; }); + androidenv = nixpkgs.androidenv; #TODO: Keep the signing key for dev mode more consistent, e.g. in ~/.config/reflex-platform, so that the app can be reinstalled in-place addDeployScript = src: nixpkgs.runCommand "android-app" { inherit src; @@ -16,11 +17,16 @@ let overrideAndroidCabal = package: overrideCabal package (drv: { EOF chmod +x "$out/bin/deploy" ''; - buildInputs = [ nixpkgs.androidenv.androidsdk_8_0 ]; + buildInputs = [ androidenv.androidPkgs_9_0.androidsdk ]; } ""; + buildGradleApp = import ./build-gradle-app.nix { + inherit (nixpkgs) stdenv jdk gnumake gawk file runCommand + which gradle fetchurl buildEnv; + inherit androidenv; + }; inherit (nixpkgs.lib) splitString escapeShellArg mapAttrs attrNames concatStrings optionalString; in { - buildApp = args: with args; addDeployScript (nixpkgs.androidenv.buildGradleApp { + buildApp = args: with args; addDeployScript (buildGradleApp { inherit acceptAndroidSdkLicenses; buildDirectory = "./."; # Can be "assembleRelease" or "assembleDebug" (to build release or debug) or "assemble" (to build both) @@ -44,10 +50,10 @@ in { myNixpkgs = nixpkgsCross.android.aarch64; myHaskellPackages = ghcAndroidAarch64; }; - "armeabi-v7a" = { - myNixpkgs = nixpkgsCross.android.aarch32; - myHaskellPackages = ghcAndroidAarch32; - }; + # "armeabi-v7a" = { + # myNixpkgs = nixpkgsCross.android.aarch32; + # myHaskellPackages = ghcAndroidAarch32; + # }; }; abiVersions = attrNames appSOs; in nixpkgs.runCommand "android-app" { @@ -108,7 +114,7 @@ in { [ -d "$out/assets" ] [ -d "$out/res" ] ''); - useExtraSupportLibs = true; #TODO: Should this be enabled by default? + # useExtraSupportLibs = true; #TODO: Should this be enabled by default? useGoogleAPIs = true; #TODO: Should this be enabled by default? # We use the NDK build process diff --git a/examples/project/default.nix b/examples/project/default.nix new file mode 100644 index 000000000..a6869a118 --- /dev/null +++ b/examples/project/default.nix @@ -0,0 +1,7 @@ +{ system ? builtins.currentSystem +, config ? {} +}: +let reflex-platform = import ../../. { inherit system config; }; + projSrc = reflex-platform.hackGet ./reflex-project-skeleton; + proj = import projSrc { inherit reflex-platform; }; +in proj diff --git a/examples/project/reflex-project-skeleton/default.nix b/examples/project/reflex-project-skeleton/default.nix new file mode 100644 index 000000000..d42886c4e --- /dev/null +++ b/examples/project/reflex-project-skeleton/default.nix @@ -0,0 +1 @@ +import ((import {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json))) diff --git a/examples/project/reflex-project-skeleton/git.json b/examples/project/reflex-project-skeleton/github.json similarity index 55% rename from examples/project/reflex-project-skeleton/git.json rename to examples/project/reflex-project-skeleton/github.json index 709b30d55..9f42804cb 100644 --- a/examples/project/reflex-project-skeleton/git.json +++ b/examples/project/reflex-project-skeleton/github.json @@ -1,6 +1,6 @@ { - "url": "git@github.com:obsidiansystems/reflex-project-skeleton", + "owner": "obsidiansystems", + "repo": "reflex-project-skeleton", "rev": "30d29322d74e98d189b755c3d25fffecfee32fe1", - "sha256": "14vcmi3bdmlcj228wj0hzjyqmixyfrd0ch8qzp2655kzik7dbgga", - "fetchSubmodules": false + "sha256": "14vcmi3bdmlcj228wj0hzjyqmixyfrd0ch8qzp2655kzik7dbgga" } diff --git a/haskell-overlays/android/dep/android-activity/default.nix b/haskell-overlays/android/dep/android-activity/default.nix new file mode 100644 index 000000000..d42886c4e --- /dev/null +++ b/haskell-overlays/android/dep/android-activity/default.nix @@ -0,0 +1 @@ +import ((import {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json))) diff --git a/haskell-overlays/android/dep/android-activity/github.json b/haskell-overlays/android/dep/android-activity/github.json index 74234bc52..9a9c4e201 100644 --- a/haskell-overlays/android/dep/android-activity/github.json +++ b/haskell-overlays/android/dep/android-activity/github.json @@ -1,6 +1,6 @@ { "owner": "obsidiansystems", "repo": "android-activity", - "rev": "af7139857b33b8617539a3bb3d8ac91c91daa3de", - "sha256": "0wphsfpswbw5ihqsx456vh406rc8ca0anfkcaz4rxx4lm8prn444" + "rev": "e83e427ac01a86ca4120bbeeef2324b529cc44be", + "sha256": "05x0qqclpah2a49rlhvd1h3ibv0lv5v7lmwd5mym4r0lx3872ng7" } From b99e2307183e5be5f90eafa08185eaf576d83864 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 16 Jul 2019 17:05:06 -0400 Subject: [PATCH 43/55] Add libffi-3.3-rc0 override for android builds --- android/impl.nix | 8 ++++---- nixpkgs-overlays/mobile-ghc/default.nix | 13 +++++++++++++ 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/android/impl.nix b/android/impl.nix index 3935012a7..4888e36db 100644 --- a/android/impl.nix +++ b/android/impl.nix @@ -50,10 +50,10 @@ in { myNixpkgs = nixpkgsCross.android.aarch64; myHaskellPackages = ghcAndroidAarch64; }; - # "armeabi-v7a" = { - # myNixpkgs = nixpkgsCross.android.aarch32; - # myHaskellPackages = ghcAndroidAarch32; - # }; + "armeabi-v7a" = { + myNixpkgs = nixpkgsCross.android.aarch32; + myHaskellPackages = ghcAndroidAarch32; + }; }; abiVersions = attrNames appSOs; in nixpkgs.runCommand "android-app" { diff --git a/nixpkgs-overlays/mobile-ghc/default.nix b/nixpkgs-overlays/mobile-ghc/default.nix index 024b64e87..338b778f4 100644 --- a/nixpkgs-overlays/mobile-ghc/default.nix +++ b/nixpkgs-overlays/mobile-ghc/default.nix @@ -8,4 +8,17 @@ self: super: { ]; })) { inherit (super.haskell.compiler) ghc865 ghcSplices; }; }; + libffi = if self.stdenv.targetPlatform.useAndroidPrebuilt + then + super.libffi.overrideAttrs (drv: { + name = "libffi-3.3-rc0"; + patches = []; + src = builtins.fetchurl { + url = "https://github.com/libffi/libffi/releases/download/v3.3-rc0/libffi-3.3-rc0.tar.gz"; + sha256 = "1kqfyar1xaxrylrw7j1nclqvcgr6a2cisazaamw1a18wpym6fga0"; + }; + postFixup = ""; + }) + else + super.libffi; } From bd2605917fc3e3515e5014330d68c6723bb4783b Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 16 Jul 2019 17:14:53 -0400 Subject: [PATCH 44/55] Add explanation for libffi override --- nixpkgs-overlays/mobile-ghc/default.nix | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/nixpkgs-overlays/mobile-ghc/default.nix b/nixpkgs-overlays/mobile-ghc/default.nix index 338b778f4..9fa4c2e24 100644 --- a/nixpkgs-overlays/mobile-ghc/default.nix +++ b/nixpkgs-overlays/mobile-ghc/default.nix @@ -10,6 +10,9 @@ self: super: { }; libffi = if self.stdenv.targetPlatform.useAndroidPrebuilt then + # Use libffi-3.3-rc0 because the regular libffi is not compatible with android-ndk. + # Google has its own forked libffi (https://android.googlesource.com/platform/external/libffi/) + # but upstream also has a release candidate that fixes the same issues. We're using upstream here: super.libffi.overrideAttrs (drv: { name = "libffi-3.3-rc0"; patches = []; @@ -17,6 +20,9 @@ self: super: { url = "https://github.com/libffi/libffi/releases/download/v3.3-rc0/libffi-3.3-rc0.tar.gz"; sha256 = "1kqfyar1xaxrylrw7j1nclqvcgr6a2cisazaamw1a18wpym6fga0"; }; + # The new version of libffi doesn't require the same post-fixup hacks that 3.2.1 required. Also, + # the postFixup script in nixpkgs-channel 19.03 hardcoded some paths to include "3.2.1" specifically, + # which is no longer valid. postFixup = ""; }) else From bb93de4778550ab84648c607e0977a08073ed69a Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 17 Jul 2019 15:21:18 -0400 Subject: [PATCH 45/55] Use vendored libffi on android --- nixpkgs-overlays/mobile-ghc/default.nix | 29 +++++++------------------ 1 file changed, 8 insertions(+), 21 deletions(-) diff --git a/nixpkgs-overlays/mobile-ghc/default.nix b/nixpkgs-overlays/mobile-ghc/default.nix index 9fa4c2e24..f0014428f 100644 --- a/nixpkgs-overlays/mobile-ghc/default.nix +++ b/nixpkgs-overlays/mobile-ghc/default.nix @@ -1,30 +1,17 @@ { lib }: -self: super: { +let # Setting libffi to null causes GHC to use its own vendored libffi, which seems to be + # necessary on android. See discussion here: + # https://github.com/reflex-frp/reflex-platform/pull/506#issuecomment-511978967 + overrideLibffiOnAndroid = self: v: if self.stdenv.targetPlatform.useAndroidPrebuilt + then v.override { libffi = null; } + else v; +in self: super: { haskell = super.haskell // { - compiler = super.haskell.compiler // lib.mapAttrs (n: v: v.overrideAttrs (drv: { + compiler = super.haskell.compiler // lib.mapAttrs (n: v: (overrideLibffiOnAndroid self v).overrideAttrs (drv: { patches = (drv.patches or []) ++ lib.optionals self.stdenv.targetPlatform.useAndroidPrebuilt [ ./8.6.y/android-patches/force-relocation.patch ]; })) { inherit (super.haskell.compiler) ghc865 ghcSplices; }; }; - libffi = if self.stdenv.targetPlatform.useAndroidPrebuilt - then - # Use libffi-3.3-rc0 because the regular libffi is not compatible with android-ndk. - # Google has its own forked libffi (https://android.googlesource.com/platform/external/libffi/) - # but upstream also has a release candidate that fixes the same issues. We're using upstream here: - super.libffi.overrideAttrs (drv: { - name = "libffi-3.3-rc0"; - patches = []; - src = builtins.fetchurl { - url = "https://github.com/libffi/libffi/releases/download/v3.3-rc0/libffi-3.3-rc0.tar.gz"; - sha256 = "1kqfyar1xaxrylrw7j1nclqvcgr6a2cisazaamw1a18wpym6fga0"; - }; - # The new version of libffi doesn't require the same post-fixup hacks that 3.2.1 required. Also, - # the postFixup script in nixpkgs-channel 19.03 hardcoded some paths to include "3.2.1" specifically, - # which is no longer valid. - postFixup = ""; - }) - else - super.libffi; } From b61e21688bb47757f1b557ff8cef68d97894027a Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 17 Jul 2019 20:11:40 -0400 Subject: [PATCH 46/55] Update build-gradle-app to use new gradle and androidenv --- android/build-gradle-app.nix | 28 +- android/build.gradle.nix | 8 +- android/defaults/deps.nix | 900 +++++++++++++++++++++++------------ android/defaults/pom.xml | 14 +- android/impl.nix | 4 +- 5 files changed, 612 insertions(+), 342 deletions(-) diff --git a/android/build-gradle-app.nix b/android/build-gradle-app.nix index 5984b47c8..541fce6fa 100644 --- a/android/build-gradle-app.nix +++ b/android/build-gradle-app.nix @@ -1,8 +1,8 @@ { stdenv, androidenv, jdk, gnumake, gawk, file , which, gradle, fetchurl, buildEnv, runCommand }: -args@{ name, src, platformVersions ? [ "8" ], useGoogleAPIs ? false - # , useExtraSupportLibs ? false, useGooglePlayServices ? false +args@{ name, src, platformVersions ? [ "8" ] + , useGoogleAPIs ? false, useGooglePlayServices ? false , release ? false, keyStore ? null, keyAlias ? null , keyStorePassword ? null, keyAliasPassword ? null , useNDK ? false, buildInputs ? [], mavenDeps, gradleTask @@ -15,7 +15,7 @@ assert release -> keyAliasPassword != null; assert acceptAndroidSdkLicenses; let - inherit (stdenv.lib) optionalString; + inherit (stdenv.lib) optionalString optional; m2install = { repo, version, artifactId, groupId , jarSha256, pomSha256, aarSha256, suffix ? "" }: @@ -39,9 +39,10 @@ let sha256 = aarSha256; }} $out/m2/${m2Path}/${m2Name}${suffix}.aar ''); - androidsdkComposition = androidenv.composeAndroidPackages { inherit platformVersions useGoogleAPIs; + includeExtras = [ "extras;android;m2repository" ] + ++ optional useGooglePlayServices "extras;google;google_play_services"; }; in stdenv.mkDerivation ({ @@ -49,12 +50,9 @@ stdenv.mkDerivation ({ name = builtins.replaceStrings [" "] [""] args.name; ANDROID_HOME = "${androidsdkComposition.androidsdk}/libexec"; - # ANDROID_NDK_HOME = "${androidsdkComposition.ndk-bundle}/libexec/android-sdk/android-ndk"; + ANDROID_NDK_HOME = "${androidsdkComposition.ndk-bundle}/libexec/android-sdk/ndk-bundle"; - buildInputs = [ jdk gradle ]; - # ++ - # stdenv.lib.optional useNDK [ androidsdkComposition.ndk-bundle gnumake gawk file which ] ++ - # args.buildInputs; + buildInputs = [ jdk gradle ] ++ buildInputs ++ stdenv.lib.optional useNDK [ androidsdkComposition.ndk-bundle gnumake gawk file which ]; DEPENDENCIES = buildEnv { name = "${name}-maven-deps"; paths = map m2install mavenDeps; @@ -72,7 +70,7 @@ stdenv.mkDerivation ({ buildDir=`pwd` cp -r $ANDROID_HOME $buildDir/local_sdk chmod -R 755 local_sdk - export ANDROID_HOME=$buildDir/local_sdk + export ANDROID_HOME=$buildDir/local_sdk/android-sdk # Key files cannot be stored in the user's home directory. This # overrides it. export ANDROID_SDK_HOME=`pwd` @@ -89,20 +87,16 @@ stdenv.mkDerivation ({ fi chmod -R 755 .m2 mkdir -p .m2/repository/com/android/support - cp -RL local_sdk/extras/android/m2repository/com/android/support/* .m2/repository/com/android/support/ - cp -RL local_sdk/extras/google/m2repository/* .m2/repository/ + cp -RL local_sdk/android-sdk/extras/android/m2repository/com/android/support/* .m2/repository/com/android/support/ gradle ${gradleTask} --offline --no-daemon -g ./tmp -Dmaven.repo.local=`pwd`/.m2/repository ''; installPhase = '' mkdir -p $out - mv ${buildDirectory}/build/outputs/apk/*.apk $out - - mkdir -p $out/nix-support - echo "file binary-dist \"$(echo $out/*.apk)\"" > $out/nix-support/hydra-build-products + cp -RL build/outputs/apk/*/*.apk $out ''; meta = { license = stdenv.lib.licenses.unfree; }; -}) # // builtins.removeAttrs args ["name" "mavenDeps"]) +} // builtins.removeAttrs args ["name" "mavenDeps"]) diff --git a/android/build.gradle.nix b/android/build.gradle.nix index ede0f844b..f785a3766 100644 --- a/android/build.gradle.nix +++ b/android/build.gradle.nix @@ -12,7 +12,7 @@ buildscript { mavenLocal() } dependencies { - classpath 'com.android.tools.build:gradle:2.3.0' + classpath 'com.android.tools.build:gradle:3.1.0' ${googleServicesClasspath} } } @@ -25,8 +25,8 @@ allprojects { apply plugin: 'com.android.application' android { - compileSdkVersion 26 - buildToolsVersion '26.0.0' + compileSdkVersion 28 + buildToolsVersion '28.0.3' sourceSets { main { @@ -40,7 +40,7 @@ android { defaultConfig { applicationId "${applicationId}" minSdkVersion 21 - targetSdkVersion 26 + targetSdkVersion 28 versionCode ${version.code} versionName "${version.name}" } diff --git a/android/defaults/deps.nix b/android/defaults/deps.nix index 77d012d9f..fc13694b3 100644 --- a/android/defaults/deps.nix +++ b/android/defaults/deps.nix @@ -1,288 +1,352 @@ [ { artifactId = "baseLibrary"; groupId = "com.android.databinding"; - version = "2.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "d3cbb38a09f934cf9de92310ed7b97717cc965fe5e4c4a022f3aa72e7c2cef6b"; - pomSha256 = "270e0e778e40136ae8eb2bf520325c3db57c21f5f6e5c84046d1e48bf2e2b719"; + version = "3.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "788dd6aa22a49fecd1d7125b717c46103025bb647f9b50b6cb70f58e0962884d"; + pomSha256 = "79d0d2111187b8af3ad3635d815595f7b50c49685463784fe6bd7c3f897358e3"; aarSha256 = null; } { artifactId = "compilerCommon"; groupId = "com.android.databinding"; - version = "2.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "482cf1b60bf207b6456c49c458dd01fc56de57af4c07c4eaa06fd174fed5f9af"; - pomSha256 = "5b0fa91a9f30eaacfa52aecceb4fa1199ea01e532de7bd19a2a822047539876a"; + version = "3.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "5c7d7b188eb06a074a0c7131fc5a22cd9f3fc2cd5810ec32222d18cffdf8144f"; + pomSha256 = "cbe7dab110aa887f6d7ae1ed209eb679e1334a154f1f02b8a92a693fea6299a0"; aarSha256 = null; } { artifactId = "annotations"; groupId = "com.android.tools"; version = "24.5.0"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "29fbaf8e9ee7cbdbbf3e23c2955c04bb752d835d2c4c90936e89e023517dd922"; pomSha256 = "c3c99bf58182889fe86315e9a01473ee2c95540b9dedef898cec64554d925c54"; aarSha256 = null; } { artifactId = "annotations"; groupId = "com.android.tools"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "6e6d7ceeba24a82a4def69c2d4fabe9803527e11827143bb5653353852fdd32b"; - pomSha256 = "57e6d283bf7c2cc813d834f402b4d685c7f7eface3a6376e4db7fcff6aab60d6"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "cd69e90c331faa78ae5e65509a2ac9df452d1ee2bad7cf3034f073fc1c1305af"; + pomSha256 = "59ac55c581df73ba7efdc454c9134a63330db42f62053a675f36ad22265e3b6b"; aarSha256 = null; } { artifactId = "common"; groupId = "com.android.tools"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "662780de8a38bc73642b797cb4509d4eb0475658090771fc4bd139ac918d64da"; - pomSha256 = "c8f734839c62f8b49b5d0cf5c9a71ba07ac36829fbeb1fa9071f5cc263980ca5"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "b24e096cdd8ca1c38ce34f722bfea3e60ce5017a0c637af6b229d9bc3fc3a14a"; + pomSha256 = "7d90ddec5f11b616aa80ff306bd818d1133f3cffafca88cc3e2bdd659863c75b"; aarSha256 = null; } { artifactId = "dvlib"; groupId = "com.android.tools"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "0002c6e9f0f0a28d2aaccab81b7b7ea0f162b380057d7bebe745c0f42d3ea07a"; - pomSha256 = "26e61846e3d35a449bae3c42d3211342ac759d1509b1f67a7ff4f8e2478195fb"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "3790edb05c95577ea2cf3430158b494ffef7f3fce90cd7da1b68e5d52c2e2812"; + pomSha256 = "6b93985e7deda921224dccd63031eeb9b282c00eff3103b3cca4dfd945b0d7e9"; aarSha256 = null; } { artifactId = "repository"; groupId = "com.android.tools"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "0d8650bfe3ec4e967b2d05e7c9c245d5c784944acc960f92c42ee33a785f1e72"; - pomSha256 = "5d045484b7535d87970d966fa011c4e110f7a0435acc09031349a19d0a231c65"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "e65a921804a1daa865c73fa8e68286d22353434f60612fc61f5e584dd6d88e32"; + pomSha256 = "e9344a57c53db3a11520d160da91482d0f491c08edde34bc1c5b4fb5baf798f1"; aarSha256 = null; } { artifactId = "sdk-common"; groupId = "com.android.tools"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "33913aab3d1c5d3d687d3e202627374208d1b548892881893fdb8b6cef866662"; - pomSha256 = "5fd21c9b3a6ae309e3b959eb606341dbd8b0adfbea0f652b836073da32fa832d"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "38954e8d9c297d62846ac7bcddc7a5758a184ec1b05092e5e1089650be4962b0"; + pomSha256 = "02554156b6af9aafbb34da23ad09ccc93383657b47b2ac8e151ec325966a8e72"; aarSha256 = null; } { artifactId = "sdklib"; groupId = "com.android.tools"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "dd0c40cf6e75cb90d772749f353b7faddcdc0c7ac072a0b50d5641159aaed17a"; - pomSha256 = "6f0ff03465f8730ac156c1b18a360697e3195c1bd8c4800289f39e001ac85a29"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "d4ebd42e1dbc81281085cdf5b56cebb183a9b8aeae51a84f53ff84774abcc94e"; + pomSha256 = "8971cb4273045b0af916ce6ebeb140527b9ebc917319ce5d1ea266362690e4dd"; aarSha256 = null; } { artifactId = "protos"; groupId = "com.android.tools.analytics-library"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "428719a449a74c8e1b9f9efa2680d03f66d49566e97fde5f4a053eee9ebc55dd"; - pomSha256 = "3243846f4f7f2595e07a75eb59608ca2d7e8c4198c2a74f142df3b12a94928c7"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "80c134366b35e375d2ed22158d8958f3732366fa80980df76bd632371368eb96"; + pomSha256 = "5a3f320877640666ea483eb6764e6d407c283c324d4d45b38db9d5fbfc8bdf8b"; aarSha256 = null; } { artifactId = "shared"; groupId = "com.android.tools.analytics-library"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "9d9798b132b18ce2dc1f043eec473480db88b050a004d2c0a8a2e83500d2cd89"; - pomSha256 = "7b12feb1db2ff97319feb1864631fbe9e19e5bea79bf53c3746b6fae1114ac88"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "9772cb36f7498ca30f0accf25911560753fbe9167c3af58e8b00e7eb6ac1f7c3"; + pomSha256 = "8c5adb944e161657e866270783fb92a4a6bf2c1e5d3211a98b7ab1b3b7c91cb2"; aarSha256 = null; } { artifactId = "tracker"; groupId = "com.android.tools.analytics-library"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "a752bbb4dcbc9baf555b7a2b1b525781cae731caf9b9701bfdc5e4506c10bf5c"; - pomSha256 = "03aa68be0872f2f1f04ca6e3be446c89265b069d57925454d437cd1a7439f11b"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "ed9d26dce59d2e5b436702da2f7c57d52754c3afbc558872db30ac110279967d"; + pomSha256 = "77fa615c35438801d49a487f82b6426d5f55c516b7a287d975c25432dc77af7a"; + aarSha256 = null; } + + { artifactId = "aapt2-proto"; + groupId = "com.android.tools.build"; + version = "0.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "20a5111ef908e8cbab6c0a0e3ae1c031fa1460ed6bb00b4f621e9e93e6fac9f4"; + pomSha256 = "6ca265a30441628d070e4abe03b3c3c9ddadbcf3a06283ba0d6506baaaa23bc1"; + aarSha256 = null; } + + { artifactId = "apksig"; + groupId = "com.android.tools.build"; + version = "3.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "fa7c629e1ef9e8e3bedd647431f5d023ba87b5ad536c3a79497e2cd8c40f40be"; + pomSha256 = "48b9884f3c8d7765749723a8224299fa73bdb453c54126529c274305bc37077d"; aarSha256 = null; } { artifactId = "builder"; groupId = "com.android.tools.build"; - version = "2.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "0adabd61e2fbedefc1c0589fc95f827e20e18fc3f757ae439b1907e9453f2dfa"; - pomSha256 = "2c60b8a882eb3194892a0dd516225108ac62e60449bbfec261f087b7d2b652ac"; + version = "3.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "2166e41cacbce74d2573afd585b719b826f34863d7d9e9db1103e61686857ad1"; + pomSha256 = "01b97e89902e1a85de0d7a6708d56dca8b8ca4c496f2710e777f3c74e2dd9660"; aarSha256 = null; } { artifactId = "builder-model"; groupId = "com.android.tools.build"; - version = "2.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "6f079860658e3d48e9a3f96748322f8a550208ea2a3af1f10275ad28cc77b4cb"; - pomSha256 = "e070337e26e9201c2215cf809aa0c327690f003d94d6fe333484978f18ce4b19"; + version = "3.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "3101fdd6ae78f7fd4a2f5fd15c50d2fc321f2978f2e732e2c9729bdafd85fdf7"; + pomSha256 = "31641a4746e77cec3e3375c9973530f82a389bead83099f32dcfc38137695557"; aarSha256 = null; } { artifactId = "builder-test-api"; groupId = "com.android.tools.build"; - version = "2.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "704d05bbea08775433442dd55aac399c31c68a575715499a87d6350a3fe543a2"; - pomSha256 = "a311a5a48ea3aa882429507fb603865cf3bc93b161f558b083e055b192dc8743"; + version = "3.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "51642702f1610ac3802c930983ba37737cfa1aedce849de2071f14b9fe6a6f3a"; + pomSha256 = "0aa1569bf11a2f78d202b63ef747f82a3ba0c3affaa6ff2f5071620264d2648e"; + aarSha256 = null; } + + { artifactId = "bundletool"; + groupId = "com.android.tools.build"; + version = "0.1.0-alpha01"; + repo = "https://maven.google.com/"; + jarSha256 = "3bdb56f0bfabcd26ef63e58700f0d7e5087cd1e95e1abe2aa2e4b300b5616f15"; + pomSha256 = "6c6776338f04a28676ab0d4ad13a1ada690998f4a843068cd3af7589f6d3e188"; aarSha256 = null; } { artifactId = "gradle"; groupId = "com.android.tools.build"; - version = "2.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "0cd659bab21ebc6681743c00bdc628df7b735ad1a25928d3abf618ed73527e7c"; - pomSha256 = "917f563dc6718e206d10be377ea67d4dfa0fdc97324abae530593ada6cabcb85"; + version = "3.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "f05f7bcfa15bbc61a197b6f575a0ad4a1ef750f9e906e29e4362a7059ba7616d"; + pomSha256 = "dc417b6aa3ec6ff879b13720a11f463aa00f1f9ab7c33b9fe4006de67c29cd52"; aarSha256 = null; } { artifactId = "gradle-api"; groupId = "com.android.tools.build"; - version = "2.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "4f502ae3d138d8b643434ac5cc2bf922480b3bd2c16f25c63f9a04a170f2d6bd"; - pomSha256 = "74aeccfff164490778560fbfc93017895e8fdffd05494b4d03fc17e6b5bdfd27"; + version = "3.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "b74049d19d3cf68a74da30e88e2d10b1e5127a555de32ccabde05cbbf36211d7"; + pomSha256 = "075e524b0db8885e885806f6fc7e6832c7af3c74dd7806b9c59a2ce321fd1f32"; aarSha256 = null; } { artifactId = "gradle-core"; groupId = "com.android.tools.build"; - version = "2.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "257ea002d291ddecccb73c1848c13c0c5f4085c023f77893b9d0b699d18869cb"; - pomSha256 = "87c2714674bb416d81e88051b75bd66100dc49ab305f8ca8b6decc38e7ed62ad"; + version = "3.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "3233ce076be21d977a817abfe7d937739f7a1d6dac30a497df30124989d2da85"; + pomSha256 = "8d5bbd5948e49bbc51f42c029d3a4bf8f2b8b495c8e25fc0cf0efc9df5f07054"; aarSha256 = null; } { artifactId = "manifest-merger"; groupId = "com.android.tools.build"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "7c1f3d1448bda59c267c7f21d61984c02dff18be18a4a9aacb5c503d4e2259ea"; - pomSha256 = "b308b44a1f7307cbb95d39abc3b298bf7074b3c05aa36e32c0ce8dc979e9876e"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "a096805a7e0fb3dc10fa47c325186bebb55bbf5c77cb54dd4b1c71b723692628"; + pomSha256 = "041cda360c68cb182a9b2cfae639d4b3590f714181b756452905aff9a4e5e2ed"; aarSha256 = null; } { artifactId = "transform-api"; groupId = "com.android.tools.build"; version = "2.0.0-deprecated-use-gradle-api"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "e8b4151ae1679f1abe7a14ee371ac9b3c651ae7b63290d1f586bdd0f78face9a"; pomSha256 = "d49d179f707d3f3a00b2a7d36136b54aa8d44fa22770703cd82fe52fb39e22eb"; aarSha256 = null; } { artifactId = "ddmlib"; groupId = "com.android.tools.ddms"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "b9c31bf247d5d5f6feeaf716d3a88c9e755d3b882464c2d3fc01fa85c6202691"; - pomSha256 = "afa5084301c0426932a92dee57ec91850d7255a541f202278f30d65992c4ec7a"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "6d95df7310eecf36772e74e25bf9dcffe8d1caf3614fb173443f5a5d6c937fe1"; + pomSha256 = "674c6cc0741b9babe0f154734d826c4313889bf8a9e6b3ca8af8c1bf206ebbf5"; + aarSha256 = null; } + + { artifactId = "layoutlib-api"; + groupId = "com.android.tools.layoutlib"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "29da0f2265bf14cea484bb492813318c9268afc0aac85e625ba6d0e85382ef61"; + pomSha256 = "2a587e265c5ce8aa01d4f2a5958a6c8cd4d56f28d1dcdbfb53daadb1158a898f"; + aarSha256 = null; } + + { artifactId = "lint-gradle-api"; + groupId = "com.android.tools.lint"; + version = "26.1.0"; + repo = "https://maven.google.com/"; + jarSha256 = "165576ede06d1a6466ded082938d162ed98bbdfb5e829874a18ffb58e59ec2ad"; + pomSha256 = "6743e37575c3138fe821ff1afd78d4545db8b0e850efac139dff36bb6590d46b"; aarSha256 = null; } - { artifactId = "uast"; - groupId = "com.android.tools.external.com-intellij"; - version = "162.2228.14"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "a05c0296690d329b4bbac0c36697de85be96d4e86b260acdfe2748fdd9abfd54"; - pomSha256 = "9dba64dac0e53f69fdab933171d5edbdb58584094cdb3c800f3c60fc7d3cdd31"; + { artifactId = "google"; + groupId = "com.google"; + version = "1"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "cd6db17a11a31ede794ccbd1df0e4d9750f640234731f21cff885a9997277e81"; aarSha256 = null; } - { artifactId = "lombok-ast"; - groupId = "com.android.tools.external.lombok"; - version = "0.2.3"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "45eb0d6e49430271b5fb385c53fae0b81d6ad3eae465a7a8d948217bcae1e86d"; - pomSha256 = "8c6191e0dd8bfdc862332cb79b08185ac5b63565d405dac2605be4c2b19774bd"; + { artifactId = "auto-parent"; + groupId = "com.google.auto"; + version = "3"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "c98f1b0978cfd24712c27388e040c50ce0692252b3aa9448603d9efa05ebe8a8"; aarSha256 = null; } - { artifactId = "jack-api"; - groupId = "com.android.tools.jack"; - version = "0.13.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "84263233bd055c0b28783c28ed92b46a03fe86facd8d9bd40b4facf5aeb3a6a0"; - pomSha256 = "8c6c25c596c24567b85dbe3f490784356e5633c9d5017b88de73d5c47603607c"; + { artifactId = "auto-value"; + groupId = "com.google.auto.value"; + version = "1.5.2"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "6cac9421439b39b9f4aa76738ced039462a69911c410f2c372c196b0f4b7f4cf"; + pomSha256 = "901fb1440a0ef8e0c0553a7bb44c0b89647bf53c8822642eea0b57173c7c688d"; aarSha256 = null; } - { artifactId = "jill-api"; - groupId = "com.android.tools.jill"; - version = "0.10.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "98a3906af5f018131160afaf2387ca08c5bf5b9fc1b2d156e88ede145e29f66f"; - pomSha256 = "91a4433121215f31511f96b7ff53e9bb169a0a26127168c32e278c6e03a257cc"; + { artifactId = "jsr305"; + groupId = "com.google.code.findbugs"; + version = "1.3.9"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "905721a0eea90a81534abb7ee6ef4ea2e5e645fa1def0a5cd88402df1b46c9ed"; + pomSha256 = "feab9191311c3d7aeef2b66d6064afc80d3d1d52d980fb07ae43c78c987ba93a"; aarSha256 = null; } - { artifactId = "layoutlib-api"; - groupId = "com.android.tools.layoutlib"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "98fb25637abe3bee27d39cd73b4b8f972a6d86f1a5a603d9c5057bbfb04da673"; - pomSha256 = "3aad205e8772bbea36ad3e4d894ea73ceba69901ac86fbf2d4cfc5881e03d2a0"; + { artifactId = "gson"; + groupId = "com.google.code.gson"; + version = "2.7"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "2d43eb5ea9e133d2ee2405cc14f5ee08951b8361302fdd93494a3a997b508d32"; + pomSha256 = "723936ec07b87b210a44ef8058f32f56e3d56442218dfbf8f4e538a927160ede"; aarSha256 = null; } - { artifactId = "lint"; - groupId = "com.android.tools.lint"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "f1ea8cf96c911fe851db4bea28f21294a9a8e97e6018a50f081a8dae577a479a"; - pomSha256 = "a14bbdc5f79f1f903d65d1b7f0b42da95485a96452a7ec8609acc08110dafd7f"; + { artifactId = "gson-parent"; + groupId = "com.google.code.gson"; + version = "2.7"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "871e8c737322301f0cc8acfe39a2960c4579d9d8666aeea5298bb6fcc9e4272b"; aarSha256 = null; } - { artifactId = "lint-api"; - groupId = "com.android.tools.lint"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "243d416fb8fcd6a4c974fea03a63292c1caf59117aea5435c9860511b42db633"; - pomSha256 = "55eb36626428577b255b02836a6f535d6d7a1f9d2abba7738fbcf52609b57eae"; + { artifactId = "error_prone_annotations"; + groupId = "com.google.errorprone"; + version = "2.0.18"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "cb4cfad870bf563a07199f3ebea5763f0dec440fcda0b318640b1feaa788656b"; + pomSha256 = "9144127192d6f612c2366825dceaeb23b0d53130b83e0bf1ffe107d1470a8487"; aarSha256 = null; } - { artifactId = "lint-checks"; - groupId = "com.android.tools.lint"; - version = "25.3.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "8fbd4891d48829cd8098525ef2c1e9d975e035e544024e0587b24cef8ab3f5f3"; - pomSha256 = "1abd971bc1c0d439ea080b5d17c6ca86cb0afbd751bf9e21c28b3883e438fe06"; + { artifactId = "error_prone_annotations"; + groupId = "com.google.errorprone"; + version = "2.1.2"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "de3c873b5dc06060f7a2a4d9b872a3f4dc1955c18095ef9702d13477e437782a"; + pomSha256 = "180a588bb8b4ed7cc554578b0dbfdb1aecfb3380922173df6541da18ee230911"; aarSha256 = null; } - { artifactId = "google"; - groupId = "com.google"; - version = "1"; - repo = "https://repo1.maven.org/maven2/"; + { artifactId = "error_prone_parent"; + groupId = "com.google.errorprone"; + version = "2.0.18"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "cd6db17a11a31ede794ccbd1df0e4d9750f640234731f21cff885a9997277e81"; + pomSha256 = "cf149955279b07d4f11e817985c1164a69e930d73db7441b43a6ef53bbd286c4"; aarSha256 = null; } - { artifactId = "gson"; - groupId = "com.google.code.gson"; - version = "2.2.4"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "c0328cd07ca9e363a5acd00c1cf4afe8cf554bd6d373834981ba05cebec687fb"; - pomSha256 = "ae984d5d19894ce6dc4689866eaa12f8fc31409113e60ee3b44853b8ac4fd380"; + { artifactId = "error_prone_parent"; + groupId = "com.google.errorprone"; + version = "2.1.2"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "c6b6d61ddb8f6b3bf29e8dafe35ff5d5a1ea90304b457e05657c1e7b8063a143"; aarSha256 = null; } { artifactId = "guava"; groupId = "com.google.guava"; - version = "17.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "8c36a80ea613d0b6b8040a17cf837c5bbe3677bc1b06a058a6c174fdb787ebbc"; - pomSha256 = "2a0d16010d3825c732aeab1d25f181074945063d8f76c28004e7d423d66cb75b"; + version = "18.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "d664fbfc03d2e5ce9cab2a44fb01f1d0bf9dfebeccc1a473b1f9ea31f79f6f99"; + pomSha256 = "e743d61d76f76b5dc060d6f7914fdd41c4418b3529062556920116a716719836"; + aarSha256 = null; } + + { artifactId = "guava"; + groupId = "com.google.guava"; + version = "19.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "58d4cc2e05ebb012bbac568b032f75623be1cb6fb096f3c60c72a86f7f057de4"; + pomSha256 = "addc064da7f1077fdf4dc90e5aaa887cd790850d1b74fe2e6e25d5f78551ac63"; aarSha256 = null; } { artifactId = "guava"; + groupId = "com.google.guava"; + version = "22.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "1158e94c7de4da480873f0b4ab4a1da14c0d23d4b1902cc94a58a6f0f9ab579e"; + pomSha256 = "bfadb3b40f65dd6de1666d6b29f8bb54031396c76eeef4146cf9f28255f8bf33"; + aarSha256 = null; } + + { artifactId = "guava-parent"; groupId = "com.google.guava"; version = "18.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "d664fbfc03d2e5ce9cab2a44fb01f1d0bf9dfebeccc1a473b1f9ea31f79f6f99"; - pomSha256 = "e743d61d76f76b5dc060d6f7914fdd41c4418b3529062556920116a716719836"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "a4accc8895e757f6a33f087e4fd0b661c5638ffe5e0728f298efe7d80551b166"; aarSha256 = null; } { artifactId = "guava-parent"; groupId = "com.google.guava"; - version = "17.0"; - repo = "https://repo1.maven.org/maven2/"; + version = "19.0"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "9fba53585551d3c775179de859760a73c4beab407dfde16b551a09a87b50532a"; + pomSha256 = "3b76ff43ecdf10f74da36e4aae2b470c9d063e053c5ca026f5512ae94f1c3e10"; aarSha256 = null; } { artifactId = "guava-parent"; groupId = "com.google.guava"; - version = "18.0"; - repo = "https://repo1.maven.org/maven2/"; + version = "22.0"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "a4accc8895e757f6a33f087e4fd0b661c5638ffe5e0728f298efe7d80551b166"; + pomSha256 = "1eaf9182e1977c1c50a70edbfbf70536398c68990bfaafc9f0e9899041201539"; + aarSha256 = null; } + + { artifactId = "j2objc-annotations"; + groupId = "com.google.j2objc"; + version = "1.1"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "2994a7eb78f2710bd3d3bfb639b2c94e219cedac0d4d084d516e78c16dddecf6"; + pomSha256 = "f0c98c571e93a7cb4dd18df0fa308f0963e7a0620ac2d4244e61e709d03ad6be"; aarSha256 = null; } { artifactId = "jimfs"; groupId = "com.google.jimfs"; version = "1.1"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "c4828e28d7c0a930af9387510b3bada7daa5c04d7c25a75c7b8b081f1c257ddd"; pomSha256 = "efa86e5cd922f17b472fdfcae57234d8d4ac3e148b6250737dfce454af7a7a44"; aarSha256 = null; } @@ -290,63 +354,159 @@ { artifactId = "jimfs-parent"; groupId = "com.google.jimfs"; version = "1.1"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "c71555751e57e0ef912870e8ac9625ae782502a6a5b9c19ccf83b2a97d8b26bd"; aarSha256 = null; } { artifactId = "protobuf-java"; groupId = "com.google.protobuf"; - version = "3.0.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "a1e7d6b3efc1703c7c8f1b15ecf8757f17d0ac41f32c9a48481a5caf638c55db"; - pomSha256 = "e4c7afb8f0d7aa159318d42a011cc2c9b0525d820973cbca5318bec6c649cecc"; + version = "3.4.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "dce7e66b32456a1b1198da0caff3a8acb71548658391e798c79369241e6490a4"; + pomSha256 = "83f17ba86c5fa1a15a3a3c8030d4ce42ef21c1d39b65db6cc004a8eeb2c59406"; + aarSha256 = null; } + + { artifactId = "protobuf-java-util"; + groupId = "com.google.protobuf"; + version = "3.4.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "4189e0be5ab15cf2330f70b24fbdc75ca37514f188388fce8580ce16a9a68052"; + pomSha256 = "89c43073e7eaa0eaba72a4a36ae1b6bfdfe5d81bb9d0e156aee05e4a72de3cb8"; aarSha256 = null; } { artifactId = "protobuf-parent"; groupId = "com.google.protobuf"; - version = "3.0.0"; - repo = "https://repo1.maven.org/maven2/"; + version = "3.4.0"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "932e6bab9a24a7bc958bbdb7e29e04d083b473d11c4ba3fab1e9b7149579f272"; + pomSha256 = "24909c552842c0eb7a4c769d631a43cbef5a9a10c1640f2bdbd1ea149c573a47"; + aarSha256 = null; } + + { artifactId = "json-simple"; + groupId = "com.googlecode.json-simple"; + version = "1.1"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "2d9484f4c649f708f47f9a479465fc729770ee65617dca3011836602264f6439"; + pomSha256 = "47a89be0fa0fedd476db5fd2c83487654d2a119c391f83a142be876667cf7dab"; aarSha256 = null; } { artifactId = "juniversalchardet"; groupId = "com.googlecode.juniversalchardet"; version = "1.0.3"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "757bfe906193b8b651e79dc26cd67d6b55d0770a2cdfb0381591504f779d4a76"; pomSha256 = "7846399b35c7cd642a9b3a000c3e2d62d04eb37a4547b6933cc8b18bcc2f086b"; aarSha256 = null; } - { artifactId = "annotations"; - groupId = "com.intellij"; - version = "12.0"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "f8ab13b14be080fe2f617f90e55599760e4a1b4deeea5c595df63d0d6375ed6d"; - pomSha256 = "faf82de0dc02e0c0ae327cd653f37255496b2e53fce280b3ab4cb34553a89086"; + { artifactId = "javapoet"; + groupId = "com.squareup"; + version = "1.8.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "8e108c92027bb428196f10fa11cffbe589f7648a6af2016d652279385fdfd789"; + pomSha256 = "b3760f40f19e735b2cd418f7656335d926d1d9413e10982a1c9695b64edbb647"; aarSha256 = null; } { artifactId = "javawriter"; groupId = "com.squareup"; version = "2.5.0"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "fcfb09fb0ea0aa97d3cfe7ea792398081348e468f126b3603cb3803f240197f0"; pomSha256 = "e1abd7f1116cf5e0c59947693e2189208ec94296b2a3394c959e3511d399a7b0"; aarSha256 = null; } + { artifactId = "all"; + groupId = "com.sun.activation"; + version = "1.2.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "1d8518e3ac7532a104e4f7be77def37c982e530723c6bdb3d67708cce2b0c2c4"; + aarSha256 = null; } + + { artifactId = "javax.activation"; + groupId = "com.sun.activation"; + version = "1.2.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "993302b16cd7056f21e779cc577d175a810bb4900ef73cd8fbf2b50f928ba9ce"; + pomSha256 = "f879b6e945854c6900b0dbee1c8384d7ab3de7e157fd7ac84937405c416d2a5e"; + aarSha256 = null; } + + { artifactId = "istack-commons"; + groupId = "com.sun.istack"; + version = "2.21"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "c3071277f89b162982606b4e65c92077212efb6cbf1bdc365c51bd0b57ac818c"; + aarSha256 = null; } + + { artifactId = "istack-commons-runtime"; + groupId = "com.sun.istack"; + version = "2.21"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "c33e67a0807095f02a0e2da139412dd7c4f9cc1a4c054b3e434f96831ba950f4"; + pomSha256 = "ebe7137b5fbfd050545f9a7f3f339ae55beb0b53755071b4fd62aa024c626d1c"; + aarSha256 = null; } + + { artifactId = "jaxb-bom-ext"; + groupId = "com.sun.xml.bind"; + version = "2.2.11"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "b25e0693de21cb92b039a2e4608f396590fb8773108f10d6dc9f1465f03b5be9"; + aarSha256 = null; } + + { artifactId = "jaxb-parent"; + groupId = "com.sun.xml.bind.mvn"; + version = "2.2.11"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "b5301b711c01547e571b615f9a0832ee525d34a4ce3372f53907a87cf20b0480"; + aarSha256 = null; } + + { artifactId = "jaxb-runtime-parent"; + groupId = "com.sun.xml.bind.mvn"; + version = "2.2.11"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "21918cb8e4eda67f24251e909a5d81672201d93604c4ffbf33522ad836a58e90"; + aarSha256 = null; } + + { artifactId = "jaxb-txw-parent"; + groupId = "com.sun.xml.bind.mvn"; + version = "2.2.11"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "9a398c699a5d3f3b56f1056c68890ede25d94a12d98eabc2a473733e6ab2362c"; + aarSha256 = null; } + + { artifactId = "FastInfoset"; + groupId = "com.sun.xml.fastinfoset"; + version = "1.2.13"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "27a77db909f3c2833c0b1a37c55af1db06045118ad2eed96ce567b6632bce038"; + pomSha256 = "b7505e0ecf7d495b4daa3e6569f71611d1a789dc531cbd92a2025922ff2655d3"; + aarSha256 = null; } + + { artifactId = "fastinfoset-project"; + groupId = "com.sun.xml.fastinfoset"; + version = "1.2.13"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "fd0857899f1067e0287c2ffd91e38f967a26bd405b83a34650c2742cee9fc261"; + aarSha256 = null; } + { artifactId = "commons-codec"; groupId = "commons-codec"; - version = "1.4"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "6aa4234c74f3a1035751a25822545867c8c3727125a642b6e049665d1863631b"; - pomSha256 = "f5f30069421ba013e76bece760407dcc80022461dc9555dcbd75fdb06d9a408f"; + version = "1.6"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "54b34e941b8e1414bd3e40d736efd3481772dc26db3296f6aa45cec9f6203d86"; + pomSha256 = "a06e35d3fff3a6b813d94894ebf3e498f9540c864c5b39ae783907e3a6c72889"; aarSha256 = null; } { artifactId = "commons-io"; groupId = "commons-io"; version = "2.4"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "cc6a41dc3eaacc9e440a6bd0d2890b20d36b4ee408fe2d67122f328bb6e01581"; pomSha256 = "b2b5dd46cf998fa626eb6f8a1c114f6167c8d392694164e62533e5898e9b31f2"; aarSha256 = null; } @@ -354,15 +514,55 @@ { artifactId = "commons-logging"; groupId = "commons-logging"; version = "1.1.1"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "ce6f913cad1f0db3aad70186d65c5bc7ffcc9a99e3fe8e0b137312819f7c362f"; pomSha256 = "d0f2e16d054e8bb97add9ca26525eb2346f692809fcd2a28787da8ceb3c35ee8"; aarSha256 = null; } + { artifactId = "fastutil"; + groupId = "it.unimi.dsi"; + version = "7.2.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "74fa208043740642f7e6eb09faba15965218ad2f50ce3020efb100136e4b591c"; + pomSha256 = "953b116521a73575eee990e3f2c36a892fb088bb2d9a3027c82193cb7a013ef7"; + aarSha256 = null; } + + { artifactId = "jaxb-api"; + groupId = "javax.xml.bind"; + version = "2.2.12-b140109.1041"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "b5e60cd8b7b5ff01ce4a74c5dd008f4fbd14ced3495d0b47b85cfedc182211f2"; + pomSha256 = "2092a7d8d9bc5698c59b094bdea46622915c48c83ae66d5b5ad549c7bf16155b"; + aarSha256 = null; } + + { artifactId = "jvnet-parent"; + groupId = "net.java"; + version = "1"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "281440811268e65d9e266b3cc898297e214e04f09740d0386ceeb4a8923d63bf"; + aarSha256 = null; } + + { artifactId = "jvnet-parent"; + groupId = "net.java"; + version = "3"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "30f5789efa39ddbf96095aada3fc1260c4561faf2f714686717cb2dc5049475a"; + aarSha256 = null; } + + { artifactId = "jvnet-parent"; + groupId = "net.java"; + version = "4"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "471395735549495297c8ff939b9a32e08b91302020ff773586d27e497abb8fbb"; + aarSha256 = null; } + { artifactId = "jopt-simple"; groupId = "net.sf.jopt-simple"; version = "4.9"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "26c5856e954b5f864db76f13b86919b59c6eecf9fd930b96baa8884626baf2f5"; pomSha256 = "7af7e2d8b24b4798f04c2b7da24c9fbd1b7557b4e017c2054481565916079092"; aarSha256 = null; } @@ -370,71 +570,39 @@ { artifactId = "kxml2"; groupId = "net.sf.kxml"; version = "2.3.0"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "f264dd9f79a1fde10ce5ecc53221eff24be4c9331c830b7d52f2f08a7b633de2"; pomSha256 = "31ce606f4e9518936299bb0d27c978fa61e185fd1de7c9874fe959a53e34a685"; aarSha256 = null; } { artifactId = "proguard-base"; groupId = "net.sf.proguard"; - version = "5.3.2"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "4280e94558f2ca3ef8ae38de6f23ae0378b7e97d1a8e671496b35be1ef170648"; - pomSha256 = "fc1a5113943447ce8e6b1b45921782f74a37cbae050c8c9ade07e3cd190814ad"; + version = "5.3.3"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "1d2e883717b8ab7d3fcc9fa01034d165809a9c94daa6303a838f11e4d36adc86"; + pomSha256 = "e51efb2ec140b2849b9880fb161cb6e30dd672368a534c1f47ab46d7f537d9ca"; aarSha256 = null; } { artifactId = "proguard-gradle"; groupId = "net.sf.proguard"; - version = "5.3.2"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "31544e6bdc10d4943c74f82e7e3a7e39f85d2c74737192130f45135435ecbea7"; - pomSha256 = "919b4ffe49ca3ec159cbbdc41b867ca953f04ed00fa7f342cac6808a4f647878"; + version = "5.3.3"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "f34b3a0b62cdb468eb7e8335de4edc87958dc299306c2b4ba8ea15e6a4be106a"; + pomSha256 = "f26bdec2b9496470c0ce63b0d290816e8000ef018daaa259597ebae947fd690f"; aarSha256 = null; } { artifactId = "proguard-parent"; groupId = "net.sf.proguard"; - version = "5.3.2"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = null; - pomSha256 = "c9334ee6d1d8500031a008831a6f52295b19d9c7d8bfcecd0029cca1e8433130"; - aarSha256 = null; } - - { artifactId = "ST4"; - groupId = "org.antlr"; - version = "4.0.8"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "58caabc40c9f74b0b5993fd868e0f64a50c0759094e6a251aaafad98edfc7a3b"; - pomSha256 = "3c0890dec71174eb3ba3d404ca9e341901ff6b0421808b00713b0dbb1306c17c"; - aarSha256 = null; } - - { artifactId = "antlr"; - groupId = "org.antlr"; - version = "3.5.2"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "5ac36c2acfb0a0f3d37dafe20b5b570f2643e2d000c648d44503c2738be643df"; - pomSha256 = "065e5e80662feb858795d3c01f7714247bdd319459705ee13b1a4b1968fa22e4"; - aarSha256 = null; } - - { artifactId = "antlr-master"; - groupId = "org.antlr"; - version = "3.5.2"; - repo = "https://repo1.maven.org/maven2/"; + version = "5.3.3"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "42d91a531ea5100eb09b541aa002c3b908e8f282bd73b6e2f52f371ef1331bd6"; - aarSha256 = null; } - - { artifactId = "antlr-runtime"; - groupId = "org.antlr"; - version = "3.5.2"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "ce3fc8ecb10f39e9a3cddcbb2ce350d272d9cd3d0b1e18e6fe73c3b9389c8734"; - pomSha256 = "46a9c2200bb8b12bd7124aa7a5097ff49099908329c851a04cb2051420aa7f25"; + pomSha256 = "0288414509c625b8dd544384fbd29f502bdc8b4f86cfc26625aa23eef9fa6057"; aarSha256 = null; } { artifactId = "antlr4"; groupId = "org.antlr"; version = "4.5.3"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "a32de739cfdf515774e696f91aa9697d2e7731e5cb5045ca8a4b657f8b1b4fb4"; pomSha256 = "8a4e4b32eedaa72976a757e12cf1dfe742725db0b7311bf176dd937ba4236384"; aarSha256 = null; } @@ -442,7 +610,7 @@ { artifactId = "antlr4-master"; groupId = "org.antlr"; version = "4.5.3"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "401877d5e70ad599e9b6cff18434ea0332f637b51f8ec68352646c836f9bb2a4"; aarSha256 = null; } @@ -450,15 +618,23 @@ { artifactId = "apache"; groupId = "org.apache"; version = "13"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://central.maven.org/maven2/"; jarSha256 = null; pomSha256 = "ff513db0361fd41237bef4784968bc15aae478d4ec0a9496f811072ccaf3841d"; aarSha256 = null; } + { artifactId = "apache"; + groupId = "org.apache"; + version = "16"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "9f85ff2fd7d6cb3097aa47fb419ee7f0ebe869109f98aba9f4eca3f49e74a40e"; + aarSha256 = null; } + { artifactId = "apache"; groupId = "org.apache"; version = "4"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://central.maven.org/maven2/"; jarSha256 = null; pomSha256 = "9e9323a26ba8eb2394efef0c96d31b70df570808630dc147cab1e73541cc5194"; aarSha256 = null; } @@ -466,95 +642,111 @@ { artifactId = "apache"; groupId = "org.apache"; version = "9"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "4946e60a547c8eda69f3bc23c5b6f0dadcf8469ea49b1d1da7de34aecfcf18dd"; aarSha256 = null; } { artifactId = "commons-compress"; groupId = "org.apache.commons"; - version = "1.8.1"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "5fca136503f86ecc6cb61fbd17b137d59e56b45c7a5494e6b8fd3cabd4697fbd"; - pomSha256 = "10137adb14e8520b2abcddc308003e432eb836c4d1f9a00f68601d63583b9fb8"; + version = "1.12"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "2c1542faf343185b7cab9c3d55c8ae5471d6d095d3887a4adefdbdf2984dc0b6"; + pomSha256 = "b787d574c851505e76212968b9ae1641ea79804aef7f5a2cee2a01cd4055213a"; aarSha256 = null; } { artifactId = "commons-parent"; groupId = "org.apache.commons"; - version = "11"; - repo = "https://repo1.maven.org/maven2/"; + version = "22"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "b9e0306f393460105b8a3fa5105250c5291b1efaa99954ace0ec1c783109a02a"; + pomSha256 = "fb8c5e55e30a7addb4ff210858a0e8d2494ed6757bbe19012da99d51586c3cbb"; aarSha256 = null; } { artifactId = "commons-parent"; groupId = "org.apache.commons"; version = "25"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "467ae650442e876867379094e7518dfdd67d22c5352ebd39808c84259e9790ba"; aarSha256 = null; } { artifactId = "commons-parent"; groupId = "org.apache.commons"; - version = "33"; - repo = "https://repo1.maven.org/maven2/"; + version = "39"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "53d0011352e2e5106f379dafccdac7754ec6f0f78243c0305e4969f5acddf8fb"; + pomSha256 = "87cd27e1a02a5c3eb6d85059ce98696bb1b44c2b8b650f0567c86df60fa61da7"; aarSha256 = null; } { artifactId = "commons-parent"; groupId = "org.apache.commons"; version = "5"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "8bd632c00bdf80a7de36c22b60f12452c147d8eca2f00d79d66699ebe7daa02a"; aarSha256 = null; } { artifactId = "httpclient"; groupId = "org.apache.httpcomponents"; - version = "4.1.1"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "eae526d08a6679bf6ca138d45a0005b20ba6ec4a402788be810970713c8e4751"; - pomSha256 = "adba17d9348a97d4ce05f28267970fd8195c61a56cb06d5e0dd15faff60fe2a7"; + version = "4.2.6"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "362e9324ee7c697e21279e20077b52737ddef3f1b2c1a7abe5ad34b465145550"; + pomSha256 = "f5a0a1eeaa100ed36aa83eca562d5dbb7e9b045c98b44db7da4745e9d9a20328"; aarSha256 = null; } { artifactId = "httpcomponents-client"; groupId = "org.apache.httpcomponents"; version = "4.1"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "5215b648798c6c8d9b9cde3642d3bfb5a4cc894b7c8411004352e7de5d119827"; aarSha256 = null; } { artifactId = "httpcomponents-client"; groupId = "org.apache.httpcomponents"; - version = "4.1.1"; - repo = "https://repo1.maven.org/maven2/"; + version = "4.2.6"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "475284e5e995526d7e7715134a07412ce72d5985046342383f5de4188a022a53"; + pomSha256 = "52b6fd2eaf2240e14dbe752f1fa884270cc668d6f350e8e7f65f6033a8172d69"; aarSha256 = null; } { artifactId = "httpcomponents-core"; groupId = "org.apache.httpcomponents"; version = "4.1"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "4f797ffd9c3d156de0dbec1fd1e63e9fd8584a93c7043576553dfcb706f64de4"; aarSha256 = null; } + { artifactId = "httpcomponents-core"; + groupId = "org.apache.httpcomponents"; + version = "4.2.5"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "164e7a9cf23a4e63bbc961f8db7d965d53d685710660a88249641f91d36f83a4"; + aarSha256 = null; } + { artifactId = "httpcore"; groupId = "org.apache.httpcomponents"; version = "4.1"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "3ce38de51f4e24668c6d184057a8d08541f9e815d2d319d0f462f083092b29cf"; pomSha256 = "4fc86afa38e9c9fab099ccf45c2bc743d453e6ab222490abfe8671975c3c7327"; aarSha256 = null; } + { artifactId = "httpcore"; + groupId = "org.apache.httpcomponents"; + version = "4.2.5"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "e5e82da4cc66c8d917bbf743e3c0752efe8522735e7fc9dbddb65bccea81cfe9"; + pomSha256 = "b6eb99f1362b8344ca5400d57a35c49e3504f23f3dee304fdb879d4d953f4bc6"; + aarSha256 = null; } + { artifactId = "httpmime"; groupId = "org.apache.httpcomponents"; version = "4.1"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = "31629566148e8a47688ae43b420abc3ecd783ed15b33bebc00824bf24c9b15aa"; pomSha256 = "db3cd95bec1001605e1653f2843e8542e712fa2bb672fd9c8c1ace86c57673d1"; aarSha256 = null; } @@ -562,127 +754,207 @@ { artifactId = "project"; groupId = "org.apache.httpcomponents"; version = "4.1.1"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "21bb4d44dff54e33a37c11af69859a714202ae00969aab5453eba7276688f8ec"; aarSha256 = null; } + { artifactId = "project"; + groupId = "org.apache.httpcomponents"; + version = "7"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "3d6eba428555a558de046b5d76eacc1f5a54b4f5f20b84d636ed7aff18aa48c3"; + aarSha256 = null; } + { artifactId = "bcpkix-jdk15on"; groupId = "org.bouncycastle"; - version = "1.48"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "53473336b4e5aad77968a18b16c54d15cdbc43f3e57a1878799edf6941d0ba37"; - pomSha256 = "bf7cff9aac482d42aeb8a1551d00eb67cd436ec8cd4e126ec8a1e09c84dd217d"; + version = "1.56"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "7043dee4e9e7175e93e0b36f45b1ec1ecb893c5f755667e8b916eb8dd201c6ca"; + pomSha256 = "321668fc474a73140eb9cc73c779f1ebb9f60948aade3beddee082ecefcf0259"; aarSha256 = null; } { artifactId = "bcprov-jdk15on"; groupId = "org.bouncycastle"; - version = "1.48"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "804b7e2e3b9ac771dfd3b43de16666ac6008f8600f48f28ddc94e39a114e2288"; - pomSha256 = "29122be74a8ec1b4fc541e3da2998beb622bc38c04ba8bf1f559386917827982"; + version = "1.56"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "963e1ee14f808ffb99897d848ddcdb28fa91ddda867eb18d303e82728f878349"; + pomSha256 = "8fdc3336e7b01873193ba9c48b87de7d788dc0954d1eb45c322492627a4b5c6e"; + aarSha256 = null; } + + { artifactId = "codehaus-parent"; + groupId = "org.codehaus"; + version = "4"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "6b87237de8c2e1740cf80627c7f3ce3e15de1930bb250c55a1eca94fa3e014df"; aarSha256 = null; } - { artifactId = "ecj"; - groupId = "org.eclipse.jdt.core.compiler"; - version = "4.6.1"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "9cddda75f4a1b4469e73f44e7b61a3e897d0f657df4797f9106ffe88c4eeade0"; - pomSha256 = "536c45e8804de01321c478cfb994377f81f1e32897636616fa21b877fd137c6f"; + { artifactId = "animal-sniffer-annotations"; + groupId = "org.codehaus.mojo"; + version = "1.14"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "2068320bd6bad744c3673ab048f67e30bef8f518996fa380033556600669905d"; + pomSha256 = "1879f19a05991e3ed95910b96689333396b0c467a215dc4d1f90018404b72a26"; + aarSha256 = null; } + + { artifactId = "animal-sniffer-parent"; + groupId = "org.codehaus.mojo"; + version = "1.14"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "f51550a06b1410bd4962cb0e71df0b921a60a7ef47bfa9c4825a14be72316eea"; + aarSha256 = null; } + + { artifactId = "mojo-parent"; + groupId = "org.codehaus.mojo"; + version = "34"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = null; + pomSha256 = "3e395d6fbc43c09a3774cac8694ce527398305ea3fd5492d80e25af27d382a9c"; aarSha256 = null; } - { artifactId = "org.jacoco.build"; - groupId = "org.jacoco"; - version = "0.7.5.201505241946"; - repo = "https://repo1.maven.org/maven2/"; + { artifactId = "jaxb-bom"; + groupId = "org.glassfish.jaxb"; + version = "2.2.11"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "62af6ea8a9f0614a1ec7b132c87319bd7a4f19007d06af55c22fb992d3a4a0b8"; + pomSha256 = "a52e6850f070dc9f7a2a51d0b25dfaafd49b0b9bf8196db6c0b3c5b7c94d8d38"; aarSha256 = null; } - { artifactId = "org.jacoco.core"; - groupId = "org.jacoco"; - version = "0.7.5.201505241946"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "ecf1ad8192926438d0748bfcc3f09bebc7387d2a4184bb3a171a26084677e808"; - pomSha256 = "8d6836e1e9b0b2c759483167a6059a1ac4b2f9526cf32c14f31a441461d8b4c1"; + { artifactId = "jaxb-core"; + groupId = "org.glassfish.jaxb"; + version = "2.2.11"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "37bcaee8ebb04362c8352a5bf6221b86967ecdab5164c696b10b9a2bb587b2aa"; + pomSha256 = "ec31409f203bcabf99534f59231ec0576d875d4d4b7349b09566a7a8c8179b24"; aarSha256 = null; } - { artifactId = "org.jacoco.report"; - groupId = "org.jacoco"; - version = "0.7.5.201505241946"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "6e11ba2f083af7ddc8c23f52275aafa9dbb4f762f1c41f7b55b0ea491468b0fc"; - pomSha256 = "59b31063d2ef9a282fa475e1af05b376cd54255a48f11dc3514823c128bda5db"; + { artifactId = "jaxb-runtime"; + groupId = "org.glassfish.jaxb"; + version = "2.2.11"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "a874f2351cfba8e2946be3002d10c18a6da8f21b52ba2acf52f2b85d5520ed70"; + pomSha256 = "e5327b31b595ab8143e97836d5ccdf85feb91e7ff5666f7b26913632facca4aa"; + aarSha256 = null; } + + { artifactId = "txw2"; + groupId = "org.glassfish.jaxb"; + version = "2.2.11"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "272a3ccad45a4511351920cd2a8633c53cab8d5220c7a92954da5526bb5eafea"; + pomSha256 = "8514cb724b4fca59a5cf272b632e539bd0a0f3cacf1844082d0a173a86406bd8"; + aarSha256 = null; } + + { artifactId = "annotations"; + groupId = "org.jetbrains"; + version = "13.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "ace2a10dc8e2d5fd34925ecac03e4988b2c0f851650c94b8cef49ba1bd111478"; + pomSha256 = "965aeb2bedff369819bdde1bf7a0b3b89b8247dd69c88b86375d76163bb8c397"; + aarSha256 = null; } + + { artifactId = "kotlin-reflect"; + groupId = "org.jetbrains.kotlin"; + version = "1.2.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "4f48a872bad6e4d9c053f4ad610d11e4012ad7e58dc19a03dd5eb811f36069dd"; + pomSha256 = "f35215da1bed69e3d60735d76221d7012cd1a5bc0a30f6f7421719ada463b4dd"; + aarSha256 = null; } + + { artifactId = "kotlin-stdlib"; + groupId = "org.jetbrains.kotlin"; + version = "1.2.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "05cfd9f5ac0b41910703a8925f7211a495909b27a2ffdd1c5106f1689aeafcd4"; + pomSha256 = "ca9778da4afbcd421b09384b257c9de47f610aec5c9165e0209228d25a337a20"; + aarSha256 = null; } + + { artifactId = "kotlin-stdlib-jre7"; + groupId = "org.jetbrains.kotlin"; + version = "1.2.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "c7a20fb951d437797afe8980aff6c1e5a03f310c661ba58ba1d4fa90cb0f2926"; + pomSha256 = "2077417c22d3ab7734ce35385e9c3f4721840fa8df925edb19abe3eea8507348"; + aarSha256 = null; } + + { artifactId = "kotlin-stdlib-jre8"; + groupId = "org.jetbrains.kotlin"; + version = "1.2.0"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "633524eee6ef1941f7cb1dab7ee3927b0a221ceee9047aeb5515f4cbb990c82a"; + pomSha256 = "6b7a74be21c57056eed1c1606524c3b6381ba091a98925fd934567c4a524ac38"; + aarSha256 = null; } + + { artifactId = "stax-ex"; + groupId = "org.jvnet.staxex"; + version = "1.7.7"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "a31ff7d77163c0deb09e7fee59ad35ae44c2cee2cc8552a116ccd1583d813fb4"; + pomSha256 = "27cb450b6c367a00bd8362519907f84defac7b12086c64d4d6e97e33ab873ead"; aarSha256 = null; } { artifactId = "ow2"; groupId = "org.ow2"; version = "1.3"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "51215c67d2c068d8b7d2f6f80f51372a098075deccc448d4bdd7b987ba8328fb"; aarSha256 = null; } { artifactId = "asm"; groupId = "org.ow2.asm"; - version = "5.0.4"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "896618ed8ae62702521a78bc7be42b7c491a08e6920a15f89a3ecdec31e9a220"; - pomSha256 = "b8b2c208bd8b25f845a7a6b121582135ae18eb3f4f9e0bcd2dfd87f12ac07f10"; + version = "5.1"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "d2da399a9967c69f0a21739256fa79d284222c223082cacadc17372244764b54"; + pomSha256 = "6d079b5abf39f323baaccc68463beef5cf2e9574f333dd749ae96753f00eb205"; aarSha256 = null; } { artifactId = "asm-analysis"; groupId = "org.ow2.asm"; - version = "5.0.4"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "9b9972a0c89d0f370ff49cec179ed29fbc12abb97f7de521fbd16ae03c8a3440"; - pomSha256 = "12b5660d3d069a6dbd6ea95fa97c634652a4ada46923270064e0dcd7d68f325c"; + version = "5.1"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "a34658f5c5de4b573eef21131cc32cc25f7b66407944f312b28ec2e56abb1fa9"; + pomSha256 = "81120db4d5490c4f0e9789e1178d2bac231fcff2618bd80f8ef6ff03c550d59b"; aarSha256 = null; } { artifactId = "asm-commons"; groupId = "org.ow2.asm"; - version = "5.0.4"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "532f0ea290b28651b18f03e375f1b5693e87bbf696a25879ea1f1182557486af"; - pomSha256 = "643912ec4d4f1f9bc2ca63503642780053475b039ff4693145f296e7c56ba179"; - aarSha256 = null; } - - { artifactId = "asm-debug-all"; - groupId = "org.ow2.asm"; - version = "5.0.1"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "4734de5b515a454b0096db6971fb068e5f70e6f10bbee2b3bd2fdfe5d978ed57"; - pomSha256 = "1f9f5e5637ca81b94db886d29f564c8f408154775d0fcebe5843ccea1a5a557f"; + version = "5.1"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "97b3786e1f55e74bddf8ad102bf50e33bbcbc1f6b7fd7b36f0bbbb25cd4981be"; + pomSha256 = "cd36b31f1495f4fe55a936dd00607abdd945e1f8074549225a04c402d1d35750"; aarSha256 = null; } { artifactId = "asm-parent"; groupId = "org.ow2.asm"; - version = "5.0.1"; - repo = "https://repo1.maven.org/maven2/"; + version = "5.1"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; - pomSha256 = "9884c02d47244364e1fb27675b5ef3b206a2d2d3141ac77f57fd771a175c2a2f"; + pomSha256 = "85ec8258fafc283f61647e6a11b404890821c11db6fcf550779ecf7a14151007"; aarSha256 = null; } - { artifactId = "asm-parent"; + { artifactId = "asm-tree"; groupId = "org.ow2.asm"; - version = "5.0.4"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = null; - pomSha256 = "fdf05b9df226573b331a7e5df01135e527dcc07c71626445732bd04379aa4a72"; + version = "5.1"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "c0de2bbc4cb8297419659813ecd4ed1d077ed1dd5c1f5544cc5143e493e84c10"; + pomSha256 = "fb5369fc7ea4b2e3cf8d6f20243f1d97f81341bf818b179cd8dbd1da7a781a21"; aarSha256 = null; } - { artifactId = "asm-tree"; + { artifactId = "asm-util"; groupId = "org.ow2.asm"; - version = "5.0.4"; - repo = "https://repo1.maven.org/maven2/"; - jarSha256 = "c3670fa836fac4cde743840f671a7d52a32eb0a844e2824eaedaf3a47f5c8399"; - pomSha256 = "fc8dc8eb0e2f755e8a6a11e28d7b7530de4b3b84d2b2ad738d607d46029722a6"; + version = "5.1"; + repo = "https://jcenter.bintray.com/"; + jarSha256 = "ee032c39ae5e3cd099148fbba9a2124f9ed613e5cb93e03ee0fa8808ce364040"; + pomSha256 = "0c0e9d1857c250d1d71b5c6be7b8cc29afe55e7419a90d13bbe968ae5bd7240e"; aarSha256 = null; } { artifactId = "oss-parent"; groupId = "org.sonatype.oss"; version = "7"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "b51f8867c92b6a722499557fc3a1fdea77bdf9ef574722fe90ce436a29559454"; aarSha256 = null; } @@ -690,7 +962,7 @@ { artifactId = "oss-parent"; groupId = "org.sonatype.oss"; version = "9"; - repo = "https://repo1.maven.org/maven2/"; + repo = "https://jcenter.bintray.com/"; jarSha256 = null; pomSha256 = "fb40265f982548212ff82e362e59732b2187ec6f0d80182885c14ef1f982827a"; aarSha256 = null; } diff --git a/android/defaults/pom.xml b/android/defaults/pom.xml index ac4c4949d..3681bd5fe 100644 --- a/android/defaults/pom.xml +++ b/android/defaults/pom.xml @@ -8,10 +8,6 @@ 0.0 - - maven - https://repo1.maven.org/maven2/ - central https://central.maven.org/maven2/ @@ -20,13 +16,21 @@ jcenter https://jcenter.bintray.com/ + + google + https://maven.google.com/ + + + maven + https://repo1.maven.org/maven2/ + com.android.tools.build gradle - 2.3.0 + 3.1.0 diff --git a/android/impl.nix b/android/impl.nix index 4888e36db..09fcd3b8d 100644 --- a/android/impl.nix +++ b/android/impl.nix @@ -39,7 +39,7 @@ in { keyStorePassword = releaseKey.storePassword or null; mavenDeps = import ./defaults/deps.nix; name = applicationId; - platformVersions = [ "26" ]; + platformVersions = [ "28" ]; release = false; src = let splitApplicationId = splitString "." applicationId; @@ -114,7 +114,7 @@ in { [ -d "$out/assets" ] [ -d "$out/res" ] ''); - # useExtraSupportLibs = true; #TODO: Should this be enabled by default? + useGooglePlayServices = true; # TODO: Should this be enabled by default? useGoogleAPIs = true; #TODO: Should this be enabled by default? # We use the NDK build process From 601999fc0afa8817f67727000187e2d35715d1ec Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Thu, 18 Jul 2019 21:31:50 -0400 Subject: [PATCH 47/55] Update jsaddle-wkwebview override to add cf-private correctly This resolves the Upstream prs: - https://github.com/ghcjs/jsaddle/pull/100 - https://github.com/NixOS/nixpkgs/pull/65048 --- haskell-overlays/reflex-packages/default.nix | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) diff --git a/haskell-overlays/reflex-packages/default.nix b/haskell-overlays/reflex-packages/default.nix index f0b7f9817..2a7e65224 100644 --- a/haskell-overlays/reflex-packages/default.nix +++ b/haskell-overlays/reflex-packages/default.nix @@ -50,22 +50,11 @@ in jsaddle-webkit2gtk = self.callCabal2nix "jsaddle-webkit2gtk" (jsaddleSrc + /jsaddle-webkit2gtk) {}; jsaddle-webkitgtk = self.callCabal2nix "jsaddle-webkitgtk" (jsaddleSrc + /jsaddle-webkitgtk) {}; jsaddle-wkwebview = overrideCabal (self.callCabal2nix "jsaddle-wkwebview" (jsaddleSrc + /jsaddle-wkwebview) {}) (drv: { - # HACK(matthewbauer): Can’t figure out why cf-private framework is - # not getting pulled in correctly. Has something - # to with how headers are looked up in xcode. - preBuild = lib.optionalString (!nixpkgs.stdenv.hostPlatform.useiOSPrebuilt) '' - mkdir include - ln -s ${nixpkgs.buildPackages.darwin.cf-private}/Library/Frameworks/CoreFoundation.framework/Headers include/CoreFoundation - export NIX_CFLAGS_COMPILE="-I$PWD/include $NIX_CFLAGS_COMPILE" - ''; - libraryFrameworkDepends = (drv.libraryFrameworkDepends or []) ++ (if nixpkgs.stdenv.hostPlatform.useiOSPrebuilt then [ "${nixpkgs.buildPackages.darwin.xcode}/Contents/Developer/Platforms/${nixpkgs.stdenv.hostPlatform.xcodePlatform}.platform/Developer/SDKs/${nixpkgs.stdenv.hostPlatform.xcodePlatform}.sdk/System" - ] else with nixpkgs.buildPackages.darwin; with apple_sdk.frameworks; [ - Cocoa - WebKit - ]); + ] else (with nixpkgs.buildPackages.darwin.apple_sdk.frameworks; [ Cocoa WebKit ])); + buildDepends = lib.optional (!nixpkgs.stdenv.hostPlatform.useiOSPrebuilt) [ nixpkgs.buildPackages.darwin.cf-private ]; }); # another broken test From e92f1f97f069462e16df3d64693216ffd4ce6f95 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 18 Jul 2019 22:24:51 -0400 Subject: [PATCH 48/55] Fix reference to androidsdk in default.nix --- ChangeLog.md | 1 + default.nix | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 9c1dd04f4..f7df71c42 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -7,6 +7,7 @@ This project's release branch is `master`. This log is written from the perspect * Document how to accept android sdk license agreement and pass acceptance through to android infrastructure. * Update to GHC(JS) 8.6.5 * Update to the nixos-19.03 nixpkgs channel +* Update to gradle build tools 3.1.0, androidsdk 9, and default to android platform version 28 ## v0.1.0.0 - 2019-04-03 diff --git a/default.nix b/default.nix index 6a71a0456..3e85f14ae 100644 --- a/default.nix +++ b/default.nix @@ -396,7 +396,7 @@ in let this = rec { androidDevTools = [ ghc.haven nixpkgs.maven - nixpkgs.androidsdk + nixpkgs.androidsdk_9_0 ]; # Tools that are useful for development under both ghc and ghcjs From ee9f222e886d08b9f12b6c6b65724ade23497caa Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 19 Jul 2019 19:39:29 -0400 Subject: [PATCH 49/55] text-jsstring: Fix attoparsec tests; Add thunks for aeson and attoparsec --- haskell-overlays/default.nix | 2 +- haskell-overlays/text-jsstring/aeson.patch | 79 ------------------- haskell-overlays/text-jsstring/default.nix | 14 +--- .../text-jsstring/dep/aeson/github.json | 6 ++ .../text-jsstring/dep/attoparsec/github.json | 6 ++ 5 files changed, 17 insertions(+), 90 deletions(-) delete mode 100644 haskell-overlays/text-jsstring/aeson.patch create mode 100644 haskell-overlays/text-jsstring/dep/aeson/github.json create mode 100644 haskell-overlays/text-jsstring/dep/attoparsec/github.json diff --git a/haskell-overlays/default.nix b/haskell-overlays/default.nix index f45ef8c44..23fd25f3b 100644 --- a/haskell-overlays/default.nix +++ b/haskell-overlays/default.nix @@ -88,7 +88,7 @@ rec { exposeAllUnfoldings = import ./expose-all-unfoldings.nix { }; textJSString = import ./text-jsstring { inherit lib haskellLib fetchFromGitHub versionWildcard; - inherit (nixpkgs) fetchpatch; + inherit (nixpkgs) fetchpatch hackGet; }; # For GHC and GHCJS diff --git a/haskell-overlays/text-jsstring/aeson.patch b/haskell-overlays/text-jsstring/aeson.patch deleted file mode 100644 index 02e2b4d71..000000000 --- a/haskell-overlays/text-jsstring/aeson.patch +++ /dev/null @@ -1,79 +0,0 @@ -diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs -index abe5afc..0e058c1 100644 ---- a/Data/Aeson/Types/Internal.hs -+++ b/Data/Aeson/Types/Internal.hs -@@ -75,6 +75,20 @@ module Data.Aeson.Types.Internal - , DotNetTime(..) - ) where - -+#ifdef ghcjs_HOST_OS -+import Control.Monad (forM, liftM) -+import Control.Monad.Trans.Maybe (MaybeT (..)) -+import qualified Data.JSString.Text as JSS -+import Data.Scientific (scientific, fromFloatDigits) -+import GHCJS.Foreign.Internal (JSONType (..), jsNull, toJSBool, jsonTypeOf) -+import GHCJS.Marshal (FromJSVal (..), ToJSVal (..)) -+import GHCJS.Marshal.Pure (pToJSVal) -+import GHCJS.Types (JSVal) -+import qualified JavaScript.Array.Internal as AI -+import qualified JavaScript.Object.Internal as OI -+#endif -+ -+ - import Prelude.Compat - - import Control.Applicative (Alternative(..)) -@@ -687,3 +701,40 @@ camelTo2 c = map toLower . go2 . go1 - go2 "" = "" - go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs - go2 (x:xs) = x : go2 xs -+ -+#ifdef ghcjs_HOST_OS -+instance FromJSVal Value where -+ fromJSVal r = case jsonTypeOf r of -+ JSONNull -> return (Just Null) -+ JSONInteger -> liftM (Number . flip scientific 0 . (toInteger :: Int -> Integer)) -+ <$> fromJSVal r -+ JSONFloat -> liftM (Number . (fromFloatDigits :: Double -> Scientific)) -+ <$> fromJSVal r -+ JSONBool -> liftM Bool <$> fromJSVal r -+ JSONString -> liftM String <$> fromJSVal r -+ JSONArray -> liftM (Array . V.fromList) <$> fromJSVal r -+ JSONObject -> do -+ props <- OI.listProps (OI.Object r) -+ runMaybeT $ do -+ propVals <- forM props $ \p -> do -+ v <- MaybeT (fromJSVal =<< OI.getProp p (OI.Object r)) -+ return (JSS.textFromJSString p, v) -+ return (Object (H.fromList propVals)) -+ {-# INLINE fromJSVal #-} -+ -+instance ToJSVal Value where -+ toJSVal = convertValue -+ where -+ convertValue :: Value -> IO JSVal -+ convertValue Null = return jsNull -+ convertValue (String t) = return (pToJSVal t) -+ convertValue (Array a) = (\(AI.SomeJSArray x) -> x) <$> -+ (AI.fromListIO =<< mapM convertValue (V.toList a)) -+ convertValue (Number n) = toJSVal (realToFrac n :: Double) -+ convertValue (Bool b) = return (toJSBool b) -+ convertValue (Object o) = do -+ obj@(OI.Object obj') <- OI.create -+ mapM_ (\(k,v) -> convertValue v >>= \v' -> OI.setProp (JSS.textToJSString k) v' obj) (H.toList o) -+ return obj' -+ {-# INLINE toJSVal #-} -+#endif -diff --git a/aeson.cabal b/aeson.cabal -index 6193894..3e3618c 100644 ---- a/aeson.cabal -+++ b/aeson.cabal -@@ -169,6 +169,8 @@ library - ghc-options: -O2 - - include-dirs: include -+ if impl(ghcjs) -+ build-depends: ghcjs-base, transformers - if impl(ghcjs) || !flag(cffi) - hs-source-dirs: pure - other-modules: Data.Aeson.Parser.UnescapePure diff --git a/haskell-overlays/text-jsstring/default.nix b/haskell-overlays/text-jsstring/default.nix index d02ce7140..0e9afdc54 100644 --- a/haskell-overlays/text-jsstring/default.nix +++ b/haskell-overlays/text-jsstring/default.nix @@ -1,4 +1,4 @@ -{ lib, haskellLib, fetchFromGitHub, fetchpatch, versionWildcard }: +{ lib, haskellLib, fetchFromGitHub, fetchpatch, versionWildcard, hackGet }: with lib; with haskellLib; @@ -21,13 +21,7 @@ self: super: { self.ghcjs-prim ]; }); - # TODO remove dontCheck from attoparsec - not sure why it hangs - attoparsec = dontCheck (doJailbreak (self.callCabal2nix "attoparsec" (fetchFromGitHub { - owner = "obsidiansystems"; - repo = "attoparsec"; - rev = "5569fbd47ae235a800653134a06bf51186c91f8f"; - sha256 = "0qgr9xcmwzbxxm84l9api7bib6bspmkii1d7dlg8bcgk9icqwbcw"; - }) {})); + attoparsec = self.callCabal2nix "attoparsec" (hackGet ./dep/attoparsec) {}; buffer-builder = overrideCabal super.buffer-builder (drv: { doCheck = false; src = fetchFromGitHub { @@ -66,7 +60,7 @@ self: super: { self.ghcjs-base ]; }); - # TODO Remove dontCheck. There seems to be an issue with floating point precision and with unescape of U+d800 - aeson = dontCheck (appendPatch super.aeson ./aeson.patch); + # Tests are disabled because of an issue with floating-point precision + aeson = dontCheck (self.callCabal2nix "aeson" (hackGet ./dep/aeson) {}); text-show = appendPatch super.text-show ./text-show.patch; } diff --git a/haskell-overlays/text-jsstring/dep/aeson/github.json b/haskell-overlays/text-jsstring/dep/aeson/github.json new file mode 100644 index 000000000..e0b8aabc4 --- /dev/null +++ b/haskell-overlays/text-jsstring/dep/aeson/github.json @@ -0,0 +1,6 @@ +{ + "owner": "obsidiansystems", + "repo": "aeson", + "rev": "56c4f78a35e93dde8b10088b7fd8d5124fdfe349", + "sha256": "02gm0z1zawzx501kaalhf5ahadi38950d8323daz6z71g8mqy4sx" +} diff --git a/haskell-overlays/text-jsstring/dep/attoparsec/github.json b/haskell-overlays/text-jsstring/dep/attoparsec/github.json new file mode 100644 index 000000000..e4d4e6254 --- /dev/null +++ b/haskell-overlays/text-jsstring/dep/attoparsec/github.json @@ -0,0 +1,6 @@ +{ + "owner": "obsidiansystems", + "repo": "attoparsec", + "rev": "e3ae044b430d2c2edfbad82c089a7b5b291564ce", + "sha256": "0k6l7zknak6v14aaq5q7g33ns0a3r016xrh4fm6wz6l1v53f089v" +} From 21242967fbfae75c1cc4907449b0730dc0a0d906 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Tue, 23 Jul 2019 15:10:30 -0400 Subject: [PATCH 50/55] Update skeleton.nix to use thunk src --- skeleton-test.nix | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/skeleton-test.nix b/skeleton-test.nix index 6017ecf59..a98c4c3bc 100644 --- a/skeleton-test.nix +++ b/skeleton-test.nix @@ -1,11 +1,8 @@ { reflex-platform }: let - skeletonSrc = reflex-platform.nixpkgs.fetchFromGitHub { - owner = "ElvishJerricco"; - repo = "reflex-project-skeleton"; - rev = "d1cf6b26a9aa08b192e3e81ae07a4ba00064d6d2"; - sha256 = "05a3rq4ar77fpwl05z7niz025lp5wrwxzzz804jvwkamvyjxsyf2"; + skeletonSrc = reflex-platform.nixpkgs.fetchFromGitHub (builtins.fromJSON (builtins.readFile ./examples/project/reflex-project-skeleton/github.json)) + // { fetchSubmodules = false; # Not interested in its reflex-platform checkout }; From 06f8ba7dad58cb2f850b976116b051ca9f80d1b8 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Tue, 30 Jul 2019 12:38:01 -0400 Subject: [PATCH 51/55] Remove unneeded `packageOverrides` of `webkitgtk` --- default.nix | 3 --- 1 file changed, 3 deletions(-) diff --git a/default.nix b/default.nix index 3e85f14ae..90322538f 100644 --- a/default.nix +++ b/default.nix @@ -88,9 +88,6 @@ let iosSupport = system == "x86_64-darwin"; permittedInsecurePackages = [ "webkitgtk-2.4.11" ]; - packageOverrides = pkgs: { - webkitgtk = pkgs.webkitgtk; - }; # XCode needed for native macOS app # Obelisk needs it to for some reason From e3051c6ca96824b467b34cf4f50ce65a44b4bac9 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 4 Aug 2019 23:05:52 -0400 Subject: [PATCH 52/55] haskell-overlays: Update hlint to 2.2.2 --- haskell-overlays/untriaged.nix | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/haskell-overlays/untriaged.nix b/haskell-overlays/untriaged.nix index 674abf5b1..d5213c261 100644 --- a/haskell-overlays/untriaged.nix +++ b/haskell-overlays/untriaged.nix @@ -28,8 +28,16 @@ in self: super: { } {}; # Update hlint and add new dependency - hlint = self.callHackage "hlint" "2.2" {}; - ghc-lib-parser = self.callHackage "ghc-lib-parser" "8.8.0.20190424" {}; + hlint = self.callHackageDirect { + pkg = "hlint"; + ver = "2.2.2"; + sha256 = "0m0mx1cvq2m4w6kf0armfgdayqxwapnf5k8ffjxild8amc8ysn4a"; + } {}; + ghc-lib-parser = self.callHackageDirect { + pkg = "ghc-lib-parser"; + ver = "8.8.0.20190723"; + sha256 = "0l0ffxmszjrcj8qiqwwmsdygy2sgw6vrlm1xfqrbdx60bwgc07m5"; + } {}; haskell-src-exts = super.haskell-src-exts_1_21_0; haskell-src-exts-util = self.callHackage "haskell-src-exts-util" "0.2.5" {}; stylish-haskell = self.callHackage "stylish-haskell" "0.9.2.2" {}; From 79faa15c918bd189a911dfba16de45e6a0740f4c Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 21 Aug 2019 17:18:55 -0400 Subject: [PATCH 53/55] Bump ghcjs for floating point fixes; Bump text-jsstring aeson fork --- default.nix | 4 ++-- haskell-overlays/text-jsstring/default.nix | 2 +- haskell-overlays/text-jsstring/dep/aeson/github.json | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/default.nix b/default.nix index 90322538f..9dca6434f 100644 --- a/default.nix +++ b/default.nix @@ -178,8 +178,8 @@ let iosSupport = system == "x86_64-darwin"; bootPkgs = nixpkgs.haskell.packages.ghc865; ghcjsSrc = fetchgit { url = "https://github.com/ghcjs/ghcjs.git"; - rev = "05afd14691ac7170355f6ffd51a05226f394eb76"; - sha256 = "048glad43j0nnpmlqh9v4si4bp01h6ifv1db5ca0nnpwkyb0h9v4"; + rev = "c3922ede190a7dda6c0b673a3b7441cf41afcc9c"; + sha256 = "0201d42747brfafi28yd9na2hlqah5kcf4pkzbzxq0j6k1sck6fj"; fetchSubmodules = true; }; }; diff --git a/haskell-overlays/text-jsstring/default.nix b/haskell-overlays/text-jsstring/default.nix index 0e9afdc54..61320e6b8 100644 --- a/haskell-overlays/text-jsstring/default.nix +++ b/haskell-overlays/text-jsstring/default.nix @@ -61,6 +61,6 @@ self: super: { ]; }); # Tests are disabled because of an issue with floating-point precision - aeson = dontCheck (self.callCabal2nix "aeson" (hackGet ./dep/aeson) {}); + aeson = self.callPackage (hackGet ./dep/aeson) {}; text-show = appendPatch super.text-show ./text-show.patch; } diff --git a/haskell-overlays/text-jsstring/dep/aeson/github.json b/haskell-overlays/text-jsstring/dep/aeson/github.json index e0b8aabc4..e8c8da427 100644 --- a/haskell-overlays/text-jsstring/dep/aeson/github.json +++ b/haskell-overlays/text-jsstring/dep/aeson/github.json @@ -1,6 +1,6 @@ { "owner": "obsidiansystems", "repo": "aeson", - "rev": "56c4f78a35e93dde8b10088b7fd8d5124fdfe349", - "sha256": "02gm0z1zawzx501kaalhf5ahadi38950d8323daz6z71g8mqy4sx" + "rev": "87d24d01821611e7ea310f531bc305751b9c6102", + "sha256": "145d18f4yimzi930cjcwq44qy8xqaqizqafvch1zx0f9xf3pk2mz" } From 2eddedfd7bfbfef9ac3791ef9d9fa293e0246df1 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 21 Aug 2019 17:24:00 -0400 Subject: [PATCH 54/55] Add a note to useTextJSString --- default.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/default.nix b/default.nix index 9dca6434f..e706c48d0 100644 --- a/default.nix +++ b/default.nix @@ -6,7 +6,7 @@ , enableTraceReflexEvents ? false , useFastWeak ? true , useReflexOptimizer ? false -, useTextJSString ? true +, useTextJSString ? true # Use an implementation of "Data.Text" that uses the more performant "Data.JSString" from ghcjs-base under the hood. , iosSdkVersion ? "10.2" , nixpkgsOverlays ? [] , haskellOverlays ? [] From 02389f2a709a3f28ae2f3224d2c8ba81cc64c40b Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 22 Aug 2019 09:14:53 -0400 Subject: [PATCH 55/55] Add snap overrides --- haskell-overlays/untriaged.nix | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/haskell-overlays/untriaged.nix b/haskell-overlays/untriaged.nix index d5213c261..5890c1874 100644 --- a/haskell-overlays/untriaged.nix +++ b/haskell-overlays/untriaged.nix @@ -52,6 +52,11 @@ in self: super: { webkit2gtk3-javascriptcore = self.callHackage "webkit2gtk3-javascriptcore" "0.14.2.1" {}; haskell-gi = self.callHackage "haskell-gi" "0.22.6" {}; + # Snap and deps are marked broken in 19.03 but needed by obelisk + snap = self.callHackage "snap" "1.1.2.0" {}; + heist = dontCheck (self.callHackage "heist" "1.1.0.1" {}); + map-syntax = doJailbreak (self.callHackage "map-syntax" "0.3" {}); + # Overrides for gi-* family of libraries. See addGIDeps, above. haskell-gi-base = addGIDeps (self.callHackage "haskell-gi-base" "0.22.2" {}) [nixpkgs.glib] []; gi-glib = addGIDeps (self.callHackage "gi-glib" "2.0.19" {}) [] [];