module Distribution.Simple.Glob (
GlobSyntaxError(..),
GlobResult(..),
globMatches,
matchFileGlob,
matchDirFileGlob,
matchDirFileGlob',
fileGlobMatches,
parseFileGlob,
explainGlobSyntaxError,
Glob,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Control.Monad (guard)
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Version
import System.Directory (getDirectoryContents, doesFileExist)
import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>))
data GlobResult a
= GlobMatch a
| GlobWarnMultiDot a
deriving (Show, Eq, Ord, Functor)
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
++ "'. 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
data MultiDot = MultiDotDisabled | MultiDotEnabled
data Glob
= GlobStem FilePath Glob
| GlobFinal GlobFinal
data GlobFinal
= FinalMatch IsRecursive MultiDot String
| FinalLit FilePath
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 (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 filename -> do
guard (null segs && filename == seg)
return (GlobMatch ())
checkExt
:: MultiDot
-> String
-> String
-> 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 :: Version -> FilePath -> Either GlobSyntaxError Glob
parseFileGlob version filepath = case reverse (splitDirectories filepath) of
[] ->
Left EmptyGlob
(filename : "**" : segments)
| allowGlobStar -> do
ext <- case splitExtensions filename of
("*", ext) | '*' `elem` ext -> Left StarInExtension
| null ext -> Left NoExtensionOnStar
| otherwise -> Right ext
_ -> Left LiteralFileNameGlobStar
foldM addStem (GlobFinal $ FinalMatch Recursive multidot ext) 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 filename)
foldM addStem (GlobFinal pat) segments
where
allowGlob = version >= mkVersion [1,6]
allowGlobStar = version >= mkVersion [2,4]
addStem pat seg
| '*' `elem` seg = Left StarInDirectory
| otherwise = Right (GlobStem seg pat)
multidot
| version >= mkVersion [2,4] = MultiDotEnabled
| otherwise = MultiDotDisabled
matchFileGlob :: Verbosity -> Version -> FilePath -> IO [GlobResult FilePath]
matchFileGlob verbosity version = matchDirFileGlob verbosity version "."
matchDirFileGlob :: Verbosity -> Version -> FilePath -> FilePath -> IO [GlobResult FilePath]
matchDirFileGlob verbosity version dir filepath = do
matches <- matchDirFileGlob' verbosity version dir filepath
when (null $ globMatches matches) $ die' verbosity $
"filepath wildcard '" ++ filepath
++ "' does not match any files."
return matches
matchDirFileGlob' :: Verbosity -> Version -> FilePath -> FilePath -> IO [GlobResult FilePath]
matchDirFileGlob' verbosity version rawDir filepath = case parseFileGlob version filepath of
Left err -> die' verbosity $ explainGlobSyntaxError filepath err
Right pat -> do
when (null rawDir) $
warn verbosity $
"Null dir passed to matchDirFileGlob; interpreting it "
++ "as '.'. This is probably an internal error."
let dir = if null rawDir then "." else rawDir
debug verbosity $ "Expanding glob '" ++ filepath ++ "' in directory '" ++ dir ++ "'."
let (prefixSegments, final) = splitConstantPrefix pat
joinedPrefix = joinPath prefixSegments
case final of
FinalMatch recursive multidot exts -> do
let prefix = dir </> joinedPrefix
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
FinalLit 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)
splitConstantPrefix :: Glob -> ([FilePath], GlobFinal)
splitConstantPrefix = unfoldr' step
where
step (GlobStem seg pat) = Right (seg, pat)
step (GlobFinal pat) = Left pat