Cabal/Distribution/Simple/Glob.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -----------------------------------------------------------------------------
   6 -- |
   7 -- Module      :  Distribution.Simple.Glob
   8 -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
   9 -- License     :  BSD3
  10 --                portions Copyright (c) 2007, Galois Inc.
  11 --
  12 -- Maintainer  :  cabal-devel@haskell.org
  13 -- Portability :  portable
  14 --
  15 -- Simple file globbing.
  16
  17 module Distribution.Simple.Glob (
  18         GlobSyntaxError(..),
  19         GlobResult(..),
  20         matchDirFileGlob,
  21         runDirFileGlob,
  22         fileGlobMatches,
  23         parseFileGlob,
  24         explainGlobSyntaxError,
  25         Glob,
  26   ) where
  27
  28 import Prelude ()
  29 import Distribution.Compat.Prelude
  30
  31 import Control.Monad (guard)
  32
  33 import Distribution.Simple.Utils
  34 import Distribution.Verbosity
  35 import Distribution.Version
  36
  37 import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)
  38 import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>), (<.>))
  39
  40 -- Note throughout that we use splitDirectories, not splitPath. On
  41 -- Posix, this makes no difference, but, because Windows accepts both
  42 -- slash and backslash as its path separators, if we left in the
  43 -- separators from the glob we might not end up properly normalised.
  44
  45 data GlobResult a
  46   = GlobMatch a
  47     -- ^ The glob matched the value supplied.
  48   | GlobWarnMultiDot a
  49     -- ^ The glob did not match the value supplied because the
  50     --   cabal-version is too low and the extensions on the file did
  51     --   not precisely match the glob's extensions, but rather the
  52     --   glob was a proper suffix of the file's extensions; i.e., if
  53     --   not for the low cabal-version, it would have matched.
  54   | GlobMissingDirectory FilePath
  55     -- ^ The glob couldn't match because the directory named doesn't
  56     --   exist. The directory will be as it appears in the glob (i.e.,
  57     --   relative to the directory passed to 'matchDirFileGlob', and,
  58     --   for 'data-files', relative to 'data-dir').
  59   deriving (Show, Eq, Ord, Functor)
  60
  61 -- | Extract the matches from a list of 'GlobResult's.
  62 --
  63 -- Note: throws away the 'GlobMissingDirectory' results; chances are
  64 -- that you want to check for these and error out if any are present.
  65 globMatches :: [GlobResult a] -> [a]
  66 globMatches input = [ a | GlobMatch a <- input ]
  67
  68 data GlobSyntaxError
  69   = StarInDirectory
  70   | StarInFileName
  71   | StarInExtension
  72   | NoExtensionOnStar
  73   | EmptyGlob
  74   | LiteralFileNameGlobStar
  75   | VersionDoesNotSupportGlobStar
  76   | VersionDoesNotSupportGlob
  77   deriving (Eq, Show)
  78
  79 explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String
  80 explainGlobSyntaxError filepath StarInDirectory =
  81      "invalid file glob '" ++ filepath
  82   ++ "'. A wildcard '**' is only allowed as the final parent"
  83   ++ " directory. Stars must not otherwise appear in the parent"
  84   ++ " directories."
  85 explainGlobSyntaxError filepath StarInExtension =
  86      "invalid file glob '" ++ filepath
  87   ++ "'. Wildcards '*' are only allowed as the"
  88   ++ " file's base name, not in the file extension."
  89 explainGlobSyntaxError filepath StarInFileName =
  90      "invalid file glob '" ++ filepath
  91   ++ "'. Wildcards '*' may only totally replace the"
  92   ++ " file's base name, not only parts of it."
  93 explainGlobSyntaxError filepath NoExtensionOnStar =
  94      "invalid file glob '" ++ filepath
  95   ++ "'. If a wildcard '*' is used it must be with an file extension."
  96 explainGlobSyntaxError filepath LiteralFileNameGlobStar =
  97      "invalid file glob '" ++ filepath
  98   ++ "'. If a wildcard '**' is used as a parent directory, the"
  99   ++ " file's base name must be a wildcard '*'."
 100 explainGlobSyntaxError _ EmptyGlob =
 101      "invalid file glob. A glob cannot be the empty string."
 102 explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar =
 103      "invalid file glob '" ++ filepath
 104   ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"
 105   ++ " or greater. Alternatively, for compatibility with earlier Cabal"
 106   ++ " versions, list the included directories explicitly."
 107 explainGlobSyntaxError filepath VersionDoesNotSupportGlob =
 108      "invalid file glob '" ++ filepath
 109   ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "
 110   ++ "Alternatively if you require compatibility with earlier Cabal "
 111   ++ "versions then list all the files explicitly."
 112
 113 data IsRecursive = Recursive | NonRecursive
 114
 115 data MultiDot = MultiDotDisabled | MultiDotEnabled
 116
 117 data Glob
 118   = GlobStem FilePath Glob
 119     -- ^ A single subdirectory component + remainder.
 120   | GlobFinal GlobFinal
 121
 122 data GlobFinal
 123   = FinalMatch IsRecursive MultiDot String
 124     -- ^ First argument: Is this a @**/*.ext@ pattern?
 125     --   Second argument: should we match against the exact extensions, or accept a suffix?
 126     --   Third argument: the extensions to accept.
 127   | FinalLit FilePath
 128     -- ^ Literal file name.
 129
 130 reconstructGlob :: Glob -> FilePath
 131 reconstructGlob (GlobStem dir glob) =
 132   dir </> reconstructGlob glob
 133 reconstructGlob (GlobFinal final) = case final of
 134   FinalMatch Recursive _ exts -> "**" </> "*" <.> exts
 135   FinalMatch NonRecursive _ exts -> "*" <.> exts
 136   FinalLit path -> path
 137
 138 -- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the
 139 --   result if the glob matched (or would have matched with a higher
 140 --   cabal-version).
 141 fileGlobMatches :: Glob -> FilePath -> Maybe (GlobResult FilePath)
 142 fileGlobMatches pat candidate = do
 143   match <- fileGlobMatchesSegments pat (splitDirectories candidate)
 144   return (candidate <$ match)
 145
 146 fileGlobMatchesSegments :: Glob -> [FilePath] -> Maybe (GlobResult ())
 147 fileGlobMatchesSegments _ [] = Nothing
 148 fileGlobMatchesSegments pat (seg : segs) = case pat of
 149   GlobStem dir pat' -> do
 150     guard (dir == seg)
 151     fileGlobMatchesSegments pat' segs
 152   GlobFinal final -> case final of
 153     FinalMatch Recursive multidot ext -> do
 154       let (candidateBase, candidateExts) = splitExtensions (last $ seg:segs)
 155       guard (not (null candidateBase))
 156       checkExt multidot ext candidateExts
 157     FinalMatch NonRecursive multidot ext -> do
 158       let (candidateBase, candidateExts) = splitExtensions seg
 159       guard (null segs && not (null candidateBase))
 160       checkExt multidot ext candidateExts
 161     FinalLit filename -> do
 162       guard (null segs && filename == seg)
 163       return (GlobMatch ())
 164
 165 checkExt
 166   :: MultiDot
 167   -> String -- ^ The pattern's extension
 168   -> String -- ^ The candidate file's extension
 169   -> Maybe (GlobResult ())
 170 checkExt multidot ext candidate
 171   | ext == candidate = Just (GlobMatch ())
 172   | ext `isSuffixOf` candidate = case multidot of
 173       MultiDotDisabled -> Just (GlobWarnMultiDot ())
 174       MultiDotEnabled -> Just (GlobMatch ())
 175   | otherwise = Nothing
 176
 177 parseFileGlob :: Version -> FilePath -> Either GlobSyntaxError Glob
 178 parseFileGlob version filepath = case reverse (splitDirectories filepath) of
 179   [] ->
 180         Left EmptyGlob
 181   (filename : "**" : segments)
 182     | allowGlobStar -> do
 183         ext <- case splitExtensions filename of
 184           ("*", ext) | '*' `elem` ext -> Left StarInExtension
 185                      | null ext       -> Left NoExtensionOnStar
 186                      | otherwise      -> Right ext
 187           _                           -> Left LiteralFileNameGlobStar
 188         foldM addStem (GlobFinal $ FinalMatch Recursive multidot ext) segments
 189     | otherwise -> Left VersionDoesNotSupportGlobStar
 190   (filename : segments) -> do
 191         pat <- case splitExtensions filename of
 192           ("*", ext) | not allowGlob       -> Left VersionDoesNotSupportGlob
 193                      | '*' `elem` ext      -> Left StarInExtension
 194                      | null ext            -> Left NoExtensionOnStar
 195                      | otherwise           -> Right (FinalMatch NonRecursive multidot ext)
 196           (_, ext)   | '*' `elem` ext      -> Left StarInExtension
 197                      | '*' `elem` filename -> Left StarInFileName
 198                      | otherwise           -> Right (FinalLit filename)
 199         foldM addStem (GlobFinal pat) segments
 200   where
 201     allowGlob = version >= mkVersion [1,6]
 202     allowGlobStar = version >= mkVersion [2,4]
 203     addStem pat seg
 204       | '*' `elem` seg = Left StarInDirectory
 205       | otherwise      = Right (GlobStem seg pat)
 206     multidot
 207       | version >= mkVersion [2,4] = MultiDotEnabled
 208       | otherwise = MultiDotDisabled
 209
 210 -- | This will 'die'' when the glob matches no files, or if the glob
 211 -- refers to a missing directory, or if the glob fails to parse.
 212 --
 213 -- The returned values do not include the supplied @dir@ prefix, which
 214 -- must itself be a valid directory (hence, it can't be the empty
 215 -- string).
 216 matchDirFileGlob :: Verbosity -> Version -> FilePath -> FilePath -> IO [FilePath]
 217 matchDirFileGlob verbosity version dir filepath = case parseFileGlob version filepath of
 218   Left err -> die' verbosity $ explainGlobSyntaxError filepath err
 219   Right glob -> do
 220     results <- runDirFileGlob verbosity dir glob
 221     let missingDirectories =
 222           [ missingDir | GlobMissingDirectory missingDir <- results ]
 223         matches = globMatches results
 224     -- Check for missing directories first, since we'll obviously have
 225     -- no matches in that case.
 226     for_ missingDirectories $ \ missingDir ->
 227       die' verbosity $
 228            "filepath wildcard '" ++ filepath ++ "' refers to the directory"
 229         ++ " '" ++ missingDir ++ "', which does not exist or is not a directory."
 230     when (null matches) $ die' verbosity $
 231          "filepath wildcard '" ++ filepath
 232       ++ "' does not match any files."
 233     return matches
 234
 235 -- | Match files against a pre-parsed glob, starting in a directory.
 236 --
 237 -- The returned values do not include the supplied @dir@ prefix, which
 238 -- must itself be a valid directory (hence, it can't be the empty
 239 -- string).
 240 runDirFileGlob :: Verbosity -> FilePath -> Glob -> IO [GlobResult FilePath]
 241 runDirFileGlob verbosity rawDir pat = do
 242   -- The default data-dir is null. Our callers -should- be
 243   -- converting that to '.' themselves, but it's a certainty that
 244   -- some future call-site will forget and trigger a really
 245   -- hard-to-debug failure if we don't check for that here.
 246   when (null rawDir) $
 247     warn verbosity $
 248          "Null dir passed to runDirFileGlob; interpreting it "
 249       ++ "as '.'. This is probably an internal error."
 250   let dir = if null rawDir then "." else rawDir
 251   debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'."
 252   -- This function might be called from the project root with dir as
 253   -- ".". Walking the tree starting there involves going into .git/
 254   -- and dist-newstyle/, which is a lot of work for no reward, so
 255   -- extract the constant prefix from the pattern and start walking
 256   -- there, and only walk as much as we need to: recursively if **,
 257   -- the whole directory if *, and just the specific file if it's a
 258   -- literal.
 259   let (prefixSegments, final) = splitConstantPrefix pat
 260       joinedPrefix = joinPath prefixSegments
 261   case final of
 262     FinalMatch recursive multidot exts -> do
 263       let prefix = dir </> joinedPrefix
 264       directoryExists <- doesDirectoryExist prefix
 265       if directoryExists
 266         then do
 267           candidates <- case recursive of
 268             Recursive -> getDirectoryContentsRecursive prefix
 269             NonRecursive -> filterM (doesFileExist . (prefix </>)) =<< getDirectoryContents prefix
 270           let checkName candidate = do
 271                 let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate
 272                 guard (not (null candidateBase))
 273                 match <- checkExt multidot exts candidateExts
 274                 return (joinedPrefix </> candidate <$ match)
 275           return $ mapMaybe checkName candidates
 276         else
 277           return [ GlobMissingDirectory joinedPrefix ]
 278     FinalLit fn -> do
 279       exists <- doesFileExist (dir </> joinedPrefix </> fn)
 280       return [ GlobMatch (joinedPrefix </> fn) | exists ]
 281
 282 unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)
 283 unfoldr' f a = case f a of
 284   Left r -> ([], r)
 285   Right (b, a') -> case unfoldr' f a' of
 286     (bs, r) -> (b : bs, r)
 287
 288 -- | Extract the (possibly null) constant prefix from the pattern.
 289 -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,
 290 -- then @pat === foldr GlobStem (GlobFinal final) pref@.
 291 splitConstantPrefix :: Glob -> ([FilePath], GlobFinal)
 292 splitConstantPrefix = unfoldr' step
 293   where
 294     step (GlobStem seg pat) = Right (seg, pat)
 295     step (GlobFinal pat) = Left pat