{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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 (
        GlobSyntaxError(..),
        GlobResult(..),
        matchDirFileGlob,
        matchDirFileGlobWithDie,
        runDirFileGlob,
        fileGlobMatches,
        parseFileGlob,
        explainGlobSyntaxError,
        Glob,
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.CabalSpecVersion
import Distribution.Simple.Utils
import Distribution.Verbosity

import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)
import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>), (<.>))

import qualified Data.List.NonEmpty as NE

-- 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
  = GlobMatch a
    -- ^ The glob matched the value supplied.
  | GlobWarnMultiDot 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.
  | GlobMissingDirectory FilePath
    -- ^ 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').
  deriving (Int -> GlobResult a -> ShowS
[GlobResult a] -> ShowS
GlobResult a -> String
(Int -> GlobResult a -> ShowS)
-> (GlobResult a -> String)
-> ([GlobResult a] -> ShowS)
-> Show (GlobResult a)
forall a. Show a => Int -> GlobResult a -> ShowS
forall a. Show a => [GlobResult a] -> ShowS
forall a. Show a => GlobResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlobResult a] -> ShowS
$cshowList :: forall a. Show a => [GlobResult a] -> ShowS
show :: GlobResult a -> String
$cshow :: forall a. Show a => GlobResult a -> String
showsPrec :: Int -> GlobResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> GlobResult a -> ShowS
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
/= :: GlobResult a -> GlobResult a -> Bool
$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
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
min :: GlobResult a -> GlobResult a -> GlobResult a
$cmin :: forall a. Ord a => GlobResult a -> GlobResult a -> GlobResult a
max :: GlobResult a -> GlobResult a -> GlobResult a
$cmax :: forall a. Ord a => GlobResult a -> GlobResult a -> GlobResult a
>= :: 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
$c< :: forall a. Ord a => GlobResult a -> GlobResult a -> Bool
compare :: GlobResult a -> GlobResult a -> Ordering
$ccompare :: forall a. Ord a => GlobResult a -> GlobResult a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (GlobResult a)
Ord, a -> GlobResult b -> GlobResult a
(a -> b) -> GlobResult a -> GlobResult b
(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
<$ :: a -> GlobResult b -> GlobResult a
$c<$ :: forall a b. a -> GlobResult b -> GlobResult a
fmap :: (a -> b) -> GlobResult a -> GlobResult b
$cfmap :: forall a b. (a -> b) -> GlobResult a -> GlobResult b
Functor)

-- | 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.
globMatches :: [GlobResult a] -> [a]
globMatches :: [GlobResult a] -> [a]
globMatches [GlobResult a]
input = [ a
a | GlobMatch a
a <- [GlobResult a]
input ]

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
/= :: GlobSyntaxError -> GlobSyntaxError -> Bool
$c/= :: GlobSyntaxError -> GlobSyntaxError -> Bool
== :: GlobSyntaxError -> GlobSyntaxError -> Bool
$c== :: GlobSyntaxError -> GlobSyntaxError -> Bool
Eq, Int -> GlobSyntaxError -> ShowS
[GlobSyntaxError] -> ShowS
GlobSyntaxError -> String
(Int -> GlobSyntaxError -> ShowS)
-> (GlobSyntaxError -> String)
-> ([GlobSyntaxError] -> ShowS)
-> Show GlobSyntaxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlobSyntaxError] -> ShowS
$cshowList :: [GlobSyntaxError] -> ShowS
show :: GlobSyntaxError -> String
$cshow :: GlobSyntaxError -> String
showsPrec :: Int -> GlobSyntaxError -> ShowS
$cshowsPrec :: Int -> GlobSyntaxError -> ShowS
Show)

explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String
explainGlobSyntaxError :: String -> GlobSyntaxError -> String
explainGlobSyntaxError String
filepath GlobSyntaxError
StarInDirectory =
     String
"invalid file glob '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'. A wildcard '**' is only allowed as the final parent"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" directory. Stars must not otherwise appear in the parent"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" directories."
explainGlobSyntaxError String
filepath GlobSyntaxError
StarInExtension =
     String
"invalid file glob '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'. Wildcards '*' are only allowed as the"
  String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'. Wildcards '*' may only totally replace the"
  String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath
  String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'. Prior to 'cabal-version: 3.8'"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" if a wildcard '**' is used as a parent directory, the"
  String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'. Using the double-star syntax requires 'cabal-version: 2.4'"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" or greater. Alternatively, for compatibility with earlier Cabal"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" versions, list the included directories explicitly."
