{-# LANGUAGE DeriveGeneric #-}

--TODO: [code cleanup] plausibly much of this module should be merged with
-- similar functionality in Cabal.
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


-- | 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, (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                -- ^ 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, (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)

-- | 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, (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 -- ^ 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, (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

-- | 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
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
'\\'
            -- 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