Implement bash (with globstar) style globbing

Cabal/Cabal.cabal

@@ -163,6 +163,7 @@ library
     Distribution.Compat.Exception
     Distribution.Compat.ReadP
     Distribution.Compiler
+    Distribution.Utils.Glob
     Distribution.InstalledPackageInfo
     Distribution.License
     Distribution.Make
@@ -241,6 +242,10 @@ library
     Distribution.Simple.GHC.IPI641
     Distribution.Simple.GHC.IPI642
     Distribution.Simple.GHC.ImplInfo
+    Distribution.Utils.Glob.Type
+    Distribution.Utils.Glob.Parse
+    Distribution.Utils.Glob.Match
+    Distribution.Utils.Safe
     Paths_Cabal
 
   if flag(bundled-binary-generic)
@@ -260,6 +265,7 @@ test-suite unit-tests
     UnitTests.Distribution.Compat.ReadP
     UnitTests.Distribution.Simple.Program.Internal
     UnitTests.Distribution.Utils.NubList
+    UnitTests.Distribution.Utils.Glob
   main-is: UnitTests.hs
   build-depends:
     base,

Cabal/Distribution/PackageDescription/Check.hs

@@ -55,7 +55,7 @@ import Distribution.License
 import Distribution.Simple.CCompiler
          ( filenameCDialect )
 import Distribution.Simple.Utils
-         ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase )
+         ( cabalVersion, intercalate, parseFileGlob, isRealGlob, lowercase )
 
 import Distribution.Version
          ( Version(..)
@@ -1098,8 +1098,8 @@ checkCabalVersion pkg =
     dataFilesUsingGlobSyntax     = filter usesGlobSyntax (dataFiles pkg)
     extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg)
     usesGlobSyntax str = case parseFileGlob str of
