Refactor hole constraints.wip/hole-refactor

Previously, holes (both expression holes / out of scope variables and
partial-type-signature wildcards) were emitted as *constraints* via
the CHoleCan constructor. While this worked fine for error reporting,
there was a fair amount of faff in keeping these constraints in line.
In particular, and unlike other constraints, we could never change
a CHoleCan to become CNonCanonical. In addition:
 * the "predicate" of a CHoleCan constraint was really the type
   of the hole, which is not a predicate at all
 * type-level holes (partial type signature wildcards) carried
   evidence, which was never used
 * tcNormalise (used in the pattern-match checker) had to create
   a hole constraint just to extract it again; it was quite messy

The new approach is to record holes directly in WantedConstraints.
It flows much more nicely now.

Along the way, I did some cleaning up of commentary in
GHC.Tc.Errors.Hole, which I had a hard time understanding.

This was instigated by a future patch that will refactor
the way predicates are handled. The fact that CHoleCan's
"predicate" wasn't really a predicate is incompatible with
that future patch.

No test case, because this is meant to be purely internal.

It turns out that this change improves the performance of
the pattern-match checker, likely because fewer constraints
are sloshing about in tcNormalise. I have not investigated
deeply, but an improvement is not a surprise here:

-------------------------
Metric Decrease:
    PmSeriesG
-------------------------

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