{-# 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
  , isRecursiveInRoot
  , Glob
  ) where

import Distribution.Compat.Prelude
import Prelude ()

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

import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
import System.FilePath (joinPath, splitDirectories, splitExtensions, 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
  = -- | 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 FilePath
  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
$cshowsPrec :: forall a. Show a => Int -> GlobResult a -> ShowS
showsPrec :: Int -> GlobResult a -> ShowS
$cshow :: forall a. Show a => GlobResult a -> String
show :: GlobResult a -> String
$cshowList :: forall a. Show a => [GlobResult a] -> ShowS
showList :: [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
$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)

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

data MultiDot = MultiDotDisabled | MultiDotEnabled

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

data GlobFinal
  = -- | 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.
    FinalMatch IsRecursive MultiDot String
  | -- | Literal file name.
    FinalLit IsRecursive FilePath

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 a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
candidate String -> GlobResult () -> GlobResult String
forall a b. a -> GlobResult b -> GlobResult a
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
seg String -> [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 a. [a] -> 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
segs Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall a. [a] -> 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 a. [a] -> 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 a. a -> Maybe a
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 a. Eq a => a -> [a] -> 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 a. [a] -> 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 a. Eq a => a -> [a] -> 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 a. [a] -> 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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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 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 (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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
matches
               ]

    if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors
      then [String] -> IO [String]
forall a. a -> IO a
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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
joinedPrefix String -> ShowS
</> String
candidate String -> GlobResult () -> GlobResult String
forall a b. a -> GlobResult b -> GlobResult a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GlobResult ()
match)
          [GlobResult String] -> IO [GlobResult String]
forall a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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' :: 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)

-- | 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

isRecursiveInRoot :: Glob -> Bool
isRecursiveInRoot :: Glob -> Bool
isRecursiveInRoot (GlobFinal (FinalMatch IsRecursive
Recursive MultiDot
_ String
_)) = Bool
True
isRecursiveInRoot Glob
_ = Bool
False