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


{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}

module System.FilePath.Glob.Base
   ( Token(..), Pattern(..)

   , CompOptions(..), MatchOptions(..)
   , compDefault, compPosix, matchDefault, matchPosix

   , decompile

   , compile
   , compileWith, tryCompileWith
   , tokenize -- for tests


   , 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)
-- Monoid is re-exported from Prelude as of 4.8.0.0

#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
   -- primitives

   = Literal !Char
   | ExtSeparator                              --  .  optimized away to Literal

   | PathSeparator                             --  /

   | NonPathSeparator                          --  ?

   | CharRange !Bool [Either Char (Char,Char)] --  []

   | OpenRange (Maybe String) (Maybe String)   --  <>

   | AnyNonPathSeparator                       --  *

   | AnyDirectory                              --  **/


   -- after optimization only

   | LongLiteral !Int String
   | Unmatchable  -- [/], or [.] at the beginning or after a path separator

   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)

-- Note: CharRanges aren't converted, because this is tricky in general.

-- Consider for instance [@-[], which includes the range A-Z. This would need

-- to become [@[a-z]: so essentially we'd need to either:

--

--    1) Have a list of ranges of uppercase Unicode. Check if our range

--       overlaps with any of them and if it does, take the non-overlapping

--       part and combine it with the toLower of the overlapping part.

--

--    2) Simply expand the entire range to a list and map toLower over it.

--

-- In either case we'd need to re-optimize the CharRange—we can't assume that

-- if the uppercase characters are consecutive, so are the lowercase.

--

-- 1) might be feasible if someone bothered to get the latest data.

--

-- 2) obviously isn't since you might have 'Right (minBound, maxBound)' in

-- there somewhere.

--

-- The current solution is to just check both the toUpper of the character and

-- the toLower.

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 ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s)
tokToLower Token
tok               = Token
tok

-- |An abstract data type representing a compiled pattern.

--

-- Note that the 'Eq' instance cannot tell you whether two patterns behave in

-- the same way; only whether they compile to the same 'Pattern'. For instance,

-- @'compile' \"x\"@ and @'compile' \"[x]\"@ may or may not compare equal,

-- though a @'match'@ will behave the exact same way no matter which 'Pattern'

-- is used.

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 [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 Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"*?[<"     = [Char
'[',Char
c,Char
']']
      | 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 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)   = (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 Maybe String
a Maybe String
b)     =
      Char
