Fix behaviour with QualifiedDo

CHANGELOG.md

@@ -12,7 +12,7 @@
 
 ### Fixed
 
-- ...
+- Fixed module names being removed from uses of qualified `do` ([#696]).
 
 ### Removed
 
@@ -338,6 +338,7 @@ This version is accidentally pushlished, and is the same as 5.3.3.
 [@uhbif19]: https://github.com/uhbif19
 [@toku-sa-n]: https://github.com/toku-sa-n
 
+[#696]: https://github.com/mihaimaruseac/hindent/pull/696
 [#672]: https://github.com/mihaimaruseac/hindent/pull/672
 [#671]: https://github.com/mihaimaruseac/hindent/pull/671
 [#670]: https://github.com/mihaimaruseac/hindent/pull/670

TESTS.md

@@ -2299,6 +2299,29 @@ g = mdo
   bar
 ```
 
+#### `QualifiedDo`
+
+Qualified do
+
+```haskell
+{-# LANGUAGE QualifiedDo #-}
+
+f = Module.Path.do
+  a <- foo
+  return a
+```
+
+Qualified do with `mdo`
+
+```haskell
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE QualifiedDo #-}
+
+f = Module.Path.mdo
+  a <- foo
+  return a
+```
+
 ### Function applications
 
 Long line, tuple

src/HIndent/Pretty.hs

@@ -553,12 +553,13 @@ prettyHsExpr (HsIf _ cond t f) = do
     branch :: String -> LHsExpr GhcPs -> Printer ()
     branch str e =
       case e of
-        (L _ (HsDo _ DoExpr {} xs)) -> doStmt "do" xs
-        (L _ (HsDo _ MDoExpr {} xs)) -> doStmt "mdo" xs
+        (L _ (HsDo _ (DoExpr m) xs)) -> doStmt (QualifiedDo m Do) xs
+        (L _ (HsDo _ (MDoExpr m) xs)) -> doStmt (QualifiedDo m Mdo) xs
         _ -> string str |=> pretty e
       where
-        doStmt pref stmts = do
-          string $ str ++ pref
+        doStmt qDo stmts = do
+          string str
+          pretty qDo
           newline
           indentedBlock $ printCommentsAnd stmts (lined . fmap pretty)
 prettyHsExpr (HsMultiIf _ guards) =
@@ -578,8 +579,10 @@ prettyHsExpr (HsDo _ MonadComp {} (L _ [])) =
   error "Not enough arguments are passed to pretty-print a list comprehension."
 prettyHsExpr (HsDo _ MonadComp {} (L l (lhs:rhs))) =
   pretty $ L l $ ListComprehension lhs rhs
-prettyHsExpr (HsDo _ DoExpr {} (L l xs)) = pretty $ L l $ DoExpression xs Do
-prettyHsExpr (HsDo _ MDoExpr {} (L l xs)) = pretty $ L l $ DoExpression xs Mdo
+prettyHsExpr (HsDo _ (DoExpr m) (L l xs)) =
+  pretty $ L l $ DoExpression xs (QualifiedDo m Do)
+prettyHsExpr (HsDo _ (MDoExpr m) (L l xs)) =
+  pretty $ L l $ DoExpression xs (QualifiedDo m Mdo)
 prettyHsExpr (HsDo _ GhciStmtCtxt {} _) = error "We're not using GHCi, are we?"
 prettyHsExpr (ExplicitList _ xs) = horizontal <-|> vertical
   where
@@ -1165,18 +1168,18 @@ instance Pretty GRHSExpr where
     space
     rhsSeparator grhsExprType
     case unLoc body of
-      HsDo _ DoExpr {} stmts ->
-        printCommentsAnd body (const (doExpr "do" stmts))
-      HsDo _ MDoExpr {} stmts ->
-        printCommentsAnd body (const (doExpr "mdo" stmts))
+      HsDo _ (DoExpr m) stmts ->
+        printCommentsAnd body (const (doExpr (QualifiedDo m Do) stmts))
+      HsDo _ (MDoExpr m) stmts ->
+        printCommentsAnd body (const (doExpr (QualifiedDo m Mdo) stmts))
       _ ->
         let hor = space >> pretty body
             ver = newline >> indentedBlock (pretty body)
          in hor <-|> ver
     where
-      doExpr pref stmts = do
+      doExpr qDo stmts = do
         space
-        string pref
+        pretty qDo
         newline
         indentedBlock $ printCommentsAnd stmts (lined . fmap pretty)
   pretty' (GRHSExpr {grhsExpr = (GRHS _ guards body), ..}) = do
@@ -1188,16 +1191,16 @@ instance Pretty GRHSExpr where
       space
       rhsSeparator grhsExprType
       printCommentsAnd body $ \case
-        HsDo _ DoExpr {} stmts -> doExpr "do" stmts
-        HsDo _ MDoExpr {} stmts -> doExpr "mdo" stmts
+        HsDo _ (DoExpr m) stmts -> doExpr (QualifiedDo m Do) stmts
+        HsDo _ (MDoExpr m) stmts -> doExpr (QualifiedDo m Mdo) stmts
         x ->
           let hor = space >> pretty x
               ver = newline >> indentedBlock (pretty x)
            in hor <-|> ver
     where
-      doExpr pref stmts = do
+      doExpr qDo stmts = do
         space
-        string pref
+        pretty qDo
         let hor = space >> printCommentsAnd stmts (lined . fmap pretty)
             ver = do
               newline
@@ -1480,12 +1483,14 @@ instance Pretty InfixApp where
               pretty (InfixExpr op)
               return newline
         case unLoc rhs of
-          (HsDo _ (DoExpr _) xs) -> do
-            string " do"
+          (HsDo _ (DoExpr m) xs) -> do
+            space
+            pretty (QualifiedDo m Do)
             newline
             indentedBlock $ printCommentsAnd xs (lined . fmap pretty)
-          (HsDo _ (MDoExpr _) xs) -> do
-            string " mdo"
+          (HsDo _ (MDoExpr m) xs) -> do
+            space
+            pretty (QualifiedDo m Mdo)
             newline
             indentedBlock $ printCommentsAnd xs (lined . fmap pretty)
           HsLam {} -> do
@@ -2157,12 +2162,18 @@ instance Pretty ListComprehension where
 
 instance Pretty DoExpression where
   pretty' DoExpression {..} =
-    (string pref >> space) |=> lined (fmap pretty doStmts)
-    where
-      pref =
-        case doOrMdo of
-          Do -> "do"
-          Mdo -> "mdo"
+    (pretty qualifiedDo >> space) |=> lined (fmap pretty doStmts)
+
+instance Pretty DoOrMdo where
+  pretty' Do = string "do"
+  pretty' Mdo = string "mdo"
+
+instance Pretty QualifiedDo where
+  pretty' (QualifiedDo (Just m) d) = do
+    pretty m
+    string "."
+    pretty d
+  pretty' (QualifiedDo Nothing d) = pretty d
 
 instance Pretty LetIn where
   pretty' LetIn {..} =

src/HIndent/Pretty/NodeComments.hs

@@ -126,6 +126,12 @@ instance CommentExtraction (HsExpr GhcPs) where
 instance CommentExtraction LambdaCase where
   nodeComments (LambdaCase x _) = nodeComments x
 
+instance CommentExtraction DoOrMdo where
+  nodeComments = const emptyNodeComments
+
+instance CommentExtraction QualifiedDo where
+  nodeComments = const emptyNodeComments
+
 nodeCommentsHsExpr :: HsExpr GhcPs -> NodeComments
 nodeCommentsHsExpr HsVar {} = emptyNodeComments
 nodeCommentsHsExpr (HsUnboundVar x _) = nodeComments x

src/HIndent/Pretty/Types.hs

@@ -45,6 +45,7 @@ module HIndent.Pretty.Types
   , ListComprehension(..)
   , DoExpression(..)
   , DoOrMdo(..)
+  , QualifiedDo(..)
   , LetIn(..)
   , NodeComments(..)
   , GRHSExprType(..)
@@ -277,7 +278,7 @@ data ListComprehension = ListComprehension
 -- | Use this type to pretty-print a do expression.
 data DoExpression = DoExpression
   { doStmts :: [ExprLStmt GhcPs]
-  , doOrMdo :: DoOrMdo
+  , qualifiedDo :: QualifiedDo
   }
 
 -- | Use this type to pretty-print a @let ... in ...@ expression.
@@ -298,6 +299,11 @@ data DoOrMdo
   = Do
   | Mdo
 
+-- | Values indicating whether the `do` is qualified with a module name (and
+-- whether `do` or `mdo` is used)
+data QualifiedDo =
+  QualifiedDo (Maybe ModuleName) DoOrMdo
+
 -- | Values indicating in which context a RHS is located.
 data GRHSExprType
   = GRHSExprNormal