{-# 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)
match :: Pattern -> FilePath -> Bool
match :: Pattern -> [Char] -> Bool
match = MatchOptions -> Pattern -> [Char] -> Bool
matchWith MatchOptions
matchDefault
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 ([Token] -> [Token]) -> [Token] -> [Token]
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 (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower else [Char] -> [Char]
forall a. a -> a
id
lcPat :: [Token] -> [Token]
lcPat = if MatchOptions -> Bool
ignoreCase MatchOptions
opts then (Token -> Token) -> [Token] -> [Token]
forall a b. (a -> b) -> [a] -> [b]
map Token -> Token
tokToLower else [Token] -> [Token]
forall a. a -> a
id
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 ((Token -> Bool) -> [Token] -> [Token]
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 =
(Char -> Bool) -> [Char] -> [Char]
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 ((Char -> Bool) -> [Char] -> [Char]
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 (Pattern -> Bool) -> ([Token] -> Pattern) -> [Token] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Pattern
Pattern ([Token] -> Bool) -> [Token] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [Token] -> [Token]
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 = [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
s
match' MatchOptions
_ (Token
AnyNonPathSeparator:[Token]
s) [Char]
"" = [Token] -> Bool
forall a. [a] -> Bool
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 Char -> Char -> Bool
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 ((Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
PathSeparator) [Token]
xs)
((Char -> Bool) -> [Char] -> [Char]
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 =
(Char -> Bool)
-> ((Char, Char) -> Bool) -> Either Char (Char, Char) -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) ((Char, Char) -> Char -> Bool
forall a. Ord a => (a, a) -> a -> Bool
`inRange` Char
c) Either Char (Char, Char)
r Bool -> Bool -> Bool
||
MatchOptions -> Bool
ignoreCase MatchOptions
o Bool -> Bool -> Bool
&& (Char -> Bool)
-> ((Char, Char) -> Bool) -> Either Char (Char, Char) -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
toUpper Char
c) ((Char, Char) -> Char -> Bool
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
&&
(Either Char (Char, Char) -> Bool)
-> [Either Char (Char, Char)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either Char (Char, Char) -> Bool
rangeMatch [Either Char (Char, Char)]
rng Bool -> Bool -> Bool
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 =
[([a], [a])] -> [([a], [a])]
forall a. (?callStack::CallStack) => [a] -> [a]
tail ([([a], [a])] -> [([a], [a])])
-> ([Int] -> [([a], [a])]) -> [Int] -> [([a], [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([a], [a]) -> Bool) -> [([a], [a])] -> [([a], [a])]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not(Bool -> Bool) -> (([a], [a]) -> Bool) -> ([a], [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null([a] -> Bool) -> (([a], [a]) -> [a]) -> ([a], [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([a], [a]) -> [a]
forall a b. (a, b) -> b
snd) ([([a], [a])] -> [([a], [a])])
-> ([Int] -> [([a], [a])]) -> [Int] -> [([a], [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ([a], [a])) -> [Int] -> [([a], [a])]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
`splitAt` [a]
n) ([Int] -> [([a], [a])]) -> [Int] -> [([a], [a])]
forall a b. (a -> b) -> a -> b
$ [Int
0..]
([Char]
lzNum,[Char]
cs) = (Char -> Bool) -> [Char] -> ([Char], [Char])
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 = [Char] -> [([Char], [Char])]
forall {a}. [a] -> [([a], [a])]
getNumChoices [Char]
num
zeroChoices :: [([Char], [Char])]
zeroChoices = (([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> [([Char], [Char])]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'0') ([Char] -> Bool)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst) ([Char] -> [([Char], [Char])]
forall {a}. [a] -> [([a], [a])]
getNumChoices [Char]
lzNum)
in
Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
lzNum) Bool -> Bool -> Bool
&&
((([Char], [Char]) -> Bool) -> [([Char], [Char])] -> Bool
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 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cs))
(([Char]
num,[Char]
"") ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: [([Char], [Char])]
numChoices)
Bool -> Bool -> Bool
|| (Bool -> Bool
not ([([Char], [Char])] -> Bool
forall a. [a] -> Bool
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
&& (([Char], [Char]) -> Bool) -> [([Char], [Char])] -> 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 [Char] -> [Char] -> [Char]
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
else Bool
hasMatch Bool -> Bool -> Bool
&& ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not(Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isExtSeparator(Char -> Bool) -> ([Char] -> Char) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Char] -> Char
forall a. (?callStack::CallStack) => [a] -> a
head) [[Char]]
matchedDirs
where parts :: [[Char]]
parts = [Char] -> [[Char]]
pathParts ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPathSeparator [Char]
path)
matchIndex :: Maybe Int
matchIndex = ([Char] -> Bool) -> [[Char]] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (MatchOptions -> [Token] -> [Char] -> Bool
match' MatchOptions
o [Token]
xs) [[Char]]
parts
hasMatch :: Bool
hasMatch = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
matchIndex
matchedDirs :: [[Char]]
matchedDirs = Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take (Int -> Maybe Int -> Int
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) = Int -> [Char] -> ([Char], [Char])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
len [Char]
path
in [Char]
pre [Char] -> [Char] -> Bool
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]
_ = [Char] -> Bool
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"ExtSeparator survived optimization?"
inOpenRange :: Maybe String -> Maybe String -> String -> Bool
inOpenRange :: Maybe [Char] -> Maybe [Char] -> [Char] -> Bool
inOpenRange Maybe [Char]
l_ Maybe [Char]
h_ [Char]
s_ = Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
s_) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> Maybe [Char] -> [Char] -> Ordering -> Ordering -> Bool
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
go (Just []) Maybe [a]
_ [] Ordering
LT Ordering
_ = Bool
False
go Maybe [a]
_ (Just []) [a]
_ Ordering
_ Ordering
GT = Bool
False
go Maybe [a]
_ (Just []) (a
_:[a]
_) Ordering
_ Ordering
_ = Bool
False
go (Just (a
_:[a]
_)) Maybe [a]
_ [] Ordering
_ Ordering
_ = Bool
False
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 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
c a
l
ordh' :: Ordering
ordh' = Ordering
ordh Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
c a
h
in Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go ([a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
ls) ([a] -> Maybe [a]
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 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
c a
h
in Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go Maybe [a]
forall a. Maybe a
Nothing ([a] -> Maybe [a]
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 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
c a
l
in Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go ([a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
ls) Maybe [a]
forall a. Maybe a
Nothing [a]
cs Ordering
ordl' Ordering
LT
go (Just []) Maybe [a]
hi [a]
s Ordering
_ Ordering
ordh = Maybe [a] -> Maybe [a] -> [a] -> Ordering -> Ordering -> Bool
go Maybe [a]
forall a. Maybe a
Nothing Maybe [a]
hi [a]
s Ordering
GT Ordering
ordh