Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Add type "holes", enabled by -XTypeHoles, Trac #5910

This single commit combines a lot of work done by
Thijs Alkemade <thijsalkemade@gmail.com>, plus a slew
of subsequent refactoring by Simon PJ.

The basic idea is
* Add a new expression form "_", a hole, standing for a not-yet-written expression
* Give a useful error message that
   (a) gives the type of the hole
   (b) gives the types of some enclosing value bindings that
       mention the hole

Driven by this goal I did a LOT of refactoring in TcErrors, which in turn
allows us to report enclosing value bindings for other errors, not just
holes.  (Thijs rightly did not attempt this!)

The major data type change is a new form of constraint
  data Ct = ...
    	  | CHoleCan {
    	      cc_ev       :: CtEvidence,
    	      cc_hole_ty  :: TcTauType,
    	      cc_depth    :: SubGoalDepth }

I'm still in two minds about whether this is the best plan. Another
possibility would be to have a predicate type for holes, somthing like
   class Hole a where
     holeValue :: a

It works the way it is, but there are some annoying special cases for
CHoleCan (just grep for "CHoleCan").
  • Loading branch information...
commit 8a9a7a8c42da3adb603f319a74e304af5e1b2128 1 parent b0db930
simonpj authored
1  compiler/deSugar/Coverage.lhs
@@ -576,6 +576,7 @@ addTickHsExpr (HsWrap w e) =
576 576
                 (addTickHsExpr e)       -- explicitly no tick on inside
577 577
 
578 578
 addTickHsExpr e@(HsType _) = return e
  579
+addTickHsExpr HsHole = panic "addTickHsExpr.HsHole"
579 580
 
580 581
 -- Others dhould never happen in expression content.
581 582
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
2  compiler/deSugar/DsExpr.lhs
@@ -216,6 +216,8 @@ dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty))
216 216
 
217 217
 dsExpr (HsApp fun arg)
218 218
   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
  219
+
  220
+dsExpr HsHole = panic "dsExpr: HsHole"
219 221
 \end{code}
220 222
 
221 223
 Note [Desugaring vars]
3  compiler/hsSyn/HsExpr.lhs
@@ -294,6 +294,7 @@ data HsExpr id
294 294
 
295 295
   |  HsWrap     HsWrapper    -- TRANSLATION
296 296
                 (HsExpr id)
  297
+  |  HsHole
297 298
   deriving (Data, Typeable)
298 299
 
299 300
 -- HsTupArg is used for tuple sections
@@ -559,6 +560,8 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
559 560
 ppr_expr (HsArrForm op _ args)
560 561
   = hang (ptext (sLit "(|") <> ppr_lexpr op)
561 562
          4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
  563
+ppr_expr HsHole
  564
+  = ptext $ sLit "_"
562 565
 
563 566
 pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
564 567
 pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
4  compiler/main/DynFlags.hs
@@ -507,6 +507,7 @@ data ExtensionFlag
507 507
    | Opt_TraditionalRecordSyntax
508 508
    | Opt_LambdaCase
509 509
    | Opt_MultiWayIf
  510
+   | Opt_TypeHoles
510 511
    deriving (Eq, Enum, Show)
511 512
 
512 513
 -- | Contains not only a collection of 'DynFlag's but also a plethora of
@@ -2449,7 +2450,8 @@ xFlags = [
2449 2450
   ( "OverlappingInstances",             Opt_OverlappingInstances, nop ),
2450 2451
   ( "UndecidableInstances",             Opt_UndecidableInstances, nop ),
2451 2452
   ( "IncoherentInstances",              Opt_IncoherentInstances, nop ),
2452  
-  ( "PackageImports",                   Opt_PackageImports, nop )
  2453
+  ( "PackageImports",                   Opt_PackageImports, nop ),
  2454
+  ( "TypeHoles",                        Opt_TypeHoles, nop )
2453 2455
   ]
2454 2456
 
2455 2457
 defaultFlags :: Platform -> [DynFlag]
11  compiler/rename/RnExpr.lhs
@@ -34,7 +34,7 @@ import HsSyn
34 34
 import TcRnMonad
35 35
 import TcEnv		( thRnBrack )
36 36
 import RnEnv
37  
-import RnTypes	
  37
+import RnTypes
38 38
 import RnPat
39 39
 import DynFlags
40 40
 import BasicTypes	( FixityDirection(..) )
@@ -299,6 +299,9 @@ rnExpr (ArithSeq _ seq)
299 299
 rnExpr (PArrSeq _ seq)
300 300
   = rnArithSeq seq	 `thenM` \ (new_seq, fvs) ->
301 301
     return (PArrSeq noPostTcExpr new_seq, fvs)
  302
+
  303
+rnExpr HsHole
  304
+  = return (HsHole, emptyFVs)
302 305
 \end{code}
303 306
 
304 307
 These three are pattern syntax appearing in expressions.
@@ -306,7 +309,11 @@ Since all the symbols are reservedops we can simply reject them.
306 309
 We return a (bogus) EWildPat in each case.
307 310
 
308 311
 \begin{code}
309  
-rnExpr e@EWildPat      = patSynErr e
  312
+rnExpr e@EWildPat      = do { holes <- xoptM Opt_TypeHoles
  313
+                            ; if holes
  314
+                                then return (HsHole, emptyFVs)
  315
+                                else patSynErr e
  316
+                            }
310 317
 rnExpr e@(EAsPat {})   = patSynErr e
311 318
 rnExpr e@(EViewPat {}) = patSynErr e
312 319
 rnExpr e@(ELazyPat {}) = patSynErr e
31  compiler/typecheck/Inst.lhs
@@ -356,14 +356,14 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do
356 356
 
357 357
 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
358 358
                -> TcRn (TidyEnv, SDoc)
359  
-syntaxNameCtxt name orig ty tidy_env = do
360  
-    inst_loc <- getCtLoc orig
361  
-    let
362  
-	msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+> 
363  
-				ptext (sLit "(needed by a syntactic construct)"),
364  
-		    nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
365  
-		    nest 2 (pprArisingAt inst_loc)]
366  
-    return (tidy_env, msg)
  359
+syntaxNameCtxt name orig ty tidy_env
  360
+  = do { inst_loc <- getCtLoc orig
  361
+       ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
  362
+			  <+> ptext (sLit "(needed by a syntactic construct)")
  363
+		        , nest 2 (ptext (sLit "has the required type:")
  364
+                                  <+> ppr (tidyType tidy_env ty))
  365
+		        , nest 2 (pprArisingAt inst_loc) ]
  366
+       ; return (tidy_env, msg) }
367 367
 \end{code}
368 368
 
369 369
 
@@ -523,6 +523,7 @@ tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOf
523 523
 tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
524 524
 tyVarsOfCt (CDictCan { cc_tyargs = tys }) 	        = tyVarsOfTypes tys
525 525
 tyVarsOfCt (CIrredEvCan { cc_ty = ty })                 = tyVarsOfType ty
  526
+tyVarsOfCt (CHoleCan { cc_hole_ty = ty })               = tyVarsOfType ty
526 527
 tyVarsOfCt (CNonCanonical { cc_ev = fl })               = tyVarsOfType (ctEvPred fl)
