diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 5155dc7..02567d7 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.14.1 +# version: 0.15.20220826 # -# REGENDATA ("0.14.1",["github","ghc-tcplugins-extra.cabal"]) +# REGENDATA ("0.15.20220826",["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-18.04 + runs-on: ubuntu-20.04 timeout-minutes: 60 container: @@ -28,9 +28,14 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.2.1 + - compiler: ghc-9.4.2 compilerKind: ghc - compilerVersion: 9.2.1 + compilerVersion: 9.4.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.2.4 + compilerKind: ghc + compilerVersion: 9.2.4 setup-method: ghcup allow-failure: false - compiler: ghc-9.0.2 @@ -38,10 +43,10 @@ jobs: compilerVersion: 9.0.2 setup-method: ghcup allow-failure: false - - compiler: ghc-8.10.4 + - compiler: ghc-8.10.7 compilerKind: ghc - compilerVersion: 8.10.4 - setup-method: hvr-ppa + compilerVersion: 8.10.7 + setup-method: ghcup allow-failure: false - compiler: ghc-8.8.4 compilerKind: ghc @@ -81,18 +86,19 @@ jobs: 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.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" - "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 + "$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.6.2.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.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 + "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) fi env: HCKIND: ${{ matrix.compilerKind }} @@ -123,7 +129,7 @@ jobs: echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" - if [ $((HCNUMVER > 90201)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi + if [ $((HCNUMVER > 90402)) -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: @@ -161,6 +167,7 @@ jobs: 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329 f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89 key-threshold: 3 + active-repositories: hackage.haskell.org, head.hackage.ghc.haskell.org:override EOF fi cat >> $CABAL_CONFIG <=4.8 && <5 - , ghc >=7.10 && <9.4 + , ghc >=7.10 && <9.6 + default-language: Haskell2010 if impl(ghc >= 8.0.0) ghc-options: -Wcompat -Wincomplete-uni-patterns -Widentities -Wredundant-constraints if impl(ghc >= 8.4.0) ghc-options: -fhide-source-paths if flag(deverror) ghc-options: -Werror + if impl(ghc >= 9.4) && impl(ghc < 9.6) + 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.4 + build-depends: + ghc >=9.4 && <9.6 if impl(ghc >= 9.2) && impl(ghc < 9.4) other-modules: GhcApi.Constraint @@ -183,4 +198,3 @@ library src-ghc-cpp build-depends: ghc >=7.10 && <8.0 - default-language: Haskell2010 diff --git a/package.dhall b/package.dhall index 4d47f17..837a647 100644 --- a/package.dhall +++ b/package.dhall @@ -5,13 +5,13 @@ let version = ./version.dhall in let ghc = { name = "ghc", mixin = [] : List Text } in let gin = - ghc - ⫽ { mixin = - [ "hiding ()" - , "(TcRnTypes as Constraint)" - , "(Type as Predicate)" - ] - } + ghc + // { mixin = + [ "hiding ()" + , "(TcRnTypes as Constraint)" + , "(Type as Predicate)" + ] + } in let mods = [ "GhcApi.Constraint" @@ -22,23 +22,24 @@ in let ghc = { name = "ghc", mixin = [] : List Text } , "Internal.Evidence" ] - in defs - ⫽ { library = - { source-dirs = "src" - , dependencies = - [ "base >=4.8 && <5", "ghc >=7.10 && <9.4" ] - , exposed-modules = "GHC.TcPluginM.Extra" - , other-modules = "Internal" - , when = - [ version "9.2" "9.4" [ "tree", "9.2" ] ghc mods - , version "9.0" "9.2" [ "tree", "9.0" ] ghc mods - , version "8.10" "9.0" [ "flat", "8.10" ] ghc mods - , version "8.8" "8.10" [ "flat", "8.8" ] gin mods - , version "8.6" "8.8" [ "flat", "8.6" ] gin mods - , 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) - ] + in defs + // { library = + { source-dirs = "src" + , dependencies = + [ "base >=4.8 && <5", "ghc >=7.10 && <9.6" ] + , exposed-modules = "GHC.TcPluginM.Extra" + , other-modules = "Internal" + , when = + [ version "9.4" "9.6" [ "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 + , version "8.10" "9.0" [ "flat", "8.10" ] ghc mods + , version "8.8" "8.10" [ "flat", "8.8" ] gin mods + , version "8.6" "8.8" [ "flat", "8.6" ] gin mods + , 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.4/GhcApi/Constraint.hs b/src-ghc-9.4/GhcApi/Constraint.hs new file mode 100644 index 0000000..98b32db --- /dev/null +++ b/src-ghc-9.4/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.4/GhcApi/GhcPlugins.hs b/src-ghc-9.4/GhcApi/GhcPlugins.hs new file mode 100644 index 0000000..0a7c980 --- /dev/null +++ b/src-ghc-9.4/GhcApi/GhcPlugins.hs @@ -0,0 +1,5 @@ +module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where + +import GHC.Plugins hiding (TcPlugin, mkSubst) +import GHC.Unit.Finder (findPluginModule) +import GHC.Tc.Plugin (FindResult(..)) diff --git a/src-ghc-9.4/Internal/Constraint.hs b/src-ghc-9.4/Internal/Constraint.hs new file mode 100644 index 0000000..411d1b4 --- /dev/null +++ b/src-ghc-9.4/Internal/Constraint.hs @@ -0,0 +1,49 @@ +{-# 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 (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 {..}) + | TyVarLHS tyvar <- cc_lhs + = Just ((tyvar,cc_rhs),ct) +mkSubst _ = Nothing + +-- | Modify the predicate type of the evidence term of a constraint +overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct +overEvidencePredType f (CQuantCan qci) = + let + ev :: CtEvidence + ev = qci_ev qci + in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f ct = + let + ev :: CtEvidence + ev = cc_ev ct + in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } } diff --git a/src-ghc-9.4/Internal/Evidence.hs b/src-ghc-9.4/Internal/Evidence.hs new file mode 100644 index 0000000..dcd3d3d --- /dev/null +++ b/src-ghc-9.4/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.4/Internal/Type.hs b/src-ghc-9.4/Internal/Type.hs new file mode 100644 index 0000000..39fb06a --- /dev/null +++ b/src-ghc-9.4/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-tree-9.4/GhcApi/Predicate.hs b/src-ghc-tree-9.4/GhcApi/Predicate.hs new file mode 100644 index 0000000..d8d0165 --- /dev/null +++ b/src-ghc-tree-9.4/GhcApi/Predicate.hs @@ -0,0 +1,3 @@ +module GhcApi.Predicate (mkPrimEqPred) where + +import GHC.Core.Coercion (mkPrimEqPred) diff --git a/src-ghc-tree-9.4/Internal.hs b/src-ghc-tree-9.4/Internal.hs new file mode 100644 index 0000000..e113bf3 --- /dev/null +++ b/src-ghc-tree-9.4/Internal.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Internal + ( -- * Create new constraints + TcPlugin.newWanted + , newGiven + -- * Creating evidence + , evByFiat + -- * Lookup + , lookupModule + , lookupName + -- * Trace state of the plugin + , tracePlugin + -- * Substitutions + , flattenGivens + , mkSubst + , mkSubst' + , substType + , substCt + ) +where + +import GHC.Driver.Config.Finder (initFinderOpts) +import GHC.Tc.Plugin (TcPluginM, lookupOrig, tcPluginTrace) +import qualified GHC.Tc.Plugin as TcPlugin + (newWanted, getTopEnv, tcPluginIO, findImportedModule) +import GHC.Tc.Types (TcPlugin(..), TcPluginSolveResult(..)) +import Control.Arrow (first, second) +import Data.Function (on) +import Data.List (groupBy, partition, sortOn) +import GHC.Tc.Utils.TcType (TcType) +import Data.Maybe (mapMaybe) + +import GhcApi.Constraint (Ct(..)) +import GhcApi.GhcPlugins + +import Internal.Type (substType) +import Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) +import Internal.Evidence (evByFiat) + +-- | 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 + hsc_env <- TcPlugin.getTopEnv + let fc = hsc_FC hsc_env + dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags + units = hsc_units hsc_env + mhome_unit = hsc_home_unit_maybe hsc_env + found_module <- TcPlugin.tcPluginIO $ findPluginModule fc fopts units + mhome_unit mod_nm + case found_module of + Found _ h -> return h + _ -> do + let pkg_qual = maybe NoPkgQual (ThisPkg . homeUnitId) mhome_unit + found_module' <- TcPlugin.findImportedModule mod_nm pkg_qual + case found_module' of + Found _ h -> return h + _ -> panicDoc "Couldn't find module" (ppr mod_nm) + +-- | Find a 'Name' in a 'Module' given an 'OccName' +lookupName :: Module -> OccName -> TcPluginM Name +lookupName = lookupOrig + +-- | 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 + , tcPluginRewrite = tcPluginRewrite + , tcPluginStop = traceStop + } + where + traceInit = do + tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit + + traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z + + traceSolve z ev given wanted = do + tcPluginTrace ("tcPluginSolve start " ++ s) + (text "given =" <+> ppr given + $$ text "wanted =" <+> ppr wanted) + r <- tcPluginSolve z ev given 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) + TcPluginSolveResult bad solved new + -> tcPluginTrace ("tcPluginSolveResult " ++ s) + (text "solved =" <+> ppr solved + $$ text "bad =" <+> ppr bad + $$ text "new =" <+> ppr new) + return r + +-- | 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 + +-- | 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 + +-- | Apply substitution in the evidence of Cts +substCt :: [(TcTyVar, TcType)] -> Ct -> Ct +substCt subst = overEvidencePredType (substType subst) diff --git a/src/GHC/TcPluginM/Extra.hs b/src/GHC/TcPluginM/Extra.hs index da2ff3b..bc793b7 100644 --- a/src/GHC/TcPluginM/Extra.hs +++ b/src/GHC/TcPluginM/Extra.hs @@ -11,7 +11,9 @@ module GHC.TcPluginM.Extra ( -- * Create new constraints newWanted , newGiven +#if __GLASGOW_HASKELL__ < 904 , newDerived +#endif #if __GLASGOW_HASKELL__ < 711 , newWantedWithProvenance #endif diff --git a/version.dhall b/version.dhall index a151de5..325b832 100644 --- a/version.dhall +++ b/version.dhall @@ -1,14 +1,14 @@ let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map -in λ(low : Text) → - λ(high : Text) → - λ(srcs : List Text) → - λ(ghc : { name : Text, mixin : List Text }) → - λ(mods : List Text) → +in \(low : Text) -> + \(high : Text) -> + \(srcs : List Text) -> + \(ghc : { name : Text, mixin : List Text }) -> + \(mods : List Text) -> { condition = "impl(ghc >= ${low}) && impl(ghc < ${high})" , source-dirs = - Prelude/List/map Text Text (λ(x : Text) → "src-ghc-${x}") srcs - , dependencies = [ ghc ⫽ { version = ">=${low} && <${high}" } ] + Prelude/List/map Text Text (\(x : Text) -> "src-ghc-${x}") srcs + , dependencies = [ ghc // { version = ">=${low} && <${high}" } ] , other-modules = mods }