Copy solveOneFromTheOther code path to interactIPwip/joachim/ip-special-pred

3 files changed, 40 insertions, 5 deletions

diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
index 984fb6e140..b3f4c6b415 100644
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ b/compiler/GHC/Tc/Solver/Interact.hs
@@ -1190,9 +1190,25 @@ addFunDepWork inerts work_ev cls
 -}
 
 interactIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
-interactIP inerts workItem@(CSpecialCan { cc_ev = ev_w })
+interactIP inerts workItem@(CSpecialCan { cc_ev = ev_w, cc_special_pred = IpPred ip_name, cc_xi = ty })
+  | Just ct_i <- lookupInertIp inerts (ctEvLoc ev_w) ip_name ty
+  , let ev_i = ctEvidence ct_i
+  = do { -- Ths short-cut solver didn't fire, so we
+         -- solve ev_w from the matching inert ev_i we found
+         what_next <- solveOneFromTheOther ev_i ev_w
+       ; traceTcS "lookupInertDict" (ppr what_next)
+       ; case what_next of
+           KeepBoth  -> continueWith workItem
+           KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)
+                           ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }
+           KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)
+                           ; updInertDicts $ \ ds -> delIpDict ds ip_name ty
+                           ; continueWith workItem } }
+
+
   | isGiven ev_w
   = interactGivenIP inerts workItem
+
   | otherwise
   = continueWith workItem
 
@@ -1201,7 +1217,7 @@ interactIP _ wi = pprPanic "interactGivenIP" (ppr wi)
 interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 -- Work item is Given (?x:ty)
 -- See Note [Shadowing of Implicit Parameters]
-interactGivenIP inerts workItem@(CSpecialCan { cc_ev = ev, cc_special_pred = IpPred ip_name , cc_xi = ty })
+interactGivenIP inerts workItem@(CSpecialCan { cc_ev = ev, cc_special_pred = IpPred ip_name, cc_xi = ty })
   = do { updInertCans $ \cans -> cans { inert_dicts = addIpDict filtered_dicts ip_name ty workItem }
        ; stopWith ev "Given IP" }
   where
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 74d7674079..d187092e24 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -68,7 +68,7 @@ module GHC.Tc.Solver.Monad (
     addInertCan, insertFunEq, addInertForAll,
     emitWorkNC, emitWork,
     isImprovable,
-    lookupInertDict,
+    lookupInertDict, lookupInertIp,
 
     -- The Model
     kickOutAfterUnification,
@@ -161,6 +161,7 @@ import GHC.Utils.Panic
 import GHC.Utils.Logger
 import GHC.Utils.Misc (HasDebugCallStack)
 import GHC.Data.Bag as Bag
+import GHC.Data.FastString
 import GHC.Types.Unique.Supply
 import GHC.Tc.Types
 import GHC.Tc.Types.Origin
@@ -1110,6 +1111,12 @@ lookupInertDict (IC { inert_dicts = dicts }) loc cls tys
       Just ct -> Just ct
       _       -> Nothing
 
+lookupInertIp :: InertCans -> CtLoc -> FastString -> Type -> Maybe Ct
+lookupInertIp (IC { inert_dicts = dicts }) loc ip_name ty
+  = case findIpDict dicts loc ip_name ty of
+      Just ct -> Just ct
+      _       -> Nothing
+
 -- | Look up a solved inert.
 lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
 -- Returns just if exactly this predicate type exists in the solved.
diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs
index 89944dacc6..869e603809 100644
--- a/compiler/GHC/Tc/Solver/Types.hs
+++ b/compiler/GHC/Tc/Solver/Types.hs
@@ -9,8 +9,8 @@
 module GHC.Tc.Solver.Types (
     -- Inert CDictCans
     DictMap, emptyDictMap, findDictsByClass, addDict, addClassDict, addIpDict, addDictCt,
-    addDictsByClass, addIpDicts, delDict, delClassDict, foldDicts, filterDicts,
-    findDictsByTyCon, findClassDict, dictsToBag, partitionDicts,
+    addDictsByClass, addIpDicts, delDict, delClassDict, delIpDict, foldDicts, filterDicts,
+    findDictsByTyCon, findClassDict, findIpDict, dictsToBag, partitionDicts,
 
     FunEqMap, emptyFunEqs, foldFunEqs, findFunEq, insertFunEq,
     findFunEqsByTyCon,
@@ -27,6 +27,7 @@ module GHC.Tc.Solver.Types (
 import GHC.Prelude
 
 import GHC.Tc.Types.Constraint
+import GHC.Tc.Types.Origin
 import GHC.Tc.Utils.TcType
 
 import GHC.Core.Class
@@ -148,6 +149,14 @@ findClassDict m _loc cls tys
   | otherwise
   = findTcApp m (classTyCon cls) tys
 
+findIpDict :: DictMap a -> CtLoc -> FastString -> Type -> Maybe a
+findIpDict m loc ip_name ty
+  |  isPushCallStackOrigin (ctLocOrigin loc)
+  = Nothing             -- See Note [Solving CallStack constraints]
+
+  | otherwise
+  = findTcApp m ipPrimTyCon [mkStrLitTy ip_name, ty] 
+
 findDictsByTyCon :: DictMap a -> TyCon -> Bag a
 findDictsByTyCon m tc
   | Just tm <- lookupDTyConEnv m tc = foldTM consBag tm emptyBag
@@ -162,6 +171,9 @@ delDict m tc tys = delTcApp m tc tys
 delClassDict :: DictMap a -> Class -> [Type] -> DictMap a
 delClassDict m cls tys = delDict m (classTyCon cls) tys
 
+delIpDict :: DictMap a -> FastString -> Type -> DictMap a
+delIpDict m ip_name ty = delDict m ipPrimTyCon [mkStrLitTy ip_name, ty]
+
 addDict :: DictMap a -> TyCon -> [Type] -> a -> DictMap a
 addDict m tc tys item = insertTcApp m tc tys item