pcre2 2.0.0 → 2.0.1
raw patch · 6 files changed
+249/−280 lines, 6 filesdep +microlensPVP ok
version bump matches the API change (PVP)
Dependencies added: microlens
API changes (from Hackage documentation)
Files
- ChangeLog.md +5/−0
- bench/Bench.hs +5/−8
- pcre2.cabal +4/−1
- src/hs/Text/Regex/Pcre2.hs +2/−2
- src/hs/Text/Regex/Pcre2/Internal.hs +125/−241
- src/hs/Text/Regex/Pcre2/TH.hs +108/−28
ChangeLog.md view
@@ -1,5 +1,10 @@ # Changelog and Acknowledgements +## 2.0.1+* Added `microlens` as a dependency to improve Haddock docs (`Traversal'` _et+ al_ are clickable) and relieve maintenance burden somewhat.+* Moderate refactoring of internals.+ ## 2.0.0 This release introduces significant breaking changes in order to make the API smaller, more consistent, and safer.
bench/Bench.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} @@ -67,12 +67,11 @@ in capture @"bar" cs], bgroup "substitutions" [- bgroup "single" [+ bgroup "single" $ let quux = Text.pack "quux" in [ bench "PCRE2-native" $ flip nf textSubject $- sub (Text.pack "(?<=foo )bar(?= baz)") (Text.pack "quux"),+ sub (Text.pack "(?<=foo )bar(?= baz)") quux, - let quux = Text.pack "quux"- in bench "lens-powered" $ flip nf textSubject $+ bench "lens-powered" $ flip nf textSubject $ set ([_regex|foo (bar) baz|] . _capture @1) quux], let fruit = Text.pack "apples and bananas"@@ -103,9 +102,7 @@ bench "regex-pcre-builtin" $ nfIO $ do Text.Regex.PCRE.Text.regexec regexBaseR textSubject >>= \case Right (Just (_, _, _, [bar])) -> return bar- x -> do- print x- error "BUG!",+ x -> print x >> error "BUG!", bench "pcre-light" $ flip nf textSubject $ \subj -> let Just [_, bar] = Text.Regex.PCRE.Light.Char8.match
pcre2.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: pcre2-version: 2.0.0+version: 2.0.1 synopsis: Regular expressions via the PCRE2 C library (included) description: Please see the README on GitHub at <https://github.com/sjshuck/hs-pcre2> category: Text@@ -144,6 +144,7 @@ build-depends: base >=4.9 && <5 , containers+ , microlens , mtl , template-haskell , text@@ -161,6 +162,7 @@ base >=4.9 && <5 , containers , hspec+ , microlens , microlens-platform , mtl , pcre2@@ -180,6 +182,7 @@ base >=4.9 && <5 , containers , criterion+ , microlens , microlens-platform , mtl , pcre-light
src/hs/Text/Regex/Pcre2.hs view
@@ -111,8 +111,8 @@ === __Handling results and errors__ In contrast to [other](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/match)- [APIs](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/matchAll)—including- previous versions of [this library](https://github.com/sjshuck/hs-pcre2/issues/17)—where+ [APIs](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/matchAll)—including+ previous versions of [this library](https://github.com/sjshuck/hs-pcre2/issues/17)—where there are separate functions to request single versus global matching, we accomplish this /(since 2.0.0)/ in a unified fashion using the `Alternative` typeclass. Typically the user will choose from two instances, `Maybe` and
src/hs/Text/Regex/Pcre2/Internal.hs view
@@ -1,49 +1,37 @@-{-# 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.Exception import Control.Monad.State.Strict import Data.Either (partitionEithers) import Data.Foldable (toList)-import Data.Function ((&))-import Data.Functor ((<&>))-import Data.Functor.Const (Const(..)) import Data.Functor.Identity (Identity(..)) import Data.IORef-import Data.IntMap.Strict (IntMap)+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.Monoid (Alt(..), First) 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 Lens.Micro+import Lens.Micro.Extras (preview, view) import System.IO.Unsafe (unsafePerformIO) import Text.Regex.Pcre2.Foreign @@ -63,13 +51,9 @@ -- | Helper so we never leak untracked 'FunPtr's. mkFunPtr :: ForeignPtr b -> IO (FunPtr a) -> IO (FunPtr a) mkFunPtr anchor create = do- fPtr <- create- Conc.addForeignPtrFinalizer anchor $ freeHaskellFunPtr fPtr- return fPtr--safeLast :: [a] -> Maybe a-safeLast [] = Nothing-safeLast xs = Just $ last xs+ funPtr <- create+ Conc.addForeignPtrFinalizer anchor $ freeHaskellFunPtr funPtr+ return funPtr bitOr :: (Foldable t, Bits a) => t a -> a bitOr = foldl' (.|.) zeroBits@@ -126,28 +110,9 @@ 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 = toAlternativeOf--view :: Getting a s a -> s -> a-view l = getConst . l Const--to :: (s -> a) -> forall r. Getting r s a-to k f = Const . getConst . f . k--has :: Getting Any s a -> s -> Bool-has l = getAny . getConst . l (\_ -> Const $ Any True)--toListOf :: Getting (Endo [a]) s a -> s -> [a]-toListOf l x = let build = Endo . (:) in view (l . to build) x `appEndo` []+-- ** Lens utilities +-- | A more general `toListOf` that collects targets into any `Alternative`. toAlternativeOf :: (Alternative f) => Getting (Alt f a) s a -> s -> f a toAlternativeOf l = let alt = Alt . pure in getAlt . view (l . to alt) @@ -348,9 +313,9 @@ -- /triggered at the beginning of the pattern, passing 0. None of this is/ -- /documented; expect the unexpected in the presence of side effects!/ | 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.+ -- 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. | AutoCallout -- ^ Run callout for every pattern item. Only relevant if a -- callout is set. | UnsafeSubCallout (SubCalloutInfo -> IO SubCalloutResult) -- ^ Run the@@ -414,7 +379,7 @@ -- | Input for user-defined callouts. data CalloutInfo- = CalloutInfo {+ = CalloutInfo{ -- | The index of which callout point we\'re on. calloutIndex :: CalloutIndex, -- | The captures that have been set so far.@@ -450,7 +415,7 @@ -- | Input for user-defined substitution callouts. data SubCalloutInfo- = SubCalloutInfo {+ = SubCalloutInfo{ -- | The 1-based index of which substitution we\'re on. Only goes past -- 1 during global substitutions. subCalloutSubsCount :: Int,@@ -510,7 +475,7 @@ Ucp -> [CompileOption pcre2_UCP] Ungreedy -> [CompileOption pcre2_UNGREEDY] - -- ExtraCompileOption+ -- CompileExtraOption AltBsux -> [CompileExtraOption pcre2_EXTRA_ALT_BSUX] BadEscapeIsLiteral -> [CompileExtraOption pcre2_EXTRA_BAD_ESCAPE_IS_LITERAL] EscapedCrIsLf -> [CompileExtraOption pcre2_EXTRA_ESCAPED_CR_IS_LF]@@ -566,14 +531,14 @@ -- | 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+ | CompileExtraOption !CUInt+ | CompileContextOption !(CompileContext -> IO ())+ | CompileRecGuardOption !(Int -> IO Bool)+ | MatchOption !CUInt+ | CalloutOption !(CalloutInfo -> IO CalloutResult)+ | SubCalloutOption !(SubCalloutInfo -> IO SubCalloutResult)+ | MatchContextOption !(MatchContext -> IO ()) _CompileOption f = \case CompileOption x -> CompileOption <$> f x; o -> pure o@@ -602,16 +567,16 @@ 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 (First a) AppliedOption a -> ExtractOpts [a] extractOptsOf prism = state $ partitionEithers . map discrim where- discrim opt = maybe (Right opt) Left $ preview prism opt+ discrim opt = maybe (Right opt) Left $ opt ^? prism -- | Prepare to compile a `Code`. extractCompileEnv :: ExtractOpts CompileEnv extractCompileEnv = do ctxUpds <- extractOptsOf _CompileContextOption xtraOpts <- bitOr <$> extractOptsOf _CompileExtraOption- recGuard <- safeLast <$> extractOptsOf _CompileRecGuardOption+ recGuard <- preview _last <$> extractOptsOf _CompileRecGuardOption compileEnvCtx <- sequence $ do guard $ not $ null ctxUpds && xtraOpts == 0 && null recGuard@@ -630,33 +595,30 @@ f <- recGuard Just $ liftIO $ do eRef <- newIORef Nothing- fPtr <- mkFunPtr ctx $ mkRecursionGuard $ \depth _ -> do- resultOrE <- try $ do- f <- evaluate f- result <- f $ fromIntegral depth- evaluate result+ funPtr <- mkFunPtr ctx $ mkRecursionGuard $ \depth _ -> do+ resultOrE <- try $ f (fromIntegral depth) >>= evaluate case resultOrE of Right success -> return $ if success then 0 else 1 Left e -> writeIORef eRef (Just e) >> return 1 - withForeignPtr ctx $ \ctxPtr -> do- result <- pcre2_set_compile_recursion_guard ctxPtr fPtr nullPtr- check (== 0) result+ withForeignPtr ctx $ \ctxPtr ->+ pcre2_set_compile_recursion_guard ctxPtr funPtr nullPtr >>=+ check (== 0) return eRef - return $ CompileEnv {..}+ return CompileEnv{..} -- | Inputs to `Code` compilation besides the pattern.-data CompileEnv = CompileEnv {- compileEnvCtx :: Maybe CompileContext,+data CompileEnv = CompileEnv{+ compileEnvCtx :: !(Maybe CompileContext), -- | A register for catching exceptions thrown in recursion guards, if -- needed.- compileEnvERef :: Maybe (IORef (Maybe SomeException))}+ compileEnvERef :: !(Maybe (IORef (Maybe SomeException)))} -- | Compile a `Code`. extractCode :: Text -> CompileEnv -> ExtractOpts Code-extractCode patt (CompileEnv {..}) = do+extractCode patt CompileEnv{..} = do opts <- bitOr <$> extractOptsOf _CompileOption liftIO $ mkForeignPtr pcre2_code_free $@@ -673,7 +635,7 @@ ctxPtr when (codePtr == nullPtr) $ do -- Re-throw exception (if any) from recursion guard (if any)- forM_ compileEnvERef $ readIORef >=> mapM_ throwIO+ forOf_ _Just compileEnvERef $ readIORef >=> mapM_ throwIO -- Otherwise throw PCRE2 error errorCode <- peek errorCodePtr offCUs <- peek errorOffPtr@@ -684,14 +646,14 @@ -- | `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 {+data MatchEnv = MatchEnv{ matchEnvCode :: Code, matchEnvOpts :: CUInt, matchEnvCtx :: Maybe MatchContext, matchEnvCallout :: Maybe (CalloutInfo -> IO CalloutResult), matchEnvSubCallout :: Maybe (SubCalloutInfo -> IO SubCalloutResult)} --- | Prepare a matching function.+-- | Prepare a matching function after compiling the underlying @pcre2_code@. extractMatchEnv :: Code -> ExtractOpts MatchEnv extractMatchEnv matchEnvCode = do matchEnvOpts <- bitOr <$> extractOptsOf _MatchOption@@ -706,35 +668,27 @@ return ctx - matchEnvCallout <- safeLast <$> extractOptsOf _CalloutOption- matchEnvSubCallout <- safeLast <$> extractOptsOf _SubCalloutOption-- return $ MatchEnv {..}+ matchEnvCallout <- preview _last <$> extractOptsOf _CalloutOption+ matchEnvSubCallout <- preview _last <$> extractOptsOf _SubCalloutOption --- | 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 mkSubjFun option patt =- runStateT extractAll (applyOption option) <&> \case- (subjFun, []) -> subjFun- _ -> error "BUG! Options not fully extracted"+ return MatchEnv{..} +-- | Generate, from user-supplied `Option`s and pattern, a `MatchEnv` that can+-- be reused for matching or substituting.+userMatchEnv :: Option -> Text -> IO MatchEnv+userMatchEnv option patt = runStateT extractAll (applyOption option) <&> \case+ (matchEnv, []) -> matchEnv+ _ -> error "BUG! Options not fully extracted" where- extractAll = do- compileEnv <- extractCompileEnv- code <- extractCode patt compileEnv- matchEnv <- extractMatchEnv code-- return $ mkSubjFun matchEnv+ extractAll = extractCompileEnv >>= extractCode patt >>= extractMatchEnv --- | Produce a `Matcher` from user-supplied `Option` and pattern.-assembleMatcher :: Option -> Text -> IO Matcher-assembleMatcher = assembleSubjFun $ \matchEnv@(MatchEnv {..}) subject ->- StreamEffect $+-- | A `MatchEnv` is sufficient to fully implement a matching function.+matcherWithEnv :: MatchEnv -> Matcher+matcherWithEnv matchEnv@MatchEnv{..} subject = StreamEffect $ withForeignPtr matchEnvCode $ \codePtr -> withMatchDataFromCode codePtr $ \matchDataPtr -> Text.useAsPtr subject $ \subjPtr subjCUs -> do- MatchTempEnv {..} <- mkMatchTempEnv matchEnv subject+ MatchTempEnv{..} <- mkMatchTempEnv matchEnv subject -- Loop over the subject, emitting match data until stopping. return $ fix1 0 $ \continue curOff -> do@@ -774,6 +728,11 @@ pcre2_match_data_create_from_pattern codePtr nullPtr withForeignPtr matchData action +-- | Helper to generate public matching functions.+pureUserMatcher :: Option -> Text -> Matcher+pureUserMatcher option patt = matcherWithEnv matchEnv where+ matchEnv = unsafePerformIO $ userMatchEnv option patt+ -- | 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@@ -790,25 +749,14 @@ -- 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 replacement = assembleSubjFun $ \firstMatchEnv@(MatchEnv {..}) ->- -- Subber- \subject ->+subberWithEnv :: MatchEnv -> Text -> Subber+subberWithEnv firstMatchEnv@MatchEnv{..} replacement subject = withForeignPtr matchEnvCode $ \codePtr -> Text.useAsPtr subject $ \subjPtr subjCUs -> Text.useAsPtr replacement $ \replPtr replCUs -> alloca $ \outLenPtr -> do- let checkAndGetOutput :: CInt -> PCRE2_SPTR -> IO (CInt, Text)- checkAndGetOutput 0 _ = return (0, subject)- checkAndGetOutput result outBufPtr = do- check (> 0) result- outLen <- peek outLenPtr- out <- Text.fromPtr (castCUs outBufPtr) (fromIntegral outLen)- return (result, out)+ let -- Guess the size of the output to be <= 2x that of the subject.+ initOutLen = Text.length subject * 2 run :: CUInt -> Ptr Pcre2_match_context -> PCRE2_SPTR -> IO CInt run curOpts ctxPtr outBufPtr = pcre2_substitute@@ -824,11 +772,16 @@ outBufPtr outLenPtr - -- Guess the size of the output to be <= 2x that of the subject.- initOutLen = Text.length subject * 2+ checkAndGetOutput :: CInt -> PCRE2_SPTR -> IO (CInt, Text)+ checkAndGetOutput 0 _ = return (0, subject)+ checkAndGetOutput result outBufPtr = do+ check (> 0) result+ outLen <- peek outLenPtr+ out <- Text.fromPtr (castCUs outBufPtr) (fromIntegral outLen)+ return (result, out) poke outLenPtr $ fromIntegral initOutLen- MatchTempEnv {..} <- mkMatchTempEnv firstMatchEnv subject+ MatchTempEnv{..} <- mkMatchTempEnv firstMatchEnv subject firstAttempt <- withForeignOrNullPtr matchTempEnvCtx $ \ctxPtr -> allocaArray initOutLen $ \outBufPtr -> do result <- run pcre2_SUBSTITUTE_OVERFLOW_LENGTH ctxPtr outBufPtr@@ -844,22 +797,28 @@ Left subsLog -> do -- The output was bigger than we guessed. Try again. computedOutLen <- fromIntegral <$> peek outLenPtr- let finalMatchEnv = firstMatchEnv {+ let finalMatchEnv = firstMatchEnv{ -- Do not run regular callouts again. matchEnvCallout = Nothing, -- Do not run any substitution callouts run previously. matchEnvSubCallout = fastFwd <$> matchEnvSubCallout} fastFwd f = \info ->- case subsLog IM.!? subCalloutSubsCount info of+ case subsLog !? subCalloutSubsCount info of Just result -> return result Nothing -> f info- MatchTempEnv {..} <- mkMatchTempEnv finalMatchEnv subject+ MatchTempEnv{..} <- mkMatchTempEnv finalMatchEnv subject withForeignOrNullPtr matchTempEnvCtx $ \ctxPtr -> allocaArray computedOutLen $ \outBufPtr -> do result <- run 0 ctxPtr outBufPtr maybeRethrow matchTempEnvRef checkAndGetOutput result outBufPtr +-- | Helper to generate substitution function. For consistency with+-- `pureUserMatcher`.+pureUserSubber :: Option -> Text -> Text -> Subber+pureUserSubber option patt =+ subberWithEnv $ unsafePerformIO $ userMatchEnv option patt+ -- | Generate per-call data for @pcre2_match()@ etc., to accommodate callouts. -- -- We need to save and inspect state that occurs in potentially concurrent@@ -869,10 +828,10 @@ :: MatchEnv -> Text -- ^ Callout info requires access to the original subject. -> IO MatchTempEnv-mkMatchTempEnv (MatchEnv {..}) subject+mkMatchTempEnv MatchEnv{..} subject | null matchEnvCallout && null matchEnvSubCallout = return noCallouts | otherwise = do- calloutStateRef <- newIORef $ CalloutState {+ stateRef <- newIORef CalloutState{ calloutStateException = Nothing, calloutStateSubsLog = IM.empty} ctx <- mkForeignPtr pcre2_match_context_free ctxPtrForCallouts@@ -883,58 +842,47 @@ -- saving them. -- Install callout, if any- forM_ matchEnvCallout $ \f -> do- fPtr <- mkFunPtr ctx $ mkCallout $ \blockPtr _ -> do+ forOf_ _Just matchEnvCallout $ \f -> do+ funPtr <- mkFunPtr ctx $ mkCallout $ \blockPtr _ -> do info <- getCalloutInfo subject blockPtr- resultOrE <- try $ do- f <- evaluate f- result <- f info- evaluate result+ resultOrE <- try $ f info >>= evaluate case resultOrE of Right result -> return $ case result of CalloutProceed -> 0 CalloutNoMatchHere -> 1 CalloutNoMatch -> pcre2_ERROR_NOMATCH Left e -> do- modifyIORef' calloutStateRef $ \cst -> cst {- calloutStateException = Just e}+ modifyIORef' stateRef $ _calloutStateException ?~ e return pcre2_ERROR_CALLOUT withForeignPtr ctx $ \ctxPtr ->- pcre2_set_callout ctxPtr fPtr nullPtr >>= check (== 0)+ pcre2_set_callout ctxPtr funPtr nullPtr >>= check (== 0) -- Install substitution callout, if any- forM_ matchEnvSubCallout $ \f -> do- fPtr <- mkFunPtr ctx $ mkCallout $ \blockPtr _ -> do+ forOf_ _Just matchEnvSubCallout $ \f -> do+ funPtr <- mkFunPtr ctx $ mkCallout $ \blockPtr _ -> do info <- getSubCalloutInfo subject blockPtr- resultOrE <- try $ do- f <- evaluate f- result <- f info- evaluate result+ resultOrE <- try $ f info >>= evaluate case resultOrE of Right result -> do- modifyIORef' calloutStateRef $ \cst -> cst {- calloutStateSubsLog = IM.insert- (subCalloutSubsCount info)- result- (calloutStateSubsLog cst)}+ modifyIORef' stateRef $ over _calloutStateSubsLog $+ IM.insert (subCalloutSubsCount info) result return $ case result of SubCalloutAccept -> 0 SubCalloutSkip -> 1 SubCalloutAbort -> -1 Left e -> do- modifyIORef' calloutStateRef $ \cst -> cst {- calloutStateException = Just e}+ modifyIORef' stateRef $ _calloutStateException ?~ e return (-1) withForeignPtr ctx $ \ctxPtr -> do- result <- pcre2_set_substitute_callout ctxPtr fPtr nullPtr+ result <- pcre2_set_substitute_callout ctxPtr funPtr nullPtr check (== 0) result - return $ MatchTempEnv {+ return MatchTempEnv{ matchTempEnvCtx = Just ctx,- matchTempEnvRef = Just calloutStateRef}+ matchTempEnvRef = Just stateRef} where- noCallouts = MatchTempEnv {+ noCallouts = MatchTempEnv{ matchTempEnvCtx = matchEnvCtx, matchTempEnvRef = Nothing} ctxPtrForCallouts = case matchEnvCtx of@@ -944,16 +892,21 @@ Just ctx -> withForeignPtr ctx pcre2_match_context_copy -- | Per-call data for @pcre2_match()@ etc.-data MatchTempEnv = MatchTempEnv {- matchTempEnvCtx :: Maybe MatchContext,- matchTempEnvRef :: Maybe (IORef CalloutState)}+data MatchTempEnv = MatchTempEnv{+ matchTempEnvCtx :: !(Maybe MatchContext),+ 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 {- calloutStateException :: Maybe SomeException,- calloutStateSubsLog :: IntMap SubCalloutResult}+-- inspected after @pcre2_match()@ or similar completes. `Lens'`s included.+data CalloutState = CalloutState{+ calloutStateException :: !(Maybe SomeException),+ calloutStateSubsLog :: !(IntMap SubCalloutResult)} +_calloutStateException f CalloutState{..} =+ f calloutStateException <&> \calloutStateException -> CalloutState{..}+_calloutStateSubsLog f CalloutState{..} =+ f calloutStateSubsLog <&> \calloutStateSubsLog -> CalloutState{..}+ foreign import ccall "wrapper" mkRecursionGuard :: FfiWrapper (CUInt -> Ptr a -> IO CInt) @@ -985,7 +938,7 @@ ovecPtr <- pcre2_callout_block_offset_vector blockPtr top <- pcre2_callout_block_capture_top blockPtr forM (0 :| [1 .. fromIntegral top - 1]) $ \n -> do- [start, end] <- forM [0, 1] $ peekElemOff ovecPtr . (n * 2 +)+ [start, end] <- forM [0, 1] $ \i -> peekElemOff ovecPtr $ n * 2 + i return $ if start == pcre2_UNSET then Nothing else Just $ smartSlice calloutSubject $ Slice@@ -1009,7 +962,7 @@ let calloutIsFirst = flags .&. pcre2_CALLOUT_STARTMATCH /= 0 calloutBacktracked = flags .&. pcre2_CALLOUT_BACKTRACK /= 0 - return $ CalloutInfo {..}+ return CalloutInfo{..} -- | Within a substitution callout, marshal the original subject and -- @pcre2_substitute_callout_block@ data to Haskell and present to the user@@ -1024,7 +977,7 @@ ovecPtr <- pcre2_substitute_callout_block_ovector blockPtr ovecCount <- pcre2_substitute_callout_block_oveccount blockPtr forM (0 :| [1 .. fromIntegral ovecCount - 1]) $ \n -> do- [start, end] <- forM [0, 1] $ peekElemOff ovecPtr . (n * 2 +)+ [start, end] <- forM [0, 1] $ \i -> peekElemOff ovecPtr $ n * 2 + i return $ if start == pcre2_UNSET then Nothing else Just $ smartSlice subCalloutSubject $ Slice@@ -1039,7 +992,7 @@ (castCUs $ advancePtr outPtr $ fromIntegral start) (fromIntegral $ end - start) - return $ SubCalloutInfo {..}+ return SubCalloutInfo{..} -- | If there was a callout and it threw an exception, rethrow it. maybeRethrow :: Maybe (IORef CalloutState) -> IO ()@@ -1120,8 +1073,8 @@ getWhitelistedSlices whitelist matchDataPtr -- | Placeholder for building a `Traversal'` to be passed to `has`.-nilFromMatch :: FromMatch Proxy-nilFromMatch _ = return Proxy+getNoSlices :: FromMatch Proxy+getNoSlices _ = return Proxy -- | Match a pattern to a subject and return some non-empty list(s) of captures -- in an `Alternative`, or `empty` if no match. The non-empty list constructor@@ -1148,8 +1101,8 @@ -- | @matchesOpt mempty = matches@ matchesOpt :: Option -> Text -> Text -> Bool-matchesOpt option patt = has $ _capturesInternal matcher nilFromMatch where- matcher = unsafePerformIO $ assembleMatcher option patt+matchesOpt option patt = has $ _capturesInternal matcher getNoSlices where+ matcher = pureUserMatcher option patt -- | Match a pattern to a subject and return the portion(s) that matched in an -- `Alternative`, or `empty` if no match.@@ -1188,7 +1141,7 @@ -- @ subOpt :: Option -> Text -> Text -> Text -> Text subOpt option patt replacement = snd . unsafePerformIO . subber where- subber = unsafePerformIO $ assembleSubber replacement option patt+ subber = pureUserSubber option patt replacement -- | 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.@@ -1215,8 +1168,7 @@ -- 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).+-- It's recommended that the list be modified capture-wise, using `ix`. -- -- > let madlibs = _captures "(\\w+) my (\\w+)" -- >@@ -1233,7 +1185,7 @@ -- | @_capturesOpt mempty = _captures@ _capturesOpt :: Option -> Text -> Traversal' Text (NonEmpty Text) _capturesOpt option patt = _capturesInternal matcher getAllSlices where- matcher = unsafePerformIO $ assembleMatcher option patt+ matcher = pureUserMatcher option patt -- | Given a pattern, produce a traversal (0 or more targets) that focuses from -- a subject to the non-overlapping portions of it that match.@@ -1244,9 +1196,8 @@ -- | @_matchOpt mempty = _match@ _matchOpt :: Option -> Text -> Traversal' Text Text-_matchOpt option patt = _cs . _Identity where- _cs = _capturesInternal matcher get0thSlice- matcher = unsafePerformIO $ assembleMatcher option patt+_matchOpt option patt = _capturesInternal matcher get0thSlice . _Identity where+ matcher = pureUserMatcher option patt -- * Support for Template Haskell compile-time regex analysis @@ -1281,7 +1232,7 @@ hiCaptNum <- getCodeInfo @CUInt codePtr pcre2_INFO_CAPTURECOUNT - return $ map (names IM.!?) [1 .. fromIntegral hiCaptNum]+ return $ map (names !?) [1 .. fromIntegral hiCaptNum] -- | Low-level access to compiled pattern info, per the docs. getCodeInfo :: (Storable a) => Ptr Pcre2_code -> CUInt -> IO a@@ -1289,77 +1240,10 @@ pcre2_pattern_info codePtr what wherePtr >>= check (== 0) peek 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—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-- -- FIXME See Text.Regex.Pcre2.TH, where we end the lookup table with a- -- placeholder entry due to a GHC bug. We must ensure a successful name- -- lookup does not occur on this last entry; hence the extra promoted cons- -- operators in this pattern.- 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 nonexistent number or name will result in a type error.-capture :: forall i info num. (CaptNum i info ~ num, KnownNat num) =>- Captures info -> Text-capture = view $ _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 f (Captures cs) =- let (ls, c : rs) = NE.splitAt (fromInteger $ natVal @num Proxy) cs- in f c <&> \c' -> Captures $ NE.fromList $ ls ++ c' : rs- -- * Exceptions -- | The root of the PCRE2 exception hierarchy.-data SomePcre2Exception = forall e. (Exception e) => SomePcre2Exception e+data SomePcre2Exception = forall e. (Exception e) => SomePcre2Exception !e instance Show SomePcre2Exception where show (SomePcre2Exception e) = show e instance Exception SomePcre2Exception@@ -1400,7 +1284,7 @@ -- | 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 p x = unless (p x) $ throwIO $ Pcre2Exception x+check p = unless . p <*> throwIO . Pcre2Exception -- * PCRE2 compile-time config
src/hs/Text/Regex/Pcre2/TH.hs view
@@ -1,12 +1,18 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Text.Regex.Pcre2.TH where import Control.Applicative (Alternative(..))-import Data.Functor ((<&>)) import Data.IORef import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE@@ -15,12 +21,87 @@ import Data.Proxy (Proxy(..)) import Data.Text (Text) import qualified Data.Text as Text+import Data.Type.Bool (If, type (||))+import Data.Type.Equality (type (==))+import GHC.TypeLits hiding (Text)+import qualified GHC.TypeLits as TypeLits import Language.Haskell.TH import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax+import Lens.Micro+import Lens.Micro.Extras (view) import System.IO.Unsafe (unsafePerformIO) import Text.Regex.Pcre2.Internal +-- | 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 `regex`\/`_regex` and consumed by+-- `capture`\/`_capture`, relying on type inference. Specifying the @info@+-- explicitly in a type signature is not supported—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@. The first number is the total number of+-- parenthesized captures, and the list is a lookup table from capture names to+-- numbers.+type CapturesInfo = (Nat, [(Symbol, Nat)])++-- | Helper for constructing an empty lookup table. If we splice `promotedNilT`+-- directly, we would have to require the user to turn on either+-- @KindSignatures@ or @PolyKinds@; GHC seems to monokind @'[]@ as @[*]@,+-- instead of unifying it with the list inside `CapturesInfo`.+type NoNamedCaptures = '[] :: [(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 nonexistent number or name will result in a type error.+capture :: forall i info num. (CaptNum i info ~ num, KnownNat num) =>+ Captures info -> Text+capture = view $ _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 f (Captures cs) =+ let (ls, c : rs) = NE.splitAt (fromInteger $ natVal @num Proxy) cs+ in f c <&> \c' -> Captures $ NE.fromList $ ls ++ c' : rs+ -- | Unexported, top-level `IORef` that\'s created upon the first runtime -- evaluation of a Template Haskell `Matcher`. globalMatcherCache :: IORef (Map Text Matcher)@@ -33,11 +114,9 @@ cache <- readIORef globalMatcherCache case Map.lookup patt cache of Just matcher -> return matcher- Nothing -> do- let matcher = unsafePerformIO $ assembleMatcher mempty patt- atomicModifyIORef' globalMatcherCache $ \cache ->- (Map.insert patt matcher cache, ())- return matcher+ Nothing -> atomicModifyIORef' globalMatcherCache $ \cache ->+ let matcher = pureUserMatcher mempty patt+ in (Map.insert patt matcher cache, matcher) -- | Predict parenthesized captures \(maybe named\) of a pattern at splice time. predictCaptureNamesQ :: String -> Q [Maybe Text]@@ -57,23 +136,20 @@ -- One or more parenthesized captures. Present -- [Just "foo", Nothing, Nothing, Just "bar"] -- as- -- '(4, '[ '("foo", 1), '("bar", 4), '("", 0)]).- captureNames -> Just <$> promotedTupleT 2 `appT` hi `appT` kvs where+ -- '(4, '[ '("foo", 1), '("bar", 4)]).+ captureNames -> Just <$> promotedTupleT 2 `appT` hiQ `appT` kvsQ where -- 4- hi = litT $ numTyLit $ fromIntegral $ length captureNames+ hiQ = litT $ numTyLit $ fromIntegral $ length captureNames -- '[ '("foo", 1), '("bar", 4), '("", 0)]- kvs = foldr f end (toKVs captureNames) where- -- '("foo", 1) ': ...- f (number, name) r = promotedConsT `appT` kv `appT` r where- kv = promotedTupleT 2 -- '(,)- `appT` litT (strTyLit $ Text.unpack name) -- "foo"- `appT` litT (numTyLit $ fromIntegral number) -- 1- -- FIXME GHC kind-checks empty '[] as [*] instead of [k], which breaks- -- quasi-quoted regexes with parenthesized captures but no names.- -- Therefore, we avoid ever splicing an empty lookup table by ending it- -- with a placeholder entry (which cannot arise from a pattern since ""- -- is an invalid capture group name).- end = [t| '[ '("", 0)] |]+ kvsQ = case toKVs captureNames of+ -- We can't splice '[] because it doesn't kind-check. See above.+ [] -> [t| NoNamedCaptures |]+ kvs -> foldr f promotedNilT kvs+ -- '("foo", 1) ': ...+ f (number, name) r = promotedConsT `appT` kvQ `appT` r where+ kvQ = promotedTupleT 2 -- '(,)+ `appT` litT (strTyLit $ Text.unpack name) -- "foo"+ `appT` litT (numTyLit $ fromIntegral number) -- 1 -- | Helper for `regex` with no parenthesized captures. matchTH :: (Alternative f) => Text -> Text -> f Text@@ -87,7 +163,7 @@ -- | Helper for `regex` as a guard pattern. matchesTH :: Text -> Text -> Bool-matchesTH patt = has $ _capturesInternal (memoMatcher patt) nilFromMatch+matchesTH patt = has $ _capturesInternal (memoMatcher patt) getNoSlices -- | Helper for `regex` as a pattern that binds local variables. capturesNumberedTH :: Text -> NonEmpty Int -> Text -> [Text]@@ -107,7 +183,9 @@ -- | === As an expression ----- > regex :: (Alternative f) => String -> Text -> f (Captures info)+-- @+-- regex :: (`Alternative` f) => String -> Text -> f (`Captures` info)+-- @ -- -- in the presence of parenthesized captures, or --@@ -143,7 +221,7 @@ -- -- If there are no named captures, this simply acts as a guard. regex :: QuasiQuoter-regex = QuasiQuoter {+regex = QuasiQuoter{ quoteExp = \s -> capturesInfoQ s >>= \case Nothing -> [e| matchTH (Text.pack $(stringE s)) |] Just info -> [e| capturesTH@@ -176,8 +254,10 @@ -- | An optical variant of `regex`. Can only be used as an expression. ----- > _regex :: String -> Traversal' Text (Captures info)--- > _regex :: String -> Traversal' Text Text+-- @+-- _regex :: String -> `Traversal'` Text (`Captures` info)+-- _regex :: String -> Traversal' Text Text+-- @ -- -- > import Control.Lens -- > import Data.Text.Lens@@ -190,8 +270,8 @@ -- > -- > -- There are 15 competing standards _regex :: QuasiQuoter-_regex = QuasiQuoter {- quoteExp = \s -> capturesInfoQ s >>= \case+_regex = QuasiQuoter{+ quoteExp = \s -> capturesInfoQ s >>= \case Nothing -> [e| _matchTH (Text.pack $(stringE s)) |] Just info -> [e| _capturesTH (Text.pack $(stringE s))