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.

40 files changed, 466 insertions, 2 deletions

diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index c1c9502863..9a11780dc5 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -41,6 +41,7 @@ expectedGhcOnlyExtensions =
     , "AlternativeLayoutRule"
     , "AlternativeLayoutRuleTransitional"
     , "LinearTypes"
+    , "QualifiedDo"
     ]
 
 expectedCabalOnlyExtensions :: [String]
diff --git a/testsuite/tests/qualifieddo/Makefile b/testsuite/tests/qualifieddo/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/qualifieddo/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/qualifieddo/should_compile/Makefile b/testsuite/tests/qualifieddo/should_compile/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_compile/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/qualifieddo/should_compile/all.T b/testsuite/tests/qualifieddo/should_compile/all.T
new file mode 100644
index 0000000000..a22dc0a4dc
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_compile/all.T
@@ -0,0 +1,4 @@
+setTestOpts(only_ways(['normal']));
+
+test('qdocompile001', normal, compile, ['-v0 -ddump-rn -dsuppress-uniques'])
+test('qdocompile002', normal, compile, ['-v0'])
diff --git a/testsuite/tests/qualifieddo/should_compile/qdocompile001.hs b/testsuite/tests/qualifieddo/should_compile/qdocompile001.hs
new file mode 100644
index 0000000000..a9b749c170
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_compile/qdocompile001.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE QualifiedDo #-}
+
+import Prelude as P
+
+-- Test that the context of the do shows well in the renamer
+-- output.
+--
+-- The nested do in the renamer output must be qualified the
+-- same as the outer P.do written in the source program.
+--
+-- > ==================== Renamer ====================
+-- > Main.main
+-- >   = print
+-- >       $ P.do (x <- [1, 2] |
+-- >               y <- P.do y@1 <- [1, 2] -- qualified!
+-- >                         [1, 2]
+-- >                         y)
+-- >               return y
+--
+main =
+  print $ P.do
+    x <- [1, 2]
+    y@1 <- [1, 2]
+    [1, 2]
+    P.return y
diff --git a/testsuite/tests/qualifieddo/should_compile/qdocompile001.stderr b/testsuite/tests/qualifieddo/should_compile/qdocompile001.stderr
new file mode 100644
index 0000000000..da47e331c9
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_compile/qdocompile001.stderr
@@ -0,0 +1,9 @@
+
+==================== Renamer ====================
+Main.main
+  = print
+      $ P.do (x <- [1, 2] |
+              y <- P.do y@1 <- [1, 2]
+                        [1, 2]
+                        y)
+             return y
diff --git a/testsuite/tests/qualifieddo/should_compile/qdocompile002.hs b/testsuite/tests/qualifieddo/should_compile/qdocompile002.hs
new file mode 100644
index 0000000000..bbbee88ac5
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_compile/qdocompile002.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE QualifiedDo #-}
+
+import Prelude as P hiding (fail)
+
+
+-- Tests that fail is not required with irrefutable patterns
+main =
+  print $ P.do
+    x <- [1, 2]
+    (_, y) <- [(1, "a"), (2, "b")]
+    P.return (x, y)
diff --git a/testsuite/tests/qualifieddo/should_fail/Makefile b/testsuite/tests/qualifieddo/should_fail/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/qualifieddo/should_fail/all.T b/testsuite/tests/qualifieddo/should_fail/all.T
new file mode 100644
index 0000000000..f16a2c994b
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/all.T
@@ -0,0 +1,7 @@
+setTestOpts(only_ways(['normal']));
+
+test('qdofail001', normal, compile_fail, ['-v0'])
+test('qdofail002', normal, compile_fail, ['-v0'])
+test('qdofail003', normal, compile_fail, ['-v0'])
+test('qdofail004', normal, compile_fail, ['-v0'])
+test('qdofail005', normal, compile_fail, ['-v0'])
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail001.hs b/testsuite/tests/qualifieddo/should_fail/qdofail001.hs
new file mode 100644
index 0000000000..1543a72218
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail001.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE QualifiedDo #-}
+
+import Prelude as P
+
+
+-- Tests that qualified dos show up in type-checking errors.
+main = do
+  print $ P.do
+    x <- [1, 2]
+    y@' ' <- [1, 2 :: Int]
+    [1, 2]
+    P.return y
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail001.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail001.stderr
new file mode 100644
index 0000000000..62cc54e2df
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail001.stderr
@@ -0,0 +1,10 @@
+
+qdofail001.hs:11:7:
+     Couldn't match expected type ‘Int’ with actual type ‘Char’
+     In the pattern: ' '
+      In a stmt of a qualified 'do' block: y@' ' <- [1, 2 :: Int]
+      In the second argument of ‘($)’, namely
+        ‘P.do x <- [1, 2]
+              y@' ' <- [1, 2 :: Int]
+              [1, 2]
+              return y’
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail002.hs b/testsuite/tests/qualifieddo/should_fail/qdofail002.hs
new file mode 100644
index 0000000000..38d3bfc816
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail002.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE RecursiveDo #-}
+import Prelude as P
+
+
+-- Tests that the compiler suggests using -XQualifiedDo
+-- when the user qualifies a do.
+main = do
+  print $ P.do
+    x <- [1, 2]
+    P.return x
+  print 1 $ P.mdo
+    x <- [1, 2]
+    P.return x
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail002.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail002.stderr
new file mode 100644
index 0000000000..5948678eb8
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail002.stderr
@@ -0,0 +1,8 @@
+
+qdofail002.hs:8:11:
+    Illegal qualified ‘P.do’ block
+    Perhaps you intended to use QualifiedDo
+
+qdofail002.hs:11:13:
+    Illegal qualified ‘P.mdo’ block
+    Perhaps you intended to use QualifiedDo
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail003.hs b/testsuite/tests/qualifieddo/should_fail/qdofail003.hs
new file mode 100644
index 0000000000..17cf6af64c
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail003.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE QualifiedDo #-}
+
+import Prelude as P hiding ((>>))
+
+
+-- Tests that an out-of-scope (>>) is reported
+main = do
+  print $ P.do
+    x <- [1, 2]
+    y <- [1, 2]
+    [1, 2]
+    P.return (x, y)
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail003.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail003.stderr
new file mode 100644
index 0000000000..5137ae40c0
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail003.stderr
@@ -0,0 +1,8 @@
+
+qdofail003.hs:11:5:
+    Not in scope: ‘P.>>’
+    Perhaps you meant one of these:
+      ‘P.*>’ (imported from Prelude), ‘P.<>’ (imported from Prelude),
+      ‘P.>>=’ (imported from Prelude)
+    Perhaps you want to remove ‘>>’ from the explicit hiding list
+    in the import of ‘Prelude’ (qdofail003.hs:3:1-33).
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail004.hs b/testsuite/tests/qualifieddo/should_fail/qdofail004.hs
new file mode 100644
index 0000000000..caba6e0e6b
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail004.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE QualifiedDo #-}
+
+import Prelude as P hiding (fail)
+
+
+-- Tests that fail is required with refutable patterns
+main = do
+  print $ P.do
+    x <- [1, 2]
+    (1, y) <- [(1, "a"), (2, "b")]
+    P.return (x, y)
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail004.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail004.stderr
new file mode 100644
index 0000000000..66a3fea529
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail004.stderr
@@ -0,0 +1,8 @@
+
+qdofail004.hs:10:5:
+    Not in scope: ‘P.fail’
+    Perhaps you meant one of these:
+      ‘P.tail’ (imported from Prelude), ‘P.all’ (imported from Prelude),
+      ‘P.flip’ (imported from Prelude)
+    Perhaps you want to remove ‘fail’ from the explicit hiding list
+    in the import of ‘Prelude’ (qdofail004.hs:3:1-33).
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail005.hs b/testsuite/tests/qualifieddo/should_fail/qdofail005.hs
new file mode 100644
index 0000000000..8fc08e1a24
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail005.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE QualifiedDo #-}
+
+import Control.Arrow
+import Prelude as P
+
+main = runKleisli kleisliIO 1
+
+-- Tests the error message when a qualified do
+-- is used in a command.
+kleisliIO = proc x -> P.do
+    y <- arr id -< x+1
+    Kleisli print -< 2*y
+    let z = x+y
+    t <- arr id -< x*z
+    returnA -< t+z
diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail005.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail005.stderr
new file mode 100644
index 0000000000..8d49e1d3ba
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_fail/qdofail005.stderr
@@ -0,0 +1,5 @@
+
+qdofail005.hs:11:23:
+    Parse error in command:
+      Found a qualified P.do block in a command, but
+      qualified 'do' is not supported in commands.
diff --git a/testsuite/tests/qualifieddo/should_run/Makefile b/testsuite/tests/qualifieddo/should_run/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/qualifieddo/should_run/Monad/Graded.hs b/testsuite/tests/qualifieddo/should_run/Monad/Graded.hs
new file mode 100644
index 0000000000..78f7f30b57
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/Monad/Graded.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module Monad.Graded where
+
+import Data.Kind (Constraint, Type)
+import Prelude (const, id)
+
+class GradedMonad (m :: k -> Type -> Type) where
+  type Unit m :: k
+  type Plus m (i :: k) (j :: k) :: k
+  type Inv  m (i :: k) (j :: k) :: Constraint
+  (>>=) :: Inv m i j => m i a -> (a -> m j b) -> m (Plus m i j) b
+  return :: a -> m (Unit m) a
+
+(>>) :: (GradedMonad m, Inv m i j) => m i a -> m j b -> m (Plus m i j) b
+m >> n = m >>= const n
+
+join :: (GradedMonad m, Inv m i j) => m i (m j a) -> m (Plus m i j) a
+join m = m >>= id
diff --git a/testsuite/tests/qualifieddo/should_run/Monad/Linear.hs b/testsuite/tests/qualifieddo/should_run/Monad/Linear.hs
new file mode 100644
index 0000000000..df7f2775c8
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/Monad/Linear.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LinearTypes #-}
+module Monad.Linear where
+
+import Prelude(Int, (+))
+
+data T where T :: Int -> T
+data TM a = TM a
+
+class Monad m where
+  return :: a #-> m a
+  (>>=) :: m a #-> (a #-> m b) #-> m b
+
+(>>) :: Monad m => m () #-> m b #-> m b
+m1 >> m2 = m1 >>= \() -> m2
+
+instance Monad TM where
+  return = TM
+  TM a >>= f = f a
+
+data Unrestricted a where
+  Unrestricted :: a -> Unrestricted a
+
+runTM :: TM (Unrestricted a) -> a
+runTM (TM (Unrestricted a)) = a
+
+newT :: TM T
+newT = return (T 0)
+
+increaseT :: T #-> TM T
+increaseT (T i) = return (T (i+1))
+
+extractT :: T #-> TM (T, Unrestricted Int)
+extractT (T i) = return (T i, Unrestricted i)
+
+deleteT :: T #-> TM ()
+deleteT (T _) = return ()
diff --git a/testsuite/tests/qualifieddo/should_run/Vector.hs b/testsuite/tests/qualifieddo/should_run/Vector.hs
new file mode 100644
index 0000000000..e1cc49e44d
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/Vector.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Vector
+  ( Vector(..)
+  , toList
+  , vAppend
+    -- exported for QualifiedDo
+  , fmap
+  , (<*>)
+  , pure
+  , fail
+  , mfix
+  ) where
+
+import Data.Function (fix)
+import Data.Maybe (fromMaybe)
+import Monad.Graded
+import Prelude hiding ((>>=), fail, pure, return, (<*>))
+
+
+data Nat = Zero | Succ Nat
+
+data Vector n a where
+  VNil :: Vector Zero a
+  VCons :: a -> Vector n a -> Vector (Succ n) a
+
+instance Functor (Vector n) where
+  fmap f = \case
+    VNil -> VNil
+    VCons a v -> VCons (f a) (fmap f v)
+
+vAppend :: Vector m a -> Vector n a -> Vector (Add m n) a
+vAppend VNil v = v
+vAppend (VCons a u) v = VCons a (vAppend u v)
+
+toList :: Vector n a -> [a]
+toList = \case
+  VNil -> []
+  VCons a v -> a : toList v
+
+fail :: String -> Vector n a
+fail = error
+
+class VRepeat n where
+  vRepeat :: a -> Vector n a
+instance VRepeat Zero where
+  vRepeat _ = VNil
+instance VRepeat n => VRepeat (Succ n) where
+  vRepeat a = VCons a (vRepeat a)
+
+type family Add m n :: Nat where
+  Add Zero n = n
+  Add (Succ m) n = Succ (Add m n)
+
+type family Times m n :: Nat where
+  Times Zero n = Zero
+  Times (Succ m) n = Add n (Times m n)
+
+instance GradedMonad Vector where
+  type Unit Vector = Succ Zero
+  type Plus Vector i j = Times i j
+  type Inv  Vector i j = ()
+  v >>= f = case v of
+    VNil -> VNil
+    VCons a v -> vAppend (f a) (v >>= f)
+  return a = VCons a VNil
+
+vHead :: Vector (Succ n) a -> a
+vHead (VCons a _) = a
+
+vTail :: Vector (Succ n) a -> Vector n a
+vTail (VCons _ v) = v
+
+mfix :: forall a n. Show a => (a -> Vector n a) -> Vector n a
+mfix f = case fix (f . unsafeHead) of
+    VNil -> VNil
+    VCons x _ -> VCons x (mfix (vTail . f))
+  where
+    unsafeHead :: Vector n a -> a
+    unsafeHead = \case
+      VNil -> error "VNil"
+      VCons a _ -> a
+
+pure :: a -> Vector (Succ Zero) a
+pure = return
+
+(<*>) :: Vector m (a -> b) -> Vector n a -> Vector (Times m n) b
+VNil <*> _ = VNil
+VCons _ v <*> VNil = v <*> VNil
+VCons f vf <*> v = vAppend (fmap f v) (vf <*> v)
diff --git a/testsuite/tests/qualifieddo/should_run/all.T b/testsuite/tests/qualifieddo/should_run/all.T
new file mode 100644
index 0000000000..17cf2f0d7b
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/all.T
@@ -0,0 +1,11 @@
+setTestOpts(only_ways(['normal']));
+
+qextra_files = extra_files(['Vector.hs', 'Monad'])
+
+test('qdorun001', [qextra_files], multimod_compile_and_run, ['qdorun001', ''])
+test('qdorun002', [qextra_files], multimod_compile_and_run, ['qdorun002', ''])
+test('qdorun003', [qextra_files], multimod_compile_and_run, ['qdorun003', ''])
+test('qdorun004', normal, compile_and_run, [''])
+test('qdorun005', [qextra_files], multimod_compile_and_run, ['qdorun005', ''])
+test('qdorun006', [qextra_files], multimod_compile_and_run, ['qdorun006', ''])
+test('qdorun007', [qextra_files], multimod_compile_and_run, ['qdorun007', ''])
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun001.hs b/testsuite/tests/qualifieddo/should_run/qdorun001.hs
new file mode 100644
index 0000000000..5c81d2babf
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun001.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE QualifiedDo #-}
+
+import qualified Monad.Graded as Graded
+import Vector as Graded
+
+
+main = do
+  putStrLn "The unqualified do still works."
+  print $ toList $ Graded.do
+    x <- VCons 1 (VCons 2 VNil)
+    y <- VCons 1 (VCons 2 VNil)
+    Graded.return (x, y)
+  -- test Graded.fail
+  print $ toList $ Graded.do
+    1 <- VCons 1 VNil
+    Graded.return 1
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun001.stdout b/testsuite/tests/qualifieddo/should_run/qdorun001.stdout
new file mode 100644
index 0000000000..a604b4a395
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun001.stdout
@@ -0,0 +1,3 @@
+The unqualified do still works.
+[(1,1),(1,2),(2,1),(2,2)]
+[1]
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun002.hs b/testsuite/tests/qualifieddo/should_run/qdorun002.hs
new file mode 100644
index 0000000000..31010310d1
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun002.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE RecursiveDo #-}
+
+import qualified Monad.Graded as Graded
+import Vector as Graded
+
+
+main = do
+  print $ take 6 $ concat $ toList $ Graded.do
+    rec
+      VCons (take 6 y) VNil
+      y <- VCons (1 : zipWith (+) y (0 : y)) VNil
+    Graded.return y
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun002.stdout b/testsuite/tests/qualifieddo/should_run/qdorun002.stdout
new file mode 100644
index 0000000000..01d885946e
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun002.stdout
@@ -0,0 +1 @@
+[1,1,2,3,5,8]
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun003.hs b/testsuite/tests/qualifieddo/should_run/qdorun003.hs
new file mode 100644
index 0000000000..a155139514
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun003.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE QualifiedDo #-}
+
+import qualified Monad.Graded as Graded
+import Vector as Graded
+
+
+main = do
+  print $ toList $ Graded.do
+    x <- VCons 1 (VCons 2 VNil)
+    y <- VCons 1 (VCons 2 VNil)
+    Graded.return (x, y)
+  -- Test Graded.join
+  print $ toList $ Graded.do
+    x <- VCons 1 (VCons 2 VNil)
+    y <- VCons 1 (VCons 2 VNil)
+    VCons (y, x) VNil
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun003.stdout b/testsuite/tests/qualifieddo/should_run/qdorun003.stdout
new file mode 100644
index 0000000000..ba08850cb4
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun003.stdout
@@ -0,0 +1,2 @@
+[(1,1),(1,2),(2,1),(2,2)]
+[(1,1),(2,1),(1,2),(2,2)]
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun004.hs b/testsuite/tests/qualifieddo/should_run/qdorun004.hs
new file mode 100644
index 0000000000..151f44473e
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun004.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE RecursiveDo #-}
+import qualified Control.Monad.Fix as P
+import Prelude (print, ($))
+import qualified Prelude as P
+
+return :: a -> [a]
+return x = [x, x]
+
+-- Tests that QualifiedDo doesn't affect return
+main = do
+  print $ P.do
+    x <- [1, 2]
+    return x
+  print $ P.mdo
+    x <- [1, 2]
+    return x
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun004.stdout b/testsuite/tests/qualifieddo/should_run/qdorun004.stdout
new file mode 100644
index 0000000000..d7d00ba1c3
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun004.stdout
@@ -0,0 +1,2 @@
+[1,1,2,2]
+[1,1,2,2]
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun005.hs b/testsuite/tests/qualifieddo/should_run/qdorun005.hs
new file mode 100644
index 0000000000..52ecae76fa
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun005.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE RebindableSyntax #-}
+import qualified Monad.Graded as Graded
+import Vector
+import Prelude (print, ($))
+import qualified Prelude as P
+
+xs >>= f = 'c' : P.concatMap f xs
+(>>) = (P.>>)
+
+main = do
+  print $ toList $ Graded.do
+    x <- VCons 'a' (VCons 'b' VNil)
+    Graded.return x
+  print $ do
+    a <- ['a', 'b']
+    P.return a
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun005.stdout b/testsuite/tests/qualifieddo/should_run/qdorun005.stdout
new file mode 100644
index 0000000000..f7f72c9098
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun005.stdout
@@ -0,0 +1,2 @@
+"ab"
+"cab"
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun006.hs b/testsuite/tests/qualifieddo/should_run/qdorun006.hs
new file mode 100644
index 0000000000..a795b0d251
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun006.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+import qualified Monad.Graded as Graded
+import Vector as Graded
+
+
+main = do
+  print $ toList $([| Graded.do
+    x <- VCons 1 (VCons 2 VNil)
+    y <- VCons 1 (VCons 2 VNil)
+    Graded.return (x, y) |])
+  print $ toList $([| Graded.mdo
+    z <- VCons (take 8 y) VNil
+    y <- VCons (1 : zipWith (+) y (0 : y)) VNil
+    Graded.return z |])
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun006.stdout b/testsuite/tests/qualifieddo/should_run/qdorun006.stdout
new file mode 100644
index 0000000000..0280d625f8
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun006.stdout
@@ -0,0 +1,2 @@
+[(1,1),(1,2),(2,1),(2,2)]
+[[1,1,2,3,5,8,13,21]]
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun007.hs b/testsuite/tests/qualifieddo/should_run/qdorun007.hs
new file mode 100644
index 0000000000..189c045e58
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun007.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE QualifiedDo #-}
+-- Tests that QualfiedDo works for a linear monad.
+
+import Monad.Linear as Linear
+
+
+main = do
+  let r = runTM (Linear.do
+        t0 <- newT
+        t1 <- increaseT t0
+        (t2, ur) <- extractT t1
+        deleteT t2
+        Linear.return ur)
+  print r
+  print r
diff --git a/testsuite/tests/qualifieddo/should_run/qdorun007.stdout b/testsuite/tests/qualifieddo/should_run/qdorun007.stdout
new file mode 100644
index 0000000000..6ed281c757
--- /dev/null
+++ b/testsuite/tests/qualifieddo/should_run/qdorun007.stdout
@@ -0,0 +1,2 @@
+1
+1
diff --git a/testsuite/tests/th/T2597b_Lib.hs b/testsuite/tests/th/T2597b_Lib.hs
index 395166b0b6..bed83fc5bf 100644
--- a/testsuite/tests/th/T2597b_Lib.hs
+++ b/testsuite/tests/th/T2597b_Lib.hs
@@ -6,4 +6,4 @@ import Language.Haskell.TH
 
 
 mkBug2 :: ExpQ
-mkBug2 = return $ DoE []
+mkBug2 = return $ DoE Nothing []
diff --git a/testsuite/tests/th/T9022.hs b/testsuite/tests/th/T9022.hs
index fc61691da1..9c676aa7d0 100644
--- a/testsuite/tests/th/T9022.hs
+++ b/testsuite/tests/th/T9022.hs
@@ -10,7 +10,7 @@ foo = barD
        barD = FunD ( mkName "bar" )
                    [ Clause manyArgs (NormalB barBody) [] ]
 
-       barBody = DoE [letxStmt, retxStmt]
+       barBody = DoE Nothing [letxStmt, retxStmt]
        letxStmt = LetS [ ValD (VarP xName) (NormalB $ LitE $ IntegerL 5) [] ]
        retxStmt = NoBindS $ AppE returnVarE xVarE
        xName = mkName "x"