{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Text.Regex.Pcre2.Internal where

import           Control.Applicative        (Alternative(..))
import           Control.Exception          hiding (TypeError)
import           Control.Monad.State.Strict
import           Data.Either                (partitionEithers)
import           Data.Function              ((&))
import           Data.Functor               ((<&>))
import           Data.Functor.Const         (Const(..))
import           Data.IORef
import           Data.IntMap.Strict         (IntMap)
import qualified Data.IntMap.Strict         as IM
import           Data.List                  (foldl', intercalate)
import           Data.List.NonEmpty         (NonEmpty(..))
import qualified Data.List.NonEmpty         as NE
import           Data.Monoid                (Alt(..), Any(..), Endo(..))
import           Data.Proxy                 (Proxy(..))
import           Data.Text                  (Text)
import qualified Data.Text                  as Text
import qualified Data.Text.Foreign          as Text
import           Data.Type.Bool             (If, type (||))
import           Data.Type.Equality         (type (==))
import           Data.Typeable              (cast)
import           Data.Void                  (Void, absurd)
import           Foreign
import           Foreign.C.Types
import qualified Foreign.Concurrent         as Conc
import           GHC.TypeLits               hiding (Text)
import qualified GHC.TypeLits               as TypeLits
import           System.IO.Unsafe           (unsafePerformIO)
import           Text.Regex.Pcre2.Foreign

-- * General utilities

-- | There is no @nullForeignPtr@ to pass to `withForeignPtr`, so we have to
-- fake it with a `Maybe`.
withForeignOrNullPtr :: Maybe (ForeignPtr a) -> (Ptr a -> IO b) -> IO b
withForeignOrNullPtr :: Maybe (ForeignPtr a) -> (Ptr a -> IO b) -> IO b
withForeignOrNullPtr = ((Ptr a -> IO b) -> IO b)
-> (ForeignPtr a -> (Ptr a -> IO b) -> IO b)
-> Maybe (ForeignPtr a)
-> (Ptr a -> IO b)
-> IO b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Ptr a -> IO b) -> Ptr a -> IO b
forall a b. (a -> b) -> a -> b
$ Ptr a
forall a. Ptr a
nullPtr) ForeignPtr a -> (Ptr a -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr

-- | Helper so we never leak untracked 'Ptr's.
mkForeignPtr :: (Ptr a -> IO ()) -> IO (Ptr a) -> IO (ForeignPtr a)
mkForeignPtr :: (Ptr a -> IO ()) -> IO (Ptr a) -> IO (ForeignPtr a)
mkForeignPtr Ptr a -> IO ()
finalize IO (Ptr a)
create = IO (Ptr a)
create IO (Ptr a) -> (Ptr a -> IO (ForeignPtr a)) -> IO (ForeignPtr a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr a -> IO () -> IO (ForeignPtr a)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
Conc.newForeignPtr (Ptr a -> IO () -> IO (ForeignPtr a))
-> (Ptr a -> IO ()) -> Ptr a -> IO (ForeignPtr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr a -> IO ()
finalize

-- | Helper so we never leak untracked 'FunPtr's.
mkFunPtr :: ForeignPtr b -> IO (FunPtr a) -> IO (FunPtr a)
mkFunPtr :: ForeignPtr b -> IO (FunPtr a) -> IO (FunPtr a)
mkFunPtr ForeignPtr b
anchor IO (FunPtr a)
create = do
    FunPtr a
fPtr <- IO (FunPtr a)
create
    ForeignPtr b -> IO () -> IO ()
forall a. ForeignPtr a -> IO () -> IO ()
Conc.addForeignPtrFinalizer ForeignPtr b
anchor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FunPtr a -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr a
fPtr
    FunPtr a -> IO (FunPtr a)
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr a
fPtr

safeLast :: [a] -> Maybe a
safeLast :: [a] -> Maybe a
safeLast [] = Maybe a
forall a. Maybe a
Nothing
safeLast [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. [a] -> a
last [a]
xs

bitOr :: (Foldable t, Bits a) => t a -> a
bitOr :: t a -> a
bitOr = (a -> a -> a) -> a -> t a -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
forall a. Bits a => a -> a -> a
(.|.) a
forall a. Bits a => a
zeroBits

-- | Equivalent to @flip fix@.
--
-- Used to express a recursive function of one argument that is called only once
-- on an initial value:
--
-- > let go x = ... in go x0
--
-- as:
--
-- > fix1 x0 $ \go x -> ...
fix1 :: a -> ((a -> b) -> a -> b) -> b
fix1 :: a -> ((a -> b) -> a -> b) -> b
fix1 a
x (a -> b) -> a -> b
f = ((a -> b) -> a -> b) -> a -> b
forall a. (a -> a) -> a
fix (a -> b) -> a -> b
f a
x

-- | Like `fix1`, but for a function of two arguments.  Currently unused.
fix2 :: a -> b -> ((a -> b -> c) -> a -> b -> c) -> c
fix2 :: a -> b -> ((a -> b -> c) -> a -> b -> c) -> c
fix2 a
x b
y (a -> b -> c) -> a -> b -> c
f = ((a -> b -> c) -> a -> b -> c) -> a -> b -> c
forall a. (a -> a) -> a
fix (a -> b -> c) -> a -> b -> c
f a
x b
y

-- | Like `fix1`, but for a function of three arguments.  Currently unused.
fix3 :: a -> b -> c -> ((a -> b -> c -> d) -> a -> b -> c -> d) -> d
fix3 :: a -> b -> c -> ((a -> b -> c -> d) -> a -> b -> c -> d) -> d
fix3 a
x b
y c
z (a -> b -> c -> d) -> a -> b -> c -> d
f = ((a -> b -> c -> d) -> a -> b -> c -> d) -> a -> b -> c -> d
forall a. (a -> a) -> a
fix (a -> b -> c -> d) -> a -> b -> c -> d
f a
x b
y c
z

-- ** Fast @Text@ slicing

data SliceRange = SliceRange
    {-# UNPACK #-} !Text.I16
    {-# UNPACK #-} !Text.I16

-- | Zero-copy slice a 'Text'.  An unset capture is represented by a
-- `pcre2_UNSET` range and is interpreted in this library as `Text.empty`.
thinSlice :: Text -> SliceRange -> Text
thinSlice :: Text -> SliceRange -> Text
thinSlice Text
text (SliceRange I16
off I16
offEnd)
    | I16
off I16 -> I16 -> Bool
forall a. Eq a => a -> a -> Bool
== PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
pcre2_UNSET = Text
Text.empty
    | Bool
otherwise                       = Text
text
        Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& I16 -> Text -> Text
Text.takeWord16 I16
offEnd
        Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& I16 -> Text -> Text
Text.dropWord16 I16
off

-- | Slice a 'Text', copying if it\'s less than half of the original.
slice :: Text -> SliceRange -> Text
slice :: Text -> SliceRange -> Text
slice Text
text SliceRange
sliceRange =
    let substring :: Text
substring = Text -> SliceRange -> Text
thinSlice Text
text SliceRange
sliceRange
    in if Text -> Int
Text.length Text
substring Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Text -> Int
Text.length Text
text Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
        then Text
substring
        else Text -> Text
Text.copy Text
substring

-- | Probably unnecessary, but unrestricted 'castPtr' feels dangerous.
class CastCUs a b | a -> b where
    castCUs :: Ptr a -> Ptr b
    castCUs = Ptr a -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr
    {-# INLINE castCUs #-}
instance CastCUs CUShort Word16
instance CastCUs Word16 CUShort

-- ** Lens types and utilities

type Lens'      s a = forall f. (Functor f)     => (a -> f a) -> s -> f s
type Traversal' s a = forall f. (Applicative f) => (a -> f a) -> s -> f s

type Getting r s a = (a -> Const r a) -> s -> Const r s

preview :: Getting (Alt Maybe a) s a -> s -> Maybe a
preview :: Getting (Alt Maybe a) s a -> s -> Maybe a
preview = Getting (Alt Maybe a) s a -> s -> Maybe a
forall (f :: * -> *) a s.
Alternative f =>
Getting (Alt f a) s a -> s -> f a
toAlternativeOf

view :: Getting a s a -> s -> a
view :: Getting a s a -> s -> a
view Getting a s a
l = Const a s -> a
forall a k (b :: k). Const a b -> a
getConst (Const a s -> a) -> (s -> Const a s) -> s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting a s a
l a -> Const a a
forall k a (b :: k). a -> Const a b
Const

to :: (s -> a) -> forall r. Getting r s a
to :: (s -> a) -> forall r. Getting r s a
to s -> a
k a -> Const r a
f = r -> Const r s
forall k a (b :: k). a -> Const a b
Const (r -> Const r s) -> (s -> r) -> s -> Const r s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const r a -> r
forall a k (b :: k). Const a b -> a
getConst (Const r a -> r) -> (s -> Const r a) -> s -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Const r a
f (a -> Const r a) -> (s -> a) -> s -> Const r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> a
k

has :: Getting Any s a -> s -> Bool
has :: Getting Any s a -> s -> Bool
has Getting Any s a
l = Any -> Bool
getAny (Any -> Bool) -> (s -> Any) -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const Any s -> Any
forall a k (b :: k). Const a b -> a
getConst (Const Any s -> Any) -> (s -> Const Any s) -> s -> Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Any s a
l (\a
_ -> Any -> Const Any a
forall k a (b :: k). a -> Const a b
Const (Any -> Const Any a) -> Any -> Const Any a
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True)

toListOf :: Getting (Endo [a]) s a -> s -> [a]
toListOf :: Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [a]) s a
l s
x = let build :: a -> Endo [a]
build = ([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (([a] -> [a]) -> Endo [a]) -> (a -> [a] -> [a]) -> a -> Endo [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) in Getting (Endo [a]) s (Endo [a]) -> s -> Endo [a]
forall a s. Getting a s a -> s -> a
view (Getting (Endo [a]) s a
l Getting (Endo [a]) s a
-> ((Endo [a] -> Const (Endo [a]) (Endo [a]))
    -> a -> Const (Endo [a]) a)
-> Getting (Endo [a]) s (Endo [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Endo [a]) -> forall r. Getting r a (Endo [a])
forall s a. (s -> a) -> forall r. Getting r s a
to a -> Endo [a]
forall a. a -> Endo [a]
build) s
x Endo [a] -> [a] -> [a]
forall a. Endo a -> a -> a
`appEndo` []

toAlternativeOf :: (Alternative f) => Getting (Alt f a) s a -> s -> f a
toAlternativeOf :: Getting (Alt f a) s a -> s -> f a
toAlternativeOf Getting (Alt f a) s a
l = let alt :: a -> Alt f a
alt = f a -> Alt f a
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (f a -> Alt f a) -> (a -> f a) -> a -> Alt f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure in Alt f a -> f a
forall k (f :: k -> *) (a :: k). Alt f a -> f a
getAlt (Alt f a -> f a) -> (s -> Alt f a) -> s -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Alt f a) s (Alt f a) -> s -> Alt f a
forall a s. Getting a s a -> s -> a
view (Getting (Alt f a) s a
l Getting (Alt f a) s a
-> ((Alt f a -> Const (Alt f a) (Alt f a))
    -> a -> Const (Alt f a) a)
-> Getting (Alt f a) s (Alt f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Alt f a) -> forall r. Getting r a (Alt f a)
forall s a. (s -> a) -> forall r. Getting r s a
to a -> Alt f a
forall a. a -> Alt f a
alt)

-- | See https://github.com/sjshuck/hs-pcre2/issues/17.
-- This should go away with https://github.com/sjshuck/hs-pcre2/issues/18.
toAlternativeOf1 :: (Alternative f) => Getting (Alt Maybe a) s a -> s -> f a
toAlternativeOf1 :: Getting (Alt Maybe a) s a -> s -> f a
toAlternativeOf1 Getting (Alt Maybe a) s a
l = f a -> (a -> f a) -> Maybe a -> f a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe f a
forall (f :: * -> *) a. Alternative f => f a
empty a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> f a) -> (s -> Maybe a) -> s -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Alt Maybe a) s a -> s -> Maybe a
forall a s. Getting (Alt Maybe a) s a -> s -> Maybe a
preview Getting (Alt Maybe a) s a
l

_headNE :: Lens' (NonEmpty a) a
_headNE :: (a -> f a) -> NonEmpty a -> f (NonEmpty a)
_headNE a -> f a
f (a
x :| [a]
xs) = a -> f a
f a
x f a -> (a -> NonEmpty a) -> f (NonEmpty a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

-- ** Streaming support

-- | A @FreeT@-style stream that can short-circuit.
data Stream b m a
    = StreamPure a
    | StreamYield b (Stream b m a)    -- ^ yield a value and keep going
    | StreamEffect (m (Stream b m a)) -- ^ have an effect and keep going
    | StreamStop                      -- ^ short-circuit
    deriving (a -> Stream b m b -> Stream b m a
(a -> b) -> Stream b m a -> Stream b m b
(forall a b. (a -> b) -> Stream b m a -> Stream b m b)
-> (forall a b. a -> Stream b m b -> Stream b m a)
-> Functor (Stream b m)
forall a b. a -> Stream b m b -> Stream b m a
forall a b. (a -> b) -> Stream b m a -> Stream b m b
forall b (m :: * -> *) a b.
Functor m =>
a -> Stream b m b -> Stream b m a
forall b (m :: * -> *) a b.
Functor m =>
(a -> b) -> Stream b m a -> Stream b m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Stream b m b -> Stream b m a
$c<$ :: forall b (m :: * -> *) a b.
Functor m =>
a -> Stream b m b -> Stream b m a
fmap :: (a -> b) -> Stream b m a -> Stream b m b
$cfmap :: forall b (m :: * -> *) a b.
Functor m =>
(a -> b) -> Stream b m a -> Stream b m b
Functor)

instance (Functor m) => Applicative (Stream b m) where
    pure :: a -> Stream b m a
pure = a -> Stream b m a
forall b (m :: * -> *) a. a -> Stream b m a
StreamPure
    StreamPure a -> b
f     <*> :: Stream b m (a -> b) -> Stream b m a -> Stream b m b
<*> Stream b m a
sx = a -> b
f (a -> b) -> Stream b m a -> Stream b m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream b m a
sx
    StreamYield b
y Stream b m (a -> b)
sf <*> Stream b m a
sx = b -> Stream b m b -> Stream b m b
forall b (m :: * -> *) a. b -> Stream b m a -> Stream b m a
StreamYield b
y (Stream b m b -> Stream b m b) -> Stream b m b -> Stream b m b
forall a b. (a -> b) -> a -> b
$ Stream b m (a -> b)
sf Stream b m (a -> b) -> Stream b m a -> Stream b m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stream b m a
sx
    StreamEffect m (Stream b m (a -> b))
msf <*> Stream b m a
sx = m (Stream b m b) -> Stream b m b
forall b (m :: * -> *) a. m (Stream b m a) -> Stream b m a
StreamEffect (m (Stream b m b) -> Stream b m b)
-> m (Stream b m b) -> Stream b m b
forall a b. (a -> b) -> a -> b
$ m (Stream b m (a -> b))
msf m (Stream b m (a -> b))
-> (Stream b m (a -> b) -> Stream b m b) -> m (Stream b m b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Stream b m (a -> b) -> Stream b m a -> Stream b m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stream b m a
sx)
    Stream b m (a -> b)
StreamStop       <*> Stream b m a
_  = Stream b m b
forall b (m :: * -> *) a. Stream b m a
StreamStop

instance (Functor m) => Monad (Stream b m) where
    StreamPure a
x     >>= :: Stream b m a -> (a -> Stream b m b) -> Stream b m b
>>= a -> Stream b m b
f = a -> Stream b m b
f a
x
    StreamYield b
y Stream b m a
sx >>= a -> Stream b m b
f = b -> Stream b m b -> Stream b m b
forall b (m :: * -> *) a. b -> Stream b m a -> Stream b m a
StreamYield b
y (Stream b m b -> Stream b m b) -> Stream b m b -> Stream b m b
forall a b. (a -> b) -> a -> b
$ Stream b m a
sx Stream b m a -> (a -> Stream b m b) -> Stream b m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Stream b m b
f
    StreamEffect m (Stream b m a)
msx >>= a -> Stream b m b
f = m (Stream b m b) -> Stream b m b
forall b (m :: * -> *) a. m (Stream b m a) -> Stream b m a
StreamEffect (m (Stream b m b) -> Stream b m b)
-> m (Stream b m b) -> Stream b m b
forall a b. (a -> b) -> a -> b
$ m (Stream b m a)
msx m (Stream b m a)
-> (Stream b m a -> Stream b m b) -> m (Stream b m b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Stream b m a -> (a -> Stream b m b) -> Stream b m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Stream b m b
f)
    Stream b m a
StreamStop       >>= a -> Stream b m b
_ = Stream b m b
forall b (m :: * -> *) a. Stream b m a
StreamStop

instance MonadTrans (Stream b) where
    lift :: m a -> Stream b m a
lift = m (Stream b m a) -> Stream b m a
forall b (m :: * -> *) a. m (Stream b m a) -> Stream b m a
StreamEffect (m (Stream b m a) -> Stream b m a)
-> (m a -> m (Stream b m a)) -> m a -> Stream b m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Stream b m a) -> m a -> m (Stream b m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Stream b m a
forall b (m :: * -> *) a. a -> Stream b m a
StreamPure

instance (MonadIO m) => MonadIO (Stream b m) where
    liftIO :: IO a -> Stream b m a
liftIO = m a -> Stream b m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Stream b m a) -> (IO a -> m a) -> IO a -> Stream b m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

streamYield :: b -> Stream b m ()
streamYield :: b -> Stream b m ()
streamYield b
y = b -> Stream b m () -> Stream b m ()
forall b (m :: * -> *) a. b -> Stream b m a -> Stream b m a
StreamYield b
y (Stream b m () -> Stream b m ()) -> Stream b m () -> Stream b m ()
forall a b. (a -> b) -> a -> b
$ () -> Stream b m ()
forall b (m :: * -> *) a. a -> Stream b m a
StreamPure ()

-- | Effectfully transform yielded values.
mapMS :: (Functor m) => (b -> m c) -> Stream b m a -> Stream c m a
mapMS :: (b -> m c) -> Stream b m a -> Stream c m a
mapMS b -> m c
f = ((Stream b m a -> Stream c m a) -> Stream b m a -> Stream c m a)
-> Stream b m a -> Stream c m a
forall a. (a -> a) -> a
fix (((Stream b m a -> Stream c m a) -> Stream b m a -> Stream c m a)
 -> Stream b m a -> Stream c m a)
-> ((Stream b m a -> Stream c m a) -> Stream b m a -> Stream c m a)
-> Stream b m a
-> Stream c m a
forall a b. (a -> b) -> a -> b
$ \Stream b m a -> Stream c m a
go -> \case
    StreamPure a
x     -> a -> Stream c m a
forall b (m :: * -> *) a. a -> Stream b m a
StreamPure a
x
    StreamYield b
y Stream b m a
sx -> m (Stream c m a) -> Stream c m a
forall b (m :: * -> *) a. m (Stream b m a) -> Stream b m a
StreamEffect (m (Stream c m a) -> Stream c m a)
-> m (Stream c m a) -> Stream c m a
forall a b. (a -> b) -> a -> b
$ b -> m c
f b
y m c -> (c -> Stream c m a) -> m (Stream c m a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \c
y' -> c -> Stream c m a -> Stream c m a
forall b (m :: * -> *) a. b -> Stream b m a -> Stream b m a
StreamYield c
y' (Stream c m a -> Stream c m a) -> Stream c m a -> Stream c m a
forall a b. (a -> b) -> a -> b
$ Stream b m a -> Stream c m a
go Stream b m a
sx
    StreamEffect m (Stream b m a)
ms  -> m (Stream c m a) -> Stream c m a
forall b (m :: * -> *) a. m (Stream b m a) -> Stream b m a
StreamEffect (m (Stream c m a) -> Stream c m a)
-> m (Stream c m a) -> Stream c m a
forall a b. (a -> b) -> a -> b
$ Stream b m a -> Stream c m a
go (Stream b m a -> Stream c m a)
-> m (Stream b m a) -> m (Stream c m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Stream b m a)
ms
    Stream b m a
StreamStop       -> Stream c m a
forall b (m :: * -> *) a. Stream b m a
StreamStop

-- | Unsafely, lazily tear down a `Stream` into a pure list of values yielded.
-- The stream must be infinite in the sense of it only terminating due to
-- explicit `StreamStop`.
unsafeLazyStreamToList :: Stream b IO Void -> [b]
unsafeLazyStreamToList :: Stream b IO Void -> [b]
unsafeLazyStreamToList = ((Stream b IO Void -> [b]) -> Stream b IO Void -> [b])
-> Stream b IO Void -> [b]
forall a. (a -> a) -> a
fix (((Stream b IO Void -> [b]) -> Stream b IO Void -> [b])
 -> Stream b IO Void -> [b])
-> ((Stream b IO Void -> [b]) -> Stream b IO Void -> [b])
-> Stream b IO Void
-> [b]
forall a b. (a -> b) -> a -> b
$ \Stream b IO Void -> [b]
continue -> \case
    StreamPure Void
v    -> Void -> [b]
forall a. Void -> a
absurd Void
v
    StreamYield b
y Stream b IO Void
s -> b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Stream b IO Void -> [b]
continue Stream b IO Void
s
    StreamEffect IO (Stream b IO Void)
ms -> Stream b IO Void -> [b]
continue (Stream b IO Void -> [b]) -> Stream b IO Void -> [b]
forall a b. (a -> b) -> a -> b
$ IO (Stream b IO Void) -> Stream b IO Void
forall a. IO a -> a
unsafePerformIO IO (Stream b IO Void)
ms
    Stream b IO Void
StreamStop      -> []

-- * Assembling inputs into @Matcher@s and @Subber@s

-- | A matching function where all inputs and auxilliary data structures have
-- been \"compiled\".  It takes a subject a produces a stream of match results
-- corresponding to a global match.
--
-- The actual values of type @Ptr Pcre2_match_data@ will be equal within each
-- global match; they represent the states of the C data at moments in time, and
-- are intended to be composed with another streaming transformation before
-- being subjected to teardown and `unsafePerformIO`.
type Matcher = Text -> Stream (Ptr Pcre2_match_data) IO Void

-- | A substitution function.  It takes a subject and produces the number of
-- substitutions performed (0 or 1, or more in the presence of `SubGlobal`)
-- along with the transformed subject.  Currently the number is unused.
type Subber = Text -> IO (CInt, Text)

-- ** Options

-- | A `Monoid` representing nearly every facility PCRE2 presents for tweaking
-- the behavior of regex compilation and execution.
--
-- All library functions that take options have the suffix @Opt@ in their names;
-- for each of them, there\'s also a non-@Opt@ convenience function that simply
-- has the (unexported) `mempty` option.  For many uses, options won\'t be
-- needed.
--
-- Some options can be enabled by special character sequences in the pattern as
-- an alternative to specifying them as an `Option`.  See `Caseless` for
-- example.
--
-- Documentation is scant here.  For more complete, accurate information,
-- including discussions of corner cases arising from specific combinations of
-- options and pattern items, please see the [C API
-- documentation](https://pcre.org/current/doc/html/pcre2api.html).
data Option
    = NoOptions -- ^ `mempty`
    | TwoOptions Option Option -- ^ `<>`

    | AllowEmptyClass -- ^ Make @[]@ not match anything, rather than counting
    -- the @]@ as the first character of the class.
    | AltBsux -- ^ Like `AltBsuxLegacy`, except with ECMAScript 6 hex literal
    -- feature for @\\u@.
    | AltBsuxLegacy -- ^ Behave like ECMAScript 5 for @\\U@, @\\u@, and @\\x@.
    -- See 'AltBsux'.
    | AltCircumflex -- ^ Match a @^@ after a newline at the end of the subject.
    -- Only relevant in multiline mode.
    | AltVerbNames -- ^ Enable backslash escapes in verb names.  E.g.,
    -- @(*MARK:L\\(O\\)L)@.
    | Anchored -- ^ Equivalent to beginning pattern with @^@.
    | AutoCallout -- ^ Run callout for every pattern item.  Only relevant if a
    -- callout is set.
    | BadEscapeIsLiteral -- ^ Do not throw an error for unrecognized or
    -- malformed escapes.  /\"This is a dangerous option.\"/
    | Bsr Bsr -- ^ Override what @\\R@ matches (default given by `defaultBsr`).
    | Caseless -- ^ Case-insensitive match.  Equivalent to @(?i)@.
    | DepthLimit Word32 -- ^ Override maximum depth of nested backtracking
    -- (default given by `defaultDepthLimit`).  Equivalent to
    -- @(*LIMIT_DEPTH=@/number/@)@.
    | DollarEndOnly -- ^ Don\'t match @$@ with a newline at the end of the
    -- subject.
    | DotAll -- ^ A dot also matches a (single-character) newline.  Equivalent
    -- to @(?s)@.
    | DupNames -- ^ Allow non-unique capture names.
    | EndAnchored -- ^ More or less like ending pattern with @$@.
    | EscapedCrIsLf -- ^ Interpret @\\r@ as @\\n@.
    | Extended -- ^ In the pattern, ignore whitespace, and enable comments
    -- starting with @#@.  Equivalent to @(?x)@.
    | ExtendedMore -- ^ Like `Extended` but also ignore spaces and tabs within
    -- @[]@.
    | FirstLine -- ^ The match must begin in the first line of the subject.
    | HeapLimit Word32 -- ^ Override maximum heap memory (in kibibytes) used to
    -- hold backtracking information (default given by `defaultHeapLimit`).
    -- Equivalent to @(*LIMIT_HEAP=@/number/@)@.
    | Literal -- ^ Treat the pattern as a literal string.
    | MatchLimit Word32 -- ^ Override maximum value of the main matching loop\'s
    -- internal counter (default given by `defaultMatchLimit`), as a simple CPU
    -- throttle.  Equivalent to @(*LIMIT_MATCH=@/number/@)@.
    | MatchLine -- ^ Only match complete lines.  Equivalent to bracketing the
    -- pattern with @^(?:@/pattern/@)$@.
    | MatchUnsetBackRef -- ^ A backreference to an unset capture group matches
    -- an empty string.
    | MatchWord -- ^ Only match subjects that have word boundaries at the
    -- beginning and end.  Equivalent to bracketing the pattern with
    -- @\\b(?:@/pattern/@)\\b@.
    | MaxPatternLength Word64 -- ^ Default is `maxBound`.
    | Multiline -- ^ @^@ and @$@ mean \"beginning\/end of a line\" rather than
    -- \"beginning\/end of the subject\".  Equivalent to @(?m)@.
    | NeverBackslashC -- ^ Do not allow the unsafe @\\C@ sequence.
    | NeverUcp -- ^ Don\'t count Unicode characters in some character classes
    -- such as @\\d@.  Overrides @(*UCP)@.
    | Newline Newline -- ^ Override what a newline is (default given by
    -- `defaultNewline`).  Equivalent to @(*CRLF)@ or similar.
    | NoAutoCapture -- ^ Disable numbered capturing parentheses.
    | NoAutoPossess -- ^ Turn off some optimizations, possibly resulting in some
    -- callouts not being called.
    | NoDotStarAnchor -- ^ Turn off an optimization involving @.*@, possibly
    -- resulting in some callouts not being called.
    | NoStartOptimize -- ^ Turn off some optimizations normally performed at the
    -- beginning of a pattern.
    | NotBol -- ^ First character of subject is not the __b__eginning __o__f
    -- __l__ine.  Only affects @^@.
    | NotEmpty -- ^ The 0th capture doesn\'t match if it would be empty.
    | NotEmptyAtStart -- ^ The 0th capture doesn\'t match if it would be empty
    -- and at the beginning of the subject.
    | NotEol -- ^ End of subject is not the __e__nd __o__f __l__ine.  Only
    -- affects @$@.
    | OffsetLimit Word64 -- ^ Limit how far an unanchored search can advance in
    -- the subject.
    | ParensLimit Word32 -- ^ Override max depth of nested parentheses (default
    -- given by `defaultParensLimit`).
    | PartialHard -- ^ If the subject ends without finding a complete match,
    -- stop trying alternatives and signal a partial match immediately.
    -- Currently we do this by throwing a `Pcre2Exception` but we should do
    -- better.
    | PartialSoft -- ^ If the subject ends and all alternatives have been tried,
    -- but no complete match is found, signal a partial match.  Currently we do
    -- this by throwing a `Pcre2Exception` but we should do better.
    | SubGlobal -- ^ /Affects `subOpt`./  Replace all, rather than just the
    -- first.
    | SubLiteral -- ^ /Affects `subOpt`./  Treat the replacement as a literal
    -- string.
    | SubReplacementOnly -- ^ /Affects `subOpt`./  Return just the rendered
    -- replacement instead of it within the subject.  With `SubGlobal`, all
    -- results are concatenated.
    | SubUnknownUnset -- ^ /Affects `subOpt`./  References in the replacement to
    -- non-existent captures don\'t error but are treated as unset.
    | SubUnsetEmpty -- ^ /Affects `subOpt`./  References in the replacement to
    -- unset captures don\'t error but are treated as empty.
    | Ucp -- ^ Count Unicode characters in some character classes such as @\\d@.
    -- Incompatible with `NeverUcp`.
    | Ungreedy -- ^ Invert the effect of @?@.  Without it, quantifiers are
    -- non-greedy; with it, they are greedy.  Equivalent to @(?U)@.
    | UnsafeCallout (CalloutInfo -> IO CalloutResult) -- ^ Run the given callout
    -- at every callout point
    -- (see [the docs](https://pcre.org/current/doc/html/pcre2callout.html) for
    -- more info).  Multiples of this option before the rightmost are ignored.
    --
    -- /NOTE: The callout is run via `unsafePerformIO` within pure code!/
    | UnsafeCompileRecGuard (Int -> IO Bool) -- ^ Run the given guard on every
    -- new descent into a level of parentheses, passing the current depth as
    -- argument.  Returning @False@ aborts pattern compilation with an
    -- exception.  Multiples of this option before the rightmost are ignored.
    --
    -- /NOTE: Currently (PCRE2 version 10\.35) patterns seem to be parsed in/
    -- /two passes, both times triggering the recursion guard.  Also, it is/
    -- /triggered at the beginning of the pattern, passing 0.  None of this is/
    -- /documented; expect the unexpected in the presence of side effects!/
    --
    -- /NOTE: The guard is run via `unsafePerformIO` within pure code!/
    | UnsafeSubCallout (SubCalloutInfo -> IO SubCalloutResult) -- ^ Run the
    -- given callout on every substitution.  This is at most once unless
    -- `SubGlobal` is set.  Multiples of this option before the rightmost are
    -- ignored.
    --
    -- /NOTE: The callout is run via `unsafePerformIO` within pure code!/
    | Utf -- ^ Treat both the pattern and subject as UTF rather than fixed-width
    -- 16-bit code units.

instance Semigroup Option where
    <> :: Option -> Option -> Option
(<>) = Option -> Option -> Option
TwoOptions

instance Monoid Option where
    mempty :: Option
mempty = Option
NoOptions

-- | What @\\R@, __b__ack__s__lash __R__, can mean.
data Bsr
    = BsrUnicode -- ^ any Unicode line ending sequence
    | BsrAnyCrlf -- ^ @\\r@, @\\n@, or @\\r\\n@
    deriving (Bsr -> Bsr -> Bool
(Bsr -> Bsr -> Bool) -> (Bsr -> Bsr -> Bool) -> Eq Bsr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bsr -> Bsr -> Bool
$c/= :: Bsr -> Bsr -> Bool
== :: Bsr -> Bsr -> Bool
$c== :: Bsr -> Bsr -> Bool
Eq, Int -> Bsr -> ShowS
[Bsr] -> ShowS
Bsr -> String
(Int -> Bsr -> ShowS)
-> (Bsr -> String) -> ([Bsr] -> ShowS) -> Show Bsr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bsr] -> ShowS
$cshowList :: [Bsr] -> ShowS
show :: Bsr -> String
$cshow :: Bsr -> String
showsPrec :: Int -> Bsr -> ShowS
$cshowsPrec :: Int -> Bsr -> ShowS
Show)

-- | C to Haskell.
bsrFromC :: CUInt -> Bsr
bsrFromC :: CUInt -> Bsr
bsrFromC CUInt
x
    | CUInt
x CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
pcre2_BSR_UNICODE = Bsr
BsrUnicode
    | CUInt
x CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
pcre2_BSR_ANYCRLF = Bsr
BsrAnyCrlf
    | Bool
otherwise              = String -> Bsr
forall a. HasCallStack => String -> a
error (String -> Bsr) -> String -> Bsr
forall a b. (a -> b) -> a -> b
$ String
"bsrFromC: bad value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CUInt -> String
forall a. Show a => a -> String
show CUInt
x

-- | Haskell to C.
bsrToC :: Bsr -> CUInt
bsrToC :: Bsr -> CUInt
bsrToC Bsr
BsrUnicode = CUInt
pcre2_BSR_UNICODE
bsrToC Bsr
BsrAnyCrlf = CUInt
pcre2_BSR_ANYCRLF

-- | What\'s considered a newline.
data Newline
    = NewlineCr      -- ^ @\\r@ only
    | NewlineLf      -- ^ @\\n@ only
    | NewlineCrlf    -- ^ @\\r\\n@ only
    | NewlineAny     -- ^ any Unicode line ending sequence
    | NewlineAnyCrlf -- ^ any of the above
    | NewlineNul     -- ^ binary zero
    deriving (Newline -> Newline -> Bool
(Newline -> Newline -> Bool)
-> (Newline -> Newline -> Bool) -> Eq Newline
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Newline -> Newline -> Bool
$c/= :: Newline -> Newline -> Bool
== :: Newline -> Newline -> Bool
$c== :: Newline -> Newline -> Bool
Eq, Int -> Newline -> ShowS
[Newline] -> ShowS
Newline -> String
(Int -> Newline -> ShowS)
-> (Newline -> String) -> ([Newline] -> ShowS) -> Show Newline
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Newline] -> ShowS
$cshowList :: [Newline] -> ShowS
show :: Newline -> String
$cshow :: Newline -> String
showsPrec :: Int -> Newline -> ShowS
$cshowsPrec :: Int -> Newline -> ShowS
Show)

-- | C to Haskell.
newlineFromC :: CUInt -> Newline
newlineFromC :: CUInt -> Newline
newlineFromC CUInt
x
    | CUInt
x CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
pcre2_NEWLINE_CR      = Newline
NewlineCr
    | CUInt
x CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
pcre2_NEWLINE_LF      = Newline
NewlineLf
    | CUInt
x CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
pcre2_NEWLINE_CRLF    = Newline
NewlineCrlf
    | CUInt
x CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
pcre2_NEWLINE_ANY     = Newline
NewlineAny
    | CUInt
x CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
pcre2_NEWLINE_ANYCRLF = Newline
NewlineAnyCrlf
    | CUInt
x CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
pcre2_NEWLINE_NUL     = Newline
NewlineNul
    | Bool
otherwise                  = String -> Newline
forall a. HasCallStack => String -> a
error (String -> Newline) -> String -> Newline
forall a b. (a -> b) -> a -> b
$ String
"newlineFromC: bad value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CUInt -> String
forall a. Show a => a -> String
show CUInt
x

-- | Haskell to C.
newlineToC :: Newline -> CUInt
newlineToC :: Newline -> CUInt
newlineToC Newline
NewlineCr      = CUInt
pcre2_NEWLINE_CR
newlineToC Newline
NewlineLf      = CUInt
pcre2_NEWLINE_LF
newlineToC Newline
NewlineCrlf    = CUInt
pcre2_NEWLINE_CRLF
newlineToC Newline
NewlineAny     = CUInt
pcre2_NEWLINE_ANY
newlineToC Newline
NewlineAnyCrlf = CUInt
pcre2_NEWLINE_ANYCRLF
newlineToC Newline
NewlineNul     = CUInt
pcre2_NEWLINE_NUL

-- | Input for user-defined callouts.
data CalloutInfo
    = CalloutInfo {
        -- | The index of which callout point we\'re on.
        CalloutInfo -> CalloutIndex
calloutIndex :: CalloutIndex,
        -- | The captures that have been set so far.
        CalloutInfo -> NonEmpty (Maybe Text)
calloutCaptures :: NonEmpty (Maybe Text),
        -- | The original subject.
        CalloutInfo -> Text
calloutSubject :: Text,
        -- | The name of the most recently passed @(*MARK)@, @(*PRUNE)@, or
        -- @(*THEN)@, if any.
        CalloutInfo -> Maybe Text
calloutMark :: Maybe Text,
        -- | Is this the first callout after the start of matching?
        CalloutInfo -> Bool
calloutIsFirst :: Bool,
        -- | Has a backtrack occurred since the previous callout, or the
        -- beginning of matching if no previous callouts?
        CalloutInfo -> Bool
calloutBacktracked :: Bool}
    deriving (Int -> CalloutInfo -> ShowS
[CalloutInfo] -> ShowS
CalloutInfo -> String
(Int -> CalloutInfo -> ShowS)
-> (CalloutInfo -> String)
-> ([CalloutInfo] -> ShowS)
-> Show CalloutInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CalloutInfo] -> ShowS
$cshowList :: [CalloutInfo] -> ShowS
show :: CalloutInfo -> String
$cshow :: CalloutInfo -> String
showsPrec :: Int -> CalloutInfo -> ShowS
$cshowsPrec :: Int -> CalloutInfo -> ShowS
Show, CalloutInfo -> CalloutInfo -> Bool
(CalloutInfo -> CalloutInfo -> Bool)
-> (CalloutInfo -> CalloutInfo -> Bool) -> Eq CalloutInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CalloutInfo -> CalloutInfo -> Bool
$c/= :: CalloutInfo -> CalloutInfo -> Bool
== :: CalloutInfo -> CalloutInfo -> Bool
$c== :: CalloutInfo -> CalloutInfo -> Bool
Eq)

-- | What caused the callout.
data CalloutIndex
    = CalloutNumber Int -- ^ Numerical callout.
    | CalloutName Text -- ^ String callout.
    | CalloutAuto Int Int -- ^ The item located at this half-open range of
    -- offsets within the pattern.  See `AutoCallout`.
    deriving (Int -> CalloutIndex -> ShowS
[CalloutIndex] -> ShowS
CalloutIndex -> String
(Int -> CalloutIndex -> ShowS)
-> (CalloutIndex -> String)
-> ([CalloutIndex] -> ShowS)
-> Show CalloutIndex
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CalloutIndex] -> ShowS
$cshowList :: [CalloutIndex] -> ShowS
show :: CalloutIndex -> String
$cshow :: CalloutIndex -> String
showsPrec :: Int -> CalloutIndex -> ShowS
$cshowsPrec :: Int -> CalloutIndex -> ShowS
Show, CalloutIndex -> CalloutIndex -> Bool
(CalloutIndex -> CalloutIndex -> Bool)
-> (CalloutIndex -> CalloutIndex -> Bool) -> Eq CalloutIndex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CalloutIndex -> CalloutIndex -> Bool
$c/= :: CalloutIndex -> CalloutIndex -> Bool
== :: CalloutIndex -> CalloutIndex -> Bool
$c== :: CalloutIndex -> CalloutIndex -> Bool
Eq)

-- | Callout functions return one of these values, which dictates what happens
-- next in the match.
data CalloutResult
    = CalloutProceed -- ^ Keep going.
    | CalloutNoMatchHere -- ^ Fail the current capture, but not the whole match.
    -- For example, backtracking may occur.
    | CalloutNoMatch -- ^ Fail the whole match.
    deriving (Int -> CalloutResult -> ShowS
[CalloutResult] -> ShowS
CalloutResult -> String
(Int -> CalloutResult -> ShowS)
-> (CalloutResult -> String)
-> ([CalloutResult] -> ShowS)
-> Show CalloutResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CalloutResult] -> ShowS
$cshowList :: [CalloutResult] -> ShowS
show :: CalloutResult -> String
$cshow :: CalloutResult -> String
showsPrec :: Int -> CalloutResult -> ShowS
$cshowsPrec :: Int -> CalloutResult -> ShowS
Show, CalloutResult -> CalloutResult -> Bool
(CalloutResult -> CalloutResult -> Bool)
-> (CalloutResult -> CalloutResult -> Bool) -> Eq CalloutResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CalloutResult -> CalloutResult -> Bool
$c/= :: CalloutResult -> CalloutResult -> Bool
== :: CalloutResult -> CalloutResult -> Bool
$c== :: CalloutResult -> CalloutResult -> Bool
Eq)

-- | Input for user-defined substitution callouts.
data SubCalloutInfo
    = SubCalloutInfo {
        -- | The 1-based index of which substitution we\'re on.  Only goes past
        -- 1 during global substitutions.
        SubCalloutInfo -> Int
subCalloutSubsCount :: Int,
        -- | The captures that have been set so far.
        SubCalloutInfo -> NonEmpty (Maybe Text)
subCalloutCaptures :: NonEmpty (Maybe Text),
        -- | The original subject.
        SubCalloutInfo -> Text
subCalloutSubject :: Text,
        -- | The replacement.
        SubCalloutInfo -> Text
subCalloutReplacement :: Text}
    deriving (Int -> SubCalloutInfo -> ShowS
[SubCalloutInfo] -> ShowS
SubCalloutInfo -> String
(Int -> SubCalloutInfo -> ShowS)
-> (SubCalloutInfo -> String)
-> ([SubCalloutInfo] -> ShowS)
-> Show SubCalloutInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubCalloutInfo] -> ShowS
$cshowList :: [SubCalloutInfo] -> ShowS
show :: SubCalloutInfo -> String
$cshow :: SubCalloutInfo -> String
showsPrec :: Int -> SubCalloutInfo -> ShowS
$cshowsPrec :: Int -> SubCalloutInfo -> ShowS
Show, SubCalloutInfo -> SubCalloutInfo -> Bool
(SubCalloutInfo -> SubCalloutInfo -> Bool)
-> (SubCalloutInfo -> SubCalloutInfo -> Bool) -> Eq SubCalloutInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubCalloutInfo -> SubCalloutInfo -> Bool
$c/= :: SubCalloutInfo -> SubCalloutInfo -> Bool
== :: SubCalloutInfo -> SubCalloutInfo -> Bool
$c== :: SubCalloutInfo -> SubCalloutInfo -> Bool
Eq)

-- | Substitution callout functions return one of these values, which dictates
-- what happens next in the substitution.
data SubCalloutResult
    = SubCalloutAccept -- ^ Succeed, and keep going if in global mode.
    | SubCalloutSkip -- ^ Do not perform this substitution, but keep going if in
    -- global mode.
    | SubCalloutAbort -- ^ Do not perform this or any subsequent substitutions.
    deriving (Int -> SubCalloutResult -> ShowS
[SubCalloutResult] -> ShowS
SubCalloutResult -> String
(Int -> SubCalloutResult -> ShowS)
-> (SubCalloutResult -> String)
-> ([SubCalloutResult] -> ShowS)
-> Show SubCalloutResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubCalloutResult] -> ShowS
$cshowList :: [SubCalloutResult] -> ShowS
show :: SubCalloutResult -> String
$cshow :: SubCalloutResult -> String
showsPrec :: Int -> SubCalloutResult -> ShowS
$cshowsPrec :: Int -> SubCalloutResult -> ShowS
Show, SubCalloutResult -> SubCalloutResult -> Bool
(SubCalloutResult -> SubCalloutResult -> Bool)
-> (SubCalloutResult -> SubCalloutResult -> Bool)
-> Eq SubCalloutResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubCalloutResult -> SubCalloutResult -> Bool
$c/= :: SubCalloutResult -> SubCalloutResult -> Bool
== :: SubCalloutResult -> SubCalloutResult -> Bool
$c== :: SubCalloutResult -> SubCalloutResult -> Bool
Eq)

-- ** Lower-level representation of options and C data

type CompileContext = ForeignPtr Pcre2_compile_context
type Code           = ForeignPtr Pcre2_code
type MatchContext   = ForeignPtr Pcre2_match_context
type MatchData      = ForeignPtr Pcre2_match_data

-- | An `Option` can result in multiple \"plans\".
applyOption :: Option -> [AppliedOption]
applyOption :: Option -> [AppliedOption]
applyOption = \case
    Option
NoOptions            -> []
    TwoOptions Option
opt0 Option
opt1 -> Option -> [AppliedOption]
applyOption Option
opt0 [AppliedOption] -> [AppliedOption] -> [AppliedOption]
forall a. [a] -> [a] -> [a]
++ Option -> [AppliedOption]
applyOption Option
opt1

    -- CompileOption
    Option
AllowEmptyClass   -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_ALLOW_EMPTY_CLASS]
    Option
