-- File created: 2008-10-10 13:29:03


{-# LANGUAGE CPP #-}

module System.FilePath.Glob.Match (match, matchWith) where

import Control.Exception (assert)
import Data.Char         (isDigit, toLower, toUpper)
import Data.List         (findIndex)
import Data.Maybe        (fromMaybe, isJust)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid       (mappend)
#endif
import System.FilePath   (isPathSeparator, isExtSeparator)

import System.FilePath.Glob.Base  ( Pattern(..), Token(..)
                                  , MatchOptions(..), matchDefault
                                  , isLiteral, tokToLower
                                  )
import System.FilePath.Glob.Utils (dropLeadingZeroes, inRange, pathParts)

-- |Matches the given 'Pattern' against the given 'FilePath', returning 'True'

-- if the pattern matches and 'False' otherwise.

match :: Pattern -> FilePath -> Bool
match :: Pattern -> [Char] -> Bool
match = MatchOptions -> Pattern -> [Char] -> Bool
matchWith MatchOptions
matchDefault

-- |Like 'match', but applies the given 'MatchOptions' instead of the defaults.

matchWith :: MatchOptions -> Pattern -> FilePath -> Bool
matchWith :: MatchOptions -> Pattern -> [Char] -> Bool
matchWith MatchOptions
opts Pattern
p [Char]
f = MatchOptions -> [Token] -> [Char] -> Bool
begMatch MatchOptions
opts ([Token] -> [Token]
lcPat forall a b. (a -> b) -> a -> b
$ Pattern -> [Token]
unPattern Pattern
p) ([Char] -> [Char]
lcPath [Char]
f)
 where
   lcPath :: [Char] -> [Char]
lcPath = if MatchOptions -> Bool
ignoreCase MatchOptions
opts then forall a b. (a -> b) -> [a] -> [b]
map    Char -> Char
toLower else forall a. a -> a
id
   lcPat :: [Token] -> [Token]
lcPat  = if MatchOptions -> Bool
ignoreCase MatchOptions
opts then forall a b. (a -> b) -> [a] -> [b]
map Token -> Token
tokToLower else forall a. a -> a
id

-- begMatch takes care of some things at the beginning of a pattern or after /:

--    - . needs to be matched explicitly

--    - ./foo is equivalent to foo (for any number of /)

--

-- .*/foo still needs to match ./foo though, and it won't match plain foo;

-- special case that one

--

-- and .**/foo should /not/ match ../foo; more special casing

--

-- (All of the above is modulo options, of course)

begMatch, match' :: MatchOptions -> [Token] -> FilePath -> Bool
begMatch :: MatchOptions -> [Token] -> [Char] -> Bool
begMatch MatchOptions
_ (Literal Char
'.' : Token
AnyDirectory : [Token]
_) (Char
x:Char
y:[Char]
_)
   | Char -> Bool
isExtSeparator Char
x Bool -> Bool -> Bool
&& Char -> Bool
isExtSeparator Char
y = Bool
False

begMatch MatchOptions
opts (Literal Char
'.' : Token
PathSeparator : [Token]
pat) [Char]
s | MatchOptions -> Bool
ignoreDotSlash MatchOptions
opts =
   MatchOptions -> [Token] -> [Char] -> Bool
begMatch MatchOptions
opts (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Token -> Bool
isSlash [Token]
pat) ([Char] -> [Char]
dropDotSlash [Char]
s)
 where
   isSlash :: Token -> Bool
isSlash Token
PathSeparator = Bool
True
   isSlash Token
_             = Bool
False

   dropDotSlash :: [Char] -> [Char]
dropDotSlash (Char
x:Char
y:[Char]
ys) | Char -> Bool
isExtSeparator Char
x Bool -> Bool -> Bool
&& Char -> Bool
isPathSeparator Char
y =
      forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPathSeparator [Char]
ys
   dropDotSlash [Char]
xs = [Char]
xs

begMatch MatchOptions
opts [Token]
pat (Char
x:Char
y:[Char]
s)
   | Bool
dotSlash Bool -> Bool -> Bool
&& Bool
dotStarSlash        = MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
opts [Token]
pat' [Char]
s
   | MatchOptions -> Bool
ignoreDotSlash MatchOptions
opts Bool -> Bool -> Bool
&& Bool
dotSlash =
        MatchOptions -> [Token] -> [Char] -> Bool
begMatch MatchOptions
opts [Token]
pat (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPathSeparator [Char]
s)
 where
   dotSlash :: Bool
dotSlash = Char -> Bool
isExtSeparator Char
x Bool -> Bool -> Bool
&& Char -> Bool
isPathSeparator Char
y
   (Bool
dotStarSlash, [Token]
pat') =
      case [Token]
pat of
        Literal Char
'.': Token
AnyNonPathSeparator : Token
PathSeparator : [Token]
rest -> (Bool
True, [Token]
rest)
        [Token]
_                                                       -> (Bool
False, [Token]
pat)

begMatch MatchOptions
opts [Token]
pat (Char
e:[Char]
_)
   | Char -> Bool
isExtSeparator Char
e
     Bool -> Bool -> Bool
&& Bool -> Bool
not (MatchOptions -> Bool
matchDotsImplicitly MatchOptions
opts)
     Bool -> Bool -> Bool
&& Bool -> Bool
not (Pattern -> Bool
isLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Pattern
Pattern forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
1 [Token]
pat) = Bool
False

begMatch MatchOptions
opts [Token]
pat [Char]
s = MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
opts [Token]
pat [Char]
s

match' :: MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
_ []                        [Char]
s  = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
s
match' MatchOptions
_ (Token
AnyNonPathSeparator:[Token]
s)   [Char]
"" = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
s
match' MatchOptions
_ [Token]
_                         [Char]
"" = Bool
False
match' MatchOptions
o (Literal Char
l       :[Token]
xs) (Char
c:[Char]
cs) = Char
l forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
&& MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
xs [Char]
cs
match' MatchOptions
o (Token
NonPathSeparator:[Token]
xs) (Char
c:[Char]
cs) =
   Bool -> Bool
not (Char -> Bool
isPathSeparator Char
c) Bool -> Bool -> Bool
&& MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
xs [Char]
cs

match' MatchOptions
o (Token
PathSeparator   :[Token]
xs) (Char
c:[Char]
cs) =
   Char -> Bool
isPathSeparator Char
c Bool -> Bool -> Bool
&& MatchOptions -> [Token] -> [Char] -> Bool
begMatch MatchOptions
o (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Token
PathSeparator) [Token]
xs)
                                   (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPathSeparator [Char]
cs)

match' MatchOptions
o (CharRange Bool
b [Either Char (Char, Char)]
rng :[Token]
xs) (Char
c:[Char]
cs) =
   let rangeMatch :: Either Char (Char, Char) -> Bool
rangeMatch Either Char (Char, Char)
r =
          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Eq a => a -> a -> Bool
== Char
c) (forall a. Ord a => (a, a) -> a -> Bool
`inRange` Char
c) Either Char (Char, Char)
r Bool -> Bool -> Bool
||
             -- See comment near Base.tokToLower for an explanation of why we

             -- do this

             MatchOptions -> Bool
