diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,11 @@ ## Unreleased +## 0.4.1.1 (2021-11-23) + +- Fixed a regression introduced in 0.4.1.0 where polymorphic uses of + interpreters could confuse the plugin. + ## 0.4.1.0 (2021-10-22) - The plugin can now use instances in scope to help solve ambiguous type diff --git a/polysemy-plugin.cabal b/polysemy-plugin.cabal --- a/polysemy-plugin.cabal +++ b/polysemy-plugin.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: polysemy-plugin -version: 0.4.1.0 +version: 0.4.1.1 synopsis: Disambiguate obvious uses of effects. description: Please see the README on GitHub at category: Polysemy @@ -68,7 +68,7 @@ , containers >=0.5 && <0.7 , ghc >=8.6.5 && <10 , ghc-tcplugins-extra >=0.3 && <0.5 - , polysemy >=1.3 + , polysemy >=1.3 && <1.7 , syb ==0.7.* , transformers >=0.5.2.0 && <0.6 default-language: Haskell2010 diff --git a/src/Polysemy/Plugin/Fundep.hs b/src/Polysemy/Plugin/Fundep.hs --- a/src/Polysemy/Plugin/Fundep.hs +++ b/src/Polysemy/Plugin/Fundep.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ @@ -52,13 +54,13 @@ #if __GLASGOW_HASKELL__ >= 900 import GHC.Builtin.Types.Prim (alphaTys) -import GHC.Plugins (idType, tyConClass_maybe) +import GHC.Plugins (idType, tyConClass_maybe, ppr, Outputable, sep, text, (<+>), parens) import GHC.Tc.Types.Evidence import GHC.Tc.Plugin (TcPluginM, tcPluginIO) import GHC.Tc.Types import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Env (tcGetInstEnvs) -import GHC.Tc.Utils.TcType (tcSplitPhiTy, tcSplitTyConApp) +import GHC.Tc.Utils.TcType (tcSplitPhiTy, tcSplitTyConApp, tcGetTyVar_maybe, tcSplitAppTy_maybe) import GHC.Tc.Solver.Monad hiding (tcLookupClass) import GHC.Core.Class (classTyCon) import GHC.Core.InstEnv (lookupInstEnv, is_dfun) @@ -71,14 +73,14 @@ #endif import Class (classTyCon) -import GhcPlugins (idType, tyConClass_maybe) +import GhcPlugins (idType, tyConClass_maybe, ppr, Outputable, sep, text, (<+>), parens) import Inst (tcGetInstEnvs) import InstEnv (lookupInstEnv, is_dfun) import MonadUtils (allM, anyM) import TcEvidence import TcPluginM (tcPluginIO) import TcRnTypes -import TcType (tcSplitPhiTy, tcSplitTyConApp) +import TcType (tcSplitPhiTy, tcSplitTyConApp, tcGetTyVar_maybe, tcSplitAppTy_maybe) import TcSMonad hiding (tcLookupClass) import Type import TysPrim (alphaTys) @@ -99,6 +101,7 @@ ------------------------------------------------------------------------------ -- | Like 'PredType', but has an 'Ord' instance. newtype PredType' = PredType' { getPredType :: PredType } + deriving newtype Outputable instance Eq PredType' where (==) = ((== EQ) .) . compare @@ -117,7 +120,14 @@ , fcRow :: Type -- ^ @r@ } +instance Outputable FindConstraint where + ppr FindConstraint{..} = parens $ sep + [ text "effect name = " <+> ppr fcEffectName + , text "effect = " <+> ppr fcEffect + , text "row = " <+> ppr fcRow + ] + ------------------------------------------------------------------------------ -- | Given a list of constraints, filter out the 'FindConstraint's. getFindConstraints :: PolysemyStuff 'Things -> [Ct] -> [FindConstraint] @@ -214,6 +224,18 @@ ------------------------------------------------------------------------------ +-- | It's very important that we don't try to unify entire effects when we're +-- in interpreter mode. It's OK to unify @T x ~ T y@, but never @e ~ T y@. This +-- function takes then "given" of an interpreter, and produces a singleton +-- skolem set iff the outermost effect to be unified is a tyvar. +skolemsForInterpreter :: Type -> Set TyVar +skolemsForInterpreter ty = + case tcSplitAppTy_maybe ty of + Just (tcGetTyVar_maybe -> Just skolem, _) -> S.singleton skolem + _ -> maybe mempty S.singleton $ tcGetTyVar_maybe ty + + +------------------------------------------------------------------------------ -- | Generate a wanted unification for the effect described by the -- 'FindConstraint' and the given effect --- if they can be unified in this -- context. @@ -222,7 +244,7 @@ -> SolveContext -> Type -- ^ The given effect. -> TcPluginM (Maybe (Unification, Ct)) -mkWanted fc solve_ctx given = +mkWanted fc solve_ctx given = do whenA (not (mustUnify solve_ctx) || isJust (unify solve_ctx wanted given)) $ mkWantedForce fc given where @@ -359,8 +381,10 @@ case splitAppTys r of (_, [_, eff', _]) -> mkWanted fc - (InterpreterUse $ exactlyOneWantedForR wanted_finds r) - eff' + (InterpreterUse + (exactlyOneWantedForR wanted_finds r) + (skolemsForInterpreter eff')) + eff' _ -> pure Nothing -- We only want to emit a unification wanted once, otherwise a type error can diff --git a/src/Polysemy/Plugin/Fundep/Unification.hs b/src/Polysemy/Plugin/Fundep/Unification.hs --- a/src/Polysemy/Plugin/Fundep/Unification.hs +++ b/src/Polysemy/Plugin/Fundep/Unification.hs @@ -17,9 +17,11 @@ #if __GLASGOW_HASKELL__ >= 900 import GHC.Core.Type import GHC.Core.Unify +import GHC.Plugins (Outputable, ppr, parens, text, (<+>)) #else import Type import Unify +import GhcPlugins (Outputable, ppr, parens, text, (<+>)) #endif @@ -32,10 +34,14 @@ -- | In the context of running an interpreter. The 'Bool' corresponds to -- whether we are only trying to solve a single 'Member' constraint right -- now. If so, we *must* produce a unification wanted. - | InterpreterUse Bool + | InterpreterUse Bool (Set TyVar) deriving (Eq, Ord) +instance Outputable SolveContext where + ppr (FunctionDef s) = parens $ text "FunctionDef" <+> ppr s + ppr (InterpreterUse s ty) = parens $ text "InterpreterUse" <+> ppr s <+> ppr ty + ------------------------------------------------------------------------------ -- | Depending on the context in which we're solving a constraint, we may or -- may not want to force a unification of effects. For example, when defining @@ -43,7 +49,7 @@ -- r s@, we should unify @s ~ Int@. mustUnify :: SolveContext -> Bool mustUnify (FunctionDef _) = True -mustUnify (InterpreterUse b) = b +mustUnify (InterpreterUse b _) = b ------------------------------------------------------------------------------ @@ -63,8 +69,8 @@ skolems :: Set TyVar skolems = case solve_ctx of - InterpreterUse _ -> mempty - FunctionDef s -> s + InterpreterUse _ s -> s + FunctionDef s -> s tryUnifyUnivarsButNotSkolems :: Set TyVar -> Type -> Type -> Maybe TCvSubst