diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index eee8baf3e8a..8382b4e53b6 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -150,6 +150,7 @@ library Distribution.Compat.Exception Distribution.Compat.ReadP Distribution.Compiler + Distribution.Glob Distribution.InstalledPackageInfo Distribution.License Distribution.Make diff --git a/Cabal/Distribution/Glob.hs b/Cabal/Distribution/Glob.hs new file mode 100644 index 00000000000..84685e5c9dc --- /dev/null +++ b/Cabal/Distribution/Glob.hs @@ -0,0 +1,109 @@ +module Distribution.Glob ( + parseGlob, + --matchGlob, TODO + GlobPart(..), + Glob +) + where + +import Data.List + ( intersperse ) +import System.FilePath + ( normalise, (), (<.>) + , getSearchPath, takeDirectory, splitFileName + , splitExtension, splitExtensions, splitDirectories ) +import Distribution.Compat.ReadP + +data GlobPart -- ^ A part of a glob. + = Literal FilePath -- ^ Match a file with this exact name. eg + -- "dictionary.txt", matches only "dictionary.txt" + | Choice [Glob] -- ^ Match exactly one of the given (literal) options. + -- eg "{a,b,c}" matches "a", "b", or "c" + | MatchAny -- ^ Match any part of a file or single directory name. + -- eg "jquery.*.js" matches "jquery.1.js", + -- "jquery.2.js", "jquery.3-pre.js"... + | MatchAnyRecursive -- ^ Match any part of a file name, in the current + -- directory, and all subdirectories. eg "**/*Test.hs" + -- matches "GlobTest.hs", "test/HttpTest.hs", + -- "test/examples/ExampleTest.hs"... + deriving (Show, Eq) + +type Glob = [GlobPart] -- ^ A glob that can match any number of files. + +-- Indicates whether a character needs escaping in glob patterns +isSpecialChar :: Char -> Bool +isSpecialChar x = x `elem` "\\{}*" + +showGlobPart :: GlobPart -> FilePath +showGlobPart gp = case gp of + (Literal name) -> + concatMap (\x -> if isSpecialChar x then ['\\', x] else [x]) name + (Choice xs) -> + (\y -> "{" ++ y ++ "}" ) . concat . intersperse "," . map showGlob $ xs + MatchAny -> "*" + MatchAnyRecursive -> "**" + +showGlob :: Glob -> FilePath +showGlob = concatMap showGlobPart + +parseLiteral :: ReadP r GlobPart +parseLiteral = fmap Literal $ many1 literalSegment + where + literalSegment = unspecial +++ escapeSequence + unspecial = satisfy (not . isSpecialChar) + escapeSequence = char '\\' >> satisfy isSpecialChar + +parseChoice :: ReadP r GlobPart +parseChoice = do + _ <- char '{' + choices <- sepBy parseGlob' (char ',') + _ <- char '}' + return $ Choice choices + +parseMatchAny :: ReadP r GlobPart +parseMatchAny = char '*' >> return MatchAny + +parseMatchAnyRecursive :: ReadP r GlobPart +parseMatchAnyRecursive = string "**" >> return MatchAnyRecursive + +parseGlobPart :: ReadP r GlobPart +parseGlobPart = choice + [ parseLiteral + , parseChoice + , parseMatchAny + , parseMatchAnyRecursive + ] + +parseGlob' :: ReadP r Glob +parseGlob' = many1 parseGlobPart + +parseGlob :: FilePath -> Maybe Glob +parseGlob fp = case take 1 completeResults of + (x:_) -> Just $ canonicalise x + [] -> Nothing + where + results = readP_to_S parseGlob' fp + completeResults = map fst $ filter ((== "") . snd) results + +canonicalise :: Glob -> Glob +canonicalise = canonicaliseChoices . dedupBy joinLiterals . dedupBy joinMatchAnys + where + joinLiterals x = case x of + (Literal a, Literal b) -> Just (Literal $ a ++ b) + _ -> Nothing + joinMatchAnys x = case x of + (MatchAny, MatchAny) -> Just MatchAnyRecursive + (MatchAny, MatchAnyRecursive) -> Just MatchAnyRecursive + (MatchAnyRecursive, MatchAny) -> Just MatchAnyRecursive + (MatchAnyRecursive, MatchAnyRecursive) -> Just MatchAnyRecursive + _ -> Nothing + canonicaliseChoices = fmap canonicaliseChoice + canonicaliseChoice x = case x of + Choice xs -> Choice $ fmap canonicalise xs + y -> y + +dedupBy :: ((a, a) -> Maybe a) -> [a] -> [a] +dedupBy f (x:y:ys) = case f (x, y) of + Just z -> dedupBy f $ z : ys + Nothing -> x : (dedupBy f $ y : ys) +dedupBy _ xs = xs diff --git a/Cabal/tests/UnitTests.hs b/Cabal/tests/UnitTests.hs index 3a13ee533e8..1e8474087c9 100644 --- a/Cabal/tests/UnitTests.hs +++ b/Cabal/tests/UnitTests.hs @@ -6,11 +6,14 @@ import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) import Test.Framework import qualified UnitTests.Distribution.Compat.ReadP +import qualified UnitTests.Distribution.Glob tests :: [Test] -tests = [ - testGroup "Distribution.Compat.ReadP" +tests = + [ testGroup "Distribution.Compat.ReadP" UnitTests.Distribution.Compat.ReadP.tests + , testGroup "Distribution.Glob" + UnitTests.Distribution.Glob.tests ] main :: IO () diff --git a/Cabal/tests/UnitTests/Distribution/Glob.hs b/Cabal/tests/UnitTests/Distribution/Glob.hs new file mode 100644 index 00000000000..192a1c66b10 --- /dev/null +++ b/Cabal/tests/UnitTests/Distribution/Glob.hs @@ -0,0 +1,32 @@ +module UnitTests.Distribution.Glob + ( tests + ) where + +import Distribution.Glob +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +tests :: [Test] +tests = + map toTest testData + where + toTest (input, expected) = + testCase ("parseGlob " ++ input) + (assertEqual "" expected (parseGlob input)) + +testData :: [(FilePath, Maybe Glob)] +testData = + [ ("dictionary.txt", Just [Literal "dictionary.txt"]) + , ("test/*.hs", Just [Literal "test/", MatchAny, Literal ".hs"]) + , ("{unterminated,choice", Nothing) + , ("{hello,goodbye}", Just [Choice + [[Literal "hello"], [Literal "goodbye"]]]) + , ("tests/**/*.hs", Just + [ Literal "tests/" + , MatchAnyRecursive + , Literal "/" + , MatchAny + , Literal ".hs" + ]) + ]