diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs
index 22e3af46843e801b83c9c451487eec62bee13e1d..fce1ffbc050a633bf37855090fe27ee603df348d 100644
--- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs
+++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
module UnitTests.Distribution.Simple.Glob
( tests
) where
@@ -54,7 +55,7 @@ compatibilityTests version =
[ testCase "literal match" $
testMatches "foo/a" [GlobMatch "foo/a"]
, testCase "literal no match on prefix" $
- testMatches "foo/c.html" []
+ testMatches "foo/c.html" [GlobMatchesDirectory "foo/c.html"]
, testCase "literal no match on suffix" $
testMatches "foo/a.html" [GlobMatch "foo/a.html"]
, testCase "literal no prefix" $
@@ -64,7 +65,7 @@ compatibilityTests version =
, testCase "glob" $
testMatches "*.html" [GlobMatch "a.html", GlobMatch "b.html"]
, testCase "glob in subdir" $
- testMatches "foo/*.html" [GlobMatch "foo/a.html", GlobMatch "foo/b.html"]
+ testMatches "foo/*.html" [GlobMatchesDirectory "foo/c.html", GlobMatch "foo/b.html", GlobMatch "foo/a.html"]
, testCase "glob multiple extensions" $
testMatches "foo/*.html.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/b.html.gz"]
, testCase "glob in deep subdir" $
@@ -101,13 +102,16 @@ testMatchesVersion version pat expected = do
where
isEqual = (==) `on` (sort . fmap (fmap normalise))
checkPure globPat = do
- let actual = mapMaybe (fileGlobMatches globPat) sampleFileNames
- unless (sort expected == sort actual) $
+ let actual = mapMaybe (\p -> (p <$) <$> fileGlobMatches version globPat p) sampleFileNames
+ -- We drop directory matches from the expected results since the pure
+ -- check can't identify that kind of match.
+ expected' = filter (\case GlobMatchesDirectory _ -> False; _ -> True) expected
+ unless (sort expected' == sort actual) $
assertFailure $ "Unexpected result (pure matcher): " ++ show actual
checkIO globPat =
withSystemTempDirectory "globstar-sample" $ \tmpdir -> do
makeSampleFiles tmpdir
- actual <- runDirFileGlob Verbosity.normal tmpdir globPat
+ actual <- runDirFileGlob Verbosity.normal (Just version) tmpdir globPat
unless (isEqual actual expected) $
assertFailure $ "Unexpected result (impure matcher): " ++ show actual
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
index 42f0a2989847d9b6a29b3025ba10045892065684..5fd54ba7f9e6646a1d0bb488eac6cd25540f2624 100644
--- a/Cabal/Cabal.cabal
+++ b/Cabal/Cabal.cabal
@@ -108,6 +108,7 @@ library
Distribution.Simple.GHCJS
Distribution.Simple.Haddock
Distribution.Simple.Glob
+ Distribution.Simple.Glob.Internal
Distribution.Simple.HaskellSuite
Distribution.Simple.Hpc
Distribution.Simple.Install
diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
index 1893d05014c2192b65df3a6c3493d21406406545..43f8bf0d2a43755824664342df02140a7ea0ef84 100644
--- a/Cabal/src/Distribution/PackageDescription/Check.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -61,9 +61,20 @@ import Distribution.PackageDescription.Check.Warning
import Distribution.Parsec.Warning (PWarning)
import Distribution.Pretty (prettyShow)
import Distribution.Simple.Glob
+ ( Glob
+ , GlobResult (..)
+ , globMatches
+ , parseFileGlob
+ , runDirFileGlob
+ )
import Distribution.Simple.Utils hiding (findPackageDesc, notice)
import Distribution.Utils.Generic (isAscii)
import Distribution.Utils.Path
+ ( LicenseFile
+ , PackageDir
+ , SymbolicPath
+ , getSymbolicPath
+ )
import Distribution.Verbosity
import Distribution.Version
import System.FilePath (splitExtension, takeFileName, (<.>), (</>))
@@ -170,7 +181,7 @@ checkPackageFilesGPD verbosity gpd root =
checkPreIO =
CheckPreDistributionOps
- { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (root </> fp) g
+ { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root </> fp) g
, getDirectoryContentsM = System.Directory.getDirectoryContents . relative
}
@@ -853,13 +864,14 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
[PackageDistSuspiciousWarn $ GlobNoMatch title fp]
| otherwise = []
- -- If there's a missing directory in play, since our globs don't
- -- (currently) support disjunction, that will always mean there are
+ -- If there's a missing directory in play, since globs in Cabal packages
+ -- don't (currently) support disjunction, that will always mean there are
-- no matches. The no matches error in this case is strictly less
-- informative than the missing directory error.
withoutNoMatchesWarning (GlobMatch _) = True
withoutNoMatchesWarning (GlobWarnMultiDot _) = False
withoutNoMatchesWarning (GlobMissingDirectory _) = True
+ withoutNoMatchesWarning (GlobMatchesDirectory _) = True
getWarning :: GlobResult FilePath -> Maybe PackageCheck
getWarning (GlobMatch _) = Nothing
@@ -871,6 +883,9 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file)
getWarning (GlobMissingDirectory dir) =
Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir)
+ -- GlobMatchesDirectory is handled elsewhere if relevant;
+ -- we can discard it here.
+ getWarning (GlobMatchesDirectory _) = Nothing
-- ------------------------------------------------------------
-- Other exports
@@ -1012,10 +1027,6 @@ checkMissingDocs dgs esgs edgs = do
return (mcs ++ pcs)
)
where
- -- From Distribution.Simple.Glob.
- globMatches :: [GlobResult a] -> [a]
- globMatches input = [a | GlobMatch a <- input]
-
checkDoc
:: Bool -- Cabal spec ≥ 1.18?
-> [FilePath] -- Desirables.
diff --git a/Cabal/src/Distribution/PackageDescription/Check/Paths.hs b/Cabal/src/Distribution/PackageDescription/Check/Paths.hs
index f389c6797be443308c09ba797b17cb1244bc31f0..5b2df1f18fa95ca9c7443f63f63bf70192904571 100644
--- a/Cabal/src/Distribution/PackageDescription/Check/Paths.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check/Paths.hs
@@ -24,6 +24,11 @@ import Distribution.PackageDescription.Check.Common
import Distribution.PackageDescription.Check.Monad
import Distribution.Simple.CCompiler
import Distribution.Simple.Glob
+ ( Glob
+ , explainGlobSyntaxError
+ , isRecursiveInRoot
+ , parseFileGlob
+ )
import Distribution.Simple.Utils hiding (findPackageDesc, notice)
import System.FilePath (splitDirectories, splitPath, takeExtension)
diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs
index 67abe7e2da484bf9927c6f03770d2e762e1781bb..9ce97d7555b0803b2b22d2baa16d92f8dadbde39 100644
--- a/Cabal/src/Distribution/Simple/Glob.hs
+++ b/Cabal/src/Distribution/Simple/Glob.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
@@ -15,219 +15,53 @@
--
-- Simple file globbing.
module Distribution.Simple.Glob
- ( GlobSyntaxError (..)
+ ( -- * Globs
+ Glob
+
+ -- * Matching on globs
, GlobResult (..)
+ , globMatches
+ , fileGlobMatches
, matchDirFileGlob
, matchDirFileGlobWithDie
, runDirFileGlob
- , fileGlobMatches
+
+ -- * Parsing globs
, parseFileGlob
+ , GlobSyntaxError (..)
, explainGlobSyntaxError
+
+ -- * Utility
, isRecursiveInRoot
- , Glob
- ) where
+ )
+where
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.CabalSpecVersion
-import Distribution.Simple.Utils
-import Distribution.Verbosity
-
-import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
-import System.FilePath (joinPath, splitDirectories, splitExtensions, takeFileName, (<.>), (</>))
-
-import qualified Data.List.NonEmpty as NE
+import Distribution.CabalSpecVersion (CabalSpecVersion)
import Distribution.Simple.Errors
+ ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors)
+ )
+import Distribution.Simple.Glob.Internal
+import Distribution.Simple.Utils (dieWithException, warn)
+import Distribution.Verbosity (Verbosity)
+
+-------------------------------------------------------------------------------
--- Note throughout that we use splitDirectories, not splitPath. On
--- Posix, this makes no difference, but, because Windows accepts both
--- slash and backslash as its path separators, if we left in the
--- separators from the glob we might not end up properly normalised.
+-- * Matching
-data GlobResult a
- = -- | The glob matched the value supplied.
- GlobMatch a
- | -- | The glob did not match the value supplied because the
- -- cabal-version is too low and the extensions on the file did
- -- not precisely match the glob's extensions, but rather the
- -- glob was a proper suffix of the file's extensions; i.e., if
- -- not for the low cabal-version, it would have matched.
- GlobWarnMultiDot a
- | -- | The glob couldn't match because the directory named doesn't
- -- exist. The directory will be as it appears in the glob (i.e.,
- -- relative to the directory passed to 'matchDirFileGlob', and,
- -- for 'data-files', relative to 'data-dir').
- GlobMissingDirectory FilePath
- deriving (Show, Eq, Ord, Functor)
+--------------------------------------------------------------------------------
-- | Extract the matches from a list of 'GlobResult's.
--
-- Note: throws away the 'GlobMissingDirectory' results; chances are
-- that you want to check for these and error out if any are present.
+--
+-- @since 3.12.0.0
globMatches :: [GlobResult a] -> [a]
globMatches input = [a | GlobMatch a <- input]
-data GlobSyntaxError
- = StarInDirectory
- | StarInFileName
- | StarInExtension
- | NoExtensionOnStar
- | EmptyGlob
- | LiteralFileNameGlobStar
- | VersionDoesNotSupportGlobStar
- | VersionDoesNotSupportGlob
- deriving (Eq, Show)
-
-explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String
-explainGlobSyntaxError filepath StarInDirectory =
- "invalid file glob '"
- ++ filepath
- ++ "'. A wildcard '**' is only allowed as the final parent"
- ++ " directory. Stars must not otherwise appear in the parent"
- ++ " directories."
-explainGlobSyntaxError filepath StarInExtension =
- "invalid file glob '"
- ++ filepath
- ++ "'. Wildcards '*' are only allowed as the"
- ++ " file's base name, not in the file extension."
-explainGlobSyntaxError filepath StarInFileName =
- "invalid file glob '"
- ++ filepath
- ++ "'. Wildcards '*' may only totally replace the"
- ++ " file's base name, not only parts of it."
-explainGlobSyntaxError filepath NoExtensionOnStar =
- "invalid file glob '"
- ++ filepath
- ++ "'. If a wildcard '*' is used it must be with an file extension."
-explainGlobSyntaxError filepath LiteralFileNameGlobStar =
- "invalid file glob '"
- ++ filepath
- ++ "'. Prior to 'cabal-version: 3.8'"
- ++ " if a wildcard '**' is used as a parent directory, the"
- ++ " file's base name must be a wildcard '*'."
-explainGlobSyntaxError _ EmptyGlob =
- "invalid file glob. A glob cannot be the empty string."
-explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar =
- "invalid file glob '"
- ++ filepath
- ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"
- ++ " or greater. Alternatively, for compatibility with earlier Cabal"
- ++ " versions, list the included directories explicitly."
-explainGlobSyntaxError filepath VersionDoesNotSupportGlob =
- "invalid file glob '"
- ++ filepath
- ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "
- ++ "Alternatively if you require compatibility with earlier Cabal "
- ++ "versions then list all the files explicitly."
-
-data IsRecursive = Recursive | NonRecursive deriving (Eq)
-
-data MultiDot = MultiDotDisabled | MultiDotEnabled
-
-data Glob
- = -- | A single subdirectory component + remainder.
- GlobStem FilePath Glob
- | GlobFinal GlobFinal
-
-data GlobFinal
- = -- | First argument: Is this a @**/*.ext@ pattern?
- -- Second argument: should we match against the exact extensions, or accept a suffix?
- -- Third argument: the extensions to accept.
- FinalMatch IsRecursive MultiDot String
- | -- | Literal file name.
- FinalLit IsRecursive FilePath
-
-reconstructGlob :: Glob -> FilePath
-reconstructGlob (GlobStem dir glob) =
- dir </> reconstructGlob glob
-reconstructGlob (GlobFinal final) = case final of
- FinalMatch Recursive _ exts -> "**" </> "*" <.> exts
- FinalMatch NonRecursive _ exts -> "*" <.> exts
- FinalLit Recursive path -> "**" </> path
- FinalLit NonRecursive path -> path
-
--- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the
--- result if the glob matched (or would have matched with a higher
--- cabal-version).
-fileGlobMatches :: Glob -> FilePath -> Maybe (GlobResult FilePath)
-fileGlobMatches pat candidate = do
- match <- fileGlobMatchesSegments pat (splitDirectories candidate)
- return (candidate <$ match)
-
-fileGlobMatchesSegments :: Glob -> [FilePath] -> Maybe (GlobResult ())
-fileGlobMatchesSegments _ [] = Nothing
-fileGlobMatchesSegments pat (seg : segs) = case pat of
- GlobStem dir pat' -> do
- guard (dir == seg)
- fileGlobMatchesSegments pat' segs
- GlobFinal final -> case final of
- FinalMatch Recursive multidot ext -> do
- let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg :| segs)
- guard (not (null candidateBase))
- checkExt multidot ext candidateExts
- FinalMatch NonRecursive multidot ext -> do
- let (candidateBase, candidateExts) = splitExtensions seg
- guard (null segs && not (null candidateBase))
- checkExt multidot ext candidateExts
- FinalLit isRecursive filename -> do
- guard ((isRecursive == Recursive || null segs) && filename == seg)
- return (GlobMatch ())
-
-checkExt
- :: MultiDot
- -> String
- -- ^ The pattern's extension
- -> String
- -- ^ The candidate file's extension
- -> Maybe (GlobResult ())
-checkExt multidot ext candidate
- | ext == candidate = Just (GlobMatch ())
- | ext `isSuffixOf` candidate = case multidot of
- MultiDotDisabled -> Just (GlobWarnMultiDot ())
- MultiDotEnabled -> Just (GlobMatch ())
- | otherwise = Nothing
-
-parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob
-parseFileGlob version filepath = case reverse (splitDirectories filepath) of
- [] ->
- Left EmptyGlob
- (filename : "**" : segments)
- | allowGlobStar -> do
- finalSegment <- case splitExtensions filename of
- ("*", ext)
- | '*' `elem` ext -> Left StarInExtension
- | null ext -> Left NoExtensionOnStar
- | otherwise -> Right (FinalMatch Recursive multidot ext)
- _ ->
- if allowLiteralFilenameGlobStar
- then Right (FinalLit Recursive filename)
- else Left LiteralFileNameGlobStar
- foldM addStem (GlobFinal finalSegment) segments
- | otherwise -> Left VersionDoesNotSupportGlobStar
- (filename : segments) -> do
- pat <- case splitExtensions filename of
- ("*", ext)
- | not allowGlob -> Left VersionDoesNotSupportGlob
- | '*' `elem` ext -> Left StarInExtension
- | null ext -> Left NoExtensionOnStar
- | otherwise -> Right (FinalMatch NonRecursive multidot ext)
- (_, ext)
- | '*' `elem` ext -> Left StarInExtension
- | '*' `elem` filename -> Left StarInFileName
- | otherwise -> Right (FinalLit NonRecursive filename)
- foldM addStem (GlobFinal pat) segments
- where
- allowGlob = version >= CabalSpecV1_6
- allowGlobStar = version >= CabalSpecV2_4
- addStem pat seg
- | '*' `elem` seg = Left StarInDirectory
- | otherwise = Right (GlobStem seg pat)
- multidot
- | version >= CabalSpecV2_4 = MultiDotEnabled
- | otherwise = MultiDotDisabled
- allowLiteralFilenameGlobStar = version >= CabalSpecV3_8
-
-- | This will 'die'' when the glob matches no files, or if the glob
-- refers to a missing directory, or if the glob fails to parse.
--
@@ -247,14 +81,21 @@ matchDirFileGlob v = matchDirFileGlobWithDie v dieWithException
-- | Like 'matchDirFileGlob' but with customizable 'die'
--
-- @since 3.6.0.0
-matchDirFileGlobWithDie :: Verbosity -> (Verbosity -> CabalException -> IO [FilePath]) -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]
+matchDirFileGlobWithDie
+ :: Verbosity
+ -> (Verbosity -> CabalException -> IO [FilePath])
+ -> CabalSpecVersion
+ -> FilePath
+ -> FilePath
+ -> IO [FilePath]
matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob version filepath of
Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError filepath err)
Right glob -> do
- results <- runDirFileGlob verbosity dir glob
+ results <- runDirFileGlob verbosity (Just version) dir glob
let missingDirectories =
[missingDir | GlobMissingDirectory missingDir <- results]
matches = globMatches results
+ directoryMatches = [a | GlobMatchesDirectory a <- results]
let errors :: [String]
errors =
@@ -267,89 +108,20 @@ matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob
| missingDir <- missingDirectories
]
++ [ "filepath wildcard '" ++ filepath ++ "' does not match any files."
- | null matches
+ | null matches && null directoryMatches
+ -- we don't error out on directory matches, simply warn about them and ignore.
]
+ warns :: [String]
+ warns =
+ [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)."
+ | path <- directoryMatches
+ ]
+
if null errors
- then return matches
+ then do
+ unless (null warns) $
+ warn verbosity $
+ unlines warns
+ return matches
else rip verbosity $ MatchDirFileGlobErrors errors
-
--- | Match files against a pre-parsed glob, starting in a directory.
---
--- The 'Version' argument must be the spec version of the package
--- description being processed, as globs behave slightly differently
--- in different spec versions.
---
--- The 'FilePath' argument is the directory that the glob is relative
--- to. It must be a valid directory (and hence it can't be the empty
--- string). The returned values will not include this prefix.
-runDirFileGlob :: Verbosity -> FilePath -> Glob -> IO [GlobResult FilePath]
-runDirFileGlob verbosity rawDir pat = do
- -- The default data-dir is null. Our callers -should- be
- -- converting that to '.' themselves, but it's a certainty that
- -- some future call-site will forget and trigger a really
- -- hard-to-debug failure if we don't check for that here.
- when (null rawDir) $
- warn verbosity $
- "Null dir passed to runDirFileGlob; interpreting it "
- ++ "as '.'. This is probably an internal error."
- let dir = if null rawDir then "." else rawDir
- debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'."
- -- This function might be called from the project root with dir as
- -- ".". Walking the tree starting there involves going into .git/
- -- and dist-newstyle/, which is a lot of work for no reward, so
- -- extract the constant prefix from the pattern and start walking
- -- there, and only walk as much as we need to: recursively if **,
- -- the whole directory if *, and just the specific file if it's a
- -- literal.
- let (prefixSegments, final) = splitConstantPrefix pat
- joinedPrefix = joinPath prefixSegments
- case final of
- FinalMatch recursive multidot exts -> do
- let prefix = dir </> joinedPrefix
- directoryExists <- doesDirectoryExist prefix
- if directoryExists
- then do
- candidates <- case recursive of
- Recursive -> getDirectoryContentsRecursive prefix
- NonRecursive -> filterM (doesFileExist . (prefix </>)) =<< getDirectoryContents prefix
- let checkName candidate = do
- let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate
- guard (not (null candidateBase))
- match <- checkExt multidot exts candidateExts
- return (joinedPrefix </> candidate <$ match)
- return $ mapMaybe checkName candidates
- else return [GlobMissingDirectory joinedPrefix]
- FinalLit Recursive fn -> do
- let prefix = dir </> joinedPrefix
- directoryExists <- doesDirectoryExist prefix
- if directoryExists
- then do
- candidates <- getDirectoryContentsRecursive prefix
- let checkName candidate
- | takeFileName candidate == fn = Just $ GlobMatch (joinedPrefix </> candidate)
- | otherwise = Nothing
- return $ mapMaybe checkName candidates
- else return [GlobMissingDirectory joinedPrefix]
- FinalLit NonRecursive fn -> do
- exists <- doesFileExist (dir </> joinedPrefix </> fn)
- return [GlobMatch (joinedPrefix </> fn) | exists]
-
-unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)
-unfoldr' f a = case f a of
- Left r -> ([], r)
- Right (b, a') -> case unfoldr' f a' of
- (bs, r) -> (b : bs, r)
-
--- | Extract the (possibly null) constant prefix from the pattern.
--- This has the property that, if @(pref, final) = splitConstantPrefix pat@,
--- then @pat === foldr GlobStem (GlobFinal final) pref@.
-splitConstantPrefix :: Glob -> ([FilePath], GlobFinal)
-splitConstantPrefix = unfoldr' step
- where
- step (GlobStem seg pat) = Right (seg, pat)
- step (GlobFinal pat) = Left pat
-
-isRecursiveInRoot :: Glob -> Bool
-isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) = True
-isRecursiveInRoot _ = False
diff --git a/Cabal/src/Distribution/Simple/Glob/Internal.hs b/Cabal/src/Distribution/Simple/Glob/Internal.hs
new file mode 100644
index 0000000000000000000000000000000000000000..4f0b91eca3954ae45e490e9fa00bb567ad6eda20
--- /dev/null
+++ b/Cabal/src/Distribution/Simple/Glob/Internal.hs
@@ -0,0 +1,497 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+
+-----------------------------------------------------------------------------
+
+-- |
+-- Module : Distribution.Simple.Glob.Internal
+-- Copyright : Isaac Jones, Simon Marlow 2003-2004
+-- License : BSD3
+-- portions Copyright (c) 2007, Galois Inc.
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Internal module for simple file globbing.
+-- Please import "Distribution.Simple.Glob" instead.
+module Distribution.Simple.Glob.Internal where
+
+import Distribution.Compat.Prelude
+import Prelude ()
+
+import Control.Monad (mapM)
+
+import Distribution.Parsec
+import Distribution.Pretty
+
+import Distribution.CabalSpecVersion
+import Distribution.Simple.Utils
+import Distribution.Verbosity hiding (normal)
+
+import Data.List (stripPrefix)
+import System.Directory
+import System.FilePath
+
+import qualified Distribution.Compat.CharParsing as P
+import qualified Text.PrettyPrint as Disp
+
+--------------------------------------------------------------------------------
+
+-- | A filepath specified by globbing.
+data Glob
+ = -- | @<dirGlob>/<glob>@
+ GlobDir !GlobPieces !Glob
+ | -- | @**/<glob>@, where @**@ denotes recursively traversing
+ -- all directories and matching filenames on <glob>.
+ GlobDirRecursive !GlobPieces
+ | -- | A file glob.
+ GlobFile !GlobPieces
+ | -- | Trailing dir; a glob ending in @/@.
+ GlobDirTrailing
+ deriving (Eq, Show, Generic)
+
+instance Binary Glob
+instance Structured Glob
+
+-- | A single directory or file component of a globbed path
+type GlobPieces = [GlobPiece]
+
+-- | A piece of a globbing pattern
+data GlobPiece
+ = -- | A wildcard @*@
+ WildCard
+ | -- | A literal string @dirABC@
+ Literal String
+ | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@
+ Union [GlobPieces]
+ deriving (Eq, Show, Generic)
+
+instance Binary GlobPiece
+instance Structured GlobPiece
+
+-------------------------------------------------------------------------------
+
+-- * Matching
+
+--------------------------------------------------------------------------------
+
+-- | Match a 'Glob' against the file system, starting from a
+-- given root directory. The results are all relative to the given root.
+--
+-- @since 3.12.0.0
+matchGlob :: FilePath -> Glob -> IO [FilePath]
+matchGlob root glob =
+ -- For this function, which is the general globbing one (doesn't care about
+ -- cabal spec, used e.g. for monitoring), we consider all matches.
+ mapMaybe
+ ( \case
+ GlobMatch a -> Just a
+ GlobWarnMultiDot a -> Just a
+ GlobMatchesDirectory a -> Just a
+ GlobMissingDirectory{} -> Nothing
+ )
+ <$> runDirFileGlob silent Nothing root glob
+
+-- | Match a globbing pattern against a file path component
+matchGlobPieces :: GlobPieces -> String -> Bool
+matchGlobPieces = goStart
+ where
+ -- From the man page, glob(7):
+ -- "If a filename starts with a '.', this character must be
+ -- matched explicitly."
+
+ go, goStart :: [GlobPiece] -> String -> Bool
+
+ goStart (WildCard : _) ('.' : _) = False
+ goStart (Union globs : rest) cs =
+ any
+ (\glob -> goStart (glob ++ rest) cs)
+ globs
+ goStart rest cs = go rest cs
+
+ go [] "" = True
+ go (Literal lit : rest) cs
+ | Just cs' <- stripPrefix lit cs =
+ go rest cs'
+ | otherwise = False
+ go [WildCard] "" = True
+ go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs
+ go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs
+ go [] (_ : _) = False
+ go (_ : _) "" = False
+
+-------------------------------------------------------------------------------
+
+-- * Parsing & printing
+
+--------------------------------------------------------------------------------
+-- Filepaths with globs may be parsed in the special context is globbing in
+-- cabal package fields, such as `data-files`. In that case, we restrict the
+-- globbing syntax to that supported by the cabal spec version in use.
+-- Otherwise, we parse the globs to the extent of our globbing features
+-- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`).
+
+-- ** Parsing globs in a cabal package
+
+parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob
+parseFileGlob version filepath = case reverse (splitDirectories filepath) of
+ [] ->
+ Left EmptyGlob
+ (filename : "**" : segments)
+ | allowGlobStar -> do
+ finalSegment <- case splitExtensions filename of
+ ("*", ext)
+ | '*' `elem` ext -> Left StarInExtension
+ | null ext -> Left NoExtensionOnStar
+ | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext])
+ _
+ | allowLiteralFilenameGlobStar ->
+ Right (GlobDirRecursive [Literal filename])
+ | otherwise ->
+ Left LiteralFileNameGlobStar
+
+ foldM addStem finalSegment segments
+ | otherwise -> Left VersionDoesNotSupportGlobStar
+ (filename : segments) -> do
+ pat <- case splitExtensions filename of
+ ("*", ext)
+ | not allowGlob -> Left VersionDoesNotSupportGlob
+ | '*' `elem` ext -> Left StarInExtension
+ | null ext -> Left NoExtensionOnStar
+ | otherwise -> Right (GlobFile [WildCard, Literal ext])
+ (_, ext)
+ | '*' `elem` ext -> Left StarInExtension
+ | '*' `elem` filename -> Left StarInFileName
+ | otherwise -> Right (GlobFile [Literal filename])
+
+ foldM addStem pat segments
+ where
+ addStem pat seg
+ | '*' `elem` seg = Left StarInDirectory
+ | otherwise = Right (GlobDir [Literal seg] pat)
+ allowGlob = version >= CabalSpecV1_6
+ allowGlobStar = version >= CabalSpecV2_4
+ allowLiteralFilenameGlobStar = version >= CabalSpecV3_8
+
+enableMultidot :: CabalSpecVersion -> Bool
+enableMultidot version
+ | version >= CabalSpecV2_4 = True
+ | otherwise = False
+
+-- ** Parsing globs otherwise
+
+instance Pretty Glob where
+ pretty (GlobDir glob pathglob) =
+ dispGlobPieces glob
+ Disp.<> Disp.char '/'
+ Disp.<> pretty pathglob
+ pretty (GlobDirRecursive glob) =
+ Disp.text "**/"
+ Disp.<> dispGlobPieces glob
+ pretty (GlobFile glob) = dispGlobPieces glob
+ pretty GlobDirTrailing = Disp.empty
+
+instance Parsec Glob where
+ parsec = parsecPath
+ where
+ parsecPath :: CabalParsing m => m Glob
+ parsecPath = do
+ glob <- parsecGlob
+ dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
+ -- We could support parsing recursive directory search syntax
+ -- @**@ here too, rather than just in 'parseFileGlob'
+
+ dirSep :: CabalParsing m => m ()
+ dirSep =
+ () <$ P.char '/'
+ <|> P.try
+ ( do
+ _ <- P.char '\\'
+ -- check this isn't an escape code
+ P.notFollowedBy (P.satisfy isGlobEscapedChar)
+ )
+
+ parsecGlob :: CabalParsing m => m GlobPieces
+ parsecGlob = some parsecPiece
+ where
+ parsecPiece = P.choice [literal, wildcard, union]
+
+ wildcard = WildCard <$ P.char '*'
+ union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))
+ literal = Literal <$> some litchar
+
+ litchar = normal <|> escape
+
+ normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')
+ escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar
+
+--------------------------------------------------------------------------------
+-- Parse and printing utils
+--------------------------------------------------------------------------------
+
+dispGlobPieces :: GlobPieces -> Disp.Doc
+dispGlobPieces = Disp.hcat . map dispPiece
+ where
+ dispPiece WildCard = Disp.char '*'
+ dispPiece (Literal str) = Disp.text (escape str)
+ dispPiece (Union globs) =
+ Disp.braces
+ ( Disp.hcat
+ ( Disp.punctuate
+ (Disp.char ',')
+ (map dispGlobPieces globs)
+ )
+ )
+ escape [] = []
+ escape (c : cs)
+ | isGlobEscapedChar c = '\\' : c : escape cs
+ | otherwise = c : escape cs
+
+isGlobEscapedChar :: Char -> Bool
+isGlobEscapedChar '*' = True
+isGlobEscapedChar '{' = True
+isGlobEscapedChar '}' = True
+isGlobEscapedChar ',' = True
+isGlobEscapedChar _ = False
+
+-- ** Cabal package globbing errors
+
+data GlobSyntaxError
+ = StarInDirectory
+ | StarInFileName
+ | StarInExtension
+ | NoExtensionOnStar
+ | EmptyGlob
+ | LiteralFileNameGlobStar
+ | VersionDoesNotSupportGlobStar
+ | VersionDoesNotSupportGlob
+ deriving (Eq, Show)
+
+explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String
+explainGlobSyntaxError filepath StarInDirectory =
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. A wildcard '**' is only allowed as the final parent"
+ ++ " directory. Stars must not otherwise appear in the parent"
+ ++ " directories."
+explainGlobSyntaxError filepath StarInExtension =
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Wildcards '*' are only allowed as the"
+ ++ " file's base name, not in the file extension."
+explainGlobSyntaxError filepath StarInFileName =
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Wildcards '*' may only totally replace the"
+ ++ " file's base name, not only parts of it."
+explainGlobSyntaxError filepath NoExtensionOnStar =
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. If a wildcard '*' is used it must be with an file extension."
+explainGlobSyntaxError filepath LiteralFileNameGlobStar =
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Prior to 'cabal-version: 3.8'"
+ ++ " if a wildcard '**' is used as a parent directory, the"
+ ++ " file's base name must be a wildcard '*'."
+explainGlobSyntaxError _ EmptyGlob =
+ "invalid file glob. A glob cannot be the empty string."
+explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar =
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"
+ ++ " or greater. Alternatively, for compatibility with earlier Cabal"
+ ++ " versions, list the included directories explicitly."
+explainGlobSyntaxError filepath VersionDoesNotSupportGlob =
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "
+ ++ "Alternatively if you require compatibility with earlier Cabal "
+ ++ "versions then list all the files explicitly."
+
+-- Note throughout that we use splitDirectories, not splitPath. On
+-- Posix, this makes no difference, but, because Windows accepts both
+-- slash and backslash as its path separators, if we left in the
+-- separators from the glob we might not end up properly normalised.
+
+data GlobResult a
+ = -- | The glob matched the value supplied.
+ GlobMatch a
+ | -- | The glob did not match the value supplied because the
+ -- cabal-version is too low and the extensions on the file did
+ -- not precisely match the glob's extensions, but rather the
+ -- glob was a proper suffix of the file's extensions; i.e., if
+ -- not for the low cabal-version, it would have matched.
+ GlobWarnMultiDot a
+ | -- | The glob couldn't match because the directory named doesn't
+ -- exist. The directory will be as it appears in the glob (i.e.,
+ -- relative to the directory passed to 'matchDirFileGlob', and,
+ -- for 'data-files', relative to 'data-dir').
+ GlobMissingDirectory a
+ | -- | The glob matched a directory when we were looking for files only.
+ -- It didn't match a file!
+ --
+ -- @since 3.12.0.0
+ GlobMatchesDirectory a
+ deriving (Show, Eq, Ord, Functor)
+
+-- | Match files against a pre-parsed glob, starting in a directory.
+--
+-- The 'Version' argument must be the spec version of the package
+-- description being processed, as globs behave slightly differently
+-- in different spec versions.
+--
+-- The 'FilePath' argument is the directory that the glob is relative
+-- to. It must be a valid directory (and hence it can't be the empty
+-- string). The returned values will not include this prefix.
+runDirFileGlob
+ :: Verbosity
+ -> Maybe CabalSpecVersion
+ -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version.
+ -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'!
+ -> FilePath
+ -> Glob
+ -> IO [GlobResult FilePath]
+runDirFileGlob verbosity mspec rawRoot pat = do
+ -- The default data-dir is null. Our callers -should- be
+ -- converting that to '.' themselves, but it's a certainty that
+ -- some future call-site will forget and trigger a really
+ -- hard-to-debug failure if we don't check for that here.
+ when (null rawRoot) $
+ warn verbosity $
+ "Null dir passed to runDirFileGlob; interpreting it "
+ ++ "as '.'. This is probably an internal error."
+ let root = if null rawRoot then "." else rawRoot
+ debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'."
+ -- This function might be called from the project root with dir as
+ -- ".". Walking the tree starting there involves going into .git/
+ -- and dist-newstyle/, which is a lot of work for no reward, so
+ -- extract the constant prefix from the pattern and start walking
+ -- there, and only walk as much as we need to: recursively if **,
+ -- the whole directory if *, and just the specific file if it's a
+ -- literal.
+ let
+ (prefixSegments, variablePattern) = splitConstantPrefix pat
+ joinedPrefix = joinPath prefixSegments
+
+ -- The glob matching function depends on whether we care about the cabal version or not
+ doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ())
+ doesGlobMatch glob str = case mspec of
+ Just spec -> checkNameMatches spec glob str
+ Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing
+
+ go (GlobFile glob) dir = do
+ entries <- getDirectoryContents (root </> dir)
+ catMaybes
+ <$> mapM
+ ( \s -> do
+ -- When running a glob from a Cabal package description (i.e.
+ -- when a cabal spec version is passed as an argument), we
+ -- disallow matching a @GlobFile@ against a directory, preferring
+ -- @GlobDir dir GlobDirTrailing@ to specify a directory match.
+ isFile <- maybe (return True) (const $ doesFileExist (root </> dir </> s)) mspec
+ let match = (dir </> s <$) <$> doesGlobMatch glob s
+ return $
+ if isFile
+ then match
+ else case match of
+ Just (GlobMatch x) -> Just $ GlobMatchesDirectory x
+ Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x
+ Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x
+ Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess
+ Nothing -> Nothing
+ )
+ entries
+ go (GlobDirRecursive glob) dir = do
+ entries <- getDirectoryContentsRecursive (root </> dir)
+ return $
+ mapMaybe
+ ( \s -> do
+ globMatch <- doesGlobMatch glob (takeFileName s)
+ pure ((dir </> s) <$ globMatch)
+ )
+ entries
+ go (GlobDir glob globPath) dir = do
+ entries <- getDirectoryContents (root </> dir)
+ subdirs <-
+ filterM
+ ( \subdir ->
+ doesDirectoryExist
+ (root </> dir </> subdir)
+ )
+ $ filter (matchGlobPieces glob) entries
+ concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs
+ go GlobDirTrailing dir = return [GlobMatch dir]
+
+ directoryExists <- doesDirectoryExist (root </> joinedPrefix)
+ if directoryExists
+ then go variablePattern joinedPrefix
+ else return [GlobMissingDirectory joinedPrefix]
+ where
+ -- \| Extract the (possibly null) constant prefix from the pattern.
+ -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,
+ -- then @pat === foldr GlobDir final pref@.
+ splitConstantPrefix :: Glob -> ([FilePath], Glob)
+ splitConstantPrefix = unfoldr' step
+ where
+ step (GlobDir [Literal seg] pat') = Right (seg, pat')
+ step pat' = Left pat'
+
+ unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)
+ unfoldr' f a = case f a of
+ Left r -> ([], r)
+ Right (b, a') -> case unfoldr' f a' of
+ (bs, r) -> (b : bs, r)
+
+-- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ?
+isRecursiveInRoot :: Glob -> Bool
+isRecursiveInRoot (GlobDirRecursive _) = True
+isRecursiveInRoot _ = False
+
+-- | Check how the string matches the glob under this cabal version
+checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())
+checkNameMatches spec glob candidate
+ -- Check if glob matches in its general form
+ | matchGlobPieces glob candidate =
+ -- if multidot is supported, then this is a clean match
+ if enableMultidot spec
+ then pure (GlobMatch ())
+ else -- if not, issue a warning saying multidot is needed for the match
+
+ let (_, candidateExts) = splitExtensions $ takeFileName candidate
+ extractExts :: GlobPieces -> Maybe String
+ extractExts [] = Nothing
+ extractExts [Literal lit]
+ -- Any literal terminating a glob, and which does have an extension,
+ -- returns that extension. Otherwise, recurse until Nothing is returned.
+ | let ext = takeExtensions lit
+ , ext /= "" =
+ Just ext
+ extractExts (_ : x) = extractExts x
+ in case extractExts glob of
+ Just exts
+ | exts == candidateExts ->
+ return (GlobMatch ())
+ | exts `isSuffixOf` candidateExts ->
+ return (GlobWarnMultiDot ())
+ _ -> return (GlobMatch ())
+ | otherwise = empty
+
+-- | How/does the glob match the given filepath, according to the cabal version?
+-- Since this is pure, we don't make a distinction between matching on
+-- directories or files (i.e. this function won't return 'GlobMatchesDirectory')
+fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ())
+fileGlobMatches version g path = go g (splitDirectories path)
+ where
+ go GlobDirTrailing [] = Just (GlobMatch ())
+ go (GlobFile glob) [file] = checkNameMatches version glob file
+ go (GlobDirRecursive glob) dirs
+ | [] <- reverse dirs =
+ Nothing -- @dir/**/x.txt@ should not match @dir/hello@
+ | file : _ <- reverse dirs =
+ checkNameMatches version glob file
+ go (GlobDir glob globPath) (dir : dirs) = do
+ _ <- checkNameMatches version glob dir -- we only care if dir segment matches
+ go globPath dirs
+ go _ _ = Nothing
diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs
index a5dc0a1a0b60f350c3472523af52caa93627502e..33d497231af26ea5f430ba5b7838591c3c9a374e 100644
--- a/Cabal/src/Distribution/Simple/Haddock.hs
+++ b/Cabal/src/Distribution/Simple/Haddock.hs
@@ -49,7 +49,7 @@ import Distribution.Simple.BuildPaths
import Distribution.Simple.BuildTarget
import Distribution.Simple.Compiler
import Distribution.Simple.Flag
-import Distribution.Simple.Glob
+import Distribution.Simple.Glob (matchDirFileGlob)
import Distribution.Simple.InstallDirs
import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)
import qualified Distribution.Simple.PackageIndex as PackageIndex
diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs
index 706d3b51e35033cb0dbafd9a723015db9a209766..6c4890ee3dc54fca4fbcb19840d279b2d54cf3f6 100644
--- a/Cabal/src/Distribution/Simple/SrcDist.hs
+++ b/Cabal/src/Distribution/Simple/SrcDist.hs
@@ -245,12 +245,13 @@ listPackageSources' verbosity rip cwd pkg_descr pps =
, -- Data files.
fmap concat
. for (dataFiles pkg_descr)
- $ \filename -> do
- let srcDataDirRaw = dataDir pkg_descr
- srcDataDir
- | null srcDataDirRaw = "."
- | otherwise = srcDataDirRaw
- matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)
+ $ \filename ->
+ do
+ let srcDataDirRaw = dataDir pkg_descr
+ srcDataDir
+ | null srcDataDirRaw = "."
+ | otherwise = srcDataDirRaw
+ matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)
, -- Extra source files.
fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath
diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs
index 5edd159496b0fa70265d4a4f0a93e12c4f0980eb..084545d5e7e211d0b0e2334e13ef880aea4e2237 100644
--- a/cabal-install/src/Distribution/Client/FileMonitor.hs
+++ b/cabal-install/src/Distribution/Client/FileMonitor.hs
@@ -14,7 +14,7 @@ module Distribution.Client.FileMonitor
MonitorFilePath (..)
, MonitorKindFile (..)
, MonitorKindDir (..)
- , FilePathGlob (..)
+ , RootedGlob (..)
, monitorFile
, monitorFileHashed
, monitorNonExistentFile
@@ -91,7 +91,7 @@ data MonitorFilePath
| MonitorFileGlob
{ monitorKindFile :: !MonitorKindFile
, monitorKindDir :: !MonitorKindDir
- , monitorPathGlob :: !FilePathGlob
+ , monitorPathGlob :: !RootedGlob
}
deriving (Eq, Show, Generic)
@@ -168,13 +168,13 @@ monitorFileOrDirectory = MonitorFile FileModTime DirModTime
-- The monitored glob is considered to have changed if the set of files
-- matching the glob changes (i.e. creations or deletions), or for files if the
-- modification time and content hash of any matching file has changed.
-monitorFileGlob :: FilePathGlob -> MonitorFilePath
+monitorFileGlob :: RootedGlob -> MonitorFilePath
monitorFileGlob = MonitorFileGlob FileHashed DirExists
-- | Monitor a set of files (or directories) identified by a file glob for
-- existence only. The monitored glob is considered to have changed if the set
-- of files matching the glob changes (i.e. creations or deletions).
-monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath
+monitorFileGlobExistence :: RootedGlob -> MonitorFilePath
monitorFileGlobExistence = MonitorFileGlob FileExists DirExists
-- | Creates a list of files to monitor when you search for a file which
@@ -263,12 +263,12 @@ data MonitorStateGlob
data MonitorStateGlobRel
= MonitorStateGlobDirs
+ !GlobPieces
!Glob
- !FilePathGlobRel
!ModTime
![(FilePath, MonitorStateGlobRel)] -- invariant: sorted
| MonitorStateGlobFiles
- !Glob
+ !GlobPieces
!ModTime
![(FilePath, MonitorStateFileStatus)] -- invariant: sorted
| MonitorStateGlobDirTrailing
@@ -294,7 +294,7 @@ reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =
getGlobPath :: MonitorStateGlob -> MonitorFilePath
getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =
MonitorFileGlob kindfile kinddir $
- FilePathGlob root $
+ RootedGlob root $
case gstate of
MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs
MonitorStateGlobFiles glob _ _ -> GlobFile glob
@@ -698,7 +698,7 @@ probeMonitorStateGlobRel
let subdir = root </> dirName </> entry
in liftIO $ doesDirectoryExist subdir
)
- . filter (matchGlob glob)
+ . filter (matchGlobPieces glob)
=<< liftIO (getDirectoryContents (root </> dirName))
children' <-
@@ -784,7 +784,7 @@ probeMonitorStateGlobRel
-- directory modification time changed:
-- a matching file may have been added or deleted
matches <-
- return . filter (matchGlob glob)
+ return . filter (matchGlobPieces glob)
=<< liftIO (getDirectoryContents (root </> dirName))
traverse_ probeMergeResult $
@@ -1002,7 +1002,7 @@ buildMonitorStateGlob
-> MonitorKindDir
-> FilePath
-- ^ the root directory
- -> FilePathGlob
+ -> RootedGlob
-- ^ the matching glob
-> IO MonitorStateGlob
buildMonitorStateGlob
@@ -1011,7 +1011,7 @@ buildMonitorStateGlob
kindfile
kinddir
relroot
- (FilePathGlob globroot globPath) = do
+ (RootedGlob globroot globPath) = do
root <- liftIO $ getFilePathRootDirectory globroot relroot
MonitorStateGlob kindfile kinddir globroot
<$> buildMonitorStateGlobRel
@@ -1035,7 +1035,7 @@ buildMonitorStateGlobRel
-> FilePath
-- ^ directory we are examining
-- relative to the root
- -> FilePathGlobRel
+ -> Glob
-- ^ the matching glob
-> IO MonitorStateGlobRel
buildMonitorStateGlobRel
@@ -1050,10 +1050,11 @@ buildMonitorStateGlobRel
dirEntries <- getDirectoryContents absdir
dirMTime <- getModTime absdir
case globPath of
+ GlobDirRecursive{} -> error "Monitoring directory-recursive globs (i.e. ../**/...) is currently unsupported"
GlobDir glob globPath' -> do
subdirs <-
filterM (\subdir -> doesDirectoryExist (absdir </> subdir)) $
- filter (matchGlob glob) dirEntries
+ filter (matchGlobPieces glob) dirEntries
subdirStates <-
for (sort subdirs) $ \subdir -> do
fstate <-
@@ -1068,7 +1069,7 @@ buildMonitorStateGlobRel
return (subdir, fstate)
return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates
GlobFile glob -> do
- let files = filter (matchGlob glob) dirEntries
+ let files = filter (matchGlobPieces glob) dirEntries
filesStates <-
for (sort files) $ \file -> do
fstate <-
diff --git a/cabal-install/src/Distribution/Client/Glob.hs b/cabal-install/src/Distribution/Client/Glob.hs
index 66baadf7a5d23c8d7487f362ccd4f0d2a1824700..90054a8f64f7a03d0f2d98399f46ac57872d2530 100644
--- a/cabal-install/src/Distribution/Client/Glob.hs
+++ b/cabal-install/src/Distribution/Client/Glob.hs
@@ -1,50 +1,48 @@
{-# LANGUAGE DeriveGeneric #-}
--- TODO: [code cleanup] plausibly much of this module should be merged with
--- similar functionality in Cabal.
module Distribution.Client.Glob
- ( FilePathGlob (..)
+ ( -- * cabal-install globbing features
+ RootedGlob (..)
+ , isTrivialRootedGlob
, FilePathRoot (..)
- , FilePathGlobRel (..)
- , Glob
+ , getFilePathRootDirectory
+
+ -- * Additional re-exports
+ , module Distribution.Simple.Glob
+ , Glob (..)
, GlobPiece (..)
- , matchFileGlob
- , matchFileGlobRel
+ , GlobPieces
, matchGlob
- , isTrivialFilePathGlob
- , getFilePathRootDirectory
+ , matchGlobPieces
+ , matchFileGlob
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Data.List (stripPrefix)
+import Distribution.Simple.Glob
+import Distribution.Simple.Glob.Internal
+
import System.Directory
import System.FilePath
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
--- | A file path specified by globbing
-data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
- deriving (Eq, Show, Generic)
+--------------------------------------------------------------------------------
-data FilePathGlobRel
- = GlobDir !Glob !FilePathGlobRel
- | GlobFile !Glob
- | -- | trailing dir, a glob ending in @/@
- GlobDirTrailing
+-- | A file path specified by globbing, relative
+-- to some root directory.
+data RootedGlob
+ = RootedGlob
+ FilePathRoot
+ -- ^ what the glob is relative to
+ Glob
+ -- ^ the glob
deriving (Eq, Show, Generic)
--- | A single directory or file component of a globbed path
-type Glob = [GlobPiece]
-
--- | A piece of a globbing pattern
-data GlobPiece
- = WildCard
- | Literal String
- | Union [Glob]
- deriving (Eq, Show, Generic)
+instance Binary RootedGlob
+instance Structured RootedGlob
data FilePathRoot
= FilePathRelative
@@ -53,27 +51,22 @@ data FilePathRoot
| FilePathHomeDir
deriving (Eq, Show, Generic)
-instance Binary FilePathGlob
instance Binary FilePathRoot
-instance Binary FilePathGlobRel
-instance Binary GlobPiece
-
-instance Structured FilePathGlob
instance Structured FilePathRoot
-instance Structured FilePathGlobRel
-instance Structured GlobPiece
--- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and
+-- | Check if a 'RootedGlob' doesn't actually make use of any globbing and
-- is in fact equivalent to a non-glob 'FilePath'.
--
-- If it is trivial in this sense then the result is the equivalent constant
--- 'FilePath'. On the other hand if it is not trivial (so could in principle
--- match more than one file) then the result is @Nothing@.
-isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
-isTrivialFilePathGlob (FilePathGlob root pathglob) =
+-- 'FilePath'. On the other hand, if it is not trivial (so could in principle
+-- match more than one file), then the result is @Nothing@.
+isTrivialRootedGlob :: RootedGlob -> Maybe FilePath
+isTrivialRootedGlob (RootedGlob root pathglob) =
case root of
FilePathRelative -> go [] pathglob
FilePathRoot root' -> go [root'] pathglob
+ -- TODO: why don't we do the following?
+ -- > go ["~"] pathglob
FilePathHomeDir -> Nothing
where
go paths (GlobDir [Literal path] globs) = go (path : paths) globs
@@ -102,79 +95,30 @@ getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory
-- Matching
--
--- | Match a 'FilePathGlob' against the file system, starting from a given
+-- | Match a 'RootedGlob' against the file system, starting from a given
-- root directory for relative paths. The results of relative globs are
-- relative to the given root. Matches for absolute globs are absolute.
-matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]
-matchFileGlob relroot (FilePathGlob globroot glob) = do
+matchFileGlob :: FilePath -> RootedGlob -> IO [FilePath]
+matchFileGlob relroot (RootedGlob globroot glob) = do
root <- getFilePathRootDirectory globroot relroot
- matches <- matchFileGlobRel root glob
+ matches <- matchGlob root glob
case globroot of
FilePathRelative -> return matches
_ -> return (map (root </>) matches)
--- | Match a 'FilePathGlobRel' against the file system, starting from a
--- given root directory. The results are all relative to the given root.
-matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]
-matchFileGlobRel root glob0 = go glob0 ""
- where
- go (GlobFile glob) dir = do
- entries <- getDirectoryContents (root </> dir)
- let files = filter (matchGlob glob) entries
- return (map (dir </>) files)
- go (GlobDir glob globPath) dir = do
- entries <- getDirectoryContents (root </> dir)
- subdirs <-
- filterM
- ( \subdir ->
- doesDirectoryExist
- (root </> dir </> subdir)
- )
- $ filter (matchGlob glob) entries
- concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs
- go GlobDirTrailing dir = return [dir]
-
--- | Match a globbing pattern against a file path component
-matchGlob :: Glob -> String -> Bool
-matchGlob = goStart
- where
- -- From the man page, glob(7):
- -- "If a filename starts with a '.', this character must be
- -- matched explicitly."
-
- go, goStart :: [GlobPiece] -> String -> Bool
-
- goStart (WildCard : _) ('.' : _) = False
- goStart (Union globs : rest) cs =
- any
- (\glob -> goStart (glob ++ rest) cs)
- globs
- goStart rest cs = go rest cs
-
- go [] "" = True
- go (Literal lit : rest) cs
- | Just cs' <- stripPrefix lit cs =
- go rest cs'
- | otherwise = False
- go [WildCard] "" = True
- go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs
- go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs
- go [] (_ : _) = False
- go (_ : _) "" = False
-
------------------------------------------------------------------------------
--- Parsing & printing
+-- Parsing & pretty-printing
--
-instance Pretty FilePathGlob where
- pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob
+instance Pretty RootedGlob where
+ pretty (RootedGlob root pathglob) = pretty root Disp.<> pretty pathglob
-instance Parsec FilePathGlob where
+instance Parsec RootedGlob where
parsec = do
root <- parsec
case root of
- FilePathRelative -> FilePathGlob root <$> parsec
- _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing)
+ FilePathRelative -> RootedGlob root <$> parsec
+ _ -> RootedGlob root <$> parsec <|> pure (RootedGlob root GlobDirTrailing)
instance Pretty FilePathRoot where
pretty FilePathRelative = Disp.empty
@@ -191,68 +135,3 @@ instance Parsec FilePathRoot where
_ <- P.char ':'
_ <- P.char '/' <|> P.char '\\'
return (FilePathRoot (toUpper dr : ":\\"))
-
-instance Pretty FilePathGlobRel where
- pretty (GlobDir glob pathglob) =
- dispGlob glob
- Disp.<> Disp.char '/'
- Disp.<> pretty pathglob
- pretty (GlobFile glob) = dispGlob glob
- pretty GlobDirTrailing = Disp.empty
-
-instance Parsec FilePathGlobRel where
- parsec = parsecPath
- where
- parsecPath :: CabalParsing m => m FilePathGlobRel
- parsecPath = do
- glob <- parsecGlob
- dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
-
- dirSep :: CabalParsing m => m ()
- dirSep =
- () <$ P.char '/'
- <|> P.try
- ( do
- _ <- P.char '\\'
- -- check this isn't an escape code
- P.notFollowedBy (P.satisfy isGlobEscapedChar)
- )
-
-dispGlob :: Glob -> Disp.Doc
-dispGlob = Disp.hcat . map dispPiece
- where
- dispPiece WildCard = Disp.char '*'
- dispPiece (Literal str) = Disp.text (escape str)
- dispPiece (Union globs) =
- Disp.braces
- ( Disp.hcat
- ( Disp.punctuate
- (Disp.char ',')
- (map dispGlob globs)
- )
- )
- escape [] = []
- escape (c : cs)
- | isGlobEscapedChar c = '\\' : c : escape cs
- | otherwise = c : escape cs
-
-parsecGlob :: CabalParsing m => m Glob
-parsecGlob = some parsecPiece
- where
- parsecPiece = P.choice [literal, wildcard, union]
-
- wildcard = WildCard <$ P.char '*'
- union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))
- literal = Literal <$> some litchar
-
- litchar = normal <|> escape
-
- normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')
- escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar
-
-isGlobEscapedChar :: Char -> Bool
-isGlobEscapedChar '*' = True
-isGlobEscapedChar '{' = True
-isGlobEscapedChar '}' = True
-isGlobEscapedChar ',' = True
-isGlobEscapedChar _ = False
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs
index b4d20e317cc6417adb4ab2b354546a7508c2b88e..cffc0912c93963a849882f320bae9ead419778bf 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs
@@ -60,7 +60,7 @@ import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.Glob
- ( isTrivialFilePathGlob
+ ( isTrivialRootedGlob
)
import Distribution.Client.ProjectConfig.Legacy
import Distribution.Client.ProjectConfig.Types
@@ -1050,7 +1050,7 @@ findProjectPackages
matches <- matchFileGlob glob
case matches of
[]
- | isJust (isTrivialFilePathGlob glob) ->
+ | isJust (isTrivialRootedGlob glob) ->
return
( Left
( BadPackageLocationFile
@@ -1064,7 +1064,7 @@ findProjectPackages
<$> traverse checkFilePackageMatch matches
return $! case (failures, pkglocs) of
([failure], [])
- | isJust (isTrivialFilePathGlob glob) ->
+ | isJust (isTrivialRootedGlob glob) ->
Left (BadPackageLocationFile failure)
(_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)
_ -> Right pkglocs
@@ -1133,9 +1133,9 @@ findProjectPackages
--
-- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.
-- The directory part can be either absolute or relative.
-globStarDotCabal :: FilePath -> FilePathGlob
+globStarDotCabal :: FilePath -> RootedGlob
globStarDotCabal dir =
- FilePathGlob
+ RootedGlob
(if isAbsolute dir then FilePathRoot root else FilePathRelative)
( foldr
(\d -> GlobDir [Literal d])
diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs
index 89378922d6660bd5177641c7cfe0afd22b9725d7..83535994ac017b066f247c7f3a6fc7419efcd9a8 100644
--- a/cabal-install/src/Distribution/Client/RebuildMonad.hs
+++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs
@@ -32,9 +32,9 @@ module Distribution.Client.RebuildMonad
-- ** Monitoring file globs
, monitorFileGlob
, monitorFileGlobExistence
- , FilePathGlob (..)
+ , RootedGlob (..)
, FilePathRoot (..)
- , FilePathGlobRel (..)
+ , Glob (..)
, GlobPiece (..)
-- * Using a file monitor
@@ -232,7 +232,7 @@ delayInitSharedResources action = do
--
-- Since this operates in the 'Rebuild' monad, it also monitors the given glob
-- for changes.
-matchFileGlob :: FilePathGlob -> Rebuild [FilePath]
+matchFileGlob :: RootedGlob -> Rebuild [FilePath]
matchFileGlob glob = do
root <- askRoot
monitorFiles [monitorFileGlobExistence glob]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
index 13e06172f80596973ad05c7d84fec282151bfe1b..6acc63072d1663bdf017326289a24675fa7171e1 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
@@ -32,7 +32,7 @@ import Distribution.Types.Flag (mkFlagAssignment)
import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome, ReportLevel (..))
import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod)
-import Distribution.Client.Glob (FilePathGlob (..), FilePathGlobRel (..), FilePathRoot (..), GlobPiece (..))
+import Distribution.Client.Glob (FilePathRoot (..), Glob (..), GlobPiece (..), RootedGlob (..))
import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))
import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState)
import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp)
@@ -344,19 +344,19 @@ instance Arbitrary Outcome where
-- Glob
-------------------------------------------------------------------------------
-instance Arbitrary FilePathGlob where
+instance Arbitrary RootedGlob where
arbitrary =
- (FilePathGlob <$> arbitrary <*> arbitrary)
+ (RootedGlob <$> arbitrary <*> arbitrary)
`suchThat` validFilePathGlob
- shrink (FilePathGlob root pathglob) =
- [ FilePathGlob root' pathglob'
+ shrink (RootedGlob root pathglob) =
+ [ RootedGlob root' pathglob'
| (root', pathglob') <- shrink (root, pathglob)
- , validFilePathGlob (FilePathGlob root' pathglob')
+ , validFilePathGlob (RootedGlob root' pathglob')
]
-validFilePathGlob :: FilePathGlob -> Bool
-validFilePathGlob (FilePathGlob FilePathRelative pathglob) =
+validFilePathGlob :: RootedGlob -> Bool
+validFilePathGlob (RootedGlob FilePathRelative pathglob) =
case pathglob of
GlobDirTrailing -> False
GlobDir [Literal "~"] _ -> False
@@ -381,7 +381,7 @@ instance Arbitrary FilePathRoot where
shrink (FilePathRoot _) = [FilePathRelative]
shrink FilePathHomeDir = [FilePathRelative]
-instance Arbitrary FilePathGlobRel where
+instance Arbitrary Glob where
arbitrary = sized $ \sz ->
oneof $
take
@@ -403,6 +403,9 @@ instance Arbitrary FilePathGlobRel where
: [ GlobDir (getGlobPieces glob') pathglob'
| (glob', pathglob') <- shrink (GlobPieces glob, pathglob)
]
+ shrink (GlobDirRecursive glob) =
+ GlobDirTrailing
+ : [GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob)]
newtype GlobPieces = GlobPieces {getGlobPieces :: [GlobPiece]}
deriving (Eq)
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs
index 66b9649db1147eb3d0cc2f60d520f44acaa6790e..7e52d25173f20d9c94e7401b4ca47d0b1f89ac19 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs
@@ -13,7 +13,7 @@ import Distribution.Types.PackageName (PackageName)
import Distribution.Types.VersionRange (VersionRange)
import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome)
-import Distribution.Client.Glob (FilePathGlob)
+import Distribution.Client.Glob (RootedGlob)
import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry, ActiveRepos, CombineStrategy)
import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState)
import Distribution.Client.IndexUtils.Timestamp (Timestamp)
@@ -51,7 +51,7 @@ instance Described Outcome where
-------------------------------------------------------------------------------
-- This instance is incorrect as it may generate C:\dir\{foo,bar}
-instance Described FilePathGlob where
+instance Described RootedGlob where
describe _ = REUnion [root, relative, homedir]
where
root =
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs
index 0663360df42e0eb1ac8cb616612e0d4ec8fd7e3f..f3c8145bc49bf2f63b1e665c42a6fe210197f80a 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs
@@ -89,15 +89,15 @@ tests mtimeChange =
_ -> id
fingerprintStateGlob1, fingerprintStateGlob2, fingerprintStateFileSet1, fingerprintStateFileSet2 :: Word64
#if MIN_VERSION_base(4,19,0)
- fingerprintStateGlob1 = 0xae70229aabb1ba1f
- fingerprintStateGlob2 = 0xb53ed324c96f0d0d
- fingerprintStateFileSet1 = 0x8e509e16f973e036
- fingerprintStateFileSet2 = 0xa23f21d8dc8a2dee
+ fingerprintStateGlob1 = 0x4ebc6a7d12bb2132
+ fingerprintStateGlob2 = 0x2c2292eeda0a9319
+ fingerprintStateFileSet1 = 0x01df5796f9030851
+ fingerprintStateFileSet2 = 0x2f5c472be17bee98
#else
- fingerprintStateGlob1 = 0xfd8f6be0e8258fe7
- fingerprintStateGlob2 = 0xdb5fac737139bca6
- fingerprintStateFileSet1 = 0xb745f4ea498389a5
- fingerprintStateFileSet2 = 0x70db6adb5078aa27
+ fingerprintStateGlob1 = 0xf32c0d1644dd9ee5
+ fingerprintStateGlob2 = 0x0f2494f7b6031fb6
+ fingerprintStateFileSet1 = 0x06d4a13275c24282
+ fingerprintStateFileSet2 = 0x791b2a88684b5f37
#endif
-- Check the file system behaves the way we expect it to
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
index 8d77b6784ef3f4762e37997b1e852408a0c561d9..c51ce7e2448ff3a26262cef6588e6c803db248e0 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
@@ -22,16 +22,16 @@ tests =
, testGroup
"Structured hashes"
[ testCase "GlobPiece" $ structureHash (Proxy :: Proxy GlobPiece) @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782
- , testCase "FilePathGlobRel" $ structureHash (Proxy :: Proxy FilePathGlobRel) @?= Fingerprint 0x76fa5bcb865a8501 0xb152f68915316f98
+ , testCase "Glob" $ structureHash (Proxy :: Proxy Glob) @?= Fingerprint 0x3a5af41e8194eaa3 0xd8e461fdfdb0e07b
, testCase "FilePathRoot" $ structureHash (Proxy :: Proxy FilePathRoot) @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5
- , testCase "FilePathGlob" $ structureHash (Proxy :: Proxy FilePathGlob) @?= Fingerprint 0x3c11c41f3f03a1f0 0x96e69d85c37d0024
+ , testCase "RootedGlob" $ structureHash (Proxy :: Proxy RootedGlob) @?= Fingerprint 0x0031d198379cd1bf 0x7246ab9b6c6e0e7d
]
]
-- TODO: [nice to have] tests for trivial globs, tests for matching,
-- tests for windows style file paths
-prop_roundtrip_printparse :: FilePathGlob -> Property
+prop_roundtrip_printparse :: RootedGlob -> Property
prop_roundtrip_printparse pathglob =
counterexample (prettyShow pathglob) $
eitherParsec (prettyShow pathglob) === Right pathglob
@@ -39,35 +39,35 @@ prop_roundtrip_printparse pathglob =
-- first run, where we don't even call updateMonitor
testParseCases :: Assertion
testParseCases = do
- FilePathGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"
- FilePathGlob FilePathHomeDir GlobDirTrailing <- testparse "~/"
+ RootedGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"
+ RootedGlob FilePathHomeDir GlobDirTrailing <- testparse "~/"
- FilePathGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"
- FilePathGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"
- FilePathGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"
- FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"
+ RootedGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"
+ RootedGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"
+ RootedGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"
+ RootedGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"
- FilePathGlob
+ RootedGlob
FilePathRelative
(GlobFile [Literal "."]) <-
testparse "."
- FilePathGlob
+ RootedGlob
FilePathRelative
(GlobFile [Literal "~"]) <-
testparse "~"
- FilePathGlob
+ RootedGlob
FilePathRelative
(GlobDir [Literal "."] GlobDirTrailing) <-
testparse "./"
- FilePathGlob
+ RootedGlob
FilePathRelative
(GlobFile [Literal "foo"]) <-
testparse "foo"
- FilePathGlob
+ RootedGlob
FilePathRelative
( GlobDir
[Literal "foo"]
@@ -75,7 +75,7 @@ testParseCases = do
) <-
testparse "foo/bar"
- FilePathGlob
+ RootedGlob
FilePathRelative
( GlobDir
[Literal "foo"]
@@ -83,7 +83,7 @@ testParseCases = do
) <-
testparse "foo/bar/"
- FilePathGlob
+ RootedGlob
(FilePathRoot "/")
( GlobDir
[Literal "foo"]
@@ -91,7 +91,7 @@ testParseCases = do
) <-
testparse "/foo/bar/"
- FilePathGlob
+ RootedGlob
(FilePathRoot "C:\\")
( GlobDir
[Literal "foo"]
@@ -99,26 +99,26 @@ testParseCases = do
) <-
testparse "C:\\foo\\bar\\"
- FilePathGlob
+ RootedGlob
FilePathRelative
(GlobFile [WildCard]) <-
testparse "*"
- FilePathGlob
+ RootedGlob
FilePathRelative
(GlobFile [WildCard, WildCard]) <-
testparse "**" -- not helpful but valid
- FilePathGlob
+ RootedGlob
FilePathRelative
(GlobFile [WildCard, Literal "foo", WildCard]) <-
testparse "*foo*"
- FilePathGlob
+ RootedGlob
FilePathRelative
(GlobFile [Literal "foo", WildCard, Literal "bar"]) <-
testparse "foo*bar"
- FilePathGlob
+ RootedGlob
FilePathRelative
(GlobFile [Union [[WildCard], [Literal "foo"]]]) <-
testparse "{*,foo}"
@@ -135,7 +135,7 @@ testParseCases = do
return ()
-testparse :: String -> IO FilePathGlob
+testparse :: String -> IO RootedGlob
testparse s =
case eitherParsec s of
Right p -> return p
@@ -143,6 +143,6 @@ testparse s =
parseFail :: String -> Assertion
parseFail s =
- case eitherParsec s :: Either String FilePathGlob of
+ case eitherParsec s :: Either String RootedGlob of
Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p)
Left _ -> return ()
diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/AbsolutePath/cabal.out b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/AbsolutePath/cabal.out
index 8fa0a5d985bee8d19618b73c09e97c846b5b9c55..562f6f4d4f75b1a6cc8aca25eed716f8bb7a4e7d 100644
--- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/AbsolutePath/cabal.out
+++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/AbsolutePath/cabal.out
@@ -1,6 +1,6 @@
# cabal check
These warnings may cause trouble when distributing the package:
-Warning: [no-glob-match] In 'extra-source-files': the pattern '/home/user/file' does not match any files.
+Warning: [glob-missing-dir] In 'extra-source-files': the pattern '/home/user/file' attempts to match files in the directory '/home/user', but there is no directory by that name.
The following errors will cause portability problems on other environments:
Error: [absolute-path] 'extra-source-files: /home/user/file' specifies an absolute path, but the 'extra-source-files' field must use relative paths.
Error: [malformed-relative-path] 'extra-source-files: /home/user/file' is not a good relative path: "posix absolute path"
diff --git a/cabal-testsuite/PackageTests/SDist/T5195/cabal.out b/cabal-testsuite/PackageTests/SDist/T5195/cabal.out
deleted file mode 100644
index 5b329c9c75b2c27221bba25c371daf89d9ccc771..0000000000000000000000000000000000000000
--- a/cabal-testsuite/PackageTests/SDist/T5195/cabal.out
+++ /dev/null
@@ -1,3 +0,0 @@
-# cabal v2-sdist
-Error: [Cabal-6661]
-filepath wildcard './actually-a-directory' does not match any files.
\ No newline at end of file
diff --git a/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs b/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs
deleted file mode 100644
index c0ff953560b661d32bdf668baa1f2fe49b4a2bb2..0000000000000000000000000000000000000000
--- a/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-import Test.Cabal.Prelude
-main = cabalTest $ do
- tmpdir <- fmap testTmpDir getTestEnv
- res <- fails $ cabal' "v2-sdist" ["--list-only", "--output-directory", tmpdir]
- assertOutputContains "filepath wildcard './actually-a-directory' does not match any files" res
diff --git a/cabal-testsuite/PackageTests/SDist/T5195/t5195.cabal b/cabal-testsuite/PackageTests/SDist/T5195/t5195.cabal
deleted file mode 100644
index 5d9a759dd71343ad67129bd59daaf23a0bd958d7..0000000000000000000000000000000000000000
--- a/cabal-testsuite/PackageTests/SDist/T5195/t5195.cabal
+++ /dev/null
@@ -1,10 +0,0 @@
-cabal-version: 2.2
-name: t5195
-version: 0
-
-extra-source-files:
- ./actually-a-directory
-
-executable foo
- default-language: Haskell2010
- main-is: Main.hs
diff --git a/cabal-testsuite/PackageTests/SDist/T5195/Main.hs b/cabal-testsuite/PackageTests/SDist/T5195and5349/Main.hs
similarity index 100%
rename from cabal-testsuite/PackageTests/SDist/T5195/Main.hs
rename to cabal-testsuite/PackageTests/SDist/T5195and5349/Main.hs
diff --git a/cabal-testsuite/PackageTests/SDist/T5195/actually-a-directory/some-file b/cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-directory/some-file
similarity index 100%
rename from cabal-testsuite/PackageTests/SDist/T5195/actually-a-directory/some-file
rename to cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-directory/some-file
diff --git a/cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-file b/cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-file
new file mode 100644
index 0000000000000000000000000000000000000000..b14df6442ea5a1b382985a6549b85d435376c351
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-file
@@ -0,0 +1 @@
+Hi
diff --git a/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.out b/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.out
new file mode 100644
index 0000000000000000000000000000000000000000..22e981ee6c1fa90cbb0f7e176eee483dd453fe75
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.out
@@ -0,0 +1,5 @@
+# cabal v2-sdist
+Warning: Ignoring directory '././actually-a-directory' listed in a Cabal package field which should only include files (not directories).
+Warning: Ignoring directory './actually-a-directory' listed in a Cabal package field which should only include files (not directories).
+Warning: Ignoring directory './actually-a-directory' listed in a Cabal package field which should only include files (not directories).
+Wrote source list to <TMPDIR>/t5195and5349-0.list
diff --git a/cabal-testsuite/PackageTests/SDist/T5195/cabal.project b/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.project
similarity index 100%
rename from cabal-testsuite/PackageTests/SDist/T5195/cabal.project
rename to cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.project
diff --git a/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs b/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs
new file mode 100644
index 0000000000000000000000000000000000000000..da391fad32870c9677e628ab3a52a76517e35e02
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs
@@ -0,0 +1,5 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+ tmpdir <- fmap testTmpDir getTestEnv
+ cabal' "v2-sdist" ["--list-only", "--output-directory", tmpdir]
+ return ()
diff --git a/cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal b/cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal
new file mode 100644
index 0000000000000000000000000000000000000000..5df90b3562d7cdaaa42877d40007911fa15eec52
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal
@@ -0,0 +1,19 @@
+cabal-version: 2.2
+name: t5195and5349
+version: 0
+
+extra-source-files:
+ ./actually-a-directory
+ ./actually-a-file
+
+extra-doc-files:
+ ./actually-a-directory
+ ./actually-a-file
+
+data-files:
+ ./actually-a-directory
+ ./actually-a-file
+
+executable foo
+ default-language: Haskell2010
+ main-is: Main.hs
diff --git a/changelog.d/pr-9673 b/changelog.d/pr-9673
new file mode 100644
index 0000000000000000000000000000000000000000..c14776b0db94678f61798d369a04a7292b82f482
--- /dev/null
+++ b/changelog.d/pr-9673
@@ -0,0 +1,19 @@
+synopsis: Merge globbing implementations
+packages: Cabal cabal-install
+prs: #9673
+issues: #5349
+
+description: {
+
+The common aspects of the globbing functionality between `Cabal` and
+`cabal-install` have been factored out. The only change in the user-facing API
+is that we now record when a glob does not match exactly, but matches a
+directory with that same name, with the new constructor `GlobMatchesDirectory`
+of `GlobResult`.
+
+To illustrate, this change means that when `foo/dir` is a directory, the glob
+`*/dir/` matches exactly `foo/dir` (as before), but now
+`*/dir` produces `GlobMatchesDirectory` instead of failing.
+This allows callers to decide whether to allow or discard such inexact matches.
+
+}
diff --git a/doc/cabal-project-description-file.rst b/doc/cabal-project-description-file.rst
index a787a221f583545d7efdb267c73b7256d5efcdea..0e630c98f7dcdea732044c313fbbcbf95415f372 100644
--- a/doc/cabal-project-description-file.rst
+++ b/doc/cabal-project-description-file.rst
@@ -189,16 +189,16 @@ Formally, the format is described by the following BNF:
.. code-block:: abnf
- FilePathGlob ::= FilePathRoot FilePathGlobRel
+ RootedGlob ::= FilePathRoot Glob
FilePathRoot ::= {- empty -} # relative to cabal.project
| "/" # Unix root
| [a-zA-Z] ":" [/\\] # Windows root
| "~" # home directory
- FilePathGlobRel ::= Glob "/" FilePathGlobRel # Unix directory
- | Glob "\\" FilePathGlobRel # Windows directory
- | Glob # file
- | {- empty -} # trailing slash
- Glob ::= GlobPiece *
+ Glob ::= GlobPieces [/\\] Glob # Unix or Windows directory
+ | "..[**/\\]" GlobPieces # Recursive directory glob
+ | GlobPieces # file
+ | [/\\] # trailing slash
+ GlobPieces ::= GlobPiece *
GlobPiece ::= "*" # wildcard
| [^*{},/\\] * # literal string
| "\\" [*{},] # escaped reserved character