ignoreCase MatchOptions
o Bool -> Bool -> Bool
&& forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Eq a => a -> a -> Bool
== Char -> Char
toUpper Char
c) (forall a. Ord a => (a, a) -> a -> Bool
`inRange` Char -> Char
toUpper Char
c) Either Char (Char, Char)
r
    in Bool -> Bool
not (Char -> Bool
isPathSeparator Char
c) Bool -> Bool -> Bool
&&
       forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either Char (Char, Char) -> Bool
rangeMatch [Either Char (Char, Char)]
rng forall a. Eq a => a -> a -> Bool
== Bool
b Bool -> Bool -> Bool
&&
       MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
xs [Char]
cs

match' MatchOptions
o (OpenRange Maybe [Char]
lo Maybe [Char]
hi :[Token]
xs) [Char]
path =
   let getNumChoices :: [a] -> [([a], [a])]
getNumChoices [a]
n =
          forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. Foldable t => t a -> Bool
nullforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> ([a], [a])
`splitAt` [a]
n) forall a b. (a -> b) -> a -> b
$ [Int
0..]
       ([Char]
lzNum,[Char]
cs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
path
       num :: [Char]
num        = [Char] -> [Char]
dropLeadingZeroes [Char]
lzNum
       numChoices :: [([Char], [Char])]
numChoices = forall {a}. [a] -> [([a], [a])]
getNumChoices [Char]
num
       zeroChoices :: [([Char], [Char])]
zeroChoices = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Char
'0') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall {a}. [a] -> [([a], [a])]
getNumChoices [Char]
lzNum)
    in -- null lzNum means no digits: definitely not a match

       Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
