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
data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
deriving (FilePathGlob -> FilePathGlob -> Bool
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
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
deriving (FilePathGlobRel -> FilePathGlobRel -> Bool
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
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)
type Glob = [GlobPiece]
data GlobPiece = WildCard
| Literal String
| Union [Glob]
deriving (GlobPiece -> GlobPiece -> Bool
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
Glob -> ShowS
GlobPiece -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: Glob -> ShowS
$cshowList :: Glob -> ShowS
show :: GlobPiece -> String
$cshow :: GlobPiece -> String
showsPrec :: Int -> GlobPiece -> ShowS
$cshowsPrec :: Int -> GlobPiece -> ShowS
Show)
data FilePathRoot
= FilePathRelative
| FilePathRoot FilePath
| FilePathHomeDir
deriving (FilePathRoot -> FilePathRoot -> Bool
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
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)
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 -> 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
pathforall a. a -> [a] -> [a]
:[String]
paths) FilePathGlobRel
globs
go [String]
paths (GlobFile [Literal String
path]) = forall a. a -> Maybe a
Just ([String] -> String
joinPath (forall a. [a] -> [a]
reverse (String
pathforall a. a -> [a] -> [a]
:[String]
paths)))
go [String]
paths FilePathGlobRel
GlobDirTrailing = forall a. a -> Maybe a
Just (ShowS
addTrailingPathSeparator
([String] -> String
joinPath (forall a. [a] -> [a]
reverse [String]
paths)))
go [String]
_ FilePathGlobRel
_ = forall a. Maybe a
Nothing
getFilePathRootDirectory :: FilePathRoot
-> FilePath
-> IO FilePath
getFilePathRootDirectory :: FilePathRoot -> String -> IO String
getFilePathRootDirectory FilePathRoot
FilePathRelative String
root = forall (m :: * -> *) a. Monad m => a -> m a
return String
root
getFilePathRootDirectory (FilePathRoot String
root) String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return String
root
getFilePathRootDirectory FilePathRoot
FilePathHomeDir String
_ = IO String
getHomeDirectory
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return [String]
matches
FilePathRoot
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (String
root String -> ShowS
</>) [String]
matches)
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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Glob -> String -> Bool
matchGlob Glob
glob) [String]
entries
forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- 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))
forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Glob -> String -> Bool
matchGlob Glob
glob) [String]
entries
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (m :: * -> *) a. Monad m => a -> m a
return [String
dir]
matchGlob :: Glob -> String -> Bool
matchGlob :: Glob -> String -> Bool
matchGlob = Glob -> String -> Bool
goStart
where
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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Glob
glob -> Glob -> String -> Bool
goStart (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' <- 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
cforall a. a -> [a] -> [a]
:String
cs) Bool -> Bool -> Bool
|| Glob -> String -> Bool
go (GlobPiece
WildCardforall a. a -> [a] -> [a]
:Glob
rest) String
cs
go (Union [Glob]
globs:Glob
rest) String
cs = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Glob
glob -> Glob -> String -> Bool
go (Glob
glob forall a. [a] -> [a] -> [a]
++ Glob
rest) String
cs) [Glob]
globs
go [] (Char
_:String
_) = Bool
False
go (GlobPiece
_:Glob
_) String
"" = Bool
False
instance Pretty FilePathGlob where
pretty :: FilePathGlob -> Doc
pretty (FilePathGlob FilePathRoot
root FilePathGlobRel
pathglob) = forall a. Pretty a => a -> Doc
pretty FilePathRoot
root Doc -> Doc -> Doc
Disp.<> forall a. Pretty a => a -> Doc
pretty FilePathGlobRel
pathglob
instance Parsec FilePathGlob where
parsec :: forall (m :: * -> *). CabalParsing m => m FilePathGlob
parsec = do
FilePathRoot
root <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
case FilePathRoot
root of
FilePathRoot
FilePathRelative -> FilePathRoot -> FilePathGlobRel -> FilePathGlob
FilePathGlob FilePathRoot
root forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
FilePathRoot
_ -> FilePathRoot -> FilePathGlobRel -> FilePathGlob
FilePathGlob FilePathRoot
root forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Parsing m => m a -> m a
P.try m FilePathRoot
home forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Parsing m => m a -> m a
P.try m FilePathRoot
drive forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePathRoot
FilePathRelative where
root :: m FilePathRoot
root = String -> FilePathRoot
FilePathRoot String
"/" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'/'
home :: m FilePathRoot
home = FilePathRoot
FilePathHomeDir forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"~/"
drive :: m FilePathRoot
drive = do
Char
dr <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
c
Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'/' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'\\'
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> FilePathRoot
FilePathRoot (Char -> Char
toUpper Char
dr 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.<> 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 = forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsecPath where
parsecPath :: CabalParsing m => m FilePathGlobRel
parsecPath :: forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsecPath = do
Glob
glob <- forall (m :: * -> *). CabalParsing m => m Glob
parsecGlob
forall (m :: * -> *). CabalParsing m => m ()
dirSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Glob -> FilePathGlobRel -> FilePathGlobRel
GlobDir Glob
glob forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CabalParsing m => m FilePathGlobRel
parsecPath forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Glob -> FilePathGlobRel -> FilePathGlobRel
GlobDir Glob
glob FilePathGlobRel
GlobDirTrailing)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'/') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Parsing m => m a -> m a
P.try (do
Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'\\'
forall (m :: * -> *) a. (Parsing m, Show a) => m a -> m ()
P.notFollowedBy (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
',')
(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
'\\' forall a. a -> [a] -> [a]
: Char
c forall a. a -> [a] -> [a]
: ShowS
escape String
cs
| Bool
otherwise = Char
c forall a. a -> [a] -> [a]
: ShowS
escape String
cs
parsecGlob :: CabalParsing m => m Glob
parsecGlob :: forall (m :: * -> *). CabalParsing m => m Glob
parsecGlob = forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m GlobPiece
parsecPiece where
parsecPiece :: m GlobPiece
parsecPiece = 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 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'*'
union :: m GlobPiece
union = [Glob] -> GlobPiece
Union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
P.between (forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'{') (forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'}') (forall (m :: * -> *) a sep.
Alternative m =>
m a -> m sep -> m (NonEmpty a)
P.sepByNonEmpty forall (m :: * -> *). CabalParsing m => m Glob
parsecGlob (forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
','))
literal :: m GlobPiece
literal = String -> GlobPiece
Literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m Char
litchar
litchar :: m Char
litchar = m Char
normal forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
escape
normal :: m Char
normal = 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 forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\\')
escape :: m Char
escape = forall (m :: * -> *) a. Parsing m => m a -> m a
P.try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'\\' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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