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

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

-- |
-- Module      :  Distribution.Simple.Glob.Internal
-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
-- License     :  BSD3
--                portions Copyright (c) 2007, Galois Inc.
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Internal module for simple file globbing.
-- Please import "Distribution.Simple.Glob" instead.
module Distribution.Simple.Glob.Internal where

import Distribution.Compat.Prelude
import Prelude ()

import Control.Monad (mapM)

import Distribution.Parsec
import Distribution.Pretty

import Distribution.CabalSpecVersion
import Distribution.Simple.Utils
import Distribution.Verbosity hiding (normal)

import Data.List (stripPrefix)
import System.Directory
import System.FilePath

import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp

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

-- | A filepath specified by globbing.
data Glob
  = -- | @<dirGlob>/<glob>@
    GlobDir !GlobPieces !Glob
  | -- | @**/<glob>@, where @**@ denotes recursively traversing
    -- all directories and matching filenames on <glob>.
    GlobDirRecursive !GlobPieces
  | -- | A file glob.
    GlobFile !GlobPieces
  | -- | Trailing dir; a glob ending in @/@.
    GlobDirTrailing
  deriving (Glob -> Glob -> Bool
(Glob -> Glob -> Bool) -> (Glob -> Glob -> Bool) -> Eq Glob
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Glob -> Glob -> Bool
== :: Glob -> Glob -> Bool
$c/= :: Glob -> Glob -> Bool
/= :: Glob -> Glob -> Bool
Eq, Int -> Glob -> ShowS
[Glob] -> ShowS
Glob -> String
(Int -> Glob -> ShowS)
-> (Glob -> String) -> ([Glob] -> ShowS) -> Show Glob
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Glob -> ShowS
showsPrec :: Int -> Glob -> ShowS
$cshow :: Glob -> String
show :: Glob -> String
$cshowList :: [Glob] -> ShowS
showList :: [Glob] -> ShowS
Show, (forall x. Glob -> Rep Glob x)
-> (forall x. Rep Glob x -> Glob) -> Generic Glob
forall x. Rep Glob x -> Glob
forall x. Glob -> Rep Glob x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Glob -> Rep Glob x
from :: forall x. Glob -> Rep Glob x
$cto :: forall x. Rep Glob x -> Glob
to :: forall x. Rep Glob x -> Glob
Generic)

instance Binary Glob
instance Structured Glob

-- | A single directory or file component of a globbed path
type GlobPieces = [GlobPiece]

-- | A piece of a globbing pattern
data GlobPiece
  = -- | A wildcard @*@
    WildCard
  | -- | A literal string @dirABC@
    Literal String
  | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@
    Union [GlobPieces]
  deriving (GlobPiece -> GlobPiece -> Bool
(GlobPiece -> GlobPiece -> Bool)
-> (GlobPiece -> GlobPiece -> Bool) -> Eq GlobPiece
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobPiece -> GlobPiece -> Bool
== :: GlobPiece -> GlobPiece -> Bool
$c/= :: GlobPiece -> GlobPiece -> Bool
/= :: GlobPiece -> GlobPiece -> Bool
Eq, Int -> GlobPiece -> ShowS
GlobPieces -> ShowS
GlobPiece -> String
(Int -> GlobPiece -> ShowS)
-> (GlobPiece -> String) -> (GlobPieces -> ShowS) -> Show GlobPiece
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobPiece -> ShowS
showsPrec :: Int -> GlobPiece -> ShowS
$cshow :: GlobPiece -> String
show :: GlobPiece -> String
$cshowList :: GlobPieces -> ShowS
showList :: GlobPieces -> ShowS
Show, (forall x. GlobPiece -> Rep GlobPiece x)
-> (forall x. Rep GlobPiece x -> GlobPiece) -> Generic GlobPiece
forall x. Rep GlobPiece x -> GlobPiece
forall x. GlobPiece -> Rep GlobPiece x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GlobPiece -> Rep GlobPiece x
from :: forall x. GlobPiece -> Rep GlobPiece x
$cto :: forall x. Rep GlobPiece x -> GlobPiece
to :: forall x. Rep GlobPiece x -> GlobPiece
Generic)

