-- 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
/= :: FilePathGlob -> FilePathGlob -> Bool
$c/= :: FilePathGlob -> FilePathGlob -> Bool
== :: FilePathGlob -> FilePathGlob -> Bool
$c== :: 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
showList :: [FilePathGlob] -> ShowS
$cshowList :: [FilePathGlob] -> ShowS
show :: FilePathGlob -> String
$cshow :: FilePathGlob -> String
showsPrec :: Int -> FilePathGlob -> ShowS
$cshowsPrec :: Int -> 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
/= :: FilePathGlobRel -> FilePathGlobRel -> Bool
$c/= :: FilePathGlobRel -> FilePathGlobRel -> Bool
== :: FilePathGlobRel -> FilePathGlobRel -> Bool
$c== :: 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
showList :: [FilePathGlobRel] -> ShowS
$cshowList :: [FilePathGlobRel] -> ShowS
show :: FilePathGlobRel -> String
$cshow :: FilePathGlobRel -> String
showsPrec :: Int -> FilePathGlobRel -> ShowS
$cshowsPrec :: Int -> 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
/= :: GlobPiece -> GlobPiece -> Bool
$c/= :: GlobPiece -> GlobPiece -> Bool
== :: GlobPiece -> GlobPiece -> Bool
$c== :: GlobPiece -> GlobPiece -> Bool
Eq, Int -> GlobPiece -> ShowS
[GlobPiece] -> ShowS
GlobPiece -> String
(Int -> GlobPiece -> ShowS)
-> (GlobPiece -> String)
-> ([GlobPiece] -> ShowS)
-> Show GlobPiece
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlobPiece] -> ShowS
$cshowList :: [GlobPiece] -> ShowS
show :: GlobPiece -> String
$cshow :: GlobPiece -> String
showsPrec :: Int -> GlobPiece -> ShowS
$cshowsPrec :: Int -> GlobPiece -> 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
/= :: FilePathRoot -> FilePathRoot -> Bool
$c/= :: FilePathRoot -> FilePathRoot -> Bool
== :: FilePathRoot -> FilePathRoot -> Bool
$c== :: 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
showList :: [FilePathRoot] -> ShowS
$cshowList :: [FilePathRoot] -> ShowS
show :: FilePathRoot -> String
$cshow :: FilePathRoot -> String
showsPrec :: Int -> FilePathRoot -> ShowS
$cshowsPrec :: Int -> 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 (m :: * -> *) a. Monad m => a -> m a
return String
root
getFilePathRootDirectory (FilePathRoot String
root) String
_    = String -> IO String
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 (m :: * -> *) a. Monad m => a -> m a
return [String]
matches
      FilePathRoot
_                -> [String] -> IO [String]
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 [GlobPiece]
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 ([GlobPiece] -> String -> Bool
matchGlob [GlobPiece]
glob) [String]
entries
      [String] -> IO [String]
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 [GlobPiece]
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 ([GlobPiece] -> String -> Bool
matchGlob [GlobPiece]
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)
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 (m :: * -> *) a. Monad m => a -> m a
return [String
dir]


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

    go :: [GlobPiece] -> String -> Bool
go []                 String
""    = Bool
True
    go (Literal String
lit:[GlobPiece]
rest) String
cs
      | Just String
cs' <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
lit String
cs
                                = [GlobPiece] -> String -> Bool
go [GlobPiece]
rest String
cs'
      | Bool
otherwise               = Bool
False
    go [GlobPiece
WildCard]         String
""    = Bool
True
    go (GlobPiece
WildCard:[GlobPiece]
rest)   (Char
c:String
cs) = [GlobPiece] -> String -> Bool
go [GlobPiece]
rest (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs) Bool -> Bool -> Bool
|| [GlobPiece] -> String -> Bool
go (GlobPiece
WildCardGlobPiece -> [GlobPiece] -> [GlobPiece]
forall a. a -> [a] -> [a]
:[GlobPiece]
rest) String
cs
    go (Union [[GlobPiece]]
globs:[GlobPiece]
rest)   String
cs  = ([GlobPiece] -> Bool) -> [[GlobPiece]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[GlobPiece]
glob -> [GlobPiece] -> String -> Bool
go ([GlobPiece]
glob [GlobPiece] -> [GlobPiece] -> [GlobPiece]
forall a. [a] -> [a] -> [a]
++ [GlobPiece]
rest) String
cs) [[GlobPiece]]
globs
    go []                (Char
_:String
_)  = Bool
False
    go (GlobPiece
_:[GlobPiece]
_)              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 :: m FilePathGlob
parsec = do
        FilePathRoot