'<' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

   -- We have to be careful here with ^ and ! lest [a!b] become [!ab]. So we

   -- just put them at the end.

   --

   -- Also, [^x-] was sorted and should not become [^-x].

   --

   -- Also, for something like [/!^] or /[.^!] that got optimized to have just ^

   -- and ! we need to add a dummy /.

   show (CharRange Bool
b [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]
:[]) (\(Char
x,Char
y) -> [Char
x,Char
'-',Char
y])
          (String
caret,String
exclamation,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 (\Either Char (Char, Char)
c (String
ca,String
ex,String -> String
ss) ->
                case Either Char (Char, Char)
c of
                     Left Char
'^' -> (String
"^",String
ex,String -> String
ss)
                     Left Char
'!' -> (String
ca,String
"!",String -> String
ss)
                     Either Char (Char, Char)
_        -> (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
"", String -> String
forall a. a -> a
id)
                   [Either Char (Char, Char)]
r
          (String
beg,String
rest) = let s' :: String
s' = String -> String
fs []
                           (String
x,String
y) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
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
== String
"-"
                                 then (String
y,String
x)
                                 else (String
s',String
"")
       in [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"["
                 , if Bool
b then String
"" else String
"^"
                 , 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 String
"/" else String
""
                 , String
beg, String
caret, String
exclamation, String
rest
                 , String
"]"
                 ]

   show Token
Unmatchable = String
"[.]"

instance Show Pattern where
   showsPrec :: Int -> Pattern -> String -> String
showsPrec Int
d Pattern
p = Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
      String -> String -> String
showString String
"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
+Int
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 Int
10 (ReadPrec Pattern -> ReadPrec Pattern)
-> ReadPrec Pattern -> ReadPrec Pattern
forall a b. (a -> b) -> a -> b
$ do
      Ident String
"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 [Token]
a <> :: Pattern -> Pattern -> Pattern
<> Pattern [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 b
n (Pattern [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

-- |Options which can be passed to the 'tryCompileWith' or 'compileWith'

-- functions: with these you can selectively toggle certain features at compile

-- time.

--

-- Note that some of these options depend on each other: classes can never

-- occur if ranges aren't allowed, for instance.


-- We could presumably put locale information in here, too.

data CompOptions = CompOptions
    { CompOptions -> Bool
characterClasses   :: Bool -- ^Allow character classes, @[[:...:]]@.

    , CompOptions -> Bool
characterRanges    :: Bool -- ^Allow character ranges, @[...]@.

    , CompOptions -> Bool
numberRanges       :: Bool -- ^Allow open ranges, @\<...>@.

    , CompOptions -> Bool
wildcards          :: Bool -- ^Allow wildcards, @*@ and @?@.

    , CompOptions -> Bool
recursiveWildcards :: Bool -- ^Allow recursive wildcards, @**/@.


    , CompOptions -> Bool
pathSepInRanges    :: Bool
      -- ^Allow path separators in character ranges.

      --

      -- If true, @a[/]b@ never matches anything (since character ranges can't

      -- match path separators); if false and 'errorRecovery' is enabled,

      -- @a[/]b@ matches itself, i.e. a file named @]b@ in the subdirectory

      -- @a[@.


    , CompOptions -> Bool
errorRecovery      :: Bool
      -- ^If the input is invalid, recover by turning any invalid part into

      -- literals. For instance, with 'characterRanges' enabled, @[abc@ is an

      -- error by default (unclosed character range); with 'errorRecovery', the

      -- @[@ is turned into a literal match, as though 'characterRanges' were

      -- disabled.

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

-- |The default set of compilation options: closest to the behaviour of the

-- @zsh@ shell, with 'errorRecovery' enabled.

--

-- All options are enabled.

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
   }

-- |Options for POSIX-compliance, as described in @man 7 glob@.

--

-- 'numberRanges', 'recursiveWildcards', and 'pathSepInRanges' are disabled.

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
   }

-- |Options which can be passed to the 'matchWith' or 'globDirWith' functions:

-- with these you can selectively toggle certain features at matching time.

data MatchOptions = MatchOptions
    { MatchOptions -> Bool
matchDotsImplicitly :: Bool
      -- ^Allow @*@, @?@, and @**/@ to match @.@ at the beginning of paths.


    , MatchOptions -> Bool
ignoreCase          :: Bool
      -- ^Case-independent matching.


    , MatchOptions -> Bool
ignoreDotSlash      :: Bool
      -- ^Treat @./@ as a no-op in both paths and patterns.

      --

      -- (Of course e.g. @../@ means something different and will not be

      -- ignored.)

    }

-- |The default set of execution options: closest to the behaviour of the @zsh@

-- shell.

--

-- Currently identical to 'matchPosix'.

matchDefault :: MatchOptions
matchDefault :: MatchOptions
matchDefault = MatchOptions
matchPosix

-- |Options for POSIX-compliance, as described in @man 7 glob@.

--

-- 'ignoreDotSlash' is enabled, the rest are disabled.

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
   }

-- |Decompiles a 'Pattern' object into its textual representation: essentially

-- the inverse of 'compile'.

--

-- Note, however, that due to internal optimization, @decompile . compile@ is

-- not the identity function. Instead, @compile . decompile@ is.

--

-- Be careful with 'CompOptions': 'decompile' always produces a 'String' which

-- can be passed to 'compile' to get back the same 'Pattern'. @compileWith

-- options . decompile@ is /not/ the identity function unless @options@ is

-- 'compDefault'.

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

------------------------------------------

-- COMPILATION

------------------------------------------



-- |Compiles a glob pattern from its textual representation into a 'Pattern'

-- object.

--

-- For the most part, a character matches itself. Recognized operators are as

-- follows:

--

-- [@?@]      Matches any character except path separators.

--

-- [@*@]      Matches any number of characters except path separators,

--            including the empty string.

--

-- [@[..\]@]  Matches any of the enclosed characters. Ranges of characters can

--            be specified by separating the endpoints with a @\'-'@. @\'-'@ or

--            @']'@ can be matched by including them as the first character(s)

--            in the list. Never matches path separators: @[\/]@ matches

--            nothing at all. Named character classes can also be matched:

--            @[:x:]@ within @[]@ specifies the class named @x@, which matches

--            certain predefined characters. See below for a full list.

--

-- [@[^..\]@ or @[!..\]@] Like @[..]@, but matches any character /not/ listed.

--                        Note that @[^-x]@ is not the inverse of @[-x]@, but

--                        the range @[^-x]@.

--

-- [@\<m-n>@] Matches any integer in the range m to n, inclusive. The range may

--            be open-ended by leaving out either number: @\"\<->\"@, for

--            instance, matches any integer.

--

-- [@**/@]    Matches any number of characters, including path separators,

--            excluding the empty string.

--

-- Supported character classes:

--

-- [@[:alnum:\]@]  Equivalent to @\"0-9A-Za-z\"@.

--

-- [@[:alpha:\]@]  Equivalent to @\"A-Za-z\"@.

--

-- [@[:blank:\]@]  Equivalent to @\"\\t \"@.

--

-- [@[:cntrl:\]@]  Equivalent to @\"\\0-\\x1f\\x7f\"@.

--

-- [@[:digit:\]@]  Equivalent to @\"0-9\"@.

--

-- [@[:graph:\]@]  Equivalent to @\"!-~\"@.

--

-- [@[:lower:\]@]  Equivalent to @\"a-z\"@.

--

-- [@[:print:\]@]  Equivalent to @\" -~\"@.

--

-- [@[:punct:\]@]  Equivalent to @\"!-\/:-\@[-`{-~\"@.

--

-- [@[:space:\]@]  Equivalent to @\"\\t-\\r \"@.

--

-- [@[:upper:\]@]  Equivalent to @\"A-Z\"@.

--

-- [@[:xdigit:\]@] Equivalent to @\"0-9A-Fa-f\"@.

--

-- Note that path separators (typically @\'/\'@) have to be matched explicitly

-- or using the @**/@ pattern. In addition, extension separators (typically

-- @\'.\'@) have to be matched explicitly at the beginning of the pattern or

-- after any path separator.

--

-- If a system supports multiple path separators, any one of them will match

-- any of them. For instance, on Windows, @\'/\'@ will match itself as well as

-- @\'\\\'@.

--

-- Error recovery will be performed: erroneous operators will not be considered

-- operators, but matched as literal strings. Such operators include:

--

-- * An empty @[]@ or @[^]@ or @[!]@

--

-- * A @[@ or @\<@ without a matching @]@ or @>@

--

-- * A malformed @\<>@: e.g. nonnumeric characters or no hyphen

--

-- So, e.g. @[]@ will match the string @\"[]\"@.

compile :: String -> Pattern
compile :: String -> Pattern
compile = CompOptions -> String -> Pattern
compileWith CompOptions
compDefault

-- |Like 'compile', but recognizes operators according to the given

-- 'CompOptions' instead of the defaults.

--

-- If an error occurs and 'errorRecovery' is disabled, 'error' will be called.

compileWith :: CompOptions -> String -> Pattern
compileWith :: CompOptions -> String -> Pattern
compileWith 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

-- |A safe version of 'compileWith'.

--

-- If an error occurs and 'errorRecovery' is disabled, the error message will

-- be returned in a 'Left'.

tryCompileWith :: CompOptions -> String -> Either String Pattern
tryCompileWith :: CompOptions -> String -> Either String Pattern
tryCompileWith 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 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 String
_ Char
c 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 String
s Char
_ String
_                       = [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 (Char
'?':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 (Char
'*':String
cs) | Bool
wcs =
      case String
cs of
           Char
'*':Char
p: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
           String
_  -> 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 (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 Either String Token
-> [Either String Token] -> [Either String Token]
forall a. a -> [a] -> [a]
: String -> [Either String Token]
go String
rest

   go (Char
'<':String
cs) | Bool
ors =
      let (String
range, 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
==Char
'>') 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 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 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 (Char
c: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

-- <a-b> where a > b can never match anything; this is not considered an error

openRange :: String -> Either String Token
openRange :: String -> Either String Token
openRange [Char
'-']   = 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 (Char
'-':String
s) =
   case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s of
        (String
b,String
"") -> 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, String)
_      -> 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
$ String
"compile :: bad <>, expected number, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
openRange String
s =
   case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s of
        (String
a,String
"-")    -> 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
        (String
a,Char
'-':String
s') ->
           case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s' of
                (String
b,String
"") -> 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, String)
_ -> 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
$ String
"compile :: bad <>, expected number, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s'
        (String, String)
_ -> 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
$ String
"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 CompOptions
opts String
zs =
   case String
zs of
        Char
y:String
ys | Char
y Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"^!" ->
           case String
ys of
                -- [!-#] is not the inverse of [-#], it is the range ! through

                -- #

                Char
'-':Char
']':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 Char
'-']), String
xs)
                Char
'-'    :String
_  -> (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)
                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)
        String
_                  -> (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 (Char
']':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 Char
']' String
xs
   start (Char
'-':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 Char
'-' String
xs
   start 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 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   String
err,  [Either Char (Char, Char)]
_) -> (String -> Either String [Either Char (Char, Char)]
forall a b. a -> Either a b
Left String
err, [])
                (Right String
rest, [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 (Char
'[':Char
':':String
xs) | CompOptions -> Bool
characterClasses CompOptions
opts = String -> ExceptT String (Writer [Either Char (Char, Char)]) String
readClass String
xs
   go (    Char
']':String
xs) = String -> ExceptT String (Writer [Either Char (Char, Char)]) String
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 String -> ExceptT String (Writer [Either Char (Char, Char)]) String
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"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 String
"compile :: unclosed [] in pattern"

   char :: Char -> String -> ExceptT String (Writer CharRange) String
   char :: Char
-> String
-> ExceptT String (Writer [Either Char (Char, Char)]) String
char Char
c (Char
'-':Char
x:String
xs) =
      if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
']'
         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 Char
'-'] 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 Char
c 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 String
xs = let (String
name,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
                           Char
':':Char
']':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
                           String
_            -> [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
'[',Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left Char
':'] 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 String
name =
      -- The POSIX classes

      --

      -- TODO: this is ASCII-only, not sure how this should be extended

      --       Unicode, or with a locale as input, or something else?

      case String
name of
           String
"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]
           String
"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]
           String
"blank"  -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)]
forall b. [Either Char b]
blanks
           String
"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 (Char
'\0',Char
'\x1f'), Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left Char
'\x7f']
           String
"digit"  -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)
forall a. Either a (Char, Char)
digit]
           String
"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 (Char
'!',Char
'~')]
           String
"lower"  -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)
forall a. Either a (Char, Char)
lower]
           String
"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 (Char
' ',Char
'~')]
           String
"punct"  -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)]
forall a. [Either a (Char, Char)]
punct
           String
"space"  -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)]
spaces
           String
"upper"  -> [Either Char (Char, Char)]
-> ExceptT String (Writer [Either Char (Char, Char)]) ()
ltell [Either Char (Char, Char)
forall a. Either a (Char, Char)
upper]
           String
"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 (Char
'A',Char
'F'), (Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right (Char
'a',Char
'f')]
           String
_        ->
              String -> ExceptT String (Writer [Either Char (Char, Char)]) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String
"compile :: unknown character class '" String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")

   digit :: Either a (Char, Char)
digit  = (Char, Char) -> Either a (Char, Char)
forall a b. b -> Either a b
Right (Char
'0',Char
'9')
   upper :: Either a (Char, Char)
upper  = (Char, Char) -> Either a (Char, Char)
forall a b. b -> Either a b
Right (Char
'A',Char
'Z')
   lower :: Either a (Char, Char)
lower  = (Char, Char) -> Either a (Char, Char)
forall a b. b -> Either a b
Right (Char
'a',Char
'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 [(Char
'!',Char
'/'), (Char
':',Char
'@'), (Char
'[',Char
'`'), (Char
'{',Char
'~')]
   blanks :: [Either Char b]
blanks = [Char -> Either Char b
forall a b. a -> Either a b
Left Char
'\t',         Char -> Either Char b
forall a b. a -> Either a b
Left Char
' ']
   spaces :: [Either Char (Char, Char)]
spaces = [(Char, Char) -> Either Char (Char, Char)
forall a b. b -> Either a b
Right (Char
'\t',Char
'\r'), Char -> Either Char (Char, Char)
forall a b. a -> Either a b
Left Char
' ']

   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


------------------------------------------

-- OPTIMIZATION

------------------------------------------



optimize :: Pattern -> Pattern
optimize :: Pattern -> Pattern
optimize (Pattern [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
         Token
e : [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 Char
'.' ->
            ([Token] -> [Token]) -> [Token] -> [Token]
forall (t :: * -> *).
Foldable t =>
(t Token -> [Token]) -> t Token -> [Token]
checkUnmatchable (Char -> Token
Literal Char
'.' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:) ([Token] -> [Token]
go [Token]
ts)
         [Token]
_ ->
            -- Handle the case where the whole pattern starts with a

            -- now-literalized [.]. LongLiterals haven't been created yet so

            -- checking for Literal suffices.

            case [Token] -> [Token]
go [Token]
pat of
                 Literal Char
'.' : [Token]
_ -> [Token
Unmatchable]
                 [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 [] = []

   -- Literals to LongLiteral

   -- Has to be done here: we can't backtrack in go, but some cases might

   -- result in consecutive Literals being generated.

   -- E.g. "a[b]".

   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) = (Token -> Maybe Char) -> [Token] -> (String, [Token])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe Token -> Maybe Char
isCharLiteral [Token]
xs
       in [Token] -> [Token]
fin ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Int -> String -> Token
LongLiteral (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ls Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
                            ((Char -> String -> String) -> String -> String -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
a -> (Char
aChar -> String -> String
forall a. a -> [a] -> [a]
:)) [] (Char
x'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
y'Char -> String -> String
forall a. a -> [a] -> [a]
:String
ls))
                Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
rest

   -- concatenate LongLiterals

   -- Has to be done here because LongLiterals are generated above.

   --

   -- So one could say that we have one pass (go) which flattens everything as

   -- much as it can and one pass (fin) which concatenates what it can.

   fin (LongLiteral Int
l1 String
s1 : LongLiteral Int
l2 String
s2 : [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 Int
l String
s : Literal Char
c : [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
+Int
1) (String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
c]) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
xs

   fin (LongLiteral Int
1 String
s : [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 Char
c : LongLiteral Int
l String
s : [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
+Int
1) (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
xs

   fin (Token
x:[Token]
xs) = Token
x Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
fin [Token]
xs

   go :: [Token] -> [Token]
go [] = []

   -- Get rid of ExtSeparators, so that they can hopefully be combined into

   -- LongLiterals later.

   --

   -- /.                      -> fine

   -- . elsewhere             -> fine

   -- /[.]                    -> Unmatchable

   -- [.] at start of pattern -> handled outside 'go'

   go (p :: Token
p@Token
PathSeparator : Token
ExtSeparator : [Token]
xs) = Token
p Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Char -> Token
Literal Char
'.' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
   go (Token
ExtSeparator : [Token]
xs) = Char -> Token
Literal Char
'.' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
   go (p :: Token
p@Token
PathSeparator : x :: Token
x@(CharRange Bool
_ [Either Char (Char, Char)]
_) : [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 Bool
_ [Either Char (Char, Char)]
_) -> Token
x' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
             Literal Char
'.'        -> [Token
Unmatchable]
             Token
x'                 -> [Token] -> [Token]
go (Token
x'Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
xs)

   go (x :: Token
x@(CharRange Bool
_ [Either Char (Char, Char)]
_) : [Token]
xs) =
      case Bool -> Token -> Token
optimizeCharRange Bool
False Token
x of
           x' :: Token
x'@(CharRange Bool
_ [Either Char (Char, Char)]
_) -> Token
x' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
go [Token]
xs
           Token
x'                 -> [Token] -> [Token]
go (Token
x'Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
xs)

   -- Put [0-9] in front of <-> to allow compressing <->[0-9]<->. Handling the

   -- [0-9] first in matching should also be faster in general.

   go (o :: Token
o@(OpenRange Maybe String
Nothing Maybe String
Nothing) : Token
d : [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 (Token
x:[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 (Token
_, Int -> [Token]
f) -> let ([Token]
compressed,[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)
           Maybe (Token, Int -> [Token])
Nothing -> Token
x Token -> [Token] -> [Token]
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 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, \Int
n -> Int -> Token -> [Token]
forall a. Int -> a -> [a]
replicate Int
n Token
anyDigit)
                   ]

   isCharLiteral :: Token -> Maybe Char
isCharLiteral (Literal Char
x) = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
x
   isCharLiteral Token
_           = Maybe Char
forall a. Maybe a
Nothing

   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 (Char
'0', Char
'9')]

-- | Like 'span', but let's use a -> Maybe b predicate

spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe :: (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 b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
ys, [a]
zs)

optimizeCharRange :: Bool -> Token -> Token
optimizeCharRange :: Bool -> Token -> Token
optimizeCharRange Bool
precededBySlash (CharRange Bool
b [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
   -- [/] is interesting, it actually matches nothing at all

   -- [.] can be Literalized though, just don't make it into an ExtSeparator so

   --     that it doesn't match a leading dot

   fin :: [Either Char (Char, Char)] -> 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 (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 [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@(Either Char b
_:Either Char b
_:[Either Char b]
_) | Bool
b =
      (Either Char b -> Bool) -> [Either Char b] -> [Either Char b]
forall a. (a -> Bool) -> [a] -> [a]
filter (\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 Char
'.') 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 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
              -- [aaaaa] -> [a]

              | 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 ([Either a (a, a)]
ls,[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 -- start from y

                     ([a]
catable,[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 -- three (or more) Lefts make a Right

                     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
                        -- [abcd] -> [a-d]

                        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 (a, a)
r : [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
                   -- [da-c] -> [a-d]

                   Just (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
                   Maybe (a, a)
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 (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 (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
                   -- [a-cd] -> [a-d]

                   Just (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
                   Maybe (a, a)
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 (a, a)
r' : [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
                   -- [a-cb-d] -> [a-d]

                   Just (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
                   Maybe (a, a)
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 Bool
_ Token
_ = String -> Token
forall a. (?callStack::CallStack) => String -> a
error String
"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)    (Left   a
b)    = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
   cmp (Left   a
a)    (Right (a
b,b
_)) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
   cmp (Right (a
a,b
_)) (Left   a
b)    = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
   cmp (Right (a
a,b
_)) (Right (a
b,b
_)) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b

-- |Returns `True` iff the given `Pattern` is a literal file path, i.e. it has

-- no wildcards, character ranges, etc.

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 Char
_) = Bool
True
   lit (LongLiteral Int
_ String
_) = Bool
True
   lit Token
PathSeparator = Bool
True
   lit Token
_ = Bool
False