{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BinaryLiterals #-}
module Regex.KDE.Match
 ( matchRegex
 , matchRegexWithGroups
 , extractCapturingGroups
 ) where

import qualified Data.ByteString as B
import Data.ByteString (ByteString)
import qualified Data.ByteString.UTF8 as U
import Data.Char (toLower)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Bits (shiftL, (.|.))
import Data.Word (Word8)
import Regex.KDE.Regex
import qualified Data.IntMap.Strict as M
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup ((<>))
#endif

-- Note that all matches are from the beginning of the string.
-- The ^ anchor is implicit at the beginning of the regex.

-- To reproduce PCRE's leftmost-first (backtracking) semantics in a
-- set-based matcher, every match carries a path recording the choices
-- made to reach it: 0 for taking the left branch of an alternation or
-- continuing a greedy repetition, 1 for the right branch or ending
-- the repetition (for lazy repetitions the loop codes are reversed).
-- Comparing paths lexicographically gives the order in which a
-- backtracking matcher like PCRE would find the matches, so the
-- preferred match is always the one with the smallest path.

-- A sequence of binary choices, packed into an Integer (most recent
-- choice in the least significant bit) together with its length.
-- Compared lexicographically as a bit sequence, with a proper prefix
-- ordered before its extensions.
data Path = Path !Integer !Int
  deriving (Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Path -> ShowS
showsPrec :: Int -> Path -> ShowS
$cshow :: Path -> String
show :: Path -> String
$cshowList :: [Path] -> ShowS
showList :: [Path] -> ShowS
Show, Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
/= :: Path -> Path -> Bool
Eq)

instance Ord Path where
  compare :: Path -> Path -> Ordering
compare (Path Integer
i1 Int
l1) (Path Integer
i2 Int
l2) =
    Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer
i1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
l2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l1)) (Integer
i2 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l2))
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
l1 Int
l2

emptyPath :: Path
emptyPath :: Path
emptyPath = Integer -> Int -> Path
Path Integer
0 Int
0

pathSnoc :: Path -> Word8 -> Path
pathSnoc :: Path -> Word8 -> Path
pathSnoc (Path Integer
i Int
l) Word8
b = Integer -> Int -> Path
Path ((Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

data Match =
   Match { Match -> ByteString
matchBytes    :: !ByteString
         , Match -> Int
matchOffset   :: !Int
         , Match -> IntMap (Int, Int)
matchCaptures :: !(M.IntMap (Int, Int))
                                  -- starting offset, length in bytes
         , Match -> Path
matchPath     :: !Path
         } deriving (Int -> Match -> ShowS
[Match] -> ShowS
Match -> String
(Int -> Match -> ShowS)
-> (Match -> String) -> ([Match] -> ShowS) -> Show Match
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Match -> ShowS
showsPrec :: Int -> Match -> ShowS
$cshow :: Match -> String
show :: Match -> String
$cshowList :: [Match] -> ShowS
showList :: [Match] -> ShowS
Show)

-- consistent with Ord (which ignores matchBytes, since all matches
-- in a given run share it):
instance Eq Match where
  Match
m1 == :: Match -> Match -> Bool
== Match
m2 = Match -> Match -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Match
m1 Match
m2 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

-- preferred matches are <=; the path (priority) is decisive, and the
-- other comparisons only make the order total:
instance Ord Match where
  compare :: Match -> Match -> Ordering
compare Match
m1 Match
m2 =
    Path -> Path -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Match -> Path
matchPath Match
m1) (Match -> Path
matchPath Match
m2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<>
    Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Match -> Int
matchOffset Match
m1) (Match -> Int
matchOffset Match
m2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<>
    IntMap (Int, Int) -> IntMap (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Match -> IntMap (Int, Int)
matchCaptures Match
m1) (Match -> IntMap (Int, Int)
matchCaptures Match
m2)

-- the state of a match, disregarding its priority
stateKey :: Match -> (Int, M.IntMap (Int, Int))
stateKey :: Match -> (Int, IntMap (Int, Int))
stateKey Match
m = (Match -> Int
matchOffset Match
m, Match -> IntMap (Int, Int)
matchCaptures Match
m)

-- append a choice to the path of every match
addChoice :: Word8 -> Set Match -> Set Match
addChoice :: Word8 -> Set Match -> Set Match
addChoice !Word8
b = (Match -> Match) -> Set Match -> Set Match
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\Match
m -> Match
m{ matchPath = pathSnoc (matchPath m) b })

-- Discard any match whose state coincides with that of a preferred
-- (smaller-path) match: their futures are identical, and a
-- backtracking matcher would explore the preferred one first.
dedup :: Set Match -> Set Match
dedup :: Set Match -> Set Match
dedup = (Set (Int, IntMap (Int, Int)), Set Match) -> Set Match
forall a b. (a, b) -> b
snd ((Set (Int, IntMap (Int, Int)), Set Match) -> Set Match)
-> (Set Match -> (Set (Int, IntMap (Int, Int)), Set Match))
-> Set Match
-> Set Match
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Set (Int, IntMap (Int, Int)), Set Match)
 -> Match -> (Set (Int, IntMap (Int, Int)), Set Match))
