Add support for *named* holes; an extension of -XTypeHoles

The idea is that you can use "_foo" rather than just "_"
as a "hole" in an expression, and this name shows up in
type errors etc.

The changes are very straightforward.
Thanks for Thijs Alkemade for making the running here.

10 files changed, 53 insertions, 38 deletions

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index c4afc5b9e5..133f0e1e06 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -576,7 +576,7 @@ addTickHsExpr (HsWrap w e) =
                 (addTickHsExpr e)       -- explicitly no tick on inside
 
 addTickHsExpr e@(HsType _) = return e
-addTickHsExpr HsHole = panic "addTickHsExpr.HsHole"
+addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
 
 -- Others dhould never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index d0b71ed2d0..6df618c645 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -213,7 +213,7 @@ dsExpr (HsLamCase arg matches)
 dsExpr (HsApp fun arg)
   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
 
-dsExpr HsHole = panic "dsExpr: HsHole"
+dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
 \end{code}
 
 Note [Desugaring vars]
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 2acc34e30f..c6f8bf17ac 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -21,6 +21,7 @@ import HsBinds
 import TcEvidence
 import CoreSyn
 import Var
+import RdrName
 import Name
 import BasicTypes
 import DataCon
@@ -309,7 +310,7 @@ data HsExpr id
 
   |  HsWrap     HsWrapper    -- TRANSLATION
                 (HsExpr id)
-  |  HsHole
+  |  HsUnboundVar RdrName
   deriving (Data, Typeable)
 
 -- HsTupArg is used for tuple sections
@@ -575,8 +576,8 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
 ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <+> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
-ppr_expr HsHole
-  = ptext $ sLit "_"
+ppr_expr (HsUnboundVar nm)
+  = ppr nm
 
 \end{code}
 
@@ -612,7 +613,7 @@ hsExprNeedsParens (PArrSeq {})        = False
 hsExprNeedsParens (HsLit {})          = False
 hsExprNeedsParens (HsOverLit {})      = False
 hsExprNeedsParens (HsVar {})          = False
-hsExprNeedsParens (HsHole {})         = False
+hsExprNeedsParens (HsUnboundVar {})   = False
 hsExprNeedsParens (HsIPVar {})        = False
 hsExprNeedsParens (ExplicitTuple {})  = False
 hsExprNeedsParens (ExplicitList {})   = False
@@ -631,7 +632,7 @@ isAtomicHsExpr (HsVar {})     = True
 isAtomicHsExpr (HsLit {})     = True
 isAtomicHsExpr (HsOverLit {}) = True
 isAtomicHsExpr (HsIPVar {})   = True
-isAtomicHsExpr (HsHole {})    = True
+isAtomicHsExpr (HsUnboundVar {}) = True
 isAtomicHsExpr (HsWrap _ e)   = isAtomicHsExpr e
 isAtomicHsExpr (HsPar e)      = isAtomicHsExpr (unLoc e)
 isAtomicHsExpr _              = False
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 5e466c9a32..452025b7cc 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -7,7 +7,7 @@
 module RnEnv (
         newTopSrcBinder,
         lookupLocatedTopBndrRn, lookupTopBndrRn,
-        lookupLocatedOccRn, lookupOccRn,
+        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
         lookupLocalOccRn_maybe,
         lookupTypeOccRn, lookupKindOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 01004e3b0d..2a8e7ab589 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -108,8 +108,14 @@ finishHsVar name
 		; return (e, unitFV name) } }
 
 rnExpr (HsVar v)
-  = do name <- lookupOccRn v
-       finishHsVar name
+  = do { opt_TypeHoles <- xoptM Opt_TypeHoles
+       ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v)
+         then do { mb_name <- lookupOccRn_maybe v
+                 ; case mb_name of
+                     Nothing -> return (HsUnboundVar v, emptyFVs)
+                     Just n  -> finishHsVar n }
+         else do { name <- lookupOccRn v
+                 ; finishHsVar name } }
 
 rnExpr (HsIPVar v)
   = return (HsIPVar v, emptyFVs)
