parser-regex 0.2.0.2 → 0.3.0.0

raw patch · 10 files changed

+359/−295 lines, 10 filesdep ~ghc-bignumPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-bignum

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−1
• README.md +29/−12
• parser-regex.cabal +2/−1
• src/Regex/Internal/Debug.hs +18/−25
• src/Regex/Internal/List.hs +33/−40
• src/Regex/Internal/Parser.hs +142/−154
• src/Regex/Internal/Regex.hs +67/−20
• src/Regex/Internal/Solo.hs +27/−0
• src/Regex/Internal/Text.hs +31/−40
• src/Regex/Internal/Unique.hs +0/−2

@@ -1,7 +1,16 @@-### 0.2.0.2 -- 2024-03-15+### 0.3.0.0 -- 2025-04-19 +* Breaking changes—`Internal` modules only+  * Changes to internal representations+* Performance improvements+  * Fix a pessimization due to boxity analysis on GHC >= 9.4. Improves parsing+    time by up to 23%.++### 0.2.0.2 -- 2025-03-15+ * Compatibility with [MicroHs](https://github.com/augustss/MicroHs) * Performance improvements+  * Avoid some closure allocations, improving parsing time by up to 10%. * Fix `compileBounded`'s behavior on negative bounds  ### 0.2.0.1 -- 2024-12-25

