From 702dda2095c66c4f5148a749c8b7dbcc8a09f5c1 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Wed, 22 May 2024 15:27:07 +0200 Subject: [PATCH] Add support for GHC 9.10.1 --- .github/workflows/haskell-ci.yml | 92 +++---- CHANGELOG.md | 4 + defaults.dhall | 4 +- ghc-tcplugins-extra.cabal | 24 +- package.dhall | 6 +- src-ghc-9.10/GhcApi/Constraint.hs | 13 + src-ghc-9.10/GhcApi/GhcPlugins.hs | 5 + src-ghc-9.10/Internal/Constraint.hs | 64 +++++ src-ghc-9.10/Internal/Evidence.hs | 14 + src-ghc-9.10/Internal/Type.hs | 30 ++ src-ghc-cpp/Internal.hs | 409 ---------------------------- 11 files changed, 187 insertions(+), 478 deletions(-) create mode 100644 src-ghc-9.10/GhcApi/Constraint.hs create mode 100644 src-ghc-9.10/GhcApi/GhcPlugins.hs create mode 100644 src-ghc-9.10/Internal/Constraint.hs create mode 100644 src-ghc-9.10/Internal/Evidence.hs create mode 100644 src-ghc-9.10/Internal/Type.hs delete mode 100644 src-ghc-cpp/Internal.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 0886891..0c618eb 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.17.20231010 +# version: 0.19.20240514 # -# REGENDATA ("0.17.20231010",["github","ghc-tcplugins-extra.cabal"]) +# REGENDATA ("0.19.20240514",["github","ghc-tcplugins-extra.cabal"]) # name: Haskell-CI on: @@ -23,19 +23,24 @@ jobs: timeout-minutes: 60 container: - image: buildpack-deps:bionic + image: buildpack-deps:jammy continue-on-error: ${{ matrix.allow-failure }} strategy: matrix: include: - - compiler: ghc-9.8.1 + - compiler: ghc-9.10.1 compilerKind: ghc - compilerVersion: 9.8.1 + compilerVersion: 9.10.1 setup-method: ghcup allow-failure: false - - compiler: ghc-9.6.3 + - compiler: ghc-9.8.2 compilerKind: ghc - compilerVersion: 9.6.3 + compilerVersion: 9.8.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.6.5 + compilerKind: ghc + compilerVersion: 9.6.5 setup-method: ghcup allow-failure: false - compiler: ghc-9.4.7 @@ -61,56 +66,40 @@ jobs: - compiler: ghc-8.8.4 compilerKind: ghc compilerVersion: 8.8.4 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.6.5 compilerKind: ghc compilerVersion: 8.6.5 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.4.4 compilerKind: ghc compilerVersion: 8.4.4 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.2.2 compilerKind: ghc compilerVersion: 8.2.2 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.0.2 compilerKind: ghc compilerVersion: 8.0.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-7.10.3 - compilerKind: ghc - compilerVersion: 7.10.3 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false fail-fast: false steps: - name: apt run: | apt-get update - apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 - if [ "${{ matrix.setup-method }}" = ghcup ]; then - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$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.7.yaml; - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - else - apt-add-repository -y 'ppa:hvr/ghc' - apt-get update - apt-get install -y "$HCNAME" - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$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.7.yaml; - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - fi + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev + 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" + 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; + "$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) env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -122,27 +111,18 @@ jobs: echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER - if [ "${{ matrix.setup-method }}" = ghcup ]; then - 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.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - else - HC=$HCDIR/bin/$HCKIND - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" - echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - fi - + 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 > 90801)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi + if [ $((HCNUMVER > 91001)) -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: @@ -206,7 +186,7 @@ jobs: chmod a+x $HOME/.cabal/bin/cabal-plan cabal-plan --version - name: checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: path: source - name: initial cabal.project for sdist @@ -237,7 +217,7 @@ jobs: if $HEADHACKAGE; then echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1,/g')" >> cabal.project fi - $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(ghc-tcplugins-extra)$/; }' >> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(ghc-tcplugins-extra)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -245,7 +225,7 @@ jobs: $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all cabal-plan - name: restore cache - uses: actions/cache/restore@v3 + uses: actions/cache/restore@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store @@ -268,7 +248,7 @@ jobs: rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - name: save cache - uses: actions/cache/save@v3 + uses: actions/cache/save@v4 if: always() with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} diff --git a/CHANGELOG.md b/CHANGELOG.md index bc632ff..7a56189 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 0.4.6 *May 22nd 2024* +* Added support for GHC-9.10.1 +* Removed support for GHC 7.10 + ## 0.4.5 *October 10th 2023* * Support for GHC-9.8.1 diff --git a/defaults.dhall b/defaults.dhall index 1e08fd5..862ca95 100644 --- a/defaults.dhall +++ b/defaults.dhall @@ -1,5 +1,5 @@ { name = "ghc-tcplugins-extra" -, version = "0.4.5" +, version = "0.4.6" , synopsis = "Utilities for writing GHC type-checker plugins" , description = '' @@ -17,7 +17,7 @@ , license = "BSD2" , license-file = "LICENSE" , tested-with = - "GHC == 7.10.3, 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.3, GHC == 9.8.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.5, GHC == 9.8.2, GHC == 9.10.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 7605349..12623c4 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.5 +version: 0.4.6 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 == 7.10.3, 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.3, GHC == 9.8.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.5, GHC == 9.8.2, GHC == 9.10.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.10 + , ghc >=7.10 && <9.12 default-language: Haskell2010 if impl(ghc >= 8.0.0) ghc-options: -Wcompat -Wincomplete-uni-patterns -Widentities -Wredundant-constraints @@ -55,6 +55,19 @@ library ghc-options: -fhide-source-paths if flag(deverror) ghc-options: -Werror + if impl(ghc >= 9.10) && impl(ghc < 9.12) + 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.10 + build-depends: + ghc >=9.10 && <9.12 if impl(ghc >= 9.8) && impl(ghc < 9.10) other-modules: GhcApi.Constraint @@ -205,8 +218,3 @@ library ghc hiding () , ghc (TcRnTypes as Constraint) , ghc (Type as Predicate) - if impl(ghc >= 7.10) && impl(ghc < 8.0) - hs-source-dirs: - src-ghc-cpp - build-depends: - ghc >=7.10 && <8.0 diff --git a/package.dhall b/package.dhall index 4cc8b90..bbeae32 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.10" ] + [ "base >=4.8 && <5", "ghc >=7.10 && <9.12" ] , exposed-modules = "GHC.TcPluginM.Extra" , other-modules = "Internal" , when = - [ version "9.8" "9.10" [ "tree-9.4", "9.8" ] ghc mods + [ version "9.10" "9.12" [ "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 , version "9.0" "9.2" [ "tree", "9.0" ] ghc mods @@ -40,7 +41,6 @@ in let ghc = { name = "ghc", mixin = [] : List Text } , version "8.4" "8.6" [ "flat", "8.4" ] gin mods , version "8.2" "8.4" [ "flat", "8.2" ] gin mods , version "8.0" "8.2" [ "flat", "8.0" ] gin mods - , version "7.10" "8.0" [ "cpp" ] ghc ([] : List Text) ] } } diff --git a/src-ghc-9.10/GhcApi/Constraint.hs b/src-ghc-9.10/GhcApi/Constraint.hs new file mode 100644 index 0000000..98b32db --- /dev/null +++ b/src-ghc-9.10/GhcApi/Constraint.hs @@ -0,0 +1,13 @@ +module GhcApi.Constraint + ( Ct(..) + , CtEvidence(..) + , CtLoc + , CanEqLHS(..) + , ctLoc + , ctEvId + , mkNonCanonical + ) +where + +import GHC.Tc.Types.Constraint + (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) diff --git a/src-ghc-9.10/GhcApi/GhcPlugins.hs b/src-ghc-9.10/GhcApi/GhcPlugins.hs new file mode 100644 index 0000000..c87fa3e --- /dev/null +++ b/src-ghc-9.10/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.10/Internal/Constraint.hs b/src-ghc-9.10/Internal/Constraint.hs new file mode 100644 index 0000000..515f677 --- /dev/null +++ b/src-ghc-9.10/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.10/Internal/Evidence.hs b/src-ghc-9.10/Internal/Evidence.hs new file mode 100644 index 0000000..dcd3d3d --- /dev/null +++ b/src-ghc-9.10/Internal/Evidence.hs @@ -0,0 +1,14 @@ +module Internal.Evidence (evByFiat) 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 diff --git a/src-ghc-9.10/Internal/Type.hs b/src-ghc-9.10/Internal/Type.hs new file mode 100644 index 0000000..39fb06a --- /dev/null +++ b/src-ghc-9.10/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-cpp/Internal.hs b/src-ghc-cpp/Internal.hs deleted file mode 100644 index 112d794..0000000 --- a/src-ghc-cpp/Internal.hs +++ /dev/null @@ -1,409 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module Internal - ( -- * Create new constraints - newWanted - , newGiven - , newDerived -#if __GLASGOW_HASKELL__ < 711 - , newWantedWithProvenance -#endif - -- * Creating evidence - , evByFiat -#if __GLASGOW_HASKELL__ < 711 - -- * Report contractions - , failWithProvenace -#endif - -- * Lookup - , lookupModule - , lookupName - -- * Trace state of the plugin - , tracePlugin - -- * Substitutions - , flattenGivens - , mkSubst - , mkSubst' - , substType - , substCt - ) -where - --- External -#if __GLASGOW_HASKELL__ < 711 -import Data.Maybe (mapMaybe) -#endif - --- GHC API -#if __GLASGOW_HASKELL__ < 711 -import BasicTypes (TopLevelFlag (..)) -#endif -#if MIN_VERSION_ghc(8,5,0) -import CoreSyn (Expr(..)) -#endif -import Coercion (Role (..), mkUnivCo) -import FastString (FastString, fsLit) -import Module (Module, ModuleName) -import Name (Name) -import OccName (OccName) -import Outputable (($$), (<+>), empty, ppr, text) -import Panic (panicDoc) -#if __GLASGOW_HASKELL__ >= 711 -import TcEvidence (EvTerm (..)) -#else -import TcEvidence (EvTerm (..), TcCoercion (..)) -import TcMType (newEvVar) -#endif -#if __GLASGOW_HASKELL__ < 711 -import TcPluginM (FindResult (..), TcPluginM, findImportedModule, lookupOrig, - tcPluginTrace, unsafeTcPluginTcM) -import TcRnTypes (Ct, CtEvidence (..), CtLoc, TcIdBinder (..), TcLclEnv (..), - TcPlugin (..), TcPluginResult (..), ctEvLoc, - ctLocEnv, setCtLocEnv) -#else -import TcPluginM (FindResult (..), TcPluginM, lookupOrig, tcPluginTrace) -import qualified TcPluginM -import qualified Finder -#if __GLASGOW_HASKELL__ < 809 -import TcRnTypes (CtEvidence (..), CtLoc, - TcPlugin (..), TcPluginResult (..)) -#else -import TcRnTypes (TcPlugin (..), TcPluginResult (..)) -#endif -#endif -#if __GLASGOW_HASKELL__ < 802 -import TcPluginM (tcPluginIO) -#endif -#if __GLASGOW_HASKELL__ >= 711 -import TyCoRep (UnivCoProvenance (..)) -import Type (PredType, Type) -#else -import Type (EqRel (..), PredTree (..), PredType, Type, classifyPredType) -import Var (varType) -#endif -import Control.Arrow (first, second) -import Data.Function (on) -import Data.List (groupBy, partition, sortOn) -#if __GLASGOW_HASKELL__ < 809 -import TcRnTypes (Ct (..), ctLoc, ctEvId, mkNonCanonical) -#else -import Constraint - (Ct (..), CtEvidence (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) -#endif -import TcType (TcTyVar, TcType) -#if __GLASGOW_HASKELL__ < 809 -import Type (mkPrimEqPred) -#else -import Predicate (mkPrimEqPred) -#endif -#if __GLASGOW_HASKELL__ < 711 -import TcRnTypes (ctEvTerm) -import TypeRep (Type (..)) -#else -import Data.Maybe (mapMaybe) -import TyCoRep (Type (..)) -#endif - --- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 -#if __GLASGOW_HASKELL__ < 802 -import Data.IORef (readIORef) -import Control.Monad (unless) -import StaticFlags (initStaticOpts, v_opt_C_ready) -#endif - -{-# ANN module "HLint: ignore" #-} - -#if __GLASGOW_HASKELL__ >= 711 -pattern FoundModule :: Module -> FindResult -pattern FoundModule a <- Found _ a -fr_mod :: a -> a -fr_mod = id -#endif - - -#if __GLASGOW_HASKELL__ < 711 -{-# DEPRECATED newWantedWithProvenance "No longer available in GHC 8.0+" #-} --- | Create a new [W]anted constraint that remembers from which wanted --- constraint it was derived -newWantedWithProvenance :: CtEvidence -- ^ Constraint from which the new - -- wanted is derived - -> PredType -- ^ The type of the new constraint - -> TcPluginM CtEvidence -newWantedWithProvenance ev@(CtWanted {}) p = do - let loc = ctEvLoc ev - env = ctLocEnv loc - id_ = ctEvId ev - env' = env {tcl_bndrs = (TcIdBndr id_ NotTopLevel):tcl_bndrs env} - loc' = setCtLocEnv loc env' - evVar <- unsafeTcPluginTcM $ newEvVar p - return CtWanted { ctev_pred = p - , ctev_evar = evVar - , ctev_loc = loc'} - -newWantedWithProvenance ev _ = - panicDoc "newWantedWithProvenance: not a Wanted: " (ppr ev) -#endif - --- | Create a new [W]anted constraint. -newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -#if __GLASGOW_HASKELL__ >= 711 -newWanted = TcPluginM.newWanted -#else -newWanted loc pty = do - new_ev <- unsafeTcPluginTcM $ newEvVar pty - return CtWanted { ctev_pred = pty - , ctev_evar = new_ev - , ctev_loc = loc - } -#endif - --- | Create a new [G]iven constraint, with the supplied evidence. This must not --- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. -newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence -#if MIN_VERSION_ghc(8,5,0) -newGiven loc pty (EvExpr ev) = TcPluginM.newGiven loc pty ev -newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) -#elif __GLASGOW_HASKELL__ >= 711 -newGiven = TcPluginM.newGiven -#else -newGiven loc pty evtm = return - CtGiven { ctev_pred = pty - , ctev_evtm = evtm - , ctev_loc = loc - } -#endif - --- | Create a new [D]erived constraint. -newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence -#if __GLASGOW_HASKELL__ >= 711 -newDerived = TcPluginM.newDerived -#else -newDerived loc pty = return - CtDerived { ctev_pred = pty - , ctev_loc = loc - } -#endif - --- | 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 = -#if MIN_VERSION_ghc(8,5,0) - EvExpr - $ Coercion -#else - EvCoercion -#if __GLASGOW_HASKELL__ < 711 - $ TcCoercion -#endif -#endif - $ mkUnivCo -#if __GLASGOW_HASKELL__ >= 711 - (PluginProv name) -#else - (fsLit name) -#endif - Nominal t1 t2 - -#if __GLASGOW_HASKELL__ < 711 -{-# DEPRECATED failWithProvenace "No longer available in GHC 8.0+" #-} --- | Mark the given constraint as insoluble. --- --- If the [W]anted constraint was made by 'newWantedWithProvenance', it will --- also mark the parent(s) from which the constraint was derived as insoluble. --- Even if they were previously assumed to be solved. -failWithProvenace :: Ct -> TcPluginM TcPluginResult -failWithProvenace ct = return (TcPluginContradiction (ct : parents)) - where - loc = ctLoc ct - lclbndrs = mapMaybe (\case {TcIdBndr id_ NotTopLevel -> Just id_ - ;_ -> Nothing }) - $ tcl_bndrs (ctLocEnv loc) - eqBndrs = filter ((\x -> case x of { EqPred NomEq _ _ -> True - ; _ -> False }) - . classifyPredType . snd) - $ map (\ev -> (ev,varType ev)) lclbndrs - parents = map (\(id_,p) -> mkNonCanonical $ CtWanted p id_ loc) eqBndrs -#endif - --- | Find a module -lookupModule :: ModuleName -- ^ Name of the module - -> FastString -- ^ Name of the package containing the module. - -- NOTE: This value is ignored on ghc>=8.0. - -> TcPluginM Module -lookupModule mod_nm _pkg = do -#if __GLASGOW_HASKELL__ >= 711 - hsc_env <- TcPluginM.getTopEnv - found_module <- TcPluginM.tcPluginIO $ Finder.findPluginModule hsc_env mod_nm -#else - found_module <- findImportedModule mod_nm $ Just _pkg -#endif - case found_module of -#if __GLASGOW_HASKELL__ >= 711 - FoundModule h -> return (fr_mod h) -#else - Found _ md -> return md -#endif - _ -> do - found_module' <- TcPluginM.findImportedModule mod_nm $ Just $ fsLit "this" - case found_module' of -#if __GLASGOW_HASKELL__ >= 711 - FoundModule h -> return (fr_mod h) -#else - Found _ md -> return md -#endif - _ -> panicDoc "Unable to resolve module looked up by plugin: " - (ppr mod_nm) - --- | Find a 'Name' in a 'Module' given an 'OccName' -lookupName :: Module -> OccName -> TcPluginM Name -lookupName md occ = lookupOrig md occ - --- | Print out extra information about the initialisation, stop, and every run --- of the plugin when @-ddump-tc-trace@ is enabled. -tracePlugin :: String -> TcPlugin -> TcPlugin -tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit - , tcPluginSolve = traceSolve - , tcPluginStop = traceStop - } - where - traceInit = do - -- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 - initializeStaticFlags - tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit - - traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z - - traceSolve z given derived wanted = do - tcPluginTrace ("tcPluginSolve start " ++ s) - (text "given =" <+> ppr given - $$ text "derived =" <+> ppr derived - $$ text "wanted =" <+> ppr wanted) - r <- tcPluginSolve z given derived wanted - case r of - TcPluginOk solved new -> tcPluginTrace ("tcPluginSolve ok " ++ s) - (text "solved =" <+> ppr solved - $$ text "new =" <+> ppr new) - TcPluginContradiction bad -> tcPluginTrace - ("tcPluginSolve contradiction " ++ s) - (text "bad =" <+> ppr bad) - return r - --- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 -initializeStaticFlags :: TcPluginM () -#if __GLASGOW_HASKELL__ < 802 -initializeStaticFlags = tcPluginIO $ do - r <- readIORef v_opt_C_ready - unless r initStaticOpts -#else -initializeStaticFlags = return () -#endif - --- | Flattens evidence of constraints by substituting each others equalities. --- --- __NB:__ Should only be used on /[G]iven/ constraints! --- --- __NB:__ Doesn't flatten under binders -flattenGivens - :: [Ct] - -> [Ct] -flattenGivens givens = - mapMaybe flatToCt flat ++ map (substCt subst') givens - where - subst = mkSubst' givens - (flat,subst') - = second (map fst . concat) - $ partition ((>= 2) . length) - $ groupBy ((==) `on` (fst.fst)) - $ sortOn (fst.fst) subst - - flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct - flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) -#if MIN_VERSION_ghc(8,4,0) - (ctEvId ct) -#elif MIN_VERSION_ghc(8,0,0) - (ctEvId (cc_ev ct)) -#else - (ctEvTerm (cc_ev ct)) -#endif - (ctLoc ct) - - flatToCt _ = Nothing - - --- | Create flattened substitutions from type equalities, i.e. the substitutions --- have been applied to each others right hand sides. -mkSubst' :: [Ct] -> [((TcTyVar,TcType),Ct)] -mkSubst' = foldr substSubst [] . mapMaybe mkSubst - where - substSubst :: ((TcTyVar,TcType),Ct) - -> [((TcTyVar,TcType),Ct)] - -> [((TcTyVar,TcType),Ct)] - substSubst ((tv,t),ct) s = ((tv,substType (map fst s) t),ct) - : map (first (second (substType [(tv,t)]))) s - --- | Create simple substitution from type equalities -mkSubst - :: Ct - -> Maybe ((TcTyVar, TcType),Ct) -mkSubst ct@(CTyEqCan {..}) = Just ((cc_tyvar,cc_rhs),ct) -mkSubst ct@(CFunEqCan {..}) = Just ((cc_fsk,TyConApp cc_fun cc_tyargs),ct) -mkSubst _ = Nothing - --- | Apply substitution in the evidence of Cts -substCt - :: [(TcTyVar, TcType)] - -> Ct - -> Ct -substCt subst ct = - ct { cc_ev = (cc_ev ct) {ctev_pred = substType subst (ctev_pred (cc_ev ct))} - } - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = case lookup v subst of - Just t -> t - Nothing -> tv -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 -#if __GLASGOW_HASKELL__ >= 809 -substType subst (FunTy af t1 t2) = - FunTy af (substType subst t1) (substType subst t2) -#elif __GLASGOW_HASKELL__ >= 802 -substType subst (FunTy t1 t2) = - FunTy (substType subst t1) (substType subst t2) -#elif __GLASGOW_HASKELL__ < 711 -substType subst (FunTy t1 t2) = - FunTy (substType subst t1) (substType subst t2) -#endif -substType _ l@(LitTy _) = l -#if __GLASGOW_HASKELL__ > 711 -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co -#endif