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.

6 files changed, 33 insertions, 9 deletions

diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
index b7c3ba3a1a..e7ef699c68 100644
--- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
+++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
@@ -43,6 +43,7 @@ data Extension
    | Arrows                   -- Arrow-notation syntax
    | TemplateHaskell
    | TemplateHaskellQuotes    -- subset of TH supported by stage1, no splice
+   | QualifiedDo
    | QuasiQuotes
    | ImplicitParams
    | ImplicitPrelude
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 4c4eaf5dbe..7aa4761321 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -157,12 +157,15 @@ import Language.Haskell.TH.Lib.Internal hiding
   , derivClause
   , standaloneDerivWithStrategyD
 
+  , doE
+  , mdoE
   , tupE
   , unboxedTupE
 
   , Role
   , InjectivityAnn
   )
+import qualified Language.Haskell.TH.Lib.Internal as Internal
 import Language.Haskell.TH.Syntax
 
 import Control.Applicative ( liftA2 )
@@ -337,3 +340,12 @@ tupE es = do { es1 <- sequenceA es; return (TupE $ map Just es1)}
 
 unboxedTupE :: Quote m => [m Exp] -> m Exp
 unboxedTupE es = do { es1 <- sequenceA es; return (UnboxedTupE $ map Just es1)}
+
+-------------------------------------------------------------------------------
+-- * Do expressions
+
+doE :: Quote m => [m Stmt] -> m Exp
+doE = Internal.doE Nothing
+
+mdoE :: Quote m => [m Stmt] -> m Exp
+mdoE = Internal.mdoE Nothing
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index ff020ee62d..c93cc6c3a8 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -312,11 +312,11 @@ letE ds e = do { ds2 <- sequenceA ds; e2 <- e; pure (LetE ds2 e2) }
 caseE :: Quote m => m Exp -> [m Match] -> m Exp
 caseE e ms = do { e1 <- e; ms1 <- sequenceA ms; pure (CaseE e1 ms1) }
 
-doE :: Quote m => [m Stmt] -> m Exp
-doE ss = do { ss1 <- sequenceA ss; pure (DoE ss1) }
+doE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp
+doE m ss = do { ss1 <- sequenceA ss; pure (DoE m ss1) }
 
-mdoE :: Quote m => [m Stmt] -> m Exp
-mdoE ss = do { ss1 <- sequenceA ss; pure (MDoE ss1) }
+mdoE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp
+mdoE m ss = do { ss1 <- sequenceA ss; pure (MDoE m ss1) }
 
 compE :: Quote m => [m Stmt] -> m Exp
 compE ss = do { ss1 <- sequenceA ss; pure (CompE ss1) }
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index fcaaa40c3e..337017a958 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -182,13 +182,19 @@ pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_
 pprExp i (CaseE e ms)
  = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
                         $$ nest nestDepth (ppr ms)
-pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
+pprExp i (DoE m ss_) = parensIf (i > noPrec) $
+    pprQualifier m <> text "do" <+> pprStms ss_
   where
+    pprQualifier Nothing = empty
+    pprQualifier (Just modName) = text (modString modName) <> char '.'
     pprStms []  = empty
     pprStms [s] = ppr s
     pprStms ss  = braces (semiSep ss)
-pprExp i (MDoE ss_) = parensIf (i > noPrec) $ text "mdo" <+> pprStms ss_
+pprExp i (MDoE m ss_) = parensIf (i > noPrec) $
+    pprQualifier m <> text "mdo" <+> pprStms ss_
   where
+    pprQualifier Nothing = empty
+    pprQualifier (Just modName) = text (modString modName) <> char '.'
     pprStms []  = empty
     pprStms [s] = ppr s
     pprStms ss  = braces (semiSep ss)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 955f430d33..a894ce8378 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2039,8 +2039,10 @@ data Exp
   | MultiIfE [(Guard, Exp)]            -- ^ @{ if | g1 -> e1 | g2 -> e2 }@
   | LetE [Dec] Exp                     -- ^ @{ let { x=e1; y=e2 } in e3 }@
   | CaseE Exp [Match]                  -- ^ @{ case e of m1; m2 }@
-  | DoE [Stmt]                         -- ^ @{ do { p <- e1; e2 }  }@
-  | MDoE [Stmt]                        -- ^ @{ mdo { x <- e1 y; y <- e2 x; } }@
+  | DoE (Maybe ModName) [Stmt]         -- ^ @{ do { p <- e1; e2 }  }@ or a qualified do if
+                                       -- the module name is present
+  | MDoE (Maybe ModName) [Stmt]        -- ^ @{ mdo { x <- e1 y; y <- e2 x; } }@ or a qualified
+                                       -- mdo if the module name is present
   | CompE [Stmt]                       -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@
       --
       -- The result expression of the comprehension is
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index d3eaa00b4c..0b3aa8d079 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -9,7 +9,7 @@
     written in terms of `Q` are now disallowed. The types of `unsafeTExpCoerce`
     and `unTypeQ` are also generalised in terms of `Quote` rather than specific
     to `Q`.
-    
+
   * Implement Explicit specificity in type variable binders (GHC Proposal #99).
     In `Language.Haskell.TH.Syntax`, `TyVarBndr` is now annotated with a `flag`,
     denoting the additional argument to its constructors `PlainTV` and `KindedTV`.
@@ -26,6 +26,9 @@
 
   * Add `MonadFix` instance for `Q` (#12073).
 
+  * Add support for QualifiedDo. The data constructors `DoE` and `MDoE` got a new
+    `Maybe ModName` argument to describe the qualifier of do blocks.
+
 ## 2.16.0.0 *TBA*
 
   * Add support for tuple sections. (#15843) The type signatures of `TupE` and