@@ -66,7 +66,7 @@           , fragment = Just "parser-regex" }) ``` -### More parsing+### Parsing  Parsing is straightforward, even for tasks which may be impractical with submatch extraction typically offered by regex libraries.@@ -121,27 +121,44 @@  ### Parse any sequence -Regexes are not restricted to parsing text. For example, one may parse vectors-from the [vector](https://hackage.haskell.org/package/vector) library, because-why not.+Parsing is not restricted to text. One can parse a+[`vector`](https://hackage.haskell.org/package/vector), a+[`conduit`](https://hackage.haskell.org/package/conduit), or any other sequence+one might have.  ```hs-import Regex.Base (Parser) import qualified Regex.Base as R-import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic as VG -- from vector+import qualified Conduit as C -- from conduit -parseVector :: VG.Vector v c => Parser c a -> v c -> Maybe a+parseVector :: VG.Vector v c => R.Parser c a -> v c -> Maybe a parseVector = R.parseFoldr VG.foldr++parseConduit :: Monad m => R.Parser c a -> C.ConduitT c x m (Maybe a)+parseConduit p = R.parseNext p C.await <* C.sinkNull ``` ```hs >>> import Control.Applicative (many)->>> import qualified Data.Vector as V >>> import qualified Regex.Base as R+>>> :{+let evenOddP :: R.Parser Int [(Int, Int)]+    evenOddP = R.compile $ many ((,) <$> R.satisfy even <*> R.satisfy odd)+:} >>>->>> let p = R.compile $ many ((,) <$> R.satisfy even <*> R.satisfy odd)->>> let v = V.fromList [0..5] :: V.Vector Int->>> parseVector p v-Just [(0,1),(2,3),(4,5)]+>>> import qualified Data.Vector as V+>>> parseVector evenOddP (V.fromList [6,1,2,5,4,3])+Just [(6,1),(2,5),(4,3)]+>>> parseVector evenOddP (V.fromList [4,3,1,2])+Nothing+>>>+>>> import Conduit ((.|))+>>> import qualified Conduit as C+>>> C.runConduit $ C.yieldMany [0..3] .| C.iterMC print .| parseConduit evenOddP+0+1+2+3+Just [(0,1),(2,3)] ```  ## Documentation

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               parser-regex-version:            0.2.0.2+version:            0.3.0.0 synopsis:           Regex based parsers homepage:           https://github.com/meooow25/parser-regex bug-reports:        https://github.com/meooow25/parser-regex/issues@@ -52,6 +52,7 @@         Regex.Internal.Debug         Regex.Internal.Parser         Regex.Internal.Regex+        Regex.Internal.Solo         Regex.Internal.Text         Regex.Internal.Unique 

@@ -22,7 +22,7 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM -import Regex.Internal.Regex (RE(..), Strictness(..), Greediness(..))+import Regex.Internal.Regex (RE(..)) import Regex.Internal.Parser (Node(..), Parser(..)) import Regex.Internal.Unique (Unique(..)) import qualified Regex.Internal.CharSet as CS@@ -44,15 +44,15 @@     go :: forall b. RE c b -> M Id     go re = case re of       RToken t -> new $ labelToken "RToken" t ma-      RFmap st _ re1 ->-        withNew (str "RFmap" <+> dispsSt st) $ \i ->+      RFmap _ re1 ->+        withNew (str "RFmap") $ \i ->           go re1 >>= writeEdge i       RFmap_ _ re1 ->         withNew (str "RFmap_") $ \i ->           go re1 >>= writeEdge i       RPure _ -> new (str "RPure")-      RLiftA2 st _ re1 re2 ->-        withNew (str "RLiftA2" <+> dispsSt st) $ \i -> do+      RLiftA2 _ re1 re2 ->+        withNew (str "RLiftA2") $ \i -> do           go re1 >>= writeEdge i           go re2 >>= writeEdge i       REmpty -> new (str "REmpty")@@ -60,9 +60,12 @@         withNew (str "RAlt") $ \i -> do           go re1 >>= writeEdge i           go re2 >>= writeEdge i-      RFold st gr _ _ re1 ->-        withNew (str "RFold" <+> dispsSt st <+> dispsGr gr) $ \i ->+      RFoldGr _ _ re1 ->+        withNew (str "RFoldGr") $ \i ->           go re1 >>= writeEdge i+      RFoldMn _ _ re1 ->+        withNew (str "RFoldMn") $ \i ->+          go re1 >>= writeEdge i       RMany _ _ _ _ re1 ->         withNew (str "RMany") $ \i ->           go re1 >>= writeEdge i@@ -84,8 +87,8 @@     go :: forall b. Parser c b -> M Id     go p = case p of       PToken t -> new $ labelToken "PToken" t ma-      PFmap st _ re1 ->-        withNew (str "PFmap" <+> dispsSt st) $ \i ->+      PFmap _ re1 ->+        withNew (str "PFmap") $ \i ->           go re1 >>= writeEdge i       PFmap_ node ->         withNew (str "PFmap_") $ \i -> do@@ -94,8 +97,8 @@           writeLn (str "}")           writeEdge i j       PPure _ -> new (str "PPure")-      PLiftA2 st _ re1 re2 ->-        withNew (str "PLiftA2" <+> dispsSt st) $ \i -> do+      PLiftA2 _ re1 re2 ->+        withNew (str "PLiftA2") $ \i -> do           go re1 >>= writeEdge i           go re2 >>= writeEdge i       PEmpty -> new (str "PEmpty")@@ -107,11 +110,11 @@       PMany _ _ _ _ _ re1 ->         withNew (str "PMany") $ \i ->           go re1 >>= writeEdge i-      PFoldGr _ st _ _ re1 ->-        withNew (str "PFoldGr" <+> dispsSt st) $ \i ->+      PFoldGr _ _ _ re1 ->+        withNew (str "PFoldGr") $ \i ->           go re1 >>= writeEdge i-      PFoldMn _ st _ _ re1 ->-        withNew (str "PFoldMn" <+> dispsSt st) $ \i ->+      PFoldMn _ _ _ re1 ->+        withNew (str "PFoldMn") $ \i ->           go re1 >>= writeEdge i      goNode :: forall b. Node c b -> StateT (IntMap Id) M Id@@ -157,16 +160,6 @@  instance Monoid Str where   mempty = Str id--dispsSt :: Strictness -> Str-dispsSt st = case st of-  Strict -> str "S"-  NonStrict -> str "NS"--dispsGr :: Greediness -> Str-dispsGr gr = case gr of-  Greedy -> str "G"-  Minimal -> str "M"  labelToken :: String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> Str labelToken node t = maybe

@@ -50,10 +50,11 @@ import qualified Data.CharSet as CS import Regex.Internal.Parser (Parser) import qualified Regex.Internal.Parser as P-import Regex.Internal.Regex (RE(..), Greediness(..), Strictness(..))+import Regex.Internal.Regex (RE(..)) import qualified Regex.Internal.Regex as R import qualified Regex.Internal.Num as RNum import qualified Regex.Internal.Generated.CaseFold as CF+import Regex.Internal.Solo (Solo, mkSolo, matchSolo)  ------------------------ -- REs and combinators@@ -231,30 +232,28 @@  toMatch_ :: RE c b -> RE c (DList c) toMatch_ re = case re of-  RToken t -> RToken (\c -> singletonD c <$ t c)-  RFmap _ _ re1 -> toMatch_ re1+  RToken t -> R.token (\c -> singletonD c <$ t c)+  RFmap _ re1 -> toMatch_ re1   RFmap_ _ re1 -> toMatch_ re1-  RPure _ -> RPure mempty-  RLiftA2 _ _ re1 re2 -> RLiftA2 Strict (<>) (toMatch_ re1) (toMatch_ re2)-  REmpty -> REmpty-  RAlt re1 re2 -> RAlt (toMatch_ re1) (toMatch_ re2)-  RMany _ _ _ _ re1 -> RFold Strict Greedy (<>) mempty (toMatch_ re1)-  RFold _ gr _ _ re1 -> RFold Strict gr (<>) mempty (toMatch_ re1)+  RPure _ -> pure mempty+  RLiftA2 _ re1 re2 -> R.liftA2' (<>) (toMatch_ re1) (toMatch_ re2)+  REmpty -> Ap.empty+  RAlt re1 re2 -> toMatch_ re1 <|> toMatch_ re2+  RFoldGr _ _ re1 -> R.foldlMany' (<>) mempty (toMatch_ re1)+  RFoldMn _ _ re1 -> R.foldlManyMin' (<>) mempty (toMatch_ re1)+  RMany _ _ _ _ re1 -> R.foldlMany' (<>) mempty (toMatch_ re1)  data WithMatch c a = WM !(DList c) a -instance Functor (WithMatch c) where-  fmap f (WM t x) = WM t (f x)--fmapWM' :: (a -> b) -> WithMatch c a -> WithMatch c b-fmapWM' f (WM t x) = WM t $! f x+fmapWM :: (a -> Solo b) -> WithMatch c a -> WithMatch c b+fmapWM f (WM t x) = matchSolo (f x) (WM t) -instance Applicative (WithMatch c) where-  pure = WM mempty-  liftA2 f (WM t1 x) (WM t2 y) = WM (t1 <> t2) (f x y)+pureWM :: a -> WithMatch c a+pureWM = WM mempty -liftA2WM' :: (a1 -> a2 -> b) -> WithMatch c a1 -> WithMatch c a2 -> WithMatch c b-liftA2WM' f (WM t1 x) (WM t2 y) = WM (t1 <> t2) $! f x y+liftA2WM+  :: (a1 -> a2 -> Solo b) -> WithMatch c a1 -> WithMatch c a2 -> WithMatch c b+liftA2WM f (WM t1 x) (WM t2 y) = matchSolo (f x y) (WM (t1 <> t2))  -- | Rebuild the @RE@ to include the matched section of the list alongside the -- result.@@ -263,28 +262,22 @@   where     go :: RE c b -> RE c (WithMatch c b)     go re = case re of-      RToken t -> RToken (\c -> WM (singletonD c) <$> t c)-      RFmap st f re1 ->-        let g = case st of-              Strict -> fmapWM' f-              NonStrict -> fmap f-        in RFmap Strict g (go re1)-      RFmap_ b re1 -> RFmap Strict (flip WM b) (toMatch_ re1)-      RPure b -> RPure (pure b)-      RLiftA2 st f re1 re2 ->-        let g = case st of-              Strict -> liftA2WM' f-              NonStrict -> Ap.liftA2 f-        in RLiftA2 Strict g (go re1) (go re2)-      REmpty -> REmpty-      RAlt re1 re2 -> RAlt (go re1) (go re2)+      RToken t -> R.token (\c -> WM (singletonD c) <$> t c)+      RFmap f re1 -> R.fmap' (fmapWM f) (go re1)+      RFmap_ b re1 -> R.fmap' (flip WM b) (toMatch_ re1)+      RPure b -> pure (pureWM b)+      RLiftA2 f re1 re2 -> R.liftA2' (liftA2WM f) (go re1) (go re2)+      REmpty -> Ap.empty+      RAlt re1 re2 -> go re1 <|> go re2+      RFoldGr f z re1 -> R.foldlMany' (liftA2WM f) (pureWM z) (go re1)+      RFoldMn f z re1 -> R.foldlManyMin' (liftA2WM f) (pureWM z) (go re1)       RMany f1 f2 f z re1 ->-        RMany (fmapWM' f1) (fmapWM' f2) (liftA2WM' f) (pure z) (go re1)-      RFold st gr f z re1 ->-        let g = case st of-              Strict -> liftA2WM' f-              NonStrict -> Ap.liftA2 f-        in RFold Strict gr g (pure z) (go re1)+        RMany+          (\x -> mkSolo $! fmapWM f1 x)+          (\x -> mkSolo $! fmapWM f2 x)+          (\x y -> mkSolo $! liftA2WM f x y)+          (pureWM z)+          (go re1)  ---------- -- Parse

@@ -4,6 +4,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK not-home #-}+#if __GLASGOW_HASKELL__ >= 904+-- See Note [-fdmd-unbox-width]+{-# OPTIONS_GHC -fdmd-unbox-width=4 #-}+#endif  -- | This is an internal module. You probably don't need to import this. --@@ -30,7 +34,7 @@ import Control.Applicative ((<|>), empty) import qualified Control.Applicative as Ap import Control.Monad.Trans.State.Strict-  ( State, StateT, evalState, evalStateT, execState, gets, modify', state)+  ( State, StateT, evalState, evalStateT, gets, modify', state) import Control.Monad.Fix (mfix) import Data.Maybe (isJust) import qualified Data.Foldable as F@@ -41,7 +45,8 @@ import qualified GHC.Exts as X #endif -import Regex.Internal.Regex (RE(..), Strictness(..), Greediness(..))+import Regex.Internal.Regex (RE(..))+import Regex.Internal.Solo (Solo, matchSolo) import Regex.Internal.Unique (Unique(..), UniqueSet) import qualified Regex.Internal.Unique as U @@ -52,15 +57,15 @@ -- | A parser compiled from a @'RE' c a@. data Parser c a where   PToken  :: !(c -> Maybe a) -> Parser c a-  PFmap   :: !Strictness -> !(a1 -> a) -> !(Parser c a1) -> Parser c a+  PFmap   :: !(a1 -> Solo a) -> !(Parser c a1) -> Parser c a   PFmap_  :: !(Node c a) -> Parser c a   PPure   :: a -> Parser c a-  PLiftA2 :: !Strictness -> !(a1 -> a2 -> a) -> !(Parser c a1) -> !(Parser c a2) -> Parser c a+  PLiftA2 :: !(a1 -> a2 -> Solo a) -> !(Parser c a1) -> !(Parser c a2) -> Parser c a   PEmpty  :: Parser c a   PAlt    :: {-# UNPACK #-} !Unique -> !(Parser c a) -> !(Parser c a) -> {-# UNPACK #-} !(SmallArray (Parser c a)) -> Parser c a-  PFoldGr :: {-# UNPACK #-} !Unique -> !Strictness -> !(a -> a1 -> a) -> a -> !(Parser c a1) -> Parser c a-  PFoldMn :: {-# UNPACK #-} !Unique -> !Strictness -> !(a -> a1 -> a) -> a -> !(Parser c a1) -> Parser c a-  PMany   :: {-# UNPACK #-} !Unique -> !(a1 -> a) -> !(a2 -> a) -> !(a2 -> a1 -> a2) -> !a2 -> !(Parser c a1) -> Parser c a+  PFoldGr :: {-# UNPACK #-} !Unique -> !(a -> a1 -> Solo a) -> a -> !(Parser c a1) -> Parser c a+  PFoldMn :: {-# UNPACK #-} !Unique -> !(a -> a1 -> Solo a) -> a -> !(Parser c a1) -> Parser c a+  PMany   :: {-# UNPACK #-} !Unique -> !(a1 -> Solo a) -> !(a2 -> Solo a) -> !(a2 -> a1 -> Solo a2) -> !a2 -> !(Parser c a1) -> Parser c a  -- | A node in the NFA. Used for recognition. data Node c a where@@ -91,11 +96,11 @@ compileToParser :: RE c a -> State Unique (Parser c a) compileToParser re = case re of   RToken t -> pure $ PToken t-  RFmap st f re1 -> PFmap st f <$> compileToParser re1+  RFmap f re1 -> PFmap f <$> compileToParser re1   RFmap_ a re1 -> PFmap_ <$> compileToNode a re1   RPure a -> pure $ PPure a-  RLiftA2 st f re1 re2 ->-    Ap.liftA2 (PLiftA2 st f) (compileToParser re1) (compileToParser re2)+  RLiftA2 f re1 re2 ->+    Ap.liftA2 (PLiftA2 f) (compileToParser re1) (compileToParser re2)   REmpty -> pure PEmpty   RAlt re01 re02 -> do     u <- nxtU@@ -104,12 +109,14 @@     p2 <- compileToParser re2     ps <- T.traverse compileToParser res     pure $ PAlt u p1 p2 (smallArrayFromList ps)-  RFold st gr f z re1 -> do+  RFoldGr f z re1 -> do     u <- nxtU     _localU <- nxtU-    case gr of-      Greedy -> PFoldGr u st f z <$> compileToParser re1-      Minimal -> PFoldMn u st f z <$> compileToParser re1+    PFoldGr u f z <$> compileToParser re1+  RFoldMn f z re1 -> do+    u <- nxtU+    _localU <- nxtU+    PFoldMn u f z <$> compileToParser re1   RMany f1 f2 f z re1 -> do     u <- nxtU     _localU <- nxtU@@ -121,10 +128,10 @@     go :: forall a2. RE c a2 -> Node c a -> State Unique (Node c a)     go re nxt = case re of       RToken t -> pure $ NToken t nxt-      RFmap _ _ re1 -> go re1 nxt+      RFmap _ re1 -> go re1 nxt       RFmap_ _ re1 -> go re1 nxt       RPure _ -> pure nxt-      RLiftA2 _ _ re1 re2 -> go re2 nxt >>= go re1+      RLiftA2 _ re1 re2 -> go re2 nxt >>= go re1       REmpty -> pure NEmpty       RAlt re01 re02 -> do         u <- nxtU@@ -134,17 +141,17 @@         n2 <- go re2 nxt1         ns <- T.traverse (flip go nxt1) res         pure $ NAlt n1 n2 (smallArrayFromList ns)-      RFold _ gr _ _ re1 -> goMany gr re1 nxt-      RMany _ _ _ _ re1 -> goMany Greedy re1 nxt-    goMany :: forall a2.-              Greediness -> RE c a2 -> Node c a -> State Unique (Node c a)-    goMany gr re1 nxt = do+      RFoldGr _ _ re1 -> goMany True re1 nxt+      RFoldMn _ _ re1 -> goMany False re1 nxt+      RMany _ _ _ _ re1 -> goMany True re1 nxt+    goMany :: forall a2. Bool -> RE c a2 -> Node c a -> State Unique (Node c a)+    goMany greedy re1 nxt = do       u <- nxtU       mfix $ \n -> do         ndown <- go re1 n-        case gr of-           Greedy -> pure $ NGuard u (NAlt ndown nxt emptySmallArray)-           Minimal -> pure $ NGuard u (NAlt nxt ndown emptySmallArray)+        if greedy+        then pure $ NGuard u (NAlt ndown nxt emptySmallArray)+        else pure $ NGuard u (NAlt nxt ndown emptySmallArray)  gatherAlts :: RE c a -> RE c a -> (RE c a, RE c a, [RE c a]) gatherAlts re01 re02 = case go re01 (go re02 []) of@@ -180,14 +187,15 @@     go :: RE c a1 -> StateT Int Maybe ()     go re = case re of         RToken _ -> inc-        RFmap _ _ re1 -> inc *> go re1+        RFmap _ re1 -> inc *> go re1         RFmap_ _ re1 -> inc *> go re1         RPure _ -> inc-        RLiftA2 _ _ re1 re2 -> inc *> go re1 *> go re2+        RLiftA2 _ re1 re2 -> inc *> go re1 *> go re2         REmpty -> inc         RAlt re1 re2 -> inc *> go re1 *> go re2+        RFoldGr _ _ re1 -> inc *> go re1+        RFoldMn _ _ re1 -> inc *> go re1         RMany _ _ _ _ re1 -> inc *> go re1-        RFold _ _ _ _ re1 -> inc *> go re1     inc = do       ok <- gets (< lim)       if ok@@ -200,14 +208,14 @@  data Cont c b a where   CTop     :: Cont c a a-  CFmap    :: !Strictness -> !(b -> a1) -> !(Cont c a1 a) -> Cont c b a+  CFmap    :: !(b -> Solo a1) -> !(Cont c a1 a) -> Cont c b a   CFmap_   :: !(Node c a1) -> !(Cont c a1 a) -> Cont c b a-  CLiftA2A :: !Strictness -> !(b -> a2 -> a3) -> !(Parser c a2) -> !(Cont c a3 a) -> Cont c b a-  CLiftA2B :: !Strictness -> !(a1 -> b -> a3) -> a1 -> !(Cont c a3 a) -> Cont c b a+  CLiftA2A :: !(b -> a2 -> Solo a3) -> !(Parser c a2) -> !(Cont c a3 a) -> Cont c b a+  CLiftA2B :: !(a1 -> b -> Solo a3) -> a1 -> !(Cont c a3 a) -> Cont c b a   CAlt     :: {-# UNPACK #-} !Unique -> !(Cont c b a) -> Cont c b a-  CFoldGr  :: {-# UNPACK #-} !Unique -> !Strictness -> !(Parser c b) -> !(a1 -> b -> a1) -> a1 -> !(Cont c a1 a) -> Cont c b a-  CFoldMn  :: {-# UNPACK #-} !Unique -> !Strictness -> !(Parser c b) -> !(a1 -> b -> a1) -> a1 -> !(Cont c a1 a) -> Cont c b a-  CMany    :: {-# UNPACK #-} !Unique -> !(Parser c b) -> !(b -> a2) -> !(a1 -> a2) -> !(a1 -> b -> a1) -> !a1 -> !(Cont c a2 a) -> Cont c b a+  CFoldGr  :: {-# UNPACK #-} !Unique -> !(Parser c b) -> !(a1 -> b -> Solo a1) -> a1 -> !(Cont c a1 a) -> Cont c b a+  CFoldMn  :: {-# UNPACK #-} !Unique -> !(Parser c b) -> !(a1 -> b -> Solo a1) -> a1 -> !(Cont c a1 a) -> Cont c b a+  CMany    :: {-# UNPACK #-} !Unique -> !(Parser c b) -> !(b -> Solo a2) -> !(a1 -> Solo a2) -> !(a1 -> b -> Solo a1) -> !a1 -> !(Cont c a2 a) -> Cont c b a  data NeedCList c a where   NeedCCons :: !(c -> Maybe b) -> !(Cont c b a) -> !(NeedCList c a) -> NeedCList c a@@ -222,59 +230,72 @@ stepStateZero :: StepState c a stepStateZero = StepState U.empty NeedCNil Nothing --- Note: Ideally we would have--- down :: Parser c b -> Cont c b a -> State (StepState c a) ()--- and similar downNode and up, but GHC is unable to optimize it to be--- equivalent to the current code.------ Using State is pretty convenient though, so it is used in branches. This--- seems to get optimized well enough.+sMember :: Unique -> StepState c a -> Bool+sMember u pt = U.member u (sSet pt) -sMember :: Unique -> State (StepState c a) Bool-sMember u = gets $ \pt -> U.member u (sSet pt)+sInsert :: Unique -> StepState c a -> StepState c a+sInsert u pt = pt { sSet = U.insert u (sSet pt) } -sInsert :: Unique -> State (StepState c a) ()-sInsert u = modify' $ \pt -> pt { sSet = U.insert u (sSet pt) }+-- Note [-fdmd-unbox-width]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- GHC's worker/wrapper transformation is able to eliminate the StepState and+-- generate a worker for `down` with signature+--+-- $wdown+--   :: Parser c b -> Cont c b a+--   -> Int# -> IntSet -> NeedCList c a -> Maybe a+--   -> (# Int#, IntSet, NeedCList c a, Maybe a #)+--+-- and likewise for `downNode` and `up`.+--+-- This is great, but unfortunately boxity analysis gets in the way. Boxity+-- analysis prevents unboxing of types with more than -fdmd-unbox-width fields,+-- default 3 as of today. So we set it to the number of fields in StepState,+-- i.e. 4, with an OPTIONS_GHC pragma.  down :: Parser c b -> Cont c b a -> StepState c a -> StepState c a down p !ct !pt = case p of   PToken t -> pt { sNeed = NeedCCons t ct (sNeed pt) }-  PFmap st f p1 -> down p1 (CFmap st f ct) pt+  PFmap f p1 -> down p1 (CFmap f ct) pt   PFmap_ n -> downNode n ct pt   PPure b -> up b ct pt-  PLiftA2 st f p1 p2 -> down p1 (CLiftA2A st f p2 ct) pt+  PLiftA2 f p1 p2 -> down p1 (CLiftA2A f p2 ct) pt   PEmpty -> pt   PAlt u p1 p2 ps ->     let ct1 = CAlt u ct     in F.foldl' (\pt' p' -> down p' ct1 pt') (down p2 ct1 (down p1 ct1 pt)) ps-  PFoldGr u st f z p1 -> flip execState pt $-    unlessM (sMember u) $ do-      sInsert (localU u)-      modify' $ down p1 (CFoldGr u st p1 f z ct)-      unlessM (sMember u) $ do-        sInsert u-        modify' $ up z ct-  PFoldMn u st f z p1 -> flip execState pt $-    unlessM (sMember u) $ do-      unlessM (sMember (localU u)) $ do-        modify' $ up z ct-      sInsert u-      modify' $ down p1 (CFoldMn u st p1 f z ct)-  PMany u f1 f2 f z p1 -> flip execState pt $-    unlessM (sMember u) $ do-      sInsert (localU u)-      modify' $ down p1 (CMany u p1 f1 f2 f z ct)-      unlessM (sMember u) $ do-        sInsert u-        let !x = f2 z-        modify' $ up x ct+  PFoldGr u f z p1 ->+    if sMember u pt+    then pt+    else+      let pt1 = down p1 (CFoldGr u p1 f z ct) (sInsert (localU u) pt)+      in if sMember u pt1+         then pt1+         else up z ct (sInsert u pt1)+  PFoldMn u f z p1 ->+    if sMember u pt+    then pt+    else+      let pt1 = if sMember (localU u) pt+                then pt+                else up z ct pt+      in down p1 (CFoldMn u p1 f z ct) (sInsert u pt1)+  PMany u f1 f2 f z p1 ->+    if sMember u pt+    then pt+    else+      let pt1 = down p1 (CMany u p1 f1 f2 f z ct) (sInsert (localU u) pt)+      in if sMember u pt1+         then pt1+         else matchSolo (f2 z) $ \x -> up x ct (sInsert u pt1)  downNode :: Node c b -> Cont c b a -> StepState c a -> StepState c a downNode n !ct !pt = case n of   NAccept b -> up b ct pt-  NGuard u n1-    | U.member u (sSet pt) -> pt-    | otherwise -> downNode n1 ct (pt { sSet = U.insert u (sSet pt) })+  NGuard u n1 ->+    if sMember u pt+    then pt+    else downNode n1 ct (sInsert u pt)   NToken t nxt ->     pt { sNeed = NeedCCons t (CFmap_ nxt ct) (sNeed pt) }   NEmpty -> pt@@ -287,58 +308,42 @@ up :: b -> Cont c b a -> StepState c a -> StepState c a up b ct !pt = case ct of   CTop -> pt { sResult = sResult pt <|> Just b }-  CFmap st f ct1 -> case st of-    Strict -> let !x = f b in up x ct1 pt-    NonStrict -> up (f b) ct1 pt+  CFmap f ct1 -> matchSolo (f b) $ \x -> up x ct1 pt   CFmap_ n ct1 -> downNode n ct1 pt-  CLiftA2A st f p1 ct1 -> down p1 (CLiftA2B st f b ct1) pt-  CLiftA2B st f a ct1 -> case st of-    Strict -> let !x = f a b in up x ct1 pt-    NonStrict -> up (f a b) ct1 pt-  CAlt u ct1 -> flip execState pt $-    unlessM (sMember u) $ do-      sInsert u-      modify' $ up b ct1-  CFoldGr u st p1 f z ct1 -> flip execState pt $-    unlessM (sMember u) $ do-      lc <- sMember (localU u)-      if lc then do-        sInsert u-        modify' $ up z ct1-      else do-        let go z1 = do-              modify' $ down p1 (CFoldGr u st p1 f z1 ct1)-              sInsert u-              modify' $ up z1 ct1-            {-# INLINE go #-}-        case st of-          Strict -> let !z1 = f z b in go z1-          NonStrict -> go (f z b)-  CFoldMn u st p1 f z ct1 -> flip execState pt $-    unlessM (sMember u) $ do-      let go z1 = do-            sInsert (localU u)-            modify' $ up z1 ct1-            unlessM (sMember u) $ do-              sInsert u-              modify' $ down p1 (CFoldMn u st p1 f z1 ct1)-          {-# INLINE go #-}-      case st of-        Strict -> let !z1 = f z b in go z1-        NonStrict -> go (f z b)-  CMany u p1 f1 f2 f z ct1 -> flip execState pt $-    unlessM (sMember u) $ do-      lc <- sMember (localU u)-      if lc then do-        sInsert u-        let !x = f1 b-        modify' $ up x ct1-      else do-        let !z1 = f z b-        modify' $ down p1 (CMany u p1 f1 f2 f z1 ct1)-        sInsert u-        let !x = f2 z1-        modify' $ up x ct1+  CLiftA2A f p1 ct1 -> down p1 (CLiftA2B f b ct1) pt+  CLiftA2B f a ct1 -> matchSolo (f a b) $ \x -> up x ct1 pt+  CAlt u ct1 ->+    if sMember u pt+    then pt+    else up b ct1 (sInsert u pt)+  CFoldGr u p1 f z ct1 ->+    if sMember u pt+    then pt+    else+      if sMember (localU u) pt+      then up z ct1 (sInsert u pt)+      else matchSolo (f z b) $ \z1 ->+        let pt1 = down p1 (CFoldGr u p1 f z1 ct1) pt+        in up z1 ct1 (sInsert u pt1)+  CFoldMn u p1 f z ct1 ->+    if sMember u pt+    then pt+    else matchSolo (f z b) $ \z1 ->+      let pt1 = up z1 ct1 (sInsert (localU u) pt)+      in if sMember u pt1+         then pt1+         else down p1 (CFoldMn u p1 f z1 ct1) (sInsert u pt1)+  CMany u p1 f1 f2 f z ct1 ->+    if sMember u pt+    then pt+    else+      if sMember (localU u) pt+      then matchSolo (f1 b) $ \x -> up x ct1 (sInsert u pt)+      else+        matchSolo (f z b) $ \z1 ->+        matchSolo (f2 z1) $ \x ->+          let pt1 = down p1 (CMany u p1 f1 f2 f z1 ct1) pt+          in up x ct1 (sInsert u pt1)  localU :: Unique -> Unique localU = Unique . (+1) . unUnique@@ -395,24 +400,21 @@ -- ==== __Examples__ -- -- @--- import qualified Data.Vector.Generic as VG -- from vector------ import Regex.Base (Parser) -- import qualified Regex.Base as R+-- import qualified Data.Vector.Generic as VG -- from vector ----- parseVector :: VG.Vector v c => Parser c a -> v c -> Maybe a+-- parseVector :: VG.Vector v c => R.Parser c a -> v c -> Maybe a -- parseVector p v = R.'parseFoldr' VG.foldr p v -- @ -- -- >>> import Control.Applicative (many)--- >>> import qualified Data.Vector as V--- >>> import Regex.Base (Parser) -- >>> import qualified Regex.Base as R+-- >>> import qualified Data.Vector as V -- >>> -- >>> let p = R.compile $ many ((,) <$> R.satisfy even <*> R.satisfy odd) :: Parser Int [(Int, Int)]--- >>> parseVector p (V.fromList [0..5])--- Just [(0,1),(2,3),(4,5)]--- >>> parseVector p (V.fromList [0,2..6])+-- >>> parseVector p (V.fromList [6,1,2,5,4,3])+-- Just [(6,1),(2,5),(4,3)]+-- >>> parseVector p (V.fromList [4,3,1,2]) -- Nothing -- parseFoldr :: Foldr f c -> Parser c a -> f -> Maybe a@@ -436,35 +438,30 @@ -- ==== __Examples__ -- -- @--- import Conduit (ConduitT, await, sinkNull) -- from conduit------ import Regex.Base (Parser) -- import qualified Regex.Base as R+-- import qualified Conduit as C -- from conduit ----- parseConduit :: Monad m => Parser c a -> ConduitT c x m (Maybe a)--- parseConduit p = R.'parseNext' p await <* sinkNull+-- parseConduit :: Monad m => R.Parser c a -> C.ConduitT c x m (Maybe a)+-- parseConduit p = R.'parseNext' p C.await <* C.sinkNull -- @ -- -- >>> import Control.Applicative (many)--- >>> import Conduit ((.|), iterMC, runConduit, yieldMany)--- >>> import Regex.Base (Parser) -- >>> import qualified Regex.Base as R+-- >>> import Conduit ((.|))+-- >>> import qualified Conduit as C -- >>> -- >>> let p = R.compile $ many ((,) <$> R.satisfy even <*> R.satisfy odd) :: Parser Int [(Int, Int)]--- >>> let printYieldMany xs = yieldMany xs .| iterMC print--- >>> runConduit $ printYieldMany [0..5] .| parseConduit p+-- >>> runConduit $ C.yieldMany [0..3] .| C.iterMC print .| parseConduit p -- 0 -- 1 -- 2 -- 3+-- Just [(0,1),(2,3)]+-- >>> runConduit $ C.yieldMany [4,3,1,2] .| C.iterMC print .| parseConduit p -- 4--- 5--- Just [(0,1),(2,3),(4,5)]--- >>> runConduit $ printYieldMany [0,2..6] .| parseConduit p--- 0+-- 3+-- 1 -- 2--- 4--- 6 -- Nothing -- -- @since 0.2.0.0@@ -479,15 +476,6 @@         Nothing -> pure Nothing         Just ps' -> loop ps' {-# INLINE parseNext #-}-------------- Util------------unlessM :: Monad m => m Bool -> m () -> m ()-unlessM mb mx = do-  b <- mb-  if b then pure () else mx  ----------------- -- Array compat

@@ -6,8 +6,6 @@ -- module Regex.Internal.Regex   ( RE(..)-  , Strictness(..)-  , Greediness(..)   , Many(..)    , token@@ -53,6 +51,8 @@ import qualified Data.Foldable as F import qualified Data.Traversable as T +import Regex.Internal.Solo (Solo, mkSolo)+ --------------------------------- -- RE and constructor functions ---------------------------------@@ -90,35 +90,43 @@ -- /Performance tip/: Prefer the smaller of equivalent regexes, i.e. prefer -- @(a \<|> b) \<*> c@ over @(a \<*> c) \<|> (b \<*> c)@. --++-- See Note [Functions returning Solo] data RE c a where   RToken  :: !(c -> Maybe a) -> RE c a-  RFmap   :: !Strictness -> !(a1 -> a) -> !(RE c a1) -> RE c a+  RFmap   :: !(a1 -> Solo a) -> !(RE c a1) -> RE c a   RFmap_  :: a -> !(RE c a1) -> RE c a   RPure   :: a -> RE c a-  RLiftA2 :: !Strictness -> !(a1 -> a2 -> a) -> !(RE c a1) -> !(RE c a2) -> RE c a+  RLiftA2 :: !(a1 -> a2 -> Solo a) -> !(RE c a1) -> !(RE c a2) -> RE c a   REmpty  :: RE c a   RAlt    :: !(RE c a) -> !(RE c a) -> RE c a-  RFold   :: !Strictness -> !Greediness -> !(a -> a1 -> a) -> a -> !(RE c a1) -> RE c a-  RMany   :: !(a1 -> a) -> !(a2 -> a) -> !(a2 -> a1 -> a2) -> !a2 -> !(RE c a1) -> RE c a -- Strict and greedy implicitly--data Strictness = Strict | NonStrict-data Greediness = Greedy | Minimal+  RFoldGr :: !(a -> a1 -> Solo a) -> a -> !(RE c a1) -> RE c a+  RFoldMn :: !(a -> a1 -> Solo a) -> a -> !(RE c a1) -> RE c a+  RMany   :: !(a1 -> Solo a) -> !(a2 -> Solo a) -> !(a2 -> a1 -> Solo a2) -> !a2 -> !(RE c a1) -> RE c a -- Greedy  instance Functor (RE c) where-  fmap = RFmap NonStrict+  fmap f = RFmap (\x -> mkSolo (f x))+  {-# INLINE fmap #-}+   (<$) = RFmap_  fmap' :: (a -> b) -> RE c a -> RE c b-fmap' = RFmap Strict+fmap' f = RFmap (\x -> mkSolo $! f x)+{-# INLINE fmap' #-}  instance Applicative (RE c) where   pure = RPure-  liftA2 = RLiftA2 NonStrict-  re1 *> re2 = Ap.liftA2 (const id) (void re1) re2-  re1 <* re2 = Ap.liftA2 const re1 (void re2) +  liftA2 f = RLiftA2 (\x y -> mkSolo (f x y))+  {-# INLINE liftA2 #-}++  re1 *> re2 = RLiftA2 (\_ y -> mkSolo y) (void re1) re2++  re1 <* re2 = RLiftA2 (\x _ -> mkSolo x) re1 (void re2)+ liftA2' :: (a1 -> a2 -> b) -> RE c a1 -> RE c a2 -> RE c b-liftA2' = RLiftA2 Strict+liftA2' f = RLiftA2 (\x y -> mkSolo $! f x y)+{-# INLINE liftA2' #-}  instance Alternative (RE c) where   empty = REmpty@@ -150,24 +158,33 @@ -- -- Also see the section "Looping parsers". manyr :: RE c a -> RE c (Many a)-manyr = RMany Repeat (Finite . reverse) (flip (:)) []+manyr =+  RMany+    (\xs -> mkSolo (Repeat xs))+    (\xs -> mkSolo (Finite (reverse xs)))+    (\xs x -> mkSolo (x:xs))+    []  -- | Parse many occurences of the given @RE@. Biased towards matching more. -- -- Also see the section "Looping parsers". foldlMany :: (b -> a -> b) -> b -> RE c a -> RE c b-foldlMany = RFold NonStrict Greedy+foldlMany f = RFoldGr (\z x -> mkSolo (f z x))+{-# INLINE foldlMany #-}  foldlMany' :: (b -> a -> b) -> b -> RE c a -> RE c b-foldlMany' f !z = RFold Strict Greedy f z+foldlMany' f !z = RFoldGr (\z' x -> mkSolo $! f z' x) z+{-# INLINE foldlMany' #-}  -- | Parse many occurences of the given @RE@. Minimal, i.e. biased towards -- matching less. foldlManyMin :: (b -> a -> b) -> b -> RE c a -> RE c b-foldlManyMin = RFold NonStrict Minimal+foldlManyMin f = RFoldMn (\z x -> mkSolo (f z x))+{-# INLINE foldlManyMin #-}  foldlManyMin' :: (b -> a -> b) -> b -> RE c a -> RE c b-foldlManyMin' f !z = RFold Strict Minimal f z+foldlManyMin' f !z = RFoldMn (\z' x -> mkSolo $! f z' x) z+{-# INLINE foldlManyMin' #-}  -- | Parse a @c@ if it satisfies the given predicate. satisfy :: (c -> Bool) -> RE c c@@ -362,3 +379,33 @@ toFindMany re =   reverse <$>   foldlMany' (flip ($)) [] ((:) <$> re <|> id <$ anySingle)++----------+-- Notes+----------++-- Note [Functions returning Solo]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We use `-> Solo a` functions in RFmap, RLiftA2, RFold, RMany to get better+-- control of the evaluation and avoid wastefully creating thunks.+--+-- Under normal circumstances, GHC does a good job of avoiding such thunks using+-- demand analysis. However, for a function stored in a RE, there is no way to+-- know its demand characteristics, making such optimizations impossible.+--+-- So, Solo is a way to get some /manual/ control over evaluation. For functions+-- where we want to avoid thunks we use strict combinators, e.g. `liftA2' (:)`,+-- so that forcing the Solo forces the result. Where we don't want to force the+-- result, we use lazy combinators which simply put the thunk in the Solo, e.g.+-- `fmap reverse`.+--+-- On GHC, Solo is implemented as an unboxed 1-tuple at no extra cost. It does+-- have a cost on non-GHC however.+--+-- An alternative is to store the strictness of the function alongside it, as a+-- Bool for instance, and force the result when applying the function if it is+-- strict. In fact, this is how it was originally implemented here. This method+-- adds memory costs to the RE and makes the code a little more complicated. The+-- current setup also might incur a memory cost if an unknown function has to+-- be wrapped in a function which returns Solo. But in practice the function is+-- usually statically known and wrapping function gets simplified.