instance Binary GlobPiece
instance Structured GlobPiece

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

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

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

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

        (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 Glob
finalSegment [String]
segments
    | Bool
otherwise -> GlobSyntaxError -> Either GlobSyntaxError Glob
forall a b. a -> Either a b
Left GlobSyntaxError
VersionDoesNotSupportGlobStar
  (String
filename : [String]
segments) -> do
    Glob
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])

    (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 Glob
pat [String]
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

-- ** Parsing globs otherwise

instance Pretty Glob where
  pretty :: Glob -> Doc
pretty (GlobDir GlobPieces
glob Glob
pathglob) =
    GlobPieces -> Doc
dispGlobPieces GlobPieces
glob
      Doc -> Doc -> Doc
Disp.<> Char -> Doc
Disp.char Char
'/'
      Doc -> Doc -> Doc
Disp.<> Glob -> Doc
forall a. Pretty a => a -> Doc
pretty Glob
pathglob
  pretty (GlobDirRecursive GlobPieces
glob) =
    String -> Doc
Disp.text String
"**/"
      Doc -> Doc -> Doc
Disp.<> GlobPieces -> Doc
dispGlobPieces GlobPieces
glob
  pretty (GlobFile GlobPieces
glob) = GlobPieces -> Doc
dispGlobPieces GlobPieces
glob
  pretty Glob
GlobDirTrailing = Doc
Disp.empty

instance Parsec Glob where
  parsec :: forall (m :: * -> *). CabalParsing m => m Glob
parsec = m Glob
forall (m :: * -> *). CabalParsing m => m Glob
parsecPath
    where
      parsecPath :: CabalParsing m => m Glob
      parsecPath :: forall (m :: * -> *). CabalParsing m => m Glob
parsecPath = do
        GlobPieces
glob <- m GlobPieces
forall (m :: * -> *). CabalParsing m => m GlobPieces
parsecGlob
        m ()
forall (m :: * -> *). CabalParsing m => m ()
dirSep m () -> m Glob -> m Glob
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (GlobPieces -> Glob -> Glob
GlobDir GlobPieces
glob (Glob -> Glob) -> m Glob -> m Glob
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Glob
forall (m :: * -> *). CabalParsing m => m Glob
parsecPath m Glob -> m Glob -> m Glob
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Glob -> m Glob
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobPieces -> Glob -> Glob
GlobDir GlobPieces
glob Glob
GlobDirTrailing)) m Glob -> m Glob -> m Glob
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Glob -> m Glob
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobPieces -> Glob
GlobFile GlobPieces
glob)
      -- We could support parsing recursive directory search syntax
      -- @**@ here too, rather than just in 'parseFileGlob'

      dirSep :: CabalParsing m => m ()
      dirSep :: forall (m :: * -> *). CabalParsing m => m ()
dirSep =
        () () -> m Char -> m ()
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'/'
          m () -> m () -> m ()
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m () -> m ()
forall a. m a -> m a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try
            ( do
                Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'\\'
                -- check this isn't an escape code
                m Char -> m ()
forall a. Show a => m a -> m ()
forall (m :: * -> *) a. (Parsing m, Show a) => m a -> m ()
P.notFollowedBy ((Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy Char -> Bool
isGlobEscapedChar)
            )

      parsecGlob :: CabalParsing m => m GlobPieces
      parsecGlob :: forall (m :: * -> *). CabalParsing m => m GlobPieces
parsecGlob = m GlobPiece -> m GlobPieces
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m GlobPiece
parsecPiece
        where
          parsecPiece :: m GlobPiece
parsecPiece = [m GlobPiece] -> m GlobPiece
forall (m :: * -> *) a. Alternative m => [m a] -> m a
P.choice [m GlobPiece
literal, m GlobPiece
wildcard, m GlobPiece
union]

          wildcard :: m GlobPiece
wildcard = GlobPiece
WildCard GlobPiece -> m Char -> m GlobPiece
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'*'
          union :: m GlobPiece
union = [GlobPieces] -> GlobPiece
Union ([GlobPieces] -> GlobPiece)
-> (NonEmpty GlobPieces -> [GlobPieces])
-> NonEmpty GlobPieces
-> GlobPiece
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty GlobPieces -> [GlobPieces]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty GlobPieces -> GlobPiece)
-> m (NonEmpty GlobPieces) -> m GlobPiece
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
-> m Char -> m (NonEmpty GlobPieces) -> m (NonEmpty GlobPieces)
forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
P.between (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'{') (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'}') (m GlobPieces -> m Char -> m (NonEmpty GlobPieces)
forall (m :: * -> *) a sep.
Alternative m =>
m a -> m sep -> m (NonEmpty a)
P.sepByNonEmpty m GlobPieces
forall (m :: * -> *). CabalParsing m => m GlobPieces
parsecGlob (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
','))
          literal :: m GlobPiece
literal = String -> GlobPiece
Literal (String -> GlobPiece) -> m String -> m GlobPiece
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char -> m String
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m Char
litchar

          litchar :: m Char
litchar = m Char
normal m Char -> m Char -> m Char
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
escape

          normal :: m Char
