{-# LANGUAGE DeriveGeneric #-}
module Distribution.Client.Glob
(
RootedGlob (..)
, isTrivialRootedGlob
, FilePathRoot (..)
, getFilePathRootDirectory
, module Distribution.Simple.Glob
, Glob (..)
, GlobPiece (..)
, GlobPieces
, matchGlob
, matchGlobPieces
, matchFileGlob
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Simple.Glob
import Distribution.Simple.Glob.Internal
import System.Directory
import System.FilePath
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
data RootedGlob
= RootedGlob
FilePathRoot
Glob
deriving (RootedGlob -> RootedGlob -> Bool
(RootedGlob -> RootedGlob -> Bool)
-> (RootedGlob -> RootedGlob -> Bool) -> Eq RootedGlob
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RootedGlob -> RootedGlob -> Bool
== :: RootedGlob -> RootedGlob -> Bool
$c/= :: RootedGlob -> RootedGlob -> Bool
/= :: RootedGlob -> RootedGlob -> Bool
Eq, Int -> RootedGlob -> ShowS
[RootedGlob] -> ShowS
RootedGlob -> String
(Int -> RootedGlob -> ShowS)
-> (RootedGlob -> String)
-> ([RootedGlob] -> ShowS)
-> Show RootedGlob
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RootedGlob -> ShowS
showsPrec :: Int -> RootedGlob -> ShowS
$cshow :: RootedGlob -> String
show :: RootedGlob -> String
$cshowList :: [RootedGlob] -> ShowS
showList :: [RootedGlob] -> ShowS
Show, (forall x. RootedGlob -> Rep RootedGlob x)
-> (forall x. Rep RootedGlob x -> RootedGlob) -> Generic RootedGlob
forall x. Rep RootedGlob x -> RootedGlob
forall x. RootedGlob -> Rep RootedGlob x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RootedGlob -> Rep RootedGlob x
from :: forall x. RootedGlob -> Rep RootedGlob x
$cto :: forall x. Rep RootedGlob x -> RootedGlob
to :: forall x. Rep RootedGlob x -> RootedGlob
Generic)
instance Binary RootedGlob
instance Structured RootedGlob
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 FilePathRoot
instance Structured FilePathRoot
isTrivialRootedGlob :: RootedGlob -> Maybe FilePath
isTrivialRootedGlob :: RootedGlob -> Maybe String
isTrivialRootedGlob (RootedGlob FilePathRoot
root Glob
pathglob) =
case FilePathRoot
root of
FilePathRoot
FilePathRelative -> [String] -> Glob -> Maybe String
go [] Glob
pathglob
FilePathRoot String
root' -> [String] -> Glob -> Maybe String
go [String
root'] Glob
pathglob
FilePathRoot
FilePathHomeDir -> Maybe String
forall a. Maybe a
Nothing
where
go :: [String] -> Glob -> Maybe String
go [String]
paths (GlobDir [Literal String
path] Glob
globs) = [String] -> Glob -> Maybe String
go (String
path String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
paths) Glob
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
path String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
paths)))
go [String]
paths Glob
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]
_ Glob
_ = 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 -> RootedGlob -> IO [FilePath]
matchFileGlob :: String -> RootedGlob -> IO [String]
matchFileGlob String
relroot (RootedGlob FilePathRoot
globroot Glob
glob) = do
root <- FilePathRoot -> String -> IO String
getFilePathRootDirectory FilePathRoot
globroot String
relroot
matches <- matchGlob root glob
case 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)
instance Pretty RootedGlob where
pretty :: RootedGlob -> Doc
pretty (RootedGlob FilePathRoot
root Glob
pathglob) = FilePathRoot -> Doc
forall a. Pretty a => a -> Doc
pretty FilePathRoot
root Doc -> Doc -> Doc
Disp.<> Glob -> Doc
forall a. Pretty a => a -> Doc
pretty Glob
pathglob
instance Parsec RootedGlob where
parsec :: forall (m :: * -> *). CabalParsing m => m RootedGlob
parsec = do
root <- m FilePathRoot
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m FilePathRoot
parsec
case root of
FilePathRoot
FilePathRelative -> FilePathRoot -> Glob -> RootedGlob
RootedGlob FilePathRoot
root (Glob -> RootedGlob) -> m Glob -> m RootedGlob
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Glob
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m Glob
parsec
FilePathRoot
_ -> FilePathRoot -> Glob -> RootedGlob
RootedGlob FilePathRoot
root (Glob -> RootedGlob) -> m Glob -> m RootedGlob
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Glob
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m Glob
parsec m RootedGlob -> m RootedGlob -> m RootedGlob
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RootedGlob -> m RootedGlob
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePathRoot -> Glob -> RootedGlob
RootedGlob FilePathRoot
root Glob
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
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')
_ <- P.char ':'
_ <- P.char '/' <|> P.char '\\'
return (FilePathRoot (toUpper dr : ":\\"))