AltBsuxLegacy     -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_ALT_BSUX]
    Option
AltCircumflex     -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_ALT_CIRCUMFLEX]
    Option
AltVerbNames      -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_ALT_VERBNAMES]
    Option
Anchored          -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_ANCHORED]
    Option
AutoCallout       -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_AUTO_CALLOUT]
    Option
Caseless          -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_CASELESS]
    Option
DollarEndOnly     -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_DOLLAR_ENDONLY]
    Option
DotAll            -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_DOTALL]
    Option
DupNames          -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_DUPNAMES]
    Option
EndAnchored       -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_ENDANCHORED]
    Option
Extended          -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_EXTENDED]
    Option
ExtendedMore      -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_EXTENDED_MORE]
    Option
FirstLine         -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_FIRSTLINE]
    Option
Literal           -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_LITERAL]
    Option
MatchUnsetBackRef -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_MATCH_UNSET_BACKREF]
    Option
Multiline         -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_MULTILINE]
    Option
NeverBackslashC   -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_NEVER_BACKSLASH_C]
    Option
NeverUcp          -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_NEVER_UCP]
    Option
NoAutoCapture     -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_NO_AUTO_CAPTURE]
    Option
NoAutoPossess     -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_NO_AUTO_POSSESS]
    Option
NoDotStarAnchor   -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_NO_DOTSTAR_ANCHOR]
    Option
NoStartOptimize   -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_NO_START_OPTIMIZE]
    Option
Ucp               -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_UCP]
    Option
Ungreedy          -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_UNGREEDY]
    Option
Utf               -> [CUInt -> AppliedOption
CompileOption CUInt
pcre2_UTF]

    -- ExtraCompileOption
    Option
AltBsux            -> [CUInt -> AppliedOption
CompileExtraOption CUInt
pcre2_EXTRA_ALT_BSUX]
    Option
BadEscapeIsLiteral -> [CUInt -> AppliedOption
CompileExtraOption CUInt
pcre2_EXTRA_BAD_ESCAPE_IS_LITERAL]
    Option
EscapedCrIsLf      -> [CUInt -> AppliedOption
CompileExtraOption CUInt
pcre2_EXTRA_ESCAPED_CR_IS_LF]
    Option
MatchLine          -> [CUInt -> AppliedOption
CompileExtraOption CUInt
pcre2_EXTRA_MATCH_LINE]
    Option
MatchWord          -> [CUInt -> AppliedOption
CompileExtraOption CUInt
pcre2_EXTRA_MATCH_WORD]

    -- CompileContextOption
    Bsr Bsr
