{-# LANGUAGE TypeFamilies, GADTs, TupleSections #-}
module Text.Regex.Applicative.Interface where
import Control.Applicative hiding (empty)
import Control.Arrow
import Control.Monad (guard)
import qualified Data.List as List
import Data.Maybe
import Text.Regex.Applicative.Types
import Text.Regex.Applicative.Object

-- | 'RE' is a profunctor. This is its contravariant map.
--
-- (A dependency on the @profunctors@ package doesn't seem justified.)
comap :: (s2 -> s1) -> RE s1 a -> RE s2 a
comap :: forall s2 s1 a. (s2 -> s1) -> RE s1 a -> RE s2 a
comap s2 -> s1
f RE s1 a
re =
  case RE s1 a
re of
    RE s1 a
Eps -> RE s2 a
RE s2 ()
forall s. RE s ()
Eps
    Symbol ThreadId
t s1 -> Maybe a
p    -> ThreadId -> (s2 -> Maybe a) -> RE s2 a
forall s a. ThreadId -> (s -> Maybe a) -> RE s a
Symbol ThreadId
t (s1 -> Maybe a
p (s1 -> Maybe a) -> (s2 -> s1) -> s2 -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s2 -> s1
f)
    Alt RE s1 a
r1 RE s1 a
r2     -> RE s2 a -> RE s2 a -> RE s2 a
forall s a. RE s a -> RE s a -> RE s a
Alt ((s2 -> s1) -> RE s1 a -> RE s2 a
forall s2 s1 a. (s2 -> s1) -> RE s1 a -> RE s2 a
comap s2 -> s1
f RE s1 a
r1) ((s2 -> s1) -> RE s1 a -> RE s2 a
forall s2 s1 a. (s2 -> s1) -> RE s1 a -> RE s2 a
comap s2 -> s1
f RE s1 a
r2)
    App RE s1 (a1 -> a)
r1 RE s1 a1
r2     -> RE s2 (a1 -> a) -> RE s2 a1 -> RE s2 a
forall s a1 a. RE s (a1 -> a) -> RE s a1 -> RE s a
App ((s2 -> s1) -> RE s1 (a1 -> a) -> RE s2 (a1 -> a)
forall s2 s1 a. (s2 -> s1) -> RE s1 a -> RE s2 a
comap s2 -> s1
f RE s1 (a1 -> a)
r1) ((s2 -> s1) -> RE s1 a1 -> RE s2 a1
forall s2 s1 a. (s2 -> s1) -> RE s1 a -> RE s2 a
comap s2 -> s1
f RE s1 a1
r2)
    Fmap a1 -> a
g RE s1 a1
r      -> (a1 -> a) -> RE s2 a1 -> RE s2 a
forall a1 a s. (a1 -> a) -> RE s a1 -> RE s a
Fmap a1 -> a
g ((s2 -> s1) -> RE s1 a1 -> RE s2 a1
forall s2 s1 a. (s2 -> s1) -> RE s1 a -> RE s2 a
comap s2 -> s1
f RE s1 a1
r)
    CatMaybes RE s1 (Maybe a)
r   -> RE s2 (Maybe a) -> RE s2 a
forall s a. RE s (Maybe a) -> RE s a
CatMaybes ((s2 -> s1) -> RE s1 (Maybe a) -> RE s2 (Maybe a)
forall s2 s1 a. (s2 -> s1) -> RE s1 a -> RE s2 a
comap s2 -> s1
f RE s1 (Maybe a)
r)
    RE s1 a
Fail          -> RE s2 a
forall s a. RE s a
Fail
    Rep Greediness
gr a -> a1 -> a
fn a
a RE s1 a1
r -> Greediness -> (a -> a1 -> a) -> a -> RE s2 a1 -> RE s2 a
forall a a1 s.
Greediness -> (a -> a1 -> a) -> a -> RE s a1 -> RE s a
Rep Greediness
gr a -> a1 -> a
fn a
a ((s2 -> s1) -> RE s1 a1 -> RE s2 a1
forall s2 s1 a. (s2 -> s1) -> RE s1 a -> RE s2 a
comap s2 -> s1
f RE s1 a1
r)
    Void RE s1 a1
r        -> RE s2 a1 -> RE s2 ()
forall s a1. RE s a1 -> RE s ()
Void ((s2 -> s1) -> RE s1 a1 -> RE s2 a1
forall s2 s1 a. (s2 -> s1) -> RE s1 a -> RE s2 a
comap s2 -> s1
f RE s1 a1
r)

-- | Match and return any single symbol
anySym :: RE s s
anySym :: forall s. RE s s
anySym = (s -> Maybe s) -> RE s s
forall s a. (s -> Maybe a) -> RE s a
msym s -> Maybe s
forall a. a -> Maybe a
Just

-- | Match zero or more instances of the given expression, which are combined using
-- the given folding function.
--
-- 'Greediness' argument controls whether this regular expression should match
-- as many as possible ('Greedy') or as few as possible ('NonGreedy') instances
-- of the underlying expression.
reFoldl :: Greediness -> (b -> a -> b) -> b -> RE s a -> RE s b
reFoldl :: forall a a1 s.
Greediness -> (a -> a1 -> a) -> a -> RE s a1 -> RE s a
reFoldl Greediness
g b -> a -> b
f b
b RE s a
a = Greediness -> (b -> a -> b) -> b -> RE s a -> RE s b
forall a a1 s.
Greediness -> (a -> a1 -> a) -> a -> RE s a1 -> RE s a
Rep Greediness
g b -> a -> b
f b
b RE s a
a

-- | Match zero or more instances of the given expression, but as
-- few of them as possible (i.e. /non-greedily/). A greedy equivalent of 'few'
-- is 'many'.
--
-- Examples:
--
-- >Text.Regex.Applicative> findFirstPrefix (few anySym  <* "b") "ababab"
-- >Just ("a","abab")
-- >Text.Regex.Applicative> findFirstPrefix (many anySym  <* "b") "ababab"
-- >Just ("ababa","")
few :: RE s a -> RE s [a]
few :: forall s a. RE s a -> RE s [a]
few RE s a
a = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> RE s [a] -> RE s [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Greediness -> ([a] -> a -> [a]) -> [a] -> RE s a -> RE s [a]
forall a a1 s.
Greediness -> (a -> a1 -> a) -> a -> RE s a1 -> RE s a
Rep Greediness
NonGreedy ((a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] RE s a
a

-- | Return matched symbols as part of the return value
withMatched :: RE s a -> RE s (a, [s])
withMatched :: forall s a. RE s a -> RE s (a, [s])
withMatched RE s a
Eps = (a -> [s] -> (a, [s])) -> [s] -> a -> (a, [s])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) [] (a -> (a, [s])) -> RE s a -> RE s (a, [s])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s a
RE s ()
forall s. RE s ()
Eps
withMatched (Symbol ThreadId
t s -> Maybe a
p) = ThreadId -> (s -> Maybe (a, [s])) -> RE s (a, [s])
forall s a. ThreadId -> (s -> Maybe a) -> RE s a
Symbol ThreadId
t (\s
s -> (,[s
s]) (a -> (a, [s])) -> Maybe a -> Maybe (a, [s])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Maybe a
p s
s)
withMatched (Alt RE s a
a RE s a
b) = RE s a -> RE s (a, [s])
forall s a. RE s a -> RE s (a, [s])
withMatched RE s a
a RE s (a, [s]) -> RE s (a, [s]) -> RE s (a, [s])
forall a. RE s a -> RE s a -> RE s a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RE s a -> RE s (a, [s])
forall s a. RE s a -> RE s (a, [s])
withMatched RE s a
b
withMatched (App RE s (a1 -> a)
a RE s a1
b) =
    (\(a1 -> a
f, [s]
s) (a1
x, [s]
t) -> (a1 -> a
f a1
x, [s]
s [s] -> [s] -> [s]
forall a. [a] -> [a] -> [a]
++ [s]
t)) ((a1 -> a, [s]) -> (a1, [s]) -> (a, [s]))
-> RE s (a1 -> a, [s]) -> RE s ((a1, [s]) -> (a, [s]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        RE s (a1 -> a) -> RE s (a1 -> a, [s])
forall s a. RE s a -> RE s (a, [s])
withMatched RE s (a1 -> a)
a RE s ((a1, [s]) -> (a, [s])) -> RE s (a1, [s]) -> RE s (a, [s])
forall a b. RE s (a -> b) -> RE s a -> RE s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        RE s a1 -> RE s (a1, [s])
forall s a. RE s a -> RE s (a, [s])
withMatched RE s a1
b
withMatched RE s a
Fail = RE s (a, [s])
forall s a. RE s a
Fail
withMatched (Fmap a1 -> a
f RE s a1
x) = (a1 -> a
f (a1 -> a) -> ([s] -> [s]) -> (a1, [s]) -> (a, [s])
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [s] -> [s]
forall a. a -> a
id) ((a1, [s]) -> (a, [s])) -> RE s (a1, [s]) -> RE s (a, [s])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s a1 -> RE s (a1, [s])
forall s a. RE s a -> RE s (a, [s])
withMatched RE s a1
x
withMatched (CatMaybes RE s (Maybe a)
x) = RE s (Maybe (a, [s])) -> RE s (a, [s])
forall s a. RE s (Maybe a) -> RE s a
CatMaybes (RE s (Maybe (a, [s])) -> RE s (a, [s]))
-> RE s (Maybe (a, [s])) -> RE s (a, [s])
forall a b. (a -> b) -> a -> b
$
    (\ (Maybe a
as, [s]
s) -> (a -> [s] -> (a, [s])) -> [s] -> a -> (a, [s])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) [s]
s (a -> (a, [s])) -> Maybe a -> Maybe (a, [s])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
as) ((Maybe a, [s]) -> Maybe (a, [s]))
-> RE s (Maybe a, [s]) -> RE s (Maybe (a, [s]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s (Maybe a) -> RE s (Maybe a, [s])
forall s a. RE s a -> RE s (a, [s])
withMatched RE s (Maybe a)
x
withMatched (Rep Greediness
gr a -> a1 -> a
f a
a0 RE s a1
x) =
    Greediness
-> ((a, [s]) -> (a1, [s]) -> (a, [s]))
-> (a, [s])
-> RE s (a1, [s])
-> RE s (a, [s])
forall a a1 s.
Greediness -> (a -> a1 -> a) -> a -> RE s a1 -> RE s a
Rep Greediness
gr (\(a
a, [s]
s) (a1
x, [s]
t) -> (a -> a1 -> a
f a
a a1
x, [s]
s [s] -> [s] -> [s]
forall a. [a] -> [a] -> [a]
++ [s]
t)) (a
a0, []) (RE s a1 -> RE s (a1, [s])
forall s a. RE s a -> RE s (a, [s])
withMatched RE s a1
x)
-- N.B.: this ruins the Void optimization
withMatched (Void RE s a1
x) = (() -> a1 -> ()
forall a b. a -> b -> a
const () (a1 -> ()) -> ([s] -> [s]) -> (a1, [s]) -> ((), [s])
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [s] -> [s]
forall a. a -> a
id) ((a1, [s]) -> (a, [s])) -> RE s (a1, [s]) -> RE s (a, [s])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s a1 -> RE s (a1, [s])
forall s a. RE s a -> RE s (a, [s])
withMatched RE s a1
x

-- | @s =~ a = match a s@
(=~) :: [s] -> RE s a -> Maybe a
=~ :: forall s a. [s] -> RE s a -> Maybe a
(=~) = (RE s a -> [s] -> Maybe a) -> [s] -> RE s a -> Maybe a
forall a b c. (a -> b -> c) -> b -> a -> c
flip RE s a -> [s] -> Maybe a
forall s a. RE s a -> [s] -> Maybe a
match
infix 2 =~

-- | Attempt to match a string of symbols against the regular expression.
-- Note that the whole string (not just some part of it) should be matched.
--
-- Examples:
--
-- >Text.Regex.Applicative> match (sym 'a' <|> sym 'b') "a"
-- >Just 'a'
-- >Text.Regex.Applicative> match (sym 'a' <|> sym 'b') "ab"
-- >Nothing
--
match :: RE s a -> [s] -> Maybe a
match :: forall s a. RE s a -> [s] -> Maybe a
match RE s a
re = let obj :: ReObject s a
obj = RE s a -> ReObject s a
forall s r. RE s r -> ReObject s r
compile RE s a
re in \[s]
str ->
    [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a) -> [a] -> Maybe a
forall a b. (a -> b) -> a -> b
$
    ReObject s a -> [a]
forall s r. ReObject s r -> [r]
results (ReObject s a -> [a]) -> ReObject s a -> [a]
forall a b. (a -> b) -> a -> b
$
    (ReObject s a -> s -> ReObject s a)
-> ReObject s a -> [s] -> ReObject s a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((s -> ReObject s a -> ReObject s a)
-> ReObject s a -> s -> ReObject s a
forall a b c. (a -> b -> c) -> b -> a -> c
flip s -> ReObject s a -> ReObject s a
forall s r. s -> ReObject s r -> ReObject s r
step) ReObject s a
obj [s]
str

-- | Find a string prefix which is matched by the regular expression.
--
-- Of all matching prefixes, pick one using left bias (prefer the left part of
-- '<|>' to the right part) and greediness.
--
-- This is the match which a backtracking engine (such as Perl's one) would find
-- first.
--
-- If match is found, the rest of the input is also returned.
--
-- See also 'findFirstPrefixWithUncons', of which this is a special case.
--
-- Examples:
--
-- >Text.Regex.Applicative> findFirstPrefix ("a" <|> "ab") "abc"
-- >Just ("a","bc")
-- >Text.Regex.Applicative> findFirstPrefix ("ab" <|> "a") "abc"
-- >Just ("ab","c")
-- >Text.Regex.Applicative> findFirstPrefix "bc" "abc"
-- >Nothing
findFirstPrefix :: RE s a -> [s] -> Maybe (a, [s])
findFirstPrefix :: forall s a. RE s a -> [s] -> Maybe (a, [s])
findFirstPrefix = ([s] -> Maybe (s, [s])) -> RE s a -> [s] -> Maybe (a, [s])
forall ss s a.
(ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findFirstPrefixWithUncons [s] -> Maybe (s, [s])
forall a. [a] -> Maybe (a, [a])
List.uncons

-- | Find the first prefix, with the given @uncons@ function.
--
-- @since 0.3.4
findFirstPrefixWithUncons :: (ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findFirstPrefixWithUncons :: forall ss s a.
(ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findFirstPrefixWithUncons = (ReObject s a -> (ReObject s a, Maybe a))
-> (ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
forall s a ss.
(ReObject s a -> (ReObject s a, Maybe a))
-> (ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findPrefixWith' (ReObject s a -> [Thread s a] -> (ReObject s a, Maybe a)
forall {s} {r}.
ReObject s r -> [Thread s r] -> (ReObject s r, Maybe r)
walk ReObject s a
forall s r. ReObject s r
emptyObject ([Thread s a] -> (ReObject s a, Maybe a))
-> (ReObject s a -> [Thread s a])
-> ReObject s a
-> (ReObject s a, Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReObject s a -> [Thread s a]
forall s r. ReObject s r -> [Thread s r]
threads)
  where
    walk :: ReObject s r -> [Thread s r] -> (ReObject s r, Maybe r)
walk ReObject s r
obj [] = (ReObject s r
obj, Maybe r
forall a. Maybe a
Nothing)
    walk ReObject s r
obj (Thread s r
t:[Thread s r]
ts) =
        case Thread s r -> Maybe r
forall s r. Thread s r -> Maybe r
getResult Thread s r
t of
            Just r
r -> (ReObject s r
obj, r -> Maybe r
forall a. a -> Maybe a
Just r
r)
            Maybe r
Nothing -> ReObject s r -> [Thread s r] -> (ReObject s r, Maybe r)
walk (Thread s r -> ReObject s r -> ReObject s r
forall s r. Thread s r -> ReObject s r -> ReObject s r
addThread Thread s r
t ReObject s r
obj) [Thread s r]
ts

-- | Find the longest string prefix which is matched by the regular expression.
--
-- Submatches are still determined using left bias and greediness, so this is
-- different from POSIX semantics.
--
-- If match is found, the rest of the input is also returned.
--
-- See also 'findLongestPrefixWithUncons', of which this is a special case.
--
-- Examples:
--
-- >Text.Regex.Applicative Data.Char> let keyword = "if"
-- >Text.Regex.Applicative Data.Char> let identifier = many $ psym isAlpha
-- >Text.Regex.Applicative Data.Char> let lexeme = (Left <$> keyword) <|> (Right <$> identifier)
-- >Text.Regex.Applicative Data.Char> findLongestPrefix lexeme "if foo"
-- >Just (Left "if"," foo")
-- >Text.Regex.Applicative Data.Char> findLongestPrefix lexeme "iffoo"
-- >Just (Right "iffoo","")
findLongestPrefix :: RE s a -> [s] -> Maybe (a, [s])
findLongestPrefix :: forall s a. RE s a -> [s] -> Maybe (a, [s])
findLongestPrefix = ([s] -> Maybe (s, [s])) -> RE s a -> [s] -> Maybe (a, [s])
forall ss s a.
(ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findLongestPrefixWithUncons [s] -> Maybe (s, [s])
forall a. [a] -> Maybe (a, [a])
List.uncons

-- | Find the longest prefix, with the given @uncons@ function.
--
-- @since 0.3.4
findLongestPrefixWithUncons :: (ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findLongestPrefixWithUncons :: forall ss s a.
(ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findLongestPrefixWithUncons = (ReObject s a -> (ReObject s a, Maybe a))
-> (ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
forall s a ss.
(ReObject s a -> (ReObject s a, Maybe a))
-> (ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findPrefixWith' ((,) (ReObject s a -> Maybe a -> (ReObject s a, Maybe a))
-> (ReObject s a -> Maybe a)
-> ReObject s a
-> (ReObject s a, Maybe a)
forall a b.
(ReObject s a -> a -> b)
-> (ReObject s a -> a) -> ReObject s a -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a)
-> (ReObject s a -> [a]) -> ReObject s a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReObject s a -> [a]
forall s r. ReObject s r -> [r]
results)

findPrefixWith'
 :: (ReObject s a -> (ReObject s a, Maybe a))
 -- ^ Given the regex object, compute the regex object to feed the next input value into, and
 -- the result, if any.
 -> (ss -> Maybe (s, ss)) -- ^ @uncons@
 -> RE s a -> ss -> Maybe (a, ss)
findPrefixWith' :: forall s a ss.
(ReObject s a -> (ReObject s a, Maybe a))
-> (ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findPrefixWith' ReObject s a -> (ReObject s a, Maybe a)
walk ss -> Maybe (s, ss)
uncons = \ RE s a
re -> ReObject s a -> Maybe (a, ss) -> ss -> Maybe (a, ss)
go (RE s a -> ReObject s a
forall s r. RE s r -> ReObject s r
compile RE s a
re) Maybe (a, ss)
forall a. Maybe a
Nothing
  where
    go :: ReObject s a -> Maybe (a, ss) -> ss -> Maybe (a, ss)
go ReObject s a
obj Maybe (a, ss)
resOld ss
ss = case ReObject s a -> (ReObject s a, Maybe a)
walk ReObject s a
obj of
        (ReObject s a
obj', Maybe a
resThis) ->
            let res :: Maybe (a, ss)
res = (a -> ss -> (a, ss)) -> ss -> a -> (a, ss)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) ss
ss (a -> (a, ss)) -> Maybe a -> Maybe (a, ss)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
resThis Maybe (a, ss) -> Maybe (a, ss) -> Maybe (a, ss)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (a, ss)
resOld
            in
                case ss -> Maybe (s, ss)
uncons ss
ss of
                    Maybe (s, ss)
_ | ReObject s a -> Bool
forall s r. ReObject s r -> Bool
failed ReObject s a
obj' -> Maybe (a, ss)
res
                    Maybe (s, ss)
Nothing -> Maybe (a, ss)
res
                    Just (s
s, ss
ss) -> ReObject s a -> Maybe (a, ss) -> ss -> Maybe (a, ss)
go (s -> ReObject s a -> ReObject s a
forall s r. s -> ReObject s r -> ReObject s r
step s
s ReObject s a
obj') Maybe (a, ss)
res ss
ss

-- | Find the shortest prefix (analogous to 'findLongestPrefix')
--
-- See also 'findShortestPrefixWithUncons', of which this is a special case.
findShortestPrefix :: RE s a -> [s] -> Maybe (a, [s])
findShortestPrefix :: forall s a. RE s a -> [s] -> Maybe (a, [s])
findShortestPrefix = ([s] -> Maybe (s, [s])) -> RE s a -> [s] -> Maybe (a, [s])
forall ss s a.
(ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findShortestPrefixWithUncons [s] -> Maybe (s, [s])
forall a. [a] -> Maybe (a, [a])
List.uncons

-- | Find the shortest prefix (analogous to 'findLongestPrefix'), with the given @uncons@ function.
--
-- @since 0.3.4
findShortestPrefixWithUncons :: (ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findShortestPrefixWithUncons :: forall ss s a.
(ss -> Maybe (s, ss)) -> RE s a -> ss -> Maybe (a, ss)
findShortestPrefixWithUncons ss -> Maybe (s, ss)
uncons = ReObject s a -> ss -> Maybe (a, ss)
go (ReObject s a -> ss -> Maybe (a, ss))
-> (RE s a -> ReObject s a) -> RE s a -> ss -> Maybe (a, ss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RE s a -> ReObject s a
forall s r. RE s r -> ReObject s r
compile
  where
    go :: ReObject s a -> ss -> Maybe (a, ss)
go ReObject s a
obj ss
ss = case ReObject s a -> [a]
forall s r. ReObject s r -> [r]
results ReObject s a
obj of
        a
r:[a]
_ -> (a, ss) -> Maybe (a, ss)
forall a. a -> Maybe a
Just (a
r, ss
ss)
        [a]
_ -> do
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (ReObject s a -> Bool
forall s r. ReObject s r -> Bool
failed ReObject s a
obj))
            (s
s, ss
ss) <- ss -> Maybe (s, ss)
uncons ss
ss
            ReObject s a -> ss -> Maybe (a, ss)
go (s -> ReObject s a -> ReObject s a
forall s r. s -> ReObject s r -> ReObject s r
step s
s ReObject s a
obj) ss
ss

-- | Find the leftmost substring that is matched by the regular expression.
-- Otherwise behaves like 'findFirstPrefix'. Returns the result together with
-- the prefix and suffix of the string surrounding the match.
findFirstInfix :: RE s a -> [s] -> Maybe ([s], a, [s])
findFirstInfix :: forall s a. RE s a -> [s] -> Maybe ([s], a, [s])
findFirstInfix RE s a
re [s]
str =
    ((([s], a), [s]) -> ([s], a, [s]))
-> Maybe (([s], a), [s]) -> Maybe ([s], a, [s])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(([s]
first, a
res), [s]
last) -> ([s]
first, a
res, [s]
last)) (Maybe (([s], a), [s]) -> Maybe ([s], a, [s]))
-> Maybe (([s], a), [s]) -> Maybe ([s], a, [s])
forall a b. (a -> b) -> a -> b
$
    RE s ([s], a) -> [s] -> Maybe (([s], a), [s])
forall s a. RE s a -> [s] -> Maybe (a, [s])
findFirstPrefix ((,) ([s] -> a -> ([s], a)) -> RE s [s] -> RE s (a -> ([s], a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s s -> RE s [s]
forall s a. RE s a -> RE s [a]
few RE s s
forall s. RE s s
anySym RE s (a -> ([s], a)) -> RE s a -> RE s ([s], a)
forall a b. RE s (a -> b) -> RE s a -> RE s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE s a
re) [s]
str

-- Auxiliary function for findExtremeInfix
prefixCounter :: RE s (Int, [s])
prefixCounter :: forall s. RE s (Int, [s])
prefixCounter = ([s] -> [s]) -> (Int, [s]) -> (Int, [s])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [s] -> [s]
forall a. [a] -> [a]
reverse ((Int, [s]) -> (Int, [s])) -> RE s (Int, [s]) -> RE s (Int, [s])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Greediness
-> ((Int, [s]) -> s -> (Int, [s]))
-> (Int, [s])
-> RE s s
-> RE s (Int, [s])
forall a a1 s.
Greediness -> (a -> a1 -> a) -> a -> RE s a1 -> RE s a
reFoldl Greediness
NonGreedy (Int, [s]) -> s -> (Int, [s])
forall {a} {a}. Num a => (a, [a]) -> a -> (a, [a])
f (Int
0, []) RE s s
forall s. RE s s
anySym
    where
    f :: (a, [a]) -> a -> (a, [a])
f (a
i, [a]
prefix) a
s = ((,) (a -> [a] -> (a, [a])) -> a -> [a] -> (a, [a])
forall a b. (a -> b) -> a -> b
$! (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1)) ([a] -> (a, [a])) -> [a] -> (a, [a])
forall a b. (a -> b) -> a -> b
$ a
sa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
prefix

data InfixMatchingState s a = GotResult
    { forall s a. InfixMatchingState s a -> Int
prefixLen  :: !Int
    , forall s a. InfixMatchingState s a -> [s]
prefixStr  :: [s]
    , forall s a. InfixMatchingState s a -> a
result     :: a
    , forall s a. InfixMatchingState s a -> [s]
postfixStr :: [s]
    }
    | NoResult

-- a `preferOver` b chooses one of a and b, giving preference to a
preferOver
    :: InfixMatchingState s a
    -> InfixMatchingState s a
    -> InfixMatchingState s a
preferOver :: forall s a.
InfixMatchingState s a
-> InfixMatchingState s a -> InfixMatchingState s a
preferOver InfixMatchingState s a
NoResult InfixMatchingState s a
b = InfixMatchingState s a
b
preferOver InfixMatchingState s a
b InfixMatchingState s a
NoResult = InfixMatchingState s a
b
preferOver InfixMatchingState s a
a InfixMatchingState s a
b =
    case InfixMatchingState s a -> Int
forall s a. InfixMatchingState s a -> Int
prefixLen InfixMatchingState s a
a Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` InfixMatchingState s a -> Int
forall s a. InfixMatchingState s a -> Int
prefixLen InfixMatchingState s a
b of
        Ordering
GT -> InfixMatchingState s a
b -- prefer b when it has smaller prefix
        Ordering
_  -> InfixMatchingState s a
a -- otherwise, prefer a

mkInfixMatchingState
    :: [s] -- rest of input
    -> Thread s ((Int, [s]), a)
    -> InfixMatchingState s a
mkInfixMatchingState :: forall s a.
[s] -> Thread s ((Int, [s]), a) -> InfixMatchingState s a
mkInfixMatchingState [s]
rest Thread s ((Int, [s]), a)
thread =
    case Thread s ((Int, [s]), a) -> Maybe ((Int, [s]), a)
forall s r. Thread s r -> Maybe r
getResult Thread s ((Int, [s]), a)
thread of
        Just ((Int
pLen, [s]
pStr), a
res) ->
            GotResult
                { prefixLen :: Int
prefixLen = Int
pLen
                , prefixStr :: [s]
prefixStr = [s]
pStr
                , result :: a
result    = a
res
                , postfixStr :: [s]
postfixStr = [s]
rest
                }
        Maybe ((Int, [s]), a)
Nothing -> InfixMatchingState s a
forall s a. InfixMatchingState s a
NoResult

gotResult :: InfixMatchingState s a -> Bool
gotResult :: forall s a. InfixMatchingState s a -> Bool
gotResult GotResult {} = Bool
True
gotResult InfixMatchingState s a
_ = Bool
False

-- Algorithm for finding leftmost longest infix match:
--
-- 1. Add a thread /.*?/ to the begginning of the regexp
-- 2. As soon as we get first accept, we delete that thread
-- 3. When we get more than one accept, we choose one by the following criteria:
-- 3.1. Compare by the length of prefix (since we are looking for the leftmost
-- match)
-- 3.2. If they are produced on the same step, choose the first one (left-biased
-- choice)
-- 3.3. If they are produced on the different steps, choose the later one (since
-- they have the same prefixes, later means longer)
findExtremalInfix
    :: -- function to combine a later result (first arg) to an earlier one (second
       -- arg)
       (InfixMatchingState s a -> InfixMatchingState s a -> InfixMatchingState s a)
    -> RE s a
    -> [s]
    -> Maybe ([s], a, [s])
findExtremalInfix :: forall s a.
(InfixMatchingState s a
 -> InfixMatchingState s a -> InfixMatchingState s a)
-> RE s a -> [s] -> Maybe ([s], a, [s])
findExtremalInfix InfixMatchingState s a
-> InfixMatchingState s a -> InfixMatchingState s a
newOrOld RE s a
re [s]
str =
    case ReObject s ((Int, [s]), a)
-> [s] -> InfixMatchingState s a -> InfixMatchingState s a
go (RE s ((Int, [s]), a) -> ReObject s ((Int, [s]), a)
forall s r. RE s r -> ReObject s r
compile (RE s ((Int, [s]), a) -> ReObject s ((Int, [s]), a))
-> RE s ((Int, [s]), a) -> ReObject s ((Int, [s]), a)
forall a b. (a -> b) -> a -> b
$ (,) ((Int, [s]) -> a -> ((Int, [s]), a))
-> RE s (Int, [s]) -> RE s (a -> ((Int, [s]), a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s (Int, [s])
forall s. RE s (Int, [s])
prefixCounter RE s (a -> ((Int, [s]), a)) -> RE s a -> RE s ((Int, [s]), a)
forall a b. RE s (a -> b) -> RE s a -> RE s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE s a
re) [s]
str InfixMatchingState s a
forall s a. InfixMatchingState s a
NoResult of
        InfixMatchingState s a
NoResult -> Maybe ([s], a, [s])
forall a. Maybe a
Nothing
        r :: InfixMatchingState s a
r@GotResult{} ->
            ([s], a, [s]) -> Maybe ([s], a, [s])
forall a. a -> Maybe a
Just (InfixMatchingState s a -> [s]
forall s a. InfixMatchingState s a -> [s]
prefixStr InfixMatchingState s a
r, InfixMatchingState s a -> a
forall s a. InfixMatchingState s a -> a
result InfixMatchingState s a
r, InfixMatchingState s a -> [s]
forall s a. InfixMatchingState s a -> [s]
postfixStr InfixMatchingState s a
r)
    where
    {-
    go :: ReObject s ((Int, [s]), a)
       -> [s]
       -> InfixMatchingState s a
       -> InfixMatchingState s a
    -}
    go :: ReObject s ((Int, [s]), a)
-> [s] -> InfixMatchingState s a -> InfixMatchingState s a
go ReObject s ((Int, [s]), a)
obj [s]
str InfixMatchingState s a
resOld =
        let resThis :: InfixMatchingState s a
resThis =
                (InfixMatchingState s a
 -> Thread s ((Int, [s]), a) -> InfixMatchingState s a)
-> InfixMatchingState s a
-> [Thread s ((Int, [s]), a)]
-> InfixMatchingState s a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                    (\InfixMatchingState s a
acc Thread s ((Int, [s]), a)
t -> InfixMatchingState s a
acc InfixMatchingState s a
-> InfixMatchingState s a -> InfixMatchingState s a
forall s a.
InfixMatchingState s a
-> InfixMatchingState s a -> InfixMatchingState s a
`preferOver` [s] -> Thread s ((Int, [s]), a) -> InfixMatchingState s a
forall s a.
[s] -> Thread s ((Int, [s]), a) -> InfixMatchingState s a
mkInfixMatchingState [s]
str Thread s ((Int, [s]), a)
t)
                    InfixMatchingState s a
forall s a. InfixMatchingState s a
NoResult ([Thread s ((Int, [s]), a)] -> InfixMatchingState s a)
-> [Thread s ((Int, [s]), a)] -> InfixMatchingState s a
forall a b. (a -> b) -> a -> b
$
                    ReObject s ((Int, [s]), a) -> [Thread s ((Int, [s]), a)]
forall s r. ReObject s r -> [Thread s r]
threads ReObject s ((Int, [s]), a)
obj
            res :: InfixMatchingState s a
res = InfixMatchingState s a
resThis InfixMatchingState s a
-> InfixMatchingState s a -> InfixMatchingState s a
`newOrOld` InfixMatchingState s a
resOld
            obj' :: ReObject s ((Int, [s]), a)
obj' =
                -- If we just found the first result, kill the "prefixCounter" thread.
                -- We rely on the fact that it is the last thread of the object.
                if InfixMatchingState s a -> Bool
forall s a. InfixMatchingState s a -> Bool
gotResult InfixMatchingState s a
resThis Bool -> Bool -> Bool
&& Bool -> Bool
not (InfixMatchingState s a -> Bool
forall s a. InfixMatchingState s a -> Bool
gotResult InfixMatchingState s a
resOld)
                    then [Thread s ((Int, [s]), a)] -> ReObject s ((Int, [s]), a)
forall s r. [Thread s r] -> ReObject s r
fromThreads ([Thread s ((Int, [s]), a)] -> ReObject s ((Int, [s]), a))
-> [Thread s ((Int, [s]), a)] -> ReObject s ((Int, [s]), a)
forall a b. (a -> b) -> a -> b
$ [Thread s ((Int, [s]), a)] -> [Thread s ((Int, [s]), a)]
forall a. HasCallStack => [a] -> [a]
init ([Thread s ((Int, [s]), a)] -> [Thread s ((Int, [s]), a)])
-> [Thread s ((Int, [s]), a)] -> [Thread s ((Int, [s]), a)]
forall a b. (a -> b) -> a -> b
$ ReObject s ((Int, [s]), a) -> [Thread s ((Int, [s]), a)]
forall s r. ReObject s r -> [Thread s r]
threads ReObject s ((Int, [s]), a)
obj
                    else ReObject s ((Int, [s]), a)
obj
        in
            case [s]
str of
                [] -> InfixMatchingState s a
res
                [s]
_ | ReObject s ((Int, [s]), a) -> Bool
forall s r. ReObject s r -> Bool
failed ReObject s ((Int, [s]), a)
obj -> InfixMatchingState s a
res
                (s
s:[s]
ss) -> ReObject s ((Int, [s]), a)
-> [s] -> InfixMatchingState s a -> InfixMatchingState s a
go (s -> ReObject s ((Int, [s]), a) -> ReObject s ((Int, [s]), a)
forall s r. s -> ReObject s r -> ReObject s r
step s
s ReObject s ((Int, [s]), a)
obj') [s]
ss InfixMatchingState s a
res


-- | Find the leftmost substring that is matched by the regular expression.
-- Otherwise behaves like 'findLongestPrefix'. Returns the result together with
-- the prefix and suffix of the string surrounding the match.
findLongestInfix :: RE s a -> [s] -> Maybe ([s], a, [s])
findLongestInfix :: forall s a. RE s a -> [s] -> Maybe ([s], a, [s])
findLongestInfix = (InfixMatchingState s a
 -> InfixMatchingState s a -> InfixMatchingState s a)
-> RE s a -> [s] -> Maybe ([s], a, [s])
forall s a.
(InfixMatchingState s a
 -> InfixMatchingState s a -> InfixMatchingState s a)
-> RE s a -> [s] -> Maybe ([s], a, [s])
findExtremalInfix InfixMatchingState s a
-> InfixMatchingState s a -> InfixMatchingState s a
forall s a.
InfixMatchingState s a
-> InfixMatchingState s a -> InfixMatchingState s a
preferOver

-- | Find the leftmost substring that is matched by the regular expression.
-- Otherwise behaves like 'findShortestPrefix'. Returns the result together with
-- the prefix and suffix of the string surrounding the match.
findShortestInfix :: RE s a -> [s] -> Maybe ([s], a, [s])
findShortestInfix :: forall s a. RE s a -> [s] -> Maybe ([s], a, [s])
findShortestInfix = (InfixMatchingState s a
 -> InfixMatchingState s a -> InfixMatchingState s a)
-> RE s a -> [s] -> Maybe ([s], a, [s])
forall s a.
(InfixMatchingState s a
 -> InfixMatchingState s a -> InfixMatchingState s a)
-> RE s a -> [s] -> Maybe ([s], a, [s])
findExtremalInfix ((InfixMatchingState s a
  -> InfixMatchingState s a -> InfixMatchingState s a)
 -> RE s a -> [s] -> Maybe ([s], a, [s]))
-> (InfixMatchingState s a
    -> InfixMatchingState s a -> InfixMatchingState s a)
-> RE s a
-> [s]
-> Maybe ([s], a, [s])
forall a b. (a -> b) -> a -> b
$ (InfixMatchingState s a
 -> InfixMatchingState s a -> InfixMatchingState s a)
-> InfixMatchingState s a
-> InfixMatchingState s a
-> InfixMatchingState s a
forall a b c. (a -> b -> c) -> b -> a -> c
flip InfixMatchingState s a
-> InfixMatchingState s a -> InfixMatchingState s a
forall s a.
InfixMatchingState s a
-> InfixMatchingState s a -> InfixMatchingState s a
preferOver

-- | Replace matches of the regular expression with its value.
--
-- >Text.Regex.Applicative > replace ("!" <$ sym 'f' <* some (sym 'o')) "quuxfoofooooofoobarfobar"
-- >"quux!!!bar!bar"
replace :: RE s [s] -> [s] -> [s]
replace :: forall s. RE s [s] -> [s] -> [s]
replace RE s [s]
r = (([s] -> [s]) -> [s] -> [s]
forall a b. (a -> b) -> a -> b
$ []) (([s] -> [s]) -> [s]) -> ([s] -> [s] -> [s]) -> [s] -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> [s] -> [s]
go
  where go :: [s] -> [s] -> [s]
go [s]
ys = case RE s [s] -> [s] -> Maybe ([s], [s], [s])
forall s a. RE s a -> [s] -> Maybe ([s], a, [s])
findLongestInfix RE s [s]
r [s]
ys of
                    Maybe ([s], [s], [s])
Nothing                -> ([s]
ys [s] -> [s] -> [s]
forall a. [a] -> [a] -> [a]
++)
                    Just ([s]
before, [s]
m, [s]
rest) -> ([s]
before [s] -> [s] -> [s]
forall a. [a] -> [a] -> [a]
++) ([s] -> [s]) -> ([s] -> [s]) -> [s] -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([s]
m [s] -> [s] -> [s]
forall a. [a] -> [a] -> [a]
++) ([s] -> [s]) -> ([s] -> [s]) -> [s] -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> [s] -> [s]
go [s]
rest