Fix #13594wip/T13594

19 files changed, 74 insertions, 56 deletions

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index c08353a15b..e4d1d5cd68 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -1736,9 +1736,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
 
     (ppr_match, pref)
         = case kind of
-             FunRhs (L _ fun) _ -> (pprMatchContext kind,
-                                    \ pp -> ppr fun <+> pp)
-             _                  -> (pprMatchContext kind, \ pp -> pp)
+             FunRhs (L _ fun) _ _ -> (pprMatchContext kind,
+                                      \ pp -> ppr fun <+> pp)
+             _                    -> (pprMatchContext kind, \ pp -> pp)
 
 ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
 ppr_pats kind pats
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 1ff04b2548..79212fb655 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -142,7 +142,7 @@ dsHsBind dflags
          (FunBind { fun_id = L _ fun, fun_matches = matches
                   , fun_co_fn = co_fn, fun_tick = tick })
  = do   { (args, body) <- matchWrapper
-                           (FunRhs (noLoc $ idName fun) Prefix)
+                           (FunRhs (noLoc $ idName fun) Prefix NoSrcStrict)
                            Nothing matches
         ; core_wrap <- dsHsWrapper co_fn
         ; let body' = mkOptTickBox tick body
@@ -333,7 +333,7 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
     addDictsDs (toTcTypeBag (listToBag dicts)) $
              -- addDictsDs: push type constraints deeper for pattern match check
     do { (args, body) <- matchWrapper
-                           (FunRhs (noLoc $ idName global) Prefix)
+                           (FunRhs (noLoc $ idName global) Prefix NoSrcStrict)
                            Nothing matches
        ; core_wrap <- dsHsWrapper co_fn
        ; let body'   = mkOptTickBox tick body
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 39f76ea2c0..e2feac34b5 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -200,7 +200,7 @@ dsUnliftedBind (FunBind { fun_id = L l fun
                         , fun_tick = tick }) body
                -- Can't be a bang pattern (that looks like a PatBind)
                -- so must be simply unboxed
-  = do { (args, rhs) <- matchWrapper (FunRhs (L l $ idName fun) Prefix)
+  = do { (args, rhs) <- matchWrapper (FunRhs (L l $ idName fun) Prefix NoSrcStrict)
                                      Nothing matches
        ; MASSERT( null args ) -- Functions aren't lifted
        ; MASSERT( isIdHsWrapper co_fn )
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 8d90344f2f..15ddddc409 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -140,7 +140,7 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
 cvtDec (TH.ValD pat body ds)
   | TH.VarP s <- pat
   = do  { s' <- vNameL s
-        ; cl' <- cvtClause (FunRhs s' Prefix) (Clause [] body ds)
+        ; cl' <- cvtClause (FunRhs s' Prefix NoSrcStrict) (Clause [] body ds)
         ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
 
   | otherwise
@@ -159,7 +159,7 @@ cvtDec (TH.FunD nm cls)
                  <+> text "has no equations")
   | otherwise
   = do  { nm' <- vNameL nm
-        ; cls' <- mapM (cvtClause (FunRhs nm' Prefix)) cls
+        ; cls' <- mapM (cvtClause (FunRhs nm' Prefix NoSrcStrict)) cls
         ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
 
 cvtDec (TH.SigD nm typ)
@@ -375,7 +375,7 @@ cvtDec (TH.PatSynD nm args dir pat)
     cvtDir _ Unidir          = return Unidirectional
     cvtDir _ ImplBidir       = return ImplicitBidirectional
     cvtDir n (ExplBidir cls) =
