{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module System.FilePath.Glob.Base
( Token(..), Pattern(..)
, CompOptions(..), MatchOptions(..)
, compDefault, compPosix, matchDefault, matchPosix
, decompile
, compile
, compileWith, tryCompileWith
, tokenize
, optimize
, liftP, tokToLower
, isLiteral
) where
import Control.Arrow (first)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Control.Monad.Trans.Writer.Strict (Writer, runWriter, tell)
import Control.Exception (assert)
import Data.Char (isDigit, isAlpha, toLower)
import Data.List (find, sortBy)
import Data.List.NonEmpty (toList)
import Data.Maybe (fromMaybe)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid, mappend, mempty, mconcat)
#endif
#if MIN_VERSION_base(4,11,0)
import Data.Semigroup (sconcat, stimes)
#else
import Data.Semigroup (Semigroup, (<>), sconcat, stimes)
#endif
import Data.String (IsString(fromString))
import System.FilePath ( pathSeparator, extSeparator
, isExtSeparator, isPathSeparator
)
import System.FilePath.Glob.Utils ( dropLeadingZeroes
, isLeft, fromLeft
, increasingSeq
, addToRange, overlap
)
#if __GLASGOW_HASKELL__
import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident))
#endif
data Token
= Literal !Char
| ExtSeparator
| PathSeparator
| NonPathSeparator
| CharRange !Bool [Either Char (Char,Char)]
| OpenRange (Maybe String) (Maybe String)
| AnyNonPathSeparator
| AnyDirectory
| LongLiteral !Int String
| Unmatchable
deriving (Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq)
tokToLower :: Token -> Token
tokToLower :: Token -> Token
tokToLower (Literal Char
c) = Char -> Token
Literal (Char -> Char
toLower Char
c)
tokToLower (LongLiteral Int
n String
s) = Int -> String -> Token
LongLiteral Int
n (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s)
tokToLower Token
tok = Token
tok
newtype Pattern = Pattern { Pattern -> [Token]
unPattern :: [Token] } deriving (Pattern -> Pattern -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pattern -> Pattern -> Bool
$c/= :: Pattern -> Pattern -> Bool
== :: Pattern -> Pattern -> Bool
$c== :: Pattern -> Pattern -> Bool
Eq)
liftP :: ([Token] -> [Token]) -> Pattern -> Pattern
liftP :: ([Token] -> [Token]) -> Pattern -> Pattern
liftP [Token] -> [Token]
f (Pattern [Token]
pat) = [Token] -> Pattern
Pattern ([Token] -> [Token]
f [Token]
pat)
instance Show Token where
show :: Token -> String
show (Literal Char
c)
| Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"*?[<" = [Char
'[',Char
c,Char
']']
| Bool
otherwise = forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Char -> Bool
isPathSeparator Char
c) [Char
c]
show Token
ExtSeparator = [ Char
extSeparator]
show Token
PathSeparator = [Char
pathSeparator]
show Token
NonPathSeparator = String
"?"
show Token
AnyNonPathSeparator = String
"*"
show Token
AnyDirectory = String
"**/"
show (LongLiteral Int
_ String
s) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Token
Literal) String
s
show (OpenRange Maybe String
a Maybe String
b) =
Char
'<' forall a. a -> [a] -> [a]
: forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
a forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
b forall a. [a] -> [a] -> [a]
++ String
">"
show (CharRange Bool
b CharRange
r) =
let f :: Either Char (Char, Char) -> String
f = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. a -> [a] -> [a]
:[]) (\(Char
x,Char
y) -> [Char
x,Char
'-',Char
y])
(String
caret,String
exclamation,ShowS
fs) =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Either Char (Char, Char)
c (String
ca,String
ex,ShowS
ss) ->
case Either Char (Char, Char)
c of
Left Char
'^' -> (String
"^",String
ex,ShowS
ss)
Left Char
'!' -> (String
ca,String
"!",ShowS
ss)
Either Char (Char, Char)
_ -> (String
ca, String
ex,(Either Char (Char, Char) -> String
f Either Char (Char, Char)
c forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
ss)
)
(String
"", String
"", forall a. a -> a
id)
CharRange
r
(String
beg,String
rest) = let s' :: String
s' = ShowS
fs []
(String
x,String
y) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 String
s'
in if Bool -> Bool
not Bool
b Bool -> Bool -> Bool
&& String
x forall a. Eq a => a -> a -> Bool
== String
"-"
then (String
y,String
x)
else (String
s',String
"")
in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"["
, if Bool
b then String
"" else String
"^"
, if Bool
b Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
beg Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
caret Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
exclamation) then String
"/" else String
""
, String
beg, String
caret, String
exclamation, String
rest
, String
"]"
]
show Token
Unmatchable = String
"[.]"
instance Show Pattern where
showsPrec :: Int -> Pattern -> ShowS
showsPrec Int
d Pattern
p = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
String -> ShowS
showString String
"compile " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec (Int
dforall a. Num a => a -> a -> a
+Int
1) (Pattern -> String
decompile Pattern
p)
instance Read Pattern where
#if __GLASGOW_HASKELL__
readPrec :: ReadPrec Pattern
readPrec = forall a. ReadPrec a -> ReadPrec a
parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
10 forall a b. (a -> b) -> a -> b
$ do
Ident String
"compile" <- ReadPrec Lexeme
lexP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Pattern
compile forall a. Read a => ReadPrec a
readPrec
#else
readsPrec d = readParen (d > 10) $ \r -> do
("compile",string) <- lex r
(xs,rest) <- readsPrec (d+1) string
[(compile xs, rest)]
#endif
instance Semigroup Pattern where
Pattern [Token]
a <> :: Pattern -> Pattern -> Pattern
<> Pattern [Token]
b = Pattern -> Pattern
optimize forall a b. (a -> b) -> a -> b
$ [Token] -> Pattern
Pattern ([Token]
a forall a. Semigroup a => a -> a -> a
<> [Token]
b)
sconcat :: NonEmpty Pattern -> Pattern
sconcat = Pattern -> Pattern
optimize forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Pattern
Pattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pattern -> [Token]
unPattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
toList
stimes :: forall b. Integral b => b -> Pattern -> Pattern
stimes b
n (Pattern [Token]
a) = Pattern -> Pattern
optimize forall a b. (a -> b) -> a -> b
$ [Token] -> Pattern
Pattern (forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes b
n [Token]
a)
instance Monoid Pattern where
mempty :: Pattern
mempty = [Token] -> Pattern
Pattern []
mappend :: Pattern -> Pattern -> Pattern
mappend = forall a. Semigroup a => a -> a -> a
(<>)
mconcat :: [Pattern] -> Pattern
mconcat = Pattern -> Pattern
optimize forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Pattern
Pattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pattern -> [Token]
unPattern
instance IsString Pattern where
fromString :: String -> Pattern
fromString = String -> Pattern
compile
data CompOptions = CompOptions
{ CompOptions -> Bool
characterClasses :: Bool
, CompOptions -> Bool
characterRanges :: Bool
, CompOptions -> Bool
numberRanges :: Bool
, CompOptions -> Bool
wildcards :: Bool
, CompOptions -> Bool
recursiveWildcards :: Bool
, CompOptions -> Bool
pathSepInRanges :: Bool
, CompOptions -> Bool
errorRecovery :: Bool
} deriving (Int -> CompOptions -> ShowS
[CompOptions] -> ShowS
CompOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompOptions] -> ShowS
$cshowList :: [CompOptions] -> ShowS
show :: CompOptions -> String
$cshow :: CompOptions -> String
showsPrec :: Int -> CompOptions -> ShowS
$cshowsPrec :: Int -> CompOptions -> ShowS
Show,ReadPrec [CompOptions]
ReadPrec CompOptions
Int -> ReadS CompOptions
ReadS [CompOptions]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CompOptions]
$creadListPrec :: ReadPrec [CompOptions]
readPrec :: ReadPrec CompOptions
$creadPrec :: ReadPrec CompOptions
readList :: ReadS [CompOptions]
$creadList :: ReadS [CompOptions]
readsPrec :: Int -> ReadS CompOptions
$creadsPrec :: Int -> ReadS CompOptions
Read,CompOptions -> CompOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompOptions -> CompOptions -> Bool
$c/= :: CompOptions -> CompOptions -> Bool
== :: CompOptions -> CompOptions -> Bool
$c== :: CompOptions -> CompOptions -> Bool
Eq)
compDefault :: CompOptions
compDefault :: CompOptions
compDefault = CompOptions
{ characterClasses :: Bool
characterClasses = Bool
True
, characterRanges :: Bool
characterRanges = Bool
True
, numberRanges :: Bool
numberRanges = Bool
True
, wildcards :: Bool
wildcards = Bool
True
, recursiveWildcards :: Bool
recursiveWildcards = Bool
True
, pathSepInRanges :: Bool
pathSepInRanges = Bool
True
, errorRecovery :: Bool
errorRecovery = Bool
True
}
compPosix :: CompOptions
compPosix :: CompOptions
compPosix = CompOptions
{ characterClasses :: Bool
characterClasses = Bool
True
, characterRanges :: Bool
characterRanges = Bool
True
, numberRanges :: Bool
numberRanges = Bool
False
, wildcards :: Bool
wildcards = Bool
True
, recursiveWildcards :: Bool
recursiveWildcards = Bool
False
, pathSepInRanges :: Bool
pathSepInRanges = Bool
False
, errorRecovery :: Bool
errorRecovery = Bool
True
}
data MatchOptions = MatchOptions
{ MatchOptions -> Bool
matchDotsImplicitly :: Bool
, MatchOptions -> Bool
ignoreCase :: Bool
, MatchOptions -> Bool
ignoreDotSlash :: Bool
}
matchDefault :: MatchOptions
matchDefault :: MatchOptions
matchDefault = MatchOptions
matchPosix
matchPosix :: MatchOptions
matchPosix :: MatchOptions
matchPosix = MatchOptions
{ matchDotsImplicitly :: Bool
matchDotsImplicitly = Bool
False
, ignoreCase :: Bool
ignoreCase = Bool
False
, ignoreDotSlash :: Bool
ignoreDotSlash = Bool
True
}
decompile :: Pattern -> String
decompile :: Pattern -> String
decompile = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> [Token]
unPattern
compile :: String -> Pattern
compile :: String -> Pattern
compile = CompOptions -> String -> Pattern
compileWith CompOptions
compDefault
compileWith :: CompOptions -> String -> Pattern
compileWith :: CompOptions -> String -> Pattern
compileWith CompOptions
opts = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompOptions -> String -> Either String Pattern
tryCompileWith CompOptions
opts
tryCompileWith :: CompOptions -> String -> Either String Pattern
tryCompileWith :: CompOptions -> String -> Either String Pattern
tryCompileWith CompOptions
opts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pattern -> Pattern
optimize forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompOptions -> String -> Either String Pattern
tokenize CompOptions
opts
tokenize :: CompOptions -> String -> Either String Pattern
tokenize :: CompOptions -> String -> Either String Pattern
tokenize CompOptions
opts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Token] -> Pattern
Pattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Either String Token]
go
where
err :: String -> Char -> String -> [Either String Token]
err String
_ Char
c String
cs | CompOptions -> Bool
errorRecovery CompOptions
opts = forall a b. b -> Either a b
Right (Char -> Token
Literal Char
c) forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
err String
s Char
_ String
_ = [forall a b. a -> Either a b
Left String
s]
go :: String -> [Either String Token]
go :: String -> [Either String Token]
go [] = []
go (Char
'?':String
cs) | Bool
wcs = forall a b. b -> Either a b
Right Token
NonPathSeparator forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
go (Char
'*':String
cs) | Bool
wcs =
case String
cs of
Char
'*':Char
p:String
xs | Bool
rwcs Bool -> Bool -> Bool
&& Char -> Bool
isPathSeparator Char
p
-> forall a b. b -> Either a b
Right Token
AnyDirectory forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
xs
String
_ -> forall a b. b -> Either a b
Right Token
AnyNonPathSeparator forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
go (Char
'[':String
cs) | Bool
crs = let (Either String Token
range,String
rest) = CompOptions -> String -> (Either String Token, String)
charRange CompOptions
opts String
cs
in case Either String Token
range of
Left String
s -> String -> Char -> String -> [Either String Token]
err String
s Char
'[' String
cs
Either String Token
r -> Either String Token
r forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
rest
go (Char
'<':String
cs) | Bool
ors =
let (String
range, String
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
'>') String
cs
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest
then String -> Char -> String -> [Either String Token]
err String
"compile :: unclosed <> in pattern" Char
'<' String
cs
else case String -> Either String Token
openRange String
range of
Left String
s -> String -> Char -> String -> [Either String Token]
err String
s Char
'<' String
cs
Either String Token
r -> Either String Token
r forall a. a -> [a] -> [a]
: String -> [Either String Token]
go (forall a. [a] -> [a]
tail String
rest)
go (Char
c:String
cs)
| Char -> Bool
isPathSeparator Char
c = forall a b. b -> Either a b
Right Token
PathSeparator forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
| Char -> Bool
isExtSeparator Char
c = forall a b. b -> Either a b
Right Token
ExtSeparator forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
| Bool
otherwise = forall a b. b -> Either a b
Right (Char -> Token
Literal Char
c) forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
wcs :: Bool
wcs = CompOptions -> Bool
wildcards CompOptions
opts
rwcs :: Bool
rwcs = CompOptions -> Bool
recursiveWildcards CompOptions
opts
crs :: Bool
crs = CompOptions -> Bool
characterRanges CompOptions
opts
ors :: Bool
ors = CompOptions -> Bool
numberRanges CompOptions
opts
openRange :: String -> Either String Token
openRange :: String -> Either String Token
openRange [Char
'-'] = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> Token
OpenRange forall a. Maybe a
Nothing forall a. Maybe a
Nothing
openRange (Char
'-':String
s) =
case forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s of
(String
b,String
"") -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> Token
OpenRange forall a. Maybe a
Nothing (String -> Maybe String
openRangeNum String
b)
(String, String)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"compile :: bad <>, expected number, got " forall a. [a] -> [a] -> [a]
++ String
s
openRange String
s =
case forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s of
(String
a,String
"-") -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> Token
OpenRange (String -> Maybe String
openRangeNum String
a) forall a. Maybe a
Nothing
(String
a,Char
'-':String
s') ->
case forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s' of
(String
b,String
"") -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> Token
OpenRange (String -> Maybe String
openRangeNum String
a) (String -> Maybe String
openRangeNum String
b)
(String, String)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"compile :: bad <>, expected number, got " forall a. [a] -> [a] -> [a]
++ String
s'
(String, String)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"compile :: bad <>, expected number followed by - in " forall a. [a] -> [a] -> [a]
++ String
s
openRangeNum :: String -> Maybe String
openRangeNum :: String -> Maybe String
openRangeNum = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropLeadingZeroes
type CharRange = [Either Char (Char,Char)]
charRange :: CompOptions -> String -> (Either String Token, String)
charRange :: CompOptions -> String -> (Either String Token, String)
charRange CompOptions
opts String
zs =
case String
zs of
Char
y:String
ys | Char
y forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"^!" ->
case String
ys of
Char
'-':Char
']':String
xs -> (forall a b. b -> Either a b
Right (Bool -> CharRange -> Token
CharRange Bool
False [forall a b. a -> Either a b
Left Char
'-']), String
xs)
Char
'-' :String
_ -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> CharRange -> Token
CharRange Bool
True )) (String -> (Either String CharRange, String)
start String
zs)
String
xs -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> CharRange -> Token
CharRange Bool
False)) (String -> (Either String CharRange, String)
start String
xs)
String
_ -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> CharRange -> Token
CharRange Bool
True )) (String -> (Either String CharRange, String)
start String
zs)
where
start :: String -> (Either String CharRange, String)
start :: String -> (Either String CharRange, String)
start (Char
']':String
xs) = ExceptT String (Writer CharRange) String
-> (Either String CharRange, String)
run forall a b. (a -> b) -> a -> b
$ Char -> String -> ExceptT String (Writer CharRange) String
char Char
']' String
xs
start (Char
'-':String
xs) = ExceptT String (Writer CharRange) String
-> (Either String CharRange, String)
run forall a b. (a -> b) -> a -> b
$ Char -> String -> ExceptT String (Writer CharRange) String
char Char
'-' String
xs
start String
xs = ExceptT String (Writer CharRange) String
-> (Either String CharRange, String)
run forall a b. (a -> b) -> a -> b
$ String -> ExceptT String (Writer CharRange) String
go String
xs
run :: ExceptT String (Writer CharRange) String
-> (Either String CharRange, String)
run :: ExceptT String (Writer CharRange) String
-> (Either String CharRange, String)
run ExceptT String (Writer CharRange) String
m = case forall w a. Writer w a -> (a, w)
runWriterforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ ExceptT String (Writer CharRange) String
m of
(Left String
err, CharRange
_) -> (forall a b. a -> Either a b
Left String
err, [])
(Right String
rest, CharRange
cs) -> (forall a b. b -> Either a b
Right CharRange
cs, String
rest)
go :: String -> ExceptT String (Writer CharRange) String
go :: String -> ExceptT String (Writer CharRange) String
go (Char
'[':Char
':':String
xs) | CompOptions -> Bool
characterClasses CompOptions
opts = String -> ExceptT String (Writer CharRange) String
readClass String
xs
go ( Char
']':String
xs) = forall (m :: * -> *) a. Monad m => a -> m a
return String
xs
go ( Char
c:String
xs) =
if Bool -> Bool
not (CompOptions -> Bool
pathSepInRanges CompOptions
opts) Bool -> Bool -> Bool
&& Char -> Bool
isPathSeparator Char
c
then forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"compile :: path separator within []"
else Char -> String -> ExceptT String (Writer CharRange) String
char Char
c String
xs
go [] = forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"compile :: unclosed [] in pattern"
char :: Char -> String -> ExceptT String (Writer CharRange) String
char :: Char -> String -> ExceptT String (Writer CharRange) String
char Char
c (Char
'-':Char
x:String
xs) =
if Char
x forall a. Eq a => a -> a -> Bool
== Char
']'
then CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall a b. a -> Either a b
Left Char
c, forall a b. a -> Either a b
Left Char
'-'] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return String
xs
else CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall a b. b -> Either a b
Right (Char
c,Char
x)] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ExceptT String (Writer CharRange) String
go String
xs
char Char
c String
xs = CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall a b. a -> Either a b
Left Char
c] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ExceptT String (Writer CharRange) String
go String
xs
readClass :: String -> ExceptT String (Writer CharRange) String
readClass :: String -> ExceptT String (Writer CharRange) String
readClass String
xs = let (String
name,String
end) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlpha String
xs
in case String
end of
Char
':':Char
']':String
rest -> String -> ExceptT String (Writer CharRange) ()
charClass String
name forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ExceptT String (Writer CharRange) String
go String
rest
String
_ -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall a b. a -> Either a b
Left Char
'[',forall a b. a -> Either a b
Left Char
':'] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ExceptT String (Writer CharRange) String
go String
xs
charClass :: String -> ExceptT String (Writer CharRange) ()
charClass :: String -> ExceptT String (Writer CharRange) ()
charClass String
name =
case String
name of
String
"alnum" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall {a}. Either a (Char, Char)
digit,forall {a}. Either a (Char, Char)
upper,forall {a}. Either a (Char, Char)
lower]
String
"alpha" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall {a}. Either a (Char, Char)
upper,forall {a}. Either a (Char, Char)
lower]
String
"blank" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell forall {b}. [Either Char b]
blanks
String
"cntrl" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall a b. b -> Either a b
Right (Char
'\0',Char
'\x1f'), forall a b. a -> Either a b
Left Char
'\x7f']
String
"digit" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall {a}. Either a (Char, Char)
digit]
String
"graph" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall a b. b -> Either a b
Right (Char
'!',Char
'~')]
String
"lower" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall {a}. Either a (Char, Char)
lower]
String
"print" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall a b. b -> Either a b
Right (Char
' ',Char
'~')]
String
"punct" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell forall {a}. [Either a (Char, Char)]
punct
String
"space" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell CharRange
spaces
String
"upper" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall {a}. Either a (Char, Char)
upper]
String
"xdigit" -> CharRange -> ExceptT String (Writer CharRange) ()
ltell [forall {a}. Either a (Char, Char)
digit, forall a b. b -> Either a b
Right (Char
'A',Char
'F'), forall a b. b -> Either a b
Right (Char
'a',Char
'f')]
String
_ ->
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String
"compile :: unknown character class '" forall a. [a] -> [a] -> [a]
++String
nameforall a. [a] -> [a] -> [a]
++ String
"'")
digit :: Either a (Char, Char)
digit = forall a b. b -> Either a b
Right (Char
'0',Char
'9')
upper :: Either a (Char, Char)
upper = forall a b. b -> Either a b
Right (Char
'A',Char
'Z')
lower :: Either a (Char, Char)
lower = forall a b. b -> Either a b
Right (Char
'a',Char
'z')
punct :: [Either a (Char, Char)]
punct = forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [(Char
'!',Char
'/'), (Char
':',Char
'@'), (Char
'[',Char
'`'), (Char
'{',Char
'~')]
blanks :: [Either Char b]
blanks = [forall a b. a -> Either a b
Left Char
'\t', forall a b. a -> Either a b
Left Char
' ']
spaces :: CharRange
spaces = [forall a b. b -> Either a b
Right (Char
'\t',Char
'\r'), forall a b. a -> Either a b
Left Char
' ']
ltell :: CharRange -> ExceptT String (Writer CharRange) ()
ltell = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell
optimize :: Pattern -> Pattern
optimize :: Pattern -> Pattern
optimize (Pattern [Token]
pat) =
[Token] -> Pattern
Pattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
fin forall a b. (a -> b) -> a -> b
$
case [Token]
pat of
Token
e : [Token]
ts | Token
e forall a. Eq a => a -> a -> Bool
== Token
ExtSeparator Bool -> Bool -> Bool
|| Token
e forall a. Eq a => a -> a -> Bool
== Char -> Token
Literal Char
'.' ->
forall {t :: * -> *}.
Foldable t =>
(t Token -> [Token]) -> t Token -> [Token]
checkUnmatchable (Char -> Token
Literal Char
'.' forall a. a -> [a] -> [a]
:) ([Token] -> [Token]
go [Token]
ts)
[Token]
_ ->
case [Token] -> [Token]
go [Token]
pat of
Literal Char
'.' : [Token]
_ -> [Token
Unmatchable]
[Token]
opat -> forall {t :: * -> *}.
Foldable t =>
(t Token -> [Token]) -> t Token -> [Token]
checkUnmatchable forall a. a -> a
id [Token]
opat
where
fin :: [Token] -> [Token]
fin [] = []
fin (Token
x:Token
y:[Token]
xs) | Just Char
x' <- Token -> Maybe Char
isCharLiteral Token
x, Just Char
y' <- Token -> Maybe Char
isCharLiteral Token
y =
let (String
ls,[Token]
rest) = forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe Token -> Maybe Char
isCharLiteral [Token]
xs
in [Token] -> [Token]
fin forall a b. (a -> b) -> a -> b
$ Int -> String -> Token
LongLiteral (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ls forall a. Num a => a -> a -> a
+ Int
2)
(forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
a -> (Char
aforall a. a -> [a] -> [a]
:)) [] (Char
x'forall a. a -> [a] -> [a]
:Char
y'forall a. a -> [a] -> [a]
:String
ls))
forall a. a -> [a] -> [a]
: [Token]
rest
fin (LongLiteral Int
l1 String
s1 : LongLiteral Int
l2 String
s2 : [Token]
xs) =
[Token] -> [Token]
fin forall a b. (a -> b) -> a -> b
$ Int -> String -> Token
LongLiteral (Int
l1forall a. Num a => a -> a -> a
+Int
l2) (String
s1forall a. [a] -> [a] -> [a]
++String
s2) forall a. a -> [a] -> [a]
: [Token]
xs
fin (LongLiteral Int
l String
s : Literal Char
c : [Token]
xs) =
[Token] -> [Token]
fin forall a b. (a -> b) -> a -> b
$ Int -> String -> Token
LongLiteral (Int
lforall a. Num a => a -> a -> a
+Int
1) (String
sforall a. [a] -> [a] -> [a]
++[Char
c]) forall a. a -> [a] -> [a]
: [Token]
xs
fin (LongLiteral Int
1 String
s : [Token]
xs) = Char -> Token
Literal (forall a. [a] -> a
head String
s) forall a. a -> [a] -> [a]
: [Token] -> [Token]
fin [Token]
xs
fin (Literal Char
c : LongLiteral Int
l String
s : [Token]
xs) =
[Token] -> [Token]
fin forall a b. (a -> b) -> a -> b
$ Int -> String -> Token
LongLiteral (Int
lforall a. Num a => a -> a -> a
+Int
1) (Char
cforall a. a -> [a] -> [a]
:String
s) forall a. a -> [a] -> [a]
: [Token]
xs
fin (Token
x:[Token]
xs) = Token
x forall a. a -> [a] -> [a]
: [Token] -> [Token]
fin [Token]
xs
go :: [Token] -> [Token]
go [] = []
go (p :: Token
p@Token
PathSeparator : Token
ExtSeparator : [Token]
xs) = Token
p forall a. a -> [a] -> [a]
: Char -> Token
Literal Char
'.' forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
go (Token
ExtSeparator : [Token]
xs) = Char -> Token
Literal Char
'.' forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
go (p :: Token
p@Token
PathSeparator : x :: Token
x@(CharRange Bool
_ CharRange
_) : [Token]
xs) =
Token
p forall a. a -> [a] -> [a]
: case Bool -> Token -> Token
optimizeCharRange Bool
True Token
x of
x' :: Token
x'@(CharRange Bool
_ CharRange
_) -> Token
x' forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
Literal Char
'.' -> [Token
Unmatchable]
Token
x' -> [Token] -> [Token]
go (Token
x'forall a. a -> [a] -> [a]
:[Token]
xs)
go (x :: Token
x@(CharRange Bool
_ CharRange
_) : [Token]
xs) =
case Bool -> Token -> Token
optimizeCharRange Bool
False Token
x of
x' :: Token
x'@(CharRange Bool
_ CharRange
_) -> Token
x' forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
Token
x' -> [Token] -> [Token]
go (Token
x'forall a. a -> [a] -> [a]
:[Token]
xs)
go (o :: Token
o@(OpenRange Maybe String
Nothing Maybe String
Nothing) : Token
d : [Token]
xs) | Token
d forall a. Eq a => a -> a -> Bool
== Token
anyDigit =
Token
d forall a. a -> [a] -> [a]
: [Token] -> [Token]
go (Token
o forall a. a -> [a] -> [a]
: [Token]
xs)
go (Token
x:[Token]
xs) =
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Token
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Token, Int -> [Token])]
compressables of
Just (Token
_, Int -> [Token]
f) -> let ([Token]
compressed,[Token]
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
== Token
x) [Token]
xs
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
compressed
then Token
x forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
ys
else Int -> [Token]
f (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Token]
compressed) forall a. [a] -> [a] -> [a]
++ [Token] -> [Token]
go (Token
x forall a. a -> [a] -> [a]
: [Token]
ys)
Maybe (Token, Int -> [Token])
Nothing -> Token
x forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
checkUnmatchable :: (t Token -> [Token]) -> t Token -> [Token]
checkUnmatchable t Token -> [Token]
f t Token
ts = if Token
Unmatchable forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Token
ts then [Token
Unmatchable] else t Token -> [Token]
f t Token
ts
compressables :: [(Token, Int -> [Token])]
compressables = [ (Token
AnyNonPathSeparator, forall a b. a -> b -> a
const [])
, (Token
AnyDirectory, forall a b. a -> b -> a
const [])
, (Maybe String -> Maybe String -> Token
OpenRange forall a. Maybe a
Nothing forall a. Maybe a
Nothing, \Int
n -> forall a. Int -> a -> [a]
replicate Int
n Token
anyDigit)
]
isCharLiteral :: Token -> Maybe Char
isCharLiteral (Literal Char
x) = forall a. a -> Maybe a
Just Char
x
isCharLiteral Token
_ = forall a. Maybe a
Nothing
anyDigit :: Token
anyDigit = Bool -> CharRange -> Token
CharRange Bool
True [forall a b. b -> Either a b
Right (Char
'0', Char
'9')]
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe :: forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe a -> Maybe b
f = [a] -> ([b], [a])
go
where
go :: [a] -> ([b], [a])
go xs :: [a]
xs@[] = ([], [a]
xs)
go xs :: [a]
xs@(a
x : [a]
xs') = case a -> Maybe b
f a
x of
Maybe b
Nothing -> ([], [a]
xs)
Just b
y -> let ([b]
ys, [a]
zs) = [a] -> ([b], [a])
go [a]
xs' in (b
y forall a. a -> [a] -> [a]
: [b]
ys, [a]
zs)
optimizeCharRange :: Bool -> Token -> Token
optimizeCharRange :: Bool -> Token -> Token
optimizeCharRange Bool
precededBySlash (CharRange Bool
b CharRange
rs) =
CharRange -> Token
fin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Eq b => [Either Char b] -> [Either Char b]
stripUnmatchable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
(Ord a, Enum a) =>
[Either a (a, a)] -> [Either a (a, a)]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharRange -> CharRange
sortCharRange forall a b. (a -> b) -> a -> b
$ CharRange
rs
where
fin :: CharRange -> Token
fin [Left Char
c] | Bool
b = if Char -> Bool
isPathSeparator Char
c then Token
Unmatchable else Char -> Token
Literal Char
c
fin [Right (Char, Char)
r] | Bool
b Bool -> Bool -> Bool
&& (Char, Char)
r forall a. Eq a => a -> a -> Bool
== (forall a. Bounded a => a
minBound,forall a. Bounded a => a
maxBound) = Token
NonPathSeparator
fin CharRange
x = Bool -> CharRange -> Token
CharRange Bool
b CharRange
x
stripUnmatchable :: [Either Char b] -> [Either Char b]
stripUnmatchable xs :: [Either Char b]
xs@(Either Char b
_:Either Char b
_:[Either Char b]
_) | Bool
b =
forall a. (a -> Bool) -> [a] -> [a]
filter (\Either Char b
x -> (Bool -> Bool
not Bool
precededBySlash Bool -> Bool -> Bool
|| Either Char b
x forall a. Eq a => a -> a -> Bool
/= forall a b. a -> Either a b
Left Char
'.') Bool -> Bool -> Bool
&& Either Char b
x forall a. Eq a => a -> a -> Bool
/= forall a b. a -> Either a b
Left Char
'/') [Either Char b]
xs
stripUnmatchable [Either Char b]
xs = [Either Char b]
xs
go :: [Either a (a, a)] -> [Either a (a, a)]
go [] = []
go (x :: Either a (a, a)
x@(Left a
c) : [Either a (a, a)]
xs) =
case [Either a (a, a)]
xs of
[] -> [Either a (a, a)
x]
y :: Either a (a, a)
y@(Left a
d) : [Either a (a, a)]
ys
| a
c forall a. Eq a => a -> a -> Bool
== a
d -> [Either a (a, a)] -> [Either a (a, a)]
goforall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left a
c forall a. a -> [a] -> [a]
: [Either a (a, a)]
ys
| a
d forall a. Eq a => a -> a -> Bool
== forall a. Enum a => a -> a
succ a
c ->
let ([Either a (a, a)]
ls,[Either a (a, a)]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span forall a b. Either a b -> Bool
isLeft [Either a (a, a)]
xs
([a]
catable,[a]
others) = forall a. (Eq a, Enum a) => [a] -> ([a], [a])
increasingSeq (forall a b. (a -> b) -> [a] -> [b]
map forall a b. Either a b -> a
fromLeft [Either a (a, a)]
ls)
range :: (a, a)
range = (a
c, forall a. [a] -> a
head [a]
catable)
in
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
catable Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. [a] -> [a]
tail [a]
catable)
then Either a (a, a)
x forall a. a -> [a] -> [a]
: Either a (a, a)
y forall a. a -> [a] -> [a]
: [Either a (a, a)] -> [Either a (a, a)]
go [Either a (a, a)]
ys
else [Either a (a, a)] -> [Either a (a, a)]
goforall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (a, a)
range forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left [a]
others forall a. [a] -> [a] -> [a]
++ [Either a (a, a)]
rest
| Bool
otherwise -> Either a (a, a)
x forall a. a -> [a] -> [a]
: [Either a (a, a)] -> [Either a (a, a)]
go [Either a (a, a)]
xs
Right (a, a)
r : [Either a (a, a)]
ys ->
case forall a. (Ord a, Enum a) => (a, a) -> a -> Maybe (a, a)
addToRange (a, a)
r a
c of
Just (a, a)
r' -> [Either a (a, a)] -> [Either a (a, a)]
goforall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (a, a)
r' forall a. a -> [a] -> [a]
: [Either a (a, a)]
ys
Maybe (a, a)
Nothing -> Either a (a, a)
x forall a. a -> [a] -> [a]
: [Either a (a, a)] -> [Either a (a, a)]
go [Either a (a, a)]
xs
go (x :: Either a (a, a)
x@(Right (a, a)
r) : [Either a (a, a)]
xs) =
case [Either a (a, a)]
xs of
[] -> [Either a (a, a)
x]
Left a
c : [Either a (a, a)]
ys ->
case forall a. (Ord a, Enum a) => (a, a) -> a -> Maybe (a, a)
addToRange (a, a)
r a
c of
Just (a, a)
r' -> [Either a (a, a)] -> [Either a (a, a)]
goforall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (a, a)
r' forall a. a -> [a] -> [a]
: [Either a (a, a)]
ys
Maybe (a, a)
Nothing -> Either a (a, a)
x forall a. a -> [a] -> [a]
: [Either a (a, a)] -> [Either a (a, a)]
go [Either a (a, a)]
xs
Right (a, a)
r' : [Either a (a, a)]
ys ->
case forall a. Ord a => (a, a) -> (a, a) -> Maybe (a, a)
overlap (a, a)
r (a, a)
r' of
Just (a, a)
o -> [Either a (a, a)] -> [Either a (a, a)]
goforall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (a, a)
o forall a. a -> [a] -> [a]
: [Either a (a, a)]
ys
Maybe (a, a)
Nothing -> Either a (a, a)
x forall a. a -> [a] -> [a]
: [Either a (a, a)] -> [Either a (a, a)]
go [Either a (a, a)]
xs
optimizeCharRange Bool
_ Token
_ = forall a. HasCallStack => String -> a
error String
"Glob.optimizeCharRange :: internal error"
sortCharRange :: [Either Char (Char,Char)] -> [Either Char (Char,Char)]
sortCharRange :: CharRange -> CharRange
sortCharRange = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {b} {b}.
Ord a =>
Either a (a, b) -> Either a (a, b) -> Ordering
cmp
where
cmp :: Either a (a, b) -> Either a (a, b) -> Ordering
cmp (Left a
a) (Left a
b) = forall a. Ord a => a -> a -> Ordering
compare a
a a
b
cmp (Left a
a) (Right (a
b,b
_)) = forall a. Ord a => a -> a -> Ordering
compare a
a a
b
cmp (Right (a
a,b
_)) (Left a
b) = forall a. Ord a => a -> a -> Ordering
compare a
a a
b
cmp (Right (a
a,b
_)) (Right (a
b,b
_)) = forall a. Ord a => a -> a -> Ordering
compare a
a a
b
isLiteral :: Pattern -> Bool
isLiteral :: Pattern -> Bool
isLiteral = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Token -> Bool
lit forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> [Token]
unPattern
where
lit :: Token -> Bool
lit (Literal Char
_) = Bool
True
lit (LongLiteral Int
_ String
_) = Bool
True
lit Token
PathSeparator = Bool
True
lit Token
_ = Bool
False