summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc/Utils
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc/Utils')
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs63
-rw-r--r--compiler/GHC/Tc/Utils/TcMType.hs61
2 files changed, 59 insertions, 65 deletions
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 60714e4cc1..2c308a74fe 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -98,14 +98,14 @@ module GHC.Tc.Utils.Monad(
chooseUniqueOccTc,
getConstraintVar, setConstraintVar,
emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
- emitImplication, emitImplications, emitInsoluble,
+ emitImplication, emitImplications, emitInsoluble, emitHole,
discardConstraints, captureConstraints, tryCaptureConstraints,
pushLevelAndCaptureConstraints,
pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
getTcLevel, setTcLevel, isTouchableTcM,
getLclTypeEnv, setLclTypeEnv,
traceTcConstraints,
- emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint,
+ emitNamedTypeHole, emitAnonTypeHole,
-- * Template Haskell context
recordThUse, recordThSpliceUse,
@@ -1569,12 +1569,11 @@ emitInsoluble ct
; lie_var <- getConstraintVar
; updTcRef lie_var (`addInsols` unitBag ct) }
-emitInsolubles :: Cts -> TcM ()
-emitInsolubles cts
- | isEmptyBag cts = return ()
- | otherwise = do { traceTc "emitInsolubles" (ppr cts)
- ; lie_var <- getConstraintVar
- ; updTcRef lie_var (`addInsols` cts) }
+emitHole :: Hole -> TcM ()
+emitHole hole
+ = do { traceTc "emitHole" (ppr hole)
+ ; lie_var <- getConstraintVar
+ ; updTcRef lie_var (`addHole` hole) }
-- | Throw out any constraints emitted by the thing_inside
discardConstraints :: TcM a -> TcM a
@@ -1644,34 +1643,28 @@ traceTcConstraints msg
hang (text (msg ++ ": LIE:")) 2 (ppr lie)
}
-emitAnonWildCardHoleConstraint :: TcTyVar -> TcM ()
-emitAnonWildCardHoleConstraint tv
- = do { ct_loc <- getCtLocM HoleOrigin Nothing
- ; emitInsolubles $ unitBag $
- CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
- , ctev_loc = ct_loc }
- , cc_occ = mkTyVarOcc "_"
- , cc_hole = TypeHole } }
-
-emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
-emitNamedWildCardHoleConstraints wcs
- = do { ct_loc <- getCtLocM HoleOrigin Nothing
- ; emitInsolubles $ listToBag $
- map (do_one ct_loc) wcs }
+emitAnonTypeHole :: TcTyVar -> TcM ()
+emitAnonTypeHole tv
+ = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing
+ ; let hole = Hole { hole_sort = TypeHole
+ , hole_occ = occ
+ , hole_ty = mkTyVarTy tv
+ , hole_loc = ct_loc }
+ ; emitHole hole }
+ where
+ occ = mkTyVarOcc "_"
+
+emitNamedTypeHole :: (Name, TcTyVar) -> TcM ()
+emitNamedTypeHole (name, tv)
+ = do { ct_loc <- setSrcSpan (nameSrcSpan name) $
+ getCtLocM (TypeHoleOrigin occ) Nothing
+ ; let hole = Hole { hole_sort = TypeHole
+ , hole_occ = occ
+ , hole_ty = mkTyVarTy tv
+ , hole_loc = ct_loc }
+ ; emitHole hole }
where
- do_one :: CtLoc -> (Name, TcTyVar) -> Ct
- do_one ct_loc (name, tv)
- = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
- , ctev_loc = ct_loc' }
- , cc_occ = occName name
- , cc_hole = TypeHole }
- where
- real_span = case nameSrcSpan name of
- RealSrcSpan span _ -> span
- UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints"
- (ppr name <+> quotes (ftext str))
- -- Wildcards are defined locally, and so have RealSrcSpans
- ct_loc' = setCtLocSpan ct_loc real_span
+ occ = nameOccName name
{- Note [Constraints and errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 1189a57cd7..bbd52bd059 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -41,10 +41,11 @@ module GHC.Tc.Utils.TcMType (
--------------------------------
-- Creating new evidence variables
newEvVar, newEvVars, newDict,
- newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC,
+ newWanted, newWanteds, cloneWanted, cloneWC,
emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
emitDerivedEqs,
newTcEvBinds, newNoTcEvBinds, addTcEvBind,
+ emitNewExprHole,
newCoercionHole, fillCoercionHole, isFilledCoercionHole,
unpackCoercionHole, unpackCoercionHole_maybe,
@@ -67,7 +68,7 @@ module GHC.Tc.Utils.TcMType (
--------------------------------
-- Zonking and tidying
zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin,
- tidyEvVar, tidyCt, tidySkolemInfo,
+ tidyEvVar, tidyCt, tidyHole, tidySkolemInfo,
zonkTcTyVar, zonkTcTyVars,
zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,
zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV,
@@ -193,17 +194,6 @@ newWanted orig t_or_k pty
newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
newWanteds orig = mapM (newWanted orig Nothing)
--- | Create a new 'CHoleCan' 'Ct'.
-newHoleCt :: HoleSort -> Id -> Type -> TcM Ct
-newHoleCt hole ev ty = do
- loc <- getCtLocM HoleOrigin Nothing
- pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty
- , ctev_dest = EvVarDest ev
- , ctev_nosh = WDeriv
- , ctev_loc = loc }
- , cc_occ = getOccName ev
- , cc_hole = hole }
-
----------------------------------------------
-- Cloning constraints
----------------------------------------------
@@ -286,6 +276,18 @@ emitWantedEvVar origin ty
emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]
emitWantedEvVars orig = mapM (emitWantedEvVar orig)
+-- | Emit a new wanted expression hole
+emitNewExprHole :: OccName -- of the hole
+ -> Id -- of the evidence
+ -> Type -> TcM ()
+emitNewExprHole occ ev_id ty
+ = do { loc <- getCtLocM (ExprHoleOrigin occ) (Just TypeLevel)
+ ; let hole = Hole { hole_sort = ExprHole ev_id
+ , hole_occ = getOccName ev_id
+ , hole_ty = ty
+ , hole_loc = loc }
+ ; emitHole hole }
+
newDict :: Class -> [TcType] -> TcM DictId
newDict cls tys
= do { name <- newSysName (mkDictOcc (getOccName cls))
@@ -2002,21 +2004,28 @@ zonkWC :: WantedConstraints -> TcM WantedConstraints
zonkWC wc = zonkWCRec wc
zonkWCRec :: WantedConstraints -> TcM WantedConstraints
-zonkWCRec (WC { wc_simple = simple, wc_impl = implic })
+zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_holes = holes })
= do { simple' <- zonkSimples simple
; implic' <- mapBagM zonkImplication implic
- ; return (WC { wc_simple = simple', wc_impl = implic' }) }
+ ; holes' <- mapBagM zonkHole holes
+ ; return (WC { wc_simple = simple', wc_impl = implic', wc_holes = holes' }) }
zonkSimples :: Cts -> TcM Cts
zonkSimples cts = do { cts' <- mapBagM zonkCt cts
; traceTc "zonkSimples done:" (ppr cts')
; return cts' }
+zonkHole :: Hole -> TcM Hole
+zonkHole hole@(Hole { hole_ty = ty })
+ = do { ty' <- zonkTcType ty
+ ; return (hole { hole_ty = ty' }) }
+ -- No need to zonk the Id in any ExprHole because we never look at it
+ -- until after the final zonk and desugaring
+
{- Note [zonkCt behaviour]
~~~~~~~~~~~~~~~~~~~~~~~~~~
zonkCt tries to maintain the canonical form of a Ct. For example,
- a CDictCan should stay a CDictCan;
- - a CHoleCan should stay a CHoleCan
- a CIrredCan should stay a CIrredCan with its cc_status flag intact
Why?, for example:
@@ -2026,8 +2035,6 @@ Why?, for example:
don't preserve a canonical form, @expandSuperClasses@ fails to expand
superclasses. This is what happened in #11525.
-- For CHoleCan, once we forget that it's a hole, we can never recover that info.
-
- For CIrredCan we want to see if a constraint is insoluble with insolubleWC
On the other hand, we change CTyEqCan to CNonCanonical, because of all of
@@ -2046,10 +2053,6 @@ creates e.g. a CDictCan where the cc_tyars are /not/ function free.
zonkCt :: Ct -> TcM Ct
-- See Note [zonkCt behaviour]
-zonkCt ct@(CHoleCan { cc_ev = ev })
- = do { ev' <- zonkCtEvidence ev
- ; return $ ct { cc_ev = ev' } }
-
zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
= do { ev' <- zonkCtEvidence ev
; args' <- mapM zonkTcType args
@@ -2262,17 +2265,15 @@ zonkTidyOrigin env orig = return (env, orig)
tidyCt :: TidyEnv -> Ct -> Ct
-- Used only in error reporting
tidyCt env ct
- = ct { cc_ev = tidy_ev env (ctEvidence ct) }
+ = ct { cc_ev = tidy_ev (ctEvidence ct) }
where
- tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence
+ tidy_ev :: CtEvidence -> CtEvidence
-- NB: we do not tidy the ctev_evar field because we don't
-- show it in error messages
- tidy_ev env ctev@(CtGiven { ctev_pred = pred })
- = ctev { ctev_pred = tidyType env pred }
- tidy_ev env ctev@(CtWanted { ctev_pred = pred })
- = ctev { ctev_pred = tidyType env pred }
- tidy_ev env ctev@(CtDerived { ctev_pred = pred })
- = ctev { ctev_pred = tidyType env pred }
+ tidy_ev ctev = ctev { ctev_pred = tidyType env (ctev_pred ctev) }
+
+tidyHole :: TidyEnv -> Hole -> Hole
+tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty }
----------------
tidyEvVar :: TidyEnv -> EvVar -> EvVar
View Lorry Controller Status