Syntax check package-qualified imports (#9225)

Version numbers are not allowed in the package name of a
package-qualified import.

Reviewed By: austin, ezyang

Differential Revision: https://phabricator.haskell.org/D755

5 files changed, 34 insertions, 2 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 9389708c67..d6b7ed6d15 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -84,6 +84,9 @@ import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataC
                           unboxedUnitTyCon, unboxedUnitDataCon,
                           listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
 
+-- compiler/utils
+import Util             ( looksLikePackageName )
+
 }
 
 {- Last updated: 03 Mar 2015
@@ -774,8 +777,13 @@ maybe_safe :: { ([AddAnn],Bool) }
         | {- empty -}                           { ([],False) }
 
 maybe_pkg :: { ([AddAnn],Maybe FastString) }
-        : STRING                                { ([mj AnnPackageName $1]
-                                                  ,Just (getSTRING $1)) }
+        : STRING  {% let pkgFS = getSTRING $1 in
+                     if looksLikePackageName (unpackFS pkgFS)
+                        then return ([mj AnnPackageName $1], Just pkgFS)
+                        else parseErrorSDoc (getLoc $1) $ vcat [
+                             text "parse error" <> colon <+> quotes (ppr pkgFS),
+                             text "Version number or non-alphanumeric" <+>
+                             text "character in package name"] }
         | {- empty -}                           { ([],Nothing) }
 
 optqualified :: { ([AddAnn],Bool) }
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index ddcfe1117b..732f2b8f6b 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -67,6 +67,7 @@ module Util (
 
         -- * Module names
         looksLikeModuleName,
+        looksLikePackageName,
 
         -- * Argument processing
         getCmd, toCmdArgs, toArgs,
@@ -115,6 +116,10 @@ import Data.List        hiding (group)
 import FastTypes
 #endif
 
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative (Applicative)
+#endif
+import Control.Applicative ( liftA2 )
 import Control.Monad    ( liftM )
 import System.IO.Error as IO ( isDoesNotExistError )
 import System.Directory ( doesDirectoryExist, getModificationTime )
@@ -655,6 +660,11 @@ cmpList cmp (a:as) (b:bs)
 removeSpaces :: String -> String
 removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace
 
+-- Boolean operators lifted to Applicative
+(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
+(<&&>) = liftA2 (&&)
+infixr 3 <&&> -- same as (&&)
+
 {-
 ************************************************************************
 *                                                                      *
@@ -822,6 +832,11 @@ looksLikeModuleName (c:cs) = isUpper c && go cs
         go ('.':cs) = looksLikeModuleName cs
         go (c:cs)   = (isAlphaNum c || c == '_' || c == '\'') && go cs
 
+-- Similar to 'parse' for Distribution.Package.PackageName,
+-- but we don't want to depend on Cabal.
+looksLikePackageName :: String -> Bool
+looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-'
+
 {-
 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 quoted strings as Haskell Strings, and also parses Haskell [String]
diff --git a/testsuite/tests/parser/should_fail/T9225.hs b/testsuite/tests/parser/should_fail/T9225.hs
new file mode 100644
index 0000000000..8122779b63
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T9225.hs
@@ -0,0 +1,4 @@
+module T9225 where
+-- Should be a parse error:
+-- version numbers not allowed in package qualified imports
+import "some-package-0.1.2.3" Some.Module
diff --git a/testsuite/tests/parser/should_fail/T9225.stderr b/testsuite/tests/parser/should_fail/T9225.stderr
new file mode 100644
index 0000000000..abbfd0ad7e
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T9225.stderr
@@ -0,0 +1,4 @@
+
+T9225.hs:4:8:
+    parse error: ‘some-package-0.1.2.3’
+    Version number or non-alphanumeric character in package name
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 7e286cf3f2..0352235180 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -86,3 +86,4 @@ test('ExportCommaComma', normal, compile_fail, [''])
 test('T8430', literate, compile_fail, [''])
 test('T8431', [timeout_multiplier(0.05)], compile_fail, ['-XAlternativeLayoutRule'])
 test('T8506', normal, compile_fail, [''])
+test('T9225', normal, compile_fail, [''])