diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 0c618eb..4b48ce0 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20240514 +# version: 0.19.20250216 # -# REGENDATA ("0.19.20240514",["github","ghc-tcplugins-extra.cabal"]) +# REGENDATA ("0.19.20250216",["github","ghc-tcplugins-extra.cabal"]) # name: Haskell-CI on: @@ -19,7 +19,7 @@ on: jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} - runs-on: ubuntu-20.04 + runs-on: ubuntu-24.04 timeout-minutes: 60 container: @@ -28,24 +28,29 @@ jobs: strategy: matrix: include: + - compiler: ghc-9.12.1 + compilerKind: ghc + compilerVersion: 9.12.1 + setup-method: ghcup + allow-failure: false - compiler: ghc-9.10.1 compilerKind: ghc compilerVersion: 9.10.1 setup-method: ghcup allow-failure: false - - compiler: ghc-9.8.2 + - compiler: ghc-9.8.4 compilerKind: ghc - compilerVersion: 9.8.2 + compilerVersion: 9.8.4 setup-method: ghcup allow-failure: false - - compiler: ghc-9.6.5 + - compiler: ghc-9.6.6 compilerKind: ghc - compilerVersion: 9.6.5 + compilerVersion: 9.6.6 setup-method: ghcup allow-failure: false - - compiler: ghc-9.4.7 + - compiler: ghc-9.4.8 compilerKind: ghc - compilerVersion: 9.4.7 + compilerVersion: 9.4.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.2.8 @@ -90,16 +95,29 @@ jobs: allow-failure: false fail-fast: false steps: - - name: apt + - name: apt-get install run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev + - name: Install GHCup + run: | mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.40.0/x86_64-linux-ghcup-0.1.40.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; + - name: Install cabal-install + run: | + "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1 || (cat "$HOME"/.ghcup/logs/*.* && false) + echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1 -vnormal+nowrap" >> "$GITHUB_ENV" + - name: Install GHC (GHCup) + if: matrix.setup-method == 'ghcup' + run: | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -110,21 +128,12 @@ jobs: echo "LANG=C.UTF-8" >> "$GITHUB_ENV" echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" - HCDIR=/opt/$HCKIND/$HCVER - HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") - HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') - HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" - echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" - if [ $((HCNUMVER > 91001)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi + if [ $((HCNUMVER > 91201)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" - echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -248,8 +257,8 @@ jobs: rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - name: save cache - uses: actions/cache/save@v4 if: always() + uses: actions/cache/save@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store diff --git a/.github/workflows/stack.yml b/.github/workflows/stack.yml index af87ccf..e4ba297 100644 --- a/.github/workflows/stack.yml +++ b/.github/workflows/stack.yml @@ -21,11 +21,11 @@ jobs: - "9.0.1" steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 with: submodules: true - - uses: haskell/actions/setup@v1 + - uses: haskell/actions/setup@v2 name: Setup Stack with: enable-stack: true @@ -35,8 +35,9 @@ jobs: - uses: haskell/actions/hlint-setup@v2 name: Set up HLint - - uses: actions/cache@v2 - name: Cache ~/.stack + - name: Cache ~/.stack + if: always() + uses: actions/cache@v4 with: path: ~/.stack key: ${{ runner.os }}-${{ matrix.ghc }}-stack diff --git a/CHANGELOG.md b/CHANGELOG.md index 7a56189..68e3ec8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 0.5 *March 4th 2024* +* Add `evByFiatWithDependencies`, see https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12037 for more details. +* Added support for GHC 9.12.1 + ## 0.4.6 *May 22nd 2024* * Added support for GHC-9.10.1 * Removed support for GHC 7.10 diff --git a/defaults.dhall b/defaults.dhall index 862ca95..2251cfd 100644 --- a/defaults.dhall +++ b/defaults.dhall @@ -1,5 +1,5 @@ { name = "ghc-tcplugins-extra" -, version = "0.4.6" +, version = "0.5" , synopsis = "Utilities for writing GHC type-checker plugins" , description = '' @@ -17,7 +17,7 @@ , license = "BSD2" , license-file = "LICENSE" , tested-with = - "GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.5, GHC == 9.8.2, GHC == 9.10.1" + "GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1, GHC == 9.12.1" , extra-source-files = [ "README.md", "CHANGELOG.md", "defaults.dhall", "package.dhall" ] , ghc-options = [ "-Wall" ] diff --git a/ghc-tcplugins-extra.cabal b/ghc-tcplugins-extra.cabal index 12623c4..1a21fec 100644 --- a/ghc-tcplugins-extra.cabal +++ b/ghc-tcplugins-extra.cabal @@ -5,7 +5,7 @@ cabal-version: 2.0 -- see: https://github.com/sol/hpack name: ghc-tcplugins-extra -version: 0.4.6 +version: 0.5 synopsis: Utilities for writing GHC type-checker plugins description: Utilities for writing GHC type-checker plugins, such as creating constraints, with a stable API covering multiple @@ -21,7 +21,7 @@ license: BSD2 license-file: LICENSE build-type: Simple tested-with: - GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.5, GHC == 9.8.2, GHC == 9.10.1 + GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1, GHC == 9.12.1 extra-source-files: README.md CHANGELOG.md @@ -47,7 +47,7 @@ library ghc-options: -Wall build-depends: base >=4.8 && <5 - , ghc >=7.10 && <9.12 + , ghc >=7.10 && <9.13 default-language: Haskell2010 if impl(ghc >= 8.0.0) ghc-options: -Wcompat -Wincomplete-uni-patterns -Widentities -Wredundant-constraints @@ -55,7 +55,20 @@ library ghc-options: -fhide-source-paths if flag(deverror) ghc-options: -Werror - if impl(ghc >= 9.10) && impl(ghc < 9.12) + if impl(ghc >= 9.11) && impl(ghc < 9.13) + other-modules: + GhcApi.Constraint + GhcApi.Predicate + GhcApi.GhcPlugins + Internal.Type + Internal.Constraint + Internal.Evidence + hs-source-dirs: + src-ghc-tree-9.4 + src-ghc-9.12 + build-depends: + ghc >=9.11 && <9.13 + if impl(ghc >= 9.10) && impl(ghc < 9.11) other-modules: GhcApi.Constraint GhcApi.Predicate @@ -67,7 +80,7 @@ library src-ghc-tree-9.4 src-ghc-9.10 build-depends: - ghc >=9.10 && <9.12 + ghc ==9.10.* if impl(ghc >= 9.8) && impl(ghc < 9.10) other-modules: GhcApi.Constraint diff --git a/package.dhall b/package.dhall index bbeae32..6cf2d1d 100644 --- a/package.dhall +++ b/package.dhall @@ -26,11 +26,12 @@ in let ghc = { name = "ghc", mixin = [] : List Text } // { library = { source-dirs = "src" , dependencies = - [ "base >=4.8 && <5", "ghc >=7.10 && <9.12" ] + [ "base >=4.8 && <5", "ghc >=7.10 && <9.13" ] , exposed-modules = "GHC.TcPluginM.Extra" , other-modules = "Internal" , when = - [ version "9.10" "9.12" [ "tree-9.4", "9.10" ] ghc mods + [ version "9.11" "9.13" [ "tree-9.4", "9.12" ] ghc mods + , version "9.10" "9.11" [ "tree-9.4", "9.10" ] ghc mods , version "9.8" "9.10" [ "tree-9.4", "9.8" ] ghc mods , version "9.4" "9.8" [ "tree-9.4", "9.4" ] ghc mods , version "9.2" "9.4" [ "tree", "9.2" ] ghc mods diff --git a/src-ghc-8.0/Internal/Evidence.hs b/src-ghc-8.0/Internal/Evidence.hs index 14d57c5..77e566d 100644 --- a/src-ghc-8.0/Internal/Evidence.hs +++ b/src-ghc-8.0/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import TcEvidence (EvTerm(..)) import TyCoRep (UnivCoProvenance (..)) @@ -12,3 +12,13 @@ evByFiat :: String -- ^ Name the coercion should have -> EvTerm evByFiat name t1 t2 = EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-8.10/Internal/Evidence.hs b/src-ghc-8.10/Internal/Evidence.hs index 2c75e9f..e507979 100644 --- a/src-ghc-8.10/Internal/Evidence.hs +++ b/src-ghc-8.10/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import TcEvidence (EvTerm(..)) import TyCoRep (UnivCoProvenance (..)) @@ -12,3 +12,13 @@ evByFiat :: String -- ^ Name the coercion should have -> EvTerm evByFiat name t1 t2 = EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-8.2/Internal/Evidence.hs b/src-ghc-8.2/Internal/Evidence.hs index 14d57c5..77e566d 100644 --- a/src-ghc-8.2/Internal/Evidence.hs +++ b/src-ghc-8.2/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import TcEvidence (EvTerm(..)) import TyCoRep (UnivCoProvenance (..)) @@ -12,3 +12,13 @@ evByFiat :: String -- ^ Name the coercion should have -> EvTerm evByFiat name t1 t2 = EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-8.4/Internal/Evidence.hs b/src-ghc-8.4/Internal/Evidence.hs index 14d57c5..77e566d 100644 --- a/src-ghc-8.4/Internal/Evidence.hs +++ b/src-ghc-8.4/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import TcEvidence (EvTerm(..)) import TyCoRep (UnivCoProvenance (..)) @@ -12,3 +12,13 @@ evByFiat :: String -- ^ Name the coercion should have -> EvTerm evByFiat name t1 t2 = EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-8.6/Internal/Evidence.hs b/src-ghc-8.6/Internal/Evidence.hs index 2c75e9f..e507979 100644 --- a/src-ghc-8.6/Internal/Evidence.hs +++ b/src-ghc-8.6/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import TcEvidence (EvTerm(..)) import TyCoRep (UnivCoProvenance (..)) @@ -12,3 +12,13 @@ evByFiat :: String -- ^ Name the coercion should have -> EvTerm evByFiat name t1 t2 = EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-8.8/Internal/Evidence.hs b/src-ghc-8.8/Internal/Evidence.hs index 2c75e9f..e507979 100644 --- a/src-ghc-8.8/Internal/Evidence.hs +++ b/src-ghc-8.8/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import TcEvidence (EvTerm(..)) import TyCoRep (UnivCoProvenance (..)) @@ -12,3 +12,13 @@ evByFiat :: String -- ^ Name the coercion should have -> EvTerm evByFiat name t1 t2 = EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-9.0/Internal/Evidence.hs b/src-ghc-9.0/Internal/Evidence.hs index aefd612..0e5bfd2 100644 --- a/src-ghc-9.0/Internal/Evidence.hs +++ b/src-ghc-9.0/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import GHC.Tc.Types.Evidence (EvTerm(..)) import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) @@ -11,4 +11,14 @@ evByFiat :: String -- ^ Name the coercion should have -> Type -- ^ The RHS of the equivalence relation (~) -> EvTerm evByFiat name t1 t2 = - EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 \ No newline at end of file + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-9.10/Internal/Evidence.hs b/src-ghc-9.10/Internal/Evidence.hs index dcd3d3d..0e5bfd2 100644 --- a/src-ghc-9.10/Internal/Evidence.hs +++ b/src-ghc-9.10/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import GHC.Tc.Types.Evidence (EvTerm(..)) import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) @@ -12,3 +12,13 @@ evByFiat :: String -- ^ Name the coercion should have -> EvTerm evByFiat name t1 t2 = EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-9.12/GhcApi/Constraint.hs b/src-ghc-9.12/GhcApi/Constraint.hs new file mode 100644 index 0000000..ab1e8a9 --- /dev/null +++ b/src-ghc-9.12/GhcApi/Constraint.hs @@ -0,0 +1,14 @@ +module GhcApi.Constraint + ( Ct(..) + , CtEvidence(..) + , CtLoc + , CanEqLHS(..) + , ctLoc + , ctEvId + , mkNonCanonical + ) +where + +import GHC.Tc.Types.Constraint + (Ct (..), CtEvidence (..), CanEqLHS (..), ctLoc, ctEvId, mkNonCanonical) +import GHC.Tc.Types.CtLoc (CtLoc) diff --git a/src-ghc-9.12/GhcApi/GhcPlugins.hs b/src-ghc-9.12/GhcApi/GhcPlugins.hs new file mode 100644 index 0000000..c87fa3e --- /dev/null +++ b/src-ghc-9.12/GhcApi/GhcPlugins.hs @@ -0,0 +1,5 @@ +module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where + +import GHC.Plugins hiding (TcPlugin) +import GHC.Unit.Finder (findPluginModule) +import GHC.Tc.Plugin (FindResult(..)) diff --git a/src-ghc-9.12/Internal/Constraint.hs b/src-ghc-9.12/Internal/Constraint.hs new file mode 100644 index 0000000..515f677 --- /dev/null +++ b/src-ghc-9.12/Internal/Constraint.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RecordWildCards #-} + +module Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) where + +import GhcApi.GhcPlugins +import GhcApi.Constraint + (Ct(..), CtEvidence(..), CanEqLHS(..), CtLoc, ctLoc, ctEvId, mkNonCanonical) + +import GHC.Tc.Utils.TcType (TcType) +import GHC.Tc.Types.Constraint (DictCt(..), IrredCt(..), EqCt(..), QCInst(..)) +import GHC.Tc.Types.Evidence (EvTerm(..), EvBindsVar) +import GHC.Tc.Plugin (TcPluginM) +import qualified GHC.Tc.Plugin as TcPlugin (newGiven) + +-- | Create a new [G]iven constraint, with the supplied evidence. This must not +-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. +newGiven :: EvBindsVar -> CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence +newGiven tcEvbinds loc pty (EvExpr ev) = TcPlugin.newGiven tcEvbinds loc pty ev +newGiven _ _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) + +flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct +flatToCt [((_,lhs),ct),((_,rhs),_)] + = Just + $ mkNonCanonical + $ CtGiven (mkPrimEqPred lhs rhs) + (ctEvId ct) + (ctLoc ct) + +flatToCt _ = Nothing + +-- | Create simple substitution from type equalities +mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct) +mkSubst ct@(CEqCan (EqCt {..})) + | TyVarLHS tyvar <- eq_lhs + = Just ((tyvar,eq_rhs),ct) +mkSubst _ = Nothing + +-- | Modify the predicate type of the evidence term of a constraint +overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct +overEvidencePredType f (CDictCan di) = + let + ev :: CtEvidence + ev = di_ev di + in CDictCan ( di { di_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CIrredCan ir) = + let + ev :: CtEvidence + ev = ir_ev ir + in CIrredCan ( ir { ir_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CEqCan eq) = + let + ev :: CtEvidence + ev = eq_ev eq + in CEqCan ( eq { eq_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CNonCanonical ct) = + let + ev :: CtEvidence + ev = ct + in CNonCanonical ( ev { ctev_pred = f (ctev_pred ev) } ) +overEvidencePredType f (CQuantCan qci) = + let + ev :: CtEvidence + ev = qci_ev qci + in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } ) diff --git a/src-ghc-9.12/Internal/Evidence.hs b/src-ghc-9.12/Internal/Evidence.hs new file mode 100644 index 0000000..8e55741 --- /dev/null +++ b/src-ghc-9.12/Internal/Evidence.hs @@ -0,0 +1,25 @@ +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where + +import GHC.Tc.Types.Evidence (EvTerm(..)) +import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) + +import GhcApi.GhcPlugins + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiat :: String -- ^ Name the coercion should have + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiat name t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) [] Nominal t1 t2 +{-# DEPRECATED evByFiat "'evByFiat' creates proofs that can lead to unsoundness, use 'evByFiatWithDependencies' instead.\nSee also https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12037" #-} + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) deps Nominal t1 t2 diff --git a/src-ghc-9.12/Internal/Type.hs b/src-ghc-9.12/Internal/Type.hs new file mode 100644 index 0000000..39fb06a --- /dev/null +++ b/src-ghc-9.12/Internal/Type.hs @@ -0,0 +1,30 @@ +module Internal.Type (substType) where + +import Data.Maybe (fromMaybe) +import GHC.Tc.Utils.TcType (TcType) +import GHC.Core.TyCo.Rep (Type (..)) +import GHC.Types.Var (TcTyVar) + +-- | Apply substitutions in Types +-- +-- __NB:__ Doesn't substitute under binders +substType + :: [(TcTyVar, TcType)] + -> TcType + -> TcType +substType subst tv@(TyVarTy v) = + fromMaybe tv (lookup v subst) +substType subst (AppTy t1 t2) = + AppTy (substType subst t1) (substType subst t2) +substType subst (TyConApp tc xs) = + TyConApp tc (map (substType subst) xs) +substType _subst t@(ForAllTy _tv _ty) = + -- TODO: Is it safe to do "dumb" substitution under binders? + -- ForAllTy tv (substType subst ty) + t +substType subst (FunTy k1 k2 t1 t2) = + FunTy k1 k2 (substType subst t1) (substType subst t2) +substType _ l@(LitTy _) = l +substType subst (CastTy ty co) = + CastTy (substType subst ty) co +substType _ co@(CoercionTy _) = co diff --git a/src-ghc-9.2/Internal/Evidence.hs b/src-ghc-9.2/Internal/Evidence.hs index aefd612..0e5bfd2 100644 --- a/src-ghc-9.2/Internal/Evidence.hs +++ b/src-ghc-9.2/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import GHC.Tc.Types.Evidence (EvTerm(..)) import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) @@ -11,4 +11,14 @@ evByFiat :: String -- ^ Name the coercion should have -> Type -- ^ The RHS of the equivalence relation (~) -> EvTerm evByFiat name t1 t2 = - EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 \ No newline at end of file + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-9.4/Internal/Evidence.hs b/src-ghc-9.4/Internal/Evidence.hs index dcd3d3d..0e5bfd2 100644 --- a/src-ghc-9.4/Internal/Evidence.hs +++ b/src-ghc-9.4/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import GHC.Tc.Types.Evidence (EvTerm(..)) import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) @@ -12,3 +12,13 @@ evByFiat :: String -- ^ Name the coercion should have -> EvTerm evByFiat name t1 t2 = EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-9.8/Internal/Evidence.hs b/src-ghc-9.8/Internal/Evidence.hs index dcd3d3d..0e5bfd2 100644 --- a/src-ghc-9.8/Internal/Evidence.hs +++ b/src-ghc-9.8/Internal/Evidence.hs @@ -1,4 +1,4 @@ -module Internal.Evidence (evByFiat) where +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where import GHC.Tc.Types.Evidence (EvTerm(..)) import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) @@ -12,3 +12,13 @@ evByFiat :: String -- ^ Name the coercion should have -> EvTerm evByFiat name t1 t2 = EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name _deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 diff --git a/src-ghc-flat/Internal.hs b/src-ghc-flat/Internal.hs index 036eadd..ee485fc 100644 --- a/src-ghc-flat/Internal.hs +++ b/src-ghc-flat/Internal.hs @@ -9,6 +9,7 @@ module Internal , newGiven , newDerived -- * Creating evidence + , evByFiatWithDependencies , evByFiat -- * Lookup , lookupModule @@ -41,7 +42,7 @@ import GhcApi.GhcPlugins import Internal.Type (substType) import Internal.Constraint (newGiven, flatToCt, overEvidencePredType) -import Internal.Evidence (evByFiat) +import Internal.Evidence (evByFiat, evByFiatWithDependencies) {-# ANN fr_mod "HLint: ignore Use camelCase" #-} diff --git a/src-ghc-tree-9.4/Internal.hs b/src-ghc-tree-9.4/Internal.hs index e113bf3..1845010 100644 --- a/src-ghc-tree-9.4/Internal.hs +++ b/src-ghc-tree-9.4/Internal.hs @@ -7,6 +7,7 @@ module Internal TcPlugin.newWanted , newGiven -- * Creating evidence + , evByFiatWithDependencies , evByFiat -- * Lookup , lookupModule @@ -38,7 +39,7 @@ import GhcApi.GhcPlugins import Internal.Type (substType) import Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) -import Internal.Evidence (evByFiat) +import Internal.Evidence (evByFiatWithDependencies, evByFiat) -- | Find a module lookupModule :: ModuleName -- ^ Name of the module diff --git a/src-ghc-tree/Internal.hs b/src-ghc-tree/Internal.hs index c24caf9..8464936 100644 --- a/src-ghc-tree/Internal.hs +++ b/src-ghc-tree/Internal.hs @@ -9,6 +9,7 @@ module Internal , newGiven , newDerived -- * Creating evidence + , evByFiatWithDependencies , evByFiat -- * Lookup , lookupModule @@ -39,7 +40,7 @@ import GhcApi.GhcPlugins import Internal.Type (substType) import Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) -import Internal.Evidence (evByFiat) +import Internal.Evidence (evByFiat, evByFiatWithDependencies) {-# ANN fr_mod "HLint: ignore Use camelCase" #-} diff --git a/src/GHC/TcPluginM/Extra.hs b/src/GHC/TcPluginM/Extra.hs index bc793b7..9a04305 100644 --- a/src/GHC/TcPluginM/Extra.hs +++ b/src/GHC/TcPluginM/Extra.hs @@ -18,6 +18,7 @@ module GHC.TcPluginM.Extra , newWantedWithProvenance #endif -- * Creating evidence + , evByFiatWithDependencies , evByFiat #if __GLASGOW_HASKELL__ < 711 -- * Report contractions