-      do { ms <- mapM (cvtClause (FunRhs n Prefix)) cls
+      do { ms <- mapM (cvtClause (FunRhs n Prefix NoSrcStrict)) cls
          ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
 
 cvtDec (TH.PatSynSigD nm ty)
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index b39e25a2c7..74fc94965b 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -138,6 +138,7 @@ data HsBindLR idL idR
     --
     -- FunBind is used for both functions     @f x = e@
     -- and variables                          @f = \x -> e@
+    -- and strict variables                   @!x = x + 1@
     --
     -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
     --
@@ -148,6 +149,9 @@ data HsBindLR idL idR
     -- parses as a pattern binding, just like
     --                                        @(f :: a -> a) = ... @
     --
+    -- Strict binders have their strictness recorded in the 'SrcStrictness' of their
+    -- 'MatchContext'.
+    --
     --  'ApiAnnotation.AnnKeywordId's
     --
     --  - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index f3cc3d0861..1961fd448c 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1451,8 +1451,8 @@ Example infix function definition requiring individual API Annotations
 
 isInfixMatch :: Match id body -> Bool
 isInfixMatch match = case m_ctxt match of
-  FunRhs _ Infix -> True
-  _              -> False
+  FunRhs _ Infix _ -> True
+  _                -> False
 
 isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
@@ -1531,7 +1531,7 @@ pprMatch match
     ctxt = m_ctxt match
     (herald, other_pats)
         = case ctxt of
-            FunRhs (L _ fun) fixity
+            FunRhs (L _ fun) fixity _
                 | fixity == Prefix -> (pprPrefixOcc fun, m_pats match)
                         -- f x y z = e
                         -- Not pprBndr; the AbsBinds will
@@ -2332,7 +2332,9 @@ pp_dotdot = text " .. "
 --
 -- Context of a Match
 data HsMatchContext id
-  = FunRhs (Located id) LexicalFixity -- ^Function binding for f, fixity
+  = FunRhs (Located id) LexicalFixity SrcStrictness
+                                -- ^Function binding for f, fixity, and whether
+                                -- the pattern was banged
   | LambdaExpr                  -- ^Patterns of a lambda
   | CaseAlt                     -- ^Patterns and guards on a case alternative
   | IfAlt                       -- ^Guards of a multi-way if alternative
@@ -2353,7 +2355,7 @@ data HsMatchContext id
 deriving instance (DataIdPost id) => Data (HsMatchContext id)
 
 instance OutputableBndr id => Outputable (HsMatchContext id) where
-  ppr (FunRhs (L _ id) fix) = text "FunRhs" <+> ppr id <+> ppr fix
+  ppr (FunRhs (L _ id) fix str) = text "FunRhs" <+> ppr id <+> ppr fix <+> ppr str
   ppr LambdaExpr            = text "LambdaExpr"
   ppr CaseAlt               = text "CaseAlt"
   ppr IfAlt                 = text "IfAlt"
@@ -2438,7 +2440,7 @@ pprMatchContext ctxt
 
 pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)
                     => HsMatchContext id -> SDoc
-pprMatchContextNoun (FunRhs (L _ fun) _) = text "equation for"
+pprMatchContextNoun (FunRhs (L _ fun) _ _) = text "equation for"
                                       <+> quotes (ppr fun)
 pprMatchContextNoun CaseAlt         = text "case alternative"
 pprMatchContextNoun IfAlt           = text "multi-way if alternative"
@@ -2498,7 +2500,7 @@ instance (Outputable id, Outputable (NameOrRdrName id))
 -- Used to generate the string for a *runtime* error message
 matchContextErrString :: Outputable id
                       => HsMatchContext id -> SDoc
-matchContextErrString (FunRhs (L _ fun) _) = text "function" <+> ppr fun
+matchContextErrString (FunRhs (L _ fun) _ _) = text "function" <+> ppr fun
 matchContextErrString CaseAlt              = text "case"
 matchContextErrString IfAlt                = text "multi-way if"
 matchContextErrString PatBindRhs           = text "pattern binding"
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index c7d43b02a1..16a55a97fa 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -745,7 +745,7 @@ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
                 -> LHsExpr RdrName -> LHsBind RdrName
 mk_easy_FunBind loc fun pats expr
   = L loc $ mkFunBind (L loc fun)
-              [mkMatch (FunRhs (L loc fun) Prefix) pats expr
+              [mkMatch (FunRhs (L loc fun) Prefix NoSrcStrict) pats expr
                        (noLoc emptyLocalBinds)]
 
 ------------
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 21f564e2b9..0d2e90763f 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2181,19 +2181,21 @@ docdecld :: { LDocDecl }
 decl_no_th :: { LHsDecl RdrName }
         : sigdecl               { $1 }
 
-        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) };
-                                        pat <- checkPattern empty e;
-                                        _ <- ams (sLL $1 $> ())
-                                               (fst $ unLoc $3);
-                                        return $ sLL $1 $> $ ValD $
-                                            PatBind pat (snd $ unLoc $3)
-                                                    placeHolderType
-                                                    placeHolderNames
-                                                    ([],[]) } }
+        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)
+                                            ; l = comb2 $1 $> };
+                                        (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
+                                        case r of {
+                                          (FunBind n _ _ _ _) ->
+                                                ams (L l ()) [mj AnnFunId n] >> return () ;
+                                          (PatBind (L lh _lhs) _rhs _ _ _) ->
+                                                ams (L lh ()) [] >> return () } ;
+
+                                        _ <- ams (L l ()) (ann ++ fst (unLoc $3)) ;
+                                        return $! (sL l $ ValD r) } }
                                 -- Turn it all into an expression so that
                                 -- checkPattern can check that bangs are enabled
 
