-- From Distribution.Client.Glob
module Cabal.Internal.Glob where

import Control.Applicative   (some, (<|>))
import Control.Monad         (filterM, void)
import Data.Char             (isAsciiLower, isAsciiUpper, toUpper)
import Data.Foldable         (toList)
import Data.List             (stripPrefix)
import Distribution.Parsec   (CabalParsing, Parsec (..))
import Distribution.Pretty   (Pretty (..))
import System.Directory      (doesDirectoryExist, getDirectoryContents, getHomeDirectory)
import System.FilePath.Posix (addTrailingPathSeparator, joinPath, (</>))

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

-- | A file path specified by globbing
--
data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
  deriving (FilePathGlob -> FilePathGlob -> Bool
(FilePathGlob -> FilePathGlob -> Bool)
-> (FilePathGlob -> FilePathGlob -> Bool) -> Eq FilePathGlob
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FilePathGlob -> FilePathGlob -> Bool
== :: FilePathGlob -> FilePathGlob -> Bool
$c/= :: FilePathGlob -> FilePathGlob -> Bool
/= :: FilePathGlob -> FilePathGlob -> Bool
Eq, Int -> FilePathGlob -> ShowS
[FilePathGlob] -> ShowS
FilePathGlob -> String
(Int -> FilePathGlob -> ShowS)
-> (FilePathGlob -> String)
-> ([FilePathGlob] -> ShowS)
-> Show FilePathGlob
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FilePathGlob -> ShowS
showsPrec :: Int -> FilePathGlob -> ShowS
$cshow :: FilePathGlob -> String
show :: FilePathGlob -> String
$cshowList :: [FilePathGlob] -> ShowS
showList :: [FilePathGlob] -> ShowS
Show)

data FilePathGlobRel
   = GlobDir  !Glob !FilePathGlobRel
   | GlobFile !Glob
   | GlobDirTrailing                -- ^ trailing dir, a glob ending in @/@
  deriving (FilePathGlobRel -> FilePathGlobRel -> Bool
(FilePathGlobRel -> FilePathGlobRel -> Bool)
-> (FilePathGlobRel -> FilePathGlobRel -> Bool)
-> Eq FilePathGlobRel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FilePathGlobRel -> FilePathGlobRel -> Bool
== :: FilePathGlobRel -> FilePathGlobRel -> Bool
$c/= :: FilePathGlobRel -> FilePathGlobRel -> Bool
/= :: FilePathGlobRel -> FilePathGlobRel -> Bool
Eq, Int -> FilePathGlobRel -> ShowS
[FilePathGlobRel] -> ShowS
FilePathGlobRel -> String
(Int -> FilePathGlobRel -> ShowS)
-> (FilePathGlobRel -> String)
-> ([FilePathGlobRel] -> ShowS)
-> Show FilePathGlobRel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FilePathGlobRel -> ShowS
showsPrec :: Int -> FilePathGlobRel -> ShowS
$cshow :: FilePathGlobRel -> String
show :: FilePathGlobRel -> String
$cshowList :: [FilePathGlobRel] -> ShowS
showList :: [FilePathGlobRel] -> ShowS
Show)

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

-- | A piece of a globbing pattern
data GlobPiece = WildCard
               | Literal String
               | Union [Glob]
  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
Glob -> ShowS
GlobPiece -> String
(Int -> GlobPiece -> ShowS)
-> (GlobPiece -> String) -> (Glob -> 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 :: Glob -> ShowS
showList :: Glob -> ShowS
Show)