527 528
 
528 529
 tyVarsOfCts :: Cts -> TcTyVarSet
@@ -551,8 +552,10 @@ tidyCt :: TidyEnv -> Ct -> Ct
551 552
 -- Used only in error reporting
552 553
 -- Also converts it to non-canonical
553 554
 tidyCt env ct 
554  
-  = CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct)
555  
-                  , cc_depth  = cc_depth ct } 
  555
+  = case ct of
  556
+     CHoleCan {} -> ct { cc_ev = tidy_flavor env (cc_ev ct) }
  557
+     _ -> CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct)
  558
+                        , cc_depth  = cc_depth ct }
556 559
   where 
557 560
     tidy_flavor :: TidyEnv -> CtEvidence -> CtEvidence
558 561
      -- NB: we do not tidy the ctev_evtm/var field because we don't 
@@ -569,8 +572,8 @@ tidyEvVar :: TidyEnv -> EvVar -> EvVar
569 572
 tidyEvVar env var = setVarType var (tidyType env (varType var))
570 573
 
571 574
 tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
572  
-tidyGivenLoc env (CtLoc skol span ctxt) 
573  
-  = CtLoc (tidySkolemInfo env skol) span ctxt
  575
+tidyGivenLoc env (CtLoc skol lcl) 
  576
+  = CtLoc (tidySkolemInfo env skol) lcl
574 577
 
575 578
 tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
576 579
 tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
@@ -635,8 +638,8 @@ substFlavor subst ctev@(CtDerived { ctev_pred = pty })
635 638
   = ctev { ctev_pred = substTy subst pty }
636 639
 
637 640
 substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
638  
-substGivenLoc subst (CtLoc skol span ctxt) 
639  
-  = CtLoc (substSkolemInfo subst skol) span ctxt
  641
+substGivenLoc subst (CtLoc skol lcl) 
  642
+  = CtLoc (substSkolemInfo subst skol) lcl
640 643
 
641 644
 substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo
642 645
 substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
90  compiler/typecheck/TcBinds.lhs
@@ -6,7 +6,7 @@
6 6
 
7 7
 \begin{code}
8 8
 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
9  
-                 tcHsBootSigs, tcPolyBinds, tcPolyCheck,
  9
+                 tcHsBootSigs, tcPolyCheck,
10 10
                  PragFun, tcSpecPrags, tcVectDecls, mkPragFun, 
11 11
                  TcSigInfo(..), TcSigFun, 
12 12
                  instTcTySig, instTcTySigFromId,
@@ -274,7 +274,8 @@ tcValBinds top_lvl binds sigs thing_inside
274 274
 
275 275
                 -- Extend the envt right away with all 
276 276
                 -- the Ids declared with type signatures
277  
-        ; (binds', thing) <- tcExtendIdEnv poly_ids $
  277
+                -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack
  278
+        ; (binds', thing) <- tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $
278 279
                              tcBindGroups top_lvl sig_fn prag_fn 
279 280
                                           binds thing_inside
280 281
 
@@ -336,7 +337,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
336 337
 
337 338
     go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
338 339
     go (scc:sccs) = do  { (binds1, ids1, closed) <- tc_scc scc
339  
-                        ; (binds2, ids2, thing)  <- tcExtendLetEnv closed ids1 $ go sccs
  340
+                        ; (binds2, ids2, thing)  <- tcExtendLetEnv closed ids1 $ 
  341
+                                                    go sccs
340 342
                         ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
341 343
     go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
342 344
 
@@ -397,20 +399,15 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
397 399
 
398 400
     { traceTc "------------------------------------------------" empty
399 401
     ; traceTc "Bindings for {" (ppr binder_names)
400  
-
401  
---    -- Instantiate the polytypes of any binders that have signatures
402  
---    -- (as determined by sig_fn), returning a TcSigInfo for each
403  
---    ; tc_sig_fn <- tcInstSigs sig_fn binder_names
404  
-
405 402
     ; dflags   <- getDynFlags
406 403
     ; type_env <- getLclTypeEnv
407 404
     ; let plan = decideGeneralisationPlan dflags type_env 
408 405
                          binder_names bind_list sig_fn
409 406
     ; traceTc "Generalisation plan" (ppr plan)
410 407
     ; result@(tc_binds, poly_ids, _) <- case plan of
411  
-         NoGen          -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list
412  
-         InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list
413  
-         CheckGen sig   -> tcPolyCheck sig prag_fn rec_tc bind_list
  408
+         NoGen          -> tcPolyNoGen top_lvl rec_tc prag_fn sig_fn bind_list
  409
+         InferGen mn cl -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn mn cl bind_list
  410
+         CheckGen sig   -> tcPolyCheck top_lvl rec_tc prag_fn sig bind_list
414 411
 
415 412
         -- Check whether strict bindings are ok
416 413
         -- These must be non-recursive etc, and are not generalised
@@ -429,17 +426,18 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
429 426
          -- span that includes them all
430 427
 
431 428
 ------------------
432  
-tcPolyNoGen 
433  
-  :: TcSigFun -> PragFun
  429
+tcPolyNoGen     -- No generalisation whatsoever
  430
+  :: TopLevelFlag
434 431
   -> RecFlag       -- Whether it's recursive after breaking
435 432
                    -- dependencies based on type signatures
  433
+  -> PragFun -> TcSigFun
436 434
   -> [LHsBind Name]
437 435
   -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
438  
--- No generalisation whatsoever
439 436
 
440  
-tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
441  
-  = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn) 
442  
-                                             rec_tc bind_list
  437
+tcPolyNoGen top_lvl rec_tc prag_fn tc_sig_fn bind_list
  438
+  = do { (binds', mono_infos) <- tcMonoBinds top_lvl rec_tc tc_sig_fn
  439
+                                             (LetGblBndr prag_fn) 
  440
+                                             bind_list
443 441
        ; mono_ids' <- mapM tc_mono_info mono_infos
444 442
        ; return (binds', mono_ids', NotTopLevel) }
445 443
   where
@@ -455,17 +453,19 @@ tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
455 453
            -- So we can safely ignore _specs
456 454
 
457 455
 ------------------
458  
-tcPolyCheck :: TcSigInfo -> PragFun
  456
+tcPolyCheck :: TopLevelFlag
459 457
             -> RecFlag       -- Whether it's recursive after breaking
460 458
                              -- dependencies based on type signatures
  459
+            -> PragFun -> TcSigInfo 
461 460
             -> [LHsBind Name]
462 461
             -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
463 462
 -- There is just one binding, 
464 463
 --   it binds a single variable,
465 464
 --   it has a signature,
466  
-tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped 
  465
+tcPolyCheck top_lvl rec_tc prag_fn
  466
+            sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped 
467 467
                            , sig_theta = theta, sig_tau = tau, sig_loc = loc })
468  
-    prag_fn rec_tc bind_list
  468
+            bind_list
469 469
   = do { ev_vars <- newEvVars theta
470 470
        ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
471 471
              prag_sigs = prag_fn (idName poly_id)
@@ -474,7 +474,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
474 474
             <- setSrcSpan loc $  
475 475
                checkConstraints skol_info tvs ev_vars $
476 476
                tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $
477  
-               tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
  477
+               tcMonoBinds top_lvl rec_tc (\_ -> Just sig) LetLclBndr bind_list
478 478
 
479 479
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
480 480
        ; poly_id    <- addInlinePrags poly_id prag_sigs
@@ -494,17 +494,18 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
494 494
 
495 495
 ------------------
496 496
 tcPolyInfer 
497  
-  :: Bool         -- True <=> apply the monomorphism restriction
498  
-  -> Bool         -- True <=> free vars have closed types
499  
-  -> TcSigFun -> PragFun
  497
+  :: TopLevelFlag
500 498
   -> RecFlag       -- Whether it's recursive after breaking
501 499
                    -- dependencies based on type signatures
  500
+  -> PragFun -> TcSigFun 
  501
+  -> Bool         -- True <=> apply the monomorphism restriction
  502
+  -> Bool         -- True <=> free vars have closed types
502 503
   -> [LHsBind Name]
503 504
   -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
504  
-tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
  505
+tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn mono closed bind_list
505 506
   = do { ((binds', mono_infos), wanted)
506 507
              <- captureConstraints $
507  
-                tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
  508
+                tcMonoBinds top_lvl rec_tc tc_sig_fn LetLclBndr bind_list
508 509
 
509 510
        ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
510 511
        ; (qtvs, givens, mr_bites, ev_binds) <- 
@@ -524,10 +525,8 @@ tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
524 525
 
525 526
        ; traceTc "Binding:" (ppr final_closed $$
526 527
                              ppr (poly_ids `zip` map idType poly_ids))
527  
-       ; return (unitBag abs_bind, poly_ids, final_closed)   
  528
+       ; return (unitBag abs_bind, poly_ids, final_closed) }
528 529
          -- poly_ids are guaranteed zonked by mkExport
529  
-  }
530  
-
531 530
 
532 531
 --------------
533 532
 mkExport :: PragFun 
@@ -937,14 +936,15 @@ should not typecheck because
937 936
 will not typecheck.
938 937
 
939 938
 \begin{code}
940  
-tcMonoBinds :: TcSigFun -> LetBndrSpec 
  939
+tcMonoBinds :: TopLevelFlag
941 940
             -> RecFlag  -- Whether the binding is recursive for typechecking purposes
942 941
                         -- i.e. the binders are mentioned in their RHSs, and
943 942
                         --      we are not rescued by a type signature
  943
+            -> TcSigFun -> LetBndrSpec 
944 944
             -> [LHsBind Name]
945 945
             -> TcM (LHsBinds TcId, [MonoBindInfo])
946 946
 
947  
-tcMonoBinds sig_fn no_gen is_rec
  947
+tcMonoBinds top_lvl is_rec sig_fn no_gen
948 948
            [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
949 949
                                 fun_matches = matches, bind_fvs = fvs })]
950 950
                              -- Single function binding, 
@@ -956,15 +956,17 @@ tcMonoBinds sig_fn no_gen is_rec
956 956
         -- e.g.         f = \(x::forall a. a->a) -> <body>
957 957
         --      We want to infer a higher-rank type for f
958 958
     setSrcSpan b_loc    $
959  
-    do  { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
960  
-
  959
+    do  { rhs_ty  <- newFlexiTyVarTy openTypeKind
961 960
         ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
  961
+        ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $
  962
+                               tcMatchesFun name inf matches rhs_ty
  963
+
962 964
         ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
963 965
                                               fun_matches = matches', bind_fvs = fvs,
964 966
                                               fun_co_fn = co_fn, fun_tick = Nothing })),
965 967
                   [(name, Nothing, mono_id)]) }