bsr -> ((ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption)
-> (Ptr Pcre2_compile_context -> CUInt -> IO CInt)
-> CUInt
-> [AppliedOption]
forall a a t.
((ForeignPtr a -> IO ()) -> a)
-> (Ptr a -> t -> IO CInt) -> t -> [a]
unary
        (ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption
CompileContextOption Ptr Pcre2_compile_context -> CUInt -> IO CInt
pcre2_set_bsr (Bsr -> CUInt
bsrToC Bsr
bsr)
    MaxPatternLength Word64
len -> ((ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption)
-> (Ptr Pcre2_compile_context -> PCRE2_SIZE -> IO CInt)
-> PCRE2_SIZE
-> [AppliedOption]
forall a a t.
((ForeignPtr a -> IO ()) -> a)
-> (Ptr a -> t -> IO CInt) -> t -> [a]
unary
        (ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption
CompileContextOption Ptr Pcre2_compile_context -> PCRE2_SIZE -> IO CInt
pcre2_set_max_pattern_length (Word64 -> PCRE2_SIZE
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
len)
    Newline Newline
newline -> ((ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption)
-> (Ptr Pcre2_compile_context -> CUInt -> IO CInt)
-> CUInt
-> [AppliedOption]
forall a a t.
((ForeignPtr a -> IO ()) -> a)
-> (Ptr a -> t -> IO CInt) -> t -> [a]
unary
        (ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption
CompileContextOption Ptr Pcre2_compile_context -> CUInt -> IO CInt
pcre2_set_newline (Newline -> CUInt
newlineToC Newline
newline)
    ParensLimit Word32
limit -> ((ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption)
-> (Ptr Pcre2_compile_context -> CUInt -> IO CInt)
-> CUInt
-> [AppliedOption]
forall a a t.
((ForeignPtr a -> IO ()) -> a)
-> (Ptr a -> t -> IO CInt) -> t -> [a]
unary
        (ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption
CompileContextOption Ptr Pcre2_compile_context -> CUInt -> IO CInt
pcre2_set_parens_nest_limit (Word32 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
limit)

    -- CompileRecGuardOption
    UnsafeCompileRecGuard Int -> IO Bool
f -> [(Int -> IO Bool) -> AppliedOption
CompileRecGuardOption Int -> IO Bool
f]

    -- MatchOption
    Option
NotBol             -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_NOTBOL]
    Option
NotEmpty           -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_NOTEMPTY]
    Option
NotEmptyAtStart    -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_NOTEMPTY_ATSTART]
    Option
NotEol             -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_NOTEOL]
    Option
PartialHard        -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_PARTIAL_HARD]
    Option
PartialSoft        -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_PARTIAL_SOFT]
    Option
SubGlobal          -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_SUBSTITUTE_GLOBAL]
    Option
SubLiteral         -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_SUBSTITUTE_LITERAL]
    Option
SubReplacementOnly -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_SUBSTITUTE_REPLACEMENT_ONLY]
    Option
SubUnknownUnset    -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_SUBSTITUTE_UNKNOWN_UNSET]
    Option
SubUnsetEmpty      -> [CUInt -> AppliedOption
MatchOption CUInt
pcre2_SUBSTITUTE_UNSET_EMPTY]

    -- CalloutOption
    UnsafeCallout CalloutInfo -> IO CalloutResult
f -> [(CalloutInfo -> IO CalloutResult) -> AppliedOption
CalloutOption CalloutInfo -> IO CalloutResult
f]

    -- SubCalloutOption
    UnsafeSubCallout SubCalloutInfo -> IO SubCalloutResult
f -> [(SubCalloutInfo -> IO SubCalloutResult) -> AppliedOption
SubCalloutOption SubCalloutInfo -> IO SubCalloutResult
f]

    -- MatchContextOption
    DepthLimit Word32
limit -> ((ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption)
-> (Ptr Pcre2_match_context -> CUInt -> IO CInt)
-> CUInt
-> [AppliedOption]
forall a a t.
((ForeignPtr a -> IO ()) -> a)
-> (Ptr a -> t -> IO CInt) -> t -> [a]
unary
        (ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption
MatchContextOption Ptr Pcre2_match_context -> CUInt -> IO CInt
pcre2_set_depth_limit (Word32 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
limit)
    HeapLimit Word32
limit -> ((ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption)
-> (Ptr Pcre2_match_context -> CUInt -> IO CInt)
-> CUInt
-> [AppliedOption]
forall a a t.
((ForeignPtr a -> IO ()) -> a)
-> (Ptr a -> t -> IO CInt) -> t -> [a]
unary
        (ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption
MatchContextOption Ptr Pcre2_match_context -> CUInt -> IO CInt
pcre2_set_heap_limit (Word32 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
limit)
    MatchLimit Word32
limit -> ((ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption)
-> (Ptr Pcre2_match_context -> CUInt -> IO CInt)
-> CUInt
-> [AppliedOption]
forall a a t.
((ForeignPtr a -> IO ()) -> a)
-> (Ptr a -> t -> IO CInt) -> t -> [a]
unary
        (ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption
MatchContextOption Ptr Pcre2_match_context -> CUInt -> IO CInt
pcre2_set_match_limit (Word32 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
limit)
    OffsetLimit Word64
limit -> CUInt -> AppliedOption
CompileOption CUInt
pcre2_USE_OFFSET_LIMIT AppliedOption -> [AppliedOption] -> [AppliedOption]
forall a. a -> [a] -> [a]
: ((ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption)
-> (Ptr Pcre2_match_context -> PCRE2_SIZE -> IO CInt)
-> PCRE2_SIZE
-> [AppliedOption]
forall a a t.
((ForeignPtr a -> IO ()) -> a)
-> (Ptr a -> t -> IO CInt) -> t -> [a]
unary
        (ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption
MatchContextOption Ptr Pcre2_match_context -> PCRE2_SIZE -> IO CInt
pcre2_set_offset_limit (Word64 -> PCRE2_SIZE
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
limit)

    where
    unary :: ((ForeignPtr a -> IO ()) -> a)
-> (Ptr a -> t -> IO CInt) -> t -> [a]
unary (ForeignPtr a -> IO ()) -> a
ctor Ptr a -> t -> IO CInt
f t
x = (a -> [a] -> [a]
forall a. a -> [a] -> [a]
: []) (a -> [a]) -> a -> [a]
forall a b. (a -> b) -> a -> b
$ (ForeignPtr a -> IO ()) -> a
ctor ((ForeignPtr a -> IO ()) -> a) -> (ForeignPtr a -> IO ()) -> a
forall a b. (a -> b) -> a -> b
$ \ForeignPtr a
ctx -> ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
ctx ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
ctxPtr ->
        Ptr a -> t -> IO CInt
f Ptr a
ctxPtr t
x IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
check (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0)

-- | Intermediate representation of options expressing what effect they\'ll have
-- on which stage of regex compilation\/execution.  Also provide fake @Prism'@s.
data AppliedOption
    = CompileOption CUInt
    | CompileExtraOption CUInt
    | CompileContextOption (CompileContext -> IO ())
    | CompileRecGuardOption (Int -> IO Bool)
    | MatchOption CUInt
    | CalloutOption (CalloutInfo -> IO CalloutResult)
    | SubCalloutOption (SubCalloutInfo -> IO SubCalloutResult)
    | MatchContextOption (MatchContext -> IO ())

_CompileOption :: (CUInt -> f CUInt) -> AppliedOption -> f AppliedOption
_CompileOption CUInt -> f CUInt
f =
    \case CompileOption CUInt
x -> CUInt -> AppliedOption
CompileOption (CUInt -> AppliedOption) -> f CUInt -> f AppliedOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CUInt -> f CUInt
f CUInt
x; AppliedOption
o -> AppliedOption -> f AppliedOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppliedOption
o
_CompileExtraOption :: (CUInt -> f CUInt) -> AppliedOption -> f AppliedOption
_CompileExtraOption CUInt -> f CUInt
f =
    \case CompileExtraOption CUInt
x -> CUInt -> AppliedOption
CompileExtraOption (CUInt -> AppliedOption) -> f CUInt -> f AppliedOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CUInt -> f CUInt
f CUInt
x; AppliedOption
o -> AppliedOption -> f AppliedOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppliedOption
o
_CompileContextOption :: ((ForeignPtr Pcre2_compile_context -> IO ())
 -> f (ForeignPtr Pcre2_compile_context -> IO ()))
-> AppliedOption -> f AppliedOption
_CompileContextOption (ForeignPtr Pcre2_compile_context -> IO ())
-> f (ForeignPtr Pcre2_compile_context -> IO ())
f =
    \case CompileContextOption ForeignPtr Pcre2_compile_context -> IO ()
x -> (ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption
CompileContextOption ((ForeignPtr Pcre2_compile_context -> IO ()) -> AppliedOption)
-> f (ForeignPtr Pcre2_compile_context -> IO ()) -> f AppliedOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ForeignPtr Pcre2_compile_context -> IO ())
-> f (ForeignPtr Pcre2_compile_context -> IO ())
f ForeignPtr Pcre2_compile_context -> IO ()
x; AppliedOption
o -> AppliedOption -> f AppliedOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppliedOption
o
_CompileRecGuardOption :: ((Int -> IO Bool) -> f (Int -> IO Bool))
-> AppliedOption -> f AppliedOption
_CompileRecGuardOption (Int -> IO Bool) -> f (Int -> IO Bool)
f =
    \case CompileRecGuardOption Int -> IO Bool
x -> (Int -> IO Bool) -> AppliedOption
CompileRecGuardOption ((Int -> IO Bool) -> AppliedOption)
-> f (Int -> IO Bool) -> f AppliedOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IO Bool) -> f (Int -> IO Bool)
f Int -> IO Bool
x; AppliedOption
o -> AppliedOption -> f AppliedOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppliedOption
o
_MatchOption :: (CUInt -> f CUInt) -> AppliedOption -> f AppliedOption
_MatchOption CUInt -> f CUInt
f =
    \case MatchOption CUInt
x -> CUInt -> AppliedOption
MatchOption (CUInt -> AppliedOption) -> f CUInt -> f AppliedOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CUInt -> f CUInt
f CUInt
x; AppliedOption
o -> AppliedOption -> f AppliedOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppliedOption
o
_CalloutOption :: ((CalloutInfo -> IO CalloutResult)
 -> f (CalloutInfo -> IO CalloutResult))
-> AppliedOption -> f AppliedOption
_CalloutOption (CalloutInfo -> IO CalloutResult)
-> f (CalloutInfo -> IO CalloutResult)
f =
    \case CalloutOption CalloutInfo -> IO CalloutResult
x -> (CalloutInfo -> IO CalloutResult) -> AppliedOption
CalloutOption ((CalloutInfo -> IO CalloutResult) -> AppliedOption)
-> f (CalloutInfo -> IO CalloutResult) -> f AppliedOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CalloutInfo -> IO CalloutResult)
-> f (CalloutInfo -> IO CalloutResult)
f CalloutInfo -> IO CalloutResult
x; AppliedOption
o -> AppliedOption -> f AppliedOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppliedOption
o
_SubCalloutOption :: ((SubCalloutInfo -> IO SubCalloutResult)
 -> f (SubCalloutInfo -> IO SubCalloutResult))
-> AppliedOption -> f AppliedOption
_SubCalloutOption (SubCalloutInfo -> IO SubCalloutResult)
-> f (SubCalloutInfo -> IO SubCalloutResult)
f =
    \case SubCalloutOption SubCalloutInfo -> IO SubCalloutResult
x -> (SubCalloutInfo -> IO SubCalloutResult) -> AppliedOption
SubCalloutOption ((SubCalloutInfo -> IO SubCalloutResult) -> AppliedOption)
-> f (SubCalloutInfo -> IO SubCalloutResult) -> f AppliedOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SubCalloutInfo -> IO SubCalloutResult)
-> f (SubCalloutInfo -> IO SubCalloutResult)
f SubCalloutInfo -> IO SubCalloutResult
x; AppliedOption
o -> AppliedOption -> f AppliedOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppliedOption
o
_MatchContextOption :: ((ForeignPtr Pcre2_match_context -> IO ())
 -> f (ForeignPtr Pcre2_match_context -> IO ()))
-> AppliedOption -> f AppliedOption
_MatchContextOption (ForeignPtr Pcre2_match_context -> IO ())
-> f (ForeignPtr Pcre2_match_context -> IO ())
f =
    \case MatchContextOption ForeignPtr Pcre2_match_context -> IO ()
x -> (ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption
MatchContextOption ((ForeignPtr Pcre2_match_context -> IO ()) -> AppliedOption)
-> f (ForeignPtr Pcre2_match_context -> IO ()) -> f AppliedOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ForeignPtr Pcre2_match_context -> IO ())
-> f (ForeignPtr Pcre2_match_context -> IO ())
f ForeignPtr Pcre2_match_context -> IO ()
x; AppliedOption
o -> AppliedOption -> f AppliedOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppliedOption
o

-- ** Extracting options at the right times
--
-- $ExtractingOptionsAtTheRightTimes
-- We interleave the extraction of options with the manipulation of foreign data
-- en route to the target `Matcher` or `Subber`.

-- | A `Monad` modeling both option extraction and foreign effects.
type ExtractOpts = StateT [AppliedOption] IO

-- | Use a fake @Prism'@ to extract a category of options.
extractOptsOf :: Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf :: Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf Getting (Alt Maybe a) AppliedOption a
traversal = ([AppliedOption] -> ([a], [AppliedOption])) -> ExtractOpts [a]
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (([AppliedOption] -> ([a], [AppliedOption])) -> ExtractOpts [a])
-> ([AppliedOption] -> ([a], [AppliedOption])) -> ExtractOpts [a]
forall a b. (a -> b) -> a -> b
$ [Either a AppliedOption] -> ([a], [AppliedOption])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either a AppliedOption] -> ([a], [AppliedOption]))
-> ([AppliedOption] -> [Either a AppliedOption])
-> [AppliedOption]
-> ([a], [AppliedOption])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppliedOption -> Either a AppliedOption)
-> [AppliedOption] -> [Either a AppliedOption]
forall a b. (a -> b) -> [a] -> [b]
map AppliedOption -> Either a AppliedOption
discrim where
    discrim :: AppliedOption -> Either a AppliedOption
discrim AppliedOption
opt = Either a AppliedOption
-> (a -> Either a AppliedOption)
-> Maybe a
-> Either a AppliedOption
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AppliedOption -> Either a AppliedOption
forall a b. b -> Either a b
Right AppliedOption
opt) a -> Either a AppliedOption
forall a b. a -> Either a b
Left (Maybe a -> Either a AppliedOption)
-> Maybe a -> Either a AppliedOption
forall a b. (a -> b) -> a -> b
$ Getting (Alt Maybe a) AppliedOption a -> AppliedOption -> Maybe a
forall a s. Getting (Alt Maybe a) s a -> s -> Maybe a
preview Getting (Alt Maybe a) AppliedOption a
traversal AppliedOption
opt

-- | Prepare to compile a `Code`.
extractCompileEnv :: ExtractOpts CompileEnv
extractCompileEnv :: ExtractOpts CompileEnv
extractCompileEnv = do
    [ForeignPtr Pcre2_compile_context -> IO ()]
ctxUpds <- Getting
  (Alt Maybe (ForeignPtr Pcre2_compile_context -> IO ()))
  AppliedOption
  (ForeignPtr Pcre2_compile_context -> IO ())
-> ExtractOpts [ForeignPtr Pcre2_compile_context -> IO ()]
forall a. Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf Getting
  (Alt Maybe (ForeignPtr Pcre2_compile_context -> IO ()))
  AppliedOption
  (ForeignPtr Pcre2_compile_context -> IO ())
forall (f :: * -> *).
Applicative f =>
((ForeignPtr Pcre2_compile_context -> IO ())
 -> f (ForeignPtr Pcre2_compile_context -> IO ()))
-> AppliedOption -> f AppliedOption
_CompileContextOption
    CUInt
xtraOpts <- [CUInt] -> CUInt
forall (t :: * -> *) a. (Foldable t, Bits a) => t a -> a
bitOr ([CUInt] -> CUInt)
-> StateT [AppliedOption] IO [CUInt]
-> StateT [AppliedOption] IO CUInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Alt Maybe CUInt) AppliedOption CUInt
-> StateT [AppliedOption] IO [CUInt]
forall a. Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf Getting (Alt Maybe CUInt) AppliedOption CUInt
forall (f :: * -> *).
Applicative f =>
(CUInt -> f CUInt) -> AppliedOption -> f AppliedOption
_CompileExtraOption
    Maybe (Int -> IO Bool)
recGuard <- [Int -> IO Bool] -> Maybe (Int -> IO Bool)
forall a. [a] -> Maybe a
safeLast ([Int -> IO Bool] -> Maybe (Int -> IO Bool))
-> StateT [AppliedOption] IO [Int -> IO Bool]
-> StateT [AppliedOption] IO (Maybe (Int -> IO Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Alt Maybe (Int -> IO Bool)) AppliedOption (Int -> IO Bool)
-> StateT [AppliedOption] IO [Int -> IO Bool]
forall a. Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf Getting (Alt Maybe (Int -> IO Bool)) AppliedOption (Int -> IO Bool)
forall (f :: * -> *).
Applicative f =>
((Int -> IO Bool) -> f (Int -> IO Bool))
-> AppliedOption -> f AppliedOption
_CompileRecGuardOption

    Maybe (ForeignPtr Pcre2_compile_context)
compileEnvCtx <- Maybe
  (StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context))
-> StateT
     [AppliedOption] IO (Maybe (ForeignPtr Pcre2_compile_context))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Maybe
   (StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context))
 -> StateT
      [AppliedOption] IO (Maybe (ForeignPtr Pcre2_compile_context)))
-> Maybe
     (StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context))
-> StateT
     [AppliedOption] IO (Maybe (ForeignPtr Pcre2_compile_context))
forall a b. (a -> b) -> a -> b
$ do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ForeignPtr Pcre2_compile_context -> IO ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ForeignPtr Pcre2_compile_context -> IO ()]
ctxUpds Bool -> Bool -> Bool
&& CUInt
xtraOpts CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
0 Bool -> Bool -> Bool
&& Maybe (Int -> IO Bool) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe (Int -> IO Bool)
recGuard
        StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context)
-> Maybe
     (StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context))
forall a. a -> Maybe a
Just (StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context)
 -> Maybe
      (StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context)))
-> StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context)
-> Maybe
     (StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context))
forall a b. (a -> b) -> a -> b
$ IO (ForeignPtr Pcre2_compile_context)
-> StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ForeignPtr Pcre2_compile_context)
 -> StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context))
-> IO (ForeignPtr Pcre2_compile_context)
-> StateT [AppliedOption] IO (ForeignPtr Pcre2_compile_context)
forall a b. (a -> b) -> a -> b
$ do
            ForeignPtr Pcre2_compile_context
ctx <- (Ptr Pcre2_compile_context -> IO ())
-> IO (Ptr Pcre2_compile_context)
-> IO (ForeignPtr Pcre2_compile_context)
forall a. (Ptr a -> IO ()) -> IO (Ptr a) -> IO (ForeignPtr a)
mkForeignPtr Ptr Pcre2_compile_context -> IO ()
pcre2_compile_context_free (IO (Ptr Pcre2_compile_context)
 -> IO (ForeignPtr Pcre2_compile_context))
-> IO (Ptr Pcre2_compile_context)
-> IO (ForeignPtr Pcre2_compile_context)
forall a b. (a -> b) -> a -> b
$
                Ptr Pcre2_general_context -> IO (Ptr Pcre2_compile_context)
pcre2_compile_context_create Ptr Pcre2_general_context
forall a. Ptr a
nullPtr

            [ForeignPtr Pcre2_compile_context -> IO ()]
