Refactor HsStmtContext and remove HsDoRn

Parts of HsStmtContext were split into a separate data structure
HsDoFlavour. Before this change HsDo used to have HsStmtContext
inside, but in reality only parts of HsStmtContext were used and other
cases were invariants handled with panics. Separating those parts
into its own data structure helps us to get rid of those panics as
well as HsDoRn type family.

16 files changed, 165 insertions, 165 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 011a527d53..d0c5dbef0c 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -186,7 +186,6 @@ data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper
 
 deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)
 
-type instance HsDoRn (GhcPass _) = GhcRn
 type instance HsBracketRn (GhcPass _) = GhcRn
 type instance PendingRnSplice' (GhcPass _) = PendingRnSplice
 type instance PendingTcSplice' (GhcPass _) = PendingTcSplice
@@ -797,7 +796,7 @@ hsExprNeedsParens prec = go
     go (HsMultiIf{})                  = prec > topPrec
     go (HsLet{})                      = prec > topPrec
     go (HsDo _ sc _)
-      | isComprehensionContext sc     = False
+      | isDoComprehensionContext sc   = False
       | otherwise                     = prec > topPrec
     go (ExplicitList{})               = False
     go (RecordUpd{})                  = False
@@ -1185,7 +1184,7 @@ ppr_cmd (HsCmdLet _ binds cmd)
   = sep [hang (text "let") 2 (pprBinds binds),
          hang (text "in")  2 (ppr cmd)]
 
-ppr_cmd (HsCmdDo _ (L _ stmts))  = pprDo ArrowExpr stmts
+ppr_cmd (HsCmdDo _ (L _ stmts))  = pprArrowExpr stmts
 
 ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
   = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
@@ -1448,8 +1447,6 @@ type instance XApplicativeArgOne GhcTc = FailOperator GhcTc
 type instance XApplicativeArgMany (GhcPass _) = NoExtField
 type instance XXApplicativeArg    (GhcPass _) = NoExtCon
 
-type instance ApplicativeArgStmCtxPass _ = GhcRn
-
 instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),
           Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))
         => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where
@@ -1562,16 +1559,20 @@ pprBy (Just e) = text "by" <+> ppr e
 pprDo :: (OutputableBndrId p, Outputable body,
                  Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA
          )
-      => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
+      => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc
 pprDo (DoExpr m)    stmts =
   ppr_module_name_prefix m <> text "do"  <+> ppr_do_stmts stmts
 pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts
-pprDo ArrowExpr     stmts = text "do"  <+> ppr_do_stmts stmts
 pprDo (MDoExpr m)   stmts =
   ppr_module_name_prefix m <> text "mdo"  <+> ppr_do_stmts stmts
 pprDo ListComp      stmts = brackets    $ pprComp stmts
 pprDo MonadComp     stmts = brackets    $ pprComp stmts
-pprDo _             _     = panic "pprDo" -- PatGuard, ParStmtCxt
+
+pprArrowExpr :: (OutputableBndrId p, Outputable body,
+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA
+         )
+      => [LStmt (GhcPass p) body] -> SDoc
+pprArrowExpr stmts = text "do"  <+> ppr_do_stmts stmts
 
 ppr_module_name_prefix :: Maybe ModuleName -> SDoc
 ppr_module_name_prefix = \case
@@ -1868,12 +1869,15 @@ matchContextErrString PatSyn                     = panic "matchContextErrString"
 matchContextErrString (StmtCtxt (ParStmtCtxt c))   = matchContextErrString (StmtCtxt c)
 matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
 matchContextErrString (StmtCtxt (PatGuard _))      = text "pattern guard"
-matchContextErrString (StmtCtxt GhciStmtCtxt)      = text "interactive GHCi command"
-matchContextErrString (StmtCtxt (DoExpr m))        = prependQualified m (text "'do' block")
-matchContextErrString (StmtCtxt ArrowExpr)         = text "'do' block"
-matchContextErrString (StmtCtxt (MDoExpr m))       = prependQualified m (text "'mdo' block")
-matchContextErrString (StmtCtxt ListComp)          = text "list comprehension"
-matchContextErrString (StmtCtxt MonadComp)         = text "monad comprehension"
+matchContextErrString (StmtCtxt (ArrowExpr))  = text "'do' block"
+matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour
+
+matchDoContextErrString :: HsDoFlavour -> SDoc
+matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"
+matchDoContextErrString (DoExpr m)   = prependQualified m (text "'do' block")
+matchDoContextErrString (MDoExpr m)  = prependQualified m (text "'mdo' block")
+matchDoContextErrString ListComp     = text "list comprehension"
+matchDoContextErrString MonadComp    = text "monad comprehension"
 
 pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)
                => Match (GhcPass idR) body -> SDoc
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 87f1ceafff..d2f69cc7bb 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -366,6 +366,8 @@ deriving instance Data (HsStmtContext GhcPs)
 deriving instance Data (HsStmtContext GhcRn)
 deriving instance Data (HsStmtContext GhcTc)
 