@@ -300,9 +306,6 @@ rnExpr (ArithSeq _ seq)
 rnExpr (PArrSeq _ seq)
   = rnArithSeq seq	 `thenM` \ (new_seq, fvs) ->
     return (PArrSeq noPostTcExpr new_seq, fvs)
-
-rnExpr HsHole
-  = return (HsHole, emptyFVs)
 \end{code}
 
 These three are pattern syntax appearing in expressions.
@@ -312,7 +315,7 @@ We return a (bogus) EWildPat in each case.
 \begin{code}
 rnExpr e@EWildPat      = do { holes <- xoptM Opt_TypeHoles
                             ; if holes
-                                then return (HsHole, emptyFVs)
+                                then return (hsHoleExpr, emptyFVs)
                                 else patSynErr e
                             }
 rnExpr e@(EAsPat {})   = patSynErr e
@@ -340,13 +343,16 @@ rnExpr e@(HsArrForm {}) = arrowFail e
 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
 	-- HsWrap
 
+hsHoleExpr :: HsExpr Name
+hsHoleExpr = HsUnboundVar (mkRdrUnqual (mkVarOcc "_"))
+
 arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 arrowFail e
   = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:")
                       , nest 2 (ppr e) ])
          -- Return a place-holder hole, so that we can carry on
          -- to report other errors
-       ; return (HsHole, emptyFVs) }
+       ; return (hsHoleExpr, emptyFVs) }
 
 ----------------------
 -- See Note [Parsing sections] in Parser.y.pp
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index a7533ed8b8..c300b62a22 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -23,6 +23,7 @@ import TyCon
 import TypeRep
 import Var
 import VarEnv
+import OccName( OccName )
 import Outputable
 import Control.Monad    ( when )
 import TysWiredIn ( eqTyCon )
@@ -192,8 +193,8 @@ canonicalize (CFunEqCan { cc_loc = d
 canonicalize (CIrredEvCan { cc_ev = ev
                           , cc_loc = d })
   = canIrred d ev
-canonicalize (CHoleCan { cc_ev = ev, cc_loc = d })
-  = canHole d ev
+canonicalize (CHoleCan { cc_ev = ev, cc_loc = d, cc_occ = occ })
+  = canHole d ev occ
 
 canEvNC :: CtLoc -> CtEvidence -> TcS StopOrContinue
 -- Called only for non-canonical EvVars 
@@ -401,13 +402,13 @@ canIrred d ev
              Just new_ev -> canEvNC d new_ev  -- Re-classify and try again
              Nothing     -> return Stop } }   -- Found a cached copy
 
-canHole :: CtLoc -> CtEvidence -> TcS StopOrContinue
-canHole d ev 
+canHole :: CtLoc -> CtEvidence -> OccName -> TcS StopOrContinue
+canHole d ev occ
   = do { let ty = ctEvPred ev
        ; (xi,co) <- flatten d FMFullFlatten (ctEvFlavour ev) ty -- co :: xi ~ ty
        ; mb <- rewriteCtFlavor ev xi co 
        ; case mb of
-             Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_loc = d})
+             Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_loc = d, cc_occ = occ })
              Nothing     -> return ()   -- Found a cached copy; won't happen
        ; return Stop } 
 \end{code}
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index fd716f8dfb..01240288af 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -472,19 +472,19 @@ mkIrredErr ctxt cts
 
 ----------------
 mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
-mkHoleError ctxt ct@(CHoleCan {})
+mkHoleError ctxt ct@(CHoleCan { cc_occ = occ })
   = do { let tyvars = varSetElems (tyVarsOfCt ct)
              tyvars_msg = map loc_msg tyvars
-             msg = (text "Found hole" <+> quotes (text "_") 
-                    <+> text "with type") <+> pprType (ctEvPred (cc_ev ct))
-                   $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg)
+             msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ))
+                             2 (ptext (sLit "with type:") <+> pprType (ctEvPred (cc_ev ct)))
+                        , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ]
        ; (ctxt, binds_doc) <- relevantBindings ctxt ct
        ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
   where
     loc_msg tv 
        = case tcTyVarDetails tv of
           SkolemTv {} -> quotes (ppr tv) <+> skol_msg
