{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.Glob
-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
-- License     :  BSD3
--                portions Copyright (c) 2007, Galois Inc.
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Simple file globbing.
module Distribution.Simple.Glob
  ( -- * Globs
    Glob

    -- * Matching on globs
  , GlobResult (..)
  , globMatches
  , fileGlobMatches
  , matchGlob
  , matchGlobPieces
  , matchDirFileGlob
  , matchDirFileGlobWithDie
  , runDirFileGlob

    -- * Parsing globs
  , parseFileGlob
  , GlobSyntaxError (..)
  , explainGlobSyntaxError

    -- * Utility
  , isRecursiveInRoot
  )
where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.CabalSpecVersion
  ( CabalSpecVersion (..)
  )
import Distribution.Pretty
import Distribution.Simple.Errors
  ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors)
  )
import Distribution.Simple.Glob.Internal
import Distribution.Simple.Utils
  ( debug
  , dieWithException
  , getDirectoryContentsRecursive
  , warn
  )
import Distribution.Utils.Path
import Distribution.Verbosity
  ( Verbosity
  , silent
  )

import Control.Monad (mapM)
import Data.List (stripPrefix)
import System.Directory
import System.FilePath hiding ((<.>), (</>))

-------------------------------------------------------------------------------

-- * Matching

--------------------------------------------------------------------------------

-- | Match a 'Glob' against the file system, starting from a
-- given root directory. The results are all relative to the given root.
--
-- @since 3.12.0.0
matchGlob :: FilePath -> Glob -> IO [FilePath]
matchGlob :: String -> Glob -> IO [String]
matchGlob String
root Glob
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.
  (GlobResult String -> Maybe String)