root <- m FilePathRoot
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
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
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
parsec m FilePathGlob -> m FilePathGlob -> m FilePathGlob
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePathGlob -> m FilePathGlob
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 :: m FilePathRoot
parsec = m FilePathRoot
root m FilePathRoot -> m FilePathRoot -> m FilePathRoot
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m FilePathRoot -> m FilePathRoot
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try m FilePathRoot
home m FilePathRoot -> m FilePathRoot -> m FilePathRoot
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m FilePathRoot -> m FilePathRoot
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try m FilePathRoot
drive m FilePathRoot -> m FilePathRoot -> m FilePathRoot
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePathRoot -> m FilePathRoot
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 (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 (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 (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 (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  [GlobPiece]
glob FilePathGlobRel
pathglob) = [GlobPiece] -> Doc
dispGlob [GlobPiece]
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 [GlobPiece]
glob)          = [GlobPiece] -> Doc
dispGlob [GlobPiece]
glob
    pretty FilePathGlobRel
GlobDirTrailing          = Doc
Disp.empty

instance Parsec FilePathGlobRel where
    parsec :: m FilePathGlobRel
parsec = m FilePathGlobRel
forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsecPath where
        parsecPath :: CabalParsing m => m FilePathGlobRel
        parsecPath :: m FilePathGlobRel
parsecPath = do
            [GlobPiece]
glob <- m [GlobPiece]
forall (m :: * -> *). CabalParsing m => m [GlobPiece]
parsecGlob
            m ()
forall (m :: * -> *). CabalParsing m => m ()
dirSep m () -> m FilePathGlobRel -> m FilePathGlobRel
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([GlobPiece] -> FilePathGlobRel -> FilePathGlobRel
GlobDir [GlobPiece]
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePathGlobRel -> m FilePathGlobRel
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GlobPiece] -> FilePathGlobRel -> FilePathGlobRel
GlobDir [GlobPiece]
glob FilePathGlobRel
GlobDirTrailing)) m FilePathGlobRel -> m FilePathGlobRel -> m FilePathGlobRel
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePathGlobRel -> m FilePathGlobRel
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GlobPiece] -> FilePathGlobRel
GlobFile [GlobPiece]
glob)

        dirSep :: CabalParsing m => m ()
        dirSep :: 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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m () -> m ()
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 (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 :: [GlobPiece] -> Doc
dispGlob = [Doc] -> Doc
Disp.hcat ([Doc] -> Doc) -> ([GlobPiece] -> [Doc]) -> [GlobPiece] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobPiece -> Doc) -> [GlobPiece] -> [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 [[GlobPiece]]
globs) = Doc -> Doc
Disp.braces
                                ([Doc] -> Doc
Disp.hcat (Doc -> [Doc] -> [Doc]
Disp.punctuate
                                             (Char -> Doc
Disp.char Char
',')
                                             (([GlobPiece] -> Doc) -> [[GlobPiece]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [GlobPiece] -> Doc
dispGlob [[GlobPiece]]
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 :: m [GlobPiece]
parsecGlob = m GlobPiece -> m [GlobPiece]
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 (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    = [[GlobPiece]] -> GlobPiece
Union ([[GlobPiece]] -> GlobPiece)
-> (NonEmpty [GlobPiece] -> [[GlobPiece]])
-> NonEmpty [GlobPiece]
-> GlobPiece
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [GlobPiece] -> [[GlobPiece]]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty [GlobPiece] -> GlobPiece)
-> m (NonEmpty [GlobPiece]) -> m GlobPiece
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
-> m Char -> m (NonEmpty [GlobPiece]) -> m (NonEmpty [GlobPiece])
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 [GlobPiece] -> m Char -> m (NonEmpty [GlobPiece])
forall (m :: * -> *) a sep.
Alternative m =>
m a -> m sep -> m (NonEmpty a)
P.sepByNonEmpty m [GlobPiece]
forall (m :: * -> *). CabalParsing m => m [GlobPiece]
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 (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 (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 (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 (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