-      Just (FileGlob _ _) -> True
-      _                   -> False
+      Just g  -> isRealGlob g
+      Nothing -> False
 
     versionRangeExpressions =
         [ dep | dep@(Dependency _ vr) <- buildDepends pkg

Cabal/Distribution/Simple/Utils.hs

@@ -78,11 +78,12 @@ module Distribution.Simple.Utils (
         isInSearchPath,
         addLibraryPath,
 
-        -- * simple file globbing
+        -- * file globbing
         matchFileGlob,
         matchDirFileGlob,
         parseFileGlob,
-        FileGlob(..),
+        Glob(..),
+        isRealGlob,
 
         -- * modification time
         moreRecentFile,
@@ -127,6 +128,7 @@ module Distribution.Simple.Utils (
         ordNubRight,
         wrapText,
         wrapLine,
+        tailMay,
   ) where
 
 import Control.Monad
@@ -156,7 +158,7 @@ import System.Exit
 import System.FilePath
     ( normalise, (</>), (<.>)
     , getSearchPath, joinPath, takeDirectory, splitFileName
-    , splitExtension, splitExtensions, splitDirectories
+    , splitExtension, splitDirectories
     , searchPathSeparator )
 import System.Directory
     ( createDirectory, renameFile, removeDirectoryRecursive )
@@ -199,6 +201,8 @@ import Distribution.Compat.TempFile
 import Distribution.Compat.Exception
          ( tryIO, catchIO, catchExit )
 import Distribution.Verbosity
+import Distribution.Utils.Glob
+import Distribution.Utils.Safe
 
 #ifdef VERSION_base
 import qualified Paths_Cabal (version)
@@ -723,43 +727,22 @@ addLibraryPath os paths = addEnv
 ----------------
 -- File globbing
 
-data FileGlob
-   -- | No glob at all, just an ordinary file
-   = NoGlob FilePath
-
-   -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to
-   --    @FileGlob \"foo\/bar\" \".baz\"@
-   | FileGlob FilePath String
-
-parseFileGlob :: FilePath -> Maybe FileGlob
-parseFileGlob filepath = case splitExtensions filepath of
-  (filepath', ext) -> case splitFileName filepath' of
-    (dir, "*") | '*' `elem` dir
-              || '*' `elem` ext
-              || null ext            -> Nothing
-               | null dir            -> Just (FileGlob "." ext)
-               | otherwise           -> Just (FileGlob dir ext)
-    _          | '*' `elem` filepath -> Nothing
-               | otherwise           -> Just (NoGlob filepath)
-
 matchFileGlob :: FilePath -> IO [FilePath]
 matchFileGlob = matchDirFileGlob "."
 
-matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath]
-matchDirFileGlob dir filepath = case parseFileGlob filepath of
-  Nothing -> die $ "invalid file glob '" ++ filepath
-                ++ "'. Wildcards '*' are only allowed in place of the file"
-                ++ " name, not in the directory name or file extension."
-                ++ " If a wildcard is used it must be with an file extension."
-  Just (NoGlob filepath') -> return [filepath']
-  Just (FileGlob dir' ext) -> do
-    files <- getDirectoryContents (dir </> dir')
-    case   [ dir' </> file
-           | file <- files
-           , let (name, ext') = splitExtensions file
-           , not (null name) && ext' == ext ] of
-      []      -> die $ "filepath wildcard '" ++ filepath
-                    ++ "' does not match any files."
+-- | Return a list of files matching a glob pattern, relative to a given source
+-- directory. Note that not all the returned files are guaranteed to exist.
+matchDirFileGlob :: FilePath -> String -> IO [FilePath]
+matchDirFileGlob dir pattern = case parseFileGlob pattern of
+  Nothing ->
+    die $ "invalid file glob '" ++ pattern ++ "'."
+  Just (NoGlob filepath') ->
+    return [filepath']
+  Just (Glob glob) -> do
+    files <- getDirectoryContentsRecursive dir
+    case filter (realIsMatch glob) files of
+      [] -> die $ "glob pattern '" ++ pattern
+                  ++ "' does not match any files."
       matches -> return matches
 
 --------------------

Cabal/Distribution/Utils/Glob.hs

@@ -0,0 +1,12 @@
+module Distribution.Utils.Glob
+  ( Glob(..)
+  , isRealGlob
+  , parseFileGlob
+  , isMatch
+  , realIsMatch
+  )
+  where
+
+import Distribution.Utils.Glob.Type
+import Distribution.Utils.Glob.Parse
+import Distribution.Utils.Glob.Match

Cabal/Distribution/Utils/Glob/Match.hs

@@ -0,0 +1,103 @@
+module Distribution.Utils.Glob.Match where
+
+import Control.Monad
+    ( (>=>) )
+import Data.Maybe
+    ( listToMaybe )
+import Data.List
+    ( stripPrefix )
+import Distribution.Utils.Safe
+    ( tailMay )
+import Distribution.Utils.Glob.Type
+
+isMatch :: Glob -> FilePath -> Bool
+isMatch (Glob realGlob) fp = realIsMatch realGlob fp
+isMatch (NoGlob fp') fp = fp' == fp
+
+realIsMatch :: RealGlob -> FilePath -> Bool
+realIsMatch (RealGlob parts) fp = isMatch' True parts (toSegments fp)
+
+toSegments :: FilePath -> [String]
+toSegments = filter (not . null) . splitOn '/'
+
+-- Not quite the same as the function from Data.List.Split, but this allows
+-- for a simpler implementation
+splitOn :: Eq a => a -> [a] -> [[a]]
+splitOn _ [] = []
+splitOn splitter list =
+  let (next, rest) = span (/= splitter) list
+  in  next : splitOn splitter (drop 1 rest)
+
+-- | Given:
+-- * A Bool which records whether we are at the beginning of the current
+-- segment
+-- * A list of GlobParts
+-- * A list of path segments in a file path
+-- Return whether the glob parts list matches the file path.
+isMatch' :: Bool -> [GlobPart] -> [String] -> Bool
+isMatch' _ (Literal l : parts) (seg : segs) =
+  case stripPrefix l seg of
+    Just seg' -> isMatch' False parts (seg' : segs)
+    Nothing -> False
+isMatch' _ (PathSeparator : parts) (seg : segs)
+  | seg == "" = isMatch' True parts segs
+  | otherwise = False
+isMatch' _ (CharList cs : parts) ((h:tl) : segs) =
+  if charListIsMatch cs h
+    then isMatch' False parts (tl : segs)
+    else False
+isMatch' _ (CharListComplement cs : parts) ((h:tl) : segs) =
+  if charListIsMatch cs h
+    then False
+    else isMatch' False parts (tl : segs)
+isMatch' startSegment (WildOne : parts) ((h:tl) : segs)
+  | startSegment && h == '.' = False
+  | otherwise = isMatch' False parts (tl : segs)
+isMatch' startSegment (WildMany : parts) segs
+  | startSegment && (listToMaybe >=> listToMaybe) segs == Just '.' = False
+  | otherwise =
+    case segs of
+      first : rest ->
+        let candidates = map (:rest) (iterateWhile tailMay first)
+        in  any (isMatch' False parts) candidates
+      [] ->
+        isMatch' startSegment parts segs
+isMatch' startSegment (WildManyRecursive : parts) segs
+   | startSegment && (listToMaybe >=> listToMaybe) segs == Just '.' = False
+   | otherwise =
+     anyCandidates || handlePathSep
+     where
+     anyCandidates =
+       any (\(start, segs') -> isMatch' start parts segs') candidates
+     candidates = iterateWhile (drop1' . snd) (False, segs)
+     handlePathSep =
+       case parts of
+         PathSeparator : parts' -> isMatch' startSegment parts' segs
+         _ -> False
+
+isMatch' startSegment (Choice gs : parts) segs =
+  any (\g -> isMatch' startSegment (g ++ parts) segs) gs
+isMatch' _ [] [""] = True
+isMatch' _ _ _ = False
+
+charListIsMatch :: [CharListPart] -> Char -> Bool
+charListIsMatch parts c = any (matches c) parts
+  where
+  matches x (CharLiteral y) = x == y
+  matches x (Range start end) = start <= x && x <= end
+
+-- | Drop one character from a list of path segments, or if the first segment
+-- is empty, move on to the next segment.
+drop1' :: [String] -> Maybe (Bool, [String])
+drop1' [] = Nothing
+drop1' ("" : segs) = Just (True, segs)
+drop1' (seg : segs) = Just (False, drop 1 seg : segs)
+
+-- | Generate a list of values obtained by repeatedly applying a function
+-- to an initial value, until it stops returning Just.
+iterateWhile :: (a -> Maybe a) -> a -> [a]
+iterateWhile f x = x : rest
+  where
+  rest = case f x of
+    Just y -> iterateWhile f y
+    Nothing -> []