normal = (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy (\Char
c -> Bool -> Bool
not (Char -> Bool
isGlobEscapedChar Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\')
          escape :: m Char
escape = m Char -> m Char
forall a. m a -> m a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try (m Char -> m Char) -> m Char -> m Char
forall a b. (a -> b) -> a -> b
$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'\\' m Char -> m Char -> m Char
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy Char -> Bool
isGlobEscapedChar

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

dispGlobPieces :: GlobPieces -> Disp.Doc
dispGlobPieces :: GlobPieces -> Doc
dispGlobPieces = [Doc] -> Doc
Disp.hcat ([Doc] -> Doc) -> (GlobPieces -> [Doc]) -> GlobPieces -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobPiece -> Doc) -> GlobPieces -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map GlobPiece -> Doc
dispPiece
  where
    dispPiece :: GlobPiece -> Doc
dispPiece GlobPiece
WildCard = Char -> Doc
Disp.char Char
'*'
    dispPiece (Literal String
str) = String -> Doc
Disp.text (ShowS
escape String
str)
    dispPiece (Union [GlobPieces]
globs) =
      Doc -> Doc
Disp.braces
        ( [Doc] -> Doc
Disp.hcat
            ( Doc -> [Doc] -> [Doc]
Disp.punctuate
                (Char -> Doc
Disp.char Char
',')
                ((GlobPieces -> Doc) -> [GlobPieces] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map GlobPieces -> Doc
dispGlobPieces [GlobPieces]
globs)
            )
        )
    escape :: ShowS
escape [] = []
    escape (Char
c : String
cs)
      | Char -> Bool
isGlobEscapedChar Char
c = Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
cs
      | Bool
otherwise = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
cs

isGlobEscapedChar :: Char -> Bool
isGlobEscapedChar :: Char -> Bool
isGlobEscapedChar Char
'*' = Bool
True
isGlobEscapedChar Char
'{' = Bool
True
isGlobEscapedChar Char
'}' = Bool
True
isGlobEscapedChar Char
',' = Bool
True
isGlobEscapedChar Char
_ = Bool
False

-- ** 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 -> 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."

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

-- | 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 -> ShowS
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 -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' in directory '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
root 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, 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
      [String]
entries <- String -> IO [String]
getDirectoryContents (String
root String -> ShowS
</> String
dir)
      [Maybe (GlobResult String)] -> [GlobResult String]
forall a. [Maybe a] -> [a]
catMaybes
        ([Maybe (GlobResult String)] -> [GlobResult String])
-> IO [Maybe (GlobResult String)] -> IO [GlobResult String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe (GlobResult String)))
-> [String] -> IO [Maybe (GlobResult String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
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.
              Bool
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 -> ShowS
</> String
dir String -> ShowS
</> String
s)) Maybe CabalSpecVersion
mspec
              let match :: Maybe (GlobResult String)
match = (String
dir String -> ShowS
</> 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
              Maybe (GlobResult String) -> IO (Maybe (GlobResult String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (GlobResult String) -> IO (Maybe (GlobResult String)))
-> Maybe (GlobResult String) -> IO (Maybe (GlobResult String))
forall a b. (a -> b) -> a -> b
$
                if Bool
isFile
                  then Maybe (GlobResult String)
match
                  else case Maybe (GlobResult String)
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
          )
          [String]
entries
    go (GlobDirRecursive GlobPieces
glob) String
dir = do
      [String]
entries <- String -> IO [String]
getDirectoryContentsRecursive (String
root String -> ShowS
</> String
dir)
      [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
s -> do
              GlobResult ()
globMatch <- GlobPieces -> String -> Maybe (GlobResult ())
doesGlobMatch GlobPieces
glob (ShowS
takeFileName String
s)
              GlobResult String -> Maybe (GlobResult String)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String
dir String -> ShowS
</> 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 ()
globMatch)
          )
          [String]
entries
    go (GlobDir GlobPieces
glob Glob
globPath) String
dir = do
      [String]
entries <- String -> IO [String]
getDirectoryContents (String
root String -> ShowS
</> String
dir)
      [String]
subdirs <-
        (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
          ( \String
subdir ->
              String -> IO Bool
doesDirectoryExist
                (String
root String -> ShowS
</> String
dir String -> ShowS
</> String
subdir)
          )
          ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (GlobPieces -> String -> Bool
matchGlobPieces GlobPieces
glob) [String]
entries
      [[GlobResult String]] -> [GlobResult String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[GlobResult String]] -> [GlobResult String])
-> IO [[GlobResult String]] -> IO [GlobResult String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [GlobResult String])
-> [String] -> IO [[GlobResult String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\String
subdir -> Glob -> String -> IO [GlobResult String]
go Glob
globPath (String
dir String -> ShowS
</> String
subdir)) [String]
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]

  Bool
directoryExists <- String -> IO Bool
doesDirectoryExist (String
root String -> ShowS
</> String
joinedPrefix)
  if Bool
directoryExists
    then Glob -> String -> IO [GlobResult String]
go Glob
variablePattern String
joinedPrefix
    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. a -> GlobResult a
GlobMissingDirectory String
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
$ ShowS
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 = ShowS
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
      GlobResult ()
_ <- CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())
checkNameMatches CabalSpecVersion
version GlobPieces
glob String
dir -- we only care if dir segment matches
      Glob -> [String] -> Maybe (GlobResult ())
go Glob
globPath [String]
dirs
    go Glob
_ [String]
_ = Maybe (GlobResult ())
forall a. Maybe a
Nothing