-> [GlobResult String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
    ( \case
        GlobMatch String
a -> String -> Maybe String
forall a. a -> Maybe a
Just String
a
        GlobWarnMultiDot String
a -> String -> Maybe String
forall a. a -> Maybe a
Just String
a
        GlobMatchesDirectory String
a -> String -> Maybe String
forall a. a -> Maybe a
Just String
a
        GlobMissingDirectory{} -> Maybe String
forall a. Maybe a
Nothing
    )
    ([GlobResult String] -> [String])
-> IO [GlobResult String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Maybe CabalSpecVersion
-> String
-> Glob
-> IO [GlobResult String]
runDirFileGlob Verbosity
silent Maybe CabalSpecVersion
forall a. Maybe a
Nothing String
root Glob
glob

-- | Match a globbing pattern against a file path component
matchGlobPieces :: GlobPieces -> String -> Bool
matchGlobPieces :: GlobPieces -> String -> Bool
matchGlobPieces = GlobPieces -> String -> Bool
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 :: GlobPieces -> String -> Bool
goStart (GlobPiece
WildCard : GlobPieces
_) (Char
'.' : String
_) = Bool
False
    goStart (Union [GlobPieces]
globs : GlobPieces
rest) String
cs =
      (GlobPieces -> Bool) -> [GlobPieces] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
        (\GlobPieces
glob -> GlobPieces -> String -> Bool
goStart (GlobPieces
glob GlobPieces -> GlobPieces -> GlobPieces
forall a. [a] -> [a] -> [a]
++ GlobPieces
rest) String
cs)
        [GlobPieces]
globs
    goStart GlobPieces
rest String
cs = GlobPieces -> String -> Bool
go GlobPieces
rest String
cs

    go :: GlobPieces -> String -> Bool
go [] String
"" = Bool
True
    go (Literal String
lit : GlobPieces
rest) String
cs
      | Just String
cs' <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
lit String
cs =
          GlobPieces -> String -> Bool
go GlobPieces
rest String
cs'
      | Bool
otherwise = Bool
False
    go [GlobPiece
WildCard] String
"" = Bool
True
    go (GlobPiece
WildCard : GlobPieces
rest) (Char
c : String
cs) = GlobPieces -> String -> Bool
go GlobPieces
rest (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs) Bool -> Bool -> Bool
|| GlobPieces -> String -> Bool
go (GlobPiece
WildCard GlobPiece -> GlobPieces -> GlobPieces
forall a. a -> [a] -> [a]
: GlobPieces
rest) String
cs
    go (Union [GlobPieces]
globs : GlobPieces
rest) String
cs = (GlobPieces -> Bool) -> [GlobPieces] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\GlobPieces
glob -> GlobPieces -> String -> Bool
go (GlobPieces
glob GlobPieces -> GlobPieces -> GlobPieces
forall a. [a] -> [a] -> [a]
++ GlobPieces
rest) String
cs) [GlobPieces]
globs
    go [] (Char
_ : String
_) = Bool
False
    go (GlobPiece
_ : GlobPieces
_) String
"" = Bool
False

-- | 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.
--
-- @since 3.12.0.0
globMatches :: [GlobResult a] -> [a]
globMatches :: forall a. [GlobResult a] -> [a]
globMatches [GlobResult a]
input = [a
a | GlobMatch a
a <- [GlobResult 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.
--
-- The 'Version' argument must be the spec version of the package
-- description being processed, as globs behave slightly differently
-- in different spec versions.
--
-- The first '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.
--
-- The second 'FilePath' is the glob itself.
matchDirFileGlob
  :: Verbosity
  -> CabalSpecVersion
  -> Maybe (SymbolicPath CWD (Dir dir))
  -> SymbolicPathX allowAbs dir file
  -> IO [SymbolicPathX allowAbs dir file]
matchDirFileGlob :: forall dir (allowAbs :: AllowAbsolute) (file :: FileOrDir).
Verbosity
-> CabalSpecVersion
-> Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPathX allowAbs dir file
-> IO [SymbolicPathX allowAbs dir file]
matchDirFileGlob Verbosity
v = Verbosity
-> (forall res. Verbosity -> CabalException -> IO [res])
-> CabalSpecVersion
-> Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPathX allowAbs dir file
-> IO [SymbolicPathX allowAbs dir file]
forall dir (allowAbs :: AllowAbsolute) (file :: FileOrDir).
Verbosity
-> (forall res. Verbosity -> CabalException -> IO [res])
-> CabalSpecVersion
-> Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPathX allowAbs dir file
-> IO [SymbolicPathX allowAbs dir file]
matchDirFileGlobWithDie Verbosity
v Verbosity -> CabalException -> IO [res]
forall res. Verbosity -> CabalException -> IO [res]
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException

-- | Like 'matchDirFileGlob' but with customizable 'die'
--
-- @since 3.6.0.0
matchDirFileGlobWithDie
  :: Verbosity
  -> (forall res. Verbosity -> CabalException -> IO [res])
  -> CabalSpecVersion
  -> Maybe (SymbolicPath CWD (Dir dir))
  -> SymbolicPathX allowAbs dir file
  -> IO [SymbolicPathX allowAbs dir file]
matchDirFileGlobWithDie :: forall dir (allowAbs :: AllowAbsolute) (file :: FileOrDir).
Verbosity
-> (forall res. Verbosity -> CabalException -> IO [res])
-> CabalSpecVersion
-> Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPathX allowAbs dir file
-> IO [SymbolicPathX allowAbs dir file]
matchDirFileGlobWithDie Verbosity
verbosity forall res. Verbosity -> CabalException -> IO [res]
rip CabalSpecVersion
version Maybe (SymbolicPath CWD ('Dir dir))
mbWorkDir SymbolicPathX allowAbs dir file
symPath =
  let rawFilePath :: String
rawFilePath = SymbolicPathX allowAbs dir file -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPathX allowAbs dir file
symPath
      dir :: String
dir = String
-> (SymbolicPath CWD ('Dir dir) -> String)
-> Maybe (SymbolicPath CWD ('Dir dir))
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"." SymbolicPath CWD ('Dir dir) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath Maybe (SymbolicPath CWD ('Dir dir))
mbWorkDir
   in case CabalSpecVersion -> String -> Either GlobSyntaxError Glob
parseFileGlob CabalSpecVersion
version String
rawFilePath of
        Left GlobSyntaxError
err -> Verbosity -> CabalException -> IO [SymbolicPathX allowAbs dir file]
forall res. Verbosity -> CabalException -> IO [res]
rip Verbosity
verbosity (CabalException -> IO [SymbolicPathX allowAbs dir file])
-> CabalException -> IO [SymbolicPathX allowAbs dir file]
forall a b. (a -> b) -> a -> b
$ String -> CabalException
MatchDirFileGlob (String -> GlobSyntaxError -> String
explainGlobSyntaxError String
rawFilePath GlobSyntaxError
err)
        Right Glob
glob -> do
          results <- Verbosity
-> Maybe CabalSpecVersion
-> String
-> Glob
-> IO [GlobResult String]
runDirFileGlob Verbosity
verbosity (CabalSpecVersion -> Maybe CabalSpecVersion
forall a. a -> Maybe a
Just CabalSpecVersion
version) String
dir Glob
glob
          let missingDirectories =
                [String
missingDir | GlobMissingDirectory String
missingDir <- [GlobResult String]
results]
              matches = [GlobResult String] -> [String]
forall a. [GlobResult a] -> [a]
globMatches [GlobResult String]
results
              directoryMatches = [String
a | GlobMatchesDirectory String
a <- [GlobResult String]
results]

          let errors :: [String]
              errors =
                [ String
"filepath wildcard '"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rawFilePath
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' refers to the directory"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" '"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
missingDir
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"', which does not exist or is not a directory."
                | String
missingDir <- [String]
missingDirectories
                ]
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"filepath wildcard '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rawFilePath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' does not match any files."
                     | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
matches Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
directoryMatches
                     -- we don't error out on directory matches, simply warn about them and ignore.
                     ]

              warns :: [String]
              warns =
                [ String
"Ignoring directory '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" listed in a Cabal package field which should only include files (not directories)."
                | String
path <- [String]
directoryMatches
                ]

          if null errors
            then do
              unless (null warns) $
                warn verbosity $
                  unlines warns
              return $ map unsafeMakeSymbolicPath matches
            else rip verbosity $ MatchDirFileGlobErrors errors

-------------------------------------------------------------------------------

-- * 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 :: CabalSpecVersion -> String -> Either GlobSyntaxError Glob
parseFileGlob CabalSpecVersion
version String
filepath = case [String] -> [String]
forall a. [a] -> [a]
reverse (String -> [String]
splitDirectories String
filepath) of
  [] ->
    GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
EmptyGlob
  (String
filename : String
"**" : [String]
segments)
    | Bool
allowGlobStar -> do
        finalSegment <- case String -> (String, String)
splitExtensions String
filename of
          (String
"*", String
ext)
            | Char
'*' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ext -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
StarInExtension
            | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ext -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
NoExtensionOnStar
            | Bool
otherwise -> Glob -> Either GlobSyntaxError Glob
forall a b. b -> Either a b
Right (GlobPieces -> Glob
GlobDirRecursive [GlobPiece
WildCard, String -> GlobPiece
Literal String
ext])
          (String, String)
_
            | Bool
allowLiteralFilenameGlobStar ->
                Glob -> Either GlobSyntaxError Glob
forall a b. b -> Either a b
Right (GlobPieces -> Glob
GlobDirRecursive [String -> GlobPiece
Literal String
filename])
            | Bool
otherwise ->
                GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
LiteralFileNameGlobStar

        foldM addStem finalSegment segments
    | Bool
otherwise -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
VersionDoesNotSupportGlobStar
  (String
filename : [String]
segments) -> do
    pat <- case String -> (String, String)
splitExtensions String
filename of
      (String
"*", String
ext)
        | Bool -> Bool
not Bool
allowGlob -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
VersionDoesNotSupportGlob
        | Char
'*' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ext -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
StarInExtension
        | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ext -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
NoExtensionOnStar
        | Bool
otherwise -> Glob -> Either GlobSyntaxError Glob
forall a b. b -> Either a b
Right (GlobPieces -> Glob
GlobFile [GlobPiece
WildCard, String -> GlobPiece
Literal String
ext])
      (String
_, String
ext)
        | Char
'*' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ext -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
StarInExtension
        | Char
'*' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
filename -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
StarInFileName
        | Bool
otherwise -> Glob -> Either GlobSyntaxError Glob
forall a b. b -> Either a b
Right (GlobPieces -> Glob
GlobFile [String -> GlobPiece
Literal String
filename])

    foldM addStem pat segments
  where
    addStem :: Glob -> String -> Either GlobSyntaxError Glob
addStem Glob
pat String
seg
      | Char
'*' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
seg = GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
StarInDirectory
      | Bool
otherwise = Glob -> Either GlobSyntaxError Glob
forall a b. b -> Either a b
Right (GlobPieces -> Glob -> Glob
GlobDir [String -> GlobPiece
Literal String
seg] Glob
pat)
    allowGlob :: Bool
allowGlob = CabalSpecVersion
version CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV1_6
    allowGlobStar :: Bool
allowGlobStar = CabalSpecVersion
version CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV2_4
    allowLiteralFilenameGlobStar :: Bool
allowLiteralFilenameGlobStar = CabalSpecVersion
version CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_8

enableMultidot :: CabalSpecVersion -> Bool
enableMultidot :: CabalSpecVersion -> Bool
enableMultidot CabalSpecVersion
version
  | CabalSpecVersion
version CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV2_4 = Bool
True
  | Bool
otherwise = Bool
False

--------------------------------------------------------------------------------
-- Parse and printing utils
--------------------------------------------------------------------------------

-- ** Cabal package globbing errors

data GlobSyntaxError
  = StarInDirectory
  | StarInFileName
  | StarInExtension
  | NoExtensionOnStar
  | EmptyGlob
  | LiteralFileNameGlobStar
  | VersionDoesNotSupportGlobStar
  | VersionDoesNotSupportGlob
  deriving (GlobSyntaxError -> GlobSyntaxError -> Bool
(GlobSyntaxError -> GlobSyntaxError -> Bool)
-> (GlobSyntaxError -> GlobSyntaxError -> Bool)
-> Eq GlobSyntaxError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobSyntaxError -> GlobSyntaxError -> Bool
== :: GlobSyntaxError -> GlobSyntaxError -> Bool
$c/= :: GlobSyntaxError -> GlobSyntaxError -> Bool
/= :: GlobSyntaxError -> GlobSyntaxError -> Bool
Eq, Int -> GlobSyntaxError -> String -> String
[GlobSyntaxError] -> String -> String
GlobSyntaxError -> String
(Int -> GlobSyntaxError -> String -> String)
-> (GlobSyntaxError -> String)
-> ([GlobSyntaxError] -> String -> String)
-> Show GlobSyntaxError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GlobSyntaxError -> String -> String
showsPrec :: Int -> GlobSyntaxError -> String -> String
$cshow :: GlobSyntaxError -> String
show :: GlobSyntaxError -> String
$cshowList :: [GlobSyntaxError] -> String -> String
showList :: [GlobSyntaxError] -> String -> String
Show)

explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String
explainGlobSyntaxError :: String -> GlobSyntaxError -> String
explainGlobSyntaxError String
filepath GlobSyntaxError
StarInDirectory =
  String
"invalid file glob '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filepath
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. A wildcard '**' is only allowed as the final parent"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" directory. Stars must not otherwise appear in the parent"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" directories."
explainGlobSyntaxError String
filepath GlobSyntaxError
StarInExtension =
  String
"invalid file glob '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filepath
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. Wildcards '*' are only allowed as the"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" file's base name, not in the file extension."
explainGlobSyntaxError String
filepath GlobSyntaxError
StarInFileName =
  String
"invalid file glob '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filepath
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. Wildcards '*' may only totally replace the"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" file's base name, not only parts of it."
explainGlobSyntaxError String
filepath GlobSyntaxError
NoExtensionOnStar =
  String
"invalid file glob '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filepath
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. If a wildcard '*' is used it must be with an file extension."
explainGlobSyntaxError String
filepath GlobSyntaxError
LiteralFileNameGlobStar =
  String
"invalid file glob '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filepath
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. Prior to 'cabal-version: 3.8'"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" if a wildcard '**' is used as a parent directory, the"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" file's base name must be a wildcard '*'."
explainGlobSyntaxError String
_ GlobSyntaxError
EmptyGlob =
  String
"invalid file glob. A glob cannot be the empty string."
explainGlobSyntaxError String
filepath GlobSyntaxError
VersionDoesNotSupportGlobStar =
  String
"invalid file glob '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filepath
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. Using the double-star syntax requires 'cabal-version: 2.4'"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" or greater. Alternatively, for compatibility with earlier Cabal"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" versions, list the included directories explicitly."
explainGlobSyntaxError String
filepath GlobSyntaxError
VersionDoesNotSupportGlob =
  String
"invalid file glob '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filepath
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. Using star wildcards requires 'cabal-version: >= 1.6'. "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Alternatively if you require compatibility with earlier Cabal "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"versions then list all the files explicitly."

-- 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 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!
    --
    -- @since 3.12.0.0
    GlobMatchesDirectory a
  deriving (Int -> GlobResult a -> String -> String
[GlobResult a] -> String -> String
GlobResult a -> String
(Int -> GlobResult a -> String -> String)
-> (GlobResult a -> String)
-> ([GlobResult a] -> String -> String)
-> Show (GlobResult a)
forall a. Show a => Int -> GlobResult a -> String -> String
forall a. Show a => [GlobResult a] -> String -> String
forall a. Show a => GlobResult a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a. Show a => Int -> GlobResult a -> String -> String
showsPrec :: Int -> GlobResult a -> String -> String
$cshow :: forall a. Show a => GlobResult a -> String
show :: GlobResult a -> String
$cshowList :: forall a. Show a => [GlobResult a] -> String -> String
showList :: [GlobResult a] -> String -> String
Show, GlobResult a -> GlobResult a -> Bool
(GlobResult a -> GlobResult a -> Bool)
-> (GlobResult a -> GlobResult a -> Bool) -> Eq (GlobResult a)
forall a. Eq a => GlobResult a -> GlobResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => GlobResult a -> GlobResult a -> Bool
== :: GlobResult a -> GlobResult a -> Bool
$c/= :: forall a. Eq a => GlobResult a -> GlobResult a -> Bool
/= :: GlobResult a -> GlobResult a -> Bool
Eq, Eq (GlobResult a)
Eq (GlobResult a) =>
(GlobResult a -> GlobResult a -> Ordering)
-> (GlobResult a -> GlobResult a -> Bool)
-> (GlobResult a -> GlobResult a -> Bool)
-> (GlobResult a -> GlobResult a -> Bool)
-> (GlobResult a -> GlobResult a -> Bool)
-> (GlobResult a -> GlobResult a -> GlobResult a)
-> (GlobResult a -> GlobResult a -> GlobResult a)
-> Ord (GlobResult a)
GlobResult a -> GlobResult a -> Bool
GlobResult a -> GlobResult a -> Ordering
GlobResult a -> GlobResult a -> GlobResult a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (GlobResult a)
forall a. Ord a => GlobResult a -> GlobResult a -> Bool
forall a. Ord a => GlobResult a -> GlobResult a -> Ordering
forall a. Ord a => GlobResult a -> GlobResult a -> GlobResult a
$ccompare :: forall a. Ord a => GlobResult a -> GlobResult a -> Ordering
compare :: GlobResult a -> GlobResult a -> Ordering
$c< :: forall a. Ord a => GlobResult a -> GlobResult a -> Bool
< :: GlobResult a -> GlobResult a -> Bool
$c<= :: forall a. Ord a => GlobResult a -> GlobResult a -> Bool
<= :: GlobResult a -> GlobResult a -> Bool
$c> :: forall a. Ord a => GlobResult a -> GlobResult a -> Bool
> :: GlobResult a -> GlobResult a -> Bool
$c>= :: forall a. Ord a => GlobResult a -> GlobResult a -> Bool
>= :: GlobResult a -> GlobResult a -> Bool
$cmax :: forall a. Ord a => GlobResult a -> GlobResult a -> GlobResult a
max :: GlobResult a -> GlobResult a -> GlobResult a
$cmin :: forall a. Ord a => GlobResult a -> GlobResult a -> GlobResult a
min :: GlobResult a -> GlobResult a -> GlobResult a
Ord, (forall a b. (a -> b) -> GlobResult a -> GlobResult b)
-> (forall a b. a -> GlobResult b -> GlobResult a)
-> Functor GlobResult
forall a b. a -> GlobResult b -> GlobResult a
forall a b. (a -> b) -> GlobResult a -> GlobResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GlobResult a -> GlobResult b
fmap :: forall a b. (a -> b) -> GlobResult a -> GlobResult b
$c<$ :: forall a b. a -> GlobResult b -> GlobResult a
<$ :: forall a b. a -> GlobResult b -> GlobResult a
Functor)

-- | Match files against a pre-parsed glob, starting in a directory.
--
-- The 'Version' argument must be the spec version of the package
-- description being processed, as globs behave slightly differently
-- in different spec versions.
--
-- 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
  -> 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
-> Maybe CabalSpecVersion
-> String
-> Glob
-> IO [GlobResult String]
runDirFileGlob Verbosity
verbosity Maybe CabalSpecVersion
mspec String
rawRoot Glob
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.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rawRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"Null dir passed to runDirFileGlob; interpreting it "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"as '.'. This is probably an internal error."
  let root :: String
root = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rawRoot then String
"." else String
rawRoot
  Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expanding glob '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Glob -> Doc
forall a. Pretty a => a -> Doc
pretty Glob
pat) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' in directory '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
root String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."
  -- 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
  -- extract the constant prefix from the pattern and start walking
  -- 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
    ([String]
prefixSegments, Glob
variablePattern) = Glob -> ([String], Glob)
splitConstantPrefix Glob
pat
    joinedPrefix :: String
joinedPrefix = [String] -> String
joinPath [String]
prefixSegments

    -- The glob matching function depends on whether we care about the cabal version or not
    doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ())
    doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ())
doesGlobMatch GlobPieces
glob String
str = case Maybe CabalSpecVersion
mspec of
      Just CabalSpecVersion
spec -> CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())
checkNameMatches CabalSpecVersion
spec GlobPieces
glob String
str
      Maybe CabalSpecVersion
Nothing -> if GlobPieces -> String -> Bool
matchGlobPieces GlobPieces
glob String
str then GlobResult () -> Maybe (GlobResult ())
forall a. a -> Maybe a
Just (() -> GlobResult ()
forall a. a -> GlobResult a
GlobMatch ()) else Maybe (GlobResult ())
forall a. Maybe a
Nothing

    go :: Glob -> String -> IO [GlobResult String]
go (GlobFile GlobPieces
glob) String
dir = do
      entries <- String -> IO [String]
getDirectoryContents (String
root String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
dir)
      catMaybes
        <$> mapM
          ( \String
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 <- IO Bool
-> (CabalSpecVersion -> IO Bool)
-> Maybe CabalSpecVersion
-> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) (IO Bool -> CabalSpecVersion -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> CabalSpecVersion -> IO Bool)
-> IO Bool -> CabalSpecVersion -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist (String
root String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
dir String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
s)) Maybe CabalSpecVersion
mspec
              let match = (String
dir String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
s String -> GlobResult () -> GlobResult String
forall a b. a -> GlobResult b -> GlobResult a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (GlobResult () -> GlobResult String)
-> Maybe (GlobResult ()) -> Maybe (GlobResult String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GlobPieces -> String -> Maybe (GlobResult ())
doesGlobMatch GlobPieces
glob String
s
              return $
                if isFile
                  then match
                  else case match of
                    Just (GlobMatch String
x) -> GlobResult String -> Maybe (GlobResult String)
forall a. a -> Maybe a
Just (GlobResult String -> Maybe (GlobResult String))
-> GlobResult String -> Maybe (GlobResult String)
forall a b. (a -> b) -> a -> b
$ String -> GlobResult String
forall a. a -> GlobResult a
GlobMatchesDirectory String
x
                    Just (GlobWarnMultiDot String
x) -> GlobResult String -> Maybe (GlobResult String)
forall a. a -> Maybe a
Just (GlobResult String -> Maybe (GlobResult String))
-> GlobResult String -> Maybe (GlobResult String)
forall a b. (a -> b) -> a -> b
$ String -> GlobResult String
forall a. a -> GlobResult a
GlobMatchesDirectory String
x
                    Just (GlobMatchesDirectory String
x) -> GlobResult String -> Maybe (GlobResult String)
forall a. a -> Maybe a
Just (GlobResult String -> Maybe (GlobResult String))
-> GlobResult String -> Maybe (GlobResult String)
forall a b. (a -> b) -> a -> b
$ String -> GlobResult String
forall a. a -> GlobResult a
GlobMatchesDirectory String
x
                    Just (GlobMissingDirectory String
x) -> GlobResult String -> Maybe (GlobResult String)
forall a. a -> Maybe a
Just (GlobResult String -> Maybe (GlobResult String))
-> GlobResult String -> Maybe (GlobResult String)
forall a b. (a -> b) -> a -> b
$ String -> GlobResult String
forall a. a -> GlobResult a
GlobMissingDirectory String
x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess
                    Maybe (GlobResult String)
Nothing -> Maybe (GlobResult String)
forall a. Maybe a
Nothing
          )
          entries
    go (GlobDirRecursive GlobPieces
glob) String
dir = do
      entries <- String -> IO [String]
getDirectoryContentsRecursive (String
root String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
dir)
      return $
        mapMaybe
          ( \String
s -> do
              globMatch <- GlobPieces -> String -> Maybe (GlobResult ())
doesGlobMatch GlobPieces
glob (String -> String
takeFileName String
s)
              pure ((dir </> s) <$ globMatch)
          )
          entries
    go (GlobDir GlobPieces
glob Glob
globPath) String
dir = do
      entries <- String -> IO [String]
getDirectoryContents (String
root String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
dir)
      subdirs <-
        filterM
          ( \String
subdir ->
              String -> IO Bool
doesDirectoryExist
                (String
root String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
dir String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
subdir)
          )
          $ filter (matchGlobPieces glob) entries
      concat <$> traverse (\String
subdir -> Glob -> String -> IO [GlobResult String]
go Glob
globPath (String
dir String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
subdir)) subdirs
    go Glob
GlobDirTrailing String
dir = [GlobResult String] -> IO [GlobResult String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> GlobResult String
forall a. a -> GlobResult a
GlobMatch String
dir]

  directoryExists <- String -> IO Bool
doesDirectoryExist (String
root String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
joinedPrefix)
  if directoryExists
    then go variablePattern joinedPrefix
    else return [GlobMissingDirectory joinedPrefix]
  where
    -- \| 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 :: Glob -> ([String], Glob)
splitConstantPrefix = (Glob -> Either Glob (String, Glob)) -> Glob -> ([String], Glob)
forall a r b. (a -> Either r (b, a)) -> a -> ([b], r)
unfoldr' Glob -> Either Glob (String, Glob)
step
      where
        step :: Glob -> Either Glob (String, Glob)
step (GlobDir [Literal String
seg] Glob
pat') = (String, Glob) -> Either Glob (String, Glob)
forall a b. b -> Either a b
Right (String
seg, Glob
pat')
        step Glob
pat' = Glob -> Either Glob (String, Glob)
forall a b. a -> Either a b
Left Glob
pat'

        unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)
        unfoldr' :: forall a r b. (a -> Either r (b, a)) -> a -> ([b], r)
unfoldr' a -> Either r (b, a)
f a
a = case a -> Either r (b, a)
f a
a of
          Left r
r -> ([], r
r)
          Right (b
b, a
a') -> case (a -> Either r (b, a)) -> a -> ([b], r)
forall a r b. (a -> Either r (b, a)) -> a -> ([b], r)
unfoldr' a -> Either r (b, a)
f a
a' of
            ([b]
bs, r
r) -> (b
b b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
bs, r
r)

-- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ?
isRecursiveInRoot :: Glob -> Bool
isRecursiveInRoot :: Glob -> Bool
isRecursiveInRoot (GlobDirRecursive GlobPieces
_) = Bool
True
isRecursiveInRoot Glob
_ = Bool
False

-- | Check how the string matches the glob under this cabal version
checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())
checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())
checkNameMatches CabalSpecVersion
spec GlobPieces
glob String
candidate
  -- Check if glob matches in its general form
  | GlobPieces -> String -> Bool
matchGlobPieces GlobPieces
glob String
candidate =
      -- if multidot is supported, then this is a clean match
      if CabalSpecVersion -> Bool
enableMultidot CabalSpecVersion
spec
        then GlobResult () -> Maybe (GlobResult ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> GlobResult ()
forall a. a -> GlobResult a
GlobMatch ())
        else -- if not, issue a warning saying multidot is needed for the match

          let (String
_, String
candidateExts) = String -> (String, String)
splitExtensions (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
takeFileName String
candidate
              extractExts :: GlobPieces -> Maybe String
              extractExts :: GlobPieces -> Maybe String
extractExts [] = Maybe String
forall a. Maybe a
Nothing
              extractExts [Literal String
lit]
                -- Any literal terminating a glob, and which does have an extension,
                -- returns that extension. Otherwise, recurse until Nothing is returned.
                | let ext :: String
ext = String -> String
takeExtensions String
lit
                , String
ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" =
                    String -> Maybe String
forall a. a -> Maybe a
Just String
ext
              extractExts (GlobPiece
_ : GlobPieces
x) = GlobPieces -> Maybe String
extractExts GlobPieces
x
           in case GlobPieces -> Maybe String
extractExts GlobPieces
glob of
                Just String
exts
                  | String
exts String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
candidateExts ->
                      GlobResult () -> Maybe (GlobResult ())
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> GlobResult ()
forall a. a -> GlobResult a
GlobMatch ())
                  | String
exts String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
candidateExts ->
                      GlobResult () -> Maybe (GlobResult ())
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> GlobResult ()
forall a. a -> GlobResult a
GlobWarnMultiDot ())
                Maybe String
_ -> GlobResult () -> Maybe (GlobResult ())
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> GlobResult ()
forall a. a -> GlobResult a
GlobMatch ())
  | Bool
otherwise = Maybe (GlobResult ())
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
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 :: CabalSpecVersion -> Glob -> String -> Maybe (GlobResult ())
fileGlobMatches CabalSpecVersion
version Glob
g String
path = Glob -> [String] -> Maybe (GlobResult ())
go Glob
g (String -> [String]
splitDirectories String
path)
  where
    go :: Glob -> [String] -> Maybe (GlobResult ())
go Glob
GlobDirTrailing [] = GlobResult () -> Maybe (GlobResult ())
forall a. a -> Maybe a
Just (() -> GlobResult ()
forall a. a -> GlobResult a
GlobMatch ())
    go (GlobFile GlobPieces
glob) [String
file] = CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())
checkNameMatches CabalSpecVersion
version GlobPieces
glob String
file
    go (GlobDirRecursive GlobPieces
glob) [String]
dirs
      | [] <- [String] -> [String]
forall a. [a] -> [a]
reverse [String]
dirs =
          Maybe (GlobResult ())
forall a. Maybe a
Nothing -- @dir/**/x.txt@ should not match @dir/hello@
      | String
file : [String]
_ <- [String] -> [String]
forall a. [a] -> [a]
reverse [String]
dirs =
          CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())
checkNameMatches CabalSpecVersion
version GlobPieces
glob String
file
    go (GlobDir GlobPieces
glob Glob
globPath) (String
dir : [String]
dirs) = do
      _ <- CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())
checkNameMatches CabalSpecVersion
version GlobPieces
glob String
dir -- we only care if dir segment matches
      go globPath dirs
    go Glob
_ [String]
_ = Maybe (GlobResult ())
forall a. Maybe a
Nothing