966 968
 
967  
-tcMonoBinds sig_fn no_gen _ binds
  969
+tcMonoBinds top_lvl _ sig_fn no_gen binds
968 970
   = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
969 971
 
970 972
         -- Bring the monomorphic Ids, into scope for the RHSs
@@ -973,10 +975,10 @@ tcMonoBinds sig_fn no_gen _ binds
973 975
                     -- A monomorphic binding for each term variable that lacks 
974 976
                     -- a type sig.  (Ones with a sig are already in scope.)
975 977
 
976  
-        ; binds' <- tcExtendIdEnv2 rhs_id_env $ do
977  
-                    traceTc "tcMonoBinds" $  vcat [ ppr n <+> ppr id <+> ppr (idType id) 
978  
-                                                  | (n,id) <- rhs_id_env]
979  
-                    mapM (wrapLocM tcRhs) tc_binds
  978
+        ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) 
  979
+                                       | (n,id) <- rhs_id_env]
  980
+        ; binds' <- tcExtendIdEnv2 rhs_id_env $ 
  981
+                    mapM (wrapLocM (tcRhs top_lvl)) tc_binds
980 982
         ; return (listToBag binds', mono_info) }
981 983
 
982 984
 ------------------------
@@ -1032,13 +1034,14 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1032 1034
         -- AbsBind, VarBind impossible
1033 1035
 
1034 1036
 -------------------
1035  
-tcRhs :: TcMonoBind -> TcM (HsBind TcId)
  1037
+tcRhs :: TopLevelFlag -> TcMonoBind -> TcM (HsBind TcId)
1036 1038
 -- When we are doing pattern bindings, or multiple function bindings at a time
1037 1039
 -- we *don't* bring any scoped type variables into scope
1038 1040
 -- Wny not?  They are not completely rigid.
1039 1041
 -- That's why we have the special case for a single FunBind in tcMonoBinds
1040  
-tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
1041  
-  = do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
  1042
+tcRhs top_lvl (TcFunBind (_,_,mono_id) loc inf matches)
  1043
+  = tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $
  1044
+    do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1042 1045
         ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf 
1043 1046
                                             matches (idType mono_id)
1044 1047
         ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
@@ -1046,8 +1049,9 @@ tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
1046 1049
                           , fun_co_fn = co_fn 
1047 1050
                           , bind_fvs = placeHolderNames, fun_tick = Nothing }) }
1048 1051
 
1049  
-tcRhs (TcPatBind _ pat' grhss pat_ty)
1050  
-  = do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
  1052
+tcRhs top_lvl (TcPatBind infos pat' grhss pat_ty)
  1053
+  = tcExtendIdBndrs [ TcIdBndr mono_id top_lvl | (_,_,mono_id) <- infos ] $
  1054
+    do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1051 1055
         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1052 1056
                     tcGRHSsPat grhss pat_ty
1053 1057
         ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty 
9  compiler/typecheck/TcCanonical.lhs
@@ -195,7 +195,9 @@ canonicalize (CIrredEvCan { cc_ev = fl
195 195
                           , cc_depth = d
196 196
                           , cc_ty = xi })
197 197
   = canIrred d fl xi
198  
-
  198
+canonicalize ct@(CHoleCan {})
  199
+  = do { emitInsoluble ct
  200
+       ; return Stop }
199 201
 
200 202
 canEvNC :: SubGoalDepth 
201 203
         -> CtEvidence 
@@ -227,7 +229,6 @@ canTuple d fl tys
227 229
        ; canEvVarsCreated d ctevs }
228 230
 \end{code}
229 231
 
230  
-
231 232
 %************************************************************************
232 233
 %*                                                                      *
233 234
 %*                      Class Canonicalization
@@ -818,7 +819,9 @@ canEqAppTy d fl s1 t1 s2 t2
818 819
        ; canEvVarsCreated d ctevs }