-        | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
+        | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
                                         case r of {
                                           (FunBind n _ _ _ _) ->
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 5b1006ac79..db11287b26 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -514,9 +514,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
                wrongNameBindingErr loc decl
            ; match <- case details of
                PrefixCon pats ->
-                        return $ Match (FunRhs ln Prefix) pats Nothing rhs
+                        return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs
                InfixCon pat1 pat2 ->
-                       return $ Match (FunRhs ln Infix) [pat1, pat2] Nothing rhs
+                       return $ Match (FunRhs ln Infix NoSrcStrict) [pat1, pat2] Nothing rhs
                RecCon{} -> recordPatSynErr loc pat
            ; return $ L loc match }
     fromDecl (L loc decl) = extraDeclErr loc decl
@@ -923,25 +923,27 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
 -- Check Equation Syntax
 
 checkValDef :: SDoc
+            -> SrcStrictness
             -> LHsExpr RdrName
             -> Maybe (LHsType RdrName)
             -> Located (a,GRHSs RdrName (LHsExpr RdrName))
             -> P ([AddAnn],HsBind RdrName)
 
-checkValDef msg lhs (Just sig) grhss
+checkValDef msg _strictness lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
   = checkPatBind msg (L (combineLocs lhs sig)
                         (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
 
-checkValDef msg lhs opt_sig g@(L l (_,grhss))
+checkValDef msg strictness lhs opt_sig g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats, ann) ->
-              checkFunBind msg ann (getLoc lhs)
+              checkFunBind msg strictness ann (getLoc lhs)
                            fun is_infix pats opt_sig (L l grhss)
             Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
+             -> SrcStrictness
              -> [AddAnn]
              -> SrcSpan
              -> Located RdrName
@@ -950,13 +952,13 @@ checkFunBind :: SDoc
              -> Maybe (LHsType RdrName)
              -> Located (GRHSs RdrName (LHsExpr RdrName))
              -> P ([AddAnn],HsBind RdrName)
-checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
   = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
         -- mapM_ (\a -> a match_span) ann
         return (ann, makeFunBind fun
-                  [L match_span (Match { m_ctxt = FunRhs fun is_infix
+                  [L match_span (Match { m_ctxt = FunRhs fun is_infix strictness
                                        , m_pats = ps
                                        , m_type = opt_sig
                                        , m_grhss = grhss })])
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 9abeee207e..63718ec146 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -482,7 +482,7 @@ rnBind sig_fn bind@(FunBind { fun_id = name
 
         ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
                                 -- bindSigTyVars tests for LangExt.ScopedTyVars
-                                 rnMatchGroup (FunRhs name Prefix)
+                                 rnMatchGroup (FunRhs name Prefix NoSrcStrict)
                                               rnLExpr matches
         ; let is_infix = isInfixFunBind bind
         ; when is_infix $ checkPrecMatch plain_name matches'
@@ -667,7 +667,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
             ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
             ExplicitBidirectional mg ->
                 do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $
-                                   rnMatchGroup (FunRhs (L l name) Prefix)
+                                   rnMatchGroup (FunRhs (L l name) Prefix NoSrcStrict)
                                                 rnLExpr mg
                    ; return (ExplicitBidirectional mg', fvs) }
 
@@ -1148,8 +1148,8 @@ rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
         ; rnPats ctxt pats      $ \ pats' -> do
         { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
         ; let mf' = case (ctxt,mf) of
-                      (FunRhs (L _ funid) _,FunRhs (L lf _) _)
-                                            -> FunRhs (L lf funid) fixity
+                      (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ _)
+                                            -> FunRhs (L lf funid) fixity NoSrcStrict -- TODO: Is this right?
                       _                     -> ctxt
         ; return (Match { m_ctxt = mf', m_pats = pats'
                         , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 96513da376..271bb4771b 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1509,7 +1509,7 @@ 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 (FunRhs (L loc lift_RDR) Prefix)
+                       [mkMatch (FunRhs (L loc lift_RDR) Prefix NoSrcStrict)
                                         [nlWildPat] errorMsg_Expr
                                         (noLoc emptyLocalBinds)])
                      , emptyBag)
@@ -1654,7 +1654,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
     mk_bind :: Id -> LHsBind RdrName
     mk_bind meth_id
       = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
-                                          (FunRhs (L loc meth_RDR) Prefix)
+                                          (FunRhs (L loc meth_RDR) Prefix NoSrcStrict)
                                           [] rhs_expr]
       where
         Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
@@ -1843,7 +1843,7 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
 mkFunBindSE arity loc fun pats_and_exprs
   = mkRdrFunBindSE arity (L loc fun) matches
   where
-    matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
+    matches = [mkMatch (FunRhs (L loc fun) Prefix NoSrcStrict) p e
                                (noLoc emptyLocalBinds)
               | (p,e) <-pats_and_exprs]
 
@@ -1873,7 +1873,7 @@ mkRdrFunBindEC arity catch_all
    -- which can happen with -XEmptyDataDecls
    -- See Trac #4302
    matches' = if null matches
-              then [mkMatch (FunRhs fun Prefix)
+              then [mkMatch (FunRhs fun Prefix NoSrcStrict)
                             (replicate (arity - 1) nlWildPat ++ [z_Pat])
                             (catch_all $ nlHsCase z_Expr [])
                             (noLoc emptyLocalBinds)]
@@ -1893,7 +1893,7 @@ mkRdrFunBindSE arity
    -- which can happen with -XEmptyDataDecls
    -- See Trac #4302
    matches' = if null matches
-              then [mkMatch (FunRhs fun Prefix)
+              then [mkMatch (FunRhs fun Prefix NoSrcStrict)
                             (replicate arity nlWildPat)
                             (error_Expr str) (noLoc emptyLocalBinds)]
               else matches
diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs
index 1b0f90b268..2430a55b8a 100644
--- a/compiler/typecheck/TcGenFunctor.hs
+++ b/compiler/typecheck/TcGenFunctor.hs
@@ -137,7 +137,7 @@ gen_Functor_binds loc tycon
     fmap_eqns = [mkSimpleMatch fmap_match_ctxt
                                [nlWildPat]
                                coerce_Expr]
-    fmap_match_ctxt = FunRhs fmap_name Prefix
+    fmap_match_ctxt = FunRhs fmap_name Prefix NoSrcStrict
 
 gen_Functor_binds loc tycon
   = (listToBag [fmap_bind, replace_bind], emptyBag)
@@ -147,7 +147,7 @@ gen_Functor_binds loc tycon
 
     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
     fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
-    fmap_match_ctxt = FunRhs fmap_name Prefix
+    fmap_match_ctxt = FunRhs fmap_name Prefix NoSrcStrict
 
     fmap_eqn con = flip evalState bs_RDRs $
                      match_for_con fmap_match_ctxt [f_Pat] con =<< parts
@@ -182,7 +182,7 @@ gen_Functor_binds loc tycon
 
     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
     replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
-    replace_match_ctxt = FunRhs replace_name Prefix
+    replace_match_ctxt = FunRhs replace_name Prefix NoSrcStrict
 
     replace_eqn con = flip evalState bs_RDRs $
         match_for_con replace_match_ctxt [z_Pat] con =<< parts
@@ -651,7 +651,7 @@ gen_Foldable_binds loc tycon
     foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
                                   [nlWildPat, nlWildPat]
                                   mempty_Expr]
-    foldMap_match_ctxt = FunRhs foldMap_name Prefix
+    foldMap_match_ctxt = FunRhs foldMap_name Prefix NoSrcStrict
 
 gen_Foldable_binds loc tycon
   | null data_cons  -- There's no real point producing anything but
@@ -694,7 +694,7 @@ gen_Foldable_binds loc tycon
       go (NullM a) = Just (Just a)
 
     null_name = L loc null_RDR
-    null_match_ctxt = FunRhs null_name Prefix
+    null_match_ctxt = FunRhs null_name Prefix NoSrcStrict
     null_bind = mkRdrFunBind null_name null_eqns
     null_eqns = map null_eqn data_cons
     null_eqn con
@@ -878,7 +878,7 @@ gen_Traversable_binds loc tycon
         [mkSimpleMatch traverse_match_ctxt
                        [nlWildPat, z_Pat]
                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
-    traverse_match_ctxt = FunRhs traverse_name Prefix
+    traverse_match_ctxt = FunRhs traverse_name Prefix NoSrcStrict
 
 gen_Traversable_binds loc tycon
   = (unitBag traverse_bind, emptyBag)
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 76d963d192..2bae2bc635 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -1566,7 +1566,7 @@ mkDefMethBind clas inst_tys sel_id dm_name
                                       , tyConBinderArgFlag tcb /= Inferred ]
               rhs  = foldl mk_vta (nlHsVar dm_name) visible_inst_tys
               bind = noLoc $ mkTopFunBind Generated fn $
-                             [mkSimpleMatch (FunRhs fn Prefix) [] rhs]
+                             [mkSimpleMatch (FunRhs fn Prefix NoSrcStrict) [] rhs]
 
         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
                    (vcat [ppr clas <+> ppr inst_tys,
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index e7deedee15..ba8e6de21a 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -98,7 +98,7 @@ tcMatchesFun fn@(L _ 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 fn Prefix, mc_body = tcBody }
+    match_ctxt = MC { mc_what = FunRhs fn Prefix NoSrcStrict, mc_body = tcBody }
 
 {-
 @tcMatchesCase@ doesn't do the argument-count check because the
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 01cb5420fd..89b9e0008f 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -442,7 +442,7 @@ tcPatSynMatcher (L loc name) lpat
                        , mg_res_ty = res_ty
                        , mg_origin = Generated
                        }
-             match = mkMatch (FunRhs (L loc name) Prefix) []
+             match = mkMatch (FunRhs (L loc name) Prefix NoSrcStrict) []
                              (mkHsLams (rr_tv:res_tv:univ_tvs)
                              req_dicts body')
                              (noLoc EmptyLocalBinds)
@@ -563,7 +563,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
     mk_mg body = mkMatchGroup Generated [builder_match]
              where
                builder_args  = [L loc (VarPat (L loc n)) | L loc n <- args]
-               builder_match = mkMatch (FunRhs (L loc name) Prefix)
+               builder_match = mkMatch (FunRhs (L loc name) Prefix NoSrcStrict)
                                        builder_args body
                                        (noLoc EmptyLocalBinds)
 
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index b9ffd6a835..c7c3cbd87f 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1973,7 +1973,7 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
         ; uniq <- newUnique
         ; interPrintName <- getInteractivePrintName
         ; let fresh_it  = itName uniq loc
-              matches   = [mkMatch (FunRhs (L loc fresh_it) Prefix) [] rn_expr
+              matches   = [mkMatch (FunRhs (L loc fresh_it) Prefix NoSrcStrict) [] rn_expr
                                    (noLoc emptyLocalBinds)]
               -- [it = expr]
               the_bind  = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index d147cac65c..7b1615a9b7 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -864,10 +864,10 @@ mkOneRecordSelector all_cons idDetails fl
     --    where cons_w_field = [C2,C7]
     sel_bind = mkTopFunBind Generated sel_lname alts
       where
-        alts | is_naughty = [mkSimpleMatch (FunRhs sel_lname Prefix)
+        alts | is_naughty = [mkSimpleMatch (FunRhs sel_lname Prefix NoSrcStrict)
                                            [] unit_rhs]
              | otherwise =  map mk_match cons_w_field ++ deflt
-    mk_match con = mkSimpleMatch (FunRhs sel_lname Prefix)
+    mk_match con = mkSimpleMatch (FunRhs sel_lname Prefix NoSrcStrict)
                                  [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)
diff --git a/testsuite/tests/parser/should_compile/T13594.hs b/testsuite/tests/parser/should_compile/T13594.hs
new file mode 100644
index 0000000000..627e38f8fa
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T13594.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+module Bug where
+
+x :: forall a . a ~ Integer => forall b. b ~ Integer => (a, b)
+!x = (1, 2)
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 2059979765..5cf615ecb0 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -107,3 +107,4 @@ test('T10582', expect_broken(10582), compile, [''])
 test('DumpParsedAst',      normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
 test('DumpRenamedAst',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
 test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast'])
+test('T13594', normal, compile, [''])