{-# 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
$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, (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
$cfrom :: forall x. FilePathGlob -> Rep FilePathGlob x
from :: forall x. FilePathGlob -> Rep FilePathGlob x
$cto :: forall x. Rep FilePathGlob x -> FilePathGlob
to :: forall x. Rep FilePathGlob x -> FilePathGlob
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
$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, (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
$cfrom :: forall x. FilePathGlobRel -> Rep FilePathGlobRel x
from :: forall x. FilePathGlobRel -> Rep FilePathGlobRel x
$cto :: forall x. Rep FilePathGlobRel x -> FilePathGlobRel
to :: forall x. Rep FilePathGlobRel x -> FilePathGlobRel
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
$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, (forall x. GlobPiece -> Rep GlobPiece x)
-> (forall x. Rep GlobPiece x -> GlobPiece) -> Generic GlobPiece
forall x. Rep GlobPiece x -> GlobPiece
forall x. GlobPiece -> Rep GlobPiece x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GlobPiece -> Rep GlobPiece x
from :: forall x. GlobPiece -> Rep GlobPiece x
$cto :: forall x. Rep GlobPiece x -> GlobPiece
to :: forall x. Rep GlobPiece x -> GlobPiece
Generic)
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
$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, (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
$cfrom :: forall x. FilePathRoot -> Rep FilePathRoot x
from :: forall x. FilePathRoot -> Rep FilePathRoot x
$cto :: forall x. Rep FilePathRoot x -> FilePathRoot
to :: forall x. Rep FilePathRoot x -> FilePathRoot
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 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
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)
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]
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 = (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
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
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 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 a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'/' m () -> m () -> m ()
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m () -> m ()
forall a. m a -> m a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try (do
Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'\\'
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