819 820
 
820 821
 canEqFailure :: SubGoalDepth -> CtEvidence -> TcS StopOrContinue
821  
-canEqFailure d fl = do { emitFrozenError fl d; return Stop }
  822
+canEqFailure d fl 
  823
+  = do { emitInsoluble (CNonCanonical { cc_ev = fl, cc_depth = d }) 
  824
+       ; return Stop }
822 825
 
823 826
 ------------------------
824 827
 emitKindConstraint :: Ct -> TcS StopOrContinue
21  compiler/typecheck/TcEnv.lhs
@@ -25,6 +25,8 @@ module TcEnv(
25 25
         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
26 26
         tcExtendGhciEnv, tcExtendLetEnv,
27 27
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
  28
+        tcExtendIdBndrs,
  29
+
28 30
         tcLookup, tcLookupLocated, tcLookupLocalIds, 
29 31
         tcLookupId, tcLookupTyVar, 
30 32
         tcLookupLcl_maybe, 
@@ -375,27 +377,36 @@ tcExtendLetEnv closed ids thing_inside
375 377
         ; tc_extend_local_env [ (idName id, ATcId { tct_id = id 
376 378
                                                   , tct_closed = closed
377 379
                                                   , tct_level = thLevel stage })
378  
-                                 | id <- ids]
379  
-          thing_inside }
  380
+                              | id <- ids] $
  381
+          tcExtendIdBndrs [TcIdBndr id closed | id <- ids] thing_inside }
380 382
 
381 383
 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
382 384
 tcExtendIdEnv ids thing_inside 
383  
-  = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
  385
+  = tcExtendIdEnv2 [(idName id, id) | id <- ids] $
  386
+    tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids] 
  387
+    thing_inside
384 388
 
385 389
 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
386 390
 tcExtendIdEnv1 name id thing_inside 
387  
-  = tcExtendIdEnv2 [(name,id)] thing_inside
  391
+  = tcExtendIdEnv2 [(name,id)] $
  392
+    tcExtendIdBndrs [TcIdBndr id NotTopLevel]
  393
+    thing_inside
388 394
 
389 395
 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
  396
+-- Do *not* extend the tcl_bndrs stack
  397
+-- The tct_closed flag really doesn't matter
390 398
 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
391 399
 tcExtendIdEnv2 names_w_ids thing_inside
392 400
   = do  { stage <- getStage
393 401
         ; tc_extend_local_env [ (name, ATcId { tct_id = id 
394 402
                                              , tct_closed = NotTopLevel
395 403
                                              , tct_level = thLevel stage })
396  
-                                 | (name,id) <- names_w_ids]
  404
+                              | (name,id) <- names_w_ids] $
397 405
           thing_inside }
398 406
 
  407
+tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a
  408
+tcExtendIdBndrs bndrs = updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
  409
+
399 410
 tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
400 411
 -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
401 412
 -- Note especially that we bind them at 
443  compiler/typecheck/TcErrors.lhs
@@ -8,7 +8,7 @@
8 8
 -- for details
9 9
 
10 10
 module TcErrors( 
11  
-       reportUnsolved, ErrEnv,
  11
+       reportUnsolved, reportAllUnsolved,
12 12
        warnDefaulting,
13 13
 
14 14
        flattenForAllErrorTcS,
@@ -30,15 +30,14 @@ import InstEnv
30 30
 import TyCon
31 31
 import TcEvidence
32 32
 import Name
33  
-import NameEnv
34  
-import Id               ( idType )
  33
+import Id 
35 34
 import Var
36 35
 import VarSet
37 36
 import VarEnv
38 37
 import Bag
39 38
 import Maybes
40 39
 import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
41  
-import SrcLoc           ( noSrcSpan )
  40
+import BasicTypes 
42 41
 import Util
43 42
 import FastString
44 43
 import Outputable
@@ -56,18 +55,66 @@ ToDo: for these error messages, should we note the location as coming
56 55
 from the insts, or just whatever seems to be around in the monad just
57 56
 now?
58 57
 
59  
-\begin{code}
60  
--- We keep an environment mapping coercion ids to the error messages they
61  
--- trigger; this is handy for -fwarn--type-errors
62  
-type ErrEnv = VarEnv [ErrMsg]
  58
+Note [Deferring coercion errors to runtime]
  59
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  60
+While developing, sometimes it is desirable to allow compilation to succeed even
  61
+if there are type errors in the code. Consider the following case:
  62
+
  63
+  module Main where
  64
+
  65
+  a :: Int
  66
+  a = 'a'
  67
+
  68
+  main = print "b"
  69
+
  70
+Even though `a` is ill-typed, it is not used in the end, so if all that we're
  71
+interested in is `main` it is handy to be able to ignore the problems in `a`.
  72
+
  73
+Since we treat type equalities as evidence, this is relatively simple. Whenever
  74
+we run into a type mismatch in TcUnify, we normally just emit an error. But it
  75
+is always safe to defer the mismatch to the main constraint solver. If we do
  76
+that, `a` will get transformed into
63 77
 
64  
-reportUnsolved :: Bool -> WantedConstraints -> TcM (Bag EvBind)
  78
+  co :: Int ~ Char
  79
+  co = ...
  80
+
  81
+  a :: Int
  82
+  a = 'a' `cast` co
  83
+
  84
+The constraint solver would realize that `co` is an insoluble constraint, and
  85
+emit an error with `reportUnsolved`. But we can also replace the right-hand side
  86
+of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
  87
+to compile, and it will run fine unless we evaluate `a`. This is what
  88
+`deferErrorsToRuntime` does.
  89
+
  90
+It does this by keeping track of which errors correspond to which coercion
  91
+in TcErrors. TcErrors.reportTidyWanteds does not print the errors
  92
+and does not fail if -fwarn-type-errors is on, so that we can continue
  93
+compilation. The errors are turned into warnings in `reportUnsolved`.
  94
+
  95
+\begin{code}
  96
+reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
  97
+reportUnsolved wanted
  98
+  = do { binds_var <- newTcEvBinds
  99
+       ; defer <- doptM Opt_DeferTypeErrors
  100
+       ; report_unsolved (Just binds_var) defer wanted
  101
+       ; getTcEvBinds binds_var }
  102
+
  103
+reportAllUnsolved :: WantedConstraints -> TcM ()
  104
+-- Report all unsolved goals, even if -fdefer-type-errors is on
  105
+-- See Note [Deferring coercion errors to runtime]
  106
+reportAllUnsolved wanted 
  107
+  = report_unsolved Nothing (panic "reportAllUnsolved") wanted
  108
+
  109
+report_unsolved :: Maybe EvBindsVar  -- cec_binds
  110
+                -> Bool              -- cec_defer
  111
+                -> WantedConstraints -> TcM ()
65 112
 -- Important precondition:
66 113
 -- WantedConstraints are fully zonked and unflattened, that is,
67 114
 -- zonkWC has already been applied to these constraints.
68  
-reportUnsolved runtimeCoercionErrors wanted
  115
+report_unsolved mb_binds_var defer wanted
69 116
   | isEmptyWC wanted
70  
-  = return emptyBag
  117
+  = return ()
71 118
   | otherwise
72 119
   = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted)
