From d30c7c23588689c71047dbf360f3a04f098a249c Mon Sep 17 00:00:00 2001 From: Nathaniel Burke Date: Wed, 5 Apr 2023 02:11:56 +0100 Subject: [PATCH] Fix behaviour with QualifiedDo We need to get out the module name from `DoExpr` and `MDoExpr`s and potentially print it. --- TESTS.md | 23 +++++++++++ src/HIndent/Pretty.hs | 63 ++++++++++++++++++------------ src/HIndent/Pretty/NodeComments.hs | 6 +++ src/HIndent/Pretty/Types.hs | 8 +++- 4 files changed, 73 insertions(+), 27 deletions(-) diff --git a/TESTS.md b/TESTS.md index 54d713a3a..ff9996199 100644 --- a/TESTS.md +++ b/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 diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs index 82268c889..d2b1ee84f 100644 --- a/src/HIndent/Pretty.hs +++ b/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 {..} = diff --git a/src/HIndent/Pretty/NodeComments.hs b/src/HIndent/Pretty/NodeComments.hs index 83c1ad31a..193d12009 100644 --- a/src/HIndent/Pretty/NodeComments.hs +++ b/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 diff --git a/src/HIndent/Pretty/Types.hs b/src/HIndent/Pretty/Types.hs index 6fbb03063..89728b6d8 100644 --- a/src/HIndent/Pretty/Types.hs +++ b/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