Bash (globstar) style globbing

Cabal/Cabal.cabal

@@ -150,6 +150,7 @@ library
     Distribution.Compat.Exception
     Distribution.Compat.ReadP
     Distribution.Compiler
+    Distribution.Glob
     Distribution.InstalledPackageInfo
     Distribution.License
     Distribution.Make

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

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 ()

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"
+        ])
+    ]