73 120
 
@@ -75,11 +122,6 @@ reportUnsolved runtimeCoercionErrors wanted
75 122
                  
76 123
             -- If we are deferring we are going to need /all/ evidence around,
77 124
             -- including the evidence produced by unflattening (zonkWC)
78  
-       ; defer <- if runtimeCoercionErrors 
79  
-                  then do { ev_binds_var <- newTcEvBinds
80  
-                          ; return (Just ev_binds_var) }
81  
-                  else return Nothing
82  
-
83 125
        ; errs_so_far <- ifErrsM (return True) (return False)
84 126
        ; let tidy_env = tidyFreeTyVars env0 free_tvs
85 127
              free_tvs = tyVarsOfWC wanted
@@ -90,17 +132,14 @@ reportUnsolved runtimeCoercionErrors wanted
90 132
                                           -- to report
91 133
                             , cec_extra = empty
92 134
                             , cec_tidy  = tidy_env
93  
-                            , cec_defer = defer }
  135
+                            , cec_defer = defer
  136
+                            , cec_binds = mb_binds_var }
94 137
 
95 138
        ; traceTc "reportUnsolved (after unflattening):" $ 
96 139
          vcat [ pprTvBndrs (varSetElems free_tvs)
97 140
               , ppr wanted ]
98 141
 
99  
-       ; reportWanteds err_ctxt wanted
100  
-
101  
-       ; case defer of
102  
-            Nothing -> return emptyBag
103  
-            Just ev_binds_var -> getTcEvBinds ev_binds_var }
  142
+       ; reportWanteds err_ctxt wanted }
104 143
 
105 144
 --------------------------------------------
106 145
 --      Internal functions
@@ -114,10 +153,14 @@ data ReportErrCtxt
114 153
           , cec_extra :: SDoc       -- Add this to each error message
115 154
           , cec_insol :: Bool       -- True <=> do not report errors involving 
116 155
                                     --          ambiguous errors
117  
-          , cec_defer :: Maybe EvBindsVar 
118  
-                         -- Nothinng <=> errors are, well, errors
119  
-                         -- Just ev  <=> make errors into warnings, and emit evidence
120  
-                         --              bindings into 'ev' for unsolved constraints
  156
+
  157
+          , cec_binds :: Maybe EvBindsVar 
  158
+                         -- Nothinng <=> Report all errors, including holes; no bindings
  159
+                         -- Just ev  <=> make some errors (depending on cec_defer)
  160
+                         --              into warnings, and emit evidence bindings
  161
+                         --              into 'ev' for unsolved constraints
  162
+          , cec_defer :: Bool       -- True <=> -fdefer-type-errors
  163
+                                    -- Irrelevant if cec_binds = Nothing
121 164
       }
122 165
 
123 166
 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
@@ -139,40 +182,49 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
139 182
                      , ic_loc   = tidyGivenLoc env1 loc }
140 183
     ctxt' = ctxt { cec_tidy  = env1
141 184
                  , cec_encl  = implic' : cec_encl ctxt
142  
-                 , cec_defer = case cec_defer ctxt of
  185
+                 , cec_binds = case cec_binds ctxt of
143 186
                                  Nothing -> Nothing
144 187
                                  Just {} -> Just evb }
145 188
 
146 189
 reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
147 190
 reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
148  
-  = reportTidyWanteds ctxt tidy_all implics
  191
+  = do { reportOrDefer ctxt tidy_cts
  192
+       ; mapBagM_ (reportImplic ctxt) implics }
149 193
   where
150 194
     env = cec_tidy ctxt
151  
-    tidy_all = mapBag (tidyCt env) (insols `unionBags` flats)
  195
+    tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats)
152 196
                   -- All the Derived ones have been filtered out alrady
153 197
                   -- by the constraint solver. This is ok; we don't want
154 198
                   -- to report unsolved Derived goals as error
155 199
                   -- See Note [Do not report derived but soluble errors]
156 200
 
157  
-reportTidyWanteds :: ReportErrCtxt -> Cts -> Bag Implication -> TcM ()
158  
-reportTidyWanteds ctxt flats implics
159  
-  | Just ev_binds_var <- cec_defer ctxt
160  
-  = do { -- Defer errors to runtime
161  
-         -- See Note [Deferring coercion errors to runtime] in TcSimplify
162  
-         mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) flats
163  
-       ; mapBagM_ (reportImplic ctxt) implics }
164  
-
165  
-  | otherwise
166  
-  = do { reportFlats ctxt flats
167  
-       ; mapBagM_ (reportImplic ctxt) implics }
168  
-             
  201
+reportOrDefer :: ReportErrCtxt -> Cts -> TcM ()
  202
+reportOrDefer ctxt@(CEC { cec_binds = mb_binds_var
  203
+                        , cec_defer = defer_errs }) cts
  204
+  | Just ev_binds_var <- mb_binds_var
  205
+  , defer_errs  -- -fdefer-type-errors: Defer all
  206
+                -- See Note [Deferring coercion errors to runtime]
  207
+  = mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) cts
  208
+
  209
+  | Just ev_binds_var <- mb_binds_var
  210
+                -- No -fdefer-type-errors: Defer only holes
  211
+                -- See Note [Deferring coercion errors to runtime]
  212
+  = do { let (holes, non_holes) = partitionBag isHoleCt cts
  213
+       ; reportFlats ctxt non_holes
  214
+       ; mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) holes }
  215
+      -- Thijs had something about extending the tidy-env, but I don't know why
  216
+
  217
+  | otherwise   -- Defer nothing
  218
+  = reportFlats ctxt cts
169 219
 
170 220
 deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) 
171 221
                -> Ct -> TcM ()
  222
+-- See Note [Deferring coercion errors to runtime]
172 223
 deferToRuntime ev_binds_var ctxt mk_err_msg ct 
173 224
   | CtWanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