@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedNewtypes #-}+#endif++-- | This is an internal module. You probably don't need to import this.+--+module Regex.Internal.Solo+  ( Solo+  , mkSolo+  , matchSolo+  ) where++mkSolo :: a -> Solo a+matchSolo :: Solo a -> (a -> b) -> b++#ifdef __GLASGOW_HASKELL__+newtype Solo a = Solo (# a #)+mkSolo x = Solo (# x #)+matchSolo (Solo (# x #)) f = f x+#else+data Solo a = Solo a+mkSolo = Solo+matchSolo (Solo x) f = f x+#endif

@@ -81,10 +81,11 @@ import qualified Data.CharSet as CS import Regex.Internal.Parser (Parser) import qualified Regex.Internal.Parser as P-import Regex.Internal.Regex (RE(..), Greediness(..), Strictness(..))+import Regex.Internal.Regex (RE(..)) import qualified Regex.Internal.Regex as R import qualified Regex.Internal.Num as RNum import qualified Regex.Internal.Generated.CaseFold as CF+import Regex.Internal.Solo (Solo, mkSolo, matchSolo)  ---------------------- -- Token and Text REs@@ -400,17 +401,16 @@     go :: REText b -> REText Text     go re = case re of       RToken t -> tokenMatch t-      RFmap _ _ re1 -> go re1+      RFmap _ re1 -> go re1       RFmap_ _ re1 -> go re1-      RPure _ -> RPure T.empty-      RLiftA2 _ _ re1 re2 ->-        RLiftA2 Strict unsafeAdjacentAppend (go re1) (go re2)-      REmpty -> REmpty-      RAlt re1 re2 -> RAlt (go re1) (go re2)+      RPure _ -> pure T.empty+      RLiftA2 _ re1 re2 -> R.liftA2' unsafeAdjacentAppend (go re1) (go re2)+      REmpty -> Ap.empty+      RAlt re1 re2 -> go re1 <|> go re2+      RFoldGr _ _ re1 -> R.foldlMany' unsafeAdjacentAppend T.empty (go re1)+      RFoldMn _ _ re1 -> R.foldlManyMin' unsafeAdjacentAppend T.empty (go re1)       RMany _ _ _ _ re1 ->-        RFold Strict Greedy unsafeAdjacentAppend T.empty (go re1)-      RFold _ gr _ _ re1 ->-        RFold Strict gr unsafeAdjacentAppend T.empty (go re1)+        R.foldlMany' unsafeAdjacentAppend T.empty (go re1) #else toMatch = fmap (T.pack . map tChar) . RL.toMatch #endif@@ -420,45 +420,36 @@ #ifdef __GLASGOW_HASKELL__ data WithMatch a = WM {-# UNPACK #-} !Text a -instance Functor WithMatch where-  fmap f (WM t x) = WM t (f x)--fmapWM' :: (a -> b) -> WithMatch a -> WithMatch b-fmapWM' f (WM t x) = WM t $! f x+pureWM :: a -> WithMatch a+pureWM x = WM T.empty x -instance Applicative WithMatch where-  pure = WM T.empty-  liftA2 f (WM t1 x) (WM t2 y) = WM (unsafeAdjacentAppend t1 t2) (f x y)+fmapWM :: (a -> Solo b) -> WithMatch a -> WithMatch b+fmapWM f (WM t x) = matchSolo (f x) (WM t) -liftA2WM' :: (a1 -> a2 -> b) -> WithMatch a1 -> WithMatch a2 -> WithMatch b-liftA2WM' f (WM t1 x) (WM t2 y) = WM (unsafeAdjacentAppend t1 t2) $! f x y+liftA2WM :: (a1 -> a2 -> Solo b) -> WithMatch a1 -> WithMatch a2 -> WithMatch b+liftA2WM f (WM t1 x) (WM t2 y) =+  matchSolo (f x y) (WM (unsafeAdjacentAppend t1 t2))  withMatch = R.fmap' (\(WM t x) -> (t,x)) . go   where     go :: REText b -> REText (WithMatch b)     go re = case re of       RToken t -> tokenWithMatch t-      RFmap st f re1 ->-        let g = case st of-              Strict -> fmapWM' f-              NonStrict -> fmap f-        in RFmap Strict g (go re1)-      RFmap_ b re1 -> RFmap Strict (flip WM b) (toMatch re1)-      RPure b -> RPure (pure b)-      RLiftA2 st f re1 re2 ->-        let g = case st of-              Strict -> liftA2WM' f-              NonStrict -> Ap.liftA2 f-        in RLiftA2 Strict g (go re1) (go re2)-      REmpty -> REmpty-      RAlt re1 re2 -> RAlt (go re1) (go re2)+      RFmap f re1 -> R.fmap' (fmapWM f) (go re1)+      RFmap_ b re1 -> R.fmap' (flip WM b) (toMatch re1)+      RPure b -> pure (pureWM b)+      RLiftA2 f re1 re2 -> R.liftA2' (liftA2WM f) (go re1) (go re2)+      REmpty -> Ap.empty+      RAlt re1 re2 ->  go re1 <|> go re2+      RFoldGr f z re1 -> R.foldlMany' (liftA2WM f) (pureWM z) (go re1)+      RFoldMn f z re1 -> R.foldlManyMin' (liftA2WM f) (pureWM z) (go re1)       RMany f1 f2 f z re1 ->-        RMany (fmapWM' f1) (fmapWM' f2) (liftA2WM' f) (pure z) (go re1)-      RFold st gr f z re1 ->-        let g = case st of-              Strict -> liftA2WM' f-              NonStrict -> Ap.liftA2 f-        in RFold Strict gr g (pure z) (go re1)+        RMany+          (\x -> mkSolo $! fmapWM f1 x)+          (\x -> mkSolo $! fmapWM f2 x)+          (\x y -> mkSolo $! liftA2WM f x y)+          (pureWM z)+          (go re1) #else withMatch = fmap (\(toks, x) -> (T.pack (map tChar toks), x)) . RL.withMatch #endif

@@ -1,5 +1,3 @@-{-# OPTIONS_HADDOCK not-home #-}- -- | This is an internal module. You probably don't need to import this. -- -- = WARNING