Implement ImportQualifiedPost

3 files changed, 72 insertions, 14 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 3c1ea8cc7d..edad2d90d7 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -2329,6 +2329,7 @@ data ExtBits
   | DoAndIfThenElseBit
   | MultiWayIfBit
   | GadtSyntaxBit
+  | ImportQualifiedPostBit
 
   -- Flags that are updated once parsing starts
   | InRulePragBit
@@ -2415,6 +2416,7 @@ mkParserFlags' warningFlags extensionFlags thisPackage
       .|. DoAndIfThenElseBit          `xoptBit` LangExt.DoAndIfThenElse
       .|. MultiWayIfBit               `xoptBit` LangExt.MultiWayIf
       .|. GadtSyntaxBit               `xoptBit` LangExt.GADTSyntax
+      .|. ImportQualifiedPostBit      `xoptBit` LangExt.ImportQualifiedPost
     optBits =
           HaddockBit        `setBitIf` isHaddock
       .|. RawTokenStreamBit `setBitIf` rawTokStream
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index e6f639edb3..c2dae02afc 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -39,6 +39,7 @@ module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBa
 import Control.Monad    ( unless, liftM, when, (<=<) )
 import GHC.Exts
 import Data.Char
+import Data.Maybe       ( maybeToList )
 import Control.Monad    ( mplus )
 import Control.Applicative ((<$))
 
@@ -955,17 +956,22 @@ importdecls_semi
         | {- empty -}           { [] }
 
 importdecl :: { LImportDecl GhcPs }
-        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
-                {% ams (cL (comb4 $1 $6 (snd $7) $8) $
-                  ImportDecl { ideclExt = noExt
-                             , ideclSourceSrc = snd $ fst $2
-                             , ideclName = $6, ideclPkgQual = snd $5
-                             , ideclSource = snd $2, ideclSafe = snd $3
-                             , ideclQualified = snd $4, ideclImplicit = False
-                             , ideclAs = unLoc (snd $7)
-                             , ideclHiding = unLoc $8 })
-                   ((mj AnnImport $1 : (fst $ fst $2) ++ fst $3 ++ fst $4
-                                    ++ fst $5 ++ fst $7)) }
+        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec
+                {% do {
+                  ; checkImportDecl $4 $7
+                  ; ams (cL (comb4 $1 $6 (snd $8) $9) $
+                      ImportDecl { ideclExt = noExt
+                                  , ideclSourceSrc = snd $ fst $2
+                                  , ideclName = $6, ideclPkgQual = snd $5
+                                  , ideclSource = snd $2, ideclSafe = snd $3
+                                  , ideclQualified = importDeclQualifiedStyle $4 $7
+                                  , ideclImplicit = False
+                                  , ideclAs = unLoc (snd $8)
+                                  , ideclHiding = unLoc $9 })
+                         ((mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList $4)
+                                          ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList $7) ++ fst $8))
+                  }
+                }
 
 maybe_src :: { (([AddAnn],SourceText),IsBootInterface) }
         : '{-# SOURCE' '#-}'        { (([mo $1,mc $2],getSOURCE_PRAGs $1)
@@ -986,9 +992,9 @@ maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
                         ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } }
         | {- empty -}                           { ([],Nothing) }
 
-optqualified :: { ([AddAnn],Bool) }
-        : 'qualified'                           { ([mj AnnQualified $1],True)  }
-        | {- empty -}                           { ([],False) }
+optqualified :: { Maybe (Located Token) }
+        : 'qualified'                           { Just $1 }
+        | {- empty -}                           { Nothing }
 
 maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) }
         : 'as' modid                           { ([mj AnnAs $1]
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 156931dc9f..490fed0384 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -49,6 +49,7 @@ module   RdrHsSyn (
 
         -- Bunch of functions in the parser monad for
         -- checking and constructing values
+        checkImportDecl,
         checkExpBlockArguments,
         checkPrecP,           -- Int -> P Int
         checkContext,         -- HsType -> P HsContext
@@ -81,7 +82,10 @@ module   RdrHsSyn (
 
         -- Warnings and errors
         warnStarIsType,
+        warnPrepositiveQualifiedModule,
         failOpFewArgs,
+        failOpNotEnabledImportQualifiedPost,
+        failOpImportQualifiedTwice,
 
         SumOrTuple (..),
 
@@ -1051,6 +1055,31 @@ checkNoDocs msg ty = go ty
                                   , text "on", msg, quotes (ppr t) ]
     go _ = pure ()
 
+checkImportDecl :: Maybe (Located Token)
+                -> Maybe (Located Token)
+                -> P ()
+checkImportDecl mPre mPost = do
+  let whenJust mg f = maybe (pure ()) f mg
+
+  importQualifiedPostEnabled <- getBit ImportQualifiedPostBit
+
+  -- Error if 'qualified' found in postpostive position and
+  -- 'ImportQualifiedPost' is not in effect.
+  whenJust mPost $ \post ->
+    when (not importQualifiedPostEnabled) $
+      failOpNotEnabledImportQualifiedPost (getLoc post)
+
+  -- Error if 'qualified' occurs in both pre and postpositive
+  -- positions.
+  whenJust mPost $ \post ->
+    when (isJust mPre) $
+      failOpImportQualifiedTwice (getLoc post)
+
+  -- Warn if 'qualified' found in prepositive position and
+  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.
+  whenJust mPre $ \pre ->
+    warnPrepositiveQualifiedModule (getLoc pre)
+
 -- -------------------------------------------------------------------------
 -- Checking Patterns.
 
@@ -2945,6 +2974,27 @@ isImpExpQcWildcard _                = False
 -----------------------------------------------------------------------------
 -- Warnings and failures
 
+warnPrepositiveQualifiedModule :: SrcSpan -> P ()
+warnPrepositiveQualifiedModule span =
+  addWarning Opt_WarnPrepositiveQualifiedModule span msg
+  where
+    msg = text "Found" <+> quotes (text "qualified")
+           <+> text "in prepositive position"
+       $$ text "Suggested fix: place " <+> quotes (text "qualified")
+           <+> text "after the module name instead."
+
+failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()
+failOpNotEnabledImportQualifiedPost loc = addError loc msg
+  where
+    msg = text "Found" <+> quotes (text "qualified")
+          <+> text "in postpositive position. "
+      $$ text "To allow this, enable language extension 'ImportQualifiedPost'"
+
+failOpImportQualifiedTwice :: SrcSpan -> P ()
+failOpImportQualifiedTwice loc = addError loc msg
+  where
+    msg = text "Multiple occurences of 'qualified'"
+
 warnStarIsType :: SrcSpan -> P ()
 warnStarIsType span = addWarning Opt_WarnStarIsType span msg
   where