diff options
| -rw-r--r-- | compiler/parser/Parser.y | 12 | ||||
| -rw-r--r-- | compiler/utils/Util.hs | 15 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_fail/T9225.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_fail/T9225.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_fail/all.T | 1 |
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, ['']) |