data FilePathRoot
   = FilePathRelative
   | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'
   | FilePathHomeDir
  deriving (FilePathRoot -> FilePathRoot -> Bool
(FilePathRoot -> FilePathRoot -> Bool)
-> (FilePathRoot -> FilePathRoot -> Bool) -> Eq FilePathRoot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FilePathRoot -> FilePathRoot -> Bool
== :: FilePathRoot -> FilePathRoot -> Bool
$c/= :: FilePathRoot -> FilePathRoot -> Bool
/= :: FilePathRoot -> FilePathRoot -> Bool
Eq, Int -> FilePathRoot -> ShowS
[FilePathRoot] -> ShowS
FilePathRoot -> String
(Int -> FilePathRoot -> ShowS)
-> (FilePathRoot -> String)
-> ([FilePathRoot] -> ShowS)
-> Show FilePathRoot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FilePathRoot -> ShowS
showsPrec :: Int -> FilePathRoot -> ShowS
$cshow :: FilePathRoot -> String
show :: FilePathRoot -> String
$cshowList :: [FilePathRoot] -> ShowS
showList :: [FilePathRoot] -> ShowS
Show)

-- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and
-- is in fact equivalent to a non-glob 'FilePath'.
--
-- If it is trivial in this sense then the result is the equivalent constant
-- 'FilePath'. On the other hand if it is not trivial (so could in principle
-- match more than one file) then the result is @Nothing@.
--
isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
isTrivialFilePathGlob :: FilePathGlob -> Maybe String
isTrivialFilePathGlob (FilePathGlob FilePathRoot
root FilePathGlobRel
pathglob) =
    case FilePathRoot
root of
      FilePathRoot
FilePathRelative       -> [String] -> FilePathGlobRel -> Maybe String
go []      FilePathGlobRel
pathglob
      FilePathRoot String
root'     -> [String] -> FilePathGlobRel -> Maybe String
go [String
root'] FilePathGlobRel
pathglob
      FilePathRoot
FilePathHomeDir        -> Maybe String
forall a. Maybe a
Nothing
  where
    go :: [String] -> FilePathGlobRel -> Maybe String
go [String]
paths (GlobDir  [Literal String
path] FilePathGlobRel
globs) = [String] -> FilePathGlobRel -> Maybe String
go (String
pathString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
paths) FilePathGlobRel
globs
    go [String]
paths (GlobFile [Literal String
path]) = String -> Maybe String
forall a. a -> Maybe a
Just ([String] -> String
joinPath ([String] -> [String]
forall a. [a] -> [a]
reverse (String
pathString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
paths)))
    go [String]
paths  FilePathGlobRel
GlobDirTrailing          = String -> Maybe String
forall a. a -> Maybe a
Just (ShowS
addTrailingPathSeparator
                                                 ([String] -> String
joinPath ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
paths)))
    go [String]
_ FilePathGlobRel
_ = Maybe String
forall a. Maybe a
Nothing

-- | Get the 'FilePath' corresponding to a 'FilePathRoot'.
--
-- The 'FilePath' argument is required to supply the path for the
-- 'FilePathRelative' case.
--
getFilePathRootDirectory :: FilePathRoot
                         -> FilePath      -- ^ root for relative paths
                         -> IO FilePath
getFilePathRootDirectory :: FilePathRoot -> String -> IO String
getFilePathRootDirectory  FilePathRoot
FilePathRelative   String
root = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
root
getFilePathRootDirectory (FilePathRoot String
root) String
_    = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
root
getFilePathRootDirectory  FilePathRoot
FilePathHomeDir    String
_    = IO String
getHomeDirectory


------------------------------------------------------------------------------
-- Matching
--

-- | Match a 'FilePathGlob' against the file system, starting from a given
-- root directory for relative paths. The results of relative globs are
-- relative to the given root. Matches for absolute globs are absolute.
--
matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]
matchFileGlob :: String -> FilePathGlob -> IO [String]
matchFileGlob String
relroot (FilePathGlob FilePathRoot
globroot FilePathGlobRel
glob) = do
    String
root <- FilePathRoot -> String -> IO String
getFilePathRootDirectory FilePathRoot
globroot String
relroot
    [String]
matches <- String -> FilePathGlobRel -> IO [String]
matchFileGlobRel String
root FilePathGlobRel
glob
    case FilePathRoot
globroot of
      FilePathRoot
FilePathRelative -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
matches
      FilePathRoot
_                -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
root String -> ShowS
</>) [String]
matches)

