[Git][ghc/ghc][wip/T23070-dicts] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed May 10 15:35:46 UTC 2023
Simon Peyton Jones pushed to branch wip/T23070-dicts at Glasgow Haskell Compiler / GHC
Commits:
f00d264f by Simon Peyton Jones at 2023-05-10T16:37:41+01:00
Wibbles
- - - - -
3 changed files:
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Dict.hs
Changes:
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -47,7 +47,7 @@ import GHC.Tc.Errors
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Evidence
import GHC.Tc.Solver.Interact
-import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack )
+import GHC.Tc.Solver.Dict ( makeSuperClasses, solveCallStack )
import GHC.Tc.Solver.Rewrite ( rewriteType )
import GHC.Tc.Utils.Unify ( buildTvImplication )
import GHC.Tc.Utils.TcMType as TcM
@@ -153,7 +153,7 @@ simplifyTop wanteds
; binds2 <- reportUnsolved final_wc
; traceTc "reportUnsolved (unsafe overlapping) {" empty
- ; unless (isEmptyCts unsafe_ol) $ do {
+ ; unless (isEmptyBag unsafe_ol) $ do {
-- grab current error messages and clear, warnAllUnsolved will
-- update error messages which we'll grab and then restore saved
-- messages.
@@ -161,7 +161,7 @@ simplifyTop wanteds
; saved_msg <- TcM.readTcRef errs_var
; TcM.writeTcRef errs_var emptyMessages
- ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol }
+ ; warnAllUnsolved $ emptyWC { wc_simple = fmap CDictCan unsafe_ol }
; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var
; TcM.writeTcRef errs_var saved_msg
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -5,8 +5,7 @@
module GHC.Tc.Solver.Canonical(
solveCt,
- StopOrContinue(..), stopWith, continueWith, andWhenContinue,
- solveCallStack -- For GHC.Tc.Solver
+ StopOrContinue(..), stopWith, continueWith, andWhenContinue
) where
import GHC.Prelude
@@ -18,6 +17,7 @@ import GHC.Tc.Solver.Rewrite
import GHC.Tc.Solver.Monad
import GHC.Tc.Solver.Equality( solveEquality )
import GHC.Tc.Solver.Irred( solveIrred )
+import GHC.Tc.Solver.Dict( solveDict, solveDictNC, mkStrictSuperClasses )
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.EvTerm
@@ -104,8 +104,8 @@ solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc }))
= do { ev <- rewriteEvidence ev
; case classifyPredType (ctEvPred ev) of
ClassPred cls tys
- -> solveDict (DictCt { di_ev = ev, di_cls = cls
- , di_tys = tys, di_pend_sc = pend_sc })
+ -> solveDict (DictCt { di_ev = ev, di_class = cls
+ , di_tyargs = tys, di_pend_sc = pend_sc })
_ -> pprPanic "solveCt" (ppr ev) }
solveNC :: CtEvidence -> SolverStage Ct
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -1,9 +1,10 @@
-- | Solving Class constraints CDictCan
module GHC.Tc.Solver.Dict (
- doTopReactDict,
+ solveDict, solveDictNC,
checkInstanceOK,
- matchLocalInst, chooseInstance
-
+ matchLocalInst, chooseInstance,
+ makeSuperClasses, mkStrictSuperClasses,
+ solveCallStack -- For GHC.Tc.Solver
) where
import GHC.Prelude
@@ -81,7 +82,7 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_class = cls, di_tyargs = tys })
; tryLastResortProhibitedSuperClass dict_ct
; return (CDictCan dict_ct) }
-mkDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt
+mkDictCt :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue DictCt)
-- Once-only processing of Dict constraints:
-- * expand superclasses
-- * deal with CallStack
@@ -470,8 +471,6 @@ try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_class = cls, di_tyargs
| otherwise
= continueWith ()
-interactDict _ wi = pprPanic "interactDict" (ppr wi)
-
-- See Note [Shortcut solving]
shortCutSolver :: DynFlags
-> CtEvidence -- Work item
@@ -585,7 +584,7 @@ interactGivenIP :: InertCans -> DictCt -> TcS (StopOrContinue a)
-- Work item is Given (?x:ty)
-- See Note [Shadowing of Implicit Parameters]
interactGivenIP inerts workItem@(DictCt { di_ev = ev, di_class = cls
- , di_tyargs = tys@(ip_str:_) })
+ , di_tyargs = tys })
= do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem }
; stopWith ev "Given IP" }
where
@@ -594,6 +593,10 @@ interactGivenIP inerts workItem@(DictCt { di_ev = ev, di_class = cls
other_ip_dicts = filterBag (not . is_this_ip) ip_dicts
filtered_dicts = addDictsByClass dicts cls other_ip_dicts
+ ip_str = case tys of
+ ip_str:_ -> ip_str
+ [] -> pprPanic "interactGivenIP" (ppr workItem)
+
-- Pick out any Given constraints for the same implicit parameter
is_this_ip (DictCt { di_ev = ev, di_tyargs = ip_str':_ })
= isGiven ev && ip_str `tcEqType` ip_str'
@@ -670,10 +673,10 @@ I can think of two ways to fix this:
tryInstances :: DictCt -> SolverStage ()
tryInstances dict_ct
- = Stage $ do { inerts <- getInertCans
+ = Stage $ do { inerts <- getTcSInerts
; try_instances inerts dict_ct }
-try_instances :: InertSet -> DictCt -> TcS (StopOrContinue Ct)
+try_instances :: InertSet -> DictCt -> TcS (StopOrContinue ())
-- Try to use type-class instance declarations to simplify the constraint
try_instances inerts work_item@(DictCt { di_ev = ev, di_class = cls
, di_tyargs = xis })
@@ -1185,18 +1188,18 @@ but that doesn't work for the example from #22216.
* *
**********************************************************************-}
-tryLastResortProhibitedSuperClass :: DictCt -> TcS (StopOrContinue Ct)
+tryLastResortProhibitedSuperClass :: DictCt -> SolverStage ()
-- ^ As a last resort, we TEMPORARILY allow a prohibited superclass solve,
-- emitting a loud warning when doing so: we might be creating non-terminating
-- evidence (as we are in T22912 for example).
--
-- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance.
tryLastResortProhibitedSuperClass dict_ct
- = Stage $ do { inerts <- getInertCans
+ = Stage $ do { inerts <- getTcSInerts
; last_resort inerts dict_ct }
last_resort :: InertSet -> DictCt -> TcS (StopOrContinue ())
-last_resort inerts work_item@(DictCt { di_ev = ev_w, di_class = cls, di_tyargs = xis })
+last_resort inerts (DictCt { di_ev = ev_w, di_class = cls, di_tyargs = xis })
| let loc_w = ctEvLoc ev_w
orig_w = ctLocOrigin loc_w
, ScOrigin _ NakedSc <- orig_w -- work_item is definitely Wanted
@@ -1205,9 +1208,9 @@ last_resort inerts work_item@(DictCt { di_ev = ev_w, di_class = cls, di_tyargs =
, isGiven ev_i
= do { setEvBindIfWanted ev_w IsCoherent (ctEvTerm ev_i)
; ctLocWarnTcS loc_w $
- TcRnLoopySuperclassSolve loc_w (ctPred work_item)
+ TcRnLoopySuperclassSolve loc_w (ctEvPred ev_w)
; return $ Stop ev_w (text "Loopy superclass") }
-tryLastResortProhibitedSuperclass _ _
+ | otherwise
= continueWith ()
@@ -1511,8 +1514,6 @@ doLocalFunDepImprovement (DictCt { di_ev = work_ev, di_class = cls })
(ctLocOrigin inert_loc)
(ctLocSpan inert_loc) }
-doLocalFunDepImprovement work_item = pprPanic "doLocalFunDepImprovement" (ppr work_item)
-
doTopFunDepImprovement :: DictCt -> TcS Bool
-- Try to functional-dependency improvement between the constraint
-- and the top-level instance declarations
@@ -1536,8 +1537,6 @@ doTopFunDepImprovement work_item@(DictCt { di_ev = ev, di_class = cls, di_tyargs
inst_pred inst_loc }
, emptyRewriterSet )
-doTopFunDepImprovement work_item = pprPanic "doTopFunDepImprovement" (ppr work_item)
-
{- *********************************************************************
* *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f00d264feac7ec5ddbece201fd3f32c37d0be5b3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f00d264feac7ec5ddbece201fd3f32c37d0be5b3
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230510/7b671667/attachment-0001.html>
More information about the ghc-commits
mailing list