-> ((ForeignPtr Pcre2_compile_context -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ForeignPtr Pcre2_compile_context -> IO ()]
ctxUpds (((ForeignPtr Pcre2_compile_context -> IO ()) -> IO ()) -> IO ())
-> ((ForeignPtr Pcre2_compile_context -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ForeignPtr Pcre2_compile_context -> IO ()
update -> ForeignPtr Pcre2_compile_context -> IO ()
update ForeignPtr Pcre2_compile_context
ctx
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CUInt
xtraOpts CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CUInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr Pcre2_compile_context
-> (Ptr Pcre2_compile_context -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Pcre2_compile_context
ctx ((Ptr Pcre2_compile_context -> IO ()) -> IO ())
-> (Ptr Pcre2_compile_context -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_compile_context
ctxPtr ->
                Ptr Pcre2_compile_context -> CUInt -> IO CInt
pcre2_set_compile_extra_options Ptr Pcre2_compile_context
ctxPtr CUInt
xtraOpts IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
check (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0)

            ForeignPtr Pcre2_compile_context
-> IO (ForeignPtr Pcre2_compile_context)
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignPtr Pcre2_compile_context
ctx

    Maybe (IORef (Maybe SomeException))
compileEnvERef <- Maybe (StateT [AppliedOption] IO (IORef (Maybe SomeException)))
-> StateT [AppliedOption] IO (Maybe (IORef (Maybe SomeException)))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Maybe (StateT [AppliedOption] IO (IORef (Maybe SomeException)))
 -> StateT [AppliedOption] IO (Maybe (IORef (Maybe SomeException))))
-> Maybe (StateT [AppliedOption] IO (IORef (Maybe SomeException)))
-> StateT [AppliedOption] IO (Maybe (IORef (Maybe SomeException)))
forall a b. (a -> b) -> a -> b
$ do
        ForeignPtr Pcre2_compile_context
ctx <- Maybe (ForeignPtr Pcre2_compile_context)
compileEnvCtx
        Int -> IO Bool
f <- Maybe (Int -> IO Bool)
recGuard
        StateT [AppliedOption] IO (IORef (Maybe SomeException))
-> Maybe (StateT [AppliedOption] IO (IORef (Maybe SomeException)))
forall a. a -> Maybe a
Just (StateT [AppliedOption] IO (IORef (Maybe SomeException))
 -> Maybe (StateT [AppliedOption] IO (IORef (Maybe SomeException))))
-> StateT [AppliedOption] IO (IORef (Maybe SomeException))
-> Maybe (StateT [AppliedOption] IO (IORef (Maybe SomeException)))
forall a b. (a -> b) -> a -> b
$ IO (IORef (Maybe SomeException))
-> StateT [AppliedOption] IO (IORef (Maybe SomeException))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe SomeException))
 -> StateT [AppliedOption] IO (IORef (Maybe SomeException)))
-> IO (IORef (Maybe SomeException))
-> StateT [AppliedOption] IO (IORef (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$ do
            IORef (Maybe SomeException)
eRef <- Maybe SomeException -> IO (IORef (Maybe SomeException))
forall a. a -> IO (IORef a)
newIORef Maybe SomeException
forall a. Maybe a
Nothing
            FunPtr (CUInt -> Ptr Any -> IO CInt)
fPtr <- ForeignPtr Pcre2_compile_context
-> IO (FunPtr (CUInt -> Ptr Any -> IO CInt))
-> IO (FunPtr (CUInt -> Ptr Any -> IO CInt))
forall b a. ForeignPtr b -> IO (FunPtr a) -> IO (FunPtr a)
mkFunPtr ForeignPtr Pcre2_compile_context
ctx (IO (FunPtr (CUInt -> Ptr Any -> IO CInt))
 -> IO (FunPtr (CUInt -> Ptr Any -> IO CInt)))
-> IO (FunPtr (CUInt -> Ptr Any -> IO CInt))
-> IO (FunPtr (CUInt -> Ptr Any -> IO CInt))
forall a b. (a -> b) -> a -> b
$ (CUInt -> Ptr Any -> IO CInt)
-> IO (FunPtr (CUInt -> Ptr Any -> IO CInt))
forall a.
(CUInt -> Ptr a -> IO CInt)
-> IO (FunPtr (CUInt -> Ptr a -> IO CInt))
mkRecursionGuard ((CUInt -> Ptr Any -> IO CInt)
 -> IO (FunPtr (CUInt -> Ptr Any -> IO CInt)))
-> (CUInt -> Ptr Any -> IO CInt)
-> IO (FunPtr (CUInt -> Ptr Any -> IO CInt))
forall a b. (a -> b) -> a -> b
$ \CUInt
depth Ptr Any
_ -> do
                Either SomeException Bool
resultOrE <- IO Bool -> IO (Either SomeException Bool)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Bool -> IO (Either SomeException Bool))
-> IO Bool -> IO (Either SomeException Bool)
forall a b. (a -> b) -> a -> b
$ do
                    Int -> IO Bool
f <- (Int -> IO Bool) -> IO (Int -> IO Bool)
forall a. a -> IO a
evaluate Int -> IO Bool
f
                    Bool
result <- Int -> IO Bool
f (Int -> IO Bool) -> Int -> IO Bool
forall a b. (a -> b) -> a -> b
$ CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
depth
                    Bool -> IO Bool
forall a. a -> IO a
evaluate Bool
result
                case Either SomeException Bool
resultOrE of
                    Right Bool
success -> CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ if Bool
success then CInt
0 else CInt
1
                    Left SomeException
e        -> IORef (Maybe SomeException) -> Maybe SomeException -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe SomeException)
eRef (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e) IO () -> IO CInt -> IO CInt
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
1

            ForeignPtr Pcre2_compile_context
-> (Ptr Pcre2_compile_context -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Pcre2_compile_context
ctx ((Ptr Pcre2_compile_context -> IO ()) -> IO ())
-> (Ptr Pcre2_compile_context -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_compile_context
ctxPtr -> do
                CInt
result <- Ptr Pcre2_compile_context
-> FunPtr (CUInt -> Ptr Any -> IO CInt) -> Ptr Any -> IO CInt
forall a.
Ptr Pcre2_compile_context
-> FunPtr (CUInt -> Ptr a -> IO CInt) -> Ptr a -> IO CInt
pcre2_set_compile_recursion_guard Ptr Pcre2_compile_context
ctxPtr FunPtr (CUInt -> Ptr Any -> IO CInt)
fPtr Ptr Any
forall a. Ptr a
nullPtr
                (CInt -> Bool) -> CInt -> IO ()
check (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0) CInt
result

            IORef (Maybe SomeException) -> IO (IORef (Maybe SomeException))
forall (m :: * -> *) a. Monad m => a -> m a
return IORef (Maybe SomeException)
eRef

    CompileEnv -> ExtractOpts CompileEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (CompileEnv -> ExtractOpts CompileEnv)
-> CompileEnv -> ExtractOpts CompileEnv
forall a b. (a -> b) -> a -> b
$ CompileEnv :: Maybe (ForeignPtr Pcre2_compile_context)
-> Maybe (IORef (Maybe SomeException)) -> CompileEnv
CompileEnv {Maybe (ForeignPtr Pcre2_compile_context)
Maybe (IORef (Maybe SomeException))
compileEnvERef :: Maybe (IORef (Maybe SomeException))
compileEnvCtx :: Maybe (ForeignPtr Pcre2_compile_context)
compileEnvERef :: Maybe (IORef (Maybe SomeException))
compileEnvCtx :: Maybe (ForeignPtr Pcre2_compile_context)
..}

-- | Inputs to `Code` compilation besides the pattern.
data CompileEnv = CompileEnv {
    CompileEnv -> Maybe (ForeignPtr Pcre2_compile_context)
compileEnvCtx :: Maybe CompileContext,
    -- | A register for catching exceptions thrown in recursion guards, if
    -- needed.
    CompileEnv -> Maybe (IORef (Maybe SomeException))
compileEnvERef :: Maybe (IORef (Maybe SomeException))}

-- | Compile a `Code`.
extractCode :: Text -> CompileEnv -> ExtractOpts Code
extractCode :: Text -> CompileEnv -> ExtractOpts Code
extractCode Text
patt (CompileEnv {Maybe (ForeignPtr Pcre2_compile_context)
Maybe (IORef (Maybe SomeException))
compileEnvERef :: Maybe (IORef (Maybe SomeException))
compileEnvCtx :: Maybe (ForeignPtr Pcre2_compile_context)
compileEnvERef :: CompileEnv -> Maybe (IORef (Maybe SomeException))
compileEnvCtx :: CompileEnv -> Maybe (ForeignPtr Pcre2_compile_context)
..}) = do
    CUInt
opts <- [CUInt] -> CUInt
forall (t :: * -> *) a. (Foldable t, Bits a) => t a -> a
bitOr ([CUInt] -> CUInt)
-> StateT [AppliedOption] IO [CUInt]
-> StateT [AppliedOption] IO CUInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Alt Maybe CUInt) AppliedOption CUInt
-> StateT [AppliedOption] IO [CUInt]
forall a. Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf Getting (Alt Maybe CUInt) AppliedOption CUInt
forall (f :: * -> *).
Applicative f =>
(CUInt -> f CUInt) -> AppliedOption -> f AppliedOption
_CompileOption

    IO Code -> ExtractOpts Code
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Code -> ExtractOpts Code) -> IO Code -> ExtractOpts Code
forall a b. (a -> b) -> a -> b
$ (Ptr Pcre2_code -> IO ()) -> IO (Ptr Pcre2_code) -> IO Code
forall a. (Ptr a -> IO ()) -> IO (Ptr a) -> IO (ForeignPtr a)
mkForeignPtr Ptr Pcre2_code -> IO ()
pcre2_code_free (IO (Ptr Pcre2_code) -> IO Code) -> IO (Ptr Pcre2_code) -> IO Code
forall a b. (a -> b) -> a -> b
$
        Text
-> (Ptr Word16 -> I16 -> IO (Ptr Pcre2_code))
-> IO (Ptr Pcre2_code)
forall a. Text -> (Ptr Word16 -> I16 -> IO a) -> IO a
Text.useAsPtr Text
patt ((Ptr Word16 -> I16 -> IO (Ptr Pcre2_code)) -> IO (Ptr Pcre2_code))
-> (Ptr Word16 -> I16 -> IO (Ptr Pcre2_code))
-> IO (Ptr Pcre2_code)
forall a b. (a -> b) -> a -> b
$ \Ptr Word16
pattPtr I16
pattCUs ->
        (Ptr CInt -> IO (Ptr Pcre2_code)) -> IO (Ptr Pcre2_code)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Ptr Pcre2_code)) -> IO (Ptr Pcre2_code))
-> (Ptr CInt -> IO (Ptr Pcre2_code)) -> IO (Ptr Pcre2_code)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
errorCodePtr ->
        (Ptr PCRE2_SIZE -> IO (Ptr Pcre2_code)) -> IO (Ptr Pcre2_code)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr PCRE2_SIZE -> IO (Ptr Pcre2_code)) -> IO (Ptr Pcre2_code))
-> (Ptr PCRE2_SIZE -> IO (Ptr Pcre2_code)) -> IO (Ptr Pcre2_code)
forall a b. (a -> b) -> a -> b
$ \Ptr PCRE2_SIZE
errorOffPtr ->
        Maybe (ForeignPtr Pcre2_compile_context)
-> (Ptr Pcre2_compile_context -> IO (Ptr Pcre2_code))
-> IO (Ptr Pcre2_code)
forall a b. Maybe (ForeignPtr a) -> (Ptr a -> IO b) -> IO b
withForeignOrNullPtr Maybe (ForeignPtr Pcre2_compile_context)
compileEnvCtx ((Ptr Pcre2_compile_context -> IO (Ptr Pcre2_code))
 -> IO (Ptr Pcre2_code))
-> (Ptr Pcre2_compile_context -> IO (Ptr Pcre2_code))
-> IO (Ptr Pcre2_code)
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_compile_context
ctxPtr -> do
            Ptr Pcre2_code
codePtr <- Ptr CUShort
-> PCRE2_SIZE
-> CUInt
-> Ptr CInt
-> Ptr PCRE2_SIZE
-> Ptr Pcre2_compile_context
-> IO (Ptr Pcre2_code)
pcre2_compile
                (Ptr Word16 -> Ptr CUShort
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs Ptr Word16
pattPtr)
                (I16 -> PCRE2_SIZE
forall a b. (Integral a, Num b) => a -> b
fromIntegral I16
pattCUs)
                CUInt
opts
                Ptr CInt
errorCodePtr
                Ptr PCRE2_SIZE
errorOffPtr
                Ptr Pcre2_compile_context
ctxPtr
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr Pcre2_code
codePtr Ptr Pcre2_code -> Ptr Pcre2_code -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Pcre2_code
forall a. Ptr a
nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                -- Re-throw exception (if any) from recursion guard (if any)
                Maybe (IORef (Maybe SomeException))
-> (IORef (Maybe SomeException) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (IORef (Maybe SomeException))
compileEnvERef ((IORef (Maybe SomeException) -> IO ()) -> IO ())
-> (IORef (Maybe SomeException) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe SomeException) -> IO (Maybe SomeException)
forall a. IORef a -> IO a
readIORef (IORef (Maybe SomeException) -> IO (Maybe SomeException))
-> (Maybe SomeException -> IO ())
-> IORef (Maybe SomeException)
-> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (SomeException -> IO Any) -> Maybe SomeException -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SomeException -> IO Any
forall e a. Exception e => e -> IO a
throwIO
                -- Otherwise throw PCRE2 error
                CInt
errorCode <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
errorCodePtr
                PCRE2_SIZE
offCUs <- Ptr PCRE2_SIZE -> IO PCRE2_SIZE
forall a. Storable a => Ptr a -> IO a
peek Ptr PCRE2_SIZE
errorOffPtr
                Pcre2CompileException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Pcre2CompileException -> IO ()) -> Pcre2CompileException -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Text -> PCRE2_SIZE -> Pcre2CompileException
Pcre2CompileException CInt
errorCode Text
patt PCRE2_SIZE
offCUs

            Ptr Pcre2_code -> IO (Ptr Pcre2_code)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Pcre2_code
codePtr

-- | `Code` and auxiliary compiled data used in preparation for a match or
-- substitution.  This remains constant for the lifetime of a `Matcher` or
-- `Subber`.
data MatchEnv = MatchEnv {
    MatchEnv -> Code
matchEnvCode       :: Code,
    MatchEnv -> CUInt
matchEnvOpts       :: CUInt,
    MatchEnv -> Maybe (ForeignPtr Pcre2_match_context)
matchEnvCtx        :: Maybe MatchContext,
    MatchEnv -> Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCallout    :: Maybe (CalloutInfo -> IO CalloutResult),
    MatchEnv -> Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvSubCallout :: Maybe (SubCalloutInfo -> IO SubCalloutResult)}

-- | Prepare a matching function.
extractMatchEnv :: Code -> ExtractOpts MatchEnv
extractMatchEnv :: Code -> ExtractOpts MatchEnv
extractMatchEnv Code
matchEnvCode = do
    CUInt
matchEnvOpts <- [CUInt] -> CUInt
forall (t :: * -> *) a. (Foldable t, Bits a) => t a -> a
bitOr ([CUInt] -> CUInt)
-> StateT [AppliedOption] IO [CUInt]
-> StateT [AppliedOption] IO CUInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Alt Maybe CUInt) AppliedOption CUInt
-> StateT [AppliedOption] IO [CUInt]
forall a. Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf Getting (Alt Maybe CUInt) AppliedOption CUInt
forall (f :: * -> *).
Applicative f =>
(CUInt -> f CUInt) -> AppliedOption -> f AppliedOption
_MatchOption

    Maybe (ForeignPtr Pcre2_match_context)
matchEnvCtx <- Getting
  (Alt Maybe (ForeignPtr Pcre2_match_context -> IO ()))
  AppliedOption
  (ForeignPtr Pcre2_match_context -> IO ())
-> ExtractOpts [ForeignPtr Pcre2_match_context -> IO ()]
forall a. Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf Getting
  (Alt Maybe (ForeignPtr Pcre2_match_context -> IO ()))
  AppliedOption
  (ForeignPtr Pcre2_match_context -> IO ())
forall (f :: * -> *).
Applicative f =>
((ForeignPtr Pcre2_match_context -> IO ())
 -> f (ForeignPtr Pcre2_match_context -> IO ()))
-> AppliedOption -> f AppliedOption
_MatchContextOption ExtractOpts [ForeignPtr Pcre2_match_context -> IO ()]
-> ([ForeignPtr Pcre2_match_context -> IO ()]
    -> StateT
         [AppliedOption] IO (Maybe (ForeignPtr Pcre2_match_context)))
-> StateT
     [AppliedOption] IO (Maybe (ForeignPtr Pcre2_match_context))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        []      -> Maybe (ForeignPtr Pcre2_match_context)
-> StateT
     [AppliedOption] IO (Maybe (ForeignPtr Pcre2_match_context))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ForeignPtr Pcre2_match_context)
forall a. Maybe a
Nothing
        [ForeignPtr Pcre2_match_context -> IO ()]
ctxUpds -> IO (Maybe (ForeignPtr Pcre2_match_context))
-> StateT
     [AppliedOption] IO (Maybe (ForeignPtr Pcre2_match_context))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ForeignPtr Pcre2_match_context))
 -> StateT
      [AppliedOption] IO (Maybe (ForeignPtr Pcre2_match_context)))
-> IO (Maybe (ForeignPtr Pcre2_match_context))
-> StateT
     [AppliedOption] IO (Maybe (ForeignPtr Pcre2_match_context))
forall a b. (a -> b) -> a -> b
$ ForeignPtr Pcre2_match_context
-> Maybe (ForeignPtr Pcre2_match_context)
forall a. a -> Maybe a
Just (ForeignPtr Pcre2_match_context
 -> Maybe (ForeignPtr Pcre2_match_context))
-> IO (ForeignPtr Pcre2_match_context)
-> IO (Maybe (ForeignPtr Pcre2_match_context))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
            ForeignPtr Pcre2_match_context
ctx <- (Ptr Pcre2_match_context -> IO ())
-> IO (Ptr Pcre2_match_context)
-> IO (ForeignPtr Pcre2_match_context)
forall a. (Ptr a -> IO ()) -> IO (Ptr a) -> IO (ForeignPtr a)
mkForeignPtr Ptr Pcre2_match_context -> IO ()
pcre2_match_context_free (IO (Ptr Pcre2_match_context)
 -> IO (ForeignPtr Pcre2_match_context))
-> IO (Ptr Pcre2_match_context)
-> IO (ForeignPtr Pcre2_match_context)
forall a b. (a -> b) -> a -> b
$
                Ptr Pcre2_general_context -> IO (Ptr Pcre2_match_context)
pcre2_match_context_create Ptr Pcre2_general_context
forall a. Ptr a
nullPtr

            [ForeignPtr Pcre2_match_context -> IO ()]