lzNum) Bool -> Bool -> Bool
&&
          -- So, given the path "00123foo" what we've got is:

          --    lzNum       = "00123"

          --    cs          = "foo"

          --    num         = "123"

          --    numChoices  = [("1","23"),("12","3")]

          --    zeroChoices = [("0", "0123"), ("00", "123")]

          --

          -- We want to try matching x against each of 123, 12, and 1.

          -- 12 and 1 are in numChoices already, but we need to add (num,"")

          -- manually.

          --

          -- It's also possible that we only want to match the zeroes. Handle

          -- that separately since inOpenRange doesn't like leading zeroes.

          (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\([Char]
n,[Char]
rest) -> Maybe [Char] -> Maybe [Char] -> [Char] -> Bool
inOpenRange Maybe [Char]
lo Maybe [Char]
hi [Char]
n Bool -> Bool -> Bool
&& MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
xs ([Char]
rest forall a. [a] -> [a] -> [a]
++ [Char]
cs))
               (([Char]
num,[Char]
"") forall a. a -> [a] -> [a]
: [([Char], [Char])]
numChoices)
           Bool -> Bool -> Bool
|| (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], [Char])]
zeroChoices) Bool -> Bool -> Bool
&& Maybe [Char] -> Maybe [Char] -> [Char] -> Bool
inOpenRange Maybe [Char]
lo Maybe [Char]
hi [Char]
"0"
               Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\([Char]
_,[Char]
rest) -> MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
xs ([Char]
rest forall a. [a] -> [a] -> [a]
++ [Char]
cs)) [([Char], [Char])]
zeroChoices))

match' MatchOptions
o again :: [Token]
again@(Token
AnyNonPathSeparator:[Token]
xs) path :: [Char]
path@(Char
c:[Char]
cs) =
   MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
xs [Char]
path Bool -> Bool -> Bool
|| (Bool -> Bool
not (Char -> Bool
isPathSeparator Char
c) Bool -> Bool -> Bool
&& MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
again [Char]
cs)

match' MatchOptions
o (Token
AnyDirectory:[Token]
xs) [Char]
path =
   if MatchOptions -> Bool
matchDotsImplicitly MatchOptions
o
      then Bool
hasMatch
      --  **/baz shouldn't match foo/.bar/baz, so check that none of the

      -- directories matched by **/ start with .

      else Bool
hasMatch Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isExtSeparatorforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. [a] -> a
head) [[Char]]
matchedDirs
 where parts :: [[Char]]
parts   = [Char] -> [[Char]]
pathParts (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPathSeparator [Char]
path)
       matchIndex :: Maybe Int
matchIndex = forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
xs) [[Char]]
parts
       hasMatch :: Bool
hasMatch = forall a. Maybe a -> Bool
isJust Maybe Int
matchIndex
       matchedDirs :: [[Char]]
matchedDirs = forall a. Int -> [a] -> [a]
take (forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
matchIndex) [[Char]]
parts

match' MatchOptions
o (LongLiteral Int
len [Char]
s:[Token]
xs) [Char]
path =
   let ([Char]
pre,[Char]
cs) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
len [Char]
path
    in [Char]
