{-# LANGUAGE DeriveGeneric #-}
module Distribution.Client.Glob
( FilePathGlob(..)
, FilePathRoot(..)
, FilePathGlobRel(..)
, Glob
, GlobPiece(..)
, matchFileGlob
, matchFileGlobRel
, matchGlob
, isTrivialFilePathGlob
, getFilePathRootDirectory
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Data.List (stripPrefix)
import System.Directory
import System.FilePath
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
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, (forall x. FilePathGlob -> Rep FilePathGlob x)
-> (forall x. Rep FilePathGlob x -> FilePathGlob)
-> Generic FilePathGlob
forall x. Rep FilePathGlob x -> FilePathGlob
forall x. FilePathGlob -> Rep FilePathGlob x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FilePathGlob x -> FilePathGlob
$cfrom :: forall x. FilePathGlob -> Rep FilePathGlob x
Generic)
data FilePathGlobRel
= GlobDir !Glob !FilePathGlobRel
| GlobFile !Glob
| GlobDirTrailing
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, (forall x. FilePathGlobRel -> Rep FilePathGlobRel x)
-> (forall x. Rep FilePathGlobRel x -> FilePathGlobRel)
-> Generic FilePathGlobRel
forall x. Rep FilePathGlobRel x -> FilePathGlobRel
forall x. FilePathGlobRel -> Rep FilePathGlobRel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FilePathGlobRel x -> FilePathGlobRel
$cfrom :: forall x. FilePathGlobRel -> Rep FilePathGlobRel x
Generic)
type Glob = [GlobPiece]
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, (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
$cto :: forall x. Rep GlobPiece x -> GlobPiece
$cfrom :: forall x. GlobPiece -> Rep GlobPiece x
Generic)
data FilePathRoot
= FilePathRelative
| FilePathRoot FilePath
| 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, (forall x. FilePathRoot -> Rep FilePathRoot x)
-> (forall x. Rep FilePathRoot x -> FilePathRoot)
-> Generic FilePathRoot
forall x. Rep FilePathRoot x -> FilePathRoot
forall x. FilePathRoot -> Rep FilePathRoot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FilePathRoot x -> FilePathRoot
$cfrom :: forall x. FilePathRoot -> Rep FilePathRoot x
Generic)
instance Binary FilePathGlob
instance Binary FilePathRoot
instance Binary FilePathGlobRel
instance Binary GlobPiece
instance Structured FilePathGlob
instance Structured FilePathRoot
instance Structured FilePathGlobRel
instance Structured GlobPiece
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
getFilePathRootDirectory :: FilePathRoot
-> FilePath
-> 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
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)
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]
matchGlob :: Glob -> String -> Bool
matchGlob :: [GlobPiece] -> String -> Bool
matchGlob = [GlobPiece] -> String -> Bool
goStart
where
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
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
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z') Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z')
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 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 (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
'\\'
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