-> ((ForeignPtr Pcre2_match_context -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ForeignPtr Pcre2_match_context -> IO ()]
ctxUpds (((ForeignPtr Pcre2_match_context -> IO ()) -> IO ()) -> IO ())
-> ((ForeignPtr Pcre2_match_context -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ForeignPtr Pcre2_match_context -> IO ()
update -> ForeignPtr Pcre2_match_context -> IO ()
update ForeignPtr Pcre2_match_context
ctx

            ForeignPtr Pcre2_match_context
-> IO (ForeignPtr Pcre2_match_context)
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignPtr Pcre2_match_context
ctx

    Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCallout <- [CalloutInfo -> IO CalloutResult]
-> Maybe (CalloutInfo -> IO CalloutResult)
forall a. [a] -> Maybe a
safeLast ([CalloutInfo -> IO CalloutResult]
 -> Maybe (CalloutInfo -> IO CalloutResult))
-> StateT [AppliedOption] IO [CalloutInfo -> IO CalloutResult]
-> StateT
     [AppliedOption] IO (Maybe (CalloutInfo -> IO CalloutResult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Alt Maybe (CalloutInfo -> IO CalloutResult))
  AppliedOption
  (CalloutInfo -> IO CalloutResult)
-> StateT [AppliedOption] IO [CalloutInfo -> IO CalloutResult]
forall a. Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf Getting
  (Alt Maybe (CalloutInfo -> IO CalloutResult))
  AppliedOption
  (CalloutInfo -> IO CalloutResult)
forall (f :: * -> *).
Applicative f =>
((CalloutInfo -> IO CalloutResult)
 -> f (CalloutInfo -> IO CalloutResult))
-> AppliedOption -> f AppliedOption
_CalloutOption
    Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvSubCallout <- [SubCalloutInfo -> IO SubCalloutResult]
-> Maybe (SubCalloutInfo -> IO SubCalloutResult)
forall a. [a] -> Maybe a
safeLast ([SubCalloutInfo -> IO SubCalloutResult]
 -> Maybe (SubCalloutInfo -> IO SubCalloutResult))
-> StateT
     [AppliedOption] IO [SubCalloutInfo -> IO SubCalloutResult]
-> StateT
     [AppliedOption] IO (Maybe (SubCalloutInfo -> IO SubCalloutResult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Alt Maybe (SubCalloutInfo -> IO SubCalloutResult))
  AppliedOption
  (SubCalloutInfo -> IO SubCalloutResult)
-> StateT
     [AppliedOption] IO [SubCalloutInfo -> IO SubCalloutResult]
forall a. Getting (Alt Maybe a) AppliedOption a -> ExtractOpts [a]
extractOptsOf Getting
  (Alt Maybe (SubCalloutInfo -> IO SubCalloutResult))
  AppliedOption
  (SubCalloutInfo -> IO SubCalloutResult)
forall (f :: * -> *).
Applicative f =>
((SubCalloutInfo -> IO SubCalloutResult)
 -> f (SubCalloutInfo -> IO SubCalloutResult))
-> AppliedOption -> f AppliedOption
_SubCalloutOption

    MatchEnv -> ExtractOpts MatchEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchEnv -> ExtractOpts MatchEnv)
-> MatchEnv -> ExtractOpts MatchEnv
forall a b. (a -> b) -> a -> b
$ MatchEnv :: Code
-> CUInt
-> Maybe (ForeignPtr Pcre2_match_context)
-> Maybe (CalloutInfo -> IO CalloutResult)
-> Maybe (SubCalloutInfo -> IO SubCalloutResult)
-> MatchEnv
MatchEnv {Maybe (ForeignPtr Pcre2_match_context)
Maybe (SubCalloutInfo -> IO SubCalloutResult)
Maybe (CalloutInfo -> IO CalloutResult)
Code
CUInt
matchEnvSubCallout :: Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvCallout :: Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
matchEnvOpts :: CUInt
matchEnvCode :: Code
matchEnvSubCallout :: Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvCallout :: Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
matchEnvOpts :: CUInt
matchEnvCode :: Code
..}

-- | Helper for @assemble*@ functions.  Basically, extract all options and help
-- produce a function that takes a `Text` subject.
assembleSubjFun :: (MatchEnv -> Text -> a) -> Option -> Text -> IO (Text -> a)
assembleSubjFun :: (MatchEnv -> Text -> a) -> Option -> Text -> IO (Text -> a)
assembleSubjFun MatchEnv -> Text -> a
mkSubjFun Option
option Text
patt =
    StateT [AppliedOption] IO (Text -> a)
-> [AppliedOption] -> IO (Text -> a, [AppliedOption])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT [AppliedOption] IO (Text -> a)
extractAll (Option -> [AppliedOption]
applyOption Option
option) IO (Text -> a, [AppliedOption])
-> ((Text -> a, [AppliedOption]) -> Text -> a) -> IO (Text -> a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        (Text -> a
subjFun, []) -> Text -> a
subjFun
        (Text -> a, [AppliedOption])
_             -> String -> Text -> a
forall a. HasCallStack => String -> a
error String
"BUG! Options not fully extracted"

    where
    extractAll :: StateT [AppliedOption] IO (Text -> a)
extractAll = do
        CompileEnv
compileEnv <- ExtractOpts CompileEnv
extractCompileEnv
        Code
code <- Text -> CompileEnv -> ExtractOpts Code
extractCode Text
patt CompileEnv
compileEnv
        MatchEnv
matchEnv <- Code -> ExtractOpts MatchEnv
extractMatchEnv Code
code

        (Text -> a) -> StateT [AppliedOption] IO (Text -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text -> a) -> StateT [AppliedOption] IO (Text -> a))
-> (Text -> a) -> StateT [AppliedOption] IO (Text -> a)
forall a b. (a -> b) -> a -> b
$ MatchEnv -> Text -> a
mkSubjFun MatchEnv
matchEnv

-- | Produce a `Matcher` from user-supplied `Option` and pattern.
assembleMatcher :: Option -> Text -> IO Matcher
assembleMatcher :: Option -> Text -> IO Matcher
assembleMatcher = (MatchEnv -> Matcher) -> Option -> Text -> IO Matcher
forall a.
(MatchEnv -> Text -> a) -> Option -> Text -> IO (Text -> a)
assembleSubjFun ((MatchEnv -> Matcher) -> Option -> Text -> IO Matcher)
-> (MatchEnv -> Matcher) -> Option -> Text -> IO Matcher
forall a b. (a -> b) -> a -> b
$ \matchEnv :: MatchEnv
matchEnv@(MatchEnv {Maybe (ForeignPtr Pcre2_match_context)
Maybe (SubCalloutInfo -> IO SubCalloutResult)
Maybe (CalloutInfo -> IO CalloutResult)
Code
CUInt
matchEnvSubCallout :: Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvCallout :: Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
matchEnvOpts :: CUInt
matchEnvCode :: Code
matchEnvSubCallout :: MatchEnv -> Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvCallout :: MatchEnv -> Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCtx :: MatchEnv -> Maybe (ForeignPtr Pcre2_match_context)
matchEnvOpts :: MatchEnv -> CUInt
matchEnvCode :: MatchEnv -> Code
..}) Text
subject ->
    IO (Stream (Ptr Pcre2_match_data) IO Void)
-> Stream (Ptr Pcre2_match_data) IO Void
forall b (m :: * -> *) a. m (Stream b m a) -> Stream b m a
StreamEffect (IO (Stream (Ptr Pcre2_match_data) IO Void)
 -> Stream (Ptr Pcre2_match_data) IO Void)
-> IO (Stream (Ptr Pcre2_match_data) IO Void)
-> Stream (Ptr Pcre2_match_data) IO Void
forall a b. (a -> b) -> a -> b
$
    Code
-> (Ptr Pcre2_code -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> IO (Stream (Ptr Pcre2_match_data) IO Void)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Code
matchEnvCode ((Ptr Pcre2_code -> IO (Stream (Ptr Pcre2_match_data) IO Void))
 -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> (Ptr Pcre2_code -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> IO (Stream (Ptr Pcre2_match_data) IO Void)
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_code
codePtr ->
    Ptr Pcre2_code
-> (Ptr Pcre2_match_data
    -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> IO (Stream (Ptr Pcre2_match_data) IO Void)
forall b. Ptr Pcre2_code -> (Ptr Pcre2_match_data -> IO b) -> IO b
withMatchDataFromCode Ptr Pcre2_code
codePtr ((Ptr Pcre2_match_data
  -> IO (Stream (Ptr Pcre2_match_data) IO Void))
 -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> (Ptr Pcre2_match_data
    -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> IO (Stream (Ptr Pcre2_match_data) IO Void)
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_match_data
matchDataPtr ->
    Text
-> (Ptr Word16
    -> I16 -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> IO (Stream (Ptr Pcre2_match_data) IO Void)
forall a. Text -> (Ptr Word16 -> I16 -> IO a) -> IO a
Text.useAsPtr Text
subject ((Ptr Word16 -> I16 -> IO (Stream (Ptr Pcre2_match_data) IO Void))
 -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> (Ptr Word16
    -> I16 -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> IO (Stream (Ptr Pcre2_match_data) IO Void)
forall a b. (a -> b) -> a -> b
$ \Ptr Word16
subjPtr I16
subjCUs -> do
        MatchTempEnv {Maybe (ForeignPtr Pcre2_match_context)
Maybe (IORef CalloutState)
matchTempEnvRef :: MatchTempEnv -> Maybe (IORef CalloutState)
matchTempEnvCtx :: MatchTempEnv -> Maybe (ForeignPtr Pcre2_match_context)
matchTempEnvRef :: Maybe (IORef CalloutState)
matchTempEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
..} <- MatchEnv -> Text -> IO MatchTempEnv
mkMatchTempEnv MatchEnv
matchEnv Text
subject

        -- Loop over the subject, emitting match data until stopping.
        Stream (Ptr Pcre2_match_data) IO Void
-> IO (Stream (Ptr Pcre2_match_data) IO Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream (Ptr Pcre2_match_data) IO Void
 -> IO (Stream (Ptr Pcre2_match_data) IO Void))
-> Stream (Ptr Pcre2_match_data) IO Void
-> IO (Stream (Ptr Pcre2_match_data) IO Void)
forall a b. (a -> b) -> a -> b
$ PCRE2_SIZE
-> ((PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO Void)
    -> PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO Void)
-> Stream (Ptr Pcre2_match_data) IO Void
forall a b. a -> ((a -> b) -> a -> b) -> b
fix1 PCRE2_SIZE
0 (((PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO Void)
  -> PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO Void)
 -> Stream (Ptr Pcre2_match_data) IO Void)
-> ((PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO Void)
    -> PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO Void)
-> Stream (Ptr Pcre2_match_data) IO Void
forall a b. (a -> b) -> a -> b
$ \PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO Void
continue PCRE2_SIZE
curOff -> do
            CInt
result <- IO CInt -> Stream (Ptr Pcre2_match_data) IO CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CInt -> Stream (Ptr Pcre2_match_data) IO CInt)
-> IO CInt -> Stream (Ptr Pcre2_match_data) IO CInt
forall a b. (a -> b) -> a -> b
$ Maybe (ForeignPtr Pcre2_match_context)
-> (Ptr Pcre2_match_context -> IO CInt) -> IO CInt
forall a b. Maybe (ForeignPtr a) -> (Ptr a -> IO b) -> IO b
withForeignOrNullPtr Maybe (ForeignPtr Pcre2_match_context)
matchTempEnvCtx ((Ptr Pcre2_match_context -> IO CInt) -> IO CInt)
-> (Ptr Pcre2_match_context -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_match_context
ctxPtr ->
                Ptr Pcre2_code
-> Ptr CUShort
-> PCRE2_SIZE
-> PCRE2_SIZE
-> CUInt
-> Ptr Pcre2_match_data
-> Ptr Pcre2_match_context
-> IO CInt
pcre2_match
                    Ptr Pcre2_code
codePtr
                    (Ptr Word16 -> Ptr CUShort
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs Ptr Word16
subjPtr)
                    (I16 -> PCRE2_SIZE
forall a b. (Integral a, Num b) => a -> b
fromIntegral I16
subjCUs)
                    PCRE2_SIZE
curOff
                    CUInt
matchEnvOpts
                    Ptr Pcre2_match_data
matchDataPtr
                    Ptr Pcre2_match_context
ctxPtr

            -- Handle no match and errors
            Bool
-> Stream (Ptr Pcre2_match_data) IO ()
-> Stream (Ptr Pcre2_match_data) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
pcre2_ERROR_NOMATCH) Stream (Ptr Pcre2_match_data) IO ()
forall b (m :: * -> *) a. Stream b m a
StreamStop
            Bool
-> Stream (Ptr Pcre2_match_data) IO ()
-> Stream (Ptr Pcre2_match_data) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
pcre2_ERROR_CALLOUT) (Stream (Ptr Pcre2_match_data) IO ()
 -> Stream (Ptr Pcre2_match_data) IO ())
-> Stream (Ptr Pcre2_match_data) IO ()
-> Stream (Ptr Pcre2_match_data) IO ()
forall a b. (a -> b) -> a -> b
$
                IO () -> Stream (Ptr Pcre2_match_data) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Stream (Ptr Pcre2_match_data) IO ())
-> IO () -> Stream (Ptr Pcre2_match_data) IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (IORef CalloutState) -> IO ()
maybeRethrow Maybe (IORef CalloutState)
matchTempEnvRef
            IO () -> Stream (Ptr Pcre2_match_data) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Stream (Ptr Pcre2_match_data) IO ())
-> IO () -> Stream (Ptr Pcre2_match_data) IO ()
forall a b. (a -> b) -> a -> b
$ (CInt -> Bool) -> CInt -> IO ()
check (CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> CInt
0) CInt
result

            Ptr Pcre2_match_data -> Stream (Ptr Pcre2_match_data) IO ()
forall b (m :: * -> *). b -> Stream b m ()
streamYield Ptr Pcre2_match_data
matchDataPtr

            -- Determine next starting offset
            PCRE2_SIZE
nextOff <- IO PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO PCRE2_SIZE
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO PCRE2_SIZE)
-> IO PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO PCRE2_SIZE
forall a b. (a -> b) -> a -> b
$ do
                Ptr PCRE2_SIZE
ovecPtr <- Ptr Pcre2_match_data -> IO (Ptr PCRE2_SIZE)
pcre2_get_ovector_pointer Ptr Pcre2_match_data
matchDataPtr
                PCRE2_SIZE
curOffEnd <- Ptr PCRE2_SIZE -> Int -> IO PCRE2_SIZE
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr PCRE2_SIZE
ovecPtr Int
1
                -- Prevent infinite loop upon empty match
                PCRE2_SIZE -> IO PCRE2_SIZE
forall (m :: * -> *) a. Monad m => a -> m a
return (PCRE2_SIZE -> IO PCRE2_SIZE) -> PCRE2_SIZE -> IO PCRE2_SIZE
forall a b. (a -> b) -> a -> b
$ PCRE2_SIZE -> PCRE2_SIZE -> PCRE2_SIZE
forall a. Ord a => a -> a -> a
max PCRE2_SIZE
curOffEnd (PCRE2_SIZE
curOff PCRE2_SIZE -> PCRE2_SIZE -> PCRE2_SIZE
forall a. Num a => a -> a -> a
+ PCRE2_SIZE
1)

            -- Handle end of subject
            Bool
-> Stream (Ptr Pcre2_match_data) IO ()
-> Stream (Ptr Pcre2_match_data) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PCRE2_SIZE
nextOff PCRE2_SIZE -> PCRE2_SIZE -> Bool
forall a. Ord a => a -> a -> Bool
> I16 -> PCRE2_SIZE
forall a b. (Integral a, Num b) => a -> b
fromIntegral I16
subjCUs) Stream (Ptr Pcre2_match_data) IO ()
forall b (m :: * -> *) a. Stream b m a
StreamStop

            PCRE2_SIZE -> Stream (Ptr Pcre2_match_data) IO Void
continue PCRE2_SIZE
nextOff

    where
    withMatchDataFromCode :: Ptr Pcre2_code -> (Ptr Pcre2_match_data -> IO b) -> IO b
withMatchDataFromCode Ptr Pcre2_code
codePtr Ptr Pcre2_match_data -> IO b
action = do
        ForeignPtr Pcre2_match_data
matchData <- (Ptr Pcre2_match_data -> IO ())
-> IO (Ptr Pcre2_match_data) -> IO (ForeignPtr Pcre2_match_data)
forall a. (Ptr a -> IO ()) -> IO (Ptr a) -> IO (ForeignPtr a)
mkForeignPtr Ptr Pcre2_match_data -> IO ()
pcre2_match_data_free (IO (Ptr Pcre2_match_data) -> IO (ForeignPtr Pcre2_match_data))
-> IO (Ptr Pcre2_match_data) -> IO (ForeignPtr Pcre2_match_data)
forall a b. (a -> b) -> a -> b
$
            Ptr Pcre2_code
-> Ptr Pcre2_general_context -> IO (Ptr Pcre2_match_data)
pcre2_match_data_create_from_pattern Ptr Pcre2_code
codePtr Ptr Pcre2_general_context
forall a. Ptr a
nullPtr
        ForeignPtr Pcre2_match_data
-> (Ptr Pcre2_match_data -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Pcre2_match_data
matchData Ptr Pcre2_match_data -> IO b
action

-- | A `Subber` works by first writing results to a reasonably-sized buffer.  If
-- we run out of room, PCRE2 allows us to simulate the rest of the substitution
-- without writing anything, in order to calculate how big the buffer actually
-- has to be.  In this event, we rerun the substitution with a new,
-- exactly-sized buffer.
--
-- One potential issue arising from two attempts is running effectful callouts
-- twice.  We mitigate this by skipping callouts the second time:
--
-- * all regular callouts, since they had run during the simulation, and
--
-- * those substitution callouts that had run the first time.
--
-- Therefore, the first time, log the substitution callout indexes that had run
-- along with their results, and replay the log the second time, returning those
-- same results without re-incurring effects.
assembleSubber
    :: Text      -- ^ replacement
    -> Option
    -> Text      -- ^ pattern
    -> IO Subber
assembleSubber :: Text -> Option -> Text -> IO Subber
assembleSubber Text
replacement = (MatchEnv -> Subber) -> Option -> Text -> IO Subber
forall a.
(MatchEnv -> Text -> a) -> Option -> Text -> IO (Text -> a)
assembleSubjFun ((MatchEnv -> Subber) -> Option -> Text -> IO Subber)
-> (MatchEnv -> Subber) -> Option -> Text -> IO Subber
forall a b. (a -> b) -> a -> b
$ \firstMatchEnv :: MatchEnv
firstMatchEnv@(MatchEnv {Maybe (ForeignPtr Pcre2_match_context)
Maybe (SubCalloutInfo -> IO SubCalloutResult)
Maybe (CalloutInfo -> IO CalloutResult)
Code
CUInt
matchEnvSubCallout :: Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvCallout :: Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
matchEnvOpts :: CUInt
matchEnvCode :: Code
matchEnvSubCallout :: MatchEnv -> Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvCallout :: MatchEnv -> Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCtx :: MatchEnv -> Maybe (ForeignPtr Pcre2_match_context)
matchEnvOpts :: MatchEnv -> CUInt
matchEnvCode :: MatchEnv -> Code
..}) ->
    -- Subber
    \Text
subject ->
    Code -> (Ptr Pcre2_code -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Code
matchEnvCode ((Ptr Pcre2_code -> IO (CInt, Text)) -> IO (CInt, Text))
-> (Ptr Pcre2_code -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_code
codePtr ->
    Text -> (Ptr Word16 -> I16 -> IO (CInt, Text)) -> IO (CInt, Text)
forall a. Text -> (Ptr Word16 -> I16 -> IO a) -> IO a
Text.useAsPtr Text
subject ((Ptr Word16 -> I16 -> IO (CInt, Text)) -> IO (CInt, Text))
-> (Ptr Word16 -> I16 -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. (a -> b) -> a -> b
$ \Ptr Word16
subjPtr I16
subjCUs ->
    Text -> (Ptr Word16 -> I16 -> IO (CInt, Text)) -> IO (CInt, Text)
forall a. Text -> (Ptr Word16 -> I16 -> IO a) -> IO a
Text.useAsPtr Text
replacement ((Ptr Word16 -> I16 -> IO (CInt, Text)) -> IO (CInt, Text))
-> (Ptr Word16 -> I16 -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. (a -> b) -> a -> b
$ \Ptr Word16
replPtr I16
replCUs ->
    (Ptr PCRE2_SIZE -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr PCRE2_SIZE -> IO (CInt, Text)) -> IO (CInt, Text))
-> (Ptr PCRE2_SIZE -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. (a -> b) -> a -> b
$ \Ptr PCRE2_SIZE
outLenPtr -> do
        let checkAndGetOutput :: CInt -> PCRE2_SPTR -> IO (CInt, Text)
            checkAndGetOutput :: CInt -> Ptr CUShort -> IO (CInt, Text)
checkAndGetOutput CInt
0      Ptr CUShort
_         = (CInt, Text) -> IO (CInt, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
0, Text
subject)
            checkAndGetOutput CInt
result Ptr CUShort
outBufPtr = do
                (CInt -> Bool) -> CInt -> IO ()
check (CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> CInt
0) CInt
result
                PCRE2_SIZE
outLen <- Ptr PCRE2_SIZE -> IO PCRE2_SIZE
forall a. Storable a => Ptr a -> IO a
peek Ptr PCRE2_SIZE
outLenPtr
                Text
out <- Ptr Word16 -> I16 -> IO Text
Text.fromPtr (Ptr CUShort -> Ptr Word16
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs Ptr CUShort
outBufPtr) (PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
outLen)
                (CInt, Text) -> IO (CInt, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
result, Text
out)

            run :: CUInt -> Ptr Pcre2_match_context -> PCRE2_SPTR -> IO CInt
            run :: CUInt -> Ptr Pcre2_match_context -> Ptr CUShort -> IO CInt
run CUInt
curOpts Ptr Pcre2_match_context
ctxPtr Ptr CUShort
outBufPtr = Ptr Pcre2_code
-> Ptr CUShort
-> PCRE2_SIZE
-> PCRE2_SIZE
-> CUInt
-> Ptr Pcre2_match_data
-> Ptr Pcre2_match_context
-> Ptr CUShort
-> PCRE2_SIZE
-> Ptr CUShort
-> Ptr PCRE2_SIZE
-> IO CInt
pcre2_substitute
                Ptr Pcre2_code
codePtr
                (Ptr Word16 -> Ptr CUShort
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs Ptr Word16
subjPtr)
                (I16 -> PCRE2_SIZE
forall a b. (Integral a, Num b) => a -> b
fromIntegral I16
subjCUs)
                PCRE2_SIZE
0
                (CUInt
matchEnvOpts CUInt -> CUInt -> CUInt
forall a. Bits a => a -> a -> a
.|. CUInt
curOpts)
                Ptr Pcre2_match_data
forall a. Ptr a
nullPtr
                Ptr Pcre2_match_context
ctxPtr
                (Ptr Word16 -> Ptr CUShort
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs Ptr Word16
replPtr)
                (I16 -> PCRE2_SIZE
forall a b. (Integral a, Num b) => a -> b
fromIntegral I16
replCUs)
                Ptr CUShort
outBufPtr
                Ptr PCRE2_SIZE
outLenPtr

            -- Guess the size of the output to be <= 2x that of the subject.
            initOutLen :: Int
initOutLen = Text -> Int
Text.length Text
subject Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2

        Ptr PCRE2_SIZE -> PCRE2_SIZE -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr PCRE2_SIZE
outLenPtr (PCRE2_SIZE -> IO ()) -> PCRE2_SIZE -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> PCRE2_SIZE
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
initOutLen
        MatchTempEnv {Maybe (ForeignPtr Pcre2_match_context)
Maybe (IORef CalloutState)
matchTempEnvRef :: Maybe (IORef CalloutState)
matchTempEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
matchTempEnvRef :: MatchTempEnv -> Maybe (IORef CalloutState)
matchTempEnvCtx :: MatchTempEnv -> Maybe (ForeignPtr Pcre2_match_context)
..} <- MatchEnv -> Text -> IO MatchTempEnv
mkMatchTempEnv MatchEnv
firstMatchEnv Text
subject
        Either (IntMap SubCalloutResult) (CInt, Text)
firstAttempt <- Maybe (ForeignPtr Pcre2_match_context)
-> (Ptr Pcre2_match_context
    -> IO (Either (IntMap SubCalloutResult) (CInt, Text)))
-> IO (Either (IntMap SubCalloutResult) (CInt, Text))
forall a b. Maybe (ForeignPtr a) -> (Ptr a -> IO b) -> IO b
withForeignOrNullPtr Maybe (ForeignPtr Pcre2_match_context)
matchTempEnvCtx ((Ptr Pcre2_match_context
  -> IO (Either (IntMap SubCalloutResult) (CInt, Text)))
 -> IO (Either (IntMap SubCalloutResult) (CInt, Text)))
-> (Ptr Pcre2_match_context
    -> IO (Either (IntMap SubCalloutResult) (CInt, Text)))
-> IO (Either (IntMap SubCalloutResult) (CInt, Text))
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_match_context
ctxPtr ->
            Int
-> (Ptr CUShort
    -> IO (Either (IntMap SubCalloutResult) (CInt, Text)))
-> IO (Either (IntMap SubCalloutResult) (CInt, Text))
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
initOutLen ((Ptr CUShort
  -> IO (Either (IntMap SubCalloutResult) (CInt, Text)))
 -> IO (Either (IntMap SubCalloutResult) (CInt, Text)))
-> (Ptr CUShort
    -> IO (Either (IntMap SubCalloutResult) (CInt, Text)))
-> IO (Either (IntMap SubCalloutResult) (CInt, Text))
forall a b. (a -> b) -> a -> b
$ \Ptr CUShort
outBufPtr -> do
                CInt
result <- CUInt -> Ptr Pcre2_match_context -> Ptr CUShort -> IO CInt
run CUInt
pcre2_SUBSTITUTE_OVERFLOW_LENGTH Ptr Pcre2_match_context
ctxPtr Ptr CUShort
outBufPtr
                Maybe (IORef CalloutState) -> IO ()
maybeRethrow Maybe (IORef CalloutState)
matchTempEnvRef
                if CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
pcre2_ERROR_NOMEMORY
                    then IntMap SubCalloutResult
-> Either (IntMap SubCalloutResult) (CInt, Text)
forall a b. a -> Either a b
Left (IntMap SubCalloutResult
 -> Either (IntMap SubCalloutResult) (CInt, Text))
-> IO (IntMap SubCalloutResult)
-> IO (Either (IntMap SubCalloutResult) (CInt, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe (IORef CalloutState)
matchTempEnvRef of
                        Maybe (IORef CalloutState)
Nothing  -> IntMap SubCalloutResult -> IO (IntMap SubCalloutResult)
forall (m :: * -> *) a. Monad m => a -> m a
return IntMap SubCalloutResult
forall a. IntMap a
IM.empty
                        Just IORef CalloutState
ref -> CalloutState -> IntMap SubCalloutResult
calloutStateSubsLog (CalloutState -> IntMap SubCalloutResult)
-> IO CalloutState -> IO (IntMap SubCalloutResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef CalloutState -> IO CalloutState
forall a. IORef a -> IO a
readIORef IORef CalloutState
ref
                    else (CInt, Text) -> Either (IntMap SubCalloutResult) (CInt, Text)
forall a b. b -> Either a b
Right ((CInt, Text) -> Either (IntMap SubCalloutResult) (CInt, Text))
-> IO (CInt, Text)
-> IO (Either (IntMap SubCalloutResult) (CInt, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CInt -> Ptr CUShort -> IO (CInt, Text)
checkAndGetOutput CInt
result Ptr CUShort
outBufPtr

        case Either (IntMap SubCalloutResult) (CInt, Text)
firstAttempt of
            Right (CInt, Text)
resultAndOutput -> (CInt, Text) -> IO (CInt, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt, Text)
resultAndOutput
            Left IntMap SubCalloutResult
subsLog          -> do
                -- The output was bigger than we guessed.  Try again.
                Int
computedOutLen <- PCRE2_SIZE -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PCRE2_SIZE -> Int) -> IO PCRE2_SIZE -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PCRE2_SIZE -> IO PCRE2_SIZE
forall a. Storable a => Ptr a -> IO a
peek Ptr PCRE2_SIZE
outLenPtr
                let finalMatchEnv :: MatchEnv
finalMatchEnv = MatchEnv
firstMatchEnv {
                        -- Do not run regular callouts again.
                        matchEnvCallout :: Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCallout = Maybe (CalloutInfo -> IO CalloutResult)
forall a. Maybe a
Nothing,
                        -- Do not run any substitution callouts run previously.
                        matchEnvSubCallout :: Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvSubCallout = (SubCalloutInfo -> IO SubCalloutResult)
-> SubCalloutInfo -> IO SubCalloutResult
fastFwd ((SubCalloutInfo -> IO SubCalloutResult)
 -> SubCalloutInfo -> IO SubCalloutResult)
-> Maybe (SubCalloutInfo -> IO SubCalloutResult)
-> Maybe (SubCalloutInfo -> IO SubCalloutResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvSubCallout}
                    fastFwd :: (SubCalloutInfo -> IO SubCalloutResult)
-> SubCalloutInfo -> IO SubCalloutResult
fastFwd SubCalloutInfo -> IO SubCalloutResult
f = \SubCalloutInfo
info ->
                        case IntMap SubCalloutResult
subsLog IntMap SubCalloutResult -> Int -> Maybe SubCalloutResult
forall a. IntMap a -> Int -> Maybe a
IM.!? SubCalloutInfo -> Int
subCalloutSubsCount SubCalloutInfo
info of
                            Just SubCalloutResult
result -> SubCalloutResult -> IO SubCalloutResult
forall (m :: * -> *) a. Monad m => a -> m a
return SubCalloutResult
result
                            Maybe SubCalloutResult
Nothing     -> SubCalloutInfo -> IO SubCalloutResult
f SubCalloutInfo
info
                MatchTempEnv {Maybe (ForeignPtr Pcre2_match_context)
Maybe (IORef CalloutState)
matchTempEnvRef :: Maybe (IORef CalloutState)
matchTempEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
matchTempEnvRef :: MatchTempEnv -> Maybe (IORef CalloutState)
matchTempEnvCtx :: MatchTempEnv -> Maybe (ForeignPtr Pcre2_match_context)
..} <- MatchEnv -> Text -> IO MatchTempEnv
mkMatchTempEnv MatchEnv
finalMatchEnv Text
subject
                Maybe (ForeignPtr Pcre2_match_context)
-> (Ptr Pcre2_match_context -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. Maybe (ForeignPtr a) -> (Ptr a -> IO b) -> IO b
withForeignOrNullPtr Maybe (ForeignPtr Pcre2_match_context)
matchTempEnvCtx ((Ptr Pcre2_match_context -> IO (CInt, Text)) -> IO (CInt, Text))
-> (Ptr Pcre2_match_context -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_match_context
ctxPtr ->
                    Int -> (Ptr CUShort -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
computedOutLen ((Ptr CUShort -> IO (CInt, Text)) -> IO (CInt, Text))
-> (Ptr CUShort -> IO (CInt, Text)) -> IO (CInt, Text)
forall a b. (a -> b) -> a -> b
$ \Ptr CUShort
outBufPtr -> do
                        CInt
result <- CUInt -> Ptr Pcre2_match_context -> Ptr CUShort -> IO CInt
run CUInt
0 Ptr Pcre2_match_context
ctxPtr Ptr CUShort
outBufPtr
                        Maybe (IORef CalloutState) -> IO ()
maybeRethrow Maybe (IORef CalloutState)
matchTempEnvRef
                        CInt -> Ptr CUShort -> IO (CInt, Text)
checkAndGetOutput CInt
result Ptr CUShort
outBufPtr

-- | Generate per-call data for @pcre2_match()@ etc., to accommodate callouts.
--
-- We need to save and inspect state that occurs in potentially concurrent
-- matches.  This means a new state ref for each match, which means a new
-- `FunPtr` to close on it, which means a new match context to set it to.
mkMatchTempEnv
    :: MatchEnv
    -> Text -- ^ Callout info requires access to the original subject.
    -> IO MatchTempEnv
mkMatchTempEnv :: MatchEnv -> Text -> IO MatchTempEnv
mkMatchTempEnv (MatchEnv {Maybe (ForeignPtr Pcre2_match_context)
Maybe (SubCalloutInfo -> IO SubCalloutResult)
Maybe (CalloutInfo -> IO CalloutResult)
Code
CUInt
matchEnvSubCallout :: Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvCallout :: Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
matchEnvOpts :: CUInt
matchEnvCode :: Code
matchEnvSubCallout :: MatchEnv -> Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvCallout :: MatchEnv -> Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCtx :: MatchEnv -> Maybe (ForeignPtr Pcre2_match_context)
matchEnvOpts :: MatchEnv -> CUInt
matchEnvCode :: MatchEnv -> Code
..}) Text
subject
    | Maybe (CalloutInfo -> IO CalloutResult) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCallout Bool -> Bool -> Bool
&& Maybe (SubCalloutInfo -> IO SubCalloutResult) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvSubCallout = MatchTempEnv -> IO MatchTempEnv
forall (m :: * -> *) a. Monad m => a -> m a
return MatchTempEnv
noCallouts
    | Bool
otherwise                                       = do
        IORef CalloutState
calloutStateRef <- CalloutState -> IO (IORef CalloutState)
forall a. a -> IO (IORef a)
newIORef (CalloutState -> IO (IORef CalloutState))
-> CalloutState -> IO (IORef CalloutState)
forall a b. (a -> b) -> a -> b
$ CalloutState :: Maybe SomeException -> IntMap SubCalloutResult -> CalloutState
CalloutState {
            calloutStateException :: Maybe SomeException
calloutStateException = Maybe SomeException
forall a. Maybe a
Nothing,
            calloutStateSubsLog :: IntMap SubCalloutResult
calloutStateSubsLog   = IntMap SubCalloutResult
forall a. IntMap a
IM.empty}
        ForeignPtr Pcre2_match_context
ctx <- (Ptr Pcre2_match_context -> IO ())
-> IO (Ptr Pcre2_match_context)
-> IO (ForeignPtr Pcre2_match_context)
forall a. (Ptr a -> IO ()) -> IO (Ptr a) -> IO (ForeignPtr a)
mkForeignPtr Ptr Pcre2_match_context -> IO ()
pcre2_match_context_free IO (Ptr Pcre2_match_context)
ctxPtrForCallouts

        -- Install C function pointers in the @pcre2_match_context@.  When
        -- dereferenced and called, they will force the user-supplied Haskell
        -- callout functions and their results, catching any exceptions and
        -- saving them.

        -- Install callout, if any
        Maybe (CalloutInfo -> IO CalloutResult)
-> ((CalloutInfo -> IO CalloutResult) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (CalloutInfo -> IO CalloutResult)
matchEnvCallout (((CalloutInfo -> IO CalloutResult) -> IO ()) -> IO ())
-> ((CalloutInfo -> IO CalloutResult) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CalloutInfo -> IO CalloutResult
f -> do
            FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt)
fPtr <- ForeignPtr Pcre2_match_context
-> IO (FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt))
-> IO (FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt))
forall b a. ForeignPtr b -> IO (FunPtr a) -> IO (FunPtr a)
mkFunPtr ForeignPtr Pcre2_match_context
ctx (IO (FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt))
 -> IO (FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt)))
-> IO (FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt))
-> IO (FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt))
forall a b. (a -> b) -> a -> b
$ (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt)
-> IO (FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt))
forall block a.
(Ptr block -> Ptr a -> IO CInt)
-> IO (FunPtr (Ptr block -> Ptr a -> IO CInt))
mkCallout ((Ptr Pcre2_callout_block -> Ptr Any -> IO CInt)
 -> IO (FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt)))
-> (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt)
-> IO (FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt))
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_callout_block
blockPtr Ptr Any
_ -> do
                CalloutInfo
info <- Text -> Ptr Pcre2_callout_block -> IO CalloutInfo
getCalloutInfo Text
subject Ptr Pcre2_callout_block
blockPtr
                Either SomeException CalloutResult
resultOrE <- IO CalloutResult -> IO (Either SomeException CalloutResult)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO CalloutResult -> IO (Either SomeException CalloutResult))
-> IO CalloutResult -> IO (Either SomeException CalloutResult)
forall a b. (a -> b) -> a -> b
$ do
                    CalloutInfo -> IO CalloutResult
f <- (CalloutInfo -> IO CalloutResult)
-> IO (CalloutInfo -> IO CalloutResult)
forall a. a -> IO a
evaluate CalloutInfo -> IO CalloutResult
f
                    CalloutResult
result <- CalloutInfo -> IO CalloutResult
f CalloutInfo
info
                    CalloutResult -> IO CalloutResult
forall a. a -> IO a
evaluate CalloutResult
result
                case Either SomeException CalloutResult
resultOrE of
                    Right CalloutResult
result -> CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ case CalloutResult
result of
                        CalloutResult
CalloutProceed     -> CInt
0
                        CalloutResult
CalloutNoMatchHere -> CInt
1
                        CalloutResult
CalloutNoMatch     -> CInt
pcre2_ERROR_NOMATCH
                    Left SomeException
e -> do
                        IORef CalloutState -> (CalloutState -> CalloutState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef CalloutState
calloutStateRef ((CalloutState -> CalloutState) -> IO ())
-> (CalloutState -> CalloutState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CalloutState
cst -> CalloutState
cst {
                            calloutStateException :: Maybe SomeException
calloutStateException = SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e}
                        CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
pcre2_ERROR_CALLOUT
            ForeignPtr Pcre2_match_context
-> (Ptr Pcre2_match_context -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Pcre2_match_context
ctx ((Ptr Pcre2_match_context -> IO ()) -> IO ())
-> (Ptr Pcre2_match_context -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_match_context
ctxPtr ->
                Ptr Pcre2_match_context
-> FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt)
-> Ptr Any
-> IO CInt
forall a.
Ptr Pcre2_match_context
-> FunPtr (Ptr Pcre2_callout_block -> Ptr a -> IO CInt)
-> Ptr a
-> IO CInt
pcre2_set_callout Ptr Pcre2_match_context
ctxPtr FunPtr (Ptr Pcre2_callout_block -> Ptr Any -> IO CInt)
fPtr Ptr Any
forall a. Ptr a
nullPtr IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
check (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0)

        -- Install substitution callout, if any
        Maybe (SubCalloutInfo -> IO SubCalloutResult)
-> ((SubCalloutInfo -> IO SubCalloutResult) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (SubCalloutInfo -> IO SubCalloutResult)
matchEnvSubCallout (((SubCalloutInfo -> IO SubCalloutResult) -> IO ()) -> IO ())
-> ((SubCalloutInfo -> IO SubCalloutResult) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SubCalloutInfo -> IO SubCalloutResult
f -> do
            FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt)
fPtr <- ForeignPtr Pcre2_match_context
-> IO
     (FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt))
-> IO
     (FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt))
forall b a. ForeignPtr b -> IO (FunPtr a) -> IO (FunPtr a)
mkFunPtr ForeignPtr Pcre2_match_context
ctx (IO
   (FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt))
 -> IO
      (FunPtr
         (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt)))
-> IO
     (FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt))
-> IO
     (FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt))
forall a b. (a -> b) -> a -> b
$ (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt)
-> IO
     (FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt))
forall block a.
(Ptr block -> Ptr a -> IO CInt)
-> IO (FunPtr (Ptr block -> Ptr a -> IO CInt))
mkCallout ((Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt)
 -> IO
      (FunPtr
         (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt)))
-> (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt)
-> IO
     (FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt))
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_substitute_callout_block
blockPtr Ptr Any
_ -> do
                SubCalloutInfo
info <- Text -> Ptr Pcre2_substitute_callout_block -> IO SubCalloutInfo
getSubCalloutInfo Text
subject Ptr Pcre2_substitute_callout_block
blockPtr
                Either SomeException SubCalloutResult
resultOrE <- IO SubCalloutResult -> IO (Either SomeException SubCalloutResult)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO SubCalloutResult -> IO (Either SomeException SubCalloutResult))
-> IO SubCalloutResult
-> IO (Either SomeException SubCalloutResult)
forall a b. (a -> b) -> a -> b
$ do
                    SubCalloutInfo -> IO SubCalloutResult
f <- (SubCalloutInfo -> IO SubCalloutResult)
-> IO (SubCalloutInfo -> IO SubCalloutResult)
forall a. a -> IO a
evaluate SubCalloutInfo -> IO SubCalloutResult
f
                    SubCalloutResult
result <- SubCalloutInfo -> IO SubCalloutResult
f SubCalloutInfo
info
                    SubCalloutResult -> IO SubCalloutResult
forall a. a -> IO a
evaluate SubCalloutResult
result
                case Either SomeException SubCalloutResult
resultOrE of
                    Right SubCalloutResult
result -> do
                        IORef CalloutState -> (CalloutState -> CalloutState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef CalloutState
calloutStateRef ((CalloutState -> CalloutState) -> IO ())
-> (CalloutState -> CalloutState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CalloutState
cst -> CalloutState
cst {
                            calloutStateSubsLog :: IntMap SubCalloutResult
calloutStateSubsLog = Int
-> SubCalloutResult
-> IntMap SubCalloutResult
-> IntMap SubCalloutResult
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert
                                (SubCalloutInfo -> Int
subCalloutSubsCount SubCalloutInfo
info)
                                SubCalloutResult
result
                                (CalloutState -> IntMap SubCalloutResult
calloutStateSubsLog CalloutState
cst)}
                        CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ case SubCalloutResult
result of
                            SubCalloutResult
SubCalloutAccept ->  CInt
0
                            SubCalloutResult
SubCalloutSkip   ->  CInt
1
                            SubCalloutResult
SubCalloutAbort  -> -CInt
1
                    Left SomeException
e -> do
                        IORef CalloutState -> (CalloutState -> CalloutState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef CalloutState
calloutStateRef ((CalloutState -> CalloutState) -> IO ())
-> (CalloutState -> CalloutState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CalloutState
cst -> CalloutState
cst {
                            calloutStateException :: Maybe SomeException
calloutStateException = SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e}
                        CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (-CInt
1)
            ForeignPtr Pcre2_match_context
-> (Ptr Pcre2_match_context -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Pcre2_match_context
ctx ((Ptr Pcre2_match_context -> IO ()) -> IO ())
-> (Ptr Pcre2_match_context -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_match_context
ctxPtr -> do
                CInt
result <- Ptr Pcre2_match_context
-> FunPtr
     (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt)
-> Ptr Any
-> IO CInt
forall a.
Ptr Pcre2_match_context
-> FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr a -> IO CInt)
-> Ptr a
-> IO CInt
pcre2_set_substitute_callout Ptr Pcre2_match_context
ctxPtr FunPtr (Ptr Pcre2_substitute_callout_block -> Ptr Any -> IO CInt)
fPtr Ptr Any
forall a. Ptr a
nullPtr
                (CInt -> Bool) -> CInt -> IO ()
check (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0) CInt
result

        MatchTempEnv -> IO MatchTempEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchTempEnv -> IO MatchTempEnv)
-> MatchTempEnv -> IO MatchTempEnv
forall a b. (a -> b) -> a -> b
$ MatchTempEnv :: Maybe (ForeignPtr Pcre2_match_context)
-> Maybe (IORef CalloutState) -> MatchTempEnv
MatchTempEnv {
            matchTempEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
matchTempEnvCtx = ForeignPtr Pcre2_match_context
-> Maybe (ForeignPtr Pcre2_match_context)
forall a. a -> Maybe a
Just ForeignPtr Pcre2_match_context
ctx,
            matchTempEnvRef :: Maybe (IORef CalloutState)
matchTempEnvRef = IORef CalloutState -> Maybe (IORef CalloutState)
forall a. a -> Maybe a
Just IORef CalloutState
calloutStateRef}

    where
    noCallouts :: MatchTempEnv
noCallouts = MatchTempEnv :: Maybe (ForeignPtr Pcre2_match_context)
-> Maybe (IORef CalloutState) -> MatchTempEnv
MatchTempEnv {
        matchTempEnvCtx :: Maybe (ForeignPtr Pcre2_match_context)
matchTempEnvCtx = Maybe (ForeignPtr Pcre2_match_context)
matchEnvCtx,
        matchTempEnvRef :: Maybe (IORef CalloutState)
matchTempEnvRef = Maybe (IORef CalloutState)
forall a. Maybe a
Nothing}
    ctxPtrForCallouts :: IO (Ptr Pcre2_match_context)
ctxPtrForCallouts = case Maybe (ForeignPtr Pcre2_match_context)
matchEnvCtx of
        -- No pre-existing match context, so create one afresh.
        Maybe (ForeignPtr Pcre2_match_context)
Nothing -> Ptr Pcre2_general_context -> IO (Ptr Pcre2_match_context)
pcre2_match_context_create Ptr Pcre2_general_context
forall a. Ptr a
nullPtr
        -- Pre-existing match context, so copy it.
        Just ForeignPtr Pcre2_match_context
ctx -> ForeignPtr Pcre2_match_context
-> (Ptr Pcre2_match_context -> IO (Ptr Pcre2_match_context))
-> IO (Ptr Pcre2_match_context)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Pcre2_match_context
ctx Ptr Pcre2_match_context -> IO (Ptr Pcre2_match_context)
pcre2_match_context_copy

-- | Per-call data for @pcre2_match()@ etc.
data MatchTempEnv = MatchTempEnv {
    MatchTempEnv -> Maybe (ForeignPtr Pcre2_match_context)
matchTempEnvCtx :: Maybe MatchContext,
    MatchTempEnv -> Maybe (IORef CalloutState)
matchTempEnvRef :: Maybe (IORef CalloutState)}

-- | Data computed during callouts that will be stashed in an IORef and
-- inspected after @pcre2_match()@ or similar completes.
data CalloutState = CalloutState {
    CalloutState -> Maybe SomeException
calloutStateException :: Maybe SomeException,
    CalloutState -> IntMap SubCalloutResult
calloutStateSubsLog   :: IntMap SubCalloutResult}

-- | FFI wrapper.
foreign import ccall "wrapper" mkRecursionGuard
    :: (CUInt -> Ptr a -> IO CInt)
    -> IO (FunPtr (CUInt -> Ptr a -> IO CInt))

-- | FFI wrapper.
foreign import ccall "wrapper" mkCallout
    :: (Ptr block -> Ptr a -> IO CInt)
    -> IO (FunPtr (Ptr block -> Ptr a -> IO CInt))

-- | Within a callout, marshal the original subject and @pcre2_callout_block@
-- data to Haskell and present to the user function.  Ensure no pointers are
-- leaked!
getCalloutInfo :: Text -> Ptr Pcre2_callout_block -> IO CalloutInfo
getCalloutInfo :: Text -> Ptr Pcre2_callout_block -> IO CalloutInfo
getCalloutInfo Text
calloutSubject Ptr Pcre2_callout_block
blockPtr = do
    CalloutIndex
calloutIndex <- do
        Ptr CUShort
str <- Ptr Pcre2_callout_block -> IO (Ptr CUShort)
pcre2_callout_block_callout_string Ptr Pcre2_callout_block
blockPtr
        if Ptr CUShort
str Ptr CUShort -> Ptr CUShort -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CUShort
forall a. Ptr a
nullPtr
            then Ptr Pcre2_callout_block -> IO CUInt
pcre2_callout_block_callout_number Ptr Pcre2_callout_block
blockPtr IO CUInt -> (CUInt -> IO CalloutIndex) -> IO CalloutIndex
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                -- Auto callout
                CUInt
255 -> (Int -> Int -> CalloutIndex) -> IO Int -> IO Int -> IO CalloutIndex
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Int -> Int -> CalloutIndex
CalloutAuto IO Int
pattPos IO Int
itemLen where
                    pattPos :: IO Int
pattPos = (Ptr Pcre2_callout_block -> IO PCRE2_SIZE) -> IO Int
intVia Ptr Pcre2_callout_block -> IO PCRE2_SIZE
pcre2_callout_block_pattern_position
                    itemLen :: IO Int
itemLen = (Ptr Pcre2_callout_block -> IO PCRE2_SIZE) -> IO Int
intVia Ptr Pcre2_callout_block -> IO PCRE2_SIZE
pcre2_callout_block_next_item_length
                    intVia :: (Ptr Pcre2_callout_block -> IO PCRE2_SIZE) -> IO Int
intVia Ptr Pcre2_callout_block -> IO PCRE2_SIZE
getter = PCRE2_SIZE -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PCRE2_SIZE -> Int) -> IO PCRE2_SIZE -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Pcre2_callout_block -> IO PCRE2_SIZE
getter Ptr Pcre2_callout_block
blockPtr
                -- Numerical callout
                CUInt
number -> CalloutIndex -> IO CalloutIndex
forall (m :: * -> *) a. Monad m => a -> m a
return (CalloutIndex -> IO CalloutIndex)
-> CalloutIndex -> IO CalloutIndex
forall a b. (a -> b) -> a -> b
$ Int -> CalloutIndex
CalloutNumber (Int -> CalloutIndex) -> Int -> CalloutIndex
forall a b. (a -> b) -> a -> b
$ CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
number
            else do
                -- String callout
                PCRE2_SIZE
len <- Ptr Pcre2_callout_block -> IO PCRE2_SIZE
pcre2_callout_block_callout_string_length Ptr Pcre2_callout_block
blockPtr
                Text -> CalloutIndex
CalloutName (Text -> CalloutIndex) -> IO Text -> IO CalloutIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word16 -> I16 -> IO Text
Text.fromPtr (Ptr CUShort -> Ptr Word16
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs Ptr CUShort
str) (PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
len)

    NonEmpty (Maybe Text)
calloutCaptures <- do
        Ptr PCRE2_SIZE
ovecPtr <- Ptr Pcre2_callout_block -> IO (Ptr PCRE2_SIZE)
pcre2_callout_block_offset_vector Ptr Pcre2_callout_block
blockPtr
        CUInt
top <- Ptr Pcre2_callout_block -> IO CUInt
pcre2_callout_block_capture_top Ptr Pcre2_callout_block
blockPtr
        NonEmpty Int
-> (Int -> IO (Maybe Text)) -> IO (NonEmpty (Maybe Text))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1 .. CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
top Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]) ((Int -> IO (Maybe Text)) -> IO (NonEmpty (Maybe Text)))
-> (Int -> IO (Maybe Text)) -> IO (NonEmpty (Maybe Text))
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
            [PCRE2_SIZE
start, PCRE2_SIZE
end] <- [Int] -> (Int -> IO PCRE2_SIZE) -> IO [PCRE2_SIZE]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0, Int
1] ((Int -> IO PCRE2_SIZE) -> IO [PCRE2_SIZE])
-> (Int -> IO PCRE2_SIZE) -> IO [PCRE2_SIZE]
forall a b. (a -> b) -> a -> b
$ Ptr PCRE2_SIZE -> Int -> IO PCRE2_SIZE
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr PCRE2_SIZE
ovecPtr (Int -> IO PCRE2_SIZE) -> (Int -> Int) -> Int -> IO PCRE2_SIZE
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
            Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if PCRE2_SIZE
start PCRE2_SIZE -> PCRE2_SIZE -> Bool
forall a. Eq a => a -> a -> Bool
== PCRE2_SIZE
pcre2_UNSET
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> SliceRange -> Text
slice Text
calloutSubject (SliceRange -> Text) -> SliceRange -> Text
forall a b. (a -> b) -> a -> b
$ I16 -> I16 -> SliceRange
SliceRange
                    (PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
start)
                    (PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
end)

    Maybe Text
calloutMark <- do
        Ptr CUShort
ptr <- Ptr Pcre2_callout_block -> IO (Ptr CUShort)
pcre2_callout_block_mark Ptr Pcre2_callout_block
blockPtr
        if Ptr CUShort
ptr Ptr CUShort -> Ptr CUShort -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CUShort
forall a. Ptr a
nullPtr
            then Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
            else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                -- TODO Replace this with a more obviously best way to slurp a
                -- zero-terminated region of memory into a `Text`, given
                -- whatever the pcre2callout spec means by "zero-terminated".
                Int
len <- Int -> ((Int -> IO Int) -> Int -> IO Int) -> IO Int
forall a b. a -> ((a -> b) -> a -> b) -> b
fix1 Int
0 (((Int -> IO Int) -> Int -> IO Int) -> IO Int)
-> ((Int -> IO Int) -> Int -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int -> IO Int
continue Int
off -> Ptr CUShort -> Int -> IO CUShort
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CUShort
ptr Int
off IO CUShort -> (CUShort -> IO Int) -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    CUShort
0 -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                    CUShort
_ -> Int -> IO Int
continue (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                Ptr Word16 -> I16 -> IO Text
Text.fromPtr (Ptr CUShort -> Ptr Word16
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs Ptr CUShort
ptr) (Int -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)

    CUInt
flags <- Ptr Pcre2_callout_block -> IO CUInt
pcre2_callout_block_callout_flags Ptr Pcre2_callout_block
blockPtr
    let calloutIsFirst :: Bool
calloutIsFirst = CUInt
flags CUInt -> CUInt -> CUInt
forall a. Bits a => a -> a -> a
.&. CUInt
pcre2_CALLOUT_STARTMATCH CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CUInt
0
        calloutBacktracked :: Bool
calloutBacktracked = CUInt
flags CUInt -> CUInt -> CUInt
forall a. Bits a => a -> a -> a
.&. CUInt
pcre2_CALLOUT_BACKTRACK CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CUInt
0

    CalloutInfo -> IO CalloutInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (CalloutInfo -> IO CalloutInfo) -> CalloutInfo -> IO CalloutInfo
forall a b. (a -> b) -> a -> b
$ CalloutInfo :: CalloutIndex
-> NonEmpty (Maybe Text)
-> Text
-> Maybe Text
-> Bool
-> Bool
-> CalloutInfo
CalloutInfo {Bool
Maybe Text
NonEmpty (Maybe Text)
Text
CalloutIndex
calloutBacktracked :: Bool
calloutIsFirst :: Bool
calloutMark :: Maybe Text
calloutCaptures :: NonEmpty (Maybe Text)
calloutIndex :: CalloutIndex
calloutSubject :: Text
calloutBacktracked :: Bool
calloutIsFirst :: Bool
calloutMark :: Maybe Text
calloutSubject :: Text
calloutCaptures :: NonEmpty (Maybe Text)
calloutIndex :: CalloutIndex
..}

-- | Within a substitution callout, marshal the original subject and
-- @pcre2_substitute_callout_block@ data to Haskell and present to the user
-- function.  Ensure no pointers are leaked!
getSubCalloutInfo
    :: Text -> Ptr Pcre2_substitute_callout_block -> IO SubCalloutInfo
getSubCalloutInfo :: Text -> Ptr Pcre2_substitute_callout_block -> IO SubCalloutInfo
getSubCalloutInfo Text
subCalloutSubject Ptr Pcre2_substitute_callout_block
blockPtr = do
    Int
subCalloutSubsCount <-
        CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> IO CUInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Pcre2_substitute_callout_block -> IO CUInt
pcre2_substitute_callout_block_subscount Ptr Pcre2_substitute_callout_block
blockPtr

    NonEmpty (Maybe Text)
subCalloutCaptures <- do
        Ptr PCRE2_SIZE
ovecPtr <- Ptr Pcre2_substitute_callout_block -> IO (Ptr PCRE2_SIZE)
pcre2_substitute_callout_block_ovector Ptr Pcre2_substitute_callout_block
blockPtr
        CUInt
ovecCount <- Ptr Pcre2_substitute_callout_block -> IO CUInt
pcre2_substitute_callout_block_oveccount Ptr Pcre2_substitute_callout_block
blockPtr
        NonEmpty Int
-> (Int -> IO (Maybe Text)) -> IO (NonEmpty (Maybe Text))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1 .. CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
ovecCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]) ((Int -> IO (Maybe Text)) -> IO (NonEmpty (Maybe Text)))
-> (Int -> IO (Maybe Text)) -> IO (NonEmpty (Maybe Text))
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
            [PCRE2_SIZE
start, PCRE2_SIZE
end] <- [Int] -> (Int -> IO PCRE2_SIZE) -> IO [PCRE2_SIZE]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0, Int
1] ((Int -> IO PCRE2_SIZE) -> IO [PCRE2_SIZE])
-> (Int -> IO PCRE2_SIZE) -> IO [PCRE2_SIZE]
forall a b. (a -> b) -> a -> b
$ Ptr PCRE2_SIZE -> Int -> IO PCRE2_SIZE
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr PCRE2_SIZE
ovecPtr (Int -> IO PCRE2_SIZE) -> (Int -> Int) -> Int -> IO PCRE2_SIZE
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
            Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if PCRE2_SIZE
start PCRE2_SIZE -> PCRE2_SIZE -> Bool
forall a. Eq a => a -> a -> Bool
== PCRE2_SIZE
pcre2_UNSET
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> SliceRange -> Text
slice Text
subCalloutSubject (SliceRange -> Text) -> SliceRange -> Text
forall a b. (a -> b) -> a -> b
$ I16 -> I16 -> SliceRange
SliceRange
                    (PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
start)
                    (PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
end)

    Text
subCalloutReplacement <- do
        Ptr CUShort
outPtr <- Ptr Pcre2_substitute_callout_block -> IO (Ptr CUShort)
pcre2_substitute_callout_block_output Ptr Pcre2_substitute_callout_block
blockPtr
        Ptr PCRE2_SIZE
offsetsPtr <- Ptr Pcre2_substitute_callout_block -> IO (Ptr PCRE2_SIZE)
pcre2_substitute_callout_block_output_offsets Ptr Pcre2_substitute_callout_block
blockPtr
        [PCRE2_SIZE
start, PCRE2_SIZE
end] <- [Int] -> (Int -> IO PCRE2_SIZE) -> IO [PCRE2_SIZE]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0, Int
1] ((Int -> IO PCRE2_SIZE) -> IO [PCRE2_SIZE])
-> (Int -> IO PCRE2_SIZE) -> IO [PCRE2_SIZE]
forall a b. (a -> b) -> a -> b
$ Ptr PCRE2_SIZE -> Int -> IO PCRE2_SIZE
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr PCRE2_SIZE
offsetsPtr
        Ptr Word16 -> I16 -> IO Text
Text.fromPtr
            (Ptr CUShort -> Ptr Word16
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs (Ptr CUShort -> Ptr Word16) -> Ptr CUShort -> Ptr Word16
forall a b. (a -> b) -> a -> b
$ Ptr CUShort -> Int -> Ptr CUShort
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr CUShort
outPtr (Int -> Ptr CUShort) -> Int -> Ptr CUShort
forall a b. (a -> b) -> a -> b
$ PCRE2_SIZE -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
start)
            (PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PCRE2_SIZE -> I16) -> PCRE2_SIZE -> I16
forall a b. (a -> b) -> a -> b
$ PCRE2_SIZE
end PCRE2_SIZE -> PCRE2_SIZE -> PCRE2_SIZE
forall a. Num a => a -> a -> a
- PCRE2_SIZE
start)

    SubCalloutInfo -> IO SubCalloutInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (SubCalloutInfo -> IO SubCalloutInfo)
-> SubCalloutInfo -> IO SubCalloutInfo
forall a b. (a -> b) -> a -> b
$ SubCalloutInfo :: Int -> NonEmpty (Maybe Text) -> Text -> Text -> SubCalloutInfo
SubCalloutInfo {Int
NonEmpty (Maybe Text)
Text
subCalloutReplacement :: Text
subCalloutCaptures :: NonEmpty (Maybe Text)
subCalloutSubsCount :: Int
subCalloutSubject :: Text
subCalloutReplacement :: Text
subCalloutSubject :: Text
subCalloutCaptures :: NonEmpty (Maybe Text)
subCalloutSubsCount :: Int
..}

-- | If there was a callout and it threw an exception, rethrow it.
maybeRethrow :: Maybe (IORef CalloutState) -> IO ()
maybeRethrow :: Maybe (IORef CalloutState) -> IO ()
maybeRethrow = (IORef CalloutState -> IO ())
-> Maybe (IORef CalloutState) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((IORef CalloutState -> IO ())
 -> Maybe (IORef CalloutState) -> IO ())
-> (IORef CalloutState -> IO ())
-> Maybe (IORef CalloutState)
-> IO ()
forall a b. (a -> b) -> a -> b
$ IORef CalloutState -> IO CalloutState
forall a. IORef a -> IO a
readIORef (IORef CalloutState -> IO CalloutState)
-> (CalloutState -> IO ()) -> IORef CalloutState -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (SomeException -> IO Any) -> Maybe SomeException -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SomeException -> IO Any
forall e a. Exception e => e -> IO a
throwIO (Maybe SomeException -> IO ())
-> (CalloutState -> Maybe SomeException) -> CalloutState -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalloutState -> Maybe SomeException
calloutStateException

-- * Packaging @Matcher@s and @Subber@s as public API functions

-- | The most general form of a matching function, which can also be used as a
-- @Setter'@ to perform substitutions at the Haskell level.  Operates globally.
--
-- Internal only!  Users should not (have to) know about `Matcher`.
_capturesInternal :: Matcher -> FromMatch -> Traversal' Text (NonEmpty Text)
_capturesInternal :: Matcher -> FromMatch -> Traversal' Text (NonEmpty Text)
_capturesInternal Matcher
matcher FromMatch
fromMatch NonEmpty Text -> f (NonEmpty Text)
f Text
subject =
    (NonEmpty Text -> f (NonEmpty Text))
-> [NonEmpty Text] -> f [NonEmpty Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NonEmpty Text -> f (NonEmpty Text)
f [NonEmpty Text]
captureLists f [NonEmpty Text] -> ([NonEmpty Text] -> Text) -> f Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[NonEmpty Text]
captureLists' ->
        -- Swag foldl-as-foldr to create only as many segments as we need to
        -- stitch back together and no more.
        let triples :: [(SliceRange, Text, Text)]
triples = [[(SliceRange, Text, Text)]] -> [(SliceRange, Text, Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(SliceRange, Text, Text)]] -> [(SliceRange, Text, Text)])
-> [[(SliceRange, Text, Text)]] -> [(SliceRange, Text, Text)]
forall a b. (a -> b) -> a -> b
$ ([SliceRange] -> [Text] -> [Text] -> [(SliceRange, Text, Text)])
-> [[SliceRange]]
-> [[Text]]
-> [[Text]]
-> [[(SliceRange, Text, Text)]]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 [SliceRange] -> [Text] -> [Text] -> [(SliceRange, Text, Text)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3
                ((NonEmpty SliceRange -> [SliceRange])
-> [NonEmpty SliceRange] -> [[SliceRange]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty SliceRange -> [SliceRange]
forall a. NonEmpty a -> [a]
NE.toList [NonEmpty SliceRange]
sliceRangeLists)
                ((NonEmpty Text -> [Text]) -> [NonEmpty Text] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList [NonEmpty Text]
captureLists)
                ((NonEmpty Text -> [Text]) -> [NonEmpty Text] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList [NonEmpty Text]
captureLists')
        in [Text] -> Text
Text.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((SliceRange, Text, Text) -> (I16 -> [Text]) -> I16 -> [Text])
-> (I16 -> [Text]) -> [(SliceRange, Text, Text)] -> I16 -> [Text]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (SliceRange, Text, Text) -> (I16 -> [Text]) -> I16 -> [Text]
mkSegments I16 -> [Text]
termSegments [(SliceRange, Text, Text)]
triples I16
0

    where
    sliceRangeLists :: [NonEmpty SliceRange]
sliceRangeLists = Stream (NonEmpty SliceRange) IO Void -> [NonEmpty SliceRange]
forall b. Stream b IO Void -> [b]
unsafeLazyStreamToList (Stream (NonEmpty SliceRange) IO Void -> [NonEmpty SliceRange])
-> Stream (NonEmpty SliceRange) IO Void -> [NonEmpty SliceRange]
forall a b. (a -> b) -> a -> b
$ FromMatch
-> Stream (Ptr Pcre2_match_data) IO Void
-> Stream (NonEmpty SliceRange) IO Void
forall (m :: * -> *) b c a.
Functor m =>
(b -> m c) -> Stream b m a -> Stream c m a
mapMS FromMatch
fromMatch (Stream (Ptr Pcre2_match_data) IO Void
 -> Stream (NonEmpty SliceRange) IO Void)
-> Stream (Ptr Pcre2_match_data) IO Void
-> Stream (NonEmpty SliceRange) IO Void
forall a b. (a -> b) -> a -> b
$ Matcher
matcher Text
subject
    captureLists :: [NonEmpty Text]
captureLists = (NonEmpty SliceRange -> NonEmpty Text)
-> [NonEmpty SliceRange] -> [NonEmpty Text]
forall a b. (a -> b) -> [a] -> [b]
map ((SliceRange -> Text) -> NonEmpty SliceRange -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ((SliceRange -> Text) -> NonEmpty SliceRange -> NonEmpty Text)
-> (SliceRange -> Text) -> NonEmpty SliceRange -> NonEmpty Text
forall a b. (a -> b) -> a -> b
$ Text -> SliceRange -> Text
slice Text
subject) [NonEmpty SliceRange]
sliceRangeLists

    mkSegments :: (SliceRange, Text, Text) -> (I16 -> [Text]) -> I16 -> [Text]
mkSegments (SliceRange I16
off I16
offEnd, Text
c, Text
c') I16 -> [Text]
r I16
prevOffEnd
        | I16
off I16 -> I16 -> Bool
forall a. Eq a => a -> a -> Bool
== PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
pcre2_UNSET Bool -> Bool -> Bool
|| Text
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
c' =
            -- This substring is unset or unchanged.  Keep going without making
            -- cuts.
            I16 -> [Text]
r I16
prevOffEnd
        | Bool
otherwise =
            -- Emit the subject up until here, and the new substring, and keep
            -- going, remembering where we are now.
            Text -> SliceRange -> Text
thinSlice Text
subject (I16 -> I16 -> SliceRange
SliceRange I16
prevOffEnd I16
off) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
c' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: I16 -> [Text]
r I16
offEnd
    termSegments :: I16 -> [Text]
termSegments I16
off =
        let offEnd :: I16
offEnd = Int -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> I16) -> Int -> I16
forall a b. (a -> b) -> a -> b
$ Text -> Int
Text.length Text
subject
        -- If the terminal segment is empty, omit it altogether.  That way,
        -- `Text.concat` can just return the subject without copying anything in
        -- cases where no substring is changed.
        in [Text -> SliceRange -> Text
thinSlice Text
subject (I16 -> I16 -> SliceRange
SliceRange I16
off I16
offEnd) | I16
off I16 -> I16 -> Bool
forall a. Eq a => a -> a -> Bool
/= I16
offEnd]

-- | A function that takes a C match result and extracts a list of captures.  We
-- need to pass this effectful callback to `_capturesInternal` because of the
-- latter\'s imperative loop that reuses the same @pcre2_match_data@ block.
type FromMatch = Ptr Pcre2_match_data -> IO (NonEmpty SliceRange)

-- | Read all specifically indexed captures\' offsets from match results.
getWhitelistedSliceRanges :: NonEmpty Int -> FromMatch
getWhitelistedSliceRanges :: NonEmpty Int -> FromMatch
getWhitelistedSliceRanges NonEmpty Int
whitelist Ptr Pcre2_match_data
matchDataPtr = do
    Ptr PCRE2_SIZE
ovecPtr <- Ptr Pcre2_match_data -> IO (Ptr PCRE2_SIZE)
pcre2_get_ovector_pointer Ptr Pcre2_match_data
matchDataPtr
    let peekOvec :: Int -> IO Text.I16
        peekOvec :: Int -> IO I16
peekOvec = (PCRE2_SIZE -> I16) -> IO PCRE2_SIZE -> IO I16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PCRE2_SIZE -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO PCRE2_SIZE -> IO I16)
-> (Int -> IO PCRE2_SIZE) -> Int -> IO I16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr PCRE2_SIZE -> Int -> IO PCRE2_SIZE
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr PCRE2_SIZE
ovecPtr

    NonEmpty Int -> (Int -> IO SliceRange) -> IO (NonEmpty SliceRange)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty Int
whitelist ((Int -> IO SliceRange) -> IO (NonEmpty SliceRange))
-> (Int -> IO SliceRange) -> IO (NonEmpty SliceRange)
forall a b. (a -> b) -> a -> b
$ \Int
i -> (I16 -> I16 -> SliceRange) -> IO I16 -> IO I16 -> IO SliceRange
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 I16 -> I16 -> SliceRange
SliceRange
        (Int -> IO I16
peekOvec (Int -> IO I16) -> Int -> IO I16
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
        (Int -> IO I16
peekOvec (Int -> IO I16) -> Int -> IO I16
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

-- | Read just the 0th capture\'s offsets from match results.
get0thSliceRanges :: FromMatch
get0thSliceRanges :: FromMatch
get0thSliceRanges = NonEmpty Int -> FromMatch
getWhitelistedSliceRanges (NonEmpty Int -> FromMatch) -> NonEmpty Int -> FromMatch
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| []

-- | Read all captures\' offsets from match results.
getAllSliceRanges :: FromMatch
getAllSliceRanges :: FromMatch
getAllSliceRanges Ptr Pcre2_match_data
matchDataPtr = do
    Int
count <- CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> IO CUInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Pcre2_match_data -> IO CUInt
pcre2_get_ovector_count Ptr Pcre2_match_data
matchDataPtr
    let whitelist :: NonEmpty Int
whitelist = Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1 .. Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

    NonEmpty Int -> FromMatch
getWhitelistedSliceRanges NonEmpty Int
whitelist Ptr Pcre2_match_data
matchDataPtr

-- | Placeholder for half-building a `Traversal'` to be passed to `has`.
errorFromMatch :: FromMatch
errorFromMatch :: FromMatch
errorFromMatch Ptr Pcre2_match_data
_ = NonEmpty SliceRange -> IO (NonEmpty SliceRange)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty SliceRange -> IO (NonEmpty SliceRange))
-> NonEmpty SliceRange -> IO (NonEmpty SliceRange)
forall a b. (a -> b) -> a -> b
$ String -> NonEmpty SliceRange
forall a. HasCallStack => String -> a
error String
"BUG! Tried to use match results"

-- | Match a pattern to a subject once and return a list of captures, or @[]@ if
-- no match.
captures :: Text -> Text -> [Text]
captures :: Text -> Text -> [Text]
captures = Option -> Text -> Text -> [Text]
capturesOpt Option
forall a. Monoid a => a
mempty

-- | @capturesOpt mempty = captures@
capturesOpt :: Option -> Text -> Text -> [Text]
capturesOpt :: Option -> Text -> Text -> [Text]
capturesOpt Option
option Text
patt = [Text]
-> (NonEmpty Text -> [Text]) -> Maybe (NonEmpty Text) -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList (Maybe (NonEmpty Text) -> [Text])
-> (Text -> Maybe (NonEmpty Text)) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option -> Text -> Text -> Maybe (NonEmpty Text)
forall (f :: * -> *).
Alternative f =>
Option -> Text -> Text -> f (NonEmpty Text)
capturesAOpt Option
option Text
patt

-- | Match a pattern to a subject once and return a non-empty list of captures
-- in an `Alternative`, or `empty` if no match.  The non-empty list constructor
-- `:|` serves as a cue to differentiate the 0th capture from the others:
--
-- > let parseDate = capturesA "(\\d{4})-(\\d{2})-(\\d{2})"
-- > in case parseDate "submitted 2020-10-20" of
-- >     Just (date :| [y, m, d]) -> ...
-- >     Nothing                  -> putStrLn "didn't match"
capturesA :: (Alternative f) => Text -> Text -> f (NonEmpty Text)
capturesA :: Text -> Text -> f (NonEmpty Text)
capturesA = Option -> Text -> Text -> f (NonEmpty Text)
forall (f :: * -> *).
Alternative f =>
Option -> Text -> Text -> f (NonEmpty Text)
capturesAOpt Option
forall a. Monoid a => a
mempty

-- | @capturesAOpt mempty = capturesA@
--
-- @since 1.1.0
capturesAOpt :: (Alternative f) => Option -> Text -> Text -> f (NonEmpty Text)
capturesAOpt :: Option -> Text -> Text -> f (NonEmpty Text)
capturesAOpt Option
option Text
patt = Getting (Alt Maybe (NonEmpty Text)) Text (NonEmpty Text)
-> Text -> f (NonEmpty Text)
forall (f :: * -> *) a s.
Alternative f =>
Getting (Alt Maybe a) s a -> s -> f a
toAlternativeOf1 (Getting (Alt Maybe (NonEmpty Text)) Text (NonEmpty Text)
 -> Text -> f (NonEmpty Text))
-> Getting (Alt Maybe (NonEmpty Text)) Text (NonEmpty Text)
-> Text
-> f (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ Option -> Text -> Traversal' Text (NonEmpty Text)
_capturesOpt Option
option Text
patt

-- | Match a pattern to a subject and lazily produce a list of all
-- non-overlapping portions, with all capture groups, that matched.
--
-- @since 1.1.0
capturesAll :: Text -> Text -> [NonEmpty Text]
capturesAll :: Text -> Text -> [NonEmpty Text]
capturesAll = Option -> Text -> Text -> [NonEmpty Text]
capturesAllOpt Option
forall a. Monoid a => a
mempty

-- | @capturesAllOpt mempty = capturesAll@
--
-- @since 1.1.0
capturesAllOpt :: Option -> Text -> Text -> [NonEmpty Text]
capturesAllOpt :: Option -> Text -> Text -> [NonEmpty Text]
capturesAllOpt Option
option Text
patt = Getting (Endo [NonEmpty Text]) Text (NonEmpty Text)
-> Text -> [NonEmpty Text]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (Getting (Endo [NonEmpty Text]) Text (NonEmpty Text)
 -> Text -> [NonEmpty Text])
-> Getting (Endo [NonEmpty Text]) Text (NonEmpty Text)
-> Text
-> [NonEmpty Text]
forall a b. (a -> b) -> a -> b
$ Option -> Text -> Traversal' Text (NonEmpty Text)
_capturesOpt Option
option Text
patt

-- | Does the pattern match the subject at least once?
matches :: Text -> Text -> Bool
matches :: Text -> Text -> Bool
matches = Option -> Text -> Text -> Bool
matchesOpt Option
forall a. Monoid a => a
mempty

-- | @matchesOpt mempty = matches@
matchesOpt :: Option -> Text -> Text -> Bool
matchesOpt :: Option -> Text -> Text -> Bool
matchesOpt Option
option Text
patt = Getting Any Text (NonEmpty Text) -> Text -> Bool
forall s a. Getting Any s a -> s -> Bool
has (Getting Any Text (NonEmpty Text) -> Text -> Bool)
-> Getting Any Text (NonEmpty Text) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Matcher -> FromMatch -> Traversal' Text (NonEmpty Text)
_capturesInternal Matcher
matcher FromMatch
errorFromMatch where
    matcher :: Matcher
matcher = IO Matcher -> Matcher
forall a. IO a -> a
unsafePerformIO (IO Matcher -> Matcher) -> IO Matcher -> Matcher
forall a b. (a -> b) -> a -> b
$ Option -> Text -> IO Matcher
assembleMatcher Option
option Text
patt

-- | Match a pattern to a subject once and return the portion that matched in an
-- `Alternative`, or `empty` if no match.
match :: (Alternative f) => Text -> Text -> f Text
match :: Text -> Text -> f Text
match = Option -> Text -> Text -> f Text
forall (f :: * -> *).
Alternative f =>
Option -> Text -> Text -> f Text
matchOpt Option
forall a. Monoid a => a
mempty

-- | @matchOpt mempty = match@
matchOpt :: (Alternative f) => Option -> Text -> Text -> f Text
matchOpt :: Option -> Text -> Text -> f Text
matchOpt Option
option Text
patt = Getting (Alt Maybe Text) Text Text -> Text -> f Text
forall (f :: * -> *) a s.
Alternative f =>
Getting (Alt Maybe a) s a -> s -> f a
toAlternativeOf1 (Getting (Alt Maybe Text) Text Text -> Text -> f Text)
-> Getting (Alt Maybe Text) Text Text -> Text -> f Text
forall a b. (a -> b) -> a -> b
$ Option -> Text -> Traversal' Text Text
_matchOpt Option
option Text
patt

-- | Match a pattern to a subject and lazily return a list of all
-- non-overlapping portions that matched.
--
-- @since 1.1.0
matchAll :: Text -> Text -> [Text]
matchAll :: Text -> Text -> [Text]
matchAll = Option -> Text -> Text -> [Text]
matchAllOpt Option
forall a. Monoid a => a
mempty

-- | @matchAllOpt mempty = matchAll@
--
-- @since 1.1.0
matchAllOpt :: Option -> Text -> Text -> [Text]
matchAllOpt :: Option -> Text -> Text -> [Text]
matchAllOpt Option
option Text
patt = Getting (Endo [Text]) Text Text -> Text -> [Text]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (Getting (Endo [Text]) Text Text -> Text -> [Text])
-> Getting (Endo [Text]) Text Text -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Option -> Text -> Traversal' Text Text
_matchOpt Option
option Text
patt

-- | Perform at most one substitution.  See
-- [the docs](https://pcre.org/current/doc/html/pcre2api.html#SEC36) for the
-- special syntax of /replacement/.
--
-- >>> sub "(\\w+) calling the (\\w+)" "$2 calling the $1" "the pot calling the kettle black"
-- "the kettle calling the pot black"
sub
    :: Text -- ^ pattern
    -> Text -- ^ replacement
    -> Text -- ^ subject
    -> Text -- ^ result
sub :: Text -> Text -> Text -> Text
sub = Option -> Text -> Text -> Text -> Text
subOpt Option
forall a. Monoid a => a
mempty

-- | Perform substitutions globally.
--
-- >>> gsub "a" "o" "apples and bananas"
-- "opples ond bononos"
gsub :: Text -> Text -> Text -> Text
gsub :: Text -> Text -> Text -> Text
gsub = Option -> Text -> Text -> Text -> Text
subOpt Option
SubGlobal

-- | @
-- subOpt mempty = sub
-- subOpt SubGlobal = gsub
-- @
subOpt :: Option -> Text -> Text -> Text -> Text
subOpt :: Option -> Text -> Text -> Text -> Text
subOpt Option
option Text
patt Text
replacement = (CInt, Text) -> Text
forall a b. (a, b) -> b
snd ((CInt, Text) -> Text) -> (Text -> (CInt, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (CInt, Text) -> (CInt, Text)
forall a. IO a -> a
unsafePerformIO (IO (CInt, Text) -> (CInt, Text)) -> Subber -> Text -> (CInt, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subber
subber where
    subber :: Subber
subber = IO Subber -> Subber
forall a. IO a -> a
unsafePerformIO (IO Subber -> Subber) -> IO Subber -> Subber
forall a b. (a -> b) -> a -> b
$ Text -> Option -> Text -> IO Subber
assembleSubber Text
replacement Option
option Text
patt

-- | Given a pattern, produce a traversal (0 or more targets) that focuses from
-- a subject to each non-empty list of captures that pattern matches globally.
--
-- Substitution works in the following way:  If a capture is set such that the
-- new `Text` is not equal to the old one, a substitution occurs, otherwise it
-- doesn\'t.  This matters in cases where a capture encloses another
-- capture&#x2014;notably, /all/ parenthesized captures are enclosed by the 0th.
--
-- >>> threeAndMiddle = _captures ". (.) ."
-- >>> "A A A" & threeAndMiddle .~ "A A A" :| ["B"]
-- "A B A"
-- >>> "A A A" & threeAndMiddle .~ "A B A" :| ["A"]
-- "A B A"
--
-- Changing multiple overlapping captures won\'t do what you want and is
-- unsupported.
--
-- Changing an unset capture is unsupported because the PCRE2 match API does not
-- give location info about it.  Currently we ignore all such attempts.  (Native
-- substitution functions like `sub` do not have this limitation.  See also
-- `SubUnknownUnset` and `SubUnsetEmpty`.)
--
-- If the list becomes longer for some reason, the extra elements are ignored.
-- If it\'s shortened, the absent elements are considered to be unchanged.
--
-- It's recommended that the list be modified capture-wise,
-- using [@ix@](https://hackage.haskell.org/package/microlens/docs/Lens-Micro.html#v:ix).
--
-- > let madlibs = _captures "(\\w+) my (\\w+)"
-- >
-- > print $ "Well bust my buttons!" &~ do
-- >     zoom madlibs $ do
-- >         ix 1 . _head .= 'd'
-- >         ix 2 %= Text.reverse
-- >     _last .= '?'
-- >
-- > -- "Well dust my snottub?"
_captures :: Text -> Traversal' Text (NonEmpty Text)
_captures :: Text -> Traversal' Text (NonEmpty Text)
_captures = Option -> Text -> Traversal' Text (NonEmpty Text)
_capturesOpt Option
forall a. Monoid a => a
mempty

-- | @_capturesOpt mempty = _captures@
_capturesOpt :: Option -> Text -> Traversal' Text (NonEmpty Text)
_capturesOpt :: Option -> Text -> Traversal' Text (NonEmpty Text)
_capturesOpt Option
option Text
patt = Matcher -> FromMatch -> Traversal' Text (NonEmpty Text)
_capturesInternal Matcher
matcher FromMatch
getAllSliceRanges where
    matcher :: Matcher
matcher = IO Matcher -> Matcher
forall a. IO a -> a
unsafePerformIO (IO Matcher -> Matcher) -> IO Matcher -> Matcher
forall a b. (a -> b) -> a -> b
$ Option -> Text -> IO Matcher
assembleMatcher Option
option Text
patt

-- | Given a pattern, produce a traversal (0 or more targets) that focuses from
-- a subject to the portions of it that match.
--
-- @_match = `_captures` patt . ix 0@
_match :: Text -> Traversal' Text Text
_match :: Text -> Traversal' Text Text
_match = Option -> Text -> Traversal' Text Text
_matchOpt Option
forall a. Monoid a => a
mempty

-- | @_matchOpt mempty = _match@
_matchOpt :: Option -> Text -> Traversal' Text Text
_matchOpt :: Option -> Text -> Traversal' Text Text
_matchOpt Option
option Text
patt = (NonEmpty Text -> f (NonEmpty Text)) -> Text -> f Text
_cs ((NonEmpty Text -> f (NonEmpty Text)) -> Text -> f Text)
-> ((Text -> f Text) -> NonEmpty Text -> f (NonEmpty Text))
-> (Text -> f Text)
-> Text
-> f Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> f Text) -> NonEmpty Text -> f (NonEmpty Text)
forall a. Lens' (NonEmpty a) a
_headNE where
    _cs :: (NonEmpty Text -> f (NonEmpty Text)) -> Text -> f Text
_cs = Matcher -> FromMatch -> Traversal' Text (NonEmpty Text)
_capturesInternal Matcher
matcher FromMatch
get0thSliceRanges
    matcher :: Matcher
matcher = IO Matcher -> Matcher
forall a. IO a -> a
unsafePerformIO (IO Matcher -> Matcher) -> IO Matcher -> Matcher
forall a b. (a -> b) -> a -> b
$ Option -> Text -> IO Matcher
assembleMatcher Option
option Text
patt

-- * Support for Template Haskell compile-time regex analysis

-- | From options and pattern, determine parenthesized captures\' names in
-- order.
predictCaptureNames :: Option -> Text -> IO [Maybe Text]
predictCaptureNames :: Option -> Text -> IO [Maybe Text]
predictCaptureNames Option
option Text
patt = do
    Code
code <- ExtractOpts Code -> [AppliedOption] -> IO Code
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT
        (ExtractOpts CompileEnv
extractCompileEnv ExtractOpts CompileEnv
-> (CompileEnv -> ExtractOpts Code) -> ExtractOpts Code
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> CompileEnv -> ExtractOpts Code
extractCode Text
patt)
        (Option -> [AppliedOption]
applyOption Option
option)

    Code -> (Ptr Pcre2_code -> IO [Maybe Text]) -> IO [Maybe Text]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Code
code Ptr Pcre2_code -> IO [Maybe Text]
getCaptureNames

-- | Get parenthesized captures\' names in order.
getCaptureNames :: Ptr Pcre2_code -> IO [Maybe Text]
getCaptureNames :: Ptr Pcre2_code -> IO [Maybe Text]
getCaptureNames Ptr Pcre2_code
codePtr = do
    CUInt
nameCount <- Ptr Pcre2_code -> CUInt -> IO CUInt
forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @CUInt Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_NAMECOUNT
    CUInt
nameEntrySize <- Ptr Pcre2_code -> CUInt -> IO CUInt
forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @CUInt Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_NAMEENTRYSIZE
    Ptr CUShort
nameTable <- Ptr Pcre2_code -> CUInt -> IO (Ptr CUShort)
forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @PCRE2_SPTR Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_NAMETABLE

    -- Can't do [0 .. nameCount - 1] because it underflows when nameCount == 0
    let indexes :: [CUInt]
indexes = (CUInt -> Bool) -> [CUInt] -> [CUInt]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (CUInt -> CUInt -> Bool
forall a. Ord a => a -> a -> Bool
< CUInt
nameCount) [CUInt
0 ..]
    IntMap Text
names <- ([(Int, Text)] -> IntMap Text)
-> IO [(Int, Text)] -> IO (IntMap Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Int, Text)] -> IntMap Text
forall a. [(Int, a)] -> IntMap a
IM.fromList (IO [(Int, Text)] -> IO (IntMap Text))
-> IO [(Int, Text)] -> IO (IntMap Text)
forall a b. (a -> b) -> a -> b
$ [CUInt] -> (CUInt -> IO (Int, Text)) -> IO [(Int, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CUInt]
indexes ((CUInt -> IO (Int, Text)) -> IO [(Int, Text)])
-> (CUInt -> IO (Int, Text)) -> IO [(Int, Text)]
forall a b. (a -> b) -> a -> b
$ \CUInt
i -> do
        let entryPtr :: Ptr CUShort
entryPtr = Ptr CUShort
nameTable Ptr CUShort -> Int -> Ptr CUShort
forall a. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt
i CUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
* CUInt
nameEntrySize)
            groupNamePtr :: Ptr CUShort
groupNamePtr = Ptr CUShort
entryPtr Ptr CUShort -> Int -> Ptr CUShort
forall a. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` Int
1
        CUShort
groupNumber <- Ptr CUShort -> IO CUShort
forall a. Storable a => Ptr a -> IO a
peek Ptr CUShort
entryPtr
        Int
groupNameLen <- CUShort -> Ptr CUShort -> IO Int
forall a. (Storable a, Eq a) => a -> Ptr a -> IO Int
lengthArray0 CUShort
0 Ptr CUShort
groupNamePtr
        Text
groupName <- Ptr Word16 -> I16 -> IO Text
Text.fromPtr
            (Ptr CUShort -> Ptr Word16
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs Ptr CUShort
groupNamePtr)
            (Int -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
groupNameLen)
        (Int, Text) -> IO (Int, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (CUShort -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUShort
groupNumber, Text
groupName)

    CUInt
hiCaptNum <- Ptr Pcre2_code -> CUInt -> IO CUInt
forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @CUInt Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_CAPTURECOUNT

    [Maybe Text] -> IO [Maybe Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe Text] -> IO [Maybe Text])
-> [Maybe Text] -> IO [Maybe Text]
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe Text) -> [Int] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (IntMap Text
names IntMap Text -> Int -> Maybe Text
forall a. IntMap a -> Int -> Maybe a
IM.!?) [Int
1 .. CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
hiCaptNum]

-- | Low-level access to compiled pattern info, per the docs.
getCodeInfo :: (Storable a) => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo :: Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo Ptr Pcre2_code
codePtr CUInt
what = (Ptr a -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr a
wherePtr -> do
    Ptr Pcre2_code -> CUInt -> Ptr a -> IO CInt
forall a. Ptr Pcre2_code -> CUInt -> Ptr a -> IO CInt
pcre2_pattern_info Ptr Pcre2_code
codePtr CUInt
what Ptr a
wherePtr IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
check (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0)
    Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
wherePtr

-- | A wrapper around a list of captures that carries additional type-level
-- information about the number and names of those captures.
--
-- This type is only intended to be created by
-- `Text.Regex.Pcre2.regex`\/`Text.Regex.Pcre2._regex` and consumed by
-- `Text.Regex.Pcre2.capture`\/`Text.Regex.Pcre2._capture`, relying on type
-- inference.  Specifying the @info@ explicitly in a type signature is not
-- supported&#x2014;the definition of `CapturesInfo` is not part of the public
-- API and may change without warning.
--
-- After obtaining `Captures` it\'s recommended to immediately consume them and
-- transform them into application-level data, to avoid leaking the types to top
-- level and having to write signatures.  In times of need, \"@Captures _@\" may
-- be written with the help of @{-\# LANGUAGE PartialTypeSignatures \#-}@.
newtype Captures (info :: CapturesInfo) = Captures (NonEmpty Text)

-- | The kind of `Captures`\'s @info@.
type CapturesInfo = (Nat, [(Symbol, Nat)])

-- | Look up the number of a capture at compile time, either by number or by
-- name.  Throw a helpful 'TypeError' if the index doesn\'t exist.
type family CaptNum (i :: k) (info :: CapturesInfo) :: Nat where
    CaptNum (num :: Nat) '(hi, _) =
        If (CmpNat num 0 == 'LT || CmpNat num hi == 'GT)
            -- then
            (TypeError (TypeLits.Text "No capture numbered " :<>: ShowType num))
            -- else
            num

    CaptNum (name :: Symbol) '(_, '(name, num) ': _) = num
    CaptNum (name :: Symbol) '(hi, _ ': kvs) = CaptNum name '(hi, kvs)
    CaptNum (name :: Symbol) _ = TypeError
        (TypeLits.Text "No capture named " :<>: ShowType name)

    CaptNum _ _ = TypeError
        (TypeLits.Text "Capture index must be a number (Nat) or name (Symbol)")

-- | Safely lookup a capture in a `Captures` result obtained from a Template
-- Haskell-generated matching function.
--
-- The ugly type signature may be interpreted like this:  /Given some capture/
-- /group index @i@ and some @info@ about a regex, ensure that index exists and/
-- /is resolved to the number @num@ at compile time.  Then, at runtime, get a/
-- /capture group from a list of captures./
--
-- In practice the variable @i@ is specified by type application and the other
-- variables are inferred.
--
-- > capture @3
-- > capture @"bar"
--
-- Specifying a nonexistant number or name will result in a type error.
capture :: forall i info num. (CaptNum i info ~ num, KnownNat num) =>
    Captures info -> Text
capture :: Captures info -> Text
capture = Getting Text (Captures info) Text -> Captures info -> Text
forall a s. Getting a s a -> s -> a
view (Getting Text (Captures info) Text -> Captures info -> Text)
-> Getting Text (Captures info) Text -> Captures info -> Text
forall a b. (a -> b) -> a -> b
$ forall k (i :: k) (info :: CapturesInfo) (num :: Nat).
(CaptNum i info ~ num, KnownNat num) =>
Lens' (Captures info) Text
forall (info :: CapturesInfo) (num :: Nat).
(CaptNum i info ~ num, KnownNat num) =>
Lens' (Captures info) Text
_capture @i

-- | Like `capture` but focus from a `Captures` to a capture.
_capture :: forall i info num. (CaptNum i info ~ num, KnownNat num) =>
    Lens' (Captures info) Text
_capture :: Lens' (Captures info) Text
_capture Text -> f Text
f (Captures NonEmpty Text
cs) =
    let ([Text]
ls, Text
c : [Text]
rs) = Int -> NonEmpty Text -> ([Text], [Text])
forall a. Int -> NonEmpty a -> ([a], [a])
NE.splitAt (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy num -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal @num Proxy num
forall k (t :: k). Proxy t
Proxy) NonEmpty Text
cs
    in Text -> f Text
f Text
c f Text -> (Text -> Captures info) -> f (Captures info)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
c' -> NonEmpty Text -> Captures info
forall (info :: CapturesInfo). NonEmpty Text -> Captures info
Captures (NonEmpty Text -> Captures info) -> NonEmpty Text -> Captures info
forall a b. (a -> b) -> a -> b
$ [Text] -> NonEmpty Text
forall a. [a] -> NonEmpty a
NE.fromList ([Text] -> NonEmpty Text) -> [Text] -> NonEmpty Text
forall a b. (a -> b) -> a -> b
$ [Text]
ls [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text
c' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rs

-- * Exceptions

-- | The root of the PCRE2 exception hierarchy.
data SomePcre2Exception = forall e. (Exception e) => SomePcre2Exception e
instance Show SomePcre2Exception where
    show :: SomePcre2Exception -> String
show (SomePcre2Exception e
e) = e -> String
forall a. Show a => a -> String
show e
e
instance Exception SomePcre2Exception

-- | Vanilla PCRE2 exceptions with messages generated by the underlying C
-- library.
newtype Pcre2Exception = Pcre2Exception CInt
instance Show Pcre2Exception where
    show :: Pcre2Exception -> String
show (Pcre2Exception CInt
x) = String
"pcre2: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack (CInt -> Text
getErrorMessage CInt
x)
instance Exception Pcre2Exception where
    toException :: Pcre2Exception -> SomeException
toException = SomePcre2Exception -> SomeException
forall e. Exception e => e -> SomeException
toException (SomePcre2Exception -> SomeException)
-> (Pcre2Exception -> SomePcre2Exception)
-> Pcre2Exception
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pcre2Exception -> SomePcre2Exception
forall e. Exception e => e -> SomePcre2Exception
SomePcre2Exception
    fromException :: SomeException -> Maybe Pcre2Exception
fromException = SomeException -> Maybe SomePcre2Exception
forall e. Exception e => SomeException -> Maybe e
fromException (SomeException -> Maybe SomePcre2Exception)
-> (SomePcre2Exception -> Maybe Pcre2Exception)
-> SomeException
-> Maybe Pcre2Exception
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \(SomePcre2Exception e
e) -> e -> Maybe Pcre2Exception
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e

-- | PCRE2 compile exceptions.  Along with a message stating the cause, we show
-- the pattern with a cursor pointing at where the error is (if not after the
-- last character).
data Pcre2CompileException = Pcre2CompileException !CInt !Text !PCRE2_SIZE
instance Show Pcre2CompileException where
    show :: Pcre2CompileException -> String
show (Pcre2CompileException CInt
x Text
patt PCRE2_SIZE
offset) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
        String
"pcre2_compile: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack (CInt -> Text
getErrorMessage CInt
x),
        Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
tab Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
patt] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
        [Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
tab Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset') Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"^" | Int
offset' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Text -> Int
Text.length Text
patt]
        where
        tab :: Int
tab = Int
20
        offset' :: Int
offset' = PCRE2_SIZE -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_SIZE
offset
instance Exception Pcre2CompileException where
    toException :: Pcre2CompileException -> SomeException
toException = SomePcre2Exception -> SomeException
forall e. Exception e => e -> SomeException
toException (SomePcre2Exception -> SomeException)
-> (Pcre2CompileException -> SomePcre2Exception)
-> Pcre2CompileException
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pcre2CompileException -> SomePcre2Exception
forall e. Exception e => e -> SomePcre2Exception
SomePcre2Exception
    fromException :: SomeException -> Maybe Pcre2CompileException
fromException = SomeException -> Maybe SomePcre2Exception
forall e. Exception e => SomeException -> Maybe e
fromException (SomeException -> Maybe SomePcre2Exception)
-> (SomePcre2Exception -> Maybe Pcre2CompileException)
-> SomeException
-> Maybe Pcre2CompileException
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \(SomePcre2Exception e
e) -> e -> Maybe Pcre2CompileException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e

-- | Built-in message corresponding to the integer error code.
getErrorMessage :: CInt -> Text
getErrorMessage :: CInt -> Text
getErrorMessage CInt
errorCode = IO Text -> Text
forall a. IO a -> a
unsafePerformIO (IO Text -> Text) -> IO Text -> Text
forall a b. (a -> b) -> a -> b
$ do
    let bufCUs :: Int
bufCUs = Int
120
    Int -> (Ptr CUShort -> IO Text) -> IO Text
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (Int
bufCUs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) ((Ptr CUShort -> IO Text) -> IO Text)
-> (Ptr CUShort -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ \Ptr CUShort
bufPtr -> do
        CInt
cus <- CInt -> Ptr CUShort -> PCRE2_SIZE -> IO CInt
pcre2_get_error_message CInt
errorCode Ptr CUShort
bufPtr (Int -> PCRE2_SIZE
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bufCUs)
        Ptr Word16 -> I16 -> IO Text
Text.fromPtr (Ptr CUShort -> Ptr Word16
forall a b. CastCUs a b => Ptr a -> Ptr b
castCUs Ptr CUShort
bufPtr) (CInt -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
cus)

-- | Most PCRE2 C functions return an @int@ indicating a possible error.  Test
-- it against a predicate, and throw an exception upon failure.
check :: (CInt -> Bool) -> CInt -> IO ()
check :: (CInt -> Bool) -> CInt -> IO ()
check CInt -> Bool
p CInt
x = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt -> Bool
p CInt
x) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Pcre2Exception -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Pcre2Exception -> IO ()) -> Pcre2Exception -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Pcre2Exception
Pcre2Exception CInt
x

-- * PCRE2 compile-time config

-- | Helper for getting PCRE2 compile-time config integers.
getConfigNumeric :: CUInt -> CUInt
getConfigNumeric :: CUInt -> CUInt
getConfigNumeric CUInt
what = IO CUInt -> CUInt
forall a. IO a -> a
unsafePerformIO (IO CUInt -> CUInt) -> IO CUInt -> CUInt
forall a b. (a -> b) -> a -> b
$ (Ptr CUInt -> IO CUInt) -> IO CUInt
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CUInt -> IO CUInt) -> IO CUInt)
-> (Ptr CUInt -> IO CUInt) -> IO CUInt
forall a b. (a -> b) -> a -> b
$ \Ptr CUInt
ptr -> do
    CUInt -> Ptr CUInt -> IO CInt
forall a. CUInt -> Ptr a -> IO CInt
pcre2_config CUInt
what Ptr CUInt
ptr
    Ptr CUInt -> IO CUInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CUInt
ptr

-- | Helper for getting PCRE2 compile-time config strings.
getConfigString :: CUInt -> Maybe Text
getConfigString :: CUInt -> Maybe Text
getConfigString CUInt
what = IO (Maybe Text) -> Maybe Text
forall a. IO a -> a
unsafePerformIO (IO (Maybe Text) -> Maybe Text) -> IO (Maybe Text) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ do
    CInt
len <- CUInt -> Ptr Any -> IO CInt
forall a. CUInt -> Ptr a -> IO CInt
pcre2_config CUInt
what Ptr Any
forall a. Ptr a
nullPtr
    if CInt
len CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
pcre2_ERROR_BADOPTION
        then Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
        -- FIXME Do we really need "+ 1" here?
        else Int -> (Ptr Word16 -> IO (Maybe Text)) -> IO (Maybe Text)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt
len CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ CInt
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) ((Ptr Word16 -> IO (Maybe Text)) -> IO (Maybe Text))
-> (Ptr Word16 -> IO (Maybe Text)) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ \Ptr Word16
ptr -> do
            CUInt -> Ptr Word16 -> IO CInt
forall a. CUInt -> Ptr a -> IO CInt
pcre2_config CUInt
what Ptr Word16
ptr
            Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word16 -> I16 -> IO Text
Text.fromPtr Ptr Word16
ptr (CInt -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
len I16 -> I16 -> I16
forall a. Num a => a -> a -> a
- I16
1)

-- | See `Bsr`.
defaultBsr :: Bsr
defaultBsr :: Bsr
defaultBsr = CUInt -> Bsr
bsrFromC (CUInt -> Bsr) -> CUInt -> Bsr
forall a b. (a -> b) -> a -> b
$ CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_BSR

-- | Which code widths PCRE2 is compiled to operate on.  Can be any combination
-- of 8, 16, and 32.  Should be @[16]@ but provided here for completeness.
compiledWidths :: [Int]
compiledWidths :: [Int]
compiledWidths =
    let bitmap :: CUInt
bitmap = CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_COMPILED_WIDTHS
    in [Int
w | (CUInt
b, Int
w) <- [(CUInt
1, Int
8), (CUInt
2, Int
16), (CUInt
4, Int
32)], CUInt
b CUInt -> CUInt -> CUInt
forall a. Bits a => a -> a -> a
.&. CUInt
bitmap CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CUInt
0]

-- | See `DepthLimit`.
defaultDepthLimit :: Int
defaultDepthLimit :: Int
defaultDepthLimit = CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> CUInt -> Int
forall a b. (a -> b) -> a -> b
$ CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_DEPTHLIMIT

-- | See `HeapLimit`.
defaultHeapLimit :: Int
defaultHeapLimit :: Int
defaultHeapLimit = CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> CUInt -> Int
forall a b. (a -> b) -> a -> b
$ CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_HEAPLIMIT

-- | Was PCRE2 built with JIT support?
supportsJit :: Bool
supportsJit :: Bool
supportsJit = CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_JIT CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
1

-- | A nice description of the CPU architecture JIT support is compiled for, if
-- any.
jitTarget :: Maybe Text
jitTarget :: Maybe Text
jitTarget = CUInt -> Maybe Text
getConfigString CUInt
pcre2_CONFIG_JITTARGET

-- | Number of bytes used for internal linkage in compiled regexes.
linkSize :: Int
linkSize :: Int
linkSize = CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> CUInt -> Int
forall a b. (a -> b) -> a -> b
$ CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_LINKSIZE

-- | See `MatchLimit`.
defaultMatchLimit :: Int
defaultMatchLimit :: Int
defaultMatchLimit = CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> CUInt -> Int
forall a b. (a -> b) -> a -> b
$ CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_MATCHLIMIT

-- | See `Newline`.
defaultNewline :: Newline
defaultNewline :: Newline
defaultNewline = CUInt -> Newline
newlineFromC (CUInt -> Newline) -> CUInt -> Newline
forall a b. (a -> b) -> a -> b
$ CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_NEWLINE

-- | See `NeverBackslashC`.
defaultIsNeverBackslashC :: Bool
defaultIsNeverBackslashC :: Bool
defaultIsNeverBackslashC = CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_NEVER_BACKSLASH_C CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
1

-- | See `ParensLimit`.
defaultParensLimit :: Int
defaultParensLimit :: Int
defaultParensLimit = CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> CUInt -> Int
forall a b. (a -> b) -> a -> b
$ CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_PARENSLIMIT

-- | Size in bytes of PCRE2\'s built-in character processing tables.
defaultTablesLength :: Int
defaultTablesLength :: Int
defaultTablesLength = CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> CUInt -> Int
forall a b. (a -> b) -> a -> b
$ CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_TABLES_LENGTH

-- | Unicode version string such as @8.0.0@, if Unicode is supported at all.
unicodeVersion :: Maybe Text
unicodeVersion :: Maybe Text
unicodeVersion = case CUInt -> Maybe Text
getConfigString CUInt
pcre2_CONFIG_UNICODE_VERSION of
    Just Text
v | Text -> String
Text.unpack Text
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Unicode not supported" -> Maybe Text
forall a. Maybe a
Nothing
    Maybe Text
maybeV                                            -> Maybe Text
maybeV

-- | Was PCRE2 built with Unicode support?
supportsUnicode :: Bool
supportsUnicode :: Bool
supportsUnicode = CUInt -> CUInt
getConfigNumeric CUInt
pcre2_CONFIG_UNICODE CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
1

-- | Version of the built-in C library.  The versioning scheme is that PCRE
-- legacy is 8.x and PCRE2 is 10.x, so this should be @10.@/something/.
pcreVersion :: Text
pcreVersion :: Text
pcreVersion = case CUInt -> Maybe Text
getConfigString CUInt
pcre2_CONFIG_VERSION of
    Just Text
v  -> Text
v
    Maybe Text
Nothing -> String -> Text
forall a. HasCallStack => String -> a
error String
"pcreVersion: unable to get string"