pre forall a. Eq a => a -> a -> Bool
== [Char]
s Bool -> Bool -> Bool
&& MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
xs [Char]
cs

match' MatchOptions
_ (Token
Unmatchable:[Token]
_) [Char]
_ = Bool
False
match' MatchOptions
_ (Token
ExtSeparator:[Token]
_) [Char]
_ = forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"ExtSeparator survived optimization?"

-- Does the actual open range matching: finds whether the third parameter

-- is between the first two or not.

--

-- It does this by keeping track of the Ordering so far (e.g. having

-- looked at "12" and "34" the Ordering of the two would be LT: 12 < 34)

-- and aborting if a String "runs out": a longer string is automatically

-- greater.

--

-- Assumes that the input strings contain only digits, and no leading zeroes.

inOpenRange :: Maybe String -> Maybe String -> String -> Bool
inOpenRange :: Maybe [Char] -> Maybe [Char] -> [Char] -> Bool
inOpenRange Maybe [Char]
l_ Maybe [Char]
h_ [Char]
s_ = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
s_) forall a b. (a -> b) -> a -> b
$ forall {a}.
Ord a =>
Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go Maybe [Char]
l_ Maybe [Char]
h_ [Char]
s_ Ordering
EQ Ordering
EQ
 where
   go :: Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go Maybe [a]
Nothing      Maybe [a]
Nothing   [a]
_     Ordering
_ Ordering
_  = Bool
True  -- no bounds

   go (Just [])    Maybe [a]
_         []    Ordering
LT Ordering
_ = Bool
False --  lesser than lower bound

   go Maybe [a]
_            (Just []) [a]
_     Ordering
_ Ordering
GT = Bool
False -- greater than upper bound

   go Maybe [a]
_            (Just []) (a
_:[a]
_) Ordering
_ Ordering
_  = Bool
False --  longer than upper bound

   go (Just (a
_:[a]
_)) Maybe [a]
_         []    Ordering
_ Ordering
_  = Bool
False -- shorter than lower bound

   go Maybe [a]
_            Maybe [a]
_         []    Ordering
_ Ordering
_  = Bool
True

   go (Just (a
l:[a]
ls)) (Just (a
h:[a]
hs)) (a
c:[a]
cs) Ordering
ordl Ordering
ordh =
      let ordl' :: Ordering
ordl' = Ordering
ordl forall a. Monoid a => a -> a -> a
`mappend` forall a. Ord a => a -> a -> Ordering
compare a
c a
l
          ordh' :: Ordering
ordh' = Ordering
ordh forall a. Monoid a => a -> a -> a
`mappend` forall a. Ord a => a -> a -> Ordering
compare a
c a
h
       in Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go (forall a. a -> Maybe a
Just [a]
ls) (forall a. a -> Maybe a
Just [a]
hs) [a]
cs Ordering
ordl' Ordering
ordh'

   go Maybe [a]
Nothing (Just (a
h:[a]
hs)) (a
c:[a]
cs) Ordering
_ Ordering
ordh =
      let ordh' :: Ordering
ordh' = Ordering
ordh forall a. Monoid a => a -> a -> a
`mappend` forall a. Ord a => a -> a -> Ordering
compare a
c a
h
       in Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [a]
hs) [a]
cs Ordering
GT Ordering
ordh'

   go (Just (a
l:[a]
ls)) Maybe [a]
Nothing (a
c:[a]
cs) Ordering
ordl Ordering
_ =
      let ordl' :: Ordering
ordl' = Ordering
ordl forall a. Monoid a => a -> a -> a
`mappend` forall a. Ord a => a -> a -> Ordering
compare a
c a
l
       in Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go (forall a. a -> Maybe a
Just [a]
ls) forall a. Maybe a
Nothing [a]
cs Ordering
ordl' Ordering
LT

   -- lower bound is shorter: s is greater

   go (Just []) Maybe [a]
hi [a]
s Ordering
_ Ordering
ordh = Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go forall a. Maybe a
Nothing Maybe [a]
hi [a]
s Ordering
GT Ordering
ordh