+deriving instance Data HsDoFlavour
+
 deriving instance Data (HsMatchContext GhcPs)
 deriving instance Data (HsMatchContext GhcRn)
 deriving instance Data (HsMatchContext GhcTc)
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 590cf87793..a0f4fa4c07 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -299,11 +299,11 @@ nlParPat p = noLocA (gParPat p)
 mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs
 mkHsFractional :: FractionalLit -> HsOverLit GhcPs
 mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs
-mkHsDo         :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs
-mkHsDoAnns     :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs
-mkHsComp       :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
+mkHsDo         :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs
+mkHsDoAnns     :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs
+mkHsComp       :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
                -> HsExpr GhcPs
-mkHsCompAnns   :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
+mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
                -> EpAnn AnnList
                -> HsExpr GhcPs
 
@@ -575,7 +575,7 @@ nlWildPat  = noLocA (WildPat noExtField )
 nlWildPatName :: LPat GhcRn
 nlWildPatName  = noLocA (WildPat noExtField )
 
-nlHsDo :: HsStmtContext GhcRn -> [LStmt GhcPs (LHsExpr GhcPs)]
+nlHsDo :: HsDoFlavour -> [LStmt GhcPs (LHsExpr GhcPs)]
        -> LHsExpr GhcPs
 nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))
 
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 2b7b96f118..5cfd057299 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -904,10 +904,10 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
        out_ty = mkBigCoreVarTupTy out_ids
        body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
 
-    fail_expr <- mkFailExpr (StmtCtxt (DoExpr Nothing)) out_ty
+    fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty
     pat_id    <- selectSimpleMatchVarL Many pat
     match_code
-      <- matchSimply (Var pat_id) (StmtCtxt (DoExpr Nothing)) pat body_expr fail_expr
+      <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr
     pair_id   <- newSysLocalDs Many after_c_ty
     let
         proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 2693bda345..1f0a0ddde5 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -778,8 +778,6 @@ dsExpr (OpApp x _ _ _)   = dataConCantHappen x
 dsExpr (SectionL x _ _)  = dataConCantHappen x
 dsExpr (SectionR x _ _)  = dataConCantHappen x
 dsExpr (HsBracket x _)   = dataConCantHappen x
--- HsSyn constructs that just shouldn't be here:
-dsExpr (HsDo        {}) = panic "dsExpr:HsDo"
 
 ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
 ds_prag_expr (HsPragSCC _ _ cc) expr = do
@@ -936,7 +934,7 @@ handled in GHC.HsToCore.ListComp).  Basically does the translation given in the
 Haskell 98 report:
 -}
 
-dsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
+dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
 dsDo ctx stmts
   = goL stmts
   where
@@ -961,7 +959,7 @@ dsDo ctx stmts
       = do  { body     <- goL stmts
             ; rhs'     <- dsLExpr rhs
             ; var   <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
-            ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat
+            ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
                          (xbstc_boundResultType xbs) (cantFailMatchResult body)
             ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
             ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
@@ -982,7 +980,7 @@ dsDo ctx stmts
 
            ; let match_args (pat, fail_op) (vs,body)
                    = do { var   <- selectSimpleMatchVarL Many pat
-                        ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat
+                        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
                                    body_ty (cantFailMatchResult body)
                         ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
                         ; return (var:vs, match_code)
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 6c988ee047..3f649903a1 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -288,7 +288,7 @@ deBindComp pat core_list1 quals core_list2 = do
         letrec_body = App (Var h) core_list1
 
     rest_expr <- deListComp quals core_fail
-    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
+    core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) pat rest_expr core_fail
 
     let
         rhs = Lam u1 $
@@ -376,7 +376,7 @@ dfBindComp c_id n_id (pat, core_list1) quals = do
     core_rest <- dfListComp c_id b quals
 
     -- build the pattern match
-    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
+    core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp))
                 pat core_rest (Var b)
 
     -- now build the outermost foldr, and return