-          MetaTv {}   -> quotes (ppr tv) <+> text "is an ambiguous type variable"
+          MetaTv {}   -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable")
           det -> pprTcTyVarDetails det
        where 
           skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index e87ff6d2f4..60faae75fb 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -43,6 +43,7 @@ import TcType
 import DsMonad hiding (Splice)
 import Id
 import DataCon
+import RdrName
 import Name
 import TyCon
 import Type
@@ -133,6 +134,16 @@ tcInfExpr (HsPar e) 	= do { (e', ty) <- tcInferRhoNC e
                              ; return (HsPar e', ty) }
 tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2]                                  
 tcInfExpr e             = tcInfer (tcExpr e)
+
+tcHole :: OccName -> TcRhoType -> TcM (HsExpr TcId)
+tcHole occ res_ty 
+ = do { ty <- newFlexiTyVarTy liftedTypeKind
+      ; name <- newSysName occ
+      ; let ev = mkLocalId name ty
+      ; loc <- getCtLoc HoleOrigin
+      ; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc, cc_occ = occ }
+      ; emitInsoluble can
+      ; tcWrapResult (HsVar ev) ty res_ty }
 \end{code}
 
 
@@ -231,15 +242,8 @@ tcExpr (HsType ty) _
 	-- so it's not enabled yet.
 	-- Can't eliminate it altogether from the parser, because the
 	-- same parser parses *patterns*.
-tcExpr HsHole res_ty
-  = do { ty <- newFlexiTyVarTy liftedTypeKind
-      ; traceTc "tcExpr.HsHole" (ppr ty)
-      ; ev <- mkSysLocalM (mkFastString "_") ty
-      ; loc <- getCtLoc HoleOrigin
-      ; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc }
-      ; traceTc "tcExpr.HsHole emitting" (ppr can)
-      ; emitInsoluble can
-      ; tcWrapResult (HsVar ev) ty res_ty }
+tcExpr (HsUnboundVar v) res_ty
+  = tcHole (rdrNameOcc v) res_ty
 \end{code}
 
 
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 41a65c0fd1..d6bcc41e3d 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -709,8 +709,8 @@ zonkExpr env (HsWrap co_fn expr)
     zonkExpr env1 expr	`thenM` \ new_expr ->
     return (HsWrap new_co_fn new_expr)
 
-zonkExpr _ HsHole
-  = return HsHole
+zonkExpr _ (HsUnboundVar v)
+  = return (HsUnboundVar v)
 
 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
 
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 3d53203e6e..50c9d5c3ba 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -923,7 +923,8 @@ data Ct
 
   | CHoleCan {
       cc_ev  :: CtEvidence,
-      cc_loc :: CtLoc
+      cc_loc :: CtLoc,
+      cc_occ :: OccName    -- The name of this hole
     }
 \end{code}
 
@@ -1541,6 +1542,7 @@ data CtOrigin
   | AnnOrigin           -- An annotation
   | FunDepOrigin
   | HoleOrigin
+  | UnboundOccurrenceOf RdrName
 
 pprO :: CtOrigin -> SDoc
 pprO (GivenOrigin sk)      = ppr sk
@@ -1576,7 +1578,8 @@ pprO (TypeEqOrigin t1 t2)  = ptext (sLit "a type equality") <+> sep [ppr t1, cha
 pprO (KindEqOrigin t1 t2 _) = ptext (sLit "a kind equality arising from") <+> sep [ppr t1, char '~', ppr t2]
 pprO AnnOrigin             = ptext (sLit "an annotation")
 pprO FunDepOrigin          = ptext (sLit "a functional dependency")
-pprO HoleOrigin            = ptext (sLit "a use of the hole") <+> quotes (ptext $ sLit "_")
+pprO HoleOrigin            = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_")
+pprO (UnboundOccurrenceOf name) = hsep [ptext (sLit "an undeclared identifier"), quotes (ppr name)]
 
 instance Outputable CtOrigin where
   ppr = pprO