From 0852ae75503997a6ff661dd2a7c5972da5bc8dc1 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 15 Feb 2024 16:04:38 +0100 Subject: [PATCH] Merge the two Globbing modules in cabal and cabal-install We use the datatype representation from the globbing in cabal-install, but preserve a standalone parser for globs present in cabal files, whose specification is constrained by the cabal specification. The implementations are merged taking the best parts of each. We also make sure sdist is robust to accidentally-listed directories, as the refactor of the globbing modules re-uncovered this issue, and required a prompt fix for the refactor not to break some things. Fixes #5349 --- .../UnitTests/Distribution/Simple/Glob.hs | 14 +- Cabal/Cabal.cabal | 1 + .../Distribution/PackageDescription/Check.hs | 25 +- .../PackageDescription/Check/Paths.hs | 5 + Cabal/src/Distribution/Simple/Glob.hs | 326 ++---------- .../src/Distribution/Simple/Glob/Internal.hs | 497 ++++++++++++++++++ Cabal/src/Distribution/Simple/Haddock.hs | 2 +- Cabal/src/Distribution/Simple/SrcDist.hs | 13 +- .../src/Distribution/Client/FileMonitor.hs | 29 +- cabal-install/src/Distribution/Client/Glob.hs | 205 ++------ .../src/Distribution/Client/ProjectConfig.hs | 10 +- .../src/Distribution/Client/RebuildMonad.hs | 6 +- .../Distribution/Client/ArbitraryInstances.hs | 21 +- .../Distribution/Client/DescribedInstances.hs | 4 +- .../Distribution/Client/FileMonitor.hs | 16 +- .../UnitTests/Distribution/Client/Glob.hs | 48 +- .../Paths/AbsolutePath/cabal.out | 2 +- .../PackageTests/SDist/T5195/cabal.out | 3 - .../PackageTests/SDist/T5195/cabal.test.hs | 5 - .../PackageTests/SDist/T5195/t5195.cabal | 10 - .../SDist/{T5195 => T5195and5349}/Main.hs | 0 .../actually-a-directory/some-file | 0 .../SDist/T5195and5349/actually-a-file | 1 + .../PackageTests/SDist/T5195and5349/cabal.out | 5 + .../{T5195 => T5195and5349}/cabal.project | 0 .../SDist/T5195and5349/cabal.test.hs | 5 + .../SDist/T5195and5349/t5195and5349.cabal | 19 + changelog.d/pr-9673 | 19 + doc/cabal-project-description-file.rst | 12 +- 29 files changed, 754 insertions(+), 549 deletions(-) create mode 100644 Cabal/src/Distribution/Simple/Glob/Internal.hs delete mode 100644 cabal-testsuite/PackageTests/SDist/T5195/cabal.out delete mode 100644 cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs delete mode 100644 cabal-testsuite/PackageTests/SDist/T5195/t5195.cabal rename cabal-testsuite/PackageTests/SDist/{T5195 => T5195and5349}/Main.hs (100%) rename cabal-testsuite/PackageTests/SDist/{T5195 => T5195and5349}/actually-a-directory/some-file (100%) create mode 100644 cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-file create mode 100644 cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.out rename cabal-testsuite/PackageTests/SDist/{T5195 => T5195and5349}/cabal.project (100%) create mode 100644 cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal create mode 100644 changelog.d/pr-9673 diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs index 22e3af46843..fce1ffbc050 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 cbd52b5a6e8..7ed48bfb308 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -105,6 +105,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 1893d05014c..43f8bf0d2a4 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 f389c6797be..5b2df1f18fa 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 67abe7e2da4..9ce97d7555b 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 00000000000..4f0b91eca39 --- /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 + = -- | @/@ + GlobDir !GlobPieces !Glob + | -- | @**/@, where @**@ denotes recursively traversing + -- all directories and matching filenames on . + 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 a5dc0a1a0b6..33d497231af 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 706d3b51e35..6c4890ee3dc 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 5edd159496b..084545d5e7e 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 66baadf7a5d..90054a8f64f 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 b4d20e317cc..cffc0912c93 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 89378922d66..83535994ac0 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 13e06172f80..6acc63072d1 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 66b9649db11..7e52d25173f 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 0663360df42..f3c8145bc49 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 8d77b6784ef..c51ce7e2448 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 8fa0a5d985b..562f6f4d4f7 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 5b329c9c75b..00000000000 --- 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 c0ff953560b..00000000000 --- 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 5d9a759dd71..00000000000 --- 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 00000000000..b14df6442ea --- /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 00000000000..22e981ee6c1 --- /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 /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 00000000000..da391fad328 --- /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 00000000000..5df90b3562d --- /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 00000000000..c14776b0db9 --- /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 a787a221f58..0e630c98f7d 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