@@ -614,9 +614,9 @@ dsMcBindStmt :: LPat GhcTc
 dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
   = do  { body     <- dsMcStmts stmts
         ; var      <- selectSimpleMatchVarL Many pat
-        ; match <- matchSinglePatVar var Nothing (StmtCtxt (DoExpr Nothing)) pat
+        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat
                                   res1_ty (cantFailMatchResult body)
-        ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op
+        ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op
         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
 
 -- Desugar nested monad comprehensions, for example in `then..` constructs
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 333929c956..c1426474be 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -956,7 +956,7 @@ CPR-friendly.  This matters a lot: if you don't get it right, you lose
 the tail call property.  For example, see #3403.
 -}
 
-dsHandleMonadicFailure :: HsStmtContext GhcRn -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
     -- In a do expression, pattern-match failure just calls
     -- the monadic 'fail' rather than throwing an exception
 dsHandleMonadicFailure ctx pat match m_fail_op =
@@ -977,9 +977,9 @@ dsHandleMonadicFailure ctx pat match m_fail_op =
       fail_expr <- dsSyntaxExpr fail_op [fail_msg]
       body fail_expr
 
-mk_fail_msg :: DynFlags -> HsStmtContext GhcRn -> LocatedA e -> String
+mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String
 mk_fail_msg dflags ctx pat
-  = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx
+  = showPpr dflags $ text "Pattern match failure in" <+> pprHsDoFlavour ctx
                    <+> text "at" <+> ppr (getLocA pat)
 
 {- Note [Desugaring representation-polymorphic applications]
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 946b9a87f3..6b58b70558 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1362,7 +1362,7 @@ addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do
 -- If the flag MonadComprehensions is set, return a 'MonadComp' context,
 -- otherwise use the usual 'ListComp' context
 
-checkMonadComp :: PV (HsStmtContext GhcRn)
+checkMonadComp :: PV HsDoFlavour
 checkMonadComp = do
     monadComprehensions <- getBit MonadComprehensionsBit
     return $ if monadComprehensions
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 72e18ed388..1e1f7bdce1 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -388,11 +388,11 @@ rnExpr (HsLet _ binds expr)
       ; return (HsLet noExtField binds' expr', fvExpr) }
 
 rnExpr (HsDo _ do_or_lc (L l stmts))
