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

   1 {-# LANGUAGE DeriveGeneric #-}
   2
   3 module Distribution.Client.Glob
   4   ( -- * cabal-install globbing features
   5     RootedGlob (..)
   6   , isTrivialRootedGlob
   7   , FilePathRoot (..)
   8   , getFilePathRootDirectory
   9
  10     -- * Additional re-exports
  11   , module Distribution.Simple.Glob
  12   , Glob (..)
  13   , GlobPiece (..)
  14   , GlobPieces
  15   , matchFileGlob
  16   ) where
  17
  18 import Distribution.Client.Compat.Prelude
  19 import Prelude ()
  20
  21 import Distribution.Simple.FileMonitor.Types
  22 import Distribution.Simple.Glob
  23 import Distribution.Simple.Glob.Internal
  24   ( Glob (..)
  25   , GlobPiece (..)
  26   , GlobPieces
  27   )
  28
  29 import System.Directory
  30 import System.FilePath
  31
  32 --------------------------------------------------------------------------------
  33
  34 -- | Check if a 'RootedGlob' doesn't actually make use of any globbing and
  35 -- is in fact equivalent to a non-glob 'FilePath'.
  36 --
  37 -- If it is trivial in this sense then the result is the equivalent constant
  38 -- 'FilePath'. On the other hand, if it is not trivial (so could in principle
  39 -- match more than one file), then the result is @Nothing@.
  40 isTrivialRootedGlob :: RootedGlob -> Maybe FilePath
  41 isTrivialRootedGlob (RootedGlob root pathglob) =
  42   case root of
  43     FilePathRelative -> go [] pathglob
  44     FilePathRoot root' -> go [root'] pathglob
  45     -- TODO: why don't we do the following?
  46     -- > go ["~"] pathglob
  47     FilePathHomeDir -> Nothing
  48   where
  49     go paths (GlobDir [Literal path] globs) = go (path : paths) globs
  50     go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path : paths)))
  51     go paths GlobDirTrailing =
  52       Just
  53         ( addTrailingPathSeparator
  54             (joinPath (reverse paths))
  55         )
  56     go _ _ = Nothing
  57
  58 -- | Get the 'FilePath' corresponding to a 'FilePathRoot'.
  59 --
  60 -- The 'FilePath' argument is required to supply the path for the
  61 -- 'FilePathRelative' case.
  62 getFilePathRootDirectory
  63   :: FilePathRoot
  64   -> FilePath
  65   -- ^ root for relative paths
  66   -> IO FilePath
  67 getFilePathRootDirectory FilePathRelative root = return root
  68 getFilePathRootDirectory (FilePathRoot root) _ = return root
  69 getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory
  70
  71 ------------------------------------------------------------------------------
  72 -- Matching
  73 --
  74
  75 -- | Match a 'RootedGlob' against the file system, starting from a given
  76 -- root directory for relative paths. The results of relative globs are
  77 -- relative to the given root. Matches for absolute globs are absolute.
  78 matchFileGlob :: FilePath -> RootedGlob -> IO [FilePath]
  79 matchFileGlob relroot (RootedGlob globroot glob) = do
  80   root <- getFilePathRootDirectory globroot relroot
  81   matches <- matchGlob root glob
  82   case globroot of
  83     FilePathRelative -> return matches
  84     _ -> return (map (root </>) matches)