cabal-install/src/Distribution/Client/Glob.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2
   3 -- TODO: [code cleanup] plausibly much of this module should be merged with
   4 -- similar functionality in Cabal.
   5 module Distribution.Client.Glob
   6   ( FilePathGlob (..)
   7   , FilePathRoot (..)
   8   , FilePathGlobRel (..)
   9   , Glob
  10   , GlobPiece (..)
  11   , matchFileGlob
  12   , matchFileGlobRel
  13   , matchGlob
  14   , isTrivialFilePathGlob
  15   , getFilePathRootDirectory
  16   ) where
  17
  18 import Distribution.Client.Compat.Prelude
  19 import Prelude ()
  20
  21 import Data.List (stripPrefix)
  22 import System.Directory
  23 import System.FilePath
  24
  25 import qualified Distribution.Compat.CharParsing as P
  26 import qualified Text.PrettyPrint as Disp
  27
  28 -- | A file path specified by globbing
  29 data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
  30   deriving (Eq, Show, Generic)
  31
  32 data FilePathGlobRel
  33   = GlobDir !Glob !FilePathGlobRel
  34   | GlobFile !Glob
  35   | -- | trailing dir, a glob ending in @/@
  36     GlobDirTrailing
  37   deriving (Eq, Show, Generic)
  38
  39 -- | A single directory or file component of a globbed path
  40 type Glob = [GlobPiece]
  41
  42 -- | A piece of a globbing pattern
  43 data GlobPiece
  44   = WildCard
  45   | Literal String
  46   | Union [Glob]
  47   deriving (Eq, Show, Generic)
  48
  49 data FilePathRoot
  50   = FilePathRelative
  51   | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive'
  52     FilePathRoot FilePath
  53   | FilePathHomeDir
  54   deriving (Eq, Show, Generic)
  55
  56 instance Binary FilePathGlob
  57 instance Binary FilePathRoot
  58 instance Binary FilePathGlobRel
  59 instance Binary GlobPiece
  60
  61 instance Structured FilePathGlob
  62 instance Structured FilePathRoot
  63 instance Structured FilePathGlobRel
  64 instance Structured GlobPiece
  65
  66 -- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and
  67 -- is in fact equivalent to a non-glob 'FilePath'.
  68 --
  69 -- If it is trivial in this sense then the result is the equivalent constant
  70 -- 'FilePath'. On the other hand if it is not trivial (so could in principle
  71 -- match more than one file) then the result is @Nothing@.
  72 isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
  73 isTrivialFilePathGlob (FilePathGlob root pathglob) =
  74   case root of
  75     FilePathRelative -> go [] pathglob
  76     FilePathRoot root' -> go [root'] pathglob
  77     FilePathHomeDir -> Nothing
  78   where
  79     go paths (GlobDir [Literal path] globs) = go (path : paths) globs
  80     go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path : paths)))
  81     go paths GlobDirTrailing =
  82       Just
  83         ( addTrailingPathSeparator
  84             (joinPath (reverse paths))
  85         )
  86     go _ _ = Nothing
  87
  88 -- | Get the 'FilePath' corresponding to a 'FilePathRoot'.
  89 --
  90 -- The 'FilePath' argument is required to supply the path for the
  91 -- 'FilePathRelative' case.
  92 getFilePathRootDirectory
  93   :: FilePathRoot
  94   -> FilePath
  95   -- ^ root for relative paths
  96   -> IO FilePath
  97 getFilePathRootDirectory FilePathRelative root = return root
  98 getFilePathRootDirectory (FilePathRoot root) _ = return root
  99 getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory
 100
 101 ------------------------------------------------------------------------------
 102 -- Matching
 103 --
 104
 105 -- | Match a 'FilePathGlob' against the file system, starting from a given
 106 -- root directory for relative paths. The results of relative globs are
 107 -- relative to the given root. Matches for absolute globs are absolute.
 108 matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]
 109 matchFileGlob relroot (FilePathGlob globroot glob) = do
 110   root <- getFilePathRootDirectory globroot relroot
 111   matches <- matchFileGlobRel root glob
 112   case globroot of
 113     FilePathRelative -> return matches
 114     _ -> return (map (root </>) matches)
 115
 116 -- | Match a 'FilePathGlobRel' against the file system, starting from a
 117 -- given root directory. The results are all relative to the given root.
 118 matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]
 119 matchFileGlobRel root glob0 = go glob0 ""
 120   where
 121     go (GlobFile glob) dir = do
 122       entries <- getDirectoryContents (root </> dir)
 123       let files = filter (matchGlob glob) entries
 124       return (map (dir </>) files)
 125     go (GlobDir glob globPath) dir = do
 126       entries <- getDirectoryContents (root </> dir)
 127       subdirs <-
 128         filterM
 129           ( \subdir ->
 130               doesDirectoryExist
 131                 (root </> dir </> subdir)
 132           )
 133           $ filter (matchGlob glob) entries
 134       concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs
 135     go GlobDirTrailing dir = return [dir]
 136
 137 -- | Match a globbing pattern against a file path component
 138 matchGlob :: Glob -> String -> Bool
 139 matchGlob = goStart
 140   where
 141     -- From the man page, glob(7):
 142     --   "If a filename starts with a '.', this character must be
 143     --    matched explicitly."
 144
 145     go, goStart :: [GlobPiece] -> String -> Bool
 146
 147     goStart (WildCard : _) ('.' : _) = False
 148     goStart (Union globs : rest) cs =
 149       any
 150         (\glob -> goStart (glob ++ rest) cs)
 151         globs
 152     goStart rest cs = go rest cs
 153
 154     go [] "" = True
 155     go (Literal lit : rest) cs
 156       | Just cs' <- stripPrefix lit cs =
 157           go rest cs'
 158       | otherwise = False
 159     go [WildCard] "" = True
 160     go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs
 161     go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs
 162     go [] (_ : _) = False
 163     go (_ : _) "" = False
 164
 165 ------------------------------------------------------------------------------
 166 -- Parsing & printing
 167 --
 168
 169 instance Pretty FilePathGlob where
 170   pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob
 171
 172 instance Parsec FilePathGlob where
 173   parsec = do
 174     root <- parsec
 175     case root of
 176       FilePathRelative -> FilePathGlob root <$> parsec
 177       _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing)
 178
 179 instance Pretty FilePathRoot where
 180   pretty FilePathRelative = Disp.empty
 181   pretty (FilePathRoot root) = Disp.text root
 182   pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/'
 183
 184 instance Parsec FilePathRoot where
 185   parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative
 186     where
 187       root = FilePathRoot "/" <$ P.char '/'
 188       home = FilePathHomeDir <$ P.string "~/"
 189       drive = do
 190         dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
 191         _ <- P.char ':'
 192         _ <- P.char '/' <|> P.char '\\'
 193         return (FilePathRoot (toUpper dr : ":\\"))
 194
 195 instance Pretty FilePathGlobRel where
 196   pretty (GlobDir glob pathglob) =
 197     dispGlob glob
 198       Disp.<> Disp.char '/'
 199       Disp.<> pretty pathglob
 200   pretty (GlobFile glob) = dispGlob glob
 201   pretty GlobDirTrailing = Disp.empty
 202
 203 instance Parsec FilePathGlobRel where
 204   parsec = parsecPath
 205     where
 206       parsecPath :: CabalParsing m => m FilePathGlobRel
 207       parsecPath = do
 208         glob <- parsecGlob
 209         dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
 210
 211       dirSep :: CabalParsing m => m ()
 212       dirSep =
 213         () <$ P.char '/'
 214           <|> P.try
 215             ( do
 216                 _ <- P.char '\\'
 217                 -- check this isn't an escape code
 218                 P.notFollowedBy (P.satisfy isGlobEscapedChar)
 219             )
 220
 221 dispGlob :: Glob -> Disp.Doc
 222 dispGlob = Disp.hcat . map dispPiece
 223   where
 224     dispPiece WildCard = Disp.char '*'
 225     dispPiece (Literal str) = Disp.text (escape str)
 226     dispPiece (Union globs) =
 227       Disp.braces
 228         ( Disp.hcat
 229             ( Disp.punctuate
 230                 (Disp.char ',')
 231                 (map dispGlob globs)
 232             )
 233         )
 234     escape [] = []
 235     escape (c : cs)
 236       | isGlobEscapedChar c = '\\' : c : escape cs
 237       | otherwise = c : escape cs
 238
 239 parsecGlob :: CabalParsing m => m Glob
 240 parsecGlob = some parsecPiece
 241   where
 242     parsecPiece = P.choice [literal, wildcard, union]
 243
 244     wildcard = WildCard <$ P.char '*'
 245     union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))
 246     literal = Literal <$> some litchar
 247
 248     litchar = normal <|> escape
 249
 250     normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')
 251     escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar
 252
 253 isGlobEscapedChar :: Char -> Bool
 254 isGlobEscapedChar '*' = True
 255 isGlobEscapedChar '{' = True
 256 isGlobEscapedChar '}' = True
 257 isGlobEscapedChar ',' = True
 258 isGlobEscapedChar _ = False