-  = do  { ((stmts', _), fvs) <-
-           rnStmtsWithPostProcessing do_or_lc rnExpr
-             postProcessStmtsForApplicativeDo stmts
-             (\ _ -> return ((), emptyFVs))
-        ; return ( HsDo noExtField do_or_lc (L l stmts'), fvs ) }
+ = do { ((stmts1, _), fvs1) <-
+          rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
+            (\ _ -> return ((), emptyFVs))
+      ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
+      ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }
 
 -- ExplicitList: see Note [Handling overloaded and rebindable constructs]
 rnExpr (ExplicitList _ exps)
@@ -984,34 +984,13 @@ rnStmts :: AnnoBody body
            -- ^ if these statements scope over something, this renames it
            -- and returns the result.
         -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
-rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
-
--- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
-rnStmtsWithPostProcessing
-        :: AnnoBody body
-        => HsStmtContext GhcRn
-        -> (body GhcPs -> RnM (body GhcRn, FreeVars))
-           -- ^ How to rename the body of each statement (e.g. rnLExpr)
-        -> (HsStmtContext GhcRn
-              -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-              -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars))
-           -- ^ postprocess the statements
-        -> [LStmt GhcPs (LocatedA (body GhcPs))]
-           -- ^ Statements
-        -> ([Name] -> RnM (thing, FreeVars))
-           -- ^ if these statements scope over something, this renames it
-           -- and returns the result.
-        -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
-rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
- = do { ((stmts', thing), fvs) <-
-          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
-      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
-      ; return ((pp_stmts, thing), fvs `plusFV` fvs')
-      }
+rnStmts ctxt rnBody stmts thing_inside
+ = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
+      ; return ((map fst stmts', thing), fvs) }
 
 -- | maybe rearrange statements according to the ApplicativeDo transformation
 postProcessStmtsForApplicativeDo
-  :: HsStmtContext GhcRn
+  :: HsDoFlavour
   -> [(ExprLStmt GhcRn, FreeVars)]
   -> RnM ([ExprLStmt GhcRn], FreeVars)
 postProcessStmtsForApplicativeDo ctxt stmts
@@ -1028,7 +1007,7 @@ postProcessStmtsForApplicativeDo ctxt stmts
        ; if ado_is_on && is_do_expr && not in_th_bracket
             then do { traceRn "ppsfa" (ppr stmts)
                     ; rearrangeForApplicativeDo ctxt stmts }
-            else noPostProcessStmts ctxt stmts }
+            else noPostProcessStmts (HsDoStmt ctxt) stmts }
 
 -- | strip the FreeVars annotations from statements
 noPostProcessStmts
@@ -1056,7 +1035,7 @@ rnStmtsWithFreeVars ctxt _ [] thing_inside
        ; (thing, fvs) <- thing_inside []
        ; return (([], thing), fvs) }
 
-rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside    -- Deal with mdo
+rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody stmts thing_inside    -- Deal with mdo
   = -- Behave like do { rec { ...all but last... }; last }
     do { ((stmts1, (stmts2, thing)), fvs)
            <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ ->
@@ -1313,18 +1292,22 @@ lookupStmtNamePoly ctxt name
 -- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows
 rebindableContext :: HsStmtContext GhcRn -> Bool
 rebindableContext ctxt = case ctxt of
-  ListComp        -> False
-  ArrowExpr       -> False
-  PatGuard {}     -> False
+  HsDoStmt flavour -> rebindableDoStmtContext flavour
+  ArrowExpr -> False
+  PatGuard {} -> False
 
-  DoExpr m        -> isNothing m
-  MDoExpr m       -> isNothing m
-  MonadComp       -> True
-  GhciStmtCtxt    -> True   -- I suppose?
 
   ParStmtCtxt   c -> rebindableContext c     -- Look inside to
   TransStmtCtxt c -> rebindableContext c     -- the parent context
 
+rebindableDoStmtContext :: HsDoFlavour -> Bool
+rebindableDoStmtContext flavour = case flavour of
+  ListComp -> False
+  DoExpr m -> isNothing m
+  MDoExpr m -> isNothing m
+  MonadComp -> True
+  GhciStmtCtxt -> True   -- I suppose?
+
 {-
 Note [Renaming parallel Stmts]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1546,7 +1529,7 @@ segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
   | null segs
   = ([], fvs_later)
 
-  | MDoExpr _ <- ctxt
+  | HsDoStmt (MDoExpr _) <- ctxt
   = segsToStmts empty_rec_stmt grouped_segs fvs_later
                -- Step 4: Turn the segments into Stmts
                 --         Use RecStmt when and only when there are fwd refs
@@ -1852,7 +1835,7 @@ instance Outputable MonadNames where
 -- | rearrange a list of statements using ApplicativeDoStmt.  See
 -- Note [ApplicativeDo].
 rearrangeForApplicativeDo
-  :: HsStmtContext GhcRn
+  :: HsDoFlavour
   -> [(ExprLStmt GhcRn, FreeVars)]
   -> RnM ([ExprLStmt GhcRn], FreeVars)
 
@@ -1863,8 +1846,8 @@ rearrangeForApplicativeDo ctxt stmts0 = do
   let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
                 | otherwise = mkStmtTreeHeuristic stmts
   traceRn "rearrangeForADo" (ppr stmt_tree)
-  (return_name, _) <- lookupQualifiedDoName ctxt returnMName
-  (pure_name, _)   <- lookupQualifiedDoName ctxt pureAName
+  (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
+  (pure_name, _)   <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
   let monad_names = MonadNames { return_name = return_name
                                , pure_name   = pure_name }
   stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
@@ -1978,7 +1961,7 @@ mkStmtTreeOptimal stmts =
 -- ApplicativeStmt where necessary.
 stmtTreeToStmts
   :: MonadNames
-  -> HsStmtContext GhcRn
+  -> HsDoFlavour
   -> ExprStmtTree
   -> [ExprLStmt GhcRn]             -- ^ the "tail"
   -> FreeVars                     -- ^ free variables of the tail
@@ -2062,7 +2045,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
         if | L _ ApplicativeStmt{} <- last stmts' ->
              return (unLoc tup, emptyNameSet)
            | otherwise -> do
-             (ret, _) <- lookupQualifiedDoExpr ctxt returnMName
+             (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) returnMName
              let expr = HsApp noComments (noLocA ret) tup
              return (expr, emptyFVs)
      return ( ApplicativeArgMany
@@ -2266,17 +2249,17 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
 -- it this way rather than try to ignore the return later in both the
 -- typechecker and the desugarer (I tried it that way first!).
 mkApplicativeStmt
-  :: HsStmtContext GhcRn
+  :: HsDoFlavour
   -> [ApplicativeArg GhcRn]             -- ^ The args
   -> Bool                               -- ^ True <=> need a join
   -> [ExprLStmt GhcRn]        -- ^ The body statements
   -> RnM ([ExprLStmt GhcRn], FreeVars)
 mkApplicativeStmt ctxt args need_join body_stmts
-  = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName ctxt fmapName
-       ; (ap_op, fvs2) <- lookupQualifiedDoStmtName ctxt apAName
+  = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) fmapName
+       ; (ap_op, fvs2) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) apAName
        ; (mb_join, fvs3) <-
            if need_join then
-             do { (join_op, fvs) <- lookupQualifiedDoStmtName ctxt joinMName
+             do { (join_op, fvs) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) joinMName
                 ; return (Just join_op, fvs) }
            else
              return (Nothing, emptyNameSet)
@@ -2350,11 +2333,11 @@ checkLastStmt :: AnnoBody body => HsStmtContext GhcRn
               -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
 checkLastStmt ctxt lstmt@(L loc stmt)
   = case ctxt of
-      ListComp  -> check_comp
-      MonadComp -> check_comp
+      HsDoStmt ListComp  -> check_comp
+      HsDoStmt MonadComp -> check_comp
+      HsDoStmt DoExpr{}  -> check_do
+      HsDoStmt MDoExpr{} -> check_do
       ArrowExpr -> check_do
-      DoExpr{}  -> check_do
-      MDoExpr{} -> check_do
       _         -> check_other
   where
     check_do    -- Expect BodyStmt, and change it to LastStmt
@@ -2413,14 +2396,20 @@ okStmt dflags ctxt stmt
   = case ctxt of
       PatGuard {}        -> okPatGuardStmt stmt
       ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt
-      DoExpr{}           -> okDoStmt   dflags ctxt stmt
-      MDoExpr{}          -> okDoStmt   dflags ctxt stmt
+      HsDoStmt flavour   -> okDoFlavourStmt dflags flavour ctxt stmt
       ArrowExpr          -> okDoStmt   dflags ctxt stmt
-      GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt
-      ListComp           -> okCompStmt dflags ctxt stmt
-      MonadComp          -> okCompStmt dflags ctxt stmt
       TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
 
+okDoFlavourStmt
+  :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn
+  -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
+okDoFlavourStmt dflags flavour ctxt stmt = case flavour of
+      DoExpr{}     -> okDoStmt   dflags ctxt stmt
+      MDoExpr{}    -> okDoStmt   dflags ctxt stmt
+      GhciStmtCtxt -> okDoStmt   dflags ctxt stmt
+      ListComp     -> okCompStmt dflags ctxt stmt
+      MonadComp    -> okCompStmt dflags ctxt stmt
+
 -------------
 okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
 okPatGuardStmt stmt
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 0a149f473e..ab9bf28564 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -217,7 +217,7 @@ matchNameMaker ctxt = LamMk report_unused
     -- Do not report unused names in interactive contexts
     -- i.e. when you type 'x <- e' at the GHCi prompt
     report_unused = case ctxt of
-                      StmtCtxt GhciStmtCtxt -> False
+                      StmtCtxt (HsDoStmt GhciStmtCtxt) -> False
                       -- also, don't warn in pattern quotes, as there
                       -- is no RHS where the variables can be used!
                       ThPatQuote            -> False
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 06118359f1..9b8b68aad6 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -299,7 +299,7 @@ tcGRHS ctxt res_ty (GRHS _ guards rhs)
 ************************************************************************
 -}
 
-tcDoStmts :: HsStmtContext GhcRn
+tcDoStmts :: HsDoFlavour
           -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
           -> ExpRhoType
           -> TcM (HsExpr GhcTc)          -- Returns a HsDo
@@ -307,26 +307,25 @@ tcDoStmts ListComp (L l stmts) res_ty
   = do  { res_ty <- expTypeToType res_ty
         ; (co, elt_ty) <- matchExpectedListTy res_ty
         ; let list_ty = mkListTy elt_ty
-        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
+        ; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts
                             (mkCheckExpType elt_ty)
         ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
 
 tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
-  = do  { stmts' <- tcStmts doExpr tcDoStmt stmts res_ty
+  = do  { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
         ; res_ty <- readExpType res_ty
         ; return (HsDo res_ty doExpr (L l stmts')) }
 
 tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
-  = do  { stmts' <- tcStmts mDoExpr tcDoStmt stmts res_ty
+  = do  { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
         ; res_ty <- readExpType res_ty
         ; return (HsDo res_ty mDoExpr (L l stmts')) }
 
 tcDoStmts MonadComp (L l stmts) res_ty
-  = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
+  = do  { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
         ; res_ty <- readExpType res_ty
         ; return (HsDo res_ty MonadComp (L l stmts')) }
-
-tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)
 
 tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
 tcBody body res_ty
@@ -1068,10 +1067,10 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
 
     goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)
       = do { (stmts', (ret',pat')) <-
-                tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
+                tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
                 \res_ty  -> do
                   { ret'      <- tcExpr ret res_ty
-                  ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
+                  ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
                                  return ()
                   ; return (ret', pat')
                   }
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index f458605c14..5be998e07a 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2391,7 +2391,7 @@ But for naked expressions, you will have
 
 tcUserStmt rdr_stmt@(L loc _)
   = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
-           rnStmts GhciStmtCtxt rnExpr [rdr_stmt] $ \_ -> do
+           rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do
              fix_env <- getFixityEnv
              return (fix_env, emptyFVs)
             -- Don't try to typecheck if the renamer fails!
@@ -2456,7 +2456,7 @@ tcGhciStmts stmts
       ; ret_id  <- tcLookupId returnIOName             -- return @ IO
       ; let ret_ty      = mkListTy unitTy
             io_ret_ty   = mkTyConApp ioTyCon [ret_ty]
-            tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts
+            tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts
                                          (mkCheckExpType io_ret_ty)
             names = collectLStmtsBinders CollNoDictBinders stmts
 
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index de2602e6c5..0f9bb35cd6 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1177,7 +1177,7 @@ cvtOpApp x op y
 --      Do notation and statements
 -------------------------------------
 
-cvtHsDo :: HsStmtContext GhcRn -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
+cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
 cvtHsDo do_or_lc stmts
   | null stmts = failWith (text "Empty stmt list in do-block")
   | otherwise
@@ -1191,7 +1191,7 @@ cvtHsDo do_or_lc stmts
 
         ; return $ HsDo noAnn do_or_lc (noLocA (stmts'' ++ [last''])) }
   where
-    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
+    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon
                          , nest 2 $ Outputable.ppr stmt
                          , text "(It should be an expression.)" ]
 
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 88f15515c8..34058b58f5 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -488,10 +488,7 @@ data HsExpr p
 
   -- For details on above see note [exact print annotations] in GHC.Parser.Annotation
   | HsDo        (XDo p)                  -- Type of the whole expression
-                (HsStmtContext (HsDoRn p))
-                -- The parameterisation of the above is unimportant
-                -- because in this context we never use
-                -- the PatGuard or ParStmt variant
+                HsDoFlavour
                 (XRec p [ExprLStmt p])   -- "do":one or more stmts
 
   -- | Syntactic list: [a,b,c,...]
@@ -665,7 +662,6 @@ data HsExpr p
 
 -- | The AST used to hard-refer to GhcPass, which was a layer violation. For now,
 -- we paper it over with this new extension point.
-type family HsDoRn p
 type family HsBracketRn p
 type family PendingRnSplice' p
 type family PendingTcSplice' p
@@ -1371,13 +1367,11 @@ data ApplicativeArg idL
     , app_stmts         :: [ExprLStmt idL] -- stmts
     , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)
     , bv_pattern        :: LPat idL      -- (v1,...,vn)
-    , stmt_context      :: HsStmtContext (ApplicativeArgStmCtxPass idL)
+    , stmt_context      :: HsDoFlavour
       -- ^ context of the do expression, used in pprArg
     }
   | XApplicativeArg !(XXApplicativeArg idL)
 
-type family ApplicativeArgStmCtxPass idL
-
 {-
 Note [The type of bind in Stmts]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1720,45 +1714,68 @@ isPatSynCtxt ctxt =
 
 -- | Haskell Statement Context.
 data HsStmtContext p
-  = ListComp
-  | MonadComp
-
-  | DoExpr (Maybe ModuleName)        -- ^[ModuleName.]do { ... }
-  | MDoExpr (Maybe ModuleName)       -- ^[ModuleName.]mdo { ... }  ie recursive do-expression
-  | ArrowExpr                        -- ^do-notation in an arrow-command context
-
-  | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs
+  = HsDoStmt HsDoFlavour             -- ^Context for HsDo (do-notation and comprehensions)
   | PatGuard (HsMatchContext p)      -- ^Pattern guard for specified thing
   | ParStmtCtxt (HsStmtContext p)    -- ^A branch of a parallel stmt
   | TransStmtCtxt (HsStmtContext p)  -- ^A branch of a transform stmt
+  | ArrowExpr                        -- ^do-notation in an arrow-command context
+
+data HsDoFlavour
+  = DoExpr (Maybe ModuleName)        -- ^[ModuleName.]do { ... }
+  | MDoExpr (Maybe ModuleName)       -- ^[ModuleName.]mdo { ... }  ie recursive do-expression
+  | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs
+  | ListComp
+  | MonadComp
 
 qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName
 qualifiedDoModuleName_maybe ctxt = case ctxt of
-  DoExpr m -> m
-  MDoExpr m -> m
+  HsDoStmt (DoExpr m) -> m
+  HsDoStmt (MDoExpr m) -> m
   _ -> Nothing
 
 isComprehensionContext :: HsStmtContext id -> Bool
 -- Uses comprehension syntax [ e | quals ]
-isComprehensionContext ListComp          = True
-isComprehensionContext MonadComp         = True
 isComprehensionContext (ParStmtCtxt c)   = isComprehensionContext c
 isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c
-isComprehensionContext _ = False
+isComprehensionContext ArrowExpr = False
+isComprehensionContext (PatGuard _) = False
+isComprehensionContext (HsDoStmt flavour) = isDoComprehensionContext flavour
+
+isDoComprehensionContext :: HsDoFlavour -> Bool
+isDoComprehensionContext GhciStmtCtxt = False
+isDoComprehensionContext (DoExpr _) = False
+isDoComprehensionContext (MDoExpr _) = False
+isDoComprehensionContext ListComp = True
+isDoComprehensionContext MonadComp = True
 
 -- | Is this a monadic context?
 isMonadStmtContext :: HsStmtContext id -> Bool
-isMonadStmtContext MonadComp            = True
-isMonadStmtContext DoExpr{}             = True
-isMonadStmtContext MDoExpr{}            = True
-isMonadStmtContext GhciStmtCtxt         = True
 isMonadStmtContext (ParStmtCtxt ctxt)   = isMonadStmtContext ctxt
 isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt
-isMonadStmtContext _ = False -- ListComp, PatGuard, ArrowExpr
+isMonadStmtContext (HsDoStmt flavour) = isMonadDoStmtContext flavour
+isMonadStmtContext (PatGuard _) = False
+isMonadStmtContext ArrowExpr = False
+
+isMonadDoStmtContext :: HsDoFlavour -> Bool
+isMonadDoStmtContext ListComp     = False
+isMonadDoStmtContext MonadComp    = True
+isMonadDoStmtContext DoExpr{}     = True
+isMonadDoStmtContext MDoExpr{}    = True
+isMonadDoStmtContext GhciStmtCtxt = True
 
 isMonadCompContext :: HsStmtContext id -> Bool
-isMonadCompContext MonadComp = True
-isMonadCompContext _         = False
+isMonadCompContext (HsDoStmt flavour)   = isMonadDoCompContext flavour
+isMonadCompContext (ParStmtCtxt _)   = False
+isMonadCompContext (TransStmtCtxt _) = False
+isMonadCompContext (PatGuard _)      = False
+isMonadCompContext ArrowExpr         = False
+
+isMonadDoCompContext :: HsDoFlavour -> Bool
+isMonadDoCompContext MonadComp    = True
+isMonadDoCompContext ListComp     = False
+isMonadDoCompContext GhciStmtCtxt = False
+isMonadDoCompContext (DoExpr _)   = False
+isMonadDoCompContext (MDoExpr _)  = False
 
 matchSeparator :: HsMatchContext p -> SDoc
 matchSeparator (FunRhs {})   = text "="
@@ -1806,24 +1823,13 @@ pprMatchContextNoun PatSyn          = text "pattern synonym declaration"
 -----------------
 pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
                                 => HsStmtContext p -> SDoc
-pprAStmtContext ctxt = article <+> pprStmtContext ctxt
-  where
-    pp_an = text "an"
-    pp_a  = text "a"
-    article = case ctxt of
-                  MDoExpr Nothing -> pp_an
-                  GhciStmtCtxt  -> pp_an
-                  _             -> pp_a
-
+pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour
+pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt
 
 -----------------
-pprStmtContext GhciStmtCtxt    = text "interactive GHCi command"
-pprStmtContext (DoExpr m)      = prependQualified m (text "'do' block")
-pprStmtContext (MDoExpr m)     = prependQualified m (text "'mdo' block")
-pprStmtContext ArrowExpr       = text "'do' block in an arrow command"
-pprStmtContext ListComp        = text "list comprehension"
-pprStmtContext MonadComp       = text "monad comprehension"
+pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour
 pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt
+pprStmtContext ArrowExpr       = text "'do' block in an arrow command"
 
 -- Drop the inner contexts when reporting errors, else we get
 --     Unexpected transform statement
@@ -1837,6 +1843,21 @@ pprStmtContext (TransStmtCtxt c) =
   ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
              (pprStmtContext c)
 
+pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc
+pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour
+  where
+    pp_an = text "an"
+    pp_a  = text "a"
+    article = case flavour of
+                  MDoExpr Nothing -> pp_an
+                  GhciStmtCtxt  -> pp_an
+                  _             -> pp_a
+pprHsDoFlavour (DoExpr m)      = prependQualified m (text "'do' block")
+pprHsDoFlavour (MDoExpr m)     = prependQualified m (text "'mdo' block")
+pprHsDoFlavour ListComp        = text "list comprehension"
+pprHsDoFlavour MonadComp       = text "monad comprehension"
+pprHsDoFlavour GhciStmtCtxt    = text "interactive GHCi command"
+
 prependQualified :: Maybe ModuleName -> SDoc -> SDoc
 prependQualified Nothing  t = t
 prependQualified (Just _) t = text "qualified" <+> t
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index e4f689bbbb..74135cb9f6 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -2080,14 +2080,12 @@ instance ExactPrint (HsExpr GhcPs) where
 -- ---------------------------------------------------------------------
 
 exactDo :: (ExactPrint body)
-        => EpAnn AnnList -> (HsStmtContext any) -> body -> EPP ()
+        => EpAnn AnnList -> HsDoFlavour -> body -> EPP ()
 exactDo an (DoExpr m)    stmts = exactMdo an m AnnDo             >> markAnnotatedWithLayout stmts
 exactDo an GhciStmtCtxt  stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts
-exactDo an ArrowExpr     stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts
 exactDo an (MDoExpr m)   stmts = exactMdo an m AnnMdo            >> markAnnotatedWithLayout stmts
 exactDo _  ListComp      stmts = markAnnotatedWithLayout stmts
 exactDo _  MonadComp     stmts = markAnnotatedWithLayout stmts
-exactDo _  _             _     = panic "pprDo" -- PatGuard, ParStmtCxt
 
 exactMdo :: EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EPP ()
 exactMdo an Nothing            kw = markLocatedAAL  an al_rest kw
diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs
index 5739df9dd3..74a861e773 100644
--- a/utils/check-exact/Utils.hs
+++ b/utils/check-exact/Utils.hs
@@ -207,19 +207,8 @@ orderByKey keys order
 
 -- ---------------------------------------------------------------------
 
-isListComp :: HsStmtContext name -> Bool
-isListComp cts = case cts of
-          ListComp  -> True
-          MonadComp -> True
-
-          DoExpr {}    -> False
-          MDoExpr {}   -> False
-          ArrowExpr    -> False
-          GhciStmtCtxt -> False
-
-          PatGuard {}      -> False
-          ParStmtCtxt {}   -> False
-          TransStmtCtxt {} -> False
+isListComp :: HsDoFlavour -> Bool
+isListComp = isDoComprehensionContext
 
 -- ---------------------------------------------------------------------