From 25e0913d450de1123b22ecf1ebdb9b298f5b599b Mon Sep 17 00:00:00 2001
From: Andrzej Rybczak <andrzej@rybczak.net>
Date: Wed, 11 Sep 2024 00:15:01 +0200
Subject: [PATCH] Fix plugin

---
 effectful-plugin/src-legacy/Effectful/Plugin.hs | 12 ++++++++++--
 effectful-plugin/src/Effectful/Plugin.hs        | 17 ++++++++++++++++-
 2 files changed, 26 insertions(+), 3 deletions(-)

diff --git a/effectful-plugin/src-legacy/Effectful/Plugin.hs b/effectful-plugin/src-legacy/Effectful/Plugin.hs
index 1d46d42..a0ff33d 100644
--- a/effectful-plugin/src-legacy/Effectful/Plugin.hs
+++ b/effectful-plugin/src-legacy/Effectful/Plugin.hs
@@ -13,6 +13,7 @@ import GHC.TcPluginM.Extra (lookupModule, lookupName)
 #if __GLASGOW_HASKELL__ >= 900
 import GHC.Core.Class (Class)
 import GHC.Core.InstEnv (InstEnvs, lookupInstEnv)
+import GHC.Core.Predicate (isIPClass)
 import GHC.Core.Unify (tcUnifyTy)
 import GHC.Plugins
   ( Outputable (ppr), Plugin (pluginRecompile, tcPlugin), PredType
@@ -46,6 +47,7 @@ import GhcPlugins
   , tyConClass_maybe
   )
 import InstEnv (InstEnvs, lookupInstEnv)
+import Predicate (isIPClass)
 import TcEnv (tcGetInstEnvs)
 import TcPluginM (tcLookupClass, tcPluginIO)
 import TcRnTypes
@@ -145,7 +147,7 @@ solveFakedep (elemCls, visitedRef) allGivens allWanteds = do
     -- We store a list of the types of all given constraints, which will be useful later.
     allGivenTypes = ctPred <$> allGivens
     -- We also store a list of wanted constraints that are /not/ 'Elem e es' for later use.
-    extraWanteds = ctPred <$> filter irrelevant allWanteds
+    extraWanteds = ctPred <$> filter (\w -> irrelevant w && not (isIP w)) allWanteds
 
   -- traceM $ "Givens: " <> show (showSDocUnsafe . ppr <$> allGivens)
   -- traceM $ "Wanteds: " <> show (showSDocUnsafe . ppr <$> allWanteds)
@@ -224,9 +226,15 @@ solveFakedep (elemCls, visitedRef) allGivens allWanteds = do
       | cls == elemCls = Just $ FakedepWanted (FakedepGiven (fst $ splitAppTys eff) eff es) loc
     relevantWanted _ = Nothing
 
+    -- Check if a constraint in an implicit parameter.
+    isIP :: Ct -> Bool
+    isIP = \case
+      CDictCan _ cls _ _ -> isIPClass cls
+      _ -> False
+
     -- Determine whether a constraint is /not/ of form 'Elem e es'.
     irrelevant :: Ct -> Bool
-    irrelevant = isNothing . relevantGiven
+    irrelevant = isNothing . relevantWanted
 
     -- Given a wanted constraint and a given constraint, unify them and give back a substitution that can be applied
     -- to the wanted to make it equal to the given.
diff --git a/effectful-plugin/src/Effectful/Plugin.hs b/effectful-plugin/src/Effectful/Plugin.hs
index 773a636..2f0853f 100644
--- a/effectful-plugin/src/Effectful/Plugin.hs
+++ b/effectful-plugin/src/Effectful/Plugin.hs
@@ -11,6 +11,7 @@ import Data.Traversable
 
 import GHC.Core.Class (Class)
 import GHC.Core.InstEnv (InstEnvs, lookupInstEnv)
+import GHC.Core.Predicate (isIPClass)
 import GHC.Core.TyCo.Rep (PredType, Type)
 import GHC.Core.TyCo.Subst
 import GHC.Core.TyCon (tyConClass_maybe)
@@ -167,7 +168,11 @@ solveFakedep (elemCls, visitedRef) _ allGivens allWanteds = do
     -- constraints. Therefore, we extract these constraints out of the
     -- 'allGivens' and 'allWanted's.
     effGivens = mapMaybe maybeEffGiven allGivens
-    (otherWantedTys, effWanteds) = partitionEithers $ map splitWanteds allWanteds
+    (otherWantedTys, effWanteds) = partitionEithers
+      . map splitWanteds
+      -- Get rid of implicit parameters, they're weird.
+      . filter (not . isIP)
+      $ allWanteds
 
     -- We store a list of the types of all given constraints, which will be
     -- useful later.
@@ -241,6 +246,16 @@ solveFakedep (elemCls, visitedRef) _ allGivens allWanteds = do
         else Nothing
       _ -> Nothing
 
+    -- Check if a constraint in an implicit parameter.
+    isIP :: Ct -> Bool
+    isIP = \case
+#if __GLASGOW_HASKELL__ < 908
+      CDictCan { cc_class = cls } -> isIPClass cls
+#else
+      CDictCan DictCt { di_cls = cls } -> isIPClass cls
+#endif
+      _ -> False
+
     -- Determine whether a wanted constraint is of form 'e :> es'.
     splitWanteds :: Ct -> Either PredType EffWanted
     splitWanteds = \case