diff options
Diffstat (limited to 'compiler/GHC/Parser/PostProcess.hs')
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 50 |
1 files changed, 30 insertions, 20 deletions
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 018ce7bb60..398bd78ddc 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -112,6 +112,7 @@ import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) import GHC.Types.Name.Reader import GHC.Types.Name +import GHC.Unit.Module (ModuleName) import GHC.Types.Basic import GHC.Parser.Lexer import GHC.Utils.Lexeme ( isLexCon ) @@ -978,32 +979,33 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () (checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) where checkExpr :: LHsExpr GhcPs -> PV () - checkExpr expr = case unLoc expr of - HsDo _ DoExpr _ -> check "do block" expr - HsDo _ MDoExpr _ -> check "mdo block" expr - HsLam {} -> check "lambda expression" expr - HsCase {} -> check "case expression" expr - HsLamCase {} -> check "lambda-case expression" expr - HsLet {} -> check "let expression" expr - HsIf {} -> check "if expression" expr - HsProc {} -> check "proc expression" expr + checkExpr expr = do + case unLoc expr of + HsDo _ (DoExpr m) _ -> check (prependQualified m (text "do block")) expr + HsDo _ (MDoExpr m) _ -> check (prependQualified m (text "mdo block")) expr + HsLam {} -> check (text "lambda expression") expr + HsCase {} -> check (text "case expression") expr + HsLamCase {} -> check (text "lambda-case expression") expr + HsLet {} -> check (text "let expression") expr + HsIf {} -> check (text "if expression") expr + HsProc {} -> check (text "proc expression") expr _ -> return () checkCmd :: LHsCmd GhcPs -> PV () checkCmd cmd = case unLoc cmd of - HsCmdLam {} -> check "lambda command" cmd - HsCmdCase {} -> check "case command" cmd - HsCmdIf {} -> check "if command" cmd - HsCmdLet {} -> check "let command" cmd - HsCmdDo {} -> check "do command" cmd + HsCmdLam {} -> check (text "lambda command") cmd + HsCmdCase {} -> check (text "case command") cmd + HsCmdIf {} -> check (text "if command") cmd + HsCmdLet {} -> check (text "let command") cmd + HsCmdDo {} -> check (text "do command") cmd _ -> return () - check :: Outputable a => String -> Located a -> PV () + check :: Outputable a => SDoc -> Located a -> PV () check element a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $ addError (getLoc a) $ - text "Unexpected " <> text element <> text " in function application:" + text "Unexpected " <> element <> text " in function application:" $$ nest 4 (ppr a) $$ text "You could write it with parentheses" $$ text "Or perhaps you meant to enable BlockArguments?" @@ -1814,7 +1816,11 @@ class b ~ (Body b) GhcPs => DisambECP b where -> Located b -> PV (Located b) -- | Disambiguate "do { ... }" (do notation) - mkHsDoPV :: SrcSpan -> Located [LStmt GhcPs (Located b)] -> PV (Located b) + mkHsDoPV :: + SrcSpan -> + Maybe ModuleName -> + Located [LStmt GhcPs (Located b)] -> + PV (Located b) -- | Disambiguate "( ... )" (parentheses) mkHsParPV :: SrcSpan -> Located b -> PV (Located b) -- | Disambiguate a variable "f" or a data constructor "MkF". @@ -1923,7 +1929,11 @@ instance DisambECP (HsCmd GhcPs) where mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b return $ L l (mkHsCmdIf c a b) - mkHsDoPV l stmts = return $ L l (HsCmdDo noExtField stmts) + mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts) + mkHsDoPV l (Just m) _ = + cmdFail l $ + text "Found a qualified" <+> ppr m <> text ".do block in a command, but" + $$ text "qualified 'do' is not supported in commands." mkHsParPV l c = return $ L l (HsCmdPar noExtField c) mkHsVarPV (L l v) = cmdFail l (ppr v) mkHsLitPV (L l a) = cmdFail l (ppr a) @@ -1983,7 +1993,7 @@ instance DisambECP (HsExpr GhcPs) where mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b return $ L l (mkHsIf c a b) - mkHsDoPV l stmts = return $ L l (HsDo noExtField DoExpr stmts) + mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts) mkHsParPV l e = return $ L l (HsPar noExtField e) mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v) mkHsLitPV (L l a) = return $ L l (HsLit noExtField a) @@ -2065,7 +2075,7 @@ instance DisambECP (PatBuilder GhcPs) where mkHsAppTypePV l _ _ = addFatalError l $ text "Type applications in patterns are not yet supported" mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern" - mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern" + mkHsDoPV l _ _ = addFatalError l $ text "do-notation in pattern" mkHsParPV l p = return $ L l (PatBuilderPar p) mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v) mkHsLitPV lit@(L l a) = do |