polysemy-plugin 0.4.1.0 → 0.4.1.1

raw patch · 4 files changed

+48/−13 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• polysemy-plugin.cabal +2/−2
• src/Polysemy/Plugin/Fundep.hs +31/−7
• src/Polysemy/Plugin/Fundep/Unification.hs +10/−4

@@ -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

@@ -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 <https://github.com/polysemy-research/polysemy/tree/master/polysemy-plugin#readme> 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

@@ -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

@@ -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