Implement the proposed -XQualifiedDo extension

Co-authored-by: Facundo Domínguez <facundo.dominguez@tweag.io>

QualifiedDo is implemented using the same placeholders for operation names in
the AST that were devised for RebindableSyntax. Whenever the renamer checks
which names to use for do syntax, it first checks if the do block is qualified
(e.g. M.do { stmts }), in which case it searches for qualified names in
the module M.

This allows users to write

    {-# LANGUAGE QualifiedDo #-}
    import qualified SomeModule as M

    f x = M.do           -- desugars to:
      y <- M.return x    -- M.return x M.>>= \y ->
      M.return y         -- M.return y M.>>
      M.return y         -- M.return y

See Note [QualifiedDo] and the users' guide for more details.

Issue #18214

Proposal:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0216-qualified-do.rst

Since we change the constructors `ITdo` and `ITmdo` to carry the new module
name, we need to bump the haddock submodule to account or the new shape of
these constructors.

2 files changed, 49 insertions, 26 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 20aeb72872..ffe23e5588 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -45,6 +45,7 @@ import GHC.Types.Name.Set
 import GHC.Types.Basic
 import GHC.Core.ConLike
 import GHC.Types.SrcLoc
+import GHC.Unit.Module (ModuleName)
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Data.FastString
@@ -2068,6 +2069,8 @@ 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 GhcRn -- context of the do expression
+                                               -- used in pprArg
     }
   | XApplicativeArg !(XXApplicativeArg idL)
 
@@ -2306,7 +2309,7 @@ pprStmt (ApplicativeStmt _ args mb_join)
              :: ExprStmt (GhcPass idL))]
      | otherwise =
      [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))]
-   flattenArg (_, ApplicativeArgMany _ stmts _ _) =
+   flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =
      concatMap flattenStmt stmts
 
    pp_debug =
@@ -2331,10 +2334,10 @@ pprArg (ApplicativeArgOne _ pat expr isBody)
             :: ExprStmt (GhcPass idL))
   | otherwise =
     ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))
-pprArg (ApplicativeArgMany _ stmts return pat) =
+pprArg (ApplicativeArgMany _ stmts return pat ctxt) =
      ppr pat <+>
      text "<-" <+>
-     ppr (HsDo (panic "pprStmt") DoExpr (noLoc
+     ppr (HsDo (panic "pprStmt") ctxt (noLoc
                (stmts ++
                    [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])))
 
@@ -2358,14 +2361,21 @@ pprBy (Just e) = text "by" <+> ppr e
 
 pprDo :: (OutputableBndrId p, Outputable body)
       => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
-pprDo DoExpr        stmts = text "do"  <+> ppr_do_stmts stmts
+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       stmts = text "mdo" <+> 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
 
+ppr_module_name_prefix :: Maybe ModuleName -> SDoc
+ppr_module_name_prefix = \case
+  Nothing -> empty
+  Just module_name -> ppr module_name <> char '.'
+
 ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,
                  Outputable body)
              => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
@@ -2756,8 +2766,6 @@ data HsMatchContext p
   | ThPatSplice            -- ^A Template Haskell pattern splice
   | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]
   | PatSyn                 -- ^A pattern synonym declaration
-deriving instance Data (HsMatchContext GhcPs)
-deriving instance Data (HsMatchContext GhcRn)
 
 instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
   ppr m@(FunRhs{})          = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
@@ -2784,16 +2792,20 @@ data HsStmtContext p
   = ListComp
   | MonadComp
 
-  | DoExpr                           -- ^do { ... }
-  | MDoExpr                          -- ^mdo { ... }  ie recursive do-expression
+  | 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
   | 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
-deriving instance Data (HsStmtContext GhcPs)
-deriving instance Data (HsStmtContext GhcRn)
+
+qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName
+qualifiedDoModuleName_maybe ctxt = case ctxt of
+  DoExpr m -> m
+  MDoExpr m -> m
+  _ -> Nothing
 
 isComprehensionContext :: HsStmtContext id -> Bool
 -- Uses comprehension syntax [ e | quals ]
@@ -2803,16 +2815,15 @@ isComprehensionContext (ParStmtCtxt c)   = isComprehensionContext c
 isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c
 isComprehensionContext _ = False
 
--- | Should pattern match failure in a 'HsStmtContext' be desugared using
--- 'MonadFail'?
-isMonadFailStmtContext :: HsStmtContext id -> Bool
-isMonadFailStmtContext MonadComp            = True
-isMonadFailStmtContext DoExpr               = True
-isMonadFailStmtContext MDoExpr              = True
-isMonadFailStmtContext GhciStmtCtxt         = True
-isMonadFailStmtContext (ParStmtCtxt ctxt)   = isMonadFailStmtContext ctxt
-isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt
-isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr
+-- | 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
 
 isMonadCompContext :: HsStmtContext id -> Bool
 isMonadCompContext MonadComp = True
@@ -2869,15 +2880,15 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt
     pp_an = text "an"
     pp_a  = text "a"
     article = case ctxt of
-                  MDoExpr       -> pp_an
+                  MDoExpr Nothing -> pp_an
                   GhciStmtCtxt  -> pp_an
                   _             -> pp_a
 
 
 -----------------
 pprStmtContext GhciStmtCtxt    = text "interactive GHCi command"
-pprStmtContext DoExpr          = text "'do' block"
-pprStmtContext MDoExpr         = text "'mdo' block"
+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"
@@ -2895,6 +2906,10 @@ pprStmtContext (TransStmtCtxt c) =
   ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
              (pprStmtContext c)
 
+prependQualified :: Maybe ModuleName -> SDoc -> SDoc
+prependQualified Nothing  t = t
+prependQualified (Just _) t = text "qualified" <+> t
+
 instance OutputableBndrId p
       => Outputable (HsStmtContext (GhcPass p)) where
     ppr = pprStmtContext
@@ -2917,9 +2932,9 @@ matchContextErrString (StmtCtxt (ParStmtCtxt c))   = matchContextErrString (Stmt
 matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
 matchContextErrString (StmtCtxt (PatGuard _))      = text "pattern guard"
 matchContextErrString (StmtCtxt GhciStmtCtxt)      = text "interactive GHCi command"
-matchContextErrString (StmtCtxt DoExpr)            = text "'do' block"
+matchContextErrString (StmtCtxt (DoExpr m))        = prependQualified m (text "'do' block")
 matchContextErrString (StmtCtxt ArrowExpr)         = text "'do' block"
-matchContextErrString (StmtCtxt MDoExpr)           = text "'mdo' block"
+matchContextErrString (StmtCtxt (MDoExpr m))       = prependQualified m (text "'mdo' block")
 matchContextErrString (StmtCtxt ListComp)          = text "list comprehension"
 matchContextErrString (StmtCtxt MonadComp)         = text "monad comprehension"
 
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index c66488e770..87ded0d22d 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -315,6 +315,14 @@ deriving instance Data (ApplicativeArg GhcPs)
 deriving instance Data (ApplicativeArg GhcRn)
 deriving instance Data (ApplicativeArg GhcTc)
 
+deriving instance Data (HsStmtContext GhcPs)
+deriving instance Data (HsStmtContext GhcRn)
+deriving instance Data (HsStmtContext GhcTc)
+
+deriving instance Data (HsMatchContext GhcPs)
+deriving instance Data (HsMatchContext GhcRn)
+deriving instance Data (HsMatchContext GhcTc)
+
 -- deriving instance (DataIdLR p p) => Data (HsSplice p)
 deriving instance Data (HsSplice GhcPs)
 deriving instance Data (HsSplice GhcRn)