174  
-  = do { err <- setCtLoc loc $
175  
-                mk_err_msg ctxt ct
  225
+  = do { ctxt' <- relevantBindings ctxt ct
  226
+       ; err <- setCtLoc loc $
  227
+                mk_err_msg ctxt' ct
176 228
        ; dflags <- getDynFlags
177 229
        ; let err_msg = pprLocErrMsg err
178 230
              err_fs  = mkFastString $ showSDoc dflags $
@@ -193,22 +245,24 @@ reportFlats ctxt flats    -- Here 'flats' includes insolble goals
193 245
       [ -- First deal with things that are utterly wrong
194 246
         -- Like Int ~ Bool (incl nullary TyCons)
195 247
         -- or  Int ~ t a   (AppTy on one side)
196  
-        ("Utterly wrong",  utterly_wrong,   groupErrs (mkEqErr ctxt))
  248
+        ("Utterly wrong",  utterly_wrong,   mkGroupReporter mkEqErr)
  249
+      , ("Holes",          is_hole,         mkUniReporter mkHoleError)
197 250
 
198 251
         -- Report equalities of form (a~ty).  They are usually
199 252
         -- skolem-equalities, and they cause confusing knock-on 
200 253
         -- effects in other errors; see test T4093b.
201  
-      , ("Skolem equalities",    skolem_eq,       mkReporter (mkEqErr1 ctxt))
202  
-
203  
-      , ("Unambiguous",          unambiguous,     reportFlatErrs ctxt) ]
204  
-      (reportAmbigErrs ctxt)
205  
-      (bagToList flats)
  254
+      , ("Skolem equalities",    skolem_eq,   mkUniReporter mkEqErr1)
  255
+      , ("Unambiguous",          unambiguous, reportFlatErrs) ]
  256
+      reportAmbigErrs
  257
+      ctxt (bagToList flats)
206 258
   where
207 259
     utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool
208 260
 
209 261
     utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 
210 262
     utterly_wrong _ _ = False
211 263
 
  264
+    is_hole ct _ = isHoleCt ct
  265
+
212 266
     skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 
213 267
     skolem_eq _ _ = False
214 268
 
@@ -238,63 +292,38 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
238 292
                       _ -> Nothing
239 293
 
240 294
 -----------------
241  
-type Reporter = [Ct] -> TcM ()
242  
-
243  
-mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM ()
244  
--- Reports errors one at a time
245  
-mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_ev ct) $
246  
-                                              mk_err ct; 
247  
-                                     ; reportError err })
248  
-
249  
-tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] -> Reporter -> Reporter
250  
--- Use the first reporter in the list whose predicate says True
251  
-tryReporters reporters deflt cts
252  
-  = do { traceTc "tryReporters {" (ppr cts) 
253  
-       ; go reporters cts
254  
-       ; traceTc "tryReporters }" empty }
255  
-  where
256  
-    go [] cts = deflt cts 
257  
-    go ((str, pred, reporter) : rs) cts
258  
-      | null yeses  = traceTc "tryReporters: no" (text str) >> 
259  
-                      go rs cts
260  
-      | otherwise   = traceTc "tryReporters: yes" (text str <+> ppr yeses) >> 
261  
-                      reporter yeses
262  
-      where
263  
-       yeses = filter keep_me cts
264  
-       keep_me ct = pred ct (classifyPredType (ctPred ct))
265  
-
266  
------------------
267 295
 mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg
268 296
 -- Context is already set
269 297
 mkFlatErr ctxt ct   -- The constraint is always wanted
270  
-  | isIPPred (ctPred ct) = mkIPErr    ctxt [ct]
  298
+  | isHoleCt ct
  299
+  = mkHoleError ctxt ct
271 300
   | otherwise
272 301
   = case classifyPredType (ctPred ct) of
273  
-      ClassPred {}  -> mkDictErr  ctxt [ct]
  302
+      ClassPred cls _ | isIPClass cls -> mkIPErr   ctxt [ct]
  303
+                      | otherwise     -> mkDictErr ctxt [ct]
274 304
       IrredPred {}  -> mkIrredErr ctxt [ct]
275 305
       EqPred {}     -> mkEqErr1 ctxt ct
276 306
       TuplePred {}  -> panic "mkFlat"
277 307
       
278  
-reportAmbigErrs :: ReportErrCtxt -> Reporter
  308
+reportAmbigErrs :: Reporter
279 309
 reportAmbigErrs ctxt cts
280 310
   | cec_insol ctxt = return ()
281 311
   | otherwise      = reportFlatErrs ctxt cts
282 312
           -- Only report ambiguity if no other errors (at all) happened
283 313
           -- See Note [Avoiding spurious errors] in TcSimplify
284 314
 
285  
-reportFlatErrs :: ReportErrCtxt -> Reporter
  315
+reportFlatErrs :: Reporter
286 316
 -- Called once for non-ambigs, once for ambigs
287 317
 -- Report equality errors, and others only if we've done all 
288 318
 -- the equalities.  The equality errors are more basic, and
289 319
 -- can lead to knock on type-class errors
290  
-reportFlatErrs ctxt cts
  320
+reportFlatErrs
291 321
   = tryReporters
292  
-      [ ("Equalities", is_equality, groupErrs (mkEqErr ctxt)) ]
293  
-      (\cts -> do { let (dicts, ips, irreds) = go cts [] [] []
294  
-                  ; groupErrs (mkIPErr    ctxt) ips   
295  
-                  ; groupErrs (mkIrredErr ctxt) irreds
296  
-                  ; groupErrs (mkDictErr  ctxt) dicts })
297  
-      cts
  322
+      [ ("Equalities", is_equality, mkGroupReporter mkEqErr) ]
  323
+      (\ctxt cts -> do { let (dicts, ips, irreds) = go cts [] [] []
  324
+                       ; mkGroupReporter mkIPErr    ctxt ips   
  325
+                       ; mkGroupReporter mkIrredErr ctxt irreds
  326
+                       ; mkGroupReporter mkDictErr  ctxt dicts })
298 327
   where
299 328
     is_equality _ (EqPred {}) = True
300 329
     is_equality _ _           = False
@@ -307,28 +336,41 @@ reportFlatErrs ctxt cts
307 336
       = case classifyPredType (ctPred ct) of
308 337
           ClassPred {}  -> go cts (ct:dicts) ips irreds
309 338
           IrredPred {}  -> go cts dicts ips (ct:irreds)
310  
-          _             -> panic "mkFlat"
  339
+          _             -> panic "reportFlatErrs"
311 340
     -- TuplePreds should have been expanded away by the constraint
312 341
     -- simplifier, so they shouldn't show up at this point
313 342
     -- And EqPreds are dealt with by the is_equality test
314 343
 
315 344
 
316 345
 --------------------------------------------
317  
---      Support code 
  346
+--      Reporters
318 347
 --------------------------------------------
319 348
 
320  
-groupErrs :: ([Ct] -> TcM ErrMsg)  -- Deal with one group
321  
-	  -> [Ct]	           -- Unsolved wanteds
322  
-          -> TcM ()
  349
+type Reporter = ReportErrCtxt -> [Ct] -> TcM ()
  350
+
  351
+mkUniReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
  352
+-- Reports errors one at a time
  353
+mkUniReporter mk_err ctxt 
  354
+  = mapM_ $ \ct -> 
  355
+   do { ctxt' <- relevantBindings ctxt ct
  356
+      ; err <- setCtFlavorLoc (cc_ev ct) $
  357
+               mk_err ctxt' ct; 
  358
+      ; reportError err }
  359
+
  360
+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
  361
+                             -- Make error message for a group
  362
+                -> Reporter  -- Deal with lots of constraints
323 363
 -- Group together insts from same location
324 364
 -- We want to report them together in error messages
325 365
 
326  
-groupErrs _ [] 
  366
+mkGroupReporter _ _ [] 
327 367
   = return ()
328  
-groupErrs mk_err (ct1 : rest)
329  
-  = do  { err <- setCtFlavorLoc flavor $ mk_err cts
330  
-        ; reportError err
331  
-        ; groupErrs mk_err others }
  368
+mkGroupReporter mk_err ctxt (ct1 : rest)
  369
+  = do { ctxt' <- relevantBindings ctxt ct1
  370
+       ; err <- setCtFlavorLoc flavor $ 
  371
+                mk_err ctxt' cts
  372
+       ; reportError err
  373
+       ; mkGroupReporter mk_err ctxt others }
332 374
   where
333 375
    flavor            = cc_ev ct1
334 376
    cts               = ct1 : friends
@@ -342,7 +384,26 @@ groupErrs mk_err (ct1 : rest)
342 384
    same_group _ _ = False
343 385
 
344 386
    same_loc :: CtLoc o -> CtLoc o -> Bool
345  
-   same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2
  387
+   same_loc l1 l2 = ctLocSpan l1 == ctLocSpan l2
  388
+
  389
+
  390
+tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] 
  391
+             -> Reporter -> Reporter
  392
+-- Use the first reporter in the list whose predicate says True
  393
+tryReporters reporters deflt ctxt cts
  394
+  = do { traceTc "tryReporters {" (ppr cts) 
  395
+       ; go reporters cts
  396
+       ; traceTc "tryReporters }" empty }
  397
+  where
  398
+    go [] cts = deflt ctxt cts 
  399
+    go ((str, pred, reporter) : rs) cts
  400
+      | null yeses  = traceTc "tryReporters: no" (text str) >> 
  401
+                      go rs cts
  402
+      | otherwise   = traceTc "tryReporters: yes" (text str <+> ppr yeses) >> 
  403
+                      reporter ctxt yeses
  404
+      where
  405
+       yeses = filter keep_me cts
  406
+       keep_me ct = pred ct (classifyPredType (ctPred ct))
346 407
 
347 408
 -- Add the "arising from..." part to a message about bunch of dicts
348 409
 addArising :: CtOrigin -> SDoc -> SDoc
@@ -447,6 +508,47 @@ mkIrredErr ctxt cts
447 508
     msg = couldNotDeduce givens (map ctPred cts, orig)
448 509
 \end{code}
449 510
 
  511
+\begin{code}
  512
+mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
  513
+mkHoleError ctxt ct@(CHoleCan {})
  514
+  = do { let env0 = cec_tidy ctxt
  515
+       ; let vars = tyVarsOfCt ct
  516
+
  517
+       ; zonked_vars <- zonkTyVarsAndFV vars
  518
+
  519
+       ; (env1, zonked_ty) <- zonkTidyTcType env0 (cc_hole_ty ct)
  520
+
  521
+       ; let (env2, tyvars) = tidyOpenTyVars env1 (varSetElems zonked_vars)
  522
+
  523
+       ; tyvars_msg <- mapM loc_msg tyvars
  524
+
  525
+       ; traceTc "mkHoleError" (ppr env2)
  526
+
  527
+       ; let msg = (text "Found hole" <+> quotes (text "_") <+> text "with type") <+> pprType zonked_ty
  528
+                   $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg)
  529
+
  530
+       ; mkErrorReport ctxt msg
  531
+       }
  532
+  where
  533
+    loc_msg tv = case tcTyVarDetails tv of
  534
+                    SkolemTv {} -> return $ (quotes $ ppr tv) <+> skol_msg
  535
+                    MetaTv {} -> do { tyvar <- readMetaTyVar tv
  536
+                                    ; return $ case tyvar of
  537
+                                        (Indirect ty) -> (quotes $ pprType ty) <+> skol_msg
  538
+                                        Flexi -> (quotes $ ppr tv) <+> text "is a free type variable"
  539
+                                    }
  540
+                    det -> return $ pprTcTyVarDetails det
  541
+                where skol_msg = ppr_skol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
  542
+
  543
+    ppr_skol given_loc tv_loc = case skol_info of
  544
+         UnkSkol -> ptext (sLit "is an unknown type variable")
  545
+         _ -> sep [ ptext (sLit "is a rigid type variable bound by"),
  546
+                    sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]]
  547
+     where
  548
+       skol_info = ctLocOrigin given_loc
  549
+
  550
+mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
  551
+\end{code}
450 552
 
451 553
 %************************************************************************
452 554
 %*									*
@@ -541,6 +643,12 @@ reportEqErr ctxt ct oriented ty1 ty2
541 643
 mkTyVarEqErr :: ReportErrCtxt -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg
542 644
 -- tv1 and ty2 are already tidied
543 645
 mkTyVarEqErr ctxt ct oriented tv1 ty2
  646
+  -- Occurs check
  647
+  | isNothing (occurCheckExpand tv1 ty2)
  648
+  = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
  649
+                           (sep [ppr ty1, char '~', ppr ty2])
  650
+    in mkErrorReport ctxt occCheckMsg
  651
+
544 652
   |  isSkolemTyVar tv1 	  -- ty2 won't be a meta-tyvar, or else the thing would
545 653
      		   	  -- be oriented the other way round; see TcCanonical.reOrient
546 654
   || isSigTyVar tv1 && not (isTyVarTy ty2)
@@ -552,12 +660,6 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2
552 660
   | not (k2 `tcIsSubKind` k1)   	 -- Kind error
553 661
   = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
554 662
 
555  
-  -- Occurs check
556  
-  | isNothing (occurCheckExpand tv1 ty2)
557  
-  = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
558  
-                           (sep [ppr ty1, char '=', ppr ty2])
559  
-    in mkErrorReport ctxt occCheckMsg
560  
-
561 663
   -- Check for skolem escape
562 664
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
563 665
   , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic)
@@ -565,8 +667,7 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2
565 667
   , not (null esc_skols)
566 668
   = setCtLoc implic_loc $	-- Override the error message location from the
567 669
     	     			-- place the equality arose to the implication site
568  
-    do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1)
569  
-       ; let msg = misMatchMsg oriented ty1 ty2
  670
+    do { let msg = misMatchMsg oriented ty1 ty2
570 671
              esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
571 672
                              <+> pprQuotedList esc_skols
572 673
                            , ptext (sLit "would escape") <+>
@@ -578,7 +679,7 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2
578 679
                                     else ptext (sLit "These (rigid, skolem) type variables are"))
579 680
                                    <+> ptext (sLit "bound by")
580 681
                                  , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
581  
-       ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
  682
+       ; mkErrorReport ctxt (msg $$ extra1) }
582 683
 
583 684
   -- Nastiest case: attempt to unify an untouchable variable
584 685
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
@@ -628,7 +729,7 @@ misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc
628 729
 misMatchOrCND ctxt ct oriented ty1 ty2
629 730
   | null givens || 
630 731
     (isRigid ty1 && isRigid ty2) || 
631  
-    isGiven (cc_ev ct)
  732
+    isGivenCt ct
632 733
        -- If the equality is unconditionally insoluble
633 734
        -- or there is no context, don't report the context
634 735
   = misMatchMsg oriented ty1 ty2
@@ -979,9 +1080,19 @@ mkAmbigMsg ctxt cts
979 1080
   = return (ctxt, False, empty)
980 1081
   | otherwise
981 1082
   = do { dflags <- getDynFlags
982  
-       ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set
983  
-       ; return (ctxt', True, mk_msg dflags gbl_docs) }
  1083
+       
  1084
+       ; prs <- mapSndM zonkTcType $ 
  1085
+                [ (id, idType id) | TcIdBndr id top_lvl <- ct1_bndrs
  1086
+                                  , isTopLevel top_lvl ]
  1087
+       ; let ambig_ids = [id | (id, zonked_ty) <- prs
  1088
+                             , tyVarsOfType zonked_ty `intersectsVarSet` ambig_tv_set]
  1089
+       ; return (ctxt, True, mk_msg dflags ambig_ids) }
984 1090
   where
  1091
+    ct1_bndrs = case cts of
  1092
+                  (ct1:_) -> ASSERT( not (isGivenCt ct1) )
  1093
+                             tcl_bndrs (ctLocEnv (ctWantedLoc ct1))
  1094
+                  [] -> panic "mkAmbigMsg"
  1095
+ 
985 1096
     ambig_tv_set = foldr (unionVarSet . filterVarSet isAmbiguousTyVar . tyVarsOfCt) 
986 1097
                          emptyVarSet cts
987 1098
     ambig_tvs = varSetElems ambig_tv_set
@@ -989,7 +1100,7 @@ mkAmbigMsg ctxt cts
989 1100
     is_or_are | isSingleton ambig_tvs = text "is"
990 1101
               | otherwise             = text "are"
991 1102
                  
992  
-    mk_msg dflags docs 
  1103
+    mk_msg dflags ambig_ids
993 1104
       | any isRuntimeUnkSkol ambig_tvs  -- See Note [Runtime skolems]
994 1105
       =  vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs
995 1106
                    <+> pprQuotedList ambig_tvs
@@ -998,17 +1109,17 @@ mkAmbigMsg ctxt cts
998 1109
       = vcat [ text "The type variable" <> plural ambig_tvs
999 1110
 	          <+> pprQuotedList ambig_tvs
1000 1111
                   <+> is_or_are <+> text "ambiguous"
1001  
-             , mk_extra_msg dflags docs ]
  1112
+             , mk_extra_msg dflags ambig_ids ]
1002 1113
   
1003  
-    mk_extra_msg dflags docs
1004  
-      | null docs
  1114
+    mk_extra_msg dflags ambig_ids
  1115
+      | null ambig_ids
1005 1116
       = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)")
1006 1117
 			-- This happens in things like
1007 1118
 			--	f x = show (read "foo")
1008 1119
 			-- where monomorphism doesn't play any role
1009 1120
       | otherwise 
1010  
-      = vcat [ ptext (sLit "Possible cause: the monomorphism restriction applied to the following:")
1011  
-	     , nest 2 (vcat docs)
  1121
+      = vcat [ hang (ptext (sLit "Possible cause: the monomorphism restriction applied to:"))
  1122
+	          2 (pprWithCommas (quotes . ppr) ambig_ids)
1012 1123
              , ptext (sLit "Probable fix:") <+> vcat
1013 1124
      	          [ ptext (sLit "give these definition(s) an explicit type signature")
1014 1125
      	          , if xopt Opt_MonomorphismRestriction dflags
@@ -1021,77 +1132,63 @@ getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc
1021 1132
 -- Get the skolem info for a type variable 
1022 1133
 -- from the implication constraint that binds it
1023 1134
 getSkolemInfo [] tv
1024  
-  = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
1025  
-    CtLoc UnkSkol noSrcSpan []
  1135
+  = pprPanic "No skolem info:" (ppr tv)
1026 1136
 
1027 1137
 getSkolemInfo (implic:implics) tv
1028 1138
   | tv `elem` ic_skols implic = ic_loc implic
1029 1139
   | otherwise                 = getSkolemInfo implics tv
1030 1140
 
1031 1141
 -----------------------
1032  
--- findGlobals looks at the value environment and finds values whose
  1142
+-- relevantBindings looks at the value environment and finds values whose
1033 1143
 -- types mention any of the offending type variables.  It has to be
1034 1144
 -- careful to zonk the Id's type first, so it has to be in the monad.
1035 1145
 -- We must be careful to pass it a zonked type variable, too.
1036 1146
 
1037  
-mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
1038  
-mkEnvSigMsg what env_sigs
1039  
- | null env_sigs = empty
1040  
- | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
1041  
-                    , nest 2 (vcat env_sigs) ]
1042  
-
1043  
-findGlobals :: ReportErrCtxt
1044  
-            -> TcTyVarSet
1045  
-            -> TcM (ReportErrCtxt, [SDoc])
1046  
-
1047  
-findGlobals ctxt tvs 
1048  
-  = do { lcl_ty_env <- case cec_encl ctxt of 
1049  
-                        []    -> getLclTypeEnv
1050  
-                        (i:_) -> return (ic_env i)
1051  
-       ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
  1147
+relevantBindings :: ReportErrCtxt
  1148
+                 -> Ct
  1149
+                 -> TcM ReportErrCtxt
  1150
+                 -- cec_extra includes info about relevant bindings
  1151
+relevantBindings ctxt ct
  1152
+  = do { (tidy_env', docs) <- go (cec_tidy ctxt) (6, emptyVarSet) 
  1153
+                                 (reverse (tcl_bndrs lcl_env))
  1154
+         -- The 'reverse' makes us work from outside in
  1155
+         -- Blargh; maybe have a flag for this "6"
  1156
+
  1157
+       ; traceTc "relevantBindings" (ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env])
  1158
+       ; let doc = hang (ptext (sLit "Relevant bindings include")) 
  1159
+                      2 (vcat docs)
  1160
+       ; if null docs 
  1161
+         then return ctxt
  1162
+         else return (ctxt { cec_tidy = tidy_env'  
  1163
+                           , cec_extra = doc $$ cec_extra ctxt }) }
1052 1164
   where
1053  
-    go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc)
1054  
-    go tidy_env acc (thing : things)
1055  
-       = do { (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
1056  
-	    ; case maybe_doc of
1057  
-	        Just d  -> go tidy_env1 (d:acc) things
1058  
-	        Nothing -> go tidy_env1 acc     things }
1059  
-
1060  
-    ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
  1165
+    lcl_env = ctEvEnv (cc_ev ct)
  1166
+    ct_tvs = tyVarsOfCt ct
  1167
+
  1168
+    go :: TidyEnv -> (Int, TcTyVarSet)
  1169
+       -> [TcIdBinder] -> TcM (TidyEnv, [SDoc])
  1170
+    go tidy_env (_,_) []
  1171
+       = return (tidy_env, [])
  1172
+    go tidy_env (n_left,tvs_seen) (TcIdBndr id _ : tc_bndrs)
  1173
+       | n_left <= 0, ct_tvs `subVarSet` tvs_seen
  1174
+       =   -- We have run out of n_left, and we
  1175
+           -- already have bindings mentioning all of ct_tvs
  1176
+         go tidy_env (n_left,tvs_seen) tc_bndrs
  1177
+       | otherwise
  1178
+       = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
  1179
+            ; let id_tvs = tyVarsOfType tidy_ty
  1180
+                  doc = sep [ ppr id <+> dcolon <+> ppr tidy_ty
  1181
+		            , nest 2 (parens (ptext (sLit "bound at")
  1182
+			    	 <+> ppr (getSrcLoc id)))]
  1183
+            ; if id_tvs `intersectsVarSet` ct_tvs 
  1184
+              && (n_left > 0 || not (id_tvs `subVarSet` tvs_seen))