{-# LANGUAGE CPP #-}
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
import Data.Semigroup (Semigroup, (<>), sconcat, stimes)
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
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
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 c :: Char
c) = Char -> Token
Literal (Char -> Char
toLower Char
c)
tokToLower (LongLiteral n :: Int
n s :: String
s) = Int -> String -> Token
LongLiteral Int
n ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s)
tokToLower tok :: Token
tok = Token
tok
newtype Pattern = Pattern { Pattern -> [Token]
unPattern :: [Token] } deriving (Pattern -> Pattern -> Bool
(Pattern -> Pattern -> Bool)
-> (Pattern -> Pattern -> Bool) -> Eq Pattern
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 f :: [Token] -> [Token]
f (Pattern pat :: [Token]
pat) = [Token] -> Pattern
Pattern ([Token] -> [Token]
f [Token]
pat)
instance Show Token where
show :: Token -> String
show (Literal c :: Char
c)
| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "*?[<" = ['[',Char
c,']']
| Bool
otherwise = Bool -> String -> String
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isPathSeparator Char
c) [Char
c]
show ExtSeparator = [ Char
extSeparator]
show PathSeparator = [Char
pathSeparator]
show NonPathSeparator = "?"
show AnyNonPathSeparator = "*"
show AnyDirectory = "**/"
show (LongLiteral _ s :: String
s) = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Token -> String
forall a. Show a => a -> String
show (Token -> String) -> (Char -> Token) -> Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Token
Literal) String
s
show (OpenRange a :: Maybe String
a b :: Maybe String
b) =
'<' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" Maybe String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" Maybe String
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ ">"
show (CharRange b :: Bool
b r :: [Either Char (Char, Char)]
r) =
let f :: Either Char (Char, Char) -> String
f = (Char -> String)
-> ((Char, Char) -> String) -> Either Char (Char, Char) -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) (\(x :: Char
x,y :: Char
y) -> [Char
x,'-',Char
y])
(caret :: String
caret,exclamation :: String
exclamation,fs :: String -> String
fs) =
(Either Char (Char, Char)
-> (String, String, String -> String)
-> (String, String, String -> String))
-> (String, String, String -> String)
-> [Either Char (Char, Char)]
-> (String, String, String -> String)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\c :: Either Char (Char, Char)
c (ca :: String
ca,ex :: String
ex,ss :: String -> String
ss) ->
case Either Char (Char, Char)
c of
Left '^' -> ("^",String
ex,String -> String
ss)
Left '!' -> (String
ca,"!",String -> String
ss)
_ -> (String
ca, String
ex,(Either Char (Char, Char) -> String
f Either Char (Char, Char)
c String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
ss)
)
("", "", String -> String
forall a. a -> a
id)
[Either Char (Char, Char)]
r
(beg :: String
beg,rest :: String
rest) = let s' :: String
s' = String -> String
fs []
(x :: String
x,y :: String
y) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt 1 String
s'
in if Bool -> Bool
not Bool
b Bool -> Bool -> Bool
&& String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "-"
then (String
y,String
x)
else (String
s',"")
in [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ "["
, if Bool
b then "" else "^"
, if Bool
b Bool -> Bool -> Bool
&& String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
beg Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
caret Bool -> Bool -> Bool
&& String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
exclamation) then "/" else ""
, String
beg, String
caret, String
exclamation, String
rest
, "]"
]
show Unmatchable = "[.]"
instance Show Pattern where
showsPrec :: Int -> Pattern -> String -> String
showsPrec d :: Int
d p :: Pattern
p = Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
String -> String -> String
showString "compile " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Pattern -> String
decompile Pattern
p)
instance Read Pattern where
#if __GLASGOW_HASKELL__
readPrec :: ReadPrec Pattern
readPrec = ReadPrec Pattern -> ReadPrec Pattern
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec Pattern -> ReadPrec Pattern)
-> (ReadPrec Pattern -> ReadPrec Pattern)
-> ReadPrec Pattern
-> ReadPrec Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ReadPrec Pattern -> ReadPrec Pattern
forall a. Int -> ReadPrec a -> ReadPrec a
prec 10 (ReadPrec Pattern -> ReadPrec Pattern)
-> ReadPrec Pattern -> ReadPrec Pattern
forall a b. (a -> b) -> a -> b
$ do
Ident "compile" <- ReadPrec Lexeme
lexP
(String -> Pattern) -> ReadPrec String -> ReadPrec Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Pattern
compile ReadPrec String
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 a :: [Token]
a <> :: Pattern -> Pattern -> Pattern
<> Pattern b :: [Token]
b = Pattern -> Pattern
optimize (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [Token] -> Pattern
Pattern ([Token]
a [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> [Token]
b)
sconcat :: NonEmpty Pattern -> Pattern
sconcat = Pattern -> Pattern
optimize (Pattern -> Pattern)
-> (NonEmpty Pattern -> Pattern) -> NonEmpty Pattern -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Pattern
Pattern ([Token] -> Pattern)
-> (NonEmpty Pattern -> [Token]) -> NonEmpty Pattern -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> [Token]) -> [Pattern] -> [Token]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pattern -> [Token]
unPattern ([Pattern] -> [Token])
-> (NonEmpty Pattern -> [Pattern]) -> NonEmpty Pattern -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Pattern -> [Pattern]
forall a. NonEmpty a -> [a]
toList
stimes :: b -> Pattern -> Pattern
stimes n :: b
n (Pattern a :: [Token]
a) = Pattern -> Pattern
optimize (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [Token] -> Pattern
Pattern (b -> [Token] -> [Token]
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 = Pattern -> Pattern -> Pattern
forall a. Semigroup a => a -> a -> a
(<>)
mconcat :: [Pattern] -> Pattern
mconcat = Pattern -> Pattern
optimize (Pattern -> Pattern)
-> ([Pattern] -> Pattern) -> [Pattern] -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Pattern
Pattern ([Token] -> Pattern)
-> ([Pattern] -> [Token]) -> [Pattern] -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> [Token]) -> [Pattern] -> [Token]
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 -> String -> String
[CompOptions] -> String -> String
CompOptions -> String
(Int -> CompOptions -> String -> String)
-> (CompOptions -> String)
-> ([CompOptions] -> String -> String)
-> Show CompOptions
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CompOptions] -> String -> String
$cshowList :: [CompOptions] -> String -> String
show :: CompOptions -> String
$cshow :: CompOptions -> String
showsPrec :: Int -> CompOptions -> String -> String
$cshowsPrec :: Int -> CompOptions -> String -> String
Show,ReadPrec [CompOptions]
ReadPrec CompOptions
Int -> ReadS CompOptions
ReadS [CompOptions]
(Int -> ReadS CompOptions)
-> ReadS [CompOptions]
-> ReadPrec CompOptions
-> ReadPrec [CompOptions]
-> Read 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
(CompOptions -> CompOptions -> Bool)
-> (CompOptions -> CompOptions -> Bool) -> Eq CompOptions
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 :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> CompOptions
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 :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> CompOptions
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 :: Bool -> Bool -> Bool -> MatchOptions
MatchOptions
{ matchDotsImplicitly :: Bool
matchDotsImplicitly = Bool
False
, ignoreCase :: Bool
ignoreCase = Bool
False
, ignoreDotSlash :: Bool
ignoreDotSlash = Bool
True
}
decompile :: Pattern -> String
decompile :: Pattern -> String
decompile = (Token -> String) -> [Token] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Token -> String
forall a. Show a => a -> String
show ([Token] -> String) -> (Pattern -> [Token]) -> Pattern -> String
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 opts :: CompOptions
opts = (String -> Pattern)
-> (Pattern -> Pattern) -> Either String Pattern -> Pattern
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Pattern
forall a. (?callStack::CallStack) => String -> a
error Pattern -> Pattern
forall a. a -> a
id (Either String Pattern -> Pattern)
-> (String -> Either String Pattern) -> String -> Pattern
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 opts :: CompOptions
opts = (Pattern -> Pattern)
-> Either String Pattern -> Either String Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pattern -> Pattern
optimize (Either String Pattern -> Either String Pattern)
-> (String -> Either String Pattern)
-> String
-> Either String Pattern
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 opts :: CompOptions
opts = ([Token] -> Pattern)
-> Either String [Token] -> Either String Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Token] -> Pattern
Pattern (Either String [Token] -> Either String Pattern)
-> (String -> Either String [Token])
-> String
-> Either String Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String Token] -> Either String [Token]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Either String Token] -> Either String [Token])
-> (String -> [Either String Token])
-> String
-> Either String [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Either String Token]
go
where
err :: String -> Char -> String -> [Either String Token]
err _ c :: Char
c cs :: String
cs | CompOptions -> Bool
errorRecovery CompOptions
opts = Token -> Either String Token
forall a b. b -> Either a b
Right (Char -> Token
Literal Char
c) Either String Token
-> [Either String Token] -> [Either String Token]
forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
err s :: String
s _ _ = [String -> Either String Token
forall a b. a -> Either a b
Left String
s]
go :: String -> [Either String Token]
go :: String -> [Either String Token]
go [] = []
go ('?':cs :: String
cs) | Bool
wcs = Token -> Either String Token
forall a b. b -> Either a b
Right Token
NonPathSeparator Either String Token
-> [Either String Token] -> [Either String Token]
forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
go ('*':cs :: String
cs) | Bool
wcs =
case String
cs of
'*':p :: Char
p:xs :: String
xs | Bool
rwcs Bool -> Bool -> Bool
&& Char -> Bool
isPathSeparator Char
p
-> Token -> Either String Token
forall a b. b -> Either a b
Right Token
AnyDirectory Either String Token
-> [Either String Token] -> [Either String Token]
forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
xs
_ -> Token -> Either String Token
forall a b. b -> Either a b
Right Token
AnyNonPathSeparator Either String Token
-> [Either String Token] -> [Either String Token]
forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
go ('[':cs :: String
cs) | Bool
crs = let (range :: Either String Token
range,rest :: String
rest) = CompOptions -> String -> (Either String Token, String)
charRange CompOptions
opts String
cs
in case Either String Token
range of
Left s :: String
s -> String -> Char -> String -> [Either String Token]
err String
s '[' String
cs
r :: Either String Token
r -> Either String Token
r Either String Token
-> [Either String Token] -> [Either String Token]
forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
rest
go ('<':cs :: String
cs) | Bool
ors =
let (range :: String
range, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='>') String
cs
in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest
then String -> Char -> String -> [Either String Token]
err "compile :: unclosed <> in pattern" '<' String
cs
else case String -> Either String Token
openRange String
range of
Left s :: String
s -> String -> Char -> String -> [Either String Token]
err String
s '<' String
cs
r :: Either String Token
r -> Either String Token
r Either String Token
-> [Either String Token] -> [Either String Token]
forall a. a -> [a] -> [a]
: String -> [Either String Token]
go (String -> String
forall a. [a] -> [a]
tail String
rest)
go (c :: Char
c:cs :: String
cs)
| Char -> Bool
isPathSeparator Char
c = Token -> Either String Token
forall a b. b -> Either a b
Right Token
PathSeparator Either String Token
-> [Either String Token] -> [Either String Token]
forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
| Char -> Bool
isExtSeparator Char
c = Token -> Either String Token
forall a b. b -> Either a b
Right Token
ExtSeparator Either String Token
-> [Either String Token] -> [Either String Token]
forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
cs
| Bool
otherwise = Token -> Either String Token
forall a b. b -> Either a b
Right (Char -> Token
Literal Char
c) Either String Token
-> [Either String Token] -> [Either String Token]
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 ['-'] = Token -> Either String Token
forall a b. b -> Either a b
Right (Token -> Either String Token) -> Token -> Either String Token
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> Token
OpenRange Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
openRange ('-':s :: String
s) =
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s of
(b :: String
b,"") -> Token -> Either String Token
forall a b. b -> Either a b
Right (Token -> Either String Token) -> Token -> Either String Token
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> Token
OpenRange Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
openRangeNum String
b)
_ -> String -> Either String Token
forall a b. a -> Either a b
Left (String -> Either String Token) -> String -> Either String Token
forall a b. (a -> b) -> a -> b
$ "compile :: bad <>, expected number, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
openRange s :: String
s =
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s of
(a :: String
a,"-") -> Token -> Either String Token
forall a b. b -> Either a b
Right (Token -> Either String Token) -> Token -> Either String Token
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> Token
OpenRange (String -> Maybe String
openRangeNum String
a) Maybe String
forall a. Maybe a
Nothing
(a :: String
a,'-':s' :: String
s') ->
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s' of
(b :: String
b,"") -> Token -> Either String Token
forall a b. b -> Either a b
Right (Token -> Either String Token) -> Token -> Either String Token
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 -> Either String Token
forall a b. a -> Either a b
Left (String -> Either String Token) -> String -> Either String Token
forall a b. (a -> b) -> a -> b
$ "compile :: bad <>, expected number, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s'
_ -> String -> Either String Token
forall a b. a -> Either a b
Left (String -> Either String Token) -> String -> Either String Token
forall a b. (a -> b) -> a -> b
$ "compile :: bad <>, expected number followed by - in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
openRangeNum :: String -> Maybe String
openRangeNum :: String -> Maybe String
openRangeNum = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropLeadingZeroes
type CharRange = [Either Char (Char,Char)]
charRange :: CompOptions -> String -> (Either String Token, String)
charRange :: CompOptions -> String -> (Either String Token, String)
charRange opts :: CompOptions
opts zs :: String
zs =
case String
zs of
y :: Char
y:ys :: String
ys | Char
y Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "^!" ->
case String
ys of
'-':']':xs :: String
xs -> (Token -> Either String Token
forall a b. b -> Either a b
Right (Bool -> [Either Char (Char, Char)] -> Token
CharRange Bool
False [Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left '-']), String
xs)
'-' :_ -> (Either String [Either Char (Char, Char)] -> Either String Token)
-> (Either String [Either Char (Char, Char)], String)
-> (Either String Token, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([Either Char (Char, Char)] -> Token)
-> Either String [Either Char (Char, Char)] -> Either String Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> [Either Char (Char, Char)] -> Token
CharRange Bool
True )) (String -> (Either String [Either Char (Char, Char)], String)
start String
zs)
xs :: String
xs -> (Either String [Either Char (Char, Char)] -> Either String Token)
-> (Either String [Either Char (Char, Char)], String)
-> (Either String Token, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([Either Char (Char, Char)] -> Token)
-> Either String [Either Char (Char, Char)] -> Either String Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> [Either Char (Char, Char)] -> Token
CharRange Bool
False)) (String -> (Either String [Either Char (Char, Char)], String)
start String
xs)
_ -> (Either String [Either Char (Char, Char)] -> Either String Token)
-> (Either String [Either Char (Char, Char)], String)
-> (Either String Token, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([Either Char (Char, Char)] -> Token)
-> Either String [Either Char (Char, Char)] -> Either String Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> [Either Char (Char, Char)] -> Token
CharRange Bool
True )) (String -> (Either String [Either Char (Char, Char)], String)
start String
zs)
where
start :: String -> (Either String CharRange, String)
start :: String -> (Either String [Either Char (Char, Char)], String)
start (']':xs :: String
xs) = ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String)
run (ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String))
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String)
forall a b. (a -> b) -> a -> b
$ Char
-> String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
char ']' String
xs
start ('-':xs :: String
xs) = ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String)
run (ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String))
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String)
forall a b. (a -> b) -> a -> b
$ Char
-> String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
char '-' String
xs
start xs :: String
xs = ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String)
run (ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String))
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String)
forall a b. (a -> b) -> a -> b
$ String -> ExceptT String (Writer [Either Char (Char, Char)]) String
go String
xs
run :: ExceptT String (Writer CharRange) String
-> (Either String CharRange, String)
run :: ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String [Either Char (Char, Char)], String)
run m :: ExceptT String (Writer [Either Char (Char, Char)]) String
m = case Writer [Either Char (Char, Char)] (Either String String)
-> (Either String String, [Either Char (Char, Char)])
forall w a. Writer w a -> (a, w)
runWriter(Writer [Either Char (Char, Char)] (Either String String)
-> (Either String String, [Either Char (Char, Char)]))
-> (ExceptT String (Writer [Either Char (Char, Char)]) String
-> Writer [Either Char (Char, Char)] (Either String String))
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String String, [Either Char (Char, Char)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ExceptT String (Writer [Either Char (Char, Char)]) String
-> Writer [Either Char (Char, Char)] (Either String String)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String String, [Either Char (Char, Char)]))
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> (Either String String, [Either Char (Char, Char)])
forall a b. (a -> b) -> a -> b
$ ExceptT String (Writer [Either Char (Char, Char)]) String
m of
(Left err :: String
err, _) -> (String -> Either String [Either Char (Char, Char)]
forall a b. a -> Either a b
Left String
err, [])
(Right rest :: String
rest, cs :: [Either Char (Char, Char)]
cs) -> ([Either Char (Char, Char)]
-> Either String [Either Char (Char, Char)]
forall a b. b -> Either a b
Right [Either Char (Char, Char)]
cs, String
rest)
go :: String -> ExceptT String (Writer CharRange) String
go :: String -> ExceptT String (Writer [Either Char (Char, Char)]) String
go ('[':':':xs :: String
xs) | CompOptions -> Bool
characterClasses CompOptions
opts = String -> ExceptT String (Writer [Either Char (Char, Char)]) String
readClass String
xs
go ( ']':xs :: String
xs) = String -> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
xs
go ( c :: Char
c:xs :: String
xs) =
if Bool -> Bool
not (CompOptions -> Bool
pathSepInRanges CompOptions
opts) Bool -> Bool -> Bool
&& Char -> Bool
isPathSeparator Char
c
then String -> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE "compile :: path separator within []"
else Char
-> String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
char Char
c String
xs
go [] = String -> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE "compile :: unclosed [] in pattern"
char :: Char -> String -> ExceptT String (Writer CharRange) String
char :: Char
-> String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
char c :: Char
c ('-':x :: Char
x:xs :: String
xs) =
if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ']'
then [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left Char
c, Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left '-'] ExceptT String (Writer [Either Char (Char, Char)]) ()
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
xs
else [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [(Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right (Char
c,Char
x)] ExceptT String (Writer [Either Char (Char, Char)]) ()
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ExceptT String (Writer [Either Char (Char, Char)]) String
go String
xs
char c :: Char
c xs :: String
xs = [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left Char
c] ExceptT String (Writer [Either Char (Char, Char)]) ()
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ExceptT String (Writer [Either Char (Char, Char)]) String
go String
xs
readClass :: String -> ExceptT String (Writer CharRange) String
readClass :: String -> ExceptT String (Writer [Either Char (Char, Char)]) String
readClass xs :: String
xs = let (name :: String
name,end :: String
end) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlpha String
xs
in case String
end of
':':']':rest :: String
rest -> String -> ExceptT String (Writer [Either Char (Char, Char)]) ()
charClass String
name ExceptT String (Writer [Either Char (Char, Char)]) ()
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ExceptT String (Writer [Either Char (Char, Char)]) String
go String
rest
_ -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left '[',Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left ':'] ExceptT String (Writer [Either Char (Char, Char)]) ()
-> ExceptT String (Writer [Either Char (Char, Char)]) String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ExceptT String (Writer [Either Char (Char, Char)]) String
go String
xs
charClass :: String -> ExceptT String (Writer CharRange) ()
charClass :: String -> ExceptT String (Writer [Either Char (Char, Char)]) ()
charClass name :: String
name =
case String
name of
"alnum" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)
forall a. Either a (Char, Char)
digit,Either Char (Char, Char)
forall a. Either a (Char, Char)
upper,Either Char (Char, Char)
forall a. Either a (Char, Char)
lower]
"alpha" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)
forall a. Either a (Char, Char)
upper,Either Char (Char, Char)
forall a. Either a (Char, Char)
lower]
"blank" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)]
forall b. [Either Char b]
blanks
"cntrl" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [(Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right ('\0','\x1f'), Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left '\x7f']
"digit" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)
forall a. Either a (Char, Char)
digit]
"graph" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [(Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right ('!','~')]
"lower" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)
forall a. Either a (Char, Char)
lower]
"print" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [(Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right (' ','~')]
"punct" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)]
forall a. [Either a (Char, Char)]
punct
"space" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)]
spaces
"upper" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)
forall a. Either a (Char, Char)
upper]
"xdigit" -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)
forall a. Either a (Char, Char)
digit, (Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right ('A','F'), (Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right ('a','f')]
_ ->
String -> ExceptT String (Writer [Either Char (Char, Char)]) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ("compile :: unknown character class '" String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++ "'")
digit :: Either a (Char, Char)
digit = (Char, Char) -> Either a (Char, Char)
forall a b. b -> Either a b
Right ('0','9')
upper :: Either a (Char, Char)
upper = (Char, Char) -> Either a (Char, Char)
forall a b. b -> Either a b
Right ('A','Z')
lower :: Either a (Char, Char)
lower = (Char, Char) -> Either a (Char, Char)
forall a b. b -> Either a b
Right ('a','z')
punct :: [Either a (Char, Char)]
punct = ((Char, Char) -> Either a (Char, Char))
-> [(Char, Char)] -> [Either a (Char, Char)]
forall a b. (a -> b) -> [a] -> [b]
map (Char, Char) -> Either a (Char, Char)
forall a b. b -> Either a b
Right [('!','/'), (':','@'), ('[','`'), ('{','~')]
blanks :: [Either Char b]
blanks = [Char -> Either Char b
forall a b. a -> Either a b
Left '\t', Char -> Either Char b
forall a b. a -> Either a b
Left ' ']
spaces :: [Either Char (Char, Char)]
spaces = [(Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right ('\t','\r'), Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left ' ']
ltell :: [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell = WriterT [Either Char (Char, Char)] Identity ()
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [Either Char (Char, Char)] Identity ()
-> ExceptT String (Writer [Either Char (Char, Char)]) ())
-> ([Either Char (Char, Char)]
-> WriterT [Either Char (Char, Char)] Identity ())
-> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Char (Char, Char)]
-> WriterT [Either Char (Char, Char)] Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell
optimize :: Pattern -> Pattern
optimize :: Pattern -> Pattern
optimize (Pattern pat :: [Token]
pat) =
[Token] -> Pattern
Pattern ([Token] -> Pattern) -> ([Token] -> [Token]) -> [Token] -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
fin ([Token] -> Pattern) -> [Token] -> Pattern
forall a b. (a -> b) -> a -> b
$
case [Token]
pat of
e :: Token
e : ts :: [Token]
ts | Token
e Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
ExtSeparator Bool -> Bool -> Bool
|| Token
e Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Token
Literal '.' ->
([Token] -> [Token]) -> [Token] -> [Token]
forall (t :: * -> *).
Foldable t =>
(t Token -> [Token]) -> t Token -> [Token]
checkUnmatchable (Char -> Token
Literal '.' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:) ([Token] -> [Token]
go [Token]
ts)
_ ->
case [Token] -> [Token]
go [Token]
pat of
Literal '.' : _ -> [Token
Unmatchable]
opat :: [Token]
opat -> ([Token] -> [Token]) -> [Token] -> [Token]
forall (t :: * -> *).
Foldable t =>
(t Token -> [Token]) -> t Token -> [Token]
checkUnmatchable [Token] -> [Token]
forall a. a -> a
id [Token]
opat
where
fin :: [Token] -> [Token]
fin [] = []
fin (x :: Token
x:y :: Token
y:xs :: [Token]
xs) | Token -> Bool
isCharLiteral Token
x Bool -> Bool -> Bool
&& Token -> Bool
isCharLiteral Token
y =
let (ls :: [Token]
ls,rest :: [Token]
rest) = (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Token -> Bool
isCharLiteral [Token]
xs
in [Token] -> [Token]
fin ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Int -> String -> Token
LongLiteral ([Token] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Token]
ls Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2)
((Token -> String -> String) -> String -> [Token] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Literal a :: Char
a) -> (Char
aChar -> String -> String
forall a. a -> [a] -> [a]
:)) [] (Token
xToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:Token
yToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
ls))
Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
rest
fin (LongLiteral l1 :: Int
l1 s1 :: String
s1 : LongLiteral l2 :: Int
l2 s2 :: String
s2 : xs :: [Token]
xs) =
[Token] -> [Token]
fin ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Int -> String -> Token
LongLiteral (Int
l1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
l2) (String
s1String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s2) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
xs
fin (LongLiteral l :: Int
l s :: String
s : Literal c :: Char
c : xs :: [Token]
xs) =
[Token] -> [Token]
fin ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Int -> String -> Token
LongLiteral (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
c]) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
xs
fin (LongLiteral 1 s :: String
s : xs :: [Token]
xs) = Char -> Token
Literal (String -> Char
forall a. [a] -> a
head String
s) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
fin [Token]
xs
fin (Literal c :: Char
c : LongLiteral l :: Int
l s :: String
s : xs :: [Token]
xs) =
[Token] -> [Token]
fin ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Int -> String -> Token
LongLiteral (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
xs
fin (x :: Token
x:xs :: [Token]
xs) = Token
x Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
fin [Token]
xs
go :: [Token] -> [Token]
go [] = []
go (p :: Token
p@Token
PathSeparator : ExtSeparator : xs :: [Token]
xs) = Token
p Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Char -> Token
Literal '.' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
go (ExtSeparator : xs :: [Token]
xs) = Char -> Token
Literal '.' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
go (p :: Token
p@Token
PathSeparator : x :: Token
x@(CharRange _ _) : xs :: [Token]
xs) =
Token
p Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: case Bool -> Token -> Token
optimizeCharRange Bool
True Token
x of
x' :: Token
x'@(CharRange _ _) -> Token
x' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
Literal '.' -> [Token
Unmatchable]
x' :: Token
x' -> [Token] -> [Token]
go (Token
x'Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
xs)
go (x :: Token
x@(CharRange _ _) : xs :: [Token]
xs) =
case Bool -> Token -> Token
optimizeCharRange Bool
False Token
x of
x' :: Token
x'@(CharRange _ _) -> Token
x' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
x' :: Token
x' -> [Token] -> [Token]
go (Token
x'Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
xs)
go (o :: Token
o@(OpenRange Nothing Nothing) : d :: Token
d : xs :: [Token]
xs) | Token
d Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
anyDigit =
Token
d Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go (Token
o Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
xs)
go (x :: Token
x:xs :: [Token]
xs) =
case ((Token, Int -> [Token]) -> Bool)
-> [(Token, Int -> [Token])] -> Maybe (Token, Int -> [Token])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
x) (Token -> Bool)
-> ((Token, Int -> [Token]) -> Token)
-> (Token, Int -> [Token])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token, Int -> [Token]) -> Token
forall a b. (a, b) -> a
fst) [(Token, Int -> [Token])]
compressables of
Just (_, f :: Int -> [Token]
f) -> let (compressed :: [Token]
compressed,ys :: [Token]
ys) = (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
x) [Token]
xs
in if [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
compressed
then Token
x Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
ys
else Int -> [Token]
f ([Token] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Token]
compressed) [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token] -> [Token]
go (Token
x Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
ys)
Nothing -> Token
x Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
checkUnmatchable :: (t Token -> [Token]) -> t Token -> [Token]
checkUnmatchable f :: t Token -> [Token]
f ts :: t Token
ts = if Token
Unmatchable Token -> t Token -> Bool
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, [Token] -> Int -> [Token]
forall a b. a -> b -> a
const [])
, (Token
AnyDirectory, [Token] -> Int -> [Token]
forall a b. a -> b -> a
const [])
, (Maybe String -> Maybe String -> Token
OpenRange Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing, \n :: Int
n -> Int -> Token -> [Token]
forall a. Int -> a -> [a]
replicate Int
n Token
anyDigit)
]
isCharLiteral :: Token -> Bool
isCharLiteral (Literal _) = Bool
True
isCharLiteral _ = Bool
False
anyDigit :: Token
anyDigit = Bool -> [Either Char (Char, Char)] -> Token
CharRange Bool
True [(Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right ('0', '9')]
optimizeCharRange :: Bool -> Token -> Token
optimizeCharRange :: Bool -> Token -> Token
optimizeCharRange precededBySlash :: Bool
precededBySlash (CharRange b :: Bool
b rs :: [Either Char (Char, Char)]
rs) =
[Either Char (Char, Char)] -> Token
fin ([Either Char (Char, Char)] -> Token)
-> ([Either Char (Char, Char)] -> [Either Char (Char, Char)])
-> [Either Char (Char, Char)]
-> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Char (Char, Char)] -> [Either Char (Char, Char)]
forall b. Eq b => [Either Char b] -> [Either Char b]
stripUnmatchable ([Either Char (Char, Char)] -> [Either Char (Char, Char)])
-> ([Either Char (Char, Char)] -> [Either Char (Char, Char)])
-> [Either Char (Char, Char)]
-> [Either Char (Char, Char)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Char (Char, Char)] -> [Either Char (Char, Char)]
forall a. (Ord a, Enum a) => [Either a (a, a)] -> [Either a (a, a)]
go ([Either Char (Char, Char)] -> [Either Char (Char, Char)])
-> ([Either Char (Char, Char)] -> [Either Char (Char, Char)])
-> [Either Char (Char, Char)]
-> [Either Char (Char, Char)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Char (Char, Char)] -> [Either Char (Char, Char)]
sortCharRange ([Either Char (Char, Char)] -> Token)
-> [Either Char (Char, Char)] -> Token
forall a b. (a -> b) -> a -> b
$ [Either Char (Char, Char)]
rs
where
fin :: [Either Char (Char, Char)] -> Token
fin [Left c :: Char
c] | Bool
b = if Char -> Bool
isPathSeparator Char
c then Token
Unmatchable else Char -> Token
Literal Char
c
fin [Right r :: (Char, Char)
r] | Bool
b Bool -> Bool -> Bool
&& (Char, Char)
r (Char, Char) -> (Char, Char) -> Bool
forall a. Eq a => a -> a -> Bool
== (Char
forall a. Bounded a => a
minBound,Char
forall a. Bounded a => a
maxBound) = Token
NonPathSeparator
fin x :: [Either Char (Char, Char)]
x = Bool -> [Either Char (Char, Char)] -> Token
CharRange Bool
b [Either Char (Char, Char)]
x
stripUnmatchable :: [Either Char b] -> [Either Char b]
stripUnmatchable xs :: [Either Char b]
xs@(_:_:_) | Bool
b =
(Either Char b -> Bool) -> [Either Char b] -> [Either Char b]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: Either Char b
x -> (Bool -> Bool
not Bool
precededBySlash Bool -> Bool -> Bool
|| Either Char b
x Either Char b -> Either Char b -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Either Char b
forall a b. a -> Either a b
Left '.') Bool -> Bool -> Bool
&& Either Char b
x Either Char b -> Either Char b -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Either Char b
forall a b. a -> Either a b
Left '/') [Either Char b]
xs
stripUnmatchable xs :: [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 c :: a
c) : xs :: [Either a (a, a)]
xs) =
case [Either a (a, a)]
xs of
[] -> [Either a (a, a)
x]
y :: Either a (a, a)
y@(Left d :: a
d) : ys :: [Either a (a, a)]
ys
| a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
d -> [Either a (a, a)] -> [Either a (a, a)]
go([Either a (a, a)] -> [Either a (a, a)])
-> [Either a (a, a)] -> [Either a (a, a)]
forall a b. (a -> b) -> a -> b
$ a -> Either a (a, a)
forall a b. a -> Either a b
Left a
c Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
forall a. a -> [a] -> [a]
: [Either a (a, a)]
ys
| a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
forall a. Enum a => a -> a
succ a
c ->
let (ls :: [Either a (a, a)]
ls,rest :: [Either a (a, a)]
rest) = (Either a (a, a) -> Bool)
-> [Either a (a, a)] -> ([Either a (a, a)], [Either a (a, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Either a (a, a) -> Bool
forall a b. Either a b -> Bool
isLeft [Either a (a, a)]
xs
(catable :: [a]
catable,others :: [a]
others) = [a] -> ([a], [a])
forall a. (Eq a, Enum a) => [a] -> ([a], [a])
increasingSeq ((Either a (a, a) -> a) -> [Either a (a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Either a (a, a) -> a
forall a b. Either a b -> a
fromLeft [Either a (a, a)]
ls)
range :: (a, a)
range = (a
c, [a] -> a
forall a. [a] -> a
head [a]
catable)
in
if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
catable Bool -> Bool -> Bool
|| [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> [a]
forall a. [a] -> [a]
tail [a]
catable)
then Either a (a, a)
x Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
forall a. a -> [a] -> [a]
: Either a (a, a)
y Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
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)]
go([Either a (a, a)] -> [Either a (a, a)])
-> [Either a (a, a)] -> [Either a (a, a)]
forall a b. (a -> b) -> a -> b
$ (a, a) -> Either a (a, a)
forall a b. b -> Either a b
Right (a, a)
range Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
forall a. a -> [a] -> [a]
: (a -> Either a (a, a)) -> [a] -> [Either a (a, a)]
forall a b. (a -> b) -> [a] -> [b]
map a -> Either a (a, a)
forall a b. a -> Either a b
Left [a]
others [Either a (a, a)] -> [Either a (a, a)] -> [Either a (a, a)]
forall a. [a] -> [a] -> [a]
++ [Either a (a, a)]
rest
| Bool
otherwise -> Either a (a, a)
x Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
forall a. a -> [a] -> [a]
: [Either a (a, a)] -> [Either a (a, a)]
go [Either a (a, a)]
xs
Right r :: (a, a)
r : ys :: [Either a (a, a)]
ys ->
case (a, a) -> a -> Maybe (a, a)
forall a. (Ord a, Enum a) => (a, a) -> a -> Maybe (a, a)
addToRange (a, a)
r a
c of
Just r' :: (a, a)
r' -> [Either a (a, a)] -> [Either a (a, a)]
go([Either a (a, a)] -> [Either a (a, a)])
-> [Either a (a, a)] -> [Either a (a, a)]
forall a b. (a -> b) -> a -> b
$ (a, a) -> Either a (a, a)
forall a b. b -> Either a b
Right (a, a)
r' Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
forall a. a -> [a] -> [a]
: [Either a (a, a)]
ys
Nothing -> Either a (a, a)
x Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
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 r :: (a, a)
r) : xs :: [Either a (a, a)]
xs) =
case [Either a (a, a)]
xs of
[] -> [Either a (a, a)
x]
Left c :: a
c : ys :: [Either a (a, a)]
ys ->
case (a, a) -> a -> Maybe (a, a)
forall a. (Ord a, Enum a) => (a, a) -> a -> Maybe (a, a)
addToRange (a, a)
r a
c of
Just r' :: (a, a)
r' -> [Either a (a, a)] -> [Either a (a, a)]
go([Either a (a, a)] -> [Either a (a, a)])
-> [Either a (a, a)] -> [Either a (a, a)]
forall a b. (a -> b) -> a -> b
$ (a, a) -> Either a (a, a)
forall a b. b -> Either a b
Right (a, a)
r' Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
forall a. a -> [a] -> [a]
: [Either a (a, a)]
ys
Nothing -> Either a (a, a)
x Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
forall a. a -> [a] -> [a]
: [Either a (a, a)] -> [Either a (a, a)]
go [Either a (a, a)]
xs
Right r' :: (a, a)
r' : ys :: [Either a (a, a)]
ys ->
case (a, a) -> (a, a) -> Maybe (a, a)
forall a. Ord a => (a, a) -> (a, a) -> Maybe (a, a)
overlap (a, a)
r (a, a)
r' of
Just o :: (a, a)
o -> [Either a (a, a)] -> [Either a (a, a)]
go([Either a (a, a)] -> [Either a (a, a)])
-> [Either a (a, a)] -> [Either a (a, a)]
forall a b. (a -> b) -> a -> b
$ (a, a) -> Either a (a, a)
forall a b. b -> Either a b
Right (a, a)
o Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
forall a. a -> [a] -> [a]
: [Either a (a, a)]
ys
Nothing -> Either a (a, a)
x Either a (a, a) -> [Either a (a, a)] -> [Either a (a, a)]
forall a. a -> [a] -> [a]
: [Either a (a, a)] -> [Either a (a, a)]
go [Either a (a, a)]
xs
optimizeCharRange _ _ = String -> Token
forall a. (?callStack::CallStack) => String -> a
error "Glob.optimizeCharRange :: internal error"
sortCharRange :: [Either Char (Char,Char)] -> [Either Char (Char,Char)]
sortCharRange :: [Either Char (Char, Char)] -> [Either Char (Char, Char)]
sortCharRange = (Either Char (Char, Char) -> Either Char (Char, Char) -> Ordering)
-> [Either Char (Char, Char)] -> [Either Char (Char, Char)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Either Char (Char, Char) -> Either Char (Char, Char) -> Ordering
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
a) (Left b :: a
b) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
cmp (Left a :: a
a) (Right (b :: a
b,_)) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
cmp (Right (a :: a
a,_)) (Left b :: a
b) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
cmp (Right (a :: a
a,_)) (Right (b :: a
b,_)) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
isLiteral :: Pattern -> Bool
isLiteral :: Pattern -> Bool
isLiteral = (Token -> Bool) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Token -> Bool
lit ([Token] -> Bool) -> (Pattern -> [Token]) -> Pattern -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> [Token]
unPattern
where
lit :: Token -> Bool
lit (Literal _) = Bool
True
lit (LongLiteral _ _) = Bool
True
lit PathSeparator = Bool
True
lit _ = Bool
False