explainGlobSyntaxError String
filepath GlobSyntaxError
VersionDoesNotSupportGlob =
     String
"invalid file glob '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'. Using star wildcards requires 'cabal-version: >= 1.6'. "
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Alternatively if you require compatibility with earlier Cabal "
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"versions then list all the files explicitly."

data IsRecursive = Recursive | NonRecursive deriving IsRecursive -> IsRecursive -> Bool
(IsRecursive -> IsRecursive -> Bool)
-> (IsRecursive -> IsRecursive -> Bool) -> Eq IsRecursive
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsRecursive -> IsRecursive -> Bool
$c/= :: IsRecursive -> IsRecursive -> Bool
== :: IsRecursive -> IsRecursive -> Bool
$c== :: IsRecursive -> IsRecursive -> Bool
Eq

data MultiDot = MultiDotDisabled | MultiDotEnabled

data Glob
  = GlobStem FilePath Glob
    -- ^ A single subdirectory component + remainder.
  | GlobFinal GlobFinal

data GlobFinal
  = FinalMatch IsRecursive MultiDot String
    -- ^ First argument: Is this a @**/*.ext@ pattern?
    --   Second argument: should we match against the exact extensions, or accept a suffix?
    --   Third argument: the extensions to accept.
  | FinalLit IsRecursive FilePath
    -- ^ Literal file name.

reconstructGlob :: Glob -> FilePath
reconstructGlob :: Glob -> String
reconstructGlob (GlobStem String
dir Glob
glob) =
  String
dir String -> ShowS
</> Glob -> String
reconstructGlob Glob
glob
reconstructGlob (GlobFinal GlobFinal
final) = case GlobFinal
final of
  FinalMatch IsRecursive
Recursive MultiDot
_ String
exts -> String
"**" String -> ShowS
</> String
"*" String -> ShowS
<.> String
exts
  FinalMatch IsRecursive
NonRecursive MultiDot
_ String
exts -> String
"*" String -> ShowS
<.> String
exts
  FinalLit IsRecursive
Recursive String
path -> String
"**" String -> ShowS
</> String
path
  FinalLit IsRecursive
NonRecursive String
path -> String
path

-- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the
--   result if the glob matched (or would have matched with a higher
--   cabal-version).
fileGlobMatches :: Glob -> FilePath -> Maybe (GlobResult FilePath)
fileGlobMatches :: Glob -> String -> Maybe (GlobResult String)
fileGlobMatches Glob
pat String
candidate = do
  GlobResult ()
match <- Glob -> [String] -> Maybe (GlobResult ())
fileGlobMatchesSegments Glob
pat (String -> [String]
splitDirectories String
candidate)
  GlobResult String -> Maybe (GlobResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
candidate String -> GlobResult () -> GlobResult String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GlobResult ()
match)

fileGlobMatchesSegments :: Glob -> [FilePath] -> Maybe (GlobResult ())
fileGlobMatchesSegments :: Glob -> [String] -> Maybe (GlobResult ())
fileGlobMatchesSegments Glob
_ [] = Maybe (GlobResult ())
forall a. Maybe a
Nothing
fileGlobMatchesSegments Glob
pat (String
seg : [String]
segs) = case Glob
pat of
  GlobStem String
dir Glob
pat' -> do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
dir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
seg)
    Glob -> [String] -> Maybe (GlobResult ())
fileGlobMatchesSegments Glob
pat' [String]
segs
  GlobFinal GlobFinal
final -> case GlobFinal
final of
    FinalMatch IsRecursive
Recursive MultiDot
multidot String
ext -> do
      let (String
candidateBase, String
candidateExts) = String -> (String, String)
splitExtensions (NonEmpty String -> String
forall a. NonEmpty a -> a
NE.last (NonEmpty String -> String) -> NonEmpty String -> String
forall a b. (a -> b) -> a -> b
$ String
segString -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:|[String]
segs)
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
candidateBase))
      MultiDot -> String -> String -> Maybe (GlobResult ())
checkExt MultiDot
multidot String
ext String
candidateExts
    FinalMatch IsRecursive
NonRecursive MultiDot
multidot String
ext -> do
      let (String
candidateBase, String
candidateExts) = String -> (String, String)
splitExtensions String
seg
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
segs Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
candidateBase))
      MultiDot -> String -> String -> Maybe (GlobResult ())
checkExt MultiDot
multidot String
ext String
candidateExts
    FinalLit IsRecursive
isRecursive String
filename -> do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((IsRecursive
isRecursive IsRecursive -> IsRecursive -> Bool
forall a. Eq a => a -> a -> Bool
== IsRecursive
Recursive Bool -> Bool -> Bool
|| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
segs) Bool -> Bool -> Bool
&& String
filename String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
seg)
      GlobResult () -> Maybe (GlobResult ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> GlobResult ()
forall a. a -> GlobResult a
GlobMatch ())

checkExt
  :: MultiDot
  -> String -- ^ The pattern's extension
  -> String -- ^ The candidate file's extension
  -> Maybe (GlobResult ())
checkExt :: MultiDot -> String -> String -> Maybe (GlobResult ())
checkExt MultiDot
multidot String
ext String
candidate
  | String
ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
candidate = GlobResult () -> Maybe (GlobResult ())
forall a. a -> Maybe a
Just (() -> GlobResult ()
forall a. a -> GlobResult a
GlobMatch ())
  | String
ext String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
candidate = case MultiDot
multidot of
      MultiDot
MultiDotDisabled -> GlobResult () -> Maybe (GlobResult ())
forall a. a -> Maybe a
Just (() -> GlobResult ()
forall a. a -> GlobResult a
GlobWarnMultiDot ())
      MultiDot
MultiDotEnabled -> GlobResult () -> Maybe (GlobResult ())
forall a. a -> Maybe a
Just (() -> GlobResult ()
forall a. a -> GlobResult a
GlobMatch ())
  | Bool
otherwise = Maybe (GlobResult ())
forall a. Maybe a
Nothing

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
        GlobFinal
finalSegment <- case String -> (String, String)
splitExtensions String
filename of
          (String
"*", String
ext) | Char
'*' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ext -> GlobSyntaxError -> Either GlobSyntaxError GlobFinal
forall a b. a -> Either a b
Left GlobSyntaxError
StarInExtension
                     | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ext       -> GlobSyntaxError -> Either GlobSyntaxError GlobFinal
forall a b. a -> Either a b
Left GlobSyntaxError
NoExtensionOnStar
                     | Bool
otherwise      -> GlobFinal -> Either GlobSyntaxError GlobFinal
forall a b. b -> Either a b
Right (IsRecursive -> MultiDot -> String -> GlobFinal
FinalMatch IsRecursive
Recursive MultiDot
multidot String
ext)
          (String, String)
_                           -> if Bool
allowLiteralFilenameGlobStar
                                           then GlobFinal -> Either GlobSyntaxError GlobFinal
forall a b. b -> Either a b
Right (IsRecursive -> String -> GlobFinal
FinalLit IsRecursive
Recursive String
filename)
                                           else GlobSyntaxError -> Either GlobSyntaxError GlobFinal
forall a b. a -> Either a b
Left GlobSyntaxError
LiteralFileNameGlobStar
        (Glob -> String -> Either GlobSyntaxError Glob)
-> Glob -> [String] -> Either GlobSyntaxError Glob
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Glob -> String -> Either GlobSyntaxError Glob
addStem (GlobFinal -> Glob
GlobFinal GlobFinal
finalSegment) [String]
segments
    | Bool
otherwise -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
VersionDoesNotSupportGlobStar
  (String
filename : [String]
segments) -> do
        GlobFinal
pat <- case String -> (String, String)
splitExtensions String
filename of
          (String
"*", String
ext) | Bool -> Bool
not Bool
allowGlob       -> GlobSyntaxError -> Either GlobSyntaxError GlobFinal
forall a b. a -> Either a b
Left GlobSyntaxError
VersionDoesNotSupportGlob
                     | Char
'*' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ext      -> GlobSyntaxError -> Either GlobSyntaxError GlobFinal
forall a b. a -> Either a b
Left GlobSyntaxError
StarInExtension
                     | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ext            -> GlobSyntaxError -> Either GlobSyntaxError GlobFinal
forall a b. a -> Either a b
Left GlobSyntaxError
NoExtensionOnStar
                     | Bool
otherwise           -> GlobFinal -> Either GlobSyntaxError GlobFinal
forall a b. b -> Either a b
Right (IsRecursive -> MultiDot -> String -> GlobFinal
FinalMatch IsRecursive
NonRecursive MultiDot
multidot String
ext)
          (String
_, String
ext)   | Char
'*' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ext      -> GlobSyntaxError -> Either GlobSyntaxError GlobFinal
forall a b. a -> Either a b
Left GlobSyntaxError
StarInExtension
                     | Char
'*' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
filename -> GlobSyntaxError -> Either GlobSyntaxError GlobFinal
forall a b. a -> Either a b
Left GlobSyntaxError
StarInFileName
                     | Bool
otherwise           -> GlobFinal -> Either GlobSyntaxError GlobFinal
forall a b. b -> Either a b
Right (IsRecursive -> String -> GlobFinal
FinalLit IsRecursive
NonRecursive String
filename)
        (Glob -> String -> Either GlobSyntaxError Glob)
-> Glob -> [String] -> Either GlobSyntaxError Glob
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Glob -> String -> Either GlobSyntaxError Glob
addStem (GlobFinal -> Glob
GlobFinal GlobFinal
pat) [String]
segments
  where
    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
    addStem :: Glob -> String -> Either GlobSyntaxError Glob
addStem Glob
pat String
seg
      | Char
'*' Char -> String -> 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 (String -> Glob -> Glob
GlobStem String
seg Glob
pat)
    multidot :: MultiDot
multidot
      | CabalSpecVersion
version CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV2_4 = MultiDot
MultiDotEnabled
      | Bool
otherwise                = MultiDot
MultiDotDisabled
    allowLiteralFilenameGlobStar :: Bool
allowLiteralFilenameGlobStar = CabalSpecVersion
version CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_8

-- | 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 -> FilePath -> FilePath -> IO [FilePath]
matchDirFileGlob :: Verbosity -> CabalSpecVersion -> String -> String -> IO [String]
matchDirFileGlob Verbosity
v = Verbosity
-> (Verbosity -> String -> IO [String])
-> CabalSpecVersion
-> String
-> String
-> IO [String]
matchDirFileGlobWithDie Verbosity
v Verbosity -> String -> IO [String]
forall a. Verbosity -> String -> IO a
die'

-- | Like 'matchDirFileGlob' but with customizable 'die'
--
-- @since 3.6.0.0
--
matchDirFileGlobWithDie :: Verbosity -> (Verbosity -> String -> IO [FilePath]) -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]
matchDirFileGlobWithDie :: Verbosity
-> (Verbosity -> String -> IO [String])
-> CabalSpecVersion
-> String
-> String
-> IO [String]
matchDirFileGlobWithDie Verbosity
verbosity Verbosity -> String -> IO [String]
rip CabalSpecVersion
version String
dir String
filepath = case CabalSpecVersion -> String -> Either GlobSyntaxError Glob
parseFileGlob CabalSpecVersion
version String
filepath of
  Left GlobSyntaxError
err -> Verbosity -> String -> IO [String]
rip Verbosity
verbosity (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> GlobSyntaxError -> String
explainGlobSyntaxError String
filepath GlobSyntaxError
err
  Right Glob
glob -> do
    [GlobResult String]
results <- Verbosity -> String -> Glob -> IO [GlobResult String]
runDirFileGlob Verbosity
verbosity String
dir Glob
glob
    let missingDirectories :: [String]
missingDirectories =
          [ String
missingDir | GlobMissingDirectory String
missingDir <- [GlobResult String]
results ]
        matches :: [String]
matches = [GlobResult String] -> [String]
forall a. [GlobResult a] -> [a]
globMatches [GlobResult String]
results

    let errors :: [String]
        errors :: [String]
errors =
            [ String
"filepath wildcard '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' refers to the directory"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
missingDir String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' does not match any files."
            | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
matches
            ]

    if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors
    then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
matches
    else Verbosity -> String -> IO [String]
rip Verbosity
verbosity (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
errors

-- | 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 -> FilePath -> Glob -> IO [GlobResult FilePath]
runDirFileGlob :: Verbosity -> String -> Glob -> IO [GlobResult String]
runDirFileGlob Verbosity
verbosity String
rawDir 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 (t :: * -> *) a. Foldable t => t a -> Bool
null String
rawDir) (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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"as '.'. This is probably an internal error."
  let dir :: String
dir = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rawDir then String
"." else String
rawDir
  Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expanding glob '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Glob -> String
reconstructGlob Glob
pat String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' in directory '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dir String -> ShowS
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, GlobFinal
final) = Glob -> ([String], GlobFinal)
splitConstantPrefix Glob
pat
      joinedPrefix :: String
joinedPrefix = [String] -> String
joinPath [String]
prefixSegments
  case GlobFinal
final of
    FinalMatch IsRecursive
recursive MultiDot
multidot String
exts -> do
      let prefix :: String
prefix = String
dir String -> ShowS
</> String
joinedPrefix
      Bool
directoryExists <- String -> IO Bool
doesDirectoryExist String
prefix
      if Bool
directoryExists
        then do
          [String]
candidates <- case IsRecursive
recursive of
            IsRecursive
Recursive -> String -> IO [String]
getDirectoryContentsRecursive String
prefix
            IsRecursive
NonRecursive -> (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool) -> ShowS -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix String -> ShowS
</>)) ([String] -> IO [String]) -> IO [String] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO [String]
getDirectoryContents String
prefix
          let checkName :: String -> Maybe (GlobResult String)
checkName String
candidate = do
                let (String
candidateBase, String
candidateExts) = String -> (String, String)
splitExtensions (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
candidate
                Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
candidateBase))
                GlobResult ()
match <- MultiDot -> String -> String -> Maybe (GlobResult ())
checkExt MultiDot
multidot String
exts String
candidateExts
                GlobResult String -> Maybe (GlobResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
joinedPrefix String -> ShowS
</> String
candidate String -> GlobResult () -> GlobResult String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GlobResult ()
match)
          [GlobResult String] -> IO [GlobResult String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([GlobResult String] -> IO [GlobResult String])
-> [GlobResult String] -> IO [GlobResult String]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (GlobResult String))
-> [String] -> [GlobResult String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (GlobResult String)
checkName [String]
candidates
        else
          [GlobResult String] -> IO [GlobResult String]
forall (m :: * -> *) a. Monad m => a -> m a
return [ String -> GlobResult String
forall a. String -> GlobResult a
GlobMissingDirectory String
joinedPrefix ]
    FinalLit IsRecursive
Recursive String
fn -> do
      let prefix :: String
prefix = String
dir String -> ShowS
</> String
joinedPrefix
      Bool
directoryExists <- String -> IO Bool
doesDirectoryExist String
prefix
      if Bool
directoryExists
        then do
          [String]
candidates <- String -> IO [String]
getDirectoryContentsRecursive String
prefix
          let checkName :: String -> Maybe (GlobResult String)
checkName String
candidate
                  | ShowS
takeFileName String
candidate String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fn = 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
GlobMatch (String
joinedPrefix String -> ShowS
</> String
candidate)
                  | Bool
otherwise = Maybe (GlobResult String)
forall a. Maybe a
Nothing
          [GlobResult String] -> IO [GlobResult String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([GlobResult String] -> IO [GlobResult String])
-> [GlobResult String] -> IO [GlobResult String]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (GlobResult String))
-> [String] -> [GlobResult String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (GlobResult String)
checkName [String]
candidates
        else
          [GlobResult String] -> IO [GlobResult String]
forall (m :: * -> *) a. Monad m => a -> m a
return [ String -> GlobResult String
forall a. String -> GlobResult a
GlobMissingDirectory String
joinedPrefix ]

    FinalLit IsRecursive
NonRecursive String
fn -> do
      Bool
exists <- String -> IO Bool
doesFileExist (String
dir String -> ShowS
</> String
joinedPrefix String -> ShowS
</> String
fn)
      [GlobResult String] -> IO [GlobResult String]
forall (m :: * -> *) a. Monad m => a -> m a
return [ String -> GlobResult String
forall a. a -> GlobResult a
GlobMatch (String
joinedPrefix String -> ShowS
</> String
fn) | Bool
exists ]

unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)
unfoldr' :: (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)

-- | Extract the (possibly null) constant prefix from the pattern.
-- This has the property that, if @(pref, final) = splitConstantPrefix pat@,
-- then @pat === foldr GlobStem (GlobFinal final) pref@.
splitConstantPrefix :: Glob -> ([FilePath], GlobFinal)
splitConstantPrefix :: Glob -> ([String], GlobFinal)
splitConstantPrefix = (Glob -> Either GlobFinal (String, Glob))
-> Glob -> ([String], GlobFinal)
forall a r b. (a -> Either r (b, a)) -> a -> ([b], r)
unfoldr' Glob -> Either GlobFinal (String, Glob)
step
  where
    step :: Glob -> Either GlobFinal (String, Glob)
step (GlobStem String
seg Glob
pat) = (String, Glob) -> Either GlobFinal (String, Glob)
forall a b. b -> Either a b
Right (String
seg, Glob
pat)
    step (GlobFinal GlobFinal
pat) = GlobFinal -> Either GlobFinal (String, Glob)
forall a b. a -> Either a b
Left GlobFinal
pat