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/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 1893d05014c..8fe449487bb 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -170,7 +170,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 +853,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 +872,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file) getWarning (GlobMissingDirectory dir) = Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir) + getWarning (GlobMatchesDirectory _) = Nothing -- is handled elsewhere if relevant, it is not necessarily a problem -- ------------------------------------------------------------ -- Other exports @@ -1012,10 +1014,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/Monad.hs b/Cabal/src/Distribution/PackageDescription/Check/Monad.hs index 23d37570800..43223e1e1d8 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Monad.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Monad.hs @@ -48,7 +48,7 @@ import Distribution.CabalSpecVersion (CabalSpecVersion) import Distribution.Package (packageName) import Distribution.PackageDescription.Check.Warning import Distribution.Simple.BuildToolDepends (desugarBuildToolSimple) -import Distribution.Simple.Glob (Glob, GlobResult) +import Distribution.Simple.Glob import Distribution.Types.ExeDependency (ExeDependency) import Distribution.Types.GenericPackageDescription import Distribution.Types.LegacyExeDependency (LegacyExeDependency) diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 67abe7e2da4..0cbf27c9939 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 #-} ----------------------------------------------------------------------------- @@ -14,59 +14,247 @@ -- Portability : portable -- -- Simple file globbing. -module Distribution.Simple.Glob - ( GlobSyntaxError (..) - , GlobResult (..) - , matchDirFileGlob - , matchDirFileGlobWithDie - , runDirFileGlob - , fileGlobMatches - , parseFileGlob - , explainGlobSyntaxError - , isRecursiveInRoot - , Glob - ) where +module Distribution.Simple.Glob 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 +import Distribution.Verbosity hiding (normal) -import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents) -import System.FilePath (joinPath, splitDirectories, splitExtensions, takeFileName, (<.>), ()) +import Data.List (stripPrefix) +import System.Directory +import System.FilePath -import qualified Data.List.NonEmpty as NE import Distribution.Simple.Errors --- 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. +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp -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. -globMatches :: [GlobResult a] -> [a] -globMatches input = [a | GlobMatch a <- input] +-- | 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. +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 @@ -121,112 +309,35 @@ explainGlobSyntaxError filepath VersionDoesNotSupportGlob = ++ "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 +-- 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 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 +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! + GlobMatchesDirectory a + deriving (Show, Eq, Ord, Functor) -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 +-- | 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. +globMatches :: [GlobResult a] -> [a] +globMatches input = [a | GlobMatch a <- input] -- | 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 +358,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,11 +385,22 @@ 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. @@ -283,18 +412,25 @@ matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob -- 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 +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 rawDir) $ + when (null rawRoot) $ 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 ++ "'." + 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 @@ -302,54 +438,127 @@ runDirFileGlob verbosity rawDir pat = do -- 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 + 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 - step (GlobStem seg pat) = Right (seg, pat) - step (GlobFinal pat) = Left pat + -- \| 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 (GlobFinal (FinalMatch Recursive _ _)) = True +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/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs index 706d3b51e35..b186508e20f 100644 --- a/Cabal/src/Distribution/Simple/SrcDist.hs +++ b/Cabal/src/Distribution/Simple/SrcDist.hs @@ -55,7 +55,7 @@ import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Configure (findDistPrefOrDefault) import Distribution.Simple.Flag -import Distribution.Simple.Glob (matchDirFileGlobWithDie) +import Distribution.Simple.Glob import Distribution.Simple.PreProcess import Distribution.Simple.Program import Distribution.Simple.Setup.SDist @@ -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..b5f3562eb85 100644 --- a/cabal-install/src/Distribution/Client/Glob.hs +++ b/cabal-install/src/Distribution/Client/Glob.hs @@ -1,50 +1,39 @@ {-# LANGUAGE DeriveGeneric #-} --- TODO: [code cleanup] plausibly much of this module should be merged with --- similar functionality in Cabal. module Distribution.Client.Glob - ( FilePathGlob (..) + ( module Distribution.Simple.Glob + , RootedGlob (..) , FilePathRoot (..) - , FilePathGlobRel (..) - , Glob - , GlobPiece (..) , matchFileGlob - , matchFileGlobRel - , matchGlob - , isTrivialFilePathGlob + , isTrivialRootedGlob , getFilePathRootDirectory ) where import Distribution.Client.Compat.Prelude import Prelude () -import Data.List (stripPrefix) +import Distribution.Simple.Glob + 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 +42,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 +86,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 +126,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..6c58977cbfb 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 = 0x16248eac312c6498 + fingerprintStateGlob2 = 0xe198f694cf0dee6e + fingerprintStateFileSet1 = 0xbcdcef981cc2ecec + fingerprintStateFileSet2 = 0xf9b06f5fd7261fad #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/doc/cabal-project-description-file.rst b/doc/cabal-project-description-file.rst index a787a221f58..cfdb92f2380 100644 --- a/doc/cabal-project-description-file.rst +++ b/doc/cabal-project-description-file.rst @@ -189,13 +189,13 @@ 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 ::= Glob "/" Glob # Unix directory + | Glob "\\" Glob # Windows directory | Glob # file | {- empty -} # trailing slash Glob ::= GlobPiece *