parser-regex 0.2.0.1 → 0.2.0.2
raw patch · 11 files changed
+393/−194 lines, 11 filesdep ~containersdep ~transformersPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: containers, transformers
API changes (from Hackage documentation)
- Regex.Internal.Debug: instance Data.String.IsString Regex.Internal.Debug.Str
Files
- CHANGELOG.md +6/−0
- parser-regex.cabal +19/−4
- src/Regex/Internal/CharSet.hs +21/−12
- src/Regex/Internal/Debug.hs +46/−49
- src/Regex/Internal/List.hs +8/−7
- src/Regex/Internal/Num.hs +57/−16
- src/Regex/Internal/Parser.hs +57/−30
- src/Regex/Internal/Regex.hs +16/−14
- src/Regex/Internal/Text.hs +115/−20
- src/Regex/Internal/Unique.hs +1/−1
- test/Test.hs +47/−41
CHANGELOG.md view
@@ -1,3 +1,9 @@+### 0.2.0.2 -- 2024-03-15++* Compatibility with [MicroHs](https://github.com/augustss/MicroHs)+* Performance improvements+* Fix `compileBounded`'s behavior on negative bounds+ ### 0.2.0.1 -- 2024-12-25 * Documentation improvements
parser-regex.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: parser-regex-version: 0.2.0.1+version: 0.2.0.2 synopsis: Regex based parsers homepage: https://github.com/meooow25/parser-regex bug-reports: https://github.com/meooow25/parser-regex/issues@@ -63,15 +63,30 @@ build-depends: base >= 4.15 && < 5.0- , containers >= 0.6.4 && < 0.8+ , containers >= 0.6.4 && < 0.9 , deepseq >= 1.4.5 && < 1.6- , ghc-bignum >= 1.1 && < 1.4- , primitive >= 0.7.3 && < 0.10 , text >= 2.0.1 && < 2.2 , transformers >= 0.5.6 && < 0.7 hs-source-dirs: src default-language: Haskell2010++ other-extensions:+ BangPatterns+ CPP+ GADTs+ RankNTypes+ ScopedTypeVariables++ if impl(ghc)+ build-depends:+ ghc-bignum >= 1.1 && < 1.4+ , primitive >= 0.7.3 && < 0.10++ if impl(mhs)+ build-depends:+ containers >= 0.8+ , transformers >= 0.6.1.2 test-suite test import: warnings
src/Regex/Internal/CharSet.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}+#endif {-# OPTIONS_HADDOCK not-home #-} -- | This is an internal module. You probably don't need to import this. Import@@ -35,12 +38,14 @@ import Prelude hiding (not, map) import qualified Prelude-import Data.Char-import Data.String+import Data.Char (ord)+import Data.String (IsString(..)) import qualified Data.Foldable as F import qualified Data.IntMap.Strict as IM import Data.Semigroup (Semigroup(..), stimesIdempotentMonoid)+#ifdef __GLASGOW_HASKELL__ import GHC.Exts (Int(..), Char(..), chr#)+#endif -- TODO: Evaluate other set libraries. -- Possible candidates: charset, rangeset@@ -105,8 +110,8 @@ insertRange (cl,ch) cs | cl > ch = cs insertRange (cl,ch) cs = l `join` fromRange (cl,ch) `join` r where- (l,mr) = split cl cs- (_,r) = split (unsafeChr (ord ch + 1)) mr+ (l,mr) = split (ord cl) cs+ (_,r) = split (ord ch + 1) mr -- | \(O(\min(n,C))\). Delete a @Char@ from a set. delete :: Char -> CharSet -> CharSet@@ -117,8 +122,8 @@ deleteRange (cl,ch) cs | cl > ch = cs deleteRange (cl,ch) cs = l `join` r where- (l,mr) = split cl cs- (_,r) = split (unsafeChr (ord ch + 1)) mr+ (l,mr) = split (ord cl) cs+ (_,r) = split (ord ch + 1) mr -- | \(O(s \min(s,C))\). Map a function over all @Char@s in a set. map :: (Char -> Char) -> CharSet -> CharSet@@ -169,14 +174,14 @@ -------------------- -- | \(O(\min(n,W))\). Split a set into one containing @Char@s smaller than--- the given @Char@ and one greater than or equal to the given @Char@.-split :: Char -> CharSet -> (CharSet, CharSet)-split !c cs = case IM.splitLookup (ord c) (unCharSet cs) of- (l, Just ch, r) -> (CharSet l, CharSet $ IM.insert (ord c) ch r)+-- the given char and one greater than or equal to the given char.+split :: Int -> CharSet -> (CharSet, CharSet)+split !c cs = case IM.splitLookup c (unCharSet cs) of+ (l, Just ch, r) -> (CharSet l, CharSet $ IM.insert c ch r) (l, Nothing, r) -> case IM.maxViewWithKey l of Just ((lgl,lgh),l1)- | lgh >= c -> ( CharSet $ IM.insert lgl (unsafeChr (ord c - 1)) l1- , CharSet $ IM.insert (ord c) lgh r )+ | ord lgh >= c -> ( CharSet $ IM.insert lgl (unsafeChr (c - 1)) l1+ , CharSet $ IM.insert c lgh r ) _ -> (CharSet l, CharSet r) -- The bang on c helps because splitLookup was unfortunately not strict in -- the lookup key until https://github.com/haskell/containers/pull/982.@@ -222,7 +227,11 @@ unsafePred c = unsafeChr (ord c - 1) unsafeChr :: Int -> Char+#ifdef __GLASGOW_HASKELL__ unsafeChr (I# i#) = C# (chr# i#)+#else+unsafeChr = toEnum+#endif ------------ -- Testing
src/Regex/Internal/Debug.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This module provides functions for visualizing @RE@s and @Parser@s.@@ -12,14 +11,14 @@ , dispCharRanges ) where -import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Identity+import Control.Monad ((>=>))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Writer.CPS+ (StateT(..), evalStateT, gets, modify', state)+import Control.Monad.Trans.Writer.CPS (Writer, execWriter, tell) import qualified Data.Foldable as F import Data.Maybe (isJust)-import Data.String import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM @@ -38,34 +37,34 @@ -- displayed. reToDot :: forall c a. Maybe ([c], [c] -> String) -> RE c a -> String reToDot ma re0 = execM $ do- writeLn "digraph RE {"+ writeLn (str "digraph RE {") _ <- go re0- writeLn "}"+ writeLn (str "}") where go :: forall b. RE c b -> M Id go re = case re of RToken t -> new $ labelToken "RToken" t ma RFmap st _ re1 ->- withNew ("RFmap" <+> dispsSt st) $ \i ->+ withNew (str "RFmap" <+> dispsSt st) $ \i -> go re1 >>= writeEdge i RFmap_ _ re1 ->- withNew "RFmap_" $ \i ->+ withNew (str "RFmap_") $ \i -> go re1 >>= writeEdge i- RPure _ -> new "RPure"+ RPure _ -> new (str "RPure") RLiftA2 st _ re1 re2 ->- withNew ("RLiftA2" <+> dispsSt st) $ \i -> do+ withNew (str "RLiftA2" <+> dispsSt st) $ \i -> do go re1 >>= writeEdge i go re2 >>= writeEdge i- REmpty -> new "REmpty"+ REmpty -> new (str "REmpty") RAlt re1 re2 ->- withNew "RAlt" $ \i -> do+ withNew (str "RAlt") $ \i -> do go re1 >>= writeEdge i go re2 >>= writeEdge i RFold st gr _ _ re1 ->- withNew ("RFold" <+> dispsSt st <+> dispsGr gr) $ \i ->+ withNew (str "RFold" <+> dispsSt st <+> dispsGr gr) $ \i -> go re1 >>= writeEdge i RMany _ _ _ _ re1 ->- withNew "RMany" $ \i ->+ withNew (str "RMany") $ \i -> go re1 >>= writeEdge i -----------@@ -78,58 +77,58 @@ -- characters displayed. parserToDot :: forall c a. Maybe ([c], [c] -> String) -> Parser c a -> String parserToDot ma p0 = execM $ do- writeLn "digraph Parser {"+ writeLn (str "digraph Parser {") _ <- go p0- writeLn "}"+ writeLn (str "}") where go :: forall b. Parser c b -> M Id go p = case p of PToken t -> new $ labelToken "PToken" t ma PFmap st _ re1 ->- withNew ("PFmap" <+> dispsSt st) $ \i ->+ withNew (str "PFmap" <+> dispsSt st) $ \i -> go re1 >>= writeEdge i PFmap_ node ->- withNew "PFmap_" $ \i -> do- writeLn $ "subgraph cluster" <> idStr i <> " {"+ withNew (str "PFmap_") $ \i -> do+ writeLn $ str "subgraph cluster" <> idStr i <> str " {" j <- evalStateT (goNode node) IM.empty- writeLn "}"+ writeLn (str "}") writeEdge i j- PPure _ -> new "PPure"+ PPure _ -> new (str "PPure") PLiftA2 st _ re1 re2 ->- withNew ("PLiftA2" <+> dispsSt st) $ \i -> do+ withNew (str "PLiftA2" <+> dispsSt st) $ \i -> do go re1 >>= writeEdge i go re2 >>= writeEdge i- PEmpty -> new "PEmpty"+ PEmpty -> new (str "PEmpty") PAlt _ re1 re2 res ->- withNew "PAlt" $ \i -> do+ withNew (str "PAlt") $ \i -> do go re1 >>= writeEdge i go re2 >>= writeEdge i F.traverse_ (go >=> writeEdge i) res PMany _ _ _ _ _ re1 ->- withNew "PMany" $ \i ->+ withNew (str "PMany") $ \i -> go re1 >>= writeEdge i PFoldGr _ st _ _ re1 ->- withNew ("PFoldGr" <+> dispsSt st) $ \i ->+ withNew (str "PFoldGr" <+> dispsSt st) $ \i -> go re1 >>= writeEdge i PFoldMn _ st _ _ re1 ->- withNew ("PFoldMn" <+> dispsSt st) $ \i ->+ withNew (str "PFoldMn" <+> dispsSt st) $ \i -> go re1 >>= writeEdge i goNode :: forall b. Node c b -> StateT (IntMap Id) M Id goNode n = case n of- NAccept _ -> lift $ new "NAccept"+ NAccept _ -> lift $ new (str "NAccept") NGuard u n1 -> do v <- gets $ IM.lookup (unUnique u) case v of Just i -> pure i- Nothing -> withNewT "NGuard" $ \i -> do+ Nothing -> withNewT (str "NGuard") $ \i -> do modify' $ IM.insert (unUnique u) i goNode n1 >>= lift . writeEdge i NToken t n1 -> withNewT (labelToken "NToken" t ma) $ \i -> goNode n1 >>= lift . writeEdge i- NEmpty -> lift $ new "NEmpty"- NAlt n1 n2 ns -> withNewT "NAlt" $ \i -> do+ NEmpty -> lift $ new (str "NEmpty")+ NAlt n1 n2 ns -> withNewT (str "NAlt") $ \i -> do goNode n1 >>= lift . writeEdge i goNode n2 >>= lift . writeEdge i F.traverse_ (goNode >=> lift . writeEdge i) ns@@ -150,8 +149,8 @@ newtype Str = Str { runStr :: String -> String } -instance IsString Str where- fromString = Str . (++)+str :: String -> Str+str = Str . (++) instance Semigroup Str where s1 <> s2 = Str (runStr s1 . runStr s2)@@ -161,20 +160,18 @@ dispsSt :: Strictness -> Str dispsSt st = case st of- Strict -> "S"- NonStrict -> "NS"+ Strict -> str "S"+ NonStrict -> str "NS" dispsGr :: Greediness -> Str dispsGr gr = case gr of- Greedy -> "G"- Minimal -> "M"+ Greedy -> str "G"+ Minimal -> str "M" labelToken :: String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> Str labelToken node t = maybe- (fromString node)- (\(cs, disp) ->- fromString node <+>- (fromString . escape . disp) (filter (isJust . t) cs))+ (str node)+ (\(cs, disp) -> str node <+> (str . escape . disp) (filter (isJust . t) cs)) escape :: String -> String escape = init . tail' . show@@ -183,15 +180,15 @@ tail' [] = error "tail'" (<+>) :: Str -> Str -> Str-s1 <+> s2 = s1 <> " " <> s2+s1 <+> s2 = s1 <> str " " <> s2 infixr 6 <+> declNode :: Id -> Str -> Str declNode i label = idStr i <+>- "[label=\"" <>+ str "[label=\"" <> label <>- "\", ordering=\"out\"]"+ str "\", ordering=\"out\"]" type M = StateT Int (Writer Str) @@ -201,16 +198,16 @@ newtype Id = Id { unId :: String } idStr :: Id -> Str-idStr = fromString . unId+idStr = str . unId nxt :: M Id nxt = state $ \i -> let !i' = i+1 in (Id (show i), i') writeLn :: Str -> M ()-writeLn = lift . tell . (<> "\n")+writeLn = lift . tell . (<> str "\n") writeEdge :: Id -> Id -> M ()-writeEdge fr to = writeLn $ idStr fr <> " -> " <> idStr to+writeEdge fr to = writeLn $ idStr fr <> str " -> " <> idStr to new :: Str -> M Id new node = do
src/Regex/Internal/List.hs view
@@ -40,10 +40,11 @@ , replaceAll ) where -import Control.Applicative-import Data.Char+import Control.Applicative ((<|>), many, some)+import qualified Control.Applicative as Ap+import Data.Char (ord) import Data.Maybe (fromMaybe)-import Numeric.Natural+import Numeric.Natural (Natural) import Data.CharSet (CharSet) import qualified Data.CharSet as CS@@ -273,7 +274,7 @@ RLiftA2 st f re1 re2 -> let g = case st of Strict -> liftA2WM' f- NonStrict -> liftA2 f+ NonStrict -> Ap.liftA2 f in RLiftA2 Strict g (go re1) (go re2) REmpty -> REmpty RAlt re1 re2 -> RAlt (go re1) (go re2)@@ -282,7 +283,7 @@ RFold st gr f z re1 -> let g = case st of Strict -> liftA2WM' f- NonStrict -> liftA2 f+ NonStrict -> Ap.liftA2 f in RFold Strict gr g (pure z) (go re1) ----------@@ -327,7 +328,7 @@ {-# INLINE parseSure #-} parseSureError :: a-parseSureError = errorWithoutStackTrace+parseSureError = error "Regex.List.parseSure: parse failed; if parsing can fail use 'parse' instead" reParseSure :: RE c a -> [c] -> a@@ -420,7 +421,7 @@ {-# INLINE replace #-} toReplace :: RE c [c] -> RE c [c]-toReplace re = liftA2 f manyListMin re <*> manyList+toReplace re = Ap.liftA2 f manyListMin re <*> manyList where f a b c = concat [a,b,c]
src/Regex/Internal/Num.hs view
@@ -14,13 +14,16 @@ #include "MachDeps.h" -import Control.Applicative-import Control.Monad+import Control.Applicative ((<|>), empty)+import qualified Control.Applicative as Ap+import Control.Monad (replicateM_, void)+import Data.Bits ((.&.), countLeadingZeros, unsafeShiftL, unsafeShiftR)+import Numeric.Natural (Natural)+#ifdef __GLASGOW_HASKELL__ import Data.Primitive.PrimArray-import Data.Bits-import Numeric.Natural--import GHC.Num.Natural as Nat+ (PrimArray(..), newPrimArray, runPrimArray, writePrimArray)+import qualified GHC.Num.Natural as Nat+#endif import Regex.Internal.Regex (RE) import qualified Regex.Internal.Regex as R@@ -30,7 +33,7 @@ -> RE c Natural mkNaturalDec d = 0 <$ d 0 0- <|> liftA2 finishDec (d 1 9) (R.foldlMany' stepDec state0 (d 0 9))+ <|> Ap.liftA2 finishDec (d 1 9) (R.foldlMany' stepDec state0 (d 0 9)) where state0 = NatParseState 0 1 WNil -- Start with len=1, it's reserved for the leading digit@@ -41,7 +44,7 @@ -> RE c Natural mkNaturalHex d = 0 <$ d 0 0- <|> liftA2 finishHex (d 1 15) (R.foldlMany' stepHex state0 (d 0 15))+ <|> Ap.liftA2 finishHex (d 1 15) (R.foldlMany' stepHex state0 (d 0 15)) where state0 = NatParseState 0 1 WNil -- Start with len=1, it's reserved for the leading digit@@ -220,10 +223,14 @@ -- Parsing hexadecimal is simple, there is no base conversion involved. -- -- Step 1: Accumulate the hex digits, packed into Words--- Step 2: Initialize a ByteArray and fill it with the Words------ Because we create a Nat directly, this makes us depend on ghc-bignum and--- GHC>=9.0.+-- Step 2:+-- * GHC: Initialize a ByteArray and fill it with the Words. This takes+-- O(n) time. Because we create a Nat directly, this makes us depend on+-- ghc-bignum and GHC>=9.0.+-- * Not GHC: Do it like we do for decimal, without being aware of the+-- representation of Naturals, but replace the base multiplications with+-- shifts. If it is a binary representation, this takes O(n log n) time+-- instead of O(n^2). stepHex :: NatParseState -> Word -> NatParseState stepHex (NatParseState acc len ns) d@@ -234,6 +241,7 @@ :: Word -- ^ Leading digit -> NatParseState -- ^ Everything else -> Natural+#ifdef __GLASGOW_HASKELL__ finishHex !ld (NatParseState acc0 len0 ns0) = case ns0 of WNil -> Nat.naturalFromWord (ld `unsafeShiftL` (4*(len0-1)) + acc0) WCons n ns1 ->@@ -267,7 +275,38 @@ -- * Natural invariants: -- * If the value fits in a word, it must be NS (via naturalFromWord here). -- * Otherwise, use a ByteArray# with NB. The highest Word must not be 0.+#else+finishHex !ld (NatParseState acc0 len0 ns0) = combine acc0 len0 ns0+ where+ combine !acc !len ns = case ns of+ WNil -> mul16Pow (w2n ld) (len-1) + w2n acc+ WCons n ns1 ->+ mul16Pow (combine1 maxBoundWordHexLen (go n ns1)) len + w2n acc+ where+ go n WNil =+ let !n' = mul16Pow (w2n ld) (maxBoundWordHexLen - 1) + w2n n+ in [n']+ go n (WCons m WNil) =+ let !n' = mul16Pow (w2n ld) (2 * maxBoundWordHexLen - 1) ++ mul16Pow (w2n m) maxBoundWordHexLen ++ w2n n+ in [n']+ go n (WCons m (WCons n1 ns1)) =+ let !n' = mul16Pow (w2n m) maxBoundWordHexLen + w2n n+ in n' : go n1 ns1 + combine1 :: Int -> [Natural] -> Natural+ combine1 !_ [n] = n+ combine1 !numDigs ns1 = combine1 numDigs1 (go ns1)+ where+ numDigs1 = 2 * numDigs+ go (n:m:ns) = let !n' = mul16Pow m numDigs1 + n in n' : go ns+ go ns = ns++ mul16Pow :: Natural -> Int -> Natural+ mul16Pow x p = unsafeShiftL x (4 * p)+#endif+ ----------------------------- -- Parsing decimal Naturals -----------------------------@@ -281,10 +320,11 @@ -- -- The obvious foldl approach is O(n^2) for n digits. The combine approach -- performs O(n/2^i) multiplications of size O(2^i), for i in [0..log_2(n)].--- If multiplication is O(n^k), this is also O(n^k). We have k < 2,--- thanks to subquadratic multiplication of GMP-backed Naturals:--- https://gmplib.org/manual/Multiplication-Algorithms.+-- If multiplication is O(n^k), this is also O(n^k). --+-- On GHC, we have k < 2, thanks to subquadratic multiplication of GMP-backed+-- Naturals: https://gmplib.org/manual/Multiplication-Algorithms.+-- -- For reference, here's how GMP converts any base (including 10) to a natural -- using broadly the same approach. -- https://github.com/alisw/GMP/blob/2bbd52703e5af82509773264bfbd20ff8464804f/mpn/generic/set_str.c@@ -310,6 +350,7 @@ go n (WCons m (WCons n1 ns1)) = let !n' = w2n m * safeBaseDec + w2n n in n' : go n1 ns1 + combine1 :: Natural -> [Natural] -> Natural combine1 _ [n] = n combine1 base ns1 = combine1 base1 (go ns1) where@@ -411,7 +452,7 @@ 18 -> 1000000000000000000 19 -> 10000000000000000000 #endif- _ -> errorWithoutStackTrace "Regex.Internal.Int.pow10: p too large"+ _ -> error "Regex.Internal.Int.pow10: p too large" #else #error "unsupported word size" #endif
src/Regex/Internal/Parser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}@@ -26,13 +27,19 @@ , parseNext ) where -import Control.Applicative+import Control.Applicative ((<|>), empty)+import qualified Control.Applicative as Ap import Control.Monad.Trans.State.Strict-import Control.Monad.Fix+ ( State, StateT, evalState, evalStateT, execState, gets, modify', state)+import Control.Monad.Fix (mfix) import Data.Maybe (isJust)-import Data.Primitive.SmallArray import qualified Data.Foldable as F+import qualified Data.Traversable as T+#ifdef __GLASGOW_HASKELL__+import Data.Primitive.SmallArray+ (SmallArray, emptySmallArray, smallArrayFromList) import qualified GHC.Exts as X+#endif import Regex.Internal.Regex (RE(..), Strictness(..), Greediness(..)) import Regex.Internal.Unique (Unique(..), UniqueSet)@@ -88,14 +95,14 @@ RFmap_ a re1 -> PFmap_ <$> compileToNode a re1 RPure a -> pure $ PPure a RLiftA2 st f re1 re2 ->- liftA2 (PLiftA2 st f) (compileToParser re1) (compileToParser re2)+ Ap.liftA2 (PLiftA2 st f) (compileToParser re1) (compileToParser re2) REmpty -> pure PEmpty RAlt re01 re02 -> do u <- nxtU let (re1,re2,res) = gatherAlts re01 re02 p1 <- compileToParser re1 p2 <- compileToParser re2- ps <- traverse compileToParser res+ ps <- T.traverse compileToParser res pure $ PAlt u p1 p2 (smallArrayFromList ps) RFold st gr f z re1 -> do u <- nxtU@@ -125,7 +132,7 @@ (re1,re2,res) = gatherAlts re01 re02 n1 <- go re1 nxt1 n2 <- go re2 nxt1- ns <- traverse (flip go nxt1) res+ 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@@ -142,10 +149,10 @@ 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 re11:re12:res -> (re11, re12, res)- _ -> errorWithoutStackTrace "Regex.Internal.Parser.gatherAlts: impossible"+ _ -> error "Regex.Internal.Parser.gatherAlts: impossible" where- go (RAlt re1 re2) = go re1 . go re2- go re = (re:)+ go (RAlt re1 re2) acc = go re1 (go re2 acc)+ go re acc = re:acc -------------------- -- Compile bounded@@ -182,10 +189,10 @@ RMany _ _ _ _ re1 -> inc *> go re1 RFold _ _ _ _ re1 -> inc *> go re1 inc = do- n <- get- if n == lim- then empty- else put $! n+1+ ok <- gets (< lim)+ if ok+ then modify' (+1)+ else empty ---------- -- Parse@@ -263,17 +270,19 @@ modify' $ up x ct downNode :: Node c b -> Cont c b a -> StepState c a -> StepState c a-downNode n0 !ct = go n0- where- go n !pt = case n of- NAccept b -> up b ct pt- NGuard u n1- | U.member u (sSet pt) -> pt- | otherwise -> go n1 (pt { sSet = U.insert u (sSet pt) })- NToken t nxt ->- pt { sNeed = NeedCCons t (CFmap_ nxt ct) (sNeed pt) }- NEmpty -> pt- NAlt n1 n2 ns -> F.foldl' (flip go) (go n2 (go n1 pt)) ns+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) })+ NToken t nxt ->+ pt { sNeed = NeedCCons t (CFmap_ nxt ct) (sNeed pt) }+ NEmpty -> pt+ NAlt n1 n2 ns ->+ F.foldl'+ (\pt' n' -> downNode n' ct pt')+ (downNode n2 ct (downNode n1 ct pt))+ ns up :: b -> Cont c b a -> StepState c a -> StepState c a up b ct !pt = case ct of@@ -356,14 +365,14 @@ -- Returns @Nothing@ if parsing has failed regardless of further input. -- Otherwise, returns an updated @ParserState@. stepParser :: ParserState c a -> c -> Maybe (ParserState c a)-stepParser ps c = case psNeed ps of+stepParser ps c0 = case psNeed ps of NeedCNil -> Nothing- needs -> toParserState (go needs)+ needs -> toParserState (go c0 needs) where- go (NeedCCons t ct rest) =- let !pt = go rest+ go c (NeedCCons t ct rest) =+ let !pt = go c rest in maybe pt (\b -> up b ct pt) (t c)- go NeedCNil = stepStateZero+ go _ NeedCNil = stepStateZero {-# INLINE stepParser #-} -- | \(O(1)\). Get the parse result for the input fed into the parser so far.@@ -409,7 +418,11 @@ parseFoldr :: Foldr f c -> Parser c a -> f -> Maybe a parseFoldr fr = \p xs -> prepareParser p >>= fr f finishParser xs where- f c k = X.oneShot (\ !ps -> stepParser ps c >>= k)+ f c k =+#ifdef __GLASGOW_HASKELL__+ X.oneShot+#endif+ (\ !ps -> stepParser ps c >>= k) {-# INLINE parseFoldr #-} -- | \(O(mn \log m)\). Run a parser given a \"@next@\" action.@@ -475,6 +488,20 @@ unlessM mb mx = do b <- mb if b then pure () else mx++-----------------+-- Array compat+-----------------++#ifndef __GLASGOW_HASKELL__+type SmallArray = []++emptySmallArray :: SmallArray a+emptySmallArray = []++smallArrayFromList :: [a] -> SmallArray a+smallArrayFromList = id+#endif ---------- -- Notes
src/Regex/Internal/Regex.hs view
@@ -44,12 +44,14 @@ , foldlManyMin' ) where -import Control.Applicative+import Control.Applicative (Alternative(..))+import qualified Control.Applicative as Ap import Control.DeepSeq (NFData(..), NFData1(..), rnf1)-import Control.Monad+import Control.Monad (void) import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), showsUnaryWith) import Data.Semigroup (Semigroup(..)) import qualified Data.Foldable as F+import qualified Data.Traversable as T --------------------------------- -- RE and constructor functions@@ -95,7 +97,7 @@ RPure :: a -> RE c a RLiftA2 :: !Strictness -> !(a1 -> a2 -> a) -> !(RE c a1) -> !(RE c a2) -> RE c a REmpty :: RE c a- RAlt :: !(RE c a) -> !(RE c a) -> (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 @@ -112,8 +114,8 @@ instance Applicative (RE c) where pure = RPure liftA2 = RLiftA2 NonStrict- re1 *> re2 = liftA2 (const id) (void re1) re2- re1 <* re2 = liftA2 const re1 (void re2)+ re1 *> re2 = Ap.liftA2 (const id) (void re1) re2+ re1 <* re2 = Ap.liftA2 const re1 (void re2) liftA2' :: (a1 -> a2 -> b) -> RE c a1 -> RE c a2 -> RE c b liftA2' = RLiftA2 Strict@@ -126,14 +128,14 @@ -- | @(<>)@ = @liftA2 (<>)@ instance Semigroup a => Semigroup (RE c a) where- (<>) = liftA2 (<>)- sconcat = fmap sconcat . sequenceA+ (<>) = Ap.liftA2 (<>)+ sconcat = fmap sconcat . T.sequenceA {-# INLINE sconcat #-} -- | @mempty@ = @pure mempty@ instance Monoid a => Monoid (RE c a) where mempty = pure mempty- mconcat = fmap mconcat . sequenceA+ mconcat = fmap mconcat . T.sequenceA {-# INLINE mconcat #-} -- Use the underlying type's sconcat/mconcat because it may be more efficient -- than the default right-associative definition.@@ -216,7 +218,7 @@ Repeat x -> Repeat (f x) Finite xs -> Finite (map f xs) -instance Foldable Many where+instance F.Foldable Many where foldr f z m = case m of Repeat x -> let r = f x r in r Finite xs -> foldr f z xs@@ -331,23 +333,23 @@ -- | @r \`sepEndBy1\` sep@ parses one or more occurences of @r@, separated and -- optionally ended by @sep@. Biased towards matching more. sepEndBy1 :: RE c a -> RE c sep -> RE c [a]-sepEndBy1 re sep = sepBy1 re sep <* optional sep+sepEndBy1 re sep = sepBy1 re sep <* Ap.optional sep -- | @chainl1 r op@ parses one or more occurences of @r@, separated by @op@. -- The result is obtained by left associative application of all functions -- returned by @op@ to the values returned by @p@. Biased towards matching more. chainl1 :: RE c a -> RE c (a -> a -> a) -> RE c a-chainl1 re op = liftA2 (flip id) re rest+chainl1 re op = Ap.liftA2 (flip id) re rest where- rest = foldlMany (flip (.)) id (liftA2 flip op re)+ rest = foldlMany (flip (.)) id (Ap.liftA2 flip op re) -- | @chainr1 r op@ parses one or more occurences of @r@, separated by @op@. -- The result is obtained by right associative application of all functions -- returned by @op@ to the values returned by @p@. Biased towards matching more. chainr1 :: RE c a -> RE c (a -> a -> a) -> RE c a-chainr1 re op = liftA2 id rest re+chainr1 re op = Ap.liftA2 id rest re where- rest = foldlMany (.) id (liftA2 (flip id) re op)+ rest = foldlMany (.) id (Ap.liftA2 (flip id) re op) -- | Results in the first occurence of the given @RE@. Fails if no occurence -- is found.
src/Regex/Internal/Text.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} @@ -58,17 +59,23 @@ , replaceAll ) where -import Control.Applicative-import Data.Char+import Control.Applicative ((<|>))+import qualified Control.Applicative as Ap+import Data.Char (ord) import qualified Data.Foldable as F import Data.Maybe (fromMaybe)-import Numeric.Natural+import Numeric.Natural (Natural) import Data.Text (Text) import qualified Data.Text as T+#ifdef __GLASGOW_HASKELL__ import qualified Data.Text.Array as TArray import qualified Data.Text.Internal as TInternal import qualified Data.Text.Unsafe as TUnsafe import qualified Data.Text.Internal.Encoding.Utf8 as TInternalUtf8+#else+import Control.Applicative (many, some)+import qualified Regex.Internal.List as RL+#endif import Data.CharSet (CharSet) import qualified Data.CharSet as CS@@ -85,6 +92,7 @@ -- | The token type used for parsing @Text@. +#ifdef __GLASGOW_HASKELL__ -- This module uses RE TextToken for Text regexes instead of simply RE Char to -- support Text slicing. It does mean that use cases not using slicing pay a -- small cost, but it is not worth having two separate Text regex APIs.@@ -97,6 +105,11 @@ , tOffset :: {-# UNPACK #-} !Int , tChar :: {-# UNPACK #-} !Char }+#else+-- No slicing for non-GHC. This means that there is no performance advantage+-- over Regex.List, but it is still convenient to use when working with Text.+newtype TextToken = TextToken { tChar :: Char }+#endif -- | A type alias for convenience. --@@ -143,7 +156,14 @@ -- | Parse the given @Text@. text :: Text -> REText Text-text t = t <$ T.foldr' ((*>) . char) (pure ()) t+text t =+ t <$+#ifdef __GLASGOW_HASKELL__+ T.foldr'+#else+ T.foldr+#endif+ (\c z -> char c *> z) (pure ()) t -- | Parse the given @Text@, ignoring case. --@@ -152,47 +172,94 @@ -- as described by the Unicode standard. textIgnoreCase :: Text -> REText Text textIgnoreCase t =+#ifdef __GLASGOW_HASKELL__ T.foldr' (\c cs -> R.liftA2' unsafeAdjacentAppend (ignoreCaseTokenMatch c) cs) (pure T.empty) t+#else+ T.pack <$> T.foldr f (pure []) t+ where+ f c z = Ap.liftA2 (:) (satisfy (\c'' -> CF.caseFoldSimple c'' == c')) z+ where+ !c' = CF.caseFoldSimple c+#endif -- See Note [Why simple case fold] -- | Parse any @Text@. Biased towards matching more. manyText :: REText Text-manyText = R.foldlMany' unsafeAdjacentAppend T.empty anyTokenMatch+manyText =+#ifdef __GLASGOW_HASKELL__+ R.foldlMany' unsafeAdjacentAppend T.empty anyTokenMatch+#else+ T.pack <$> many anyChar+#endif -- | Parse any non-empty @Text@. Biased towards matching more. someText :: REText Text-someText = R.liftA2' unsafeAdjacentAppend anyTokenMatch manyText+someText =+#ifdef __GLASGOW_HASKELL__+ R.liftA2' unsafeAdjacentAppend anyTokenMatch manyText+#else+ T.pack <$> some anyChar+#endif -- | Parse any @Text@. Minimal, i.e. biased towards matching less. manyTextMin :: REText Text-manyTextMin = R.foldlManyMin' unsafeAdjacentAppend T.empty anyTokenMatch+manyTextMin =+#ifdef __GLASGOW_HASKELL__+ R.foldlManyMin' unsafeAdjacentAppend T.empty anyTokenMatch+#else+ T.pack <$> R.manyMin anyChar+#endif -- | Parse any non-empty @Text@. Minimal, i.e. biased towards matching less. someTextMin :: REText Text-someTextMin = R.liftA2' unsafeAdjacentAppend anyTokenMatch manyTextMin+someTextMin =+#ifdef __GLASGOW_HASKELL__+ R.liftA2' unsafeAdjacentAppend anyTokenMatch manyTextMin+#else+ T.pack <$> R.someMin anyChar+#endif -- | Parse any @Text@ containing members of the @CharSet@. -- Biased towards matching more. manyTextOf :: CharSet -> REText Text-manyTextOf !cs = R.foldlMany' unsafeAdjacentAppend T.empty (oneOfTokenMatch cs)+manyTextOf !cs =+#ifdef __GLASGOW_HASKELL__+ R.foldlMany' unsafeAdjacentAppend T.empty (oneOfTokenMatch cs)+#else+ T.pack <$> many (satisfy (`CS.member` cs))+#endif -- | Parse any non-empty @Text@ containing members of the @CharSet@. -- Biased towards matching more. someTextOf :: CharSet -> REText Text-someTextOf !cs = R.liftA2' unsafeAdjacentAppend (oneOfTokenMatch cs) (manyTextOf cs)+someTextOf !cs =+#ifdef __GLASGOW_HASKELL__+ R.liftA2' unsafeAdjacentAppend (oneOfTokenMatch cs) (manyTextOf cs)+#else+ T.pack <$> some (satisfy (`CS.member` cs))+#endif -- | Parse any @Text@ containing members of the @CharSet@. -- Minimal, i.e. biased towards matching less. manyTextOfMin :: CharSet -> REText Text-manyTextOfMin !cs = R.foldlManyMin' unsafeAdjacentAppend T.empty (oneOfTokenMatch cs)+manyTextOfMin !cs =+#ifdef __GLASGOW_HASKELL__+ R.foldlManyMin' unsafeAdjacentAppend T.empty (oneOfTokenMatch cs)+#else+ T.pack <$> R.manyMin (satisfy (`CS.member` cs))+#endif -- | Parse any non-empty @Text@ containing members of the @CharSet@. -- Minimal, i.e. biased towards matching less. someTextOfMin :: CharSet -> REText Text someTextOfMin !cs =+#ifdef __GLASGOW_HASKELL__ R.liftA2' unsafeAdjacentAppend (oneOfTokenMatch cs) (manyTextOfMin cs)+#else+ T.pack <$> R.someMin (satisfy (`CS.member` cs))+#endif ----------------- -- Numeric REs@@ -288,9 +355,10 @@ if l <= d && d <= h then Just d else Nothing -- TODO: This can surely be optimized -------------------- Match stuff-----------------+#ifdef __GLASGOW_HASKELL__+--------------------+-- Slicing helpers+-------------------- tokenToSlice :: TextToken -> Text tokenToSlice t =@@ -318,9 +386,15 @@ if CS.member (tChar tok) cs then Just $! tokenToSlice tok else Nothing+#endif +----------------+-- Match stuff+----------------+ -- | Rebuild the @RE@ such that the result is the matched @Text@ instead. toMatch :: REText a -> REText Text+#ifdef __GLASGOW_HASKELL__ toMatch = go where go :: REText b -> REText Text@@ -337,7 +411,13 @@ RFold Strict Greedy unsafeAdjacentAppend T.empty (go re1) RFold _ gr _ _ re1 -> RFold Strict gr unsafeAdjacentAppend T.empty (go re1)+#else+toMatch = fmap (T.pack . map tChar) . RL.toMatch+#endif +-- | Rebuild the @RE@ to include the matched @Text@ alongside the result.+withMatch :: REText a -> REText (Text, a)+#ifdef __GLASGOW_HASKELL__ data WithMatch a = WM {-# UNPACK #-} !Text a instance Functor WithMatch where@@ -353,8 +433,6 @@ 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 --- | Rebuild the @RE@ to include the matched @Text@ alongside the result.-withMatch :: REText a -> REText (Text, a) withMatch = R.fmap' (\(WM t x) -> (t,x)) . go where go :: REText b -> REText (WithMatch b)@@ -370,7 +448,7 @@ RLiftA2 st f re1 re2 -> let g = case st of Strict -> liftA2WM' f- NonStrict -> liftA2 f+ NonStrict -> Ap.liftA2 f in RLiftA2 Strict g (go re1) (go re2) REmpty -> REmpty RAlt re1 re2 -> RAlt (go re1) (go re2)@@ -379,20 +457,27 @@ RFold st gr f z re1 -> let g = case st of Strict -> liftA2WM' f- NonStrict -> liftA2 f+ NonStrict -> Ap.liftA2 f in RFold Strict gr g (pure z) (go re1)+#else+withMatch = fmap (\(toks, x) -> (T.pack (map tChar toks), x)) . RL.withMatch+#endif ---------- -- Parse ---------- textTokenFoldr :: (TextToken -> b -> b) -> b -> Text -> b+#ifdef __GLASGOW_HASKELL__ textTokenFoldr f z (TInternal.Text a o0 l) = loop o0 where loop o | o - o0 >= l = z loop o = case TUnsafe.iterArray a o of TUnsafe.Iter c clen -> f (TextToken a o c) (loop (o + clen)) {-# INLINE textTokenFoldr #-}+#else+textTokenFoldr f = T.foldr (f . TextToken)+#endif -- | \(O(mn \log m)\). Parse a @Text@ with a @REText@. --@@ -427,7 +512,7 @@ parseSure p = fromMaybe parseSureError . parse p parseSureError :: a-parseSureError = errorWithoutStackTrace+parseSureError = error "Regex.Text.parseSure: parse failed; if parsing can fail use 'parse' instead" reParseSure :: REText a -> Text -> a@@ -521,9 +606,13 @@ {-# INLINE replace #-} toReplace :: REText Text -> REText Text-toReplace re = liftA2 f manyTextMin re <*> manyText+toReplace re = Ap.liftA2 f manyTextMin re <*> manyText where+#ifdef __GLASGOW_HASKELL__ f a b c = reverseConcat [c,b,a]+#else+ f a b c = T.concat [a,b,c]+#endif -- | \(O(mn \log m)\). Replace all non-overlapping matches of the given @RE@ -- with their results.@@ -555,8 +644,13 @@ toReplaceMany :: REText Text -> REText Text toReplaceMany re =+#ifdef __GLASGOW_HASKELL__ reverseConcat <$> R.foldlMany' (flip (:)) [] (re <|> anyTokenMatch)+#else+ T.concat <$> many (re <|> T.singleton <$> anyChar)+#endif +#ifdef __GLASGOW_HASKELL__ ------------------------- -- Low level Text stuff -------------------------@@ -593,6 +687,7 @@ reverseConcatOverflowError :: a reverseConcatOverflowError = errorWithoutStackTrace "Regex.Text.reverseConcat: size overflow"+#endif ---------- -- Notes
src/Regex/Internal/Unique.hs view
@@ -15,7 +15,7 @@ , insert ) where -import Data.Bits+import Data.Bits ((.|.), (.&.), unsafeShiftL, finiteBitSize) import qualified Data.IntSet as IS -- | A unique ID. Must be >= 0.
test/Test.hs view
@@ -3,25 +3,27 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Arbitrary instances -import Control.Applicative-import Control.Monad-import Data.Char+import Control.Applicative (Alternative(..))+import qualified Control.Applicative as Ap+import Control.Monad (guard, void)+import Data.Char (isDigit, isHexDigit) import qualified Data.List as L import Data.Maybe (isJust, isNothing) import Data.List.NonEmpty (NonEmpty(..))-import Data.Proxy-import Data.Semigroup-import Data.String+import Data.Proxy (Proxy(..))+import Data.Semigroup (Semigroup(..))+import Data.String (fromString) import qualified Numeric as Num-import Numeric.Natural+import Numeric.Natural (Natural) import Data.Text (Text) import qualified Data.Text as T -import Test.Tasty-import Test.Tasty.HUnit+import Test.Tasty (TestTree, defaultMain, localOption, testGroup)+import Test.Tasty.HUnit ((@?=), testCase, assertBool, assertFailure) import Test.Tasty.QuickCheck-import Test.QuickCheck.Classes.Base-import Test.QuickCheck.Poly+import Test.QuickCheck.Classes.Base (Laws(..))+import qualified Test.QuickCheck.Classes.Base as Laws+import Test.QuickCheck.Poly (A, OrdA) import qualified Data.CharSet as CS import qualified Regex.Base as R@@ -65,7 +67,7 @@ , testGroup "charIgnoreCase" $ let f c1 c2 = testPM ([c1] <> ", " <> [c2] <> ", ok") (RT.charIgnoreCase c1) (T.singleton c2) (Just c2)- in ["aA", "DZDzdz", "θϴϑΘ"] >>= \cs -> liftA2 f cs cs+ in ["aA", "DZDzdz", "θϴϑΘ"] >>= \cs -> Ap.liftA2 f cs cs , testGroup "anyChar" [ testProperty "random" $ \c -> RT.reParse RT.anyChar (T.singleton c) === Just c@@ -114,7 +116,7 @@ ] , testGroup "many some Text bias" $ let f (name,re1,re2,g) = testProperty name $ \t ->- RT.reParse (liftA2 (,) re1 re2) t === g t+ RT.reParse (Ap.liftA2 (,) re1 re2) t === g t in map f [ ("manyText manyText", RT.manyText, RT.manyText, \t -> Just (t,"")) , ("manyText someText", RT.manyText, RT.someText, \t ->@@ -197,7 +199,7 @@ , testGroup "charIgnoreCase" $ let f c1 c2 = testLPM ([c1] <> ", " <> [c2] <> ", ok") (RL.charIgnoreCase c1) [c2] (Just c2)- in ["aA", "DZDzdz", "θϴϑΘ"] >>= \cs -> liftA2 f cs cs+ in ["aA", "DZDzdz", "θϴϑΘ"] >>= \cs -> Ap.liftA2 f cs cs , testGroup "anyChar" [ testProperty "random" $ \c -> RL.reParse @Char RL.anySingle [c] === Just c@@ -246,7 +248,7 @@ ] , testGroup "many some Text bias" $ let f (name,re1,re2,g) = testProperty name $ \t ->- RL.reParse (liftA2 (,) re1 re2) t === g t+ RL.reParse (Ap.liftA2 (,) re1 re2) t === g t in map f [ ("manyList manyList", RL.manyList, RL.manyList, \t -> Just (t,"")) , ("manyList someList", RL.manyList, RL.someList, \t ->@@ -357,7 +359,7 @@ , testPM "lz, +001, ok" (RT.integerDec (many (RT.char '0'))) "+001" (Just 1) , testPM "lz, -001, ok" (RT.integerDec (many (RT.char '0'))) "-001" (Just (-1)) , testProperty "random" $- forAll (liftA2 (<>) (elements ["-","+",""]) abDecText) $ \t ->+ forAll (Ap.liftA2 (<>) (elements ["-","+",""]) abDecText) $ \t -> let ex = parseInteger parseDecNoLz (T.unpack t) in classify (isJust ex) "ok" $ RT.reParse (RT.integerDec (pure ())) t === ex@@ -399,7 +401,7 @@ , testPM "lz, +001, ok" (RT.integerHex (many (RT.char '0'))) "+001" (Just 1) , testPM "lz, -001, ok" (RT.integerHex (many (RT.char '0'))) "-001" (Just (-1)) , testProperty "random" $- forAll (liftA2 (<>) (elements ["-","+",""]) pqHexText) $ \t ->+ forAll (Ap.liftA2 (<>) (elements ["-","+",""]) pqHexText) $ \t -> let ex = parseInteger parseHexNoLz (T.unpack t) in classify (isJust ex) "ok" $ RT.reParse (RT.integerHex (pure ())) t === ex@@ -430,9 +432,9 @@ Nothing , testGroup "bias" [ let re = RT.wordRangeDec (1,999) in- testPM "(1,999) 2222 (222,2)" (liftA2 (,) re re) "2222" (Just (222,2))+ testPM "(1,999) 2222 (222,2)" (Ap.liftA2 (,) re re) "2222" (Just (222,2)) , let re = RT.wordRangeDec (1,1000) in- testPM "(1,1000) 1111, (111,1)" (liftA2 (,) re re) "1111" (Just (111,1))+ testPM "(1,1000) 1111, (111,1)" (Ap.liftA2 (,) re re) "1111" (Just (111,1)) ] , testProperty "any word" $ \(Large n) -> RT.reParse (RT.wordRangeDec (minBound,maxBound)) (T.pack (show n)) ===@@ -506,7 +508,7 @@ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n ] , testProperty "random" $ \low high ->- forAll (liftA2 (<>) (elements ["-","+",""]) abDecText) $ \t ->+ forAll (Ap.liftA2 (<>) (elements ["-","+",""]) abDecText) $ \t -> let ex = do x <- parseInteger parseDecNoLz (T.unpack t) guard $ fromIntegral low <= x && x <= fromIntegral high@@ -540,9 +542,9 @@ Nothing , testGroup "bias" [ let re = RT.wordRangeHex (0x1,0x999) in- testPM "(1,999) 2222 (222,2)" (liftA2 (,) re re) "2222" (Just (0x222,0x2))+ testPM "(1,999) 2222 (222,2)" (Ap.liftA2 (,) re re) "2222" (Just (0x222,0x2)) , let re = RT.wordRangeHex (0x1,0x1000) in- testPM "(1,1000) 1111, (111,1)" (liftA2 (,) re re) "1111" (Just (0x111,0x1))+ testPM "(1,1000) 1111, (111,1)" (Ap.liftA2 (,) re re) "1111" (Just (0x111,0x1)) ] , testProperty "any word" $ \(Large n) -> RT.reParse (RT.wordRangeHex (minBound,maxBound)) (T.pack (showHex n)) ===@@ -616,7 +618,7 @@ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n ] , testProperty "random" $ \low high ->- forAll (liftA2 (<>) (elements ["-","+",""]) pqHexText) $ \t ->+ forAll (Ap.liftA2 (<>) (elements ["-","+",""]) pqHexText) $ \t -> let ex = do x <- parseInteger parseHexNoLz (T.unpack t) guard $ fromIntegral low <= x && x <= fromIntegral high@@ -726,7 +728,7 @@ , testLPM "lz, +001, ok" (RL.integerDec (many (RL.single '0'))) "+001" (Just 1) , testLPM "lz, -001, ok" (RL.integerDec (many (RL.single '0'))) "-001" (Just (-1)) , testProperty "random" $- forAll (liftA2 (<>) (elements ["-","+",""]) abDecString) $ \t ->+ forAll (Ap.liftA2 (<>) (elements ["-","+",""]) abDecString) $ \t -> let ex = parseInteger parseDecNoLz t in classify (isJust ex) "ok" $ RL.reParse (RL.integerDec (pure ())) t === ex@@ -768,7 +770,7 @@ , testLPM "lz, +001, ok" (RL.integerHex (many (RL.single '0'))) "+001" (Just 1) , testLPM "lz, -001, ok" (RL.integerHex (many (RL.single '0'))) "-001" (Just (-1)) , testProperty "random" $- forAll (liftA2 (<>) (elements ["-","+",""]) pqHexString) $ \t ->+ forAll (Ap.liftA2 (<>) (elements ["-","+",""]) pqHexString) $ \t -> let ex = parseInteger parseHexNoLz t in classify (isJust ex) "ok" $ RL.reParse (RL.integerHex (pure ())) t === ex@@ -799,9 +801,9 @@ Nothing , testGroup "bias" [ let re = RL.wordRangeDec (1,999) in- testLPM "(1,999) 2222 (222,2)" (liftA2 (,) re re) "2222" (Just (222,2))+ testLPM "(1,999) 2222 (222,2)" (Ap.liftA2 (,) re re) "2222" (Just (222,2)) , let re = RL.wordRangeDec (1,1000) in- testLPM "(1,1000) 1111, (111,1)" (liftA2 (,) re re) "1111" (Just (111,1))+ testLPM "(1,1000) 1111, (111,1)" (Ap.liftA2 (,) re re) "1111" (Just (111,1)) ] , testProperty "any word" $ \(Large n) -> RL.reParse (RL.wordRangeDec (minBound,maxBound)) (show n) ===@@ -875,7 +877,7 @@ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n ] , testProperty "random" $ \low high ->- forAll (liftA2 (<>) (elements ["-","+",""]) abDecString) $ \t ->+ forAll (Ap.liftA2 (<>) (elements ["-","+",""]) abDecString) $ \t -> let ex = do x <- parseInteger parseDecNoLz t guard $ fromIntegral low <= x && x <= fromIntegral high@@ -909,9 +911,9 @@ Nothing , testGroup "bias" [ let re = RL.wordRangeHex (0x1,0x999) in- testLPM "(1,999) 2222 (222,2)" (liftA2 (,) re re) "2222" (Just (0x222,0x2))+ testLPM "(1,999) 2222 (222,2)" (Ap.liftA2 (,) re re) "2222" (Just (0x222,0x2)) , let re = RL.wordRangeHex (0x1,0x1000) in- testLPM "(1,1000) 1111, (111,1)" (liftA2 (,) re re) "1111" (Just (0x111,0x1))+ testLPM "(1,1000) 1111, (111,1)" (Ap.liftA2 (,) re re) "1111" (Just (0x111,0x1)) ] , testProperty "any word" $ \(Large n) -> RL.reParse (RL.wordRangeHex (minBound,maxBound)) (showHex n) ===@@ -985,7 +987,7 @@ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n ] , testProperty "random" $ \low high ->- forAll (liftA2 (<>) (elements ["-","+",""]) pqHexString) $ \t ->+ forAll (Ap.liftA2 (<>) (elements ["-","+",""]) pqHexString) $ \t -> let ex = do x <- parseInteger parseHexNoLz t guard $ fromIntegral low <= x && x <= fromIntegral high@@ -1147,7 +1149,7 @@ , testPM "pure (), a, fail" (pure ()) "a" Nothing ] , testGroup "liftA2" $- let re = liftA2 (,) (RT.char 'a') (RT.char 'b') in+ let re = Ap.liftA2 (,) (RT.char 'a') (RT.char 'b') in [ testPM "a b, <e>, fail" re "" Nothing , testPM "a b, a, fail" re "a" Nothing , testPM "a b, b, fail" re "b" Nothing@@ -1434,6 +1436,10 @@ assertBool "isJust" $ isJust (R.compileBounded 15 mixRE) , testCase "mixRE 14" $ assertBool "isNothing" $ isNothing (R.compileBounded 14 mixRE)+ , testCase "mixRE 0" $+ assertBool "isNothing" $ isNothing (R.compileBounded 0 mixRE)+ , testCase "mixRE -1" $+ assertBool "isNothing" $ isNothing (R.compileBounded (-1) mixRE) ] ] -- the exact size may change in the future, just test that there is _some_@@ -1444,7 +1450,7 @@ (() <$) . R.manyr . many .- (\r -> liftA2 (\_ _ -> ()) r r) .+ (\r -> Ap.liftA2 (\_ _ -> ()) r r) . (\r -> r <|> r) . fmap (const ()) $ R.token (const (Just ()))@@ -1617,9 +1623,9 @@ manyTests :: TestTree manyTests = testGroup "Many" $ map testLaws- [ eqLaws (Proxy :: Proxy (RT.Many A))- , ordLaws (Proxy :: Proxy (RT.Many OrdA))- , functorLaws (Proxy :: Proxy RT.Many)+ [ Laws.eqLaws (Proxy :: Proxy (RT.Many A))+ , Laws.ordLaws (Proxy :: Proxy (RT.Many OrdA))+ , Laws.functorLaws (Proxy :: Proxy RT.Many) ] -- Cannot use foldableLaws because it cannot handle infinite structures. @@ -1631,11 +1637,11 @@ charSetTests = localOption (QuickCheckTests 1000) $ testGroup "CharSet" [ testGroup "Laws" $ map testLaws $ let p = Proxy :: Proxy CS.CharSet in- [ eqLaws p- , semigroupLaws p- , commutativeSemigroupLaws p- , idempotentSemigroupLaws p- , monoidLaws p+ [ Laws.eqLaws p+ , Laws.semigroupLaws p+ , Laws.commutativeSemigroupLaws p+ , Laws.idempotentSemigroupLaws p+ , Laws.monoidLaws p ] , testGroup "fromList" [ testProperty "valid" $ \s -> validCS (CS.fromList s)