diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog and Acknowledgements +## 1.1.2 +* Refactored using the `streaming` library. Fixed + [#11](https://github.com/sjshuck/pcre2/11), where large global matches were + very slow. + ## 1.1.1 * Fixed [#12](https://github.com/sjshuck/pcre2/4), where some functions returned too many match results. diff --git a/pcre2.cabal b/pcre2.cabal --- a/pcre2.cabal +++ b/pcre2.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d8aba62e213c9b15ec9218a159e7922eb4ebb298385cd3ff0e1acd1f15fd6506 +-- hash: 59ef57516a0657d661f19dafd5afd97472da24119ee5d5d31c7681834b8c303a name: pcre2 -version: 1.1.1 +version: 1.1.2 synopsis: Regular expressions via the PCRE2 C library (included) description: Please see the README on GitHub at category: Text @@ -147,9 +147,9 @@ base >=4.9 && <5 , containers , mtl + , streaming , template-haskell , text - , transformers default-language: Haskell2010 test-suite pcre2-test @@ -167,9 +167,9 @@ , microlens-platform , mtl , pcre2 + , streaming , template-haskell , text - , transformers default-language: Haskell2010 benchmark pcre2-benchmarks @@ -189,7 +189,7 @@ , pcre-light , pcre2 , regex-pcre-builtin + , streaming , template-haskell , text - , transformers default-language: Haskell2010 diff --git a/src/hs/Text/Regex/Pcre2/Internal.hs b/src/hs/Text/Regex/Pcre2/Internal.hs --- a/src/hs/Text/Regex/Pcre2/Internal.hs +++ b/src/hs/Text/Regex/Pcre2/Internal.hs @@ -18,8 +18,6 @@ import Control.Applicative (Alternative(..)) import Control.Exception hiding (TypeError) import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Writer.Lazy (WriterT(..), execWriterT, tell) import Data.Either (partitionEithers) import Data.Function ((&)) import Data.Functor ((<&>)) @@ -31,7 +29,6 @@ import Data.List (foldl', intercalate) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromJust, fromMaybe) import Data.Monoid import Data.Proxy (Proxy(..)) import Data.Text (Text) @@ -45,6 +42,9 @@ import qualified Foreign.Concurrent as Conc import GHC.TypeLits hiding (Text) import qualified GHC.TypeLits as TypeLits +import Streaming (Of(..), Stream) +import qualified Streaming +import qualified Streaming.Prelude as Streaming import System.IO.Unsafe import Text.Regex.Pcre2.Foreign @@ -74,6 +74,10 @@ bitOr :: (Foldable t, Num a, Bits a) => t a -> a bitOr = foldl' (.|.) 0 +-- | Placeholder for half-building a `Traversal'` to be passed to `has`. +noTouchy :: a +noTouchy = error "BUG! Tried to use match results" + -- | Equivalent to @flip fix@. -- -- Used to express a recursive function of one argument that is called only once @@ -150,11 +154,14 @@ -- * 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 and a whitelist of capture indexes --- to extract, and produces lists of capture offsets representing a global --- match. The whitelist is @[]@ rather than @NonEmpty@ to facilitate writing --- literals. -type Matcher = Text -> [Int] -> IO [NonEmpty SliceRange] +-- been \"compiled\". It takes a subject a produces a finite 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 (Of (Ptr Pcre2_match_data)) IO () -- | A substitution function. It takes a subject and produces the number of -- substitutions performed (0 or 1, or more in the presence of `SubGlobal`) @@ -678,26 +685,18 @@ return $ mkSubjFun matchEnv --- | Produce a `Matcher`. -assembleMatcher - :: Option - -> Text -- ^ pattern - -> IO Matcher +-- | Produce a `Matcher` from user-supplied `Option` and pattern. +assembleMatcher :: Option -> Text -> IO Matcher assembleMatcher = assembleSubjFun $ \matchEnv@(MatchEnv {..}) -> let matchTempEnvWithSubj = mkMatchTempEnv matchEnv - in \subject whitelist -> + in \subject -> Streaming.effect $ withForeignPtr matchEnvCode $ \codePtr -> + withMatchDataFromCode codePtr $ \matchDataPtr -> Text.useAsPtr subject $ \subjPtr subjCUs -> do MatchTempEnv {..} <- matchTempEnvWithSubj subject - -- These need to happen one after the other. We need the - -- ForeignPtr to touch later, to allow cleanup after lazy matching. - matchDataPtr <- pcre2_match_data_create_from_pattern codePtr nullPtr - matchData <- - Conc.newForeignPtr <*> pcre2_match_data_free $ matchDataPtr - -- Loop over the subject, emitting slice lists until stopping. - lists <- execWriterT $ runMaybeT $ fix1 0 $ \continue curOff -> do + return $ fix1 0 $ \continue curOff -> do result <- liftIO $ withForeignOrNullPtr matchTempEnvCtx $ \ctxPtr -> pcre2_match @@ -710,17 +709,13 @@ ctxPtr -- Handle no match and errors - when (result == pcre2_ERROR_NOMATCH) stop - when (result == pcre2_ERROR_CALLOUT) $ - liftIO $ maybeRethrow matchTempEnvRef - liftIO $ check (> 0) result - - slices <- liftIO $ unsafeInterleaveIO $ - getOvecEntriesAt whitelist matchDataPtr + unless (result == pcre2_ERROR_NOMATCH) $ do + when (result == pcre2_ERROR_CALLOUT) $ + liftIO $ maybeRethrow matchTempEnvRef + liftIO $ check (> 0) result - emit slices + Streaming.yield matchDataPtr - lazy $ do -- Determine next starting offset nextOff <- liftIO $ do ovecPtr <- pcre2_get_ovector_pointer matchDataPtr @@ -729,20 +724,16 @@ return $ max curOffEnd (curOff + 1) -- Handle end of subject - when (nextOff > fromIntegral subjCUs) stop - - -- Force slices out of the current match_data state before - -- clobbering it with the next match - slices `seq` continue nextOff - - touchForeignPtr matchData - - return lists + unless (nextOff > fromIntegral subjCUs) $ + -- Force slices out of the current match_data state + -- before clobbering it with the next match + continue nextOff where - stop = MaybeT $ return Nothing - emit x = tell [x] - lazy = MaybeT . WriterT . unsafeInterleaveIO . runWriterT . runMaybeT + withMatchDataFromCode codePtr action = do + matchData <- mkForeignPtr pcre2_match_data_free $ + pcre2_match_data_create_from_pattern codePtr nullPtr + withForeignPtr matchData 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 @@ -1031,26 +1022,29 @@ -- | 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. -- --- When any capture is forced, all captures are forced in order to GC C data --- more promptly. When we need /some/ captures but not /all/ captures, we can --- pass in a whitelist of the numbers of captures we want, thereby avoiding --- unnecessary allocations. --- -- Internal only! Users should not (have to) know about `Matcher`. -_capturesInternal :: Matcher -> [Int] -> Traversal' Text (NonEmpty Text) -_capturesInternal matcher whitelist f subject = traverse f css <&> \css' -> - -- Swag foldl-as-foldr to create only as many segments as we need to stitch - -- back together and no more. - let triples = zip3 (flatten ovecEntries) (flatten css) (flatten css') - in Text.concat $ foldr mkSegments termSegments triples 0 +_capturesInternal + :: Matcher + -> FromMatch -- ^ get some or all captures offsets + -> (Text -> SliceRange -> Text) -- ^ slicer + -> Traversal' Text (NonEmpty Text) +_capturesInternal matcher getSliceRanges slicer f subject = + traverse f captureLists <&> \captureLists' -> + -- Swag foldl-as-foldr to create only as many segments as we need to + -- stitch back together and no more. + let triples = concat $ zipWith3 zip3 + (map NE.toList sliceRangeLists) + (map NE.toList captureLists) + (map NE.toList captureLists') + in Text.concat $ foldr mkSegments termSegments triples 0 where - - flatten = concatMap NE.toList - ovecEntries = unsafePerformIO $ matcher subject whitelist - css = do - ovecEntry <- ovecEntries - return $ unsafePerformIO $ mapM (evaluate . slice subject) ovecEntry + sliceRangeLists = Streaming.destroy + (Streaming.mapM getSliceRanges $ matcher subject) + (\(srs :> srss) -> srs : srss) + unsafePerformIO + (const []) + captureLists = map (NE.map $ slicer subject) sliceRangeLists mkSegments (SliceRange off offEnd, c, c') r prevOffEnd | off == fromIntegral pcre2_UNSET || c == c' = @@ -1068,24 +1062,35 @@ -- cases where no substring is changed. in [thinSlice subject (SliceRange off offEnd) | off /= offEnd] --- | Strictly read specifically indexed captures' offsets from match results. --- Truncate indexes when they go out of bounds, to support infinite lists. -getOvecEntriesAt :: [Int] -> Ptr Pcre2_match_data -> IO (NonEmpty SliceRange) -getOvecEntriesAt whitelist matchDataPtr = do - count <- fromIntegral <$> pcre2_get_ovector_count matchDataPtr +-- | A function that takes a subject and a C match result, and extracts a +-- collection of captures. We need to pass this effectful callback to +-- `_capturesInternal` because of the latter\'s tight, imperative loop that +-- reuses the same @pcre2_match_data@ block. +type FromMatch = Ptr Pcre2_match_data -> IO (NonEmpty SliceRange) - case NE.nonEmpty $ takeWhile (< count) whitelist of - Nothing -> error "BUG! Empty whitelist" - Just ns -> do - ovecPtr <- pcre2_get_ovector_pointer matchDataPtr +-- | Read all specifically indexed captures\' offsets from match results. +getWhitelistedSliceRanges :: NonEmpty Int -> FromMatch +getWhitelistedSliceRanges whitelist matchDataPtr = do + ovecPtr <- pcre2_get_ovector_pointer matchDataPtr + let peekOvec :: Int -> IO Text.I16 + peekOvec = fmap fromIntegral . peekElemOff ovecPtr - let peekOvec :: Int -> IO Text.I16 - peekOvec = fmap fromIntegral . peekElemOff ovecPtr + forM whitelist $ \i -> liftM2 SliceRange + (peekOvec $ i * 2) + (peekOvec $ i * 2 + 1) - forM ns $ \n -> liftM2 SliceRange - (peekOvec $ n * 2) - (peekOvec $ n * 2 + 1) +-- | Read just the 0th capture\'s offsets from match results. +get0thSliceRanges :: FromMatch +get0thSliceRanges = getWhitelistedSliceRanges $ 0 :| [] +-- | Read all captures\' offsets from match results. +getAllSliceRanges :: FromMatch +getAllSliceRanges matchDataPtr = do + count <- fromIntegral <$> pcre2_get_ovector_count matchDataPtr + let whitelist = 0 :| [1 .. count - 1] + + getWhitelistedSliceRanges whitelist matchDataPtr + -- | Helper to create non-Template Haskell API functions. They all take options -- and a pattern, and then do something via a 'Matcher'. withMatcher :: (Matcher -> a) -> Option -> Text -> a @@ -1137,7 +1142,10 @@ -- | @matchesOpt mempty = matches@ matchesOpt :: Option -> Text -> Text -> Bool -matchesOpt = withMatcher $ \matcher -> has $ _capturesInternal matcher [] +matchesOpt = withMatcher $ \matcher -> has $ _capturesInternal + matcher + (const $ return $ noTouchy :| noTouchy) + noTouchy -- | Match a pattern to a subject once and return the portion that matched in an -- `Alternative`, or `empty` if no match. @@ -1231,18 +1239,20 @@ -- | @_capturesOpt mempty = _captures@ _capturesOpt :: Option -> Text -> Traversal' Text (NonEmpty Text) -_capturesOpt = withMatcher $ \matcher -> _capturesInternal matcher [0 ..] +_capturesOpt = withMatcher $ \matcher -> + _capturesInternal matcher getAllSliceRanges slice -- | Given a pattern, produce a traversal (0 or more targets) that focuses from -- a subject to the portions of it that match. -- --- Equivalent to @\\patt -> `_captures` patt . ix 0@, but more efficient. +-- @_match = `_captures` patt . ix 0@ _match :: Text -> Traversal' Text Text _match = _matchOpt mempty -- | @_matchOpt mempty = _match@ _matchOpt :: Option -> Text -> Traversal' Text Text -_matchOpt = withMatcher $ \matcher -> _capturesInternal matcher [0] . _headNE +_matchOpt = withMatcher $ \matcher -> + _capturesInternal matcher get0thSliceRanges slice . _headNE -- * Support for Template Haskell compile-time regex analysis diff --git a/src/hs/Text/Regex/Pcre2/TH.hs b/src/hs/Text/Regex/Pcre2/TH.hs --- a/src/hs/Text/Regex/Pcre2/TH.hs +++ b/src/hs/Text/Regex/Pcre2/TH.hs @@ -7,7 +7,7 @@ import Control.Applicative (Alternative(..)) import Data.IORef import Data.Functor ((<&>)) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map @@ -103,31 +103,39 @@ regex = QuasiQuoter { quoteExp = \s -> capturesInfoQ s >>= \case Nothing -> [e| - let _cs = _capturesInternal $(matcherQ s) [0] + let _cs = _capturesInternal $(matcherQ s) get0thSliceRanges slice in toAlternativeOf $ _cs . _headNE |] Just info -> [e| - let wrap cs = Captures cs :: Captures $(return info) - _cs = _capturesInternal $(matcherQ s) [0 ..] + let _cs = _capturesInternal $(matcherQ s) getAllSliceRanges slice + wrap cs = Captures cs :: Captures $(return info) in toAlternativeOf $ _cs . to wrap |], quotePat = \s -> do captureNames <- predictCaptureNamesQ s - case toKVs captureNames of + case NE.nonEmpty $ toKVs captureNames of -- No named captures. Test whether the string matches without -- creating any new Text values. - [] -> viewP - [e| has $ _capturesInternal $(matcherQ s) [] |] + Nothing -> viewP + [e| + has $ _capturesInternal + $(matcherQ s) + (const $ return $ noTouchy :| noTouchy) + noTouchy |] [p| True |] -- One or more named captures. Attempt to bind only those to local -- variables of the same names. - numberedNames -> viewP e p where - (nums, names) = unzip numberedNames + Just numberedNames -> viewP e p where + (numbers, names) = NE.unzip numberedNames e = [e| - let _cs = _capturesInternal $(matcherQ s) $(liftData nums) - in maybe [] NE.toList . preview _cs |] - p = listP $ map (varP . mkName . Text.unpack) names, + let _cs = _capturesInternal + $(matcherQ s) + (getWhitelistedSliceRanges $(liftData numbers)) + slice + in view $ _cs . to NE.toList |] + p = foldr f wildP names where + f name r = conP '(:) [varP $ mkName $ Text.unpack name, r], quoteType = const $ fail "regex: cannot produce a type", @@ -152,11 +160,14 @@ _regex :: QuasiQuoter _regex = QuasiQuoter { quoteExp = \s -> capturesInfoQ s >>= \case - Nothing -> [e| _capturesInternal $(matcherQ s) [0] . _headNE |] + Nothing -> [e| + let _cs = _capturesInternal $(matcherQ s) get0thSliceRanges slice + in _cs . _headNE |] Just info -> [e| - let wrapped :: Lens' (NonEmpty Text) (Captures $(return info)) + let _cs = _capturesInternal $(matcherQ s) getAllSliceRanges slice + wrapped :: Lens' (NonEmpty Text) (Captures $(return info)) wrapped f cs = f (Captures cs) <&> \(Captures cs') -> cs' - in _capturesInternal $(matcherQ s) [0 ..] . wrapped |], + in _cs . wrapped |], quotePat = const $ fail "_regex: cannot produce a pattern",