module Cabal.Internal.Glob where

import Control.Monad                (filterM, liftM2)
import Control.Monad.IO.Class       (MonadIO (..))
import Data.Functor                 (void)
import Data.List                    (stripPrefix)
import System.Directory             (doesDirectoryExist, getDirectoryContents)
import System.FilePath.Posix        ((</>))
import Text.ParserCombinators.ReadP

-------------------------------------------------------------------------------
-- Glob
-------------------------------------------------------------------------------

{-

Globbing code and grammar judiciously stolen from cabal-install:

FilePathGlob    ::= FilePathRoot FilePathGlobRel
FilePathRoot    ::= {- empty -}        # relative to cabal.project
                  | "/"                # Unix root
                  | [a-zA-Z] ":" [/\\] # Windows root
                  | "~"                # home directory

FilePathGlobRel ::= Glob "/"  FilePathGlobRel # Unix directory
                  | Glob "\\" FilePathGlobRel # Windows directory
                  | Glob         # file
                  | {- empty -}  # trailing slash

Glob      ::= GlobPiece *
GlobPiece ::= "*"            # wildcard
            | [^*{},/\\] *   # literal string
            | "\\" [*{},]    # escaped reserved character
            | "{" Glob "," ... "," Glob "}" # union (match any of these)
-}

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)

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)

-- | 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)

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)

parseFilePathGlobRel :: ReadP FilePathGlobRel
parseFilePathGlobRel :: ReadP FilePathGlobRel
parseFilePathGlobRel =
      ReadP [GlobPiece]
parseGlob ReadP [GlobPiece]
-> ([GlobPiece] -> ReadP FilePathGlobRel) -> ReadP FilePathGlobRel
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[GlobPiece]
globpieces ->
          [GlobPiece] -> ReadP FilePathGlobRel
asDir [GlobPiece]
globpieces
      ReadP FilePathGlobRel
-> ReadP FilePathGlobRel -> ReadP FilePathGlobRel
forall a. ReadP a -> ReadP a -> ReadP a
<++ [GlobPiece] -> ReadP FilePathGlobRel
asTDir [GlobPiece]
globpieces
      ReadP FilePathGlobRel
-> ReadP FilePathGlobRel -> ReadP FilePathGlobRel
forall a. ReadP a -> ReadP a -> ReadP a
<++ [GlobPiece] -> ReadP FilePathGlobRel
forall (m :: * -> *). Monad m => [GlobPiece] -> m FilePathGlobRel
asFile [GlobPiece]
globpieces
  where
    asDir :: [GlobPiece] -> ReadP FilePathGlobRel
asDir  [GlobPiece]
glob = do ReadP ()
dirSep
                     [GlobPiece] -> FilePathGlobRel -> FilePathGlobRel
GlobDir [GlobPiece]
glob (FilePathGlobRel -> FilePathGlobRel)
-> ReadP FilePathGlobRel -> ReadP FilePathGlobRel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP FilePathGlobRel
parseFilePathGlobRel
    asTDir :: [GlobPiece] -> ReadP FilePathGlobRel
asTDir [GlobPiece]
glob = do ReadP ()
dirSep
                     FilePathGlobRel -> ReadP FilePathGlobRel
forall (m :: * -> *) a. Monad m => a -> m a
return ([GlobPiece] -> FilePathGlobRel -> FilePathGlobRel
GlobDir [GlobPiece]
glob FilePathGlobRel
GlobDirTrailing)
    asFile :: [GlobPiece] -> m FilePathGlobRel
asFile [GlobPiece]
glob = FilePathGlobRel -> m FilePathGlobRel
forall (m :: * -> *) a. Monad m => a -> m a
return ([GlobPiece] -> FilePathGlobRel
GlobFile [GlobPiece]
glob)

    dirSep :: ReadP ()
dirSep = ReadP Char -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> ReadP Char
char Char
'/')
         ReadP () -> ReadP () -> ReadP ()
forall a. ReadP a -> ReadP a -> ReadP a
+++ (do Char
_ <- Char -> ReadP Char
char Char
'\\'
                 -- check this isn't an escape code
                 String
following <- ReadP String
look
                 case String
following of
                   (Char
c:String
_) | Char -> Bool
isGlobEscapedChar Char
c -> ReadP ()
forall a. ReadP a
pfail
                   String
_                           -> () -> ReadP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

parseGlob :: ReadP Glob
parseGlob :: ReadP [GlobPiece]
parseGlob = ReadP GlobPiece -> ReadP [GlobPiece]
forall a. ReadP a -> ReadP [a]
many1 ReadP GlobPiece
parsePiece
  where
    parsePiece :: ReadP GlobPiece
parsePiece = ReadP GlobPiece
literal ReadP GlobPiece -> ReadP GlobPiece -> ReadP GlobPiece
forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP GlobPiece
wildcard ReadP GlobPiece -> ReadP GlobPiece -> ReadP GlobPiece
forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP GlobPiece
union'

    wildcard :: ReadP GlobPiece
wildcard = Char -> ReadP Char
char Char
'*' ReadP Char -> ReadP GlobPiece -> ReadP GlobPiece
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GlobPiece -> ReadP GlobPiece
forall (m :: * -> *) a. Monad m => a -> m a
return GlobPiece
WildCard

    union' :: ReadP GlobPiece
union' = ReadP Char -> ReadP Char -> ReadP GlobPiece -> ReadP GlobPiece
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'{') (Char -> ReadP Char
char Char
'}') (ReadP GlobPiece -> ReadP GlobPiece)
-> ReadP GlobPiece -> ReadP GlobPiece
forall a b. (a -> b) -> a -> b
$
              ([[GlobPiece]] -> GlobPiece)
-> ReadP [[GlobPiece]] -> ReadP GlobPiece
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[GlobPiece]] -> GlobPiece
Union (ReadP [GlobPiece] -> ReadP Char -> ReadP [[GlobPiece]]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
sepBy1 ReadP [GlobPiece]
parseGlob (Char -> ReadP Char
char Char
','))

    literal :: ReadP GlobPiece
literal = String -> GlobPiece
Literal (String -> GlobPiece) -> ReadP String -> ReadP GlobPiece
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ReadP String
litchars1

    litchar :: ReadP Char
litchar = ReadP Char
normal ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP Char
escape

    normal :: ReadP Char
normal  = (Char -> Bool) -> ReadP Char
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 :: ReadP Char
escape  = Char -> ReadP Char
char Char
'\\' ReadP Char -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isGlobEscapedChar

    litchars1 :: ReadP [Char]
    litchars1 :: ReadP String
litchars1 = (Char -> ShowS) -> ReadP Char -> ReadP String -> ReadP String
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) ReadP Char
litchar ReadP String
litchars

    litchars :: ReadP [Char]
    litchars :: ReadP String
litchars = ReadP String
litchars1 ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ String -> ReadP String
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

expandRelGlob :: MonadIO m => FilePath -> FilePathGlobRel -> m [FilePath]
expandRelGlob :: String -> FilePathGlobRel -> m [String]
expandRelGlob String
root FilePathGlobRel
glob0 = IO [String] -> m [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> m [String]) -> IO [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\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 -> FilePath -> 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