-- | Match a 'FilePathGlobRel' against the file system, starting from a
-- given root directory. The results are all relative to the given root.
--
matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]
matchFileGlobRel :: String -> FilePathGlobRel -> IO [String]
matchFileGlobRel String
root FilePathGlobRel
glob0 = FilePathGlobRel -> String -> IO [String]
go FilePathGlobRel
glob0 String
""
  where
    go :: FilePathGlobRel -> String -> IO [String]
go (GlobFile Glob
glob) String
dir = do
      [String]
entries <- String -> IO [String]
getDirectoryContents (String
root String -> ShowS
</> String
dir)
      let files :: [String]
files = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Glob -> String -> Bool
matchGlob Glob
glob) [String]
entries
      [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> ShowS
</>) [String]
files)

    go (GlobDir Glob
glob FilePathGlobRel
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 (Glob -> String -> Bool
matchGlob Glob
glob) [String]
entries
      [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[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 -> FilePathGlobRel -> String -> IO [String]
go FilePathGlobRel
globPath (String
dir String -> ShowS
</> String
subdir)) [String]
subdirs

    go FilePathGlobRel
GlobDirTrailing String
dir = [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
dir]


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

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


------------------------------------------------------------------------------
-- Parsing & printing
--

instance Pretty FilePathGlob where
  pretty :: FilePathGlob -> Doc
pretty (FilePathGlob FilePathRoot
root FilePathGlobRel
pathglob) = FilePathRoot -> Doc
forall a. Pretty a => a -> Doc
pretty FilePathRoot
root Doc -> Doc -> Doc
Disp.<> FilePathGlobRel -> Doc
forall a. Pretty a => a -> Doc
pretty FilePathGlobRel
pathglob

instance Parsec FilePathGlob where
    parsec :: forall (m :: * -> *). CabalParsing m => m FilePathGlob
parsec = do
        FilePathRoot
root <- m FilePathRoot
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m FilePathRoot
parsec
        case FilePathRoot
root of
            FilePathRoot
FilePathRelative -> FilePathRoot -> FilePathGlobRel -> FilePathGlob
FilePathGlob FilePathRoot
root (FilePathGlobRel -> FilePathGlob)
-> m FilePathGlobRel -> m FilePathGlob
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePathGlobRel
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsec
            FilePathRoot
_                -> FilePathRoot -> FilePathGlobRel -> FilePathGlob
FilePathGlob FilePathRoot
root (FilePathGlobRel -> FilePathGlob)
-> m FilePathGlobRel -> m FilePathGlob
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePathGlobRel
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsec m FilePathGlob -> m FilePathGlob -> m FilePathGlob
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePathGlob -> m FilePathGlob
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePathRoot -> FilePathGlobRel -> FilePathGlob
FilePathGlob FilePathRoot
root FilePathGlobRel
GlobDirTrailing)

instance Pretty FilePathRoot where
    pretty :: FilePathRoot -> Doc
pretty  FilePathRoot
FilePathRelative    = Doc
Disp.empty
    pretty (FilePathRoot String
root)  = String -> Doc
Disp.text String
root
    pretty FilePathRoot
FilePathHomeDir      = Char -> Doc
Disp.char Char
'~' Doc -> Doc -> Doc
Disp.<> Char -> Doc
Disp.char Char
'/'

instance Parsec FilePathRoot where
    parsec :: forall (m :: * -> *). CabalParsing m => m FilePathRoot
parsec = m FilePathRoot
root m FilePathRoot -> m FilePathRoot -> m FilePathRoot
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m FilePathRoot -> m FilePathRoot
forall a. m a -> m a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try m FilePathRoot
home m FilePathRoot -> m FilePathRoot -> m FilePathRoot
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m FilePathRoot -> m FilePathRoot
forall a. m a -> m a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try m FilePathRoot
drive m FilePathRoot -> m FilePathRoot -> m FilePathRoot
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePathRoot -> m FilePathRoot
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePathRoot
FilePathRelative where
        root :: m FilePathRoot
root = String -> FilePathRoot
FilePathRoot String
"/" FilePathRoot -> m Char -> m FilePathRoot
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
'/'
        home :: m FilePathRoot
home = FilePathRoot
FilePathHomeDir FilePathRoot -> m String -> m FilePathRoot
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"~/"
        drive :: m FilePathRoot
drive = do
            Char
dr <- (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
c
            Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
            Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'/' 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
<|> Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'\\'
            FilePathRoot -> m FilePathRoot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> FilePathRoot
FilePathRoot (Char -> Char
toUpper Char
dr Char -> ShowS
forall a. a -> [a] -> [a]
: String
":\\"))

instance Pretty FilePathGlobRel where
    pretty :: FilePathGlobRel -> Doc
pretty (GlobDir  Glob
glob FilePathGlobRel
pathglob) = Glob -> Doc
dispGlob Glob
glob
                            Doc -> Doc -> Doc
Disp.<> Char -> Doc
Disp.char Char
'/'
                            Doc -> Doc -> Doc
Disp.<> FilePathGlobRel -> Doc
forall a. Pretty a => a -> Doc
pretty FilePathGlobRel
pathglob
    pretty (GlobFile Glob
glob)          = Glob -> Doc
dispGlob Glob
glob
    pretty FilePathGlobRel
GlobDirTrailing          = Doc
Disp.empty

instance Parsec FilePathGlobRel where
    parsec :: forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsec = m FilePathGlobRel
forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsecPath where
        parsecPath :: CabalParsing m => m FilePathGlobRel
        parsecPath :: forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsecPath = do
            Glob
glob <- m Glob
forall (m :: * -> *). CabalParsing m => m Glob
parsecGlob
            m ()
forall (m :: * -> *). CabalParsing m => m ()
dirSep m () -> m FilePathGlobRel -> m FilePathGlobRel
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Glob -> FilePathGlobRel -> FilePathGlobRel
GlobDir Glob
glob (FilePathGlobRel -> FilePathGlobRel)
-> m FilePathGlobRel -> m FilePathGlobRel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePathGlobRel
forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsecPath m FilePathGlobRel -> m FilePathGlobRel -> m FilePathGlobRel
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePathGlobRel -> m FilePathGlobRel
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Glob -> FilePathGlobRel -> FilePathGlobRel
GlobDir Glob
glob FilePathGlobRel
GlobDirTrailing)) m FilePathGlobRel -> m FilePathGlobRel -> m FilePathGlobRel
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePathGlobRel -> m FilePathGlobRel
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Glob -> FilePathGlobRel
GlobFile Glob
glob)

        dirSep :: CabalParsing m => m ()
        dirSep :: forall (m :: * -> *). CabalParsing m => m ()
dirSep = m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (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))

dispGlob :: Glob -> Disp.Doc
dispGlob :: Glob -> Doc
dispGlob = [Doc] -> Doc
Disp.hcat ([Doc] -> Doc) -> (Glob -> [Doc]) -> Glob -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobPiece -> Doc) -> Glob -> [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 [Glob]
globs) = Doc -> Doc
Disp.braces
                                ([Doc] -> Doc
Disp.hcat (Doc -> [Doc] -> [Doc]
Disp.punctuate
                                             (Char -> Doc
Disp.char Char
',')
                                             ((Glob -> Doc) -> [Glob] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Glob -> Doc
dispGlob [Glob]
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

parsecGlob :: CabalParsing m => m Glob
parsecGlob :: forall (m :: * -> *). CabalParsing m => m Glob
parsecGlob = m GlobPiece -> m Glob
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    = [Glob] -> GlobPiece
Union ([Glob] -> GlobPiece)
-> (NonEmpty Glob -> [Glob]) -> NonEmpty Glob -> GlobPiece
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Glob -> [Glob]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Glob -> GlobPiece) -> m (NonEmpty Glob) -> m GlobPiece
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char -> m Char -> m (NonEmpty Glob) -> m (NonEmpty Glob)
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 Glob -> m Char -> m (NonEmpty Glob)
forall (m :: * -> *) a sep.
Alternative m =>
m a -> m sep -> m (NonEmpty a)
P.sepByNonEmpty m Glob
forall (m :: * -> *). CabalParsing m => m Glob
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

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