-> (Set (Int, IntMap (Int, Int)), Set Match)
-> Set Match
-> (Set (Int, IntMap (Int, Int)), Set Match)
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (Set (Int, IntMap (Int, Int)), Set Match)
-> Match -> (Set (Int, IntMap (Int, Int)), Set Match)
step (Set (Int, IntMap (Int, Int))
forall a. Set a
Set.empty, Set Match
forall a. Set a
Set.empty)
 where
  step :: (Set (Int, IntMap (Int, Int)), Set Match)
-> Match -> (Set (Int, IntMap (Int, Int)), Set Match)
step (!Set (Int, IntMap (Int, Int))
seen, !Set Match
out) Match
m
    | Match -> (Int, IntMap (Int, Int))
stateKey Match
m (Int, IntMap (Int, Int)) -> Set (Int, IntMap (Int, Int)) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Int, IntMap (Int, Int))
seen = (Set (Int, IntMap (Int, Int))
seen, Set Match
out)
    | Bool
otherwise = ((Int, IntMap (Int, Int))
-> Set (Int, IntMap (Int, Int)) -> Set (Int, IntMap (Int, Int))
forall a. Ord a => a -> Set a -> Set a
Set.insert (Match -> (Int, IntMap (Int, Int))
stateKey Match
m) Set (Int, IntMap (Int, Int))
seen, Match -> Set Match -> Set Match
forall a. Ord a => a -> Set a -> Set a
Set.insert Match
m Set Match
out)

mapMatching :: (Match -> Match) -> Set Match -> Set Match
mapMatching :: (Match -> Match) -> Set Match -> Set Match
mapMatching Match -> Match
f = (Match -> Bool) -> Set Match -> Set Match
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (Int -> Bool) -> (Match -> Int) -> Match -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match -> Int
matchOffset) (Set Match -> Set Match)
-> (Set Match -> Set Match) -> Set Match -> Set Match
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Match -> Match) -> Set Match -> Set Match
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Match -> Match
f

-- we take the n best matches to avoid pathological slowdown
sizeLimit :: Int
sizeLimit :: Int
sizeLimit = Int
2000

-- prune matches if it gets out of hand, keeping preferred matches
prune :: Set Match -> Set Match
prune :: Set Match -> Set Match
prune Set Match
ms = if Set Match -> Int
forall a. Set a -> Int
Set.size Set Match
ms Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sizeLimit
              then Int -> Set Match -> Set Match
forall a. Int -> Set a -> Set a
Set.take Int
sizeLimit Set Match
ms
              else Set Match
ms

-- first argument: the set of subroutine calls (group number, offset)
-- currently being evaluated -- used to prevent infinite recursion --
-- and a map of capturing groups, needed for Subroutine.
exec :: (Set (Int, Int), M.IntMap Regex)
     -> Direction -> Regex -> Set Match -> Set Match
exec :: (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
_ Direction
_ Regex
MatchNull = Set Match -> Set Match
forall a. a -> a
id
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir (Lazy (MatchSome Regex
re)) = (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Word8 -> Word8 -> Set Match -> Set Match
someLoop (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
re Word8
1 Word8
0
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir (Lazy Regex
re) = -- Lazy is only applied to MatchSome (see Compile)
  (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
re
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir (Possessive Regex
re) =
  -- commit to the first match (in backtracking order) of re; its
  -- internal choices are forgotten, so the path is reset:
  (Set Match -> Match -> Set Match)
-> Set Match -> Set Match -> Set Match
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl'
    (\Set Match
s Match
m -> case Set Match -> Maybe Match
forall a. Set a -> Maybe a
Set.lookupMin ((Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
re (Match -> Set Match
forall a. a -> Set a
Set.singleton Match
m)) of
               Maybe Match
Nothing -> Set Match
s
               Just Match
m' -> Match -> Set Match -> Set Match
forall a. Ord a => a -> Set a -> Set a
Set.insert Match
m'{ matchPath = matchPath m } Set Match
s)
    Set Match
forall a. Monoid a => a
mempty
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir (MatchDynamic Int
n) = -- if this hasn't been replaced, match literal
  (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir ((Char -> Bool) -> Regex
MatchChar (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%') Regex -> Regex -> Regex
forall a. Semigroup a => a -> a -> a
<>
            [Regex] -> Regex
forall a. Monoid a => [a] -> a
mconcat ((Char -> Regex) -> String -> [Regex]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> (Char -> Bool) -> Regex
MatchChar (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)) (Int -> String
forall a. Show a => a -> String
show Int
n)))
exec (Set (Int, Int), IntMap Regex)
_ Direction
_ Regex
AssertEnd = (Match -> Bool) -> Set Match -> Set Match
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\Match
m -> Match -> Int
matchOffset Match
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int
B.length (Match -> ByteString
matchBytes Match
m))
exec (Set (Int, Int), IntMap Regex)
_ Direction
_ Regex
AssertBeginning = (Match -> Bool) -> Set Match -> Set Match
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\Match
m -> Match -> Int
matchOffset Match
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
exec (Set (Int, Int), IntMap Regex)
cgs Direction
_ (AssertPositive Direction
dir Regex
regex) =
  -- assertions are atomic: only the captures of the first match (in
  -- backtracking order) of the assertion are kept, as in PCRE:
  (Set Match -> Match -> Set Match)
-> Set Match -> Set Match -> Set Match
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl'
    (\Set Match
s Match
m -> case Set Match -> Maybe Match
forall a. Set a -> Maybe a
Set.lookupMin ((Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
regex (Match -> Set Match
forall a. a -> Set a
Set.singleton Match
m)) of
               Maybe Match
Nothing -> Set Match
s
               Just Match
m' -> Match -> Set Match -> Set Match
forall a. Ord a => a -> Set a -> Set a
Set.insert
                            Match
m'{ matchBytes = matchBytes m
                              , matchOffset = matchOffset m
                              , matchPath = matchPath m } Set Match
s)
    Set Match
forall a. Monoid a => a
mempty
exec (Set (Int, Int), IntMap Regex)
cgs Direction
_ (AssertNegative Direction
dir Regex
regex) =
  (Match -> Bool) -> Set Match -> Set Match
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\Match
m -> Set Match -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
regex (Match -> Set Match
forall a. a -> Set a
Set.singleton Match
m)))
exec (Set (Int, Int), IntMap Regex)
_ Direction
_ Regex
AssertWordBoundary = (Match -> Bool) -> Set Match -> Set Match
forall a. (a -> Bool) -> Set a -> Set a
Set.filter Match -> Bool
atWordBoundary
exec (Set (Int, Int), IntMap Regex)
_ Direction
Forward Regex
MatchAnyChar = (Match -> Match) -> Set Match -> Set Match
mapMatching ((Match -> Match) -> Set Match -> Set Match)
-> (Match -> Match) -> Set Match -> Set Match
forall a b. (a -> b) -> a -> b
$ \Match
m ->
  case ByteString -> Maybe (Char, Int)
U.decode (Int -> ByteString -> ByteString
B.drop (Match -> Int
matchOffset Match
m) (Match -> ByteString
matchBytes Match
m)) of
    Maybe (Char, Int)
Nothing -> Match
m{ matchOffset = - 1}
    Just (Char
_,Int
n) -> Match
m{ matchOffset = matchOffset m + n }
exec (Set (Int, Int), IntMap Regex)
_ Direction
Backward Regex
MatchAnyChar = (Match -> Match) -> Set Match -> Set Match
mapMatching ((Match -> Match) -> Set Match -> Set Match)
-> (Match -> Match) -> Set Match -> Set Match
forall a b. (a -> b) -> a -> b
$ \Match
m ->
  case ByteString -> Int -> Maybe Int
lastCharOffset (Match -> ByteString
matchBytes Match
m) (Match -> Int
matchOffset Match
m) of
    Maybe Int
Nothing  -> Match
m{ matchOffset = -1 }
    Just Int
off -> Match
m{ matchOffset = off }
exec (Set (Int, Int), IntMap Regex)
_ Direction
Forward (MatchChar Char -> Bool
f) = (Match -> Match) -> Set Match -> Set Match
mapMatching ((Match -> Match) -> Set Match -> Set Match)
-> (Match -> Match) -> Set Match -> Set Match
forall a b. (a -> b) -> a -> b
$ \Match
m ->
  case ByteString -> Maybe (Char, Int)
U.decode (Int -> ByteString -> ByteString
B.drop (Match -> Int
matchOffset Match
m) (Match -> ByteString
matchBytes Match
m)) of
    Just (Char
c,Int
n) | Char -> Bool
f Char
c -> Match
m{ matchOffset = matchOffset m + n }
    Maybe (Char, Int)
_ -> Match
m{ matchOffset = -1 }
exec (Set (Int, Int), IntMap Regex)
_ Direction
Backward (MatchChar Char -> Bool
f) = (Match -> Match) -> Set Match -> Set Match
mapMatching ((Match -> Match) -> Set Match -> Set Match)
-> (Match -> Match) -> Set Match -> Set Match
forall a b. (a -> b) -> a -> b
$ \Match
m ->
  case ByteString -> Int -> Maybe Int
lastCharOffset (Match -> ByteString
matchBytes Match
m) (Match -> Int
matchOffset Match
m) of
    Maybe Int
Nothing  -> Match
m{ matchOffset = -1 }
    Just Int
off ->
      case ByteString -> Maybe (Char, Int)
U.decode (Int -> ByteString -> ByteString
B.drop Int
off (Match -> ByteString
matchBytes Match
m)) of
        Just (Char
c,Int
_) | Char -> Bool
f Char
c -> Match
m{ matchOffset = off }
        Maybe (Char, Int)
_                -> Match
m{ matchOffset = -1 }
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir (MatchConcat (MatchConcat Regex
r1 Regex
r2) Regex
r3) =
  (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir (Regex -> Regex -> Regex
MatchConcat Regex
r1 (Regex -> Regex -> Regex
MatchConcat Regex
r2 Regex
r3))
exec (Set (Int, Int), IntMap Regex)
cgs Direction
Forward (MatchConcat Regex
r1 Regex
r2) =
  \Set Match
ms ->
    let ms1 :: Set Match
ms1 = (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
Forward Regex
r1 Set Match
ms
     in if Set Match -> Bool
forall a. Set a -> Bool
Set.null Set Match
ms1
           then Set Match
ms1
           else (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
Forward Regex
r2 (Set Match -> Set Match
prune Set Match
ms1)
exec (Set (Int, Int), IntMap Regex)
cgs Direction
Backward (MatchConcat Regex
r1 Regex
r2) =
  (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
Backward Regex
r1 (Set Match -> Set Match)
-> (Set Match -> Set Match) -> Set Match -> Set Match
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
Backward Regex
r2
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir (MatchAlt Regex
r1 Regex
r2) = \Set Match
ms ->
  Set Match -> Set Match
dedup (Set Match -> Set Match) -> Set Match -> Set Match
forall a b. (a -> b) -> a -> b
$ (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
r1 (Word8 -> Set Match -> Set Match
addChoice Word8
0 Set Match
ms) Set Match -> Set Match -> Set Match
forall a. Semigroup a => a -> a -> a
<> (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
r2 (Word8 -> Set Match -> Set Match
addChoice Word8
1 Set Match
ms)
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir (MatchSome Regex
re) = (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Word8 -> Word8 -> Set Match -> Set Match
someLoop (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
re Word8
0 Word8
1
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir (MatchCapture Int
i Regex
re) =
  (Set Match -> Set Match -> Set Match)
-> Set Match -> Set (Set Match) -> Set Match
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Set Match -> Set Match -> Set Match
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Match
forall a. Set a
Set.empty (Set (Set Match) -> Set Match)
-> (Set Match -> Set (Set Match)) -> Set Match -> Set Match
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Match -> Set Match) -> Set Match -> Set (Set Match)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\Match
m ->
     (Match -> Match) -> Set Match -> Set Match
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Match -> Match -> Match
captureDifference Match
m) ((Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
re (Match -> Set Match
forall a. a -> Set a
Set.singleton Match
m)))
 where
    captureDifference :: Match -> Match -> Match
captureDifference Match
m Match
m' =
      let len :: Int
len = Match -> Int
matchOffset Match
m' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Match -> Int
matchOffset Match
m
      in  Match
m'{ matchCaptures = M.insert i (matchOffset m, len)
                                  (matchCaptures m') }
exec (Set (Int, Int), IntMap Regex)
_ Direction
dir (MatchCaptured Int
n Bool
caseSensitive) = (Match -> Match) -> Set Match -> Set Match
mapMatching Match -> Match
matchCaptured
 where
   matchCaptured :: Match -> Match
matchCaptured Match
m =
     case Int -> IntMap (Int, Int) -> Maybe (Int, Int)
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
n (Match -> IntMap (Int, Int)
matchCaptures Match
m) of
       Just (Int
offset, Int
len) ->
              let capture :: ByteString
capture = Int -> ByteString -> ByteString
B.take Int
len (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
offset (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Match -> ByteString
matchBytes Match
m
              in  case Direction
dir of
                     Direction
Forward
                       | Bool
caseSensitive
                       , ByteString -> ByteString -> Bool
B.isPrefixOf ByteString
capture
                           (Int -> ByteString -> ByteString
B.drop (Match -> Int
matchOffset Match
m) (Match -> ByteString
matchBytes Match
m))
                        -> Match
m{ matchOffset = matchOffset m + B.length capture }
                       | Bool -> Bool
not Bool
caseSensitive
                       , Just Int
len' <- String -> ByteString -> Maybe Int
ciPrefixLength (ByteString -> String
U.toString ByteString
capture)
                             (Int -> ByteString -> ByteString
B.drop (Match -> Int
matchOffset Match
m) (Match -> ByteString
matchBytes Match
m))
                        -> Match
m{ matchOffset = matchOffset m + len' }
                     Direction
Backward
                       | Bool
caseSensitive
                       , ByteString -> ByteString -> Bool
B.isSuffixOf ByteString
capture
                           (Int -> ByteString -> ByteString
B.take (Match -> Int
matchOffset Match
m) (Match -> ByteString
matchBytes Match
m))
                        -> Match
m{ matchOffset = matchOffset m - B.length capture }
                       | Bool -> Bool
not Bool
caseSensitive
                       , Just Int
off' <- String -> ByteString -> Int -> Maybe Int
ciSuffixOffset
                             (ShowS
forall a. [a] -> [a]
reverse (ByteString -> String
U.toString ByteString
capture))
                             (Match -> ByteString
matchBytes Match
m) (Match -> Int
matchOffset Match
m)
                        -> Match
m{ matchOffset = off' }
                     Direction
_  -> Match
m{ matchOffset = -1 }
       Maybe (Int, Int)
Nothing -> Match
m{ matchOffset = -1 }
exec (Set (Int, Int)
active, IntMap Regex
cgs) Direction
dir (Subroutine Int
i) =
  case Int -> IntMap Regex -> Maybe Regex
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap Regex
cgs of
    Maybe Regex
Nothing -> Set Match -> Set Match
forall a. a -> a
id  -- ignore references to nonexistent groups
    Just Regex
re' -> \Set Match
ms ->
      -- A subroutine that calls itself again without having consumed
      -- any input can never make progress: block re-entry at the same
      -- offset so that zero-progress recursion (e.g. `x|(?R)`) fails
      -- instead of looping forever.
      Set Match -> Set Match
dedup (Set Match -> Set Match) -> Set Match -> Set Match
forall a b. (a -> b) -> a -> b
$ [Set Match] -> Set Match
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
        [ (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
Set.insert (Int
i, Match -> Int
matchOffset Match
m) Set (Int, Int)
active, IntMap Regex
cgs) Direction
dir Regex
re'
            (Match -> Set Match
forall a. a -> Set a
Set.singleton Match
m)
        | Match
m <- Set Match -> [Match]
forall a. Set a -> [a]
Set.toList Set Match
ms
        , (Int
i, Match -> Int
matchOffset Match
m) (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (Int, Int)
active ]

-- Match one or more repetitions of a regex.  contB is the path code
-- appended when continuing with another repetition, stopB the one
-- appended when stopping: 0/1 for greedy, 1/0 for lazy repetitions,
-- so that the paths order the results the way a backtracking matcher
-- would find them.
someLoop :: (Set (Int, Int), M.IntMap Regex) -> Direction -> Regex
         -> Word8 -> Word8 -> Set Match -> Set Match
someLoop :: (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Word8 -> Word8 -> Set Match -> Set Match
someLoop (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
re !Word8
contB !Word8
stopB = \Set Match
ms0 ->
  let ms1 :: Set Match
ms1 = Set Match -> Set Match
dedup (Set Match -> Set Match) -> Set Match -> Set Match
forall a b. (a -> b) -> a -> b
$ (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
re Set Match
ms0  -- first, obligatory repetition
   in Set (Int, IntMap (Int, Int)) -> Set Match -> Set Match
go ((Match -> (Int, IntMap (Int, Int)))
-> Set Match -> Set (Int, IntMap (Int, Int))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Match -> (Int, IntMap (Int, Int))
stateKey Set Match
ms1) Set Match
ms1
 where
  go :: Set (Int, IntMap (Int, Int)) -> Set Match -> Set Match
go !Set (Int, IntMap (Int, Int))
seen Set Match
ms
    | Set Match -> Bool
forall a. Set a -> Bool
Set.null Set Match
ms = Set Match
forall a. Set a
Set.empty
    | Bool
otherwise =
        let ms' :: Set Match
ms' = Set Match -> Set Match
dedup (Set Match -> Set Match) -> Set Match -> Set Match
forall a b. (a -> b) -> a -> b
$ Set Match -> Set Match
prune (Set Match -> Set Match) -> Set Match -> Set Match
forall a b. (a -> b) -> a -> b
$ (Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int), IntMap Regex)
cgs Direction
dir Regex
re (Word8 -> Set Match -> Set Match
addChoice Word8
contB Set Match
ms)
            -- Drop matches that revisit an already-seen state: they
            -- have no new futures, and this guarantees termination
            -- when an iteration can match the empty string.
            new :: Set Match
new = (Match -> Bool) -> Set Match -> Set Match
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\Match
m -> Match -> (Int, IntMap (Int, Int))
stateKey Match
m (Int, IntMap (Int, Int)) -> Set (Int, IntMap (Int, Int)) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (Int, IntMap (Int, Int))
seen) Set Match
ms'
         in Word8 -> Set Match -> Set Match
addChoice Word8
stopB Set Match
ms Set Match -> Set Match -> Set Match
forall a. Semigroup a => a -> a -> a
<> Set (Int, IntMap (Int, Int)) -> Set Match -> Set Match
go (Set (Int, IntMap (Int, Int))
seen Set (Int, IntMap (Int, Int))
-> Set (Int, IntMap (Int, Int)) -> Set (Int, IntMap (Int, Int))
forall a. Semigroup a => a -> a -> a
<> (Match -> (Int, IntMap (Int, Int)))
-> Set Match -> Set (Int, IntMap (Int, Int))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Match -> (Int, IntMap (Int, Int))
stateKey Set Match
new) Set Match
new

atWordBoundary :: Match -> Bool
atWordBoundary :: Match -> Bool
atWordBoundary Match
m =
  case ByteString -> Int -> Maybe Int
lastCharOffset (Match -> ByteString
matchBytes Match
m) (Match -> Int
matchOffset Match
m) of
    Maybe Int
Nothing  -> Bool
True
    Just Int
off ->
      case ByteString -> String
U.toString (Int -> ByteString -> ByteString
B.drop Int
off (Match -> ByteString
matchBytes Match
m)) of
        (Char
cur:Char
next:String
_) -> Char -> Bool
isWordChar Char
cur Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Bool
isWordChar Char
next
        String
_ -> Bool
True

-- If the characters of the first argument match the beginning of the
-- bytestring case-insensitively, return the length in bytes of the
-- matching prefix.
ciPrefixLength :: String -> ByteString -> Maybe Int
ciPrefixLength :: String -> ByteString -> Maybe Int
ciPrefixLength [] ByteString
_ = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
ciPrefixLength (Char
c:String
cs) ByteString
bs =
  case ByteString -> Maybe (Char, Int)
U.decode ByteString
bs of
    Just (Char
d, Int
n) | Char -> Char
toLower Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
toLower Char
c ->
      (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ByteString -> Maybe Int
ciPrefixLength String
cs (Int -> ByteString -> ByteString
B.drop Int
n ByteString
bs)
    Maybe (Char, Int)
_ -> Maybe Int
forall a. Maybe a
Nothing

-- If the characters of the first argument (reversed) match the
-- characters just before the given offset case-insensitively, return
-- the offset at which the match begins.
ciSuffixOffset :: String -> ByteString -> Int -> Maybe Int
ciSuffixOffset :: String -> ByteString -> Int -> Maybe Int
ciSuffixOffset [] ByteString
_ Int
off = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
off
ciSuffixOffset (Char
c:String
cs) ByteString
bs Int
off =
  case ByteString -> Int -> Maybe Int
lastCharOffset ByteString
bs Int
off of
    Just Int
off' | Just (Char
d, Int
_) <- ByteString -> Maybe (Char, Int)
U.decode (Int -> ByteString -> ByteString
B.drop Int
off' ByteString
bs)
              , Char -> Char
toLower Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
toLower Char
c -> String -> ByteString -> Int -> Maybe Int
ciSuffixOffset String
cs ByteString
bs Int
off'
    Maybe Int
_ -> Maybe Int
forall a. Maybe a
Nothing

-- Return the offset of the start of the (UTF-8 encoded) character
-- that ends at (i.e., whose last byte is just before) offset n.
lastCharOffset :: ByteString -> Int -> Maybe Int
lastCharOffset :: ByteString -> Int -> Maybe Int
lastCharOffset ByteString
_ Int
0 = Maybe Int
forall a. Maybe a
Nothing
lastCharOffset ByteString
bs Int
n = Int -> Maybe Int
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
 where
  go :: Int -> Maybe Int
go !Int
k
    | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
    | Word8 -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
isContinuationByte (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
bs Int
k) = Int -> Maybe Int
go (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    | Bool
otherwise = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k
  isContinuationByte :: a -> Bool
isContinuationByte a
w = a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0b10000000 Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0b11000000

-- | Match a Regex against a (presumed UTF-8 encoded) ByteString,
-- returning the matched text and a map of (offset, size)
-- pairs for captures.  Note that all matches are from the
-- beginning of the string (a @^@ anchor is implicit).  As in
-- PCRE, the match returned is the first one that a backtracking
-- matcher would find (leftmost alternatives are preferred), which
-- is not necessarily the longest.  Note also that to avoid
-- pathological performance in certain cases, the matcher is limited
-- to considering 2000 possible matches at a time; when that
-- threshold is reached, it discards lower-priority matches.  Hence
-- certain regexes may incorrectly fail to match: e.g. @a*a{3000}$@
-- on a string of 3000 @a@s.
matchRegex :: Regex
           -> ByteString
           -> Maybe (ByteString, M.IntMap (Int, Int))
matchRegex :: Regex -> ByteString -> Maybe (ByteString, IntMap (Int, Int))
matchRegex Regex
re = IntMap Regex
-> Regex -> ByteString -> Maybe (ByteString, IntMap (Int, Int))
matchRegexWithGroups (Regex -> IntMap Regex
extractCapturingGroups Regex
re) Regex
re

-- | Like 'matchRegex', but takes the map of capturing groups (as
-- computed by 'extractCapturingGroups') as an argument, so that it
-- can be computed once per regex instead of once per match.  (The
-- map is only consulted for regexes containing subroutine calls
-- like @(?1)@ or @(?R)@.)
matchRegexWithGroups :: M.IntMap Regex
                     -> Regex
                     -> ByteString
                     -> Maybe (ByteString, M.IntMap (Int, Int))
matchRegexWithGroups :: IntMap Regex
-> Regex -> ByteString -> Maybe (ByteString, IntMap (Int, Int))
matchRegexWithGroups IntMap Regex
capturingGroups Regex
re ByteString
bs =
  Match -> (ByteString, IntMap (Int, Int))
toResult (Match -> (ByteString, IntMap (Int, Int)))
-> Maybe Match -> Maybe (ByteString, IntMap (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Match -> Maybe Match
forall a. Set a -> Maybe a
Set.lookupMin
             ((Set (Int, Int), IntMap Regex)
-> Direction -> Regex -> Set Match -> Set Match
exec (Set (Int, Int)
forall a. Set a
Set.empty, IntMap Regex
capturingGroups) Direction
Forward Regex
re
                (Match -> Set Match
forall a. a -> Set a
Set.singleton (ByteString -> Int -> IntMap (Int, Int) -> Path -> Match
Match ByteString
bs Int
0 IntMap (Int, Int)
forall a. IntMap a
M.empty Path
emptyPath)))
 where
   toResult :: Match -> (ByteString, IntMap (Int, Int))
toResult Match
m = (Int -> ByteString -> ByteString
B.take (Match -> Int
matchOffset Match
m) (Match -> ByteString
matchBytes Match
m), (Match -> IntMap (Int, Int)
matchCaptures Match
m))

-- | Extract the capturing groups of a regex, numbered as in the
-- regex, with the whole regex at key 0.
extractCapturingGroups :: Regex -> M.IntMap Regex
extractCapturingGroups :: Regex -> IntMap Regex
extractCapturingGroups Regex
regex = Int -> Regex -> IntMap Regex -> IntMap Regex
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
0 Regex
regex (Regex -> IntMap Regex
go Regex
regex)
 where
  -- Note: left-biased union means that with (?|...), which reuses
  -- group numbers, the first alternative's group wins.
  go :: Regex -> IntMap Regex
go (MatchSome Regex
re) = Regex -> IntMap Regex
go Regex
re
  go (MatchAlt Regex
re1 Regex
re2) = Regex -> IntMap Regex
go Regex
re1 IntMap Regex -> IntMap Regex -> IntMap Regex
forall a. Semigroup a => a -> a -> a
<> Regex -> IntMap Regex
go Regex
re2
  go (MatchConcat Regex
re1 Regex
re2) = Regex -> IntMap Regex
go Regex
re1 IntMap Regex -> IntMap Regex -> IntMap Regex
forall a. Semigroup a => a -> a -> a
<> Regex -> IntMap Regex
go Regex
re2
  go (MatchCapture Int
i Regex
re) = Int -> Regex -> IntMap Regex -> IntMap Regex
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
i Regex
re (Regex -> IntMap Regex
go Regex
re)
  go (AssertPositive Direction
_ Regex
re) = Regex -> IntMap Regex
go Regex
re
  go (AssertNegative Direction
_ Regex
re) = Regex -> IntMap Regex
go Regex
re
  go (Possessive Regex
re) = Regex -> IntMap Regex
go Regex
re
  go (Lazy Regex
re) = Regex -> IntMap Regex
go Regex
re
  go Regex
_ = IntMap Regex
forall a. Monoid a => a
mempty