Merge MatchFixity and HsMatchContextwip/T12105

Summary:
MatchFixity was introduced to facilitate use of API Annotations.

HsMatchContext does the same thing with more detail, but is chased
through all over the place to provide context when processing a Match.

Since we already have MatchFixity in the Match, it may as well provide
the full context.

updates submodule haddock

Test Plan: ./validate

Reviewers: austin, goldfire, bgamari

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2271

GHC Trac Issues: #12105

15 files changed, 106 insertions, 70 deletions

diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs
index 00dac01227..33eb83b401 100644
--- a/compiler/typecheck/TcAnnotations.hs
+++ b/compiler/typecheck/TcAnnotations.hs
@@ -6,6 +6,7 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcAnnotations ( tcAnnotations, annCtxt ) where
 
@@ -64,6 +65,6 @@ annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name
 annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod
 #endif
 
-annCtxt :: OutputableBndr id => AnnDecl id -> SDoc
+annCtxt :: (OutputableBndrId id) => AnnDecl id -> SDoc
 annCtxt ann
   = hang (text "In the annotation:") 2 (ppr ann)
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index 052c49cb19..f2424eacc6 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -241,7 +241,7 @@ tc_cmd env
                                    (match@(Match _ pats _maybe_rhs_sig grhss))],
                        mg_origin = origin }))
        (cmd_stk, res_ty)
-  = addErrCtxt (pprMatchInCtxt match_ctxt match)        $
+  = addErrCtxt (pprMatchInCtxt match)        $
     do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
 
                 -- Check the patterns, and the GRHSs inside
@@ -249,7 +249,7 @@ tc_cmd env
                              tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $
                              tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
 
-        ; let match' = L mtch_loc (Match NonFunBindMatch pats' Nothing grhss')
+        ; let match' = L mtch_loc (Match LambdaExpr pats' Nothing grhss')
               arg_tys = map hsLPatType pats'
               cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys
                                   , mg_res_ty = res_ty, mg_origin = origin })
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index fc04ec9999..b34ad0bcad 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -6,6 +6,7 @@
 -}
 
 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
                  tcValBinds, tcHsBootSigs, tcPolyCheck,
@@ -1462,7 +1463,7 @@ tcMonoBinds is_rec sig_fn no_gen
                   -- We extend the error context even for a non-recursive
                   -- function so that in type error messages we show the
                   -- type of the thing whose rhs we are type checking
-               tcMatchesFun name matches rhs_ty
+               tcMatchesFun (L nm_loc name) matches rhs_ty
         ; rhs_ty  <- readExpType rhs_ty
 
         -- Deeply instantiate the inferred type
@@ -1593,7 +1594,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
   = tcExtendIdBinderStackForRhs [info]  $
     tcExtendTyVarEnvForRhs mb_sig       $
     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
-        ; (co_fn, matches') <- tcMatchesFun (idName mono_id)
+        ; (co_fn, matches') <- tcMatchesFun (noLoc $ idName mono_id)
                                  matches (mkCheckExpType $ idType mono_id)
         ; emitWildCardHoles info
         ; return ( FunBind { fun_id = L loc mono_id
@@ -2114,7 +2115,8 @@ the common case.) -}
 
 -- This one is called on LHS, when pat and grhss are both Name
 -- and on RHS, when pat is TcId and grhss is still Name
-patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
+patMonoBindsCtxt :: (OutputableBndrId id, Outputable body)
+                 => LPat id -> GRHSs Name body -> SDoc
 patMonoBindsCtxt pat grhss
   = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
 
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 006a2f9739..42a03142c1 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -1,7 +1,10 @@
 -- (c) The University of Glasgow 2006
 {-# LANGUAGE CPP, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an
                                        -- orphan
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
 
 module TcEnv(
         TyThing(..), TcTyThing(..), TcId,
@@ -823,10 +826,10 @@ data InstBindings a
            --          Used only to improve error messages
       }
 
-instance OutputableBndr a => Outputable (InstInfo a) where
+instance (OutputableBndrId a) => Outputable (InstInfo a) where
     ppr = pprInstInfoDetails
 
-pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
+pprInstInfoDetails :: (OutputableBndrId a) => InstInfo a -> SDoc
 pprInstInfoDetails info
    = hang (pprInstanceHdr (iSpec info) <+> text "where")
         2 (details (iBinds info))
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index d4a9f38179..5089cab80a 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -7,6 +7,7 @@
 -}
 
 {-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
                 tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
@@ -237,7 +238,7 @@ tcExpr (HsLam match) res_ty
     match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
     herald = sep [ text "The lambda expression" <+>
                    quotes (pprSetDepth (PartWay 1) $
-                           pprMatches (LambdaExpr :: HsMatchContext Name) match),
+                           pprMatches match),
                         -- The pprSetDepth makes the abstraction print briefly
                    text "has"]
 
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 4157b02b72..e01586c300 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -407,13 +407,14 @@ gen_Ord_binds loc tycon
       | otherwise                -- Mixed nullary and non-nullary
       = nlHsCase (nlHsVar a_RDR) $
         (map (mkOrdOpAlt op) non_nullary_cons
-         ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
+         ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])
 
 
     mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
     -- Make the alternative  (Ki a1 a2 .. av ->
     mkOrdOpAlt op data_con
-      = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
+      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
+                    (mkInnerRhs op data_con)
       where
         as_needed    = take (dataConSourceArity data_con) as_RDRs
         data_con_RDR = getRdrName data_con
@@ -424,33 +425,35 @@ gen_Ord_binds loc tycon
 
       | tag == first_tag
       = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
       | tag == last_tag
       = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
 
       | tag == first_tag + 1
-      = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
+                                             (gtResult op)
                                  , mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
       | tag == last_tag - 1
-      = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
+                                             (ltResult op)
                                  , mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
 
       | tag > last_tag `div` 2  -- lower range is larger
       = untag_Expr tycon [(b_RDR, bh_RDR)] $
         nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
                (gtResult op) $  -- Definitely GT
         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
 
       | otherwise               -- upper range is larger
       = untag_Expr tycon [(b_RDR, bh_RDR)] $
         nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
                (ltResult op) $  -- Definitely LT
         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
       where
         tag     = get_tag data_con
         tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
@@ -459,7 +462,7 @@ gen_Ord_binds loc tycon
     -- First argument 'a' known to be built with K
     -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
     mkInnerEqAlt op data_con
-      = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
+      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
         mkCompareFields tycon op (dataConOrigArgTys data_con)
       where
         data_con_RDR = getRdrName data_con
@@ -495,9 +498,9 @@ mkCompareFields tycon op tys
       = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
       | otherwise
       = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
-          [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
-           mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
-           mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
+          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
+           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
+           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
       where
         a_expr = nlHsVar a
         b_expr = nlHsVar b
@@ -782,7 +785,7 @@ gen_Ix_binds loc tycon
            in
            nlHsCase
              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
-             [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
+             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
            ))
         )
 
@@ -1345,7 +1348,7 @@ gen_Data_binds dflags loc rep_tc
         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
                                 (map gunfold_alt data_cons)
 
-    gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
+    gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
     mk_unfold_rhs dc = foldr nlHsApp
                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
@@ -1552,13 +1555,15 @@ gen_Functor_binds loc tycon
   = (unitBag fmap_bind, emptyBag)
   where
     data_cons = tyConDataCons tycon
-    fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns
+    fun_name = L loc fmap_RDR
+    fmap_bind = mkRdrFunBind fun_name eqns
 
     fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
       where
         parts = sequence $ foldDataConArgs ft_fmap con
 
-    eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
+    eqns | null data_cons = [mkSimpleMatch (FunRhs fun_name Prefix)
+                                           [nlWildPat, nlWildPat]
                                            (error_Expr "Void fmap")]
          | otherwise      = map fmap_eqn data_cons
 
@@ -1586,7 +1591,7 @@ gen_Functor_binds loc tycon
     -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
     match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
                   -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
-    match_for_con = mkSimpleConMatch $
+    match_for_con = mkSimpleConMatch CaseAlt $
         \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
 
 {-
@@ -1719,17 +1724,19 @@ mkSimpleLam2 lam = do
 -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
 -- and its arguments, applying an expression (from @insides@) to each of the
 -- respective arguments of @con@.
-mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
+mkSimpleConMatch :: Monad m => HsMatchContext RdrName
+                 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
                  -> [LPat RdrName]
                  -> DataCon
                  -> [LHsExpr RdrName]
                  -> m (LMatch RdrName (LHsExpr RdrName))
-mkSimpleConMatch fold extra_pats con insides = do
+mkSimpleConMatch ctxt fold extra_pats con insides = do
     let con_name = getRdrName con
     let vars_needed = takeList insides as_RDRs
     let pat = nlConVarPat con_name vars_needed
     rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
-    return $ mkMatch (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds)
+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
+                     (noLoc emptyLocalBinds)
 
 -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
 --
@@ -1749,13 +1756,14 @@ mkSimpleConMatch fold extra_pats con insides = do
 --
 -- See Note [Generated code for DeriveFoldable and DeriveTraversable]
 mkSimpleConMatch2 :: Monad m
-                  => (LHsExpr RdrName -> [LHsExpr RdrName]
+                  => HsMatchContext RdrName
+                  -> (LHsExpr RdrName -> [LHsExpr RdrName]
                                       -> m (LHsExpr RdrName))
                   -> [LPat RdrName]
                   -> DataCon
                   -> [Maybe (LHsExpr RdrName)]
                   -> m (LMatch RdrName (LHsExpr RdrName))
-mkSimpleConMatch2 fold extra_pats con insides = do
+mkSimpleConMatch2 ctxt fold extra_pats con insides = do
     let con_name = getRdrName con
         vars_needed = takeList insides as_RDRs
         pat = nlConVarPat con_name vars_needed
@@ -1780,7 +1788,8 @@ mkSimpleConMatch2 fold extra_pats con insides = do
               in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
 
     rhs <- fold con_expr exps
-    return $ mkMatch (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds)
+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
+                     (noLoc emptyLocalBinds)
 
 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
@@ -1907,7 +1916,7 @@ gen_Foldable_binds loc tycon
                 -> DataCon
                 -> [Maybe (LHsExpr RdrName)]
                 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
-    match_foldr z = mkSimpleConMatch2 $ \_ xs -> return (mkFoldr xs)
+    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
       where
         -- g1 v1 (g2 v2 (.. z))
         mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName
@@ -1936,7 +1945,7 @@ gen_Foldable_binds loc tycon
                   -> DataCon
                   -> [Maybe (LHsExpr RdrName)]
                   -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
-    match_foldMap = mkSimpleConMatch2 $ \_ xs -> return (mkFoldMap xs)
+    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
       where
         -- mappend v1 (mappend v2 ..)
         mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName
@@ -2023,7 +2032,8 @@ gen_Traversable_binds loc tycon
                   -> DataCon
                   -> [Maybe (LHsExpr RdrName)]
                   -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
-    match_for_con = mkSimpleConMatch2 $ \con xs -> return (mkApCon con xs)
+    match_for_con = mkSimpleConMatch2 CaseAlt $
+                                             \con xs -> return (mkApCon con xs)
       where
         -- fmap (\b1 b2 ... -> Con b1 b2 ...) x1 <*> x2 <*> ..
         mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
@@ -2066,8 +2076,9 @@ makeG_d.
 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Lift_binds loc tycon
   | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
-                       [mkMatch [nlWildPat] errorMsg_Expr
-                                            (noLoc emptyLocalBinds)])
+                       [mkMatch (FunRhs (L loc lift_RDR) Prefix)
+                                        [nlWildPat] errorMsg_Expr
+                                        (noLoc emptyLocalBinds)])
                      , emptyBag)
   | otherwise = (unitBag lift_bind, emptyBag)
   where
@@ -2176,7 +2187,9 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
 
     mk_bind :: Id -> LHsBind RdrName
     mk_bind meth_id
-      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
+      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
+                                         (FunRhs (L loc meth_RDR) Prefix)
+                                         [] rhs_expr]
       where
         Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty meth_id
 
@@ -2351,7 +2364,9 @@ mk_HRFunBind :: Arity -> SrcSpan -> RdrName
 mk_HRFunBind arity loc fun pats_and_exprs
   = mkHRRdrFunBind arity (L loc fun) matches
   where
-    matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs]
+    matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
+                               (noLoc emptyLocalBinds)
+              | (p,e) <-pats_and_exprs]
 
 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
 mkRdrFunBind = mkHRRdrFunBind 0
@@ -2365,7 +2380,8 @@ mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches'
    -- which can happen with -XEmptyDataDecls
    -- See Trac #4302
    matches' = if null matches
-              then [mkMatch (replicate arity nlWildPat)
+              then [mkMatch (FunRhs fun Prefix)
+                            (replicate arity nlWildPat)
                             (error_Expr str) (noLoc emptyLocalBinds)]
               else matches
    str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
@@ -2481,7 +2497,7 @@ untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrN
 untag_Expr _ [] expr = expr
 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
-      [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
+      [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
 
 enum_from_to_Expr
         :: LHsExpr RdrName -> LHsExpr RdrName
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 931508bfb5..4443ed729c 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -323,8 +323,8 @@ mkBindsRep gk tycon =
   `unionBags`
     unitBag (mkRdrFunBind (L loc to01_RDR) to_matches)
       where
-        from_matches  = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
-        to_matches    = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts  ]
+        from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
+        to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]
         loc           = srcLocSpan (getSrcLoc tycon)
         datacons      = tyConDataCons tycon
 
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index db7a5f998d..2e6ab35c8e 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -14,7 +14,7 @@ checker.
 module TcHsSyn (
         mkHsConApp, mkHsDictLet, mkHsApp,
         hsLitType, hsLPatType, hsPatType,
-        mkHsAppTy, mkSimpleHsAlt,
+        mkHsAppTy, mkHsCaseAlt,
         nlHsIntLit,
         shortCutLit, hsOverLitName,
         conLikeResTy,
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 59ddaee302..ffe2d2dd01 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -1557,8 +1557,9 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name
                    (vcat [ppr clas <+> ppr inst_tys,
                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 
-        ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id))
-                                       [mkSimpleMatch [] rhs]) }
+        ; let fn = noLoc (idName sel_id)
+        ; return (noLoc $ mkTopFunBind Generated fn
+                                    [mkSimpleMatch (FunRhs fn Prefix) [] rhs]) }
   where
     rhs = nlHsVar dm_name
 
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index 05b836cccb..d4867f54da 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -10,6 +10,7 @@ TcMatches: Typecheck some @Matches@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
                    TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
@@ -68,12 +69,12 @@ so it must be prepared to use tcSkolemise to skolemise it.
 See Note [sig_tau may be polymorphic] in TcPat.
 -}
 
-tcMatchesFun :: Name
+tcMatchesFun :: Located Name
              -> MatchGroup Name (LHsExpr Name)
              -> ExpRhoType     -- Expected type of function
              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
                                 -- Returns type of body
-tcMatchesFun fun_name matches exp_ty
+tcMatchesFun fn@(L _ fun_name) matches exp_ty
   = do  {  -- Check that they all have the same no of arguments
            -- Location is in the monad, set the caller so that
            -- any inter-equation error messages get some vaguely
@@ -97,7 +98,7 @@ tcMatchesFun fun_name matches exp_ty
     arity = matchGroupArity matches
     herald = text "The equation(s) for"
              <+> quotes (ppr fun_name) <+> text "have"
-    match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody }
+    match_ctxt = MC { mc_what = FunRhs fn Prefix, mc_body = tcBody }
 
 {-
 @tcMatchesCase@ doesn't do the argument-count check because the
@@ -228,7 +229,7 @@ tcMatch ctxt pat_tys rhs_ty match
       = add_match_ctxt match $
         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
                                 tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
-           ; return (Match NonFunBindMatch pats' Nothing grhss') }
+           ; return (Match (mc_what ctxt) pats' Nothing grhss') }
 
     tc_grhss ctxt Nothing grhss rhs_ty
       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
@@ -242,7 +243,7 @@ tcMatch ctxt pat_tys rhs_ty match
     add_match_ctxt match thing_inside
         = case mc_what ctxt of
             LambdaExpr -> thing_inside
-            m_ctxt     -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
+            _          -> addErrCtxt (pprMatchInCtxt match) thing_inside
 
 -------------
 tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> ExpRhoType
diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot
index a45cbbed91..3e8dc0277b 100644
--- a/compiler/typecheck/TcMatches.hs-boot
+++ b/compiler/typecheck/TcMatches.hs-boot
@@ -4,13 +4,13 @@ import TcEvidence( HsWrapper )
 import Name     ( Name )
 import TcType   ( ExpRhoType, TcRhoType )
 import TcRnTypes( TcM, TcId )
---import SrcLoc   ( Located )
+import SrcLoc   ( Located )
 
 tcGRHSsPat    :: GRHSs Name (LHsExpr Name)
               -> TcRhoType
               -> TcM (GRHSs TcId (LHsExpr TcId))
 
-tcMatchesFun :: Name
+tcMatchesFun :: Located Name
              -> MatchGroup Name (LHsExpr Name)
              -> ExpRhoType
              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 9091840554..35624e7d32 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -7,6 +7,7 @@ TcPat: Typechecking patterns
 -}
 
 {-# LANGUAGE CPP, RankNTypes, TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcPat ( tcLetPat
              , TcPragEnv, lookupPragEnv, emptyPragEnv
@@ -1235,7 +1236,7 @@ polyPatSig sig_ty
   = hang (text "Illegal polymorphic type signature in pattern:")
        2 (ppr sig_ty)
 
-lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM ()
+lazyUnliftedPatErr :: (OutputableBndrId name) => Pat name -> TcM ()
 lazyUnliftedPatErr pat
   = failWithTc $
     hang (text "A lazy (~) pattern cannot contain unlifted types:")
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 6418a2184a..c73da99dce 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -6,6 +6,7 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcPatSyn ( tcPatSynSig, tcInferPatSynDecl, tcCheckPatSynDecl
                 , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
@@ -570,9 +571,9 @@ tcPatSynMatcher (L loc name) lpat
              args = map nlVarPat [scrutinee, cont, fail]
              lwpat = noLoc $ WildPat pat_ty
              cases = if isIrrefutableHsPat lpat
-                     then [mkSimpleHsAlt lpat  cont']
-                     else [mkSimpleHsAlt lpat  cont',
-                           mkSimpleHsAlt lwpat fail']
+                     then [mkHsCaseAlt lpat  cont']
+                     else [mkHsCaseAlt lpat  cont',
+                           mkHsCaseAlt lwpat fail']
              body = mkLHsWrap (mkWpLet req_ev_binds) $
                     L (getLoc lpat) $
                     HsCase (nlHsVar scrutinee) $
@@ -583,12 +584,15 @@ tcPatSynMatcher (L loc name) lpat
                       }
              body' = noLoc $
                      HsLam $
-                     MG{ mg_alts = noLoc [mkSimpleMatch args body]
+                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
+                                                        args body]
                        , mg_arg_tys = [pat_ty, cont_ty, res_ty]
                        , mg_res_ty = res_ty
                        , mg_origin = Generated
                        }
-             match = mkMatch [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body')
+             match = mkMatch (FunRhs (L loc name) Prefix) []
+                             (mkHsLams (rr_tv:res_tv:univ_tvs)
+                             req_dicts body')
                              (noLoc EmptyLocalBinds)
              mg = MG{ mg_alts = L (getLoc match) [match]
                     , mg_arg_tys = []
@@ -705,7 +709,9 @@ tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat
     mk_mg body = mkMatchGroupName Generated [builder_match]
              where
                builder_args  = [L loc (VarPat (L loc n)) | L loc n <- args]
-               builder_match = mkMatch builder_args body (noLoc EmptyLocalBinds)
+               builder_match = mkMatch (FunRhs (L loc name) Prefix)
+                                       builder_args body
+                                       (noLoc EmptyLocalBinds)
 
     args = case details of
               PrefixPatSyn args     -> args
@@ -717,7 +723,7 @@ tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat
     add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] })
       = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
     add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
-                             pprMatches (PatSyn :: HsMatchContext Name) other_mg
+                             pprMatches other_mg
 
 get_builder_sig :: TcSigFun -> Name -> Id -> Bool -> TcM TcIdSigInfo
 get_builder_sig sig_fun name builder_id need_dummy_arg
@@ -940,19 +946,19 @@ tcCheckPatSynPat = go
     go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
     go1   CoPat{}             = panic "CoPat in output of renamer"
 
-asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
+asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
 asPatInPatSynErr pat
   = failWithTc $
     hang (text "Pattern synonym definition cannot contain as-patterns (@):")
        2 (ppr pat)
 
-thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
+thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
 thInPatSynErr pat
   = failWithTc $
     hang (text "Pattern synonym definition cannot contain Template Haskell:")
        2 (ppr pat)
 
-nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
+nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
 nPlusKPatInPatSynErr pat
   = failWithTc $
     hang (text "Pattern synonym definition cannot contain n+k-pattern:")
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 321081a7ce..cb7bb69f16 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1790,7 +1790,8 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
         ; uniq <- newUnique
         ; interPrintName <- getInteractivePrintName
         ; let fresh_it  = itName uniq loc
-              matches   = [mkMatch [] rn_expr (noLoc emptyLocalBinds)]
+              matches   = [mkMatch (FunRhs (L loc fresh_it) Prefix) [] rn_expr
+                                   (noLoc emptyLocalBinds)]
               -- [it = expr]
               the_bind  = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }
                           -- Care here!  In GHCi the expression might have
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 8c91b4897d..7529f15001 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -974,9 +974,11 @@ mkOneRecordSelector all_cons idDetails fl
     --    where cons_w_field = [C2,C7]
     sel_bind = mkTopFunBind Generated sel_lname alts
       where
-        alts | is_naughty = [mkSimpleMatch [] unit_rhs]
+        alts | is_naughty = [mkSimpleMatch (FunRhs sel_lname Prefix)
+                                           [] unit_rhs]
              | otherwise =  map mk_match cons_w_field ++ deflt
-    mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
+    mk_match con = mkSimpleMatch (FunRhs sel_lname Prefix)
+                                 [L loc (mk_sel_pat con)]
                                  (L loc (HsVar (L loc field_var)))
     mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
@@ -992,7 +994,8 @@ mkOneRecordSelector all_cons idDetails fl
     -- We do this explicitly so that we get a nice error message that
     -- mentions this particular record selector
     deflt | all dealt_with all_cons = []
-          | otherwise = [mkSimpleMatch [L loc (WildPat placeHolderType)]
+          | otherwise = [mkSimpleMatch CaseAlt
+                            [L loc (WildPat placeHolderType)]
                             (mkHsApp (L loc (HsVar
                                             (L loc (getName rEC_SEL_ERROR_ID))))
                                      (L loc (HsLit msg_lit)))]