parser-regex (empty) → 0.1.0.0
raw patch · 19 files changed
+6808/−0 lines, 19 filesdep +QuickCheckdep +basedep +bytestring
Dependencies added: QuickCheck, base, bytestring, containers, deepseq, ghc-bignum, parser-regex, primitive, quickcheck-classes-base, tasty, tasty-hunit, tasty-quickcheck, text, transformers
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- README.md +105/−0
- parser-regex.cabal +84/−0
- src/Data/CharSet.hs +67/−0
- src/Regex/Base.hs +94/−0
- src/Regex/Internal/CharSet.hs +226/−0
- src/Regex/Internal/CharSets.hs +47/−0
- src/Regex/Internal/Debug.hs +217/−0
- src/Regex/Internal/Generated/CaseFold.hs +1472/−0
- src/Regex/Internal/List.hs +493/−0
- src/Regex/Internal/Num.hs +419/−0
- src/Regex/Internal/Parser.hs +453/−0
- src/Regex/Internal/Regex.hs +357/−0
- src/Regex/Internal/Text.hs +602/−0
- src/Regex/Internal/Unique.hs +31/−0
- src/Regex/List.hs +210/−0
- src/Regex/Text.hs +213/−0
- test/Test.hs +1685/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+### 0.1.0.0 -- 2024-03-04++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2024, Soumik Sarkar++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of meooow25 nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,105 @@+# parser-regex++[](https://hackage.haskell.org/package/parser-regex)+[](https://github.com/meooow25/parser-regex/actions/workflows/haskell-ci.yml)++Regex based parsers++## Features++* Parsers based on [regular expressions](https://en.wikipedia.org/wiki/Regular_expression),+ capable of parsing [regular languages](https://en.wikipedia.org/wiki/Regular_language).+ There are no extra features that would make parsing non-regular languages+ possible.+* Regexes are composed using combinators.+* Resumable parsing of sequences of any type containing values of any type.+* Special support for `Text` and `String` in the form of convenient combinators+ and operations like find and replace.+* Parsing runtime is linear in the length of the sequence being parsed. No+ exponential backtracking.++## Example++```hs+{-# LANGUAGE OverloadedStrings #-}+import Control.Applicative (optional)+import Data.Text (Text)++import Regex.Text (REText)+import qualified Regex.Text as R+import qualified Data.CharSet as CS++data URI = URI+ { scheme :: Maybe Text+ , authority :: Maybe Text+ , path :: Text+ , query :: Maybe Text+ , fragment :: Maybe Text+ } deriving Show++-- ^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?+-- A non-validating regex to extract parts of a URI, from RFC 3986+-- Translated:+uriRE :: REText URI+uriRE = URI+ <$> optional (R.someTextOf (CS.not ":/?#") <* R.char ':')+ <*> optional (R.text "//" *> R.manyTextOf (CS.not "/?#"))+ <*> R.manyTextOf (CS.not "?#")+ <*> optional (R.char '?' *> R.manyTextOf (CS.not "#"))+ <*> optional (R.char '#' *> R.manyText)+```+```hs+>>> R.reParse uriRE "https://github.com/meooow25/parser-regex?tab=readme-ov-file#parser-regex"+Just (URI { scheme = Just "https"+ , authority = Just "github.com"+ , path = "/meooow25/parser-regex"+ , query = Just "tab=readme-ov-file"+ , fragment = Just "parser-regex" })+```++## Documentation++Please find the documentation on Hackage:+[parser-regex](https://hackage.haskell.org/package/parser-regex)++Already familiar with regex patterns? See the+[Regex pattern cheat sheet](https://github.com/meooow25/parser-regex/wiki/Regex-pattern-cheat-sheet).++## Alternatives++### `regex-applicative`++[`regex-applicative`](https://hackage.haskell.org/package/regex-applicative) is+the primary inspiration for this library, and provides a similar set of+features.+`parser-regex` attempts to be a more fully-featured library built on the+ideas of `regex-applicative`.++### Traditional regex libraries++Other alternatives are more traditional regex libraries that use regex patterns,+like [`regex-tdfa`](https://hackage.haskell.org/package/regex-tdfa) and+[`regex-pcre`](https://hackage.haskell.org/package/regex-pcre)/+[`regex-pcre-builtin`](https://hackage.haskell.org/package/regex-pcre-builtin).++Reasons to use `parser-regex` over traditional regex libraries:++* You prefer parser combinators over regex patterns+* You need more powerful parsing capabilities than just submatch extraction+* You need to parse a sequence type that is not supported by these regex+ libraries++Reasons to use traditional regex libraries over `parser-regex`:++* The terseness of regex patterns is better suited for your use case+* You need something very fast, and adversarial input is not a concern.+ Use `regex-pcre`/`regex-pcre-builtin`.++For a more detailed comparison of regex libraries, see+[here](https://github.com/meooow25/parser-regex/tree/master/bench).++## Contributing++Questions, bug reports, documentation improvements, code contributions welcome!+Please [open an issue](https://github.com/meooow25/parser-regex/issues) as the+first step.
+ parser-regex.cabal view
@@ -0,0 +1,84 @@+cabal-version: 2.4+name: parser-regex+version: 0.1.0.0+synopsis: Regex based parsers+description: Regex based parsers.+homepage: https://github.com/meooow25/parser-regex+bug-reports: https://github.com/meooow25/parser-regex/issues+license: BSD-3-Clause+license-file: LICENSE+author: Soumik Sarkar+maintainer: soumiksarkar.3120@gmail.com+category: Parsing+build-type: Simple+extra-doc-files:+ README.md+ CHANGELOG.md++tested-with:+ GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.4+ , GHC == 9.8.1++source-repository head+ type: git+ location: https://github.com/meooow25/parser-regex.git++common warnings+ ghc-options: -Wall++library+ import: warnings++ exposed-modules:+ Data.CharSet+ Regex.Base+ Regex.List+ Regex.Text++ other-modules:+ Regex.Internal.CharSet+ Regex.Internal.CharSets+ Regex.Internal.Debug+ Regex.Internal.Generated.CaseFold+ Regex.Internal.List+ Regex.Internal.Num+ Regex.Internal.Parser+ Regex.Internal.Regex+ Regex.Internal.Text+ Regex.Internal.Unique++ build-depends:+ base >= 4.15 && < 5.0+ , bytestring >= 0.10.12 && < 0.13+ , containers >= 0.6.4 && < 0.8+ , 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++test-suite test+ import: warnings++ build-depends:+ base+ , bytestring+ , containers+ , parser-regex+ , QuickCheck >= 2.14.3 && < 2.15+ , quickcheck-classes-base >= 0.6.2 && < 0.7+ , tasty >= 1.5 && < 1.6+ , tasty-hunit >= 0.10.1 && < 0.11+ , tasty-quickcheck >= 0.10.3 && < 0.11+ , text++ hs-source-dirs: test+ main-is: Test.hs+ default-language: Haskell2010+ type: exitcode-stdio-1.0
+ src/Data/CharSet.hs view
@@ -0,0 +1,67 @@+-- |+-- It is recommended to import this module qualified to avoid name conflicts+-- with functions from the Prelude.+--+-- Enabling [@OverloadedStrings@](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/overloaded_strings.html)+-- will allow declaring @CharSet@s using string literal syntax.+--+-- @+-- {-# LANGUAGE OverloadedStrings #-}+--+-- import qualified Data.CharSet as CS+-- +-- vowels :: CS.CharSet+-- vowels = "aeiou"+-- @+--+module Data.CharSet+ (+ -- * The @CharSet@ type+ CS.CharSet++ -- * @CharSet@ operations+ -- $ops+ , CS.singleton+ , CS.fromRange+ , CS.fromList+ , CS.fromRanges+ , CS.insert+ , CS.insertRange+ , CS.delete+ , CS.deleteRange+ , CS.map+ , CS.not+ , CS.union+ , CS.difference+ , CS.intersection+ , CS.member+ , CS.notMember+ , CS.elems+ , CS.ranges++ -- * Available @CharSet@s+ , CS.empty+ , CSets.digit+ , CSets.word+ , CSets.space+ , CSets.ascii+ , CSets.asciiAlpha+ , CSets.asciiUpper+ , CSets.asciiLower++ -- * Testing+ , CS.valid+ ) where++import qualified Regex.Internal.CharSet as CS+import qualified Regex.Internal.CharSets as CSets++-- $ops+--+-- Variables used:+--+-- * \(n\): the number of @Char@ ranges+-- * \(s\): the number of @Char@s+-- * \(C\): the maximum bits in a @Char@, i.e. 21+-- * \(n\), \(m\): the number of @Char@ ranges in the first and second sets+-- respectively, for functions taking two sets
+ src/Regex/Base.hs view
@@ -0,0 +1,94 @@+-- | This module exports base types and functions. You can use these to define+-- functions to work on arbitrary sequence types. If you want to work with+-- @Text@ or @String@, import and use "Regex.Text" or "Regex.List" instead.+module Regex.Base+ (+ -- * @RE@ and @Parser@+ R.RE+ , P.Parser++ -- * Compile+ , P.compile+ , P.compileBounded++ -- * Parse+ -- $parse+ , P.ParserState+ , P.prepareParser+ , P.stepParser+ , P.finishParser+ , P.Foldr+ , P.parseFoldr++ -- * @RE@s and combinators+ , R.token+ , R.anySingle+ , R.single+ , R.satisfy+ , R.foldlMany+ , R.foldlManyMin+ , R.Many(..)+ , R.manyr+ , R.optionalMin+ , R.someMin+ , R.manyMin+ , R.atLeast+ , R.atMost+ , R.betweenCount+ , R.atLeastMin+ , R.atMostMin+ , R.betweenCountMin+ , R.sepBy+ , R.sepBy1+ , R.endBy+ , R.endBy1+ , R.sepEndBy+ , R.sepEndBy1+ , R.chainl1+ , R.chainr1+ , R.toFind+ , R.toFindMany++ -- * Strict combinators+ -- $strict++ , R.fmap'+ , R.liftA2'+ , R.foldlMany'+ , R.foldlManyMin'+ ) where++import qualified Regex.Internal.Regex as R+import qualified Regex.Internal.Parser as P++-- $parse+--+-- The functions @prepareParser@, @stepParser@, and @finishParser@ grant+-- a large amount of control over the parsing process, making it possible to+-- parse in a resumable or even branching manner.+--+-- As a simpler alternative to the trio of functions above, @parseFoldr@ can be+-- used on any sequence type that can be folded over.+--++-- $strict+--+-- These combinators force the result before continuing parsing. But beware!+-- If that particular parse ends up failing, the work done will have been for+-- nothing. This can blow up the complexity of parsing. For instance,+-- @fmap' sum (many digit)@ is \(O(n^2)\).+--+-- These functions are intended to be used when the work done in forcing the+-- result is guaranteed to be cheaper than creating a thunk, saving memory and+-- time.+-- For instance, @liftA2' (:)@ is a good usage, since @(:)@ does a small amount+-- of work and a thunk is avoided. As another example, @liftA2' ((+) \@Int)@ is+-- /not/ a good usage, because @(+)@ is strict and forces its arguments,+-- performing an arbitrary amount of work. However, it is okay to use+-- @liftA2' ((+) \@Int)@ if it is known for certain that its arguments will be+-- in WHNF.+--+-- __WARNING__: If you are not sure whether to use these function,+-- /don't use these functions/. Simply use @fmap@, @liftA2@, @foldlMany@ or+-- @foldlManyMin@ instead.+--
+ src/Regex/Internal/CharSet.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+module Regex.Internal.CharSet+ ( CharSet+ , empty+ , singleton+ , fromRange+ , fromList+ , fromRanges+ , insert+ , insertRange+ , delete+ , deleteRange+ , map+ , not+ , union+ , difference+ , intersection+ , member+ , notMember+ , elems+ , ranges+ , valid+ ) where++import Prelude hiding (not, map)+import qualified Prelude+import Data.Char+import Data.String+import Data.Foldable (foldl')+import qualified Data.IntMap.Strict as IM+import Data.Semigroup (Semigroup(..), stimesIdempotentMonoid)+import GHC.Exts (Int(..), Char(..), chr#)++-- TODO: Evaluate other set libraries.+-- Possible candidates: charset, rangeset++-- | A set of @Char@s.+--+-- The members are stored as contiguous ranges of @Char@s. This is efficient+-- when the members form contiguous ranges since many @Char@s can be represented+-- with just one range.+newtype CharSet = CharSet { unCharSet :: IM.IntMap Char } deriving Eq++instance Show CharSet where+ showsPrec p cs = showParen (p > 10) $+ showString "fromRanges " . shows (ranges cs)++-- | @fromString = 'fromList'@+instance IsString CharSet where+ fromString = fromList++-- | @(<>) = 'union'@+instance Semigroup CharSet where+ (<>) = union+ sconcat = foldl' union empty+ {-# INLINE sconcat #-}+ stimes = stimesIdempotentMonoid++-- | @mempty = 'empty'@+instance Monoid CharSet where+ mempty = empty+ mconcat = foldl' union empty+ {-# INLINE mconcat #-}++-- | The empty set.+empty :: CharSet+empty = CharSet IM.empty++-- | \(O(1)\). A set of one @Char@.+singleton :: Char -> CharSet+singleton c = CharSet (IM.singleton (ord c) c)++-- | \(O(1)\). A @Char@ range (inclusive).+fromRange :: (Char, Char) -> CharSet+fromRange (cl,ch) | cl > ch = empty+fromRange (cl,ch) = CharSet (IM.singleton (ord cl) ch)++-- | \(O(s \min(s,C))\). Create a set from @Char@s in a list.+fromList :: [Char] -> CharSet+fromList = foldl' (flip insert) empty+{-# INLINE fromList #-}++-- | \(O(n \min(n,C))\). Create a set from the given @Char@ ranges (inclusive).+fromRanges :: [(Char, Char)] -> CharSet+fromRanges = foldl' (flip insertRange) empty+{-# INLINE fromRanges #-}++-- | \(O(\min(n,C))\). Insert a @Char@ into a set.+insert :: Char -> CharSet -> CharSet+insert c = insertRange (c,c)++-- | \(O(\min(n,C))\). Insert all @Char@s in a range (inclusive) into a set.+insertRange :: (Char, Char) -> CharSet -> CharSet+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++-- | \(O(\min(n,C))\). Delete a @Char@ from a set.+delete :: Char -> CharSet -> CharSet+delete c = deleteRange (c,c)++-- | \(O(\min(n,C))\). Delete a @Char@ range (inclusive) from a set.+deleteRange :: (Char, Char) -> CharSet -> CharSet+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++-- | \(O(s \min(s,C))\). Map a function over all @Char@s in a set.+map :: (Char -> Char) -> CharSet -> CharSet+map f = fromList . fmap f . elems++-- | \(O(n)\). The complement of a set.+not :: CharSet -> CharSet+not = CharSet . IM.fromDistinctAscList . complementRanges . ranges+-- TODO: Would be nice to have O(1) complement++-- | \(O(m \min(n+m,C))\). The union of two sets.+--+-- Prefer strict left-associative unions, since this is a strict structure and+-- the runtime is linear in the size of the second argument.+union :: CharSet -> CharSet -> CharSet+union = foldlRanges' (\cs cl ch -> insertRange (cl,ch) cs)++-- | \(O(m \min(n+m,C))\). The difference of two sets.+difference :: CharSet -> CharSet -> CharSet+difference = foldlRanges' (\cs cl ch -> deleteRange (cl,ch) cs)++-- | \(O(n + m \min(n+m,C))\). The intersection of two sets.+intersection :: CharSet -> CharSet -> CharSet+intersection lcs rcs = not (not lcs `union` not rcs)++-- | \(O(\min(n,C))\). Whether a @Char@ is in a set.+member :: Char -> CharSet -> Bool+member c cs = case IM.lookupLE (ord c) (unCharSet cs) of+ Nothing -> False+ Just (_,ch) -> c <= ch++-- | \(O(\min(n,C))\). Whether a @Char@ is not in a set.+notMember :: Char -> CharSet -> Bool+notMember c = Prelude.not . member c++-- | \(O(s)\). The @Char@s in a set.+elems :: CharSet -> [Char]+elems cs = ranges cs >>= \(cl,ch) -> [cl..ch]+{-# INLINE elems #-}++-- | \(O(n)\). The contiguous ranges of @Chars@ in a set.+ranges :: CharSet -> [(Char, Char)]+ranges cs = [(unsafeChr cl, ch) | (cl,ch) <- IM.assocs (unCharSet cs)]+{-# INLINE ranges #-}++--------------------+-- Internal/Unsafe+--------------------++-- | \(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)+ (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 )+ _ -> (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.++-- | \(O(\min(n+m,W))\). Join two sets. Every @Char@ in the left set must be+-- smaller than every @Char@ in the right set.+-- /This precondition is not checked./+join :: CharSet -> CharSet -> CharSet+join lcs rcs = case ( IM.maxViewWithKey (unCharSet lcs)+ , IM.minViewWithKey (unCharSet rcs) ) of+ (Nothing, Nothing) -> empty+ (Nothing, _) -> rcs+ (_, Nothing) -> lcs+ (Just ((lgl,lgh),l1), Just ((rgl,rgh),r1))+ | ord lgh == rgl - 1 -> CharSet $ IM.union l1 (IM.insert lgl rgh r1)+ | otherwise -> CharSet $ IM.union (unCharSet lcs) (unCharSet rcs)+-- Without the Nothing cases above there is a call to union even for those+-- cases. These would ideally be removed after inlining union's wrapper.+-- TODO: maxViewWithKey constructs the map without max but we may end up not+-- needing it. Check if doing lookupMax first is better even if we have to go+-- down the tree twice.++-- | \(O(n)\). Fold over the ranges in a set.+foldlRanges' :: (b -> Char -> Char -> b) -> b -> CharSet -> b+foldlRanges' = \f z cs ->+ IM.foldlWithKey' (\b cl ch -> f b (unsafeChr cl) ch) z (unCharSet cs)+{-# INLINE foldlRanges' #-}++-- | \(O(n)\). The complement of non-overlapping sorted ranges of Chars.+complementRanges :: [(Char, Char)] -> [(Int, Char)]+complementRanges = go+ where+ go [] = [(ord minBound, maxBound)]+ go ((l,h):xs)+ | l == minBound = go1 h xs+ | otherwise = (ord minBound, unsafePred l) : go1 h xs++ go1 !ph []+ | ph == maxBound = []+ | otherwise = [(ord ph + 1, maxBound)]+ go1 ph ((l,h):xs) = (ord ph + 1, unsafePred l) : go1 h xs++ unsafePred c = unsafeChr (ord c - 1)++unsafeChr :: Int -> Char+unsafeChr (I# i#) = C# (chr# i#)++------------+-- Testing+------------++-- | Is the internal structure of the set valid?+valid :: CharSet -> Bool+valid cs = and (zipWith (<=) ls hs)+ && all (>1) (zipWith (flip (-)) hs (tail ls))+ where+ (ls,hs) = unzip (fmap (fmap ord) (IM.assocs (unCharSet cs)))
+ src/Regex/Internal/CharSets.hs view
@@ -0,0 +1,47 @@+module Regex.Internal.CharSets+ ( digit+ , word+ , space+ , ascii+ , asciiAlpha+ , asciiUpper+ , asciiLower+ ) where++import Regex.Internal.CharSet (CharSet)+import qualified Regex.Internal.CharSet as CS++-- | ASCII digits. @\'0\'..\'9\'@. Agrees with 'Data.Char.isDigit'.+digit :: CharSet+digit = CS.fromRange ('0','9')++-- | ASCII alphabet, digits and underscore.+-- @\'A\'..\'Z\',\'a\'..\'z\',\'0\'..\'9\',\'_\'@.+word :: CharSet+word = asciiUpper <> asciiLower <> digit <> CS.singleton '_'++-- | Unicode space characters and the control characters+-- @\'\\t\',\'\\n\',\'\\r\',\'\\f\',\'\\v\'@.+-- Agrees with 'Data.Char.isSpace'.+space :: CharSet+space = CS.fromList "\t\n\r\f\v"+ <> CS.fromList "\x0020\x00A0\x1680\x202F\x205F\x3000"+ <> CS.fromRange ('\x2000','\x200A')++-- | ASCII @Char@s. @\'\\0\'..\'\\127\'@. Agrees with 'Data.Char.isAscii'.+ascii :: CharSet+ascii = CS.fromRange ('\0','\127')++-- | ASCII alphabet. @\'A\'..\'Z\',\'a\'..\'z\'@.+asciiAlpha :: CharSet+asciiAlpha = asciiUpper <> asciiLower++-- | ASCII uppercase @Char@s. @\'A\'..\'Z\'@. Agrees with+-- 'Data.Char.isAsciiUpper'.+asciiUpper :: CharSet+asciiUpper = CS.fromRange ('A','Z')++-- | ASCII lowercase @Char@s. @\'a\'..\'z\'@. Agrees with+-- 'Data.Char.isAsciiLower'.+asciiLower :: CharSet+asciiLower = CS.fromRange ('a','z')
+ src/Regex/Internal/Debug.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Regex.Internal.Debug+ ( reToDot+ , parserToDot+ , dispCharRanges+ ) where++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Identity+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Writer.CPS+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++import Regex.Internal.Regex (RE(..), Strictness(..), Greediness(..))+import Regex.Internal.Parser (Node(..), Parser(..))+import Regex.Internal.Unique (Unique(..))+import qualified Regex.Internal.CharSet as CS++-------+-- RE+-------++-- | Generate a [Graphviz DOT](https://graphviz.org/doc/info/lang.html)+-- visualization of a 'RE'. Optionally takes an alphabet @[c]@, which will be+-- tested against the 'token' functions in the 'RE' and accepted characters+-- displayed.+reToDot :: forall c a. Maybe ([c], [c] -> String) -> RE c a -> String+reToDot ma re0 = execM $ do+ writeLn "digraph RE {"+ _ <- go re0+ writeLn "}"+ 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 ->+ go re1 >>= writeEdge i+ RFmap_ _ re1 ->+ withNew "RFmap_" $ \i ->+ go re1 >>= writeEdge i+ RPure _ -> new "RPure"+ RLiftA2 st _ re1 re2 ->+ withNew ("RLiftA2" <+> dispsSt st) $ \i -> do+ go re1 >>= writeEdge i+ go re2 >>= writeEdge i+ REmpty -> new "REmpty"+ RAlt re1 re2 ->+ withNew "RAlt" $ \i -> do+ go re1 >>= writeEdge i+ go re2 >>= writeEdge i+ RFold st gr _ _ re1 ->+ withNew ("RFold" <+> dispsSt st <+> dispsGr gr) $ \i ->+ go re1 >>= writeEdge i+ RMany _ _ _ _ re1 ->+ withNew "RMany" $ \i ->+ go re1 >>= writeEdge i++-----------+-- Parser+-----------++-- | Generate a [Graphviz DOT](https://graphviz.org/doc/info/lang.html)+-- visualization of a 'Parser'. Optionally takes an alphabet @[c]@, which will+-- be tested against the 'token' functions in the 'Parser' and the accepted+-- characters displayed.+parserToDot :: forall c a. Maybe ([c], [c] -> String) -> Parser c a -> String+parserToDot ma p0 = execM $ do+ writeLn "digraph Parser {"+ _ <- go p0+ writeLn "}"+ 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 ->+ go re1 >>= writeEdge i+ PFmap_ node ->+ withNew "PFmap_" $ \i -> do+ writeLn $ "subgraph cluster" <> idStr i <> " {"+ j <- evalStateT (goNode node) IM.empty+ writeLn "}"+ writeEdge i j+ PPure _ -> new "PPure"+ PLiftA2 st _ re1 re2 ->+ withNew ("PLiftA2" <+> dispsSt st) $ \i -> do+ go re1 >>= writeEdge i+ go re2 >>= writeEdge i+ PEmpty -> new "PEmpty"+ PAlt _ re1 re2 res ->+ withNew "PAlt" $ \i -> do+ go re1 >>= writeEdge i+ go re2 >>= writeEdge i+ F.traverse_ (go >=> writeEdge i) res+ PMany _ _ _ _ _ re1 ->+ withNew "PMany" $ \i ->+ go re1 >>= writeEdge i+ PFoldGr _ st _ _ re1 ->+ withNew ("PFoldGr" <+> dispsSt st) $ \i ->+ go re1 >>= writeEdge i+ PFoldMn _ st _ _ re1 ->+ withNew ("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"+ NGuard u n1 -> do+ v <- gets $ IM.lookup (unUnique u)+ case v of+ Just i -> pure i+ Nothing -> withNewT "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+ goNode n1 >>= lift . writeEdge i+ goNode n2 >>= lift . writeEdge i+ F.traverse_ (goNode >=> lift . writeEdge i) ns++------------------+-- Display Chars+------------------++dispCharRanges :: [Char] -> String+dispCharRanges = show . CS.ranges . CS.fromList++-----------------+-- Common stuff+-----------------++newtype Str = Str { runStr :: String -> String }++instance IsString Str where+ fromString = Str . (++)++instance Semigroup Str where+ s1 <> s2 = Str (runStr s1 . runStr s2)++instance Monoid Str where+ mempty = Str id++dispsSt :: Strictness -> Str+dispsSt st = case st of+ Strict -> "S"+ NonStrict -> "NS"++dispsGr :: Greediness -> Str+dispsGr gr = case gr of+ Greedy -> "G"+ Minimal -> "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))++escape :: String -> String+escape = init . tail . show++(<+>) :: Str -> Str -> Str+s1 <+> s2 = s1 <> " " <> s2+infixr 6 <+>++declNode :: Id -> Str -> Str+declNode i label =+ idStr i <+>+ "[label=\"" <>+ label <>+ "\", ordering=\"out\"]"++type M = StateT Int (Writer Str)++execM :: M a -> String+execM = ($ "") . runStr . execWriter . flip runStateT 1++newtype Id = Id { unId :: String }++idStr :: Id -> Str+idStr = fromString . unId++nxt :: M Id+nxt = state $ \i -> let !i' = i+1 in (Id (show i), i')++writeLn :: Str -> M ()+writeLn = lift . tell . (<> "\n")++writeEdge :: Id -> Id -> M ()+writeEdge fr to = writeLn $ idStr fr <> " -> " <> idStr to++new :: Str -> M Id+new node = do+ i <- nxt+ writeLn $ declNode i node+ pure i++withNew :: Str -> (Id -> M a) -> M Id+withNew node f = runIdentityT $ withNewT node $ lift . f++withNewT :: (MonadTrans t, Monad (t M)) => Str -> (Id -> t M a) -> t M Id+withNewT node f = do+ i <- lift $ new node+ _ <- f i+ pure i
+ src/Regex/Internal/Generated/CaseFold.hs view
@@ -0,0 +1,1472 @@+-- DO NOT EDIT+-- This file was generated by GenCaseFold.hs from a CaseFolding.txt with header+--+-- CaseFolding-15.1.0.txt+-- Date: 2023-05-12, 21:53:10 GMT+-- © 2023 Unicode®, Inc.+--+module Regex.Internal.Generated.CaseFold+ ( caseFoldSimple+ ) where++caseFoldSimple :: Char -> Char+caseFoldSimple c0 = case c0 of+ '\x41' -> '\x61'+ '\x42' -> '\x62'+ '\x43' -> '\x63'+ '\x44' -> '\x64'+ '\x45' -> '\x65'+ '\x46' -> '\x66'+ '\x47' -> '\x67'+ '\x48' -> '\x68'+ '\x49' -> '\x69'+ '\x4a' -> '\x6a'+ '\x4b' -> '\x6b'+ '\x4c' -> '\x6c'+ '\x4d' -> '\x6d'+ '\x4e' -> '\x6e'+ '\x4f' -> '\x6f'+ '\x50' -> '\x70'+ '\x51' -> '\x71'+ '\x52' -> '\x72'+ '\x53' -> '\x73'+ '\x54' -> '\x74'+ '\x55' -> '\x75'+ '\x56' -> '\x76'+ '\x57' -> '\x77'+ '\x58' -> '\x78'+ '\x59' -> '\x79'+ '\x5a' -> '\x7a'+ '\xb5' -> '\x3bc'+ '\xc0' -> '\xe0'+ '\xc1' -> '\xe1'+ '\xc2' -> '\xe2'+ '\xc3' -> '\xe3'+ '\xc4' -> '\xe4'+ '\xc5' -> '\xe5'+ '\xc6' -> '\xe6'+ '\xc7' -> '\xe7'+ '\xc8' -> '\xe8'+ '\xc9' -> '\xe9'+ '\xca' -> '\xea'+ '\xcb' -> '\xeb'+ '\xcc' -> '\xec'+ '\xcd' -> '\xed'+ '\xce' -> '\xee'+ '\xcf' -> '\xef'+ '\xd0' -> '\xf0'+ '\xd1' -> '\xf1'+ '\xd2' -> '\xf2'+ '\xd3' -> '\xf3'+ '\xd4' -> '\xf4'+ '\xd5' -> '\xf5'+ '\xd6' -> '\xf6'+ '\xd8' -> '\xf8'+ '\xd9' -> '\xf9'+ '\xda' -> '\xfa'+ '\xdb' -> '\xfb'+ '\xdc' -> '\xfc'+ '\xdd' -> '\xfd'+ '\xde' -> '\xfe'+ '\x100' -> '\x101'+ '\x102' -> '\x103'+ '\x104' -> '\x105'+ '\x106' -> '\x107'+ '\x108' -> '\x109'+ '\x10a' -> '\x10b'+ '\x10c' -> '\x10d'+ '\x10e' -> '\x10f'+ '\x110' -> '\x111'+ '\x112' -> '\x113'+ '\x114' -> '\x115'+ '\x116' -> '\x117'+ '\x118' -> '\x119'+ '\x11a' -> '\x11b'+ '\x11c' -> '\x11d'+ '\x11e' -> '\x11f'+ '\x120' -> '\x121'+ '\x122' -> '\x123'+ '\x124' -> '\x125'+ '\x126' -> '\x127'+ '\x128' -> '\x129'+ '\x12a' -> '\x12b'+ '\x12c' -> '\x12d'+ '\x12e' -> '\x12f'+ '\x132' -> '\x133'+ '\x134' -> '\x135'+ '\x136' -> '\x137'+ '\x139' -> '\x13a'+ '\x13b' -> '\x13c'+ '\x13d' -> '\x13e'+ '\x13f' -> '\x140'+ '\x141' -> '\x142'+ '\x143' -> '\x144'+ '\x145' -> '\x146'+ '\x147' -> '\x148'+ '\x14a' -> '\x14b'+ '\x14c' -> '\x14d'+ '\x14e' -> '\x14f'+ '\x150' -> '\x151'+ '\x152' -> '\x153'+ '\x154' -> '\x155'+ '\x156' -> '\x157'+ '\x158' -> '\x159'+ '\x15a' -> '\x15b'+ '\x15c' -> '\x15d'+ '\x15e' -> '\x15f'+ '\x160' -> '\x161'+ '\x162' -> '\x163'+ '\x164' -> '\x165'+ '\x166' -> '\x167'+ '\x168' -> '\x169'+ '\x16a' -> '\x16b'+ '\x16c' -> '\x16d'+ '\x16e' -> '\x16f'+ '\x170' -> '\x171'+ '\x172' -> '\x173'+ '\x174' -> '\x175'+ '\x176' -> '\x177'+ '\x178' -> '\xff'+ '\x179' -> '\x17a'+ '\x17b' -> '\x17c'+ '\x17d' -> '\x17e'+ '\x17f' -> '\x73'+ '\x181' -> '\x253'+ '\x182' -> '\x183'+ '\x184' -> '\x185'+ '\x186' -> '\x254'+ '\x187' -> '\x188'+ '\x189' -> '\x256'+ '\x18a' -> '\x257'+ '\x18b' -> '\x18c'+ '\x18e' -> '\x1dd'+ '\x18f' -> '\x259'+ '\x190' -> '\x25b'+ '\x191' -> '\x192'+ '\x193' -> '\x260'+ '\x194' -> '\x263'+ '\x196' -> '\x269'+ '\x197' -> '\x268'+ '\x198' -> '\x199'+ '\x19c' -> '\x26f'+ '\x19d' -> '\x272'+ '\x19f' -> '\x275'+ '\x1a0' -> '\x1a1'+ '\x1a2' -> '\x1a3'+ '\x1a4' -> '\x1a5'+ '\x1a6' -> '\x280'+ '\x1a7' -> '\x1a8'+ '\x1a9' -> '\x283'+ '\x1ac' -> '\x1ad'+ '\x1ae' -> '\x288'+ '\x1af' -> '\x1b0'+ '\x1b1' -> '\x28a'+ '\x1b2' -> '\x28b'+ '\x1b3' -> '\x1b4'+ '\x1b5' -> '\x1b6'+ '\x1b7' -> '\x292'+ '\x1b8' -> '\x1b9'+ '\x1bc' -> '\x1bd'+ '\x1c4' -> '\x1c6'+ '\x1c5' -> '\x1c6'+ '\x1c7' -> '\x1c9'+ '\x1c8' -> '\x1c9'+ '\x1ca' -> '\x1cc'+ '\x1cb' -> '\x1cc'+ '\x1cd' -> '\x1ce'+ '\x1cf' -> '\x1d0'+ '\x1d1' -> '\x1d2'+ '\x1d3' -> '\x1d4'+ '\x1d5' -> '\x1d6'+ '\x1d7' -> '\x1d8'+ '\x1d9' -> '\x1da'+ '\x1db' -> '\x1dc'+ '\x1de' -> '\x1df'+ '\x1e0' -> '\x1e1'+ '\x1e2' -> '\x1e3'+ '\x1e4' -> '\x1e5'+ '\x1e6' -> '\x1e7'+ '\x1e8' -> '\x1e9'+ '\x1ea' -> '\x1eb'+ '\x1ec' -> '\x1ed'+ '\x1ee' -> '\x1ef'+ '\x1f1' -> '\x1f3'+ '\x1f2' -> '\x1f3'+ '\x1f4' -> '\x1f5'+ '\x1f6' -> '\x195'+ '\x1f7' -> '\x1bf'+ '\x1f8' -> '\x1f9'+ '\x1fa' -> '\x1fb'+ '\x1fc' -> '\x1fd'+ '\x1fe' -> '\x1ff'+ '\x200' -> '\x201'+ '\x202' -> '\x203'+ '\x204' -> '\x205'+ '\x206' -> '\x207'+ '\x208' -> '\x209'+ '\x20a' -> '\x20b'+ '\x20c' -> '\x20d'+ '\x20e' -> '\x20f'+ '\x210' -> '\x211'+ '\x212' -> '\x213'+ '\x214' -> '\x215'+ '\x216' -> '\x217'+ '\x218' -> '\x219'+ '\x21a' -> '\x21b'+ '\x21c' -> '\x21d'+ '\x21e' -> '\x21f'+ '\x220' -> '\x19e'+ '\x222' -> '\x223'+ '\x224' -> '\x225'+ '\x226' -> '\x227'+ '\x228' -> '\x229'+ '\x22a' -> '\x22b'+ '\x22c' -> '\x22d'+ '\x22e' -> '\x22f'+ '\x230' -> '\x231'+ '\x232' -> '\x233'+ '\x23a' -> '\x2c65'+ '\x23b' -> '\x23c'+ '\x23d' -> '\x19a'+ '\x23e' -> '\x2c66'+ '\x241' -> '\x242'+ '\x243' -> '\x180'+ '\x244' -> '\x289'+ '\x245' -> '\x28c'+ '\x246' -> '\x247'+ '\x248' -> '\x249'+ '\x24a' -> '\x24b'+ '\x24c' -> '\x24d'+ '\x24e' -> '\x24f'+ '\x345' -> '\x3b9'+ '\x370' -> '\x371'+ '\x372' -> '\x373'+ '\x376' -> '\x377'+ '\x37f' -> '\x3f3'+ '\x386' -> '\x3ac'+ '\x388' -> '\x3ad'+ '\x389' -> '\x3ae'+ '\x38a' -> '\x3af'+ '\x38c' -> '\x3cc'+ '\x38e' -> '\x3cd'+ '\x38f' -> '\x3ce'+ '\x391' -> '\x3b1'+ '\x392' -> '\x3b2'+ '\x393' -> '\x3b3'+ '\x394' -> '\x3b4'+ '\x395' -> '\x3b5'+ '\x396' -> '\x3b6'+ '\x397' -> '\x3b7'+ '\x398' -> '\x3b8'+ '\x399' -> '\x3b9'+ '\x39a' -> '\x3ba'+ '\x39b' -> '\x3bb'+ '\x39c' -> '\x3bc'+ '\x39d' -> '\x3bd'+ '\x39e' -> '\x3be'+ '\x39f' -> '\x3bf'+ '\x3a0' -> '\x3c0'+ '\x3a1' -> '\x3c1'+ '\x3a3' -> '\x3c3'+ '\x3a4' -> '\x3c4'+ '\x3a5' -> '\x3c5'+ '\x3a6' -> '\x3c6'+ '\x3a7' -> '\x3c7'+ '\x3a8' -> '\x3c8'+ '\x3a9' -> '\x3c9'+ '\x3aa' -> '\x3ca'+ '\x3ab' -> '\x3cb'+ '\x3c2' -> '\x3c3'+ '\x3cf' -> '\x3d7'+ '\x3d0' -> '\x3b2'+ '\x3d1' -> '\x3b8'+ '\x3d5' -> '\x3c6'+ '\x3d6' -> '\x3c0'+ '\x3d8' -> '\x3d9'+ '\x3da' -> '\x3db'+ '\x3dc' -> '\x3dd'+ '\x3de' -> '\x3df'+ '\x3e0' -> '\x3e1'+ '\x3e2' -> '\x3e3'+ '\x3e4' -> '\x3e5'+ '\x3e6' -> '\x3e7'+ '\x3e8' -> '\x3e9'+ '\x3ea' -> '\x3eb'+ '\x3ec' -> '\x3ed'+ '\x3ee' -> '\x3ef'+ '\x3f0' -> '\x3ba'+ '\x3f1' -> '\x3c1'+ '\x3f4' -> '\x3b8'+ '\x3f5' -> '\x3b5'+ '\x3f7' -> '\x3f8'+ '\x3f9' -> '\x3f2'+ '\x3fa' -> '\x3fb'+ '\x3fd' -> '\x37b'+ '\x3fe' -> '\x37c'+ '\x3ff' -> '\x37d'+ '\x400' -> '\x450'+ '\x401' -> '\x451'+ '\x402' -> '\x452'+ '\x403' -> '\x453'+ '\x404' -> '\x454'+ '\x405' -> '\x455'+ '\x406' -> '\x456'+ '\x407' -> '\x457'+ '\x408' -> '\x458'+ '\x409' -> '\x459'+ '\x40a' -> '\x45a'+ '\x40b' -> '\x45b'+ '\x40c' -> '\x45c'+ '\x40d' -> '\x45d'+ '\x40e' -> '\x45e'+ '\x40f' -> '\x45f'+ '\x410' -> '\x430'+ '\x411' -> '\x431'+ '\x412' -> '\x432'+ '\x413' -> '\x433'+ '\x414' -> '\x434'+ '\x415' -> '\x435'+ '\x416' -> '\x436'+ '\x417' -> '\x437'+ '\x418' -> '\x438'+ '\x419' -> '\x439'+ '\x41a' -> '\x43a'+ '\x41b' -> '\x43b'+ '\x41c' -> '\x43c'+ '\x41d' -> '\x43d'+ '\x41e' -> '\x43e'+ '\x41f' -> '\x43f'+ '\x420' -> '\x440'+ '\x421' -> '\x441'+ '\x422' -> '\x442'+ '\x423' -> '\x443'+ '\x424' -> '\x444'+ '\x425' -> '\x445'+ '\x426' -> '\x446'+ '\x427' -> '\x447'+ '\x428' -> '\x448'+ '\x429' -> '\x449'+ '\x42a' -> '\x44a'+ '\x42b' -> '\x44b'+ '\x42c' -> '\x44c'+ '\x42d' -> '\x44d'+ '\x42e' -> '\x44e'+ '\x42f' -> '\x44f'+ '\x460' -> '\x461'+ '\x462' -> '\x463'+ '\x464' -> '\x465'+ '\x466' -> '\x467'+ '\x468' -> '\x469'+ '\x46a' -> '\x46b'+ '\x46c' -> '\x46d'+ '\x46e' -> '\x46f'+ '\x470' -> '\x471'+ '\x472' -> '\x473'+ '\x474' -> '\x475'+ '\x476' -> '\x477'+ '\x478' -> '\x479'+ '\x47a' -> '\x47b'+ '\x47c' -> '\x47d'+ '\x47e' -> '\x47f'+ '\x480' -> '\x481'+ '\x48a' -> '\x48b'+ '\x48c' -> '\x48d'+ '\x48e' -> '\x48f'+ '\x490' -> '\x491'+ '\x492' -> '\x493'+ '\x494' -> '\x495'+ '\x496' -> '\x497'+ '\x498' -> '\x499'+ '\x49a' -> '\x49b'+ '\x49c' -> '\x49d'+ '\x49e' -> '\x49f'+ '\x4a0' -> '\x4a1'+ '\x4a2' -> '\x4a3'+ '\x4a4' -> '\x4a5'+ '\x4a6' -> '\x4a7'+ '\x4a8' -> '\x4a9'+ '\x4aa' -> '\x4ab'+ '\x4ac' -> '\x4ad'+ '\x4ae' -> '\x4af'+ '\x4b0' -> '\x4b1'+ '\x4b2' -> '\x4b3'+ '\x4b4' -> '\x4b5'+ '\x4b6' -> '\x4b7'+ '\x4b8' -> '\x4b9'+ '\x4ba' -> '\x4bb'+ '\x4bc' -> '\x4bd'+ '\x4be' -> '\x4bf'+ '\x4c0' -> '\x4cf'+ '\x4c1' -> '\x4c2'+ '\x4c3' -> '\x4c4'+ '\x4c5' -> '\x4c6'+ '\x4c7' -> '\x4c8'+ '\x4c9' -> '\x4ca'+ '\x4cb' -> '\x4cc'+ '\x4cd' -> '\x4ce'+ '\x4d0' -> '\x4d1'+ '\x4d2' -> '\x4d3'+ '\x4d4' -> '\x4d5'+ '\x4d6' -> '\x4d7'+ '\x4d8' -> '\x4d9'+ '\x4da' -> '\x4db'+ '\x4dc' -> '\x4dd'+ '\x4de' -> '\x4df'+ '\x4e0' -> '\x4e1'+ '\x4e2' -> '\x4e3'+ '\x4e4' -> '\x4e5'+ '\x4e6' -> '\x4e7'+ '\x4e8' -> '\x4e9'+ '\x4ea' -> '\x4eb'+ '\x4ec' -> '\x4ed'+ '\x4ee' -> '\x4ef'+ '\x4f0' -> '\x4f1'+ '\x4f2' -> '\x4f3'+ '\x4f4' -> '\x4f5'+ '\x4f6' -> '\x4f7'+ '\x4f8' -> '\x4f9'+ '\x4fa' -> '\x4fb'+ '\x4fc' -> '\x4fd'+ '\x4fe' -> '\x4ff'+ '\x500' -> '\x501'+ '\x502' -> '\x503'+ '\x504' -> '\x505'+ '\x506' -> '\x507'+ '\x508' -> '\x509'+ '\x50a' -> '\x50b'+ '\x50c' -> '\x50d'+ '\x50e' -> '\x50f'+ '\x510' -> '\x511'+ '\x512' -> '\x513'+ '\x514' -> '\x515'+ '\x516' -> '\x517'+ '\x518' -> '\x519'+ '\x51a' -> '\x51b'+ '\x51c' -> '\x51d'+ '\x51e' -> '\x51f'+ '\x520' -> '\x521'+ '\x522' -> '\x523'+ '\x524' -> '\x525'+ '\x526' -> '\x527'+ '\x528' -> '\x529'+ '\x52a' -> '\x52b'+ '\x52c' -> '\x52d'+ '\x52e' -> '\x52f'+ '\x531' -> '\x561'+ '\x532' -> '\x562'+ '\x533' -> '\x563'+ '\x534' -> '\x564'+ '\x535' -> '\x565'+ '\x536' -> '\x566'+ '\x537' -> '\x567'+ '\x538' -> '\x568'+ '\x539' -> '\x569'+ '\x53a' -> '\x56a'+ '\x53b' -> '\x56b'+ '\x53c' -> '\x56c'+ '\x53d' -> '\x56d'+ '\x53e' -> '\x56e'+ '\x53f' -> '\x56f'+ '\x540' -> '\x570'+ '\x541' -> '\x571'+ '\x542' -> '\x572'+ '\x543' -> '\x573'+ '\x544' -> '\x574'+ '\x545' -> '\x575'+ '\x546' -> '\x576'+ '\x547' -> '\x577'+ '\x548' -> '\x578'+ '\x549' -> '\x579'+ '\x54a' -> '\x57a'+ '\x54b' -> '\x57b'+ '\x54c' -> '\x57c'+ '\x54d' -> '\x57d'+ '\x54e' -> '\x57e'+ '\x54f' -> '\x57f'+ '\x550' -> '\x580'+ '\x551' -> '\x581'+ '\x552' -> '\x582'+ '\x553' -> '\x583'+ '\x554' -> '\x584'+ '\x555' -> '\x585'+ '\x556' -> '\x586'+ '\x10a0' -> '\x2d00'+ '\x10a1' -> '\x2d01'+ '\x10a2' -> '\x2d02'+ '\x10a3' -> '\x2d03'+ '\x10a4' -> '\x2d04'+ '\x10a5' -> '\x2d05'+ '\x10a6' -> '\x2d06'+ '\x10a7' -> '\x2d07'+ '\x10a8' -> '\x2d08'+ '\x10a9' -> '\x2d09'+ '\x10aa' -> '\x2d0a'+ '\x10ab' -> '\x2d0b'+ '\x10ac' -> '\x2d0c'+ '\x10ad' -> '\x2d0d'+ '\x10ae' -> '\x2d0e'+ '\x10af' -> '\x2d0f'+ '\x10b0' -> '\x2d10'+ '\x10b1' -> '\x2d11'+ '\x10b2' -> '\x2d12'+ '\x10b3' -> '\x2d13'+ '\x10b4' -> '\x2d14'+ '\x10b5' -> '\x2d15'+ '\x10b6' -> '\x2d16'+ '\x10b7' -> '\x2d17'+ '\x10b8' -> '\x2d18'+ '\x10b9' -> '\x2d19'+ '\x10ba' -> '\x2d1a'+ '\x10bb' -> '\x2d1b'+ '\x10bc' -> '\x2d1c'+ '\x10bd' -> '\x2d1d'+ '\x10be' -> '\x2d1e'+ '\x10bf' -> '\x2d1f'+ '\x10c0' -> '\x2d20'+ '\x10c1' -> '\x2d21'+ '\x10c2' -> '\x2d22'+ '\x10c3' -> '\x2d23'+ '\x10c4' -> '\x2d24'+ '\x10c5' -> '\x2d25'+ '\x10c7' -> '\x2d27'+ '\x10cd' -> '\x2d2d'+ '\x13f8' -> '\x13f0'+ '\x13f9' -> '\x13f1'+ '\x13fa' -> '\x13f2'+ '\x13fb' -> '\x13f3'+ '\x13fc' -> '\x13f4'+ '\x13fd' -> '\x13f5'+ '\x1c80' -> '\x432'+ '\x1c81' -> '\x434'+ '\x1c82' -> '\x43e'+ '\x1c83' -> '\x441'+ '\x1c84' -> '\x442'+ '\x1c85' -> '\x442'+ '\x1c86' -> '\x44a'+ '\x1c87' -> '\x463'+ '\x1c88' -> '\xa64b'+ '\x1c90' -> '\x10d0'+ '\x1c91' -> '\x10d1'+ '\x1c92' -> '\x10d2'+ '\x1c93' -> '\x10d3'+ '\x1c94' -> '\x10d4'+ '\x1c95' -> '\x10d5'+ '\x1c96' -> '\x10d6'+ '\x1c97' -> '\x10d7'+ '\x1c98' -> '\x10d8'+ '\x1c99' -> '\x10d9'+ '\x1c9a' -> '\x10da'+ '\x1c9b' -> '\x10db'+ '\x1c9c' -> '\x10dc'+ '\x1c9d' -> '\x10dd'+ '\x1c9e' -> '\x10de'+ '\x1c9f' -> '\x10df'+ '\x1ca0' -> '\x10e0'+ '\x1ca1' -> '\x10e1'+ '\x1ca2' -> '\x10e2'+ '\x1ca3' -> '\x10e3'+ '\x1ca4' -> '\x10e4'+ '\x1ca5' -> '\x10e5'+ '\x1ca6' -> '\x10e6'+ '\x1ca7' -> '\x10e7'+ '\x1ca8' -> '\x10e8'+ '\x1ca9' -> '\x10e9'+ '\x1caa' -> '\x10ea'+ '\x1cab' -> '\x10eb'+ '\x1cac' -> '\x10ec'+ '\x1cad' -> '\x10ed'+ '\x1cae' -> '\x10ee'+ '\x1caf' -> '\x10ef'+ '\x1cb0' -> '\x10f0'+ '\x1cb1' -> '\x10f1'+ '\x1cb2' -> '\x10f2'+ '\x1cb3' -> '\x10f3'+ '\x1cb4' -> '\x10f4'+ '\x1cb5' -> '\x10f5'+ '\x1cb6' -> '\x10f6'+ '\x1cb7' -> '\x10f7'+ '\x1cb8' -> '\x10f8'+ '\x1cb9' -> '\x10f9'+ '\x1cba' -> '\x10fa'+ '\x1cbd' -> '\x10fd'+ '\x1cbe' -> '\x10fe'+ '\x1cbf' -> '\x10ff'+ '\x1e00' -> '\x1e01'+ '\x1e02' -> '\x1e03'+ '\x1e04' -> '\x1e05'+ '\x1e06' -> '\x1e07'+ '\x1e08' -> '\x1e09'+ '\x1e0a' -> '\x1e0b'+ '\x1e0c' -> '\x1e0d'+ '\x1e0e' -> '\x1e0f'+ '\x1e10' -> '\x1e11'+ '\x1e12' -> '\x1e13'+ '\x1e14' -> '\x1e15'+ '\x1e16' -> '\x1e17'+ '\x1e18' -> '\x1e19'+ '\x1e1a' -> '\x1e1b'+ '\x1e1c' -> '\x1e1d'+ '\x1e1e' -> '\x1e1f'+ '\x1e20' -> '\x1e21'+ '\x1e22' -> '\x1e23'+ '\x1e24' -> '\x1e25'+ '\x1e26' -> '\x1e27'+ '\x1e28' -> '\x1e29'+ '\x1e2a' -> '\x1e2b'+ '\x1e2c' -> '\x1e2d'+ '\x1e2e' -> '\x1e2f'+ '\x1e30' -> '\x1e31'+ '\x1e32' -> '\x1e33'+ '\x1e34' -> '\x1e35'+ '\x1e36' -> '\x1e37'+ '\x1e38' -> '\x1e39'+ '\x1e3a' -> '\x1e3b'+ '\x1e3c' -> '\x1e3d'+ '\x1e3e' -> '\x1e3f'+ '\x1e40' -> '\x1e41'+ '\x1e42' -> '\x1e43'+ '\x1e44' -> '\x1e45'+ '\x1e46' -> '\x1e47'+ '\x1e48' -> '\x1e49'+ '\x1e4a' -> '\x1e4b'+ '\x1e4c' -> '\x1e4d'+ '\x1e4e' -> '\x1e4f'+ '\x1e50' -> '\x1e51'+ '\x1e52' -> '\x1e53'+ '\x1e54' -> '\x1e55'+ '\x1e56' -> '\x1e57'+ '\x1e58' -> '\x1e59'+ '\x1e5a' -> '\x1e5b'+ '\x1e5c' -> '\x1e5d'+ '\x1e5e' -> '\x1e5f'+ '\x1e60' -> '\x1e61'+ '\x1e62' -> '\x1e63'+ '\x1e64' -> '\x1e65'+ '\x1e66' -> '\x1e67'+ '\x1e68' -> '\x1e69'+ '\x1e6a' -> '\x1e6b'+ '\x1e6c' -> '\x1e6d'+ '\x1e6e' -> '\x1e6f'+ '\x1e70' -> '\x1e71'+ '\x1e72' -> '\x1e73'+ '\x1e74' -> '\x1e75'+ '\x1e76' -> '\x1e77'+ '\x1e78' -> '\x1e79'+ '\x1e7a' -> '\x1e7b'+ '\x1e7c' -> '\x1e7d'+ '\x1e7e' -> '\x1e7f'+ '\x1e80' -> '\x1e81'+ '\x1e82' -> '\x1e83'+ '\x1e84' -> '\x1e85'+ '\x1e86' -> '\x1e87'+ '\x1e88' -> '\x1e89'+ '\x1e8a' -> '\x1e8b'+ '\x1e8c' -> '\x1e8d'+ '\x1e8e' -> '\x1e8f'+ '\x1e90' -> '\x1e91'+ '\x1e92' -> '\x1e93'+ '\x1e94' -> '\x1e95'+ '\x1e9b' -> '\x1e61'+ '\x1e9e' -> '\xdf'+ '\x1ea0' -> '\x1ea1'+ '\x1ea2' -> '\x1ea3'+ '\x1ea4' -> '\x1ea5'+ '\x1ea6' -> '\x1ea7'+ '\x1ea8' -> '\x1ea9'+ '\x1eaa' -> '\x1eab'+ '\x1eac' -> '\x1ead'+ '\x1eae' -> '\x1eaf'+ '\x1eb0' -> '\x1eb1'+ '\x1eb2' -> '\x1eb3'+ '\x1eb4' -> '\x1eb5'+ '\x1eb6' -> '\x1eb7'+ '\x1eb8' -> '\x1eb9'+ '\x1eba' -> '\x1ebb'+ '\x1ebc' -> '\x1ebd'+ '\x1ebe' -> '\x1ebf'+ '\x1ec0' -> '\x1ec1'+ '\x1ec2' -> '\x1ec3'+ '\x1ec4' -> '\x1ec5'+ '\x1ec6' -> '\x1ec7'+ '\x1ec8' -> '\x1ec9'+ '\x1eca' -> '\x1ecb'+ '\x1ecc' -> '\x1ecd'+ '\x1ece' -> '\x1ecf'+ '\x1ed0' -> '\x1ed1'+ '\x1ed2' -> '\x1ed3'+ '\x1ed4' -> '\x1ed5'+ '\x1ed6' -> '\x1ed7'+ '\x1ed8' -> '\x1ed9'+ '\x1eda' -> '\x1edb'+ '\x1edc' -> '\x1edd'+ '\x1ede' -> '\x1edf'+ '\x1ee0' -> '\x1ee1'+ '\x1ee2' -> '\x1ee3'+ '\x1ee4' -> '\x1ee5'+ '\x1ee6' -> '\x1ee7'+ '\x1ee8' -> '\x1ee9'+ '\x1eea' -> '\x1eeb'+ '\x1eec' -> '\x1eed'+ '\x1eee' -> '\x1eef'+ '\x1ef0' -> '\x1ef1'+ '\x1ef2' -> '\x1ef3'+ '\x1ef4' -> '\x1ef5'+ '\x1ef6' -> '\x1ef7'+ '\x1ef8' -> '\x1ef9'+ '\x1efa' -> '\x1efb'+ '\x1efc' -> '\x1efd'+ '\x1efe' -> '\x1eff'+ '\x1f08' -> '\x1f00'+ '\x1f09' -> '\x1f01'+ '\x1f0a' -> '\x1f02'+ '\x1f0b' -> '\x1f03'+ '\x1f0c' -> '\x1f04'+ '\x1f0d' -> '\x1f05'+ '\x1f0e' -> '\x1f06'+ '\x1f0f' -> '\x1f07'+ '\x1f18' -> '\x1f10'+ '\x1f19' -> '\x1f11'+ '\x1f1a' -> '\x1f12'+ '\x1f1b' -> '\x1f13'+ '\x1f1c' -> '\x1f14'+ '\x1f1d' -> '\x1f15'+ '\x1f28' -> '\x1f20'+ '\x1f29' -> '\x1f21'+ '\x1f2a' -> '\x1f22'+ '\x1f2b' -> '\x1f23'+ '\x1f2c' -> '\x1f24'+ '\x1f2d' -> '\x1f25'+ '\x1f2e' -> '\x1f26'+ '\x1f2f' -> '\x1f27'+ '\x1f38' -> '\x1f30'+ '\x1f39' -> '\x1f31'+ '\x1f3a' -> '\x1f32'+ '\x1f3b' -> '\x1f33'+ '\x1f3c' -> '\x1f34'+ '\x1f3d' -> '\x1f35'+ '\x1f3e' -> '\x1f36'+ '\x1f3f' -> '\x1f37'+ '\x1f48' -> '\x1f40'+ '\x1f49' -> '\x1f41'+ '\x1f4a' -> '\x1f42'+ '\x1f4b' -> '\x1f43'+ '\x1f4c' -> '\x1f44'+ '\x1f4d' -> '\x1f45'+ '\x1f59' -> '\x1f51'+ '\x1f5b' -> '\x1f53'+ '\x1f5d' -> '\x1f55'+ '\x1f5f' -> '\x1f57'+ '\x1f68' -> '\x1f60'+ '\x1f69' -> '\x1f61'+ '\x1f6a' -> '\x1f62'+ '\x1f6b' -> '\x1f63'+ '\x1f6c' -> '\x1f64'+ '\x1f6d' -> '\x1f65'+ '\x1f6e' -> '\x1f66'+ '\x1f6f' -> '\x1f67'+ '\x1f88' -> '\x1f80'+ '\x1f89' -> '\x1f81'+ '\x1f8a' -> '\x1f82'+ '\x1f8b' -> '\x1f83'+ '\x1f8c' -> '\x1f84'+ '\x1f8d' -> '\x1f85'+ '\x1f8e' -> '\x1f86'+ '\x1f8f' -> '\x1f87'+ '\x1f98' -> '\x1f90'+ '\x1f99' -> '\x1f91'+ '\x1f9a' -> '\x1f92'+ '\x1f9b' -> '\x1f93'+ '\x1f9c' -> '\x1f94'+ '\x1f9d' -> '\x1f95'+ '\x1f9e' -> '\x1f96'+ '\x1f9f' -> '\x1f97'+ '\x1fa8' -> '\x1fa0'+ '\x1fa9' -> '\x1fa1'+ '\x1faa' -> '\x1fa2'+ '\x1fab' -> '\x1fa3'+ '\x1fac' -> '\x1fa4'+ '\x1fad' -> '\x1fa5'+ '\x1fae' -> '\x1fa6'+ '\x1faf' -> '\x1fa7'+ '\x1fb8' -> '\x1fb0'+ '\x1fb9' -> '\x1fb1'+ '\x1fba' -> '\x1f70'+ '\x1fbb' -> '\x1f71'+ '\x1fbc' -> '\x1fb3'+ '\x1fbe' -> '\x3b9'+ '\x1fc8' -> '\x1f72'+ '\x1fc9' -> '\x1f73'+ '\x1fca' -> '\x1f74'+ '\x1fcb' -> '\x1f75'+ '\x1fcc' -> '\x1fc3'+ '\x1fd3' -> '\x390'+ '\x1fd8' -> '\x1fd0'+ '\x1fd9' -> '\x1fd1'+ '\x1fda' -> '\x1f76'+ '\x1fdb' -> '\x1f77'+ '\x1fe3' -> '\x3b0'+ '\x1fe8' -> '\x1fe0'+ '\x1fe9' -> '\x1fe1'+ '\x1fea' -> '\x1f7a'+ '\x1feb' -> '\x1f7b'+ '\x1fec' -> '\x1fe5'+ '\x1ff8' -> '\x1f78'+ '\x1ff9' -> '\x1f79'+ '\x1ffa' -> '\x1f7c'+ '\x1ffb' -> '\x1f7d'+ '\x1ffc' -> '\x1ff3'+ '\x2126' -> '\x3c9'+ '\x212a' -> '\x6b'+ '\x212b' -> '\xe5'+ '\x2132' -> '\x214e'+ '\x2160' -> '\x2170'+ '\x2161' -> '\x2171'+ '\x2162' -> '\x2172'+ '\x2163' -> '\x2173'+ '\x2164' -> '\x2174'+ '\x2165' -> '\x2175'+ '\x2166' -> '\x2176'+ '\x2167' -> '\x2177'+ '\x2168' -> '\x2178'+ '\x2169' -> '\x2179'+ '\x216a' -> '\x217a'+ '\x216b' -> '\x217b'+ '\x216c' -> '\x217c'+ '\x216d' -> '\x217d'+ '\x216e' -> '\x217e'+ '\x216f' -> '\x217f'+ '\x2183' -> '\x2184'+ '\x24b6' -> '\x24d0'+ '\x24b7' -> '\x24d1'+ '\x24b8' -> '\x24d2'+ '\x24b9' -> '\x24d3'+ '\x24ba' -> '\x24d4'+ '\x24bb' -> '\x24d5'+ '\x24bc' -> '\x24d6'+ '\x24bd' -> '\x24d7'+ '\x24be' -> '\x24d8'+ '\x24bf' -> '\x24d9'+ '\x24c0' -> '\x24da'+ '\x24c1' -> '\x24db'+ '\x24c2' -> '\x24dc'+ '\x24c3' -> '\x24dd'+ '\x24c4' -> '\x24de'+ '\x24c5' -> '\x24df'+ '\x24c6' -> '\x24e0'+ '\x24c7' -> '\x24e1'+ '\x24c8' -> '\x24e2'+ '\x24c9' -> '\x24e3'+ '\x24ca' -> '\x24e4'+ '\x24cb' -> '\x24e5'+ '\x24cc' -> '\x24e6'+ '\x24cd' -> '\x24e7'+ '\x24ce' -> '\x24e8'+ '\x24cf' -> '\x24e9'+ '\x2c00' -> '\x2c30'+ '\x2c01' -> '\x2c31'+ '\x2c02' -> '\x2c32'+ '\x2c03' -> '\x2c33'+ '\x2c04' -> '\x2c34'+ '\x2c05' -> '\x2c35'+ '\x2c06' -> '\x2c36'+ '\x2c07' -> '\x2c37'+ '\x2c08' -> '\x2c38'+ '\x2c09' -> '\x2c39'+ '\x2c0a' -> '\x2c3a'+ '\x2c0b' -> '\x2c3b'+ '\x2c0c' -> '\x2c3c'+ '\x2c0d' -> '\x2c3d'+ '\x2c0e' -> '\x2c3e'+ '\x2c0f' -> '\x2c3f'+ '\x2c10' -> '\x2c40'+ '\x2c11' -> '\x2c41'+ '\x2c12' -> '\x2c42'+ '\x2c13' -> '\x2c43'+ '\x2c14' -> '\x2c44'+ '\x2c15' -> '\x2c45'+ '\x2c16' -> '\x2c46'+ '\x2c17' -> '\x2c47'+ '\x2c18' -> '\x2c48'+ '\x2c19' -> '\x2c49'+ '\x2c1a' -> '\x2c4a'+ '\x2c1b' -> '\x2c4b'+ '\x2c1c' -> '\x2c4c'+ '\x2c1d' -> '\x2c4d'+ '\x2c1e' -> '\x2c4e'+ '\x2c1f' -> '\x2c4f'+ '\x2c20' -> '\x2c50'+ '\x2c21' -> '\x2c51'+ '\x2c22' -> '\x2c52'+ '\x2c23' -> '\x2c53'+ '\x2c24' -> '\x2c54'+ '\x2c25' -> '\x2c55'+ '\x2c26' -> '\x2c56'+ '\x2c27' -> '\x2c57'+ '\x2c28' -> '\x2c58'+ '\x2c29' -> '\x2c59'+ '\x2c2a' -> '\x2c5a'+ '\x2c2b' -> '\x2c5b'+ '\x2c2c' -> '\x2c5c'+ '\x2c2d' -> '\x2c5d'+ '\x2c2e' -> '\x2c5e'+ '\x2c2f' -> '\x2c5f'+ '\x2c60' -> '\x2c61'+ '\x2c62' -> '\x26b'+ '\x2c63' -> '\x1d7d'+ '\x2c64' -> '\x27d'+ '\x2c67' -> '\x2c68'+ '\x2c69' -> '\x2c6a'+ '\x2c6b' -> '\x2c6c'+ '\x2c6d' -> '\x251'+ '\x2c6e' -> '\x271'+ '\x2c6f' -> '\x250'+ '\x2c70' -> '\x252'+ '\x2c72' -> '\x2c73'+ '\x2c75' -> '\x2c76'+ '\x2c7e' -> '\x23f'+ '\x2c7f' -> '\x240'+ '\x2c80' -> '\x2c81'+ '\x2c82' -> '\x2c83'+ '\x2c84' -> '\x2c85'+ '\x2c86' -> '\x2c87'+ '\x2c88' -> '\x2c89'+ '\x2c8a' -> '\x2c8b'+ '\x2c8c' -> '\x2c8d'+ '\x2c8e' -> '\x2c8f'+ '\x2c90' -> '\x2c91'+ '\x2c92' -> '\x2c93'+ '\x2c94' -> '\x2c95'+ '\x2c96' -> '\x2c97'+ '\x2c98' -> '\x2c99'+ '\x2c9a' -> '\x2c9b'+ '\x2c9c' -> '\x2c9d'+ '\x2c9e' -> '\x2c9f'+ '\x2ca0' -> '\x2ca1'+ '\x2ca2' -> '\x2ca3'+ '\x2ca4' -> '\x2ca5'+ '\x2ca6' -> '\x2ca7'+ '\x2ca8' -> '\x2ca9'+ '\x2caa' -> '\x2cab'+ '\x2cac' -> '\x2cad'+ '\x2cae' -> '\x2caf'+ '\x2cb0' -> '\x2cb1'+ '\x2cb2' -> '\x2cb3'+ '\x2cb4' -> '\x2cb5'+ '\x2cb6' -> '\x2cb7'+ '\x2cb8' -> '\x2cb9'+ '\x2cba' -> '\x2cbb'+ '\x2cbc' -> '\x2cbd'+ '\x2cbe' -> '\x2cbf'+ '\x2cc0' -> '\x2cc1'+ '\x2cc2' -> '\x2cc3'+ '\x2cc4' -> '\x2cc5'+ '\x2cc6' -> '\x2cc7'+ '\x2cc8' -> '\x2cc9'+ '\x2cca' -> '\x2ccb'+ '\x2ccc' -> '\x2ccd'+ '\x2cce' -> '\x2ccf'+ '\x2cd0' -> '\x2cd1'+ '\x2cd2' -> '\x2cd3'+ '\x2cd4' -> '\x2cd5'+ '\x2cd6' -> '\x2cd7'+ '\x2cd8' -> '\x2cd9'+ '\x2cda' -> '\x2cdb'+ '\x2cdc' -> '\x2cdd'+ '\x2cde' -> '\x2cdf'+ '\x2ce0' -> '\x2ce1'+ '\x2ce2' -> '\x2ce3'+ '\x2ceb' -> '\x2cec'+ '\x2ced' -> '\x2cee'+ '\x2cf2' -> '\x2cf3'+ '\xa640' -> '\xa641'+ '\xa642' -> '\xa643'+ '\xa644' -> '\xa645'+ '\xa646' -> '\xa647'+ '\xa648' -> '\xa649'+ '\xa64a' -> '\xa64b'+ '\xa64c' -> '\xa64d'+ '\xa64e' -> '\xa64f'+ '\xa650' -> '\xa651'+ '\xa652' -> '\xa653'+ '\xa654' -> '\xa655'+ '\xa656' -> '\xa657'+ '\xa658' -> '\xa659'+ '\xa65a' -> '\xa65b'+ '\xa65c' -> '\xa65d'+ '\xa65e' -> '\xa65f'+ '\xa660' -> '\xa661'+ '\xa662' -> '\xa663'+ '\xa664' -> '\xa665'+ '\xa666' -> '\xa667'+ '\xa668' -> '\xa669'+ '\xa66a' -> '\xa66b'+ '\xa66c' -> '\xa66d'+ '\xa680' -> '\xa681'+ '\xa682' -> '\xa683'+ '\xa684' -> '\xa685'+ '\xa686' -> '\xa687'+ '\xa688' -> '\xa689'+ '\xa68a' -> '\xa68b'+ '\xa68c' -> '\xa68d'+ '\xa68e' -> '\xa68f'+ '\xa690' -> '\xa691'+ '\xa692' -> '\xa693'+ '\xa694' -> '\xa695'+ '\xa696' -> '\xa697'+ '\xa698' -> '\xa699'+ '\xa69a' -> '\xa69b'+ '\xa722' -> '\xa723'+ '\xa724' -> '\xa725'+ '\xa726' -> '\xa727'+ '\xa728' -> '\xa729'+ '\xa72a' -> '\xa72b'+ '\xa72c' -> '\xa72d'+ '\xa72e' -> '\xa72f'+ '\xa732' -> '\xa733'+ '\xa734' -> '\xa735'+ '\xa736' -> '\xa737'+ '\xa738' -> '\xa739'+ '\xa73a' -> '\xa73b'+ '\xa73c' -> '\xa73d'+ '\xa73e' -> '\xa73f'+ '\xa740' -> '\xa741'+ '\xa742' -> '\xa743'+ '\xa744' -> '\xa745'+ '\xa746' -> '\xa747'+ '\xa748' -> '\xa749'+ '\xa74a' -> '\xa74b'+ '\xa74c' -> '\xa74d'+ '\xa74e' -> '\xa74f'+ '\xa750' -> '\xa751'+ '\xa752' -> '\xa753'+ '\xa754' -> '\xa755'+ '\xa756' -> '\xa757'+ '\xa758' -> '\xa759'+ '\xa75a' -> '\xa75b'+ '\xa75c' -> '\xa75d'+ '\xa75e' -> '\xa75f'+ '\xa760' -> '\xa761'+ '\xa762' -> '\xa763'+ '\xa764' -> '\xa765'+ '\xa766' -> '\xa767'+ '\xa768' -> '\xa769'+ '\xa76a' -> '\xa76b'+ '\xa76c' -> '\xa76d'+ '\xa76e' -> '\xa76f'+ '\xa779' -> '\xa77a'+ '\xa77b' -> '\xa77c'+ '\xa77d' -> '\x1d79'+ '\xa77e' -> '\xa77f'+ '\xa780' -> '\xa781'+ '\xa782' -> '\xa783'+ '\xa784' -> '\xa785'+ '\xa786' -> '\xa787'+ '\xa78b' -> '\xa78c'+ '\xa78d' -> '\x265'+ '\xa790' -> '\xa791'+ '\xa792' -> '\xa793'+ '\xa796' -> '\xa797'+ '\xa798' -> '\xa799'+ '\xa79a' -> '\xa79b'+ '\xa79c' -> '\xa79d'+ '\xa79e' -> '\xa79f'+ '\xa7a0' -> '\xa7a1'+ '\xa7a2' -> '\xa7a3'+ '\xa7a4' -> '\xa7a5'+ '\xa7a6' -> '\xa7a7'+ '\xa7a8' -> '\xa7a9'+ '\xa7aa' -> '\x266'+ '\xa7ab' -> '\x25c'+ '\xa7ac' -> '\x261'+ '\xa7ad' -> '\x26c'+ '\xa7ae' -> '\x26a'+ '\xa7b0' -> '\x29e'+ '\xa7b1' -> '\x287'+ '\xa7b2' -> '\x29d'+ '\xa7b3' -> '\xab53'+ '\xa7b4' -> '\xa7b5'+ '\xa7b6' -> '\xa7b7'+ '\xa7b8' -> '\xa7b9'+ '\xa7ba' -> '\xa7bb'+ '\xa7bc' -> '\xa7bd'+ '\xa7be' -> '\xa7bf'+ '\xa7c0' -> '\xa7c1'+ '\xa7c2' -> '\xa7c3'+ '\xa7c4' -> '\xa794'+ '\xa7c5' -> '\x282'+ '\xa7c6' -> '\x1d8e'+ '\xa7c7' -> '\xa7c8'+ '\xa7c9' -> '\xa7ca'+ '\xa7d0' -> '\xa7d1'+ '\xa7d6' -> '\xa7d7'+ '\xa7d8' -> '\xa7d9'+ '\xa7f5' -> '\xa7f6'+ '\xab70' -> '\x13a0'+ '\xab71' -> '\x13a1'+ '\xab72' -> '\x13a2'+ '\xab73' -> '\x13a3'+ '\xab74' -> '\x13a4'+ '\xab75' -> '\x13a5'+ '\xab76' -> '\x13a6'+ '\xab77' -> '\x13a7'+ '\xab78' -> '\x13a8'+ '\xab79' -> '\x13a9'+ '\xab7a' -> '\x13aa'+ '\xab7b' -> '\x13ab'+ '\xab7c' -> '\x13ac'+ '\xab7d' -> '\x13ad'+ '\xab7e' -> '\x13ae'+ '\xab7f' -> '\x13af'+ '\xab80' -> '\x13b0'+ '\xab81' -> '\x13b1'+ '\xab82' -> '\x13b2'+ '\xab83' -> '\x13b3'+ '\xab84' -> '\x13b4'+ '\xab85' -> '\x13b5'+ '\xab86' -> '\x13b6'+ '\xab87' -> '\x13b7'+ '\xab88' -> '\x13b8'+ '\xab89' -> '\x13b9'+ '\xab8a' -> '\x13ba'+ '\xab8b' -> '\x13bb'+ '\xab8c' -> '\x13bc'+ '\xab8d' -> '\x13bd'+ '\xab8e' -> '\x13be'+ '\xab8f' -> '\x13bf'+ '\xab90' -> '\x13c0'+ '\xab91' -> '\x13c1'+ '\xab92' -> '\x13c2'+ '\xab93' -> '\x13c3'+ '\xab94' -> '\x13c4'+ '\xab95' -> '\x13c5'+ '\xab96' -> '\x13c6'+ '\xab97' -> '\x13c7'+ '\xab98' -> '\x13c8'+ '\xab99' -> '\x13c9'+ '\xab9a' -> '\x13ca'+ '\xab9b' -> '\x13cb'+ '\xab9c' -> '\x13cc'+ '\xab9d' -> '\x13cd'+ '\xab9e' -> '\x13ce'+ '\xab9f' -> '\x13cf'+ '\xaba0' -> '\x13d0'+ '\xaba1' -> '\x13d1'+ '\xaba2' -> '\x13d2'+ '\xaba3' -> '\x13d3'+ '\xaba4' -> '\x13d4'+ '\xaba5' -> '\x13d5'+ '\xaba6' -> '\x13d6'+ '\xaba7' -> '\x13d7'+ '\xaba8' -> '\x13d8'+ '\xaba9' -> '\x13d9'+ '\xabaa' -> '\x13da'+ '\xabab' -> '\x13db'+ '\xabac' -> '\x13dc'+ '\xabad' -> '\x13dd'+ '\xabae' -> '\x13de'+ '\xabaf' -> '\x13df'+ '\xabb0' -> '\x13e0'+ '\xabb1' -> '\x13e1'+ '\xabb2' -> '\x13e2'+ '\xabb3' -> '\x13e3'+ '\xabb4' -> '\x13e4'+ '\xabb5' -> '\x13e5'+ '\xabb6' -> '\x13e6'+ '\xabb7' -> '\x13e7'+ '\xabb8' -> '\x13e8'+ '\xabb9' -> '\x13e9'+ '\xabba' -> '\x13ea'+ '\xabbb' -> '\x13eb'+ '\xabbc' -> '\x13ec'+ '\xabbd' -> '\x13ed'+ '\xabbe' -> '\x13ee'+ '\xabbf' -> '\x13ef'+ '\xfb05' -> '\xfb06'+ '\xff21' -> '\xff41'+ '\xff22' -> '\xff42'+ '\xff23' -> '\xff43'+ '\xff24' -> '\xff44'+ '\xff25' -> '\xff45'+ '\xff26' -> '\xff46'+ '\xff27' -> '\xff47'+ '\xff28' -> '\xff48'+ '\xff29' -> '\xff49'+ '\xff2a' -> '\xff4a'+ '\xff2b' -> '\xff4b'+ '\xff2c' -> '\xff4c'+ '\xff2d' -> '\xff4d'+ '\xff2e' -> '\xff4e'+ '\xff2f' -> '\xff4f'+ '\xff30' -> '\xff50'+ '\xff31' -> '\xff51'+ '\xff32' -> '\xff52'+ '\xff33' -> '\xff53'+ '\xff34' -> '\xff54'+ '\xff35' -> '\xff55'+ '\xff36' -> '\xff56'+ '\xff37' -> '\xff57'+ '\xff38' -> '\xff58'+ '\xff39' -> '\xff59'+ '\xff3a' -> '\xff5a'+ '\x10400' -> '\x10428'+ '\x10401' -> '\x10429'+ '\x10402' -> '\x1042a'+ '\x10403' -> '\x1042b'+ '\x10404' -> '\x1042c'+ '\x10405' -> '\x1042d'+ '\x10406' -> '\x1042e'+ '\x10407' -> '\x1042f'+ '\x10408' -> '\x10430'+ '\x10409' -> '\x10431'+ '\x1040a' -> '\x10432'+ '\x1040b' -> '\x10433'+ '\x1040c' -> '\x10434'+ '\x1040d' -> '\x10435'+ '\x1040e' -> '\x10436'+ '\x1040f' -> '\x10437'+ '\x10410' -> '\x10438'+ '\x10411' -> '\x10439'+ '\x10412' -> '\x1043a'+ '\x10413' -> '\x1043b'+ '\x10414' -> '\x1043c'+ '\x10415' -> '\x1043d'+ '\x10416' -> '\x1043e'+ '\x10417' -> '\x1043f'+ '\x10418' -> '\x10440'+ '\x10419' -> '\x10441'+ '\x1041a' -> '\x10442'+ '\x1041b' -> '\x10443'+ '\x1041c' -> '\x10444'+ '\x1041d' -> '\x10445'+ '\x1041e' -> '\x10446'+ '\x1041f' -> '\x10447'+ '\x10420' -> '\x10448'+ '\x10421' -> '\x10449'+ '\x10422' -> '\x1044a'+ '\x10423' -> '\x1044b'+ '\x10424' -> '\x1044c'+ '\x10425' -> '\x1044d'+ '\x10426' -> '\x1044e'+ '\x10427' -> '\x1044f'+ '\x104b0' -> '\x104d8'+ '\x104b1' -> '\x104d9'+ '\x104b2' -> '\x104da'+ '\x104b3' -> '\x104db'+ '\x104b4' -> '\x104dc'+ '\x104b5' -> '\x104dd'+ '\x104b6' -> '\x104de'+ '\x104b7' -> '\x104df'+ '\x104b8' -> '\x104e0'+ '\x104b9' -> '\x104e1'+ '\x104ba' -> '\x104e2'+ '\x104bb' -> '\x104e3'+ '\x104bc' -> '\x104e4'+ '\x104bd' -> '\x104e5'+ '\x104be' -> '\x104e6'+ '\x104bf' -> '\x104e7'+ '\x104c0' -> '\x104e8'+ '\x104c1' -> '\x104e9'+ '\x104c2' -> '\x104ea'+ '\x104c3' -> '\x104eb'+ '\x104c4' -> '\x104ec'+ '\x104c5' -> '\x104ed'+ '\x104c6' -> '\x104ee'+ '\x104c7' -> '\x104ef'+ '\x104c8' -> '\x104f0'+ '\x104c9' -> '\x104f1'+ '\x104ca' -> '\x104f2'+ '\x104cb' -> '\x104f3'+ '\x104cc' -> '\x104f4'+ '\x104cd' -> '\x104f5'+ '\x104ce' -> '\x104f6'+ '\x104cf' -> '\x104f7'+ '\x104d0' -> '\x104f8'+ '\x104d1' -> '\x104f9'+ '\x104d2' -> '\x104fa'+ '\x104d3' -> '\x104fb'+ '\x10570' -> '\x10597'+ '\x10571' -> '\x10598'+ '\x10572' -> '\x10599'+ '\x10573' -> '\x1059a'+ '\x10574' -> '\x1059b'+ '\x10575' -> '\x1059c'+ '\x10576' -> '\x1059d'+ '\x10577' -> '\x1059e'+ '\x10578' -> '\x1059f'+ '\x10579' -> '\x105a0'+ '\x1057a' -> '\x105a1'+ '\x1057c' -> '\x105a3'+ '\x1057d' -> '\x105a4'+ '\x1057e' -> '\x105a5'+ '\x1057f' -> '\x105a6'+ '\x10580' -> '\x105a7'+ '\x10581' -> '\x105a8'+ '\x10582' -> '\x105a9'+ '\x10583' -> '\x105aa'+ '\x10584' -> '\x105ab'+ '\x10585' -> '\x105ac'+ '\x10586' -> '\x105ad'+ '\x10587' -> '\x105ae'+ '\x10588' -> '\x105af'+ '\x10589' -> '\x105b0'+ '\x1058a' -> '\x105b1'+ '\x1058c' -> '\x105b3'+ '\x1058d' -> '\x105b4'+ '\x1058e' -> '\x105b5'+ '\x1058f' -> '\x105b6'+ '\x10590' -> '\x105b7'+ '\x10591' -> '\x105b8'+ '\x10592' -> '\x105b9'+ '\x10594' -> '\x105bb'+ '\x10595' -> '\x105bc'+ '\x10c80' -> '\x10cc0'+ '\x10c81' -> '\x10cc1'+ '\x10c82' -> '\x10cc2'+ '\x10c83' -> '\x10cc3'+ '\x10c84' -> '\x10cc4'+ '\x10c85' -> '\x10cc5'+ '\x10c86' -> '\x10cc6'+ '\x10c87' -> '\x10cc7'+ '\x10c88' -> '\x10cc8'+ '\x10c89' -> '\x10cc9'+ '\x10c8a' -> '\x10cca'+ '\x10c8b' -> '\x10ccb'+ '\x10c8c' -> '\x10ccc'+ '\x10c8d' -> '\x10ccd'+ '\x10c8e' -> '\x10cce'+ '\x10c8f' -> '\x10ccf'+ '\x10c90' -> '\x10cd0'+ '\x10c91' -> '\x10cd1'+ '\x10c92' -> '\x10cd2'+ '\x10c93' -> '\x10cd3'+ '\x10c94' -> '\x10cd4'+ '\x10c95' -> '\x10cd5'+ '\x10c96' -> '\x10cd6'+ '\x10c97' -> '\x10cd7'+ '\x10c98' -> '\x10cd8'+ '\x10c99' -> '\x10cd9'+ '\x10c9a' -> '\x10cda'+ '\x10c9b' -> '\x10cdb'+ '\x10c9c' -> '\x10cdc'+ '\x10c9d' -> '\x10cdd'+ '\x10c9e' -> '\x10cde'+ '\x10c9f' -> '\x10cdf'+ '\x10ca0' -> '\x10ce0'+ '\x10ca1' -> '\x10ce1'+ '\x10ca2' -> '\x10ce2'+ '\x10ca3' -> '\x10ce3'+ '\x10ca4' -> '\x10ce4'+ '\x10ca5' -> '\x10ce5'+ '\x10ca6' -> '\x10ce6'+ '\x10ca7' -> '\x10ce7'+ '\x10ca8' -> '\x10ce8'+ '\x10ca9' -> '\x10ce9'+ '\x10caa' -> '\x10cea'+ '\x10cab' -> '\x10ceb'+ '\x10cac' -> '\x10cec'+ '\x10cad' -> '\x10ced'+ '\x10cae' -> '\x10cee'+ '\x10caf' -> '\x10cef'+ '\x10cb0' -> '\x10cf0'+ '\x10cb1' -> '\x10cf1'+ '\x10cb2' -> '\x10cf2'+ '\x118a0' -> '\x118c0'+ '\x118a1' -> '\x118c1'+ '\x118a2' -> '\x118c2'+ '\x118a3' -> '\x118c3'+ '\x118a4' -> '\x118c4'+ '\x118a5' -> '\x118c5'+ '\x118a6' -> '\x118c6'+ '\x118a7' -> '\x118c7'+ '\x118a8' -> '\x118c8'+ '\x118a9' -> '\x118c9'+ '\x118aa' -> '\x118ca'+ '\x118ab' -> '\x118cb'+ '\x118ac' -> '\x118cc'+ '\x118ad' -> '\x118cd'+ '\x118ae' -> '\x118ce'+ '\x118af' -> '\x118cf'+ '\x118b0' -> '\x118d0'+ '\x118b1' -> '\x118d1'+ '\x118b2' -> '\x118d2'+ '\x118b3' -> '\x118d3'+ '\x118b4' -> '\x118d4'+ '\x118b5' -> '\x118d5'+ '\x118b6' -> '\x118d6'+ '\x118b7' -> '\x118d7'+ '\x118b8' -> '\x118d8'+ '\x118b9' -> '\x118d9'+ '\x118ba' -> '\x118da'+ '\x118bb' -> '\x118db'+ '\x118bc' -> '\x118dc'+ '\x118bd' -> '\x118dd'+ '\x118be' -> '\x118de'+ '\x118bf' -> '\x118df'+ '\x16e40' -> '\x16e60'+ '\x16e41' -> '\x16e61'+ '\x16e42' -> '\x16e62'+ '\x16e43' -> '\x16e63'+ '\x16e44' -> '\x16e64'+ '\x16e45' -> '\x16e65'+ '\x16e46' -> '\x16e66'+ '\x16e47' -> '\x16e67'+ '\x16e48' -> '\x16e68'+ '\x16e49' -> '\x16e69'+ '\x16e4a' -> '\x16e6a'+ '\x16e4b' -> '\x16e6b'+ '\x16e4c' -> '\x16e6c'+ '\x16e4d' -> '\x16e6d'+ '\x16e4e' -> '\x16e6e'+ '\x16e4f' -> '\x16e6f'+ '\x16e50' -> '\x16e70'+ '\x16e51' -> '\x16e71'+ '\x16e52' -> '\x16e72'+ '\x16e53' -> '\x16e73'+ '\x16e54' -> '\x16e74'+ '\x16e55' -> '\x16e75'+ '\x16e56' -> '\x16e76'+ '\x16e57' -> '\x16e77'+ '\x16e58' -> '\x16e78'+ '\x16e59' -> '\x16e79'+ '\x16e5a' -> '\x16e7a'+ '\x16e5b' -> '\x16e7b'+ '\x16e5c' -> '\x16e7c'+ '\x16e5d' -> '\x16e7d'+ '\x16e5e' -> '\x16e7e'+ '\x16e5f' -> '\x16e7f'+ '\x1e900' -> '\x1e922'+ '\x1e901' -> '\x1e923'+ '\x1e902' -> '\x1e924'+ '\x1e903' -> '\x1e925'+ '\x1e904' -> '\x1e926'+ '\x1e905' -> '\x1e927'+ '\x1e906' -> '\x1e928'+ '\x1e907' -> '\x1e929'+ '\x1e908' -> '\x1e92a'+ '\x1e909' -> '\x1e92b'+ '\x1e90a' -> '\x1e92c'+ '\x1e90b' -> '\x1e92d'+ '\x1e90c' -> '\x1e92e'+ '\x1e90d' -> '\x1e92f'+ '\x1e90e' -> '\x1e930'+ '\x1e90f' -> '\x1e931'+ '\x1e910' -> '\x1e932'+ '\x1e911' -> '\x1e933'+ '\x1e912' -> '\x1e934'+ '\x1e913' -> '\x1e935'+ '\x1e914' -> '\x1e936'+ '\x1e915' -> '\x1e937'+ '\x1e916' -> '\x1e938'+ '\x1e917' -> '\x1e939'+ '\x1e918' -> '\x1e93a'+ '\x1e919' -> '\x1e93b'+ '\x1e91a' -> '\x1e93c'+ '\x1e91b' -> '\x1e93d'+ '\x1e91c' -> '\x1e93e'+ '\x1e91d' -> '\x1e93f'+ '\x1e91e' -> '\x1e940'+ '\x1e91f' -> '\x1e941'+ '\x1e920' -> '\x1e942'+ '\x1e921' -> '\x1e943'+ c -> c+{-# NOINLINE caseFoldSimple #-}
+ src/Regex/Internal/List.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE BangPatterns #-}+module Regex.Internal.List+ (+ list+ , manyList+ , someList+ , manyListMin+ , someListMin++ , charIgnoreCase+ , oneOfChar+ , stringIgnoreCase+ , manyStringOf+ , someStringOf+ , manyStringOfMin+ , someStringOfMin++ , naturalDec+ , integerDec+ , naturalHex+ , integerHex+ , wordRangeDec+ , intRangeDec+ , wordRangeHex+ , intRangeHex+ , wordDecN+ , wordHexN++ , toMatch+ , withMatch++ , reParse+ , parse+ , parseSure++ , find+ , findAll+ , splitOn+ , replace+ , replaceAll+ ) where++import Control.Applicative+import Data.Char+import Data.Maybe (fromMaybe)+import Numeric.Natural++import Data.CharSet (CharSet)+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 qualified Regex.Internal.Regex as R+import qualified Regex.Internal.Num as RNum+import qualified Regex.Internal.Generated.CaseFold as CF++------------------------+-- REs and combinators+------------------------++-- | Parse the given list.+list :: Eq c => [c] -> RE c [c]+list xs = xs <$ foldr ((*>) . R.single) (pure ()) xs++-- | Parse any list. Biased towards matching more.+manyList :: RE c [c]+manyList = many R.anySingle++-- | Parse any non-empty list. Biased towards matching more.+someList :: RE c [c]+someList = some R.anySingle++-- | Parse any list. Minimal, i.e. biased towards matching less.+manyListMin :: RE c [c]+manyListMin = R.manyMin R.anySingle++-- | Parse any non-empty @String@. Minimal, i.e. biased towards matching less.+someListMin :: RE c [c]+someListMin = R.someMin R.anySingle++-----------+-- String+-----------++-- | Parse the given @Char@, ignoring case.+--+-- Comparisons are performed after applying+-- [simple case folding](https://www.unicode.org/reports/tr44/#Simple_Case_Folding)+-- as described by the Unicode standard.+charIgnoreCase :: Char -> RE Char Char+charIgnoreCase c = R.satisfy $ (c'==) . CF.caseFoldSimple+ where+ !c' = CF.caseFoldSimple c+-- See Note [Why simple case fold] in Regex.Internal.Text++-- | Parse a @Char@ if it is a member of the @CharSet@.+oneOfChar :: CharSet -> RE Char Char+oneOfChar !cs = R.satisfy (`CS.member` cs)++-- | Parse the given @String@, ignoring case.+--+-- Comparisons are performed after applying+-- [simple case folding](https://www.unicode.org/reports/tr44/#Simple_Case_Folding)+-- as described by the Unicode standard.+stringIgnoreCase :: String -> RE Char String+stringIgnoreCase = foldr (R.liftA2' (:) . charIgnoreCase) (pure [])+-- See Note [Why simple case fold] in Regex.Internal.Text++-- | Parse any @String@ containing members of the @CharSet@.+-- Biased towards matching more.+manyStringOf :: CharSet -> RE Char String+manyStringOf !cs = many (R.satisfy (`CS.member` cs))++-- | Parse any non-empty @String@ containing members of the @CharSet@.+-- Biased towards matching more.+someStringOf :: CharSet -> RE Char String+someStringOf !cs = some (R.satisfy (`CS.member` cs))++-- | Parse any @String@ containing members of the @CharSet@.+-- Minimal, i.e. biased towards matching less.+manyStringOfMin :: CharSet -> RE Char String+manyStringOfMin !cs = R.manyMin (R.satisfy (`CS.member` cs))++-- | Parse any non-empty @String@ containing members of the @CharSet@.+-- Minimal, i.e. biased towards matching less.+someStringOfMin :: CharSet -> RE Char String+someStringOfMin !cs = R.someMin (R.satisfy (`CS.member` cs))++-----------------+-- Numeric REs+-----------------++-- | Parse a decimal @Natural@.+-- Leading zeros are not accepted. Biased towards matching more.+naturalDec :: RE Char Natural+naturalDec = RNum.mkNaturalDec digitRange++-- | Parse a decimal @Integer@. Parse an optional sign, @\'-\'@ or @\'+\'@,+-- followed by the given @RE@, followed by the absolute value of the integer.+-- Leading zeros are not accepted. Biased towards matching more.+integerDec :: RE Char a -> RE Char Integer+integerDec sep = RNum.mkSignedInteger minus plus (sep *> naturalDec)++-- | Parse a hexadecimal @Natural@. Both uppercase @\'A\'..\'F\'@ and lowercase+-- @\'a\'..\'f\'@ are accepted.+-- Leading zeros are not accepted. Biased towards matching more.+naturalHex :: RE Char Natural+naturalHex = RNum.mkNaturalHex hexDigitRange++-- | Parse a hexadecimal @Integer@. Parse an optional sign, @\'-\'@ or @\'+\'@,+-- followed by the given @RE@, followed by the absolute value of the integer.+-- Both uppercase @\'A\'..\'F\'@ and lowercase @\'a\'..\'f\'@ are accepted.+-- Leading zeros are not accepted. Biased towards matching more.+integerHex :: RE Char a -> RE Char Integer+integerHex sep = RNum.mkSignedInteger minus plus (sep *> naturalHex)++-- | Parse a decimal @Word@ in the range @[low..high]@.+-- Leading zeros are not accepted. Biased towards matching more.+wordRangeDec :: (Word, Word) -> RE Char Word+wordRangeDec lh = RNum.mkWordRangeDec digitRange lh++-- | Parse a decimal @Int@ in the range @[low..high]@. Parse an optional sign,+-- @\'-\'@ or @\'+\'@, followed by the given @RE@, followed by the absolute+-- value of the integer.+-- Leading zeros are not accepted. Biased towards matching more.+intRangeDec :: RE Char a -> (Int, Int) -> RE Char Int+intRangeDec sep lh =+ RNum.mkSignedIntRange minus plus ((sep *>) . wordRangeDec) lh++-- | Parse a hexadecimal @Word@ in the range @[low..high]@. Both uppercase+-- @\'A\'..\'F\'@ and lowercase @\'a\'..\'f\'@ are accepted.+-- Leading zeros are not accepted. Biased towards matching more.+wordRangeHex :: (Word, Word) -> RE Char Word+wordRangeHex lh = RNum.mkWordRangeHex hexDigitRange lh++-- | Parse a hexadecimal @Int@ in the range @[low..high]@. Parse an optional+-- sign, @\'-\'@ or @\'+\'@, followed by the given @RE@, followed by the+-- absolute value of the integer.+-- Both uppercase @\'A\'..\'F\'@ and lowercase @\'a\'..\'f\'@ are accepted.+-- Leading zeros are not accepted. Biased towards matching more.+intRangeHex :: RE Char a -> (Int, Int) -> RE Char Int+intRangeHex sep lh =+ RNum.mkSignedIntRange minus plus ((sep *>) . wordRangeHex) lh++-- | Parse a @Word@ of exactly n decimal digits, including any leading zeros.+-- Will not parse values that do not fit in a @Word@.+-- Biased towards matching more.+wordDecN :: Int -> RE Char Word+wordDecN n = RNum.mkWordDecN digitRange n++-- | Parse a @Word@ of exactly n hexadecimal digits, including any leading+-- zeros. Both uppercase @\'A\'..\'F\'@ and lowercase @\'a\'..\'f\'@ are+-- accepted. Will not parse values that do not fit in a @Word@.+-- Biased towards matching more.+wordHexN :: Int -> RE Char Word+wordHexN n = RNum.mkWordHexN hexDigitRange n++minus, plus :: RE Char ()+minus = R.token $ \c -> if c == '-' then Just () else Nothing+plus = R.token $ \c -> if c == '+' then Just () else Nothing++-- l and h must be in [0..9]+digitRange :: Word -> Word -> RE Char Word+digitRange !l !h = R.token $ \c ->+ let d = fromIntegral (ord c - ord '0')+ in if l <= d && d <= h then Just d else Nothing++-- l and h must be in [0..15]+hexDigitRange :: Word -> Word -> RE Char Word+hexDigitRange !l !h = R.token $ \c ->+ let dec = fromIntegral (ord c - ord '0')+ hexl = fromIntegral (ord c - ord 'a')+ hexu = fromIntegral (ord c - ord 'A')+ in do+ d <- case () of+ _ | dec <= 9 -> Just dec+ | hexl <= 5 -> Just $! 10 + hexl+ | hexu <= 5 -> Just $! 10 + hexu+ | otherwise -> Nothing+ if l <= d && d <= h then Just d else Nothing++----------------+-- Match stuff+----------------++-- | Rebuild the @RE@ such that the result is the matched section of the list+-- instead.+toMatch :: RE c a -> RE c [c]+toMatch = fmap dToL . toMatch_++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+ 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)++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++instance Applicative (WithMatch c) where+ pure = WM mempty+ liftA2 f (WM t1 x) (WM t2 y) = WM (t1 <> t2) (f x y)++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++-- | Rebuild the @RE@ to include the matched section of the list alongside the+-- result.+withMatch :: RE c a -> RE c ([c], a)+withMatch = R.fmap' (\(WM cs x) -> (dToL cs, x)) . go+ 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 -> liftA2 f+ in RLiftA2 Strict g (go re1) (go re2)+ REmpty -> REmpty+ RAlt re1 re2 -> RAlt (go re1) (go re2)+ 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 -> liftA2 f+ in RFold Strict gr g (pure z) (go re1)++----------+-- Parse+----------++-- | \(O(mn \log m)\). Parse a list with a @RE@.+--+-- Uses 'Regex.List.compile', see the note there.+--+-- If parsing multiple lists using the same @RE@, it is wasteful to compile+-- the @RE@ every time. So, prefer to+--+-- * Compile once with 'Regex.List.compile' or 'Regex.List.compileBounded' and+-- use the compiled 'Parser' with 'parse' as many times as required.+-- * Alternately, partially apply this function to a @RE@ and use the function+-- as many times as required.+reParse :: RE c a -> [c] -> Maybe a+reParse re = let !p = P.compile re in parse p+{-# INLINE reParse #-}++-- | \(O(mn \log m)\). Parse a list with a @Parser@.+parse :: Parser c a -> [c] -> Maybe a+parse = P.parseFoldr foldr+{-# INLINE parse #-}++-- | \(O(mn \log m)\). Parse a list with a @Parser@. Calls 'error' on+-- parse failure.+--+-- For use with parsers that are known to never fail.+parseSure :: Parser c a -> [c] -> a+parseSure p = fromMaybe parseSureError . parse p+{-# INLINE parseSure #-}++parseSureError :: a+parseSureError = errorWithoutStackTrace+ "Regex.List.parseSure: parse failed; if parsing can fail use 'parse' instead"++reParseSure :: RE c a -> [c] -> a+reParseSure re = let !p = P.compile re in parseSure p+{-# INLINE reParseSure #-}++-- | \(O(mn \log m)\). Find the first occurence of the given @RE@ in a list.+--+-- ==== __Examples__+--+-- >>> find (list "meow") "homeowner"+-- Just "meow"+--+-- To test whether a list is present in another list, like above, prefer+-- @Data.List.'Data.List.isInfixOf'@.+--+-- >>> find (stringIgnoreCase "haskell") "Look I'm Haskelling!"+-- Just "Haskell"+-- >>> find (list "backtracking") "parser-regex"+-- Nothing+--+find :: RE c a -> [c] -> Maybe a+find = reParse . R.toFind+{-# INLINE find #-}++-- | \(O(mn \log m)\). Find all non-overlapping occurences of the given @RE@ in+-- the list.+--+-- ==== __Examples__+--+-- >>> findAll (list "ana") "banananana"+-- ["ana","ana"]+--+-- @+-- data Roll = Roll+-- Natural -- ^ Rolls+-- Natural -- ^ Faces on the die+-- deriving Show+--+-- roll :: RE Char Roll+-- roll = Roll \<$> ('naturalDec' \<|> pure 1) \<* 'R.single' \'d\' \<*> naturalDec+-- @+--+-- >>> findAll roll "3d6, d10, 2d10"+-- [Roll 3 6,Roll 1 10,Roll 2 10]+--+findAll :: RE c a -> [c] -> [a]+findAll = reParseSure . R.toFindMany+{-# INLINE findAll #-}++-- | \(O(mn \log m)\). Split a list at occurences of the given @RE@.+--+-- ==== __Examples__+--+-- >>> splitOn (single ' ') "Glasses are really versatile"+-- ["Glasses","are","really","versatile"]+--+-- In cases like above, prefer using 'words' or 'lines' instead, if+-- applicable.+--+-- >>> splitOn (single ' ' *> oneOfChar "+-=" *> single ' ') "3 - 1 + 1/2 - 2 = 0"+-- ["3","1","1/2","2","0"]+--+-- If the list starts or ends with a delimiter, the result will contain+-- empty lists at those positions.+--+-- >>> splitOn (single 'a') "ayaya"+-- ["","y","y",""]+--+splitOn :: RE c a -> [c] -> [[c]]+splitOn = reParseSure . toSplitOn+{-# INLINE splitOn #-}++toSplitOn :: RE c a -> RE c [[c]]+toSplitOn re = manyListMin `R.sepBy` re++-- | \(O(mn \log m)\). Replace the first match of the given @RE@ with its+-- result. If there is no match, the result is @Nothing@.+--+-- ==== __Examples__+--+-- >>> replace ("world" <$ list "Haskell") "Hello, Haskell!"+-- Just "Hello, world!"+--+-- >>> replace ("," <$ some (single '.')) "one...two...ten"+-- Just "one,two...ten"+--+replace :: RE c [c] -> [c] -> Maybe [c]+replace = reParse . toReplace+{-# INLINE replace #-}++toReplace :: RE c [c] -> RE c [c]+toReplace re = liftA2 f manyListMin re <*> manyList+ where+ f a b c = concat [a,b,c]++-- | \(O(mn \log m)\). Replace non-overlapping matches of the given @RE@ with+-- their results.+--+-- ==== __Examples__+--+-- >>> replaceAll (" and " <$ list ", ") "red, blue, green"+-- "red and blue and green"+--+-- >>> replaceAll ("Fruit" <$ list "Time" <|> "banana" <$ list "arrow") "Time flies like an arrow"+-- "Fruit flies like a banana"+--+-- @+-- sep = 'oneOfChar' "-./"+-- digits n = 'replicateM' n (oneOfChar 'Data.CharSet.digit')+-- toYmd d m y = concat [y, \"-\", m, \"-\", d]+-- date = toYmd \<$> digits 2 \<* sep+-- \<*> digits 2 \<* sep+-- \<*> digits 4+-- @+-- >>> replaceAll date "01/01/1970, 01-04-1990, 03.07.2011"+-- "1970-01-01, 1990-04-01, 2011-07-03"+--+replaceAll :: RE c [c] -> [c] -> [c]+replaceAll = reParseSure . toReplaceMany+{-# INLINE replaceAll #-}++toReplaceMany :: RE c [c] -> RE c [c]+toReplaceMany re = concat <$> many (re <|> R.token (Just . (:[])))++---------------------+-- Difference lists+---------------------++newtype DList a = DList { unDList :: [a] -> [a] }++instance Semigroup (DList a) where+ xs <> ys = DList (unDList xs . unDList ys)++instance Monoid (DList a) where+ mempty = DList id++singletonD :: a -> DList a+singletonD = DList . (:)++dToL :: DList a -> [a]+dToL = ($ []) . unDList++----------+-- Notes+----------++-- Note [Token for Regex.List]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Regex.Text uses a token TextToken, but Regex.List doesn't, why?+--+-- TextToken is used for efficient slicing, but here a DList is used for that+-- purpose. This has the effect that combinators like manyText and friends+-- don't need to allocate a linear amount of memory, since slicing is free, but+-- manyList and friends do. We could use a token type for list like+--+-- data Take a = Take !Int ![a]+--+-- to refer to the input list and save memory.+--+-- This is not done because+-- * It increases complexity. Currently this module offers the simplest possible+-- application of RE, which is nice to have.+-- * If the list does not already exist in memory, Take would keep the entire+-- list alive in memory instead of the just the slice it needs.+-- * The current implementation is a good consumer, which can fuse with a good+-- producer of the input list.+--+-- In the end it is about the two distinct use cases of lists in Haskell:+-- * As a structure in memory, the Take token would be the better choice+-- * As a stream of elements, the current implementation is the better choice
+ src/Regex/Internal/Num.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Regex.Internal.Num+ ( mkNaturalDec+ , mkWordDecN+ , mkWordRangeDec+ , mkNaturalHex+ , mkWordHexN+ , mkWordRangeHex+ , mkSignedInteger+ , mkSignedIntRange+ ) where++#include "MachDeps.h"++import Control.Applicative+import Control.Monad+import Data.Primitive.PrimArray+import Data.Bits+import Numeric.Natural++import GHC.Num.Natural as Nat++import Regex.Internal.Regex (RE)+import qualified Regex.Internal.Regex as R++mkNaturalDec+ :: (Word -> Word -> RE c Word) -- Decimal digit range+ -> RE c Natural+mkNaturalDec d =+ 0 <$ d 0 0+ <|> 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+{-# INLINE mkNaturalDec #-}++mkNaturalHex+ :: (Word -> Word -> RE c Word) -- Hexadecimal digit range+ -> RE c Natural+mkNaturalHex d =+ 0 <$ d 0 0+ <|> 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+{-# INLINE mkNaturalHex #-}++mkSignedInteger :: RE c minus -> RE c plus -> RE c Natural -> RE c Integer+mkSignedInteger minus plus rnat = signed <*> rnat+ where+ signed = negate . fromIntegral <$ minus+ <|> fromIntegral <$ plus+ <|> pure fromIntegral++mkWordDecN+ :: (Word -> Word -> RE c Word) -- Decimal digit range+ -> Int+ -> RE c Word+mkWordDecN d n0+ | n0 <= 0 = empty+ | maxBoundWordDecLen <= n0 =+ replicateM_ (n0 - maxBoundWordDecLen) d00 *>+ ( d00 *> go (maxBoundWordDecLen - 1)+ <|> mkWordRangeDec d (pow10 safeWordDecLen, maxBound) )+ | otherwise = go n0+ where+ go 1 = d09+ go n = R.liftA2' (\x y -> x * 10 + y) (go (n-1)) d09+ d00 = d 0 0+ d09 = d 0 9+{-# INLINE mkWordDecN #-}++mkWordHexN+ :: (Word -> Word -> RE c Word) -- Hexadecimal digit range+ -> Int+ -> RE c Word+mkWordHexN d n0+ | n0 <= 0 = empty+ | maxBoundWordHexLen < n0 =+ replicateM_ (n0 - maxBoundWordHexLen) d00 *> go maxBoundWordHexLen+ | otherwise = go n0+ where+ go 1 = d0f+ go n = R.liftA2' (\x y -> x * 16 + y) (go (n-1)) d0f+ d00 = d 0 0+ d0f = d 0 15+{-# INLINE mkWordHexN #-}++mkWordRangeDec+ :: (Word -> Word -> RE c Word) -- Decimal digit range+ -> (Word, Word) -- Low high+ -> RE c Word+mkWordRangeDec d (l,h) = mkWordRangeBase 10 quotRemPow10 pow10 len10 d l h+ where+ quotRemPow10 i x = x `quotRem` pow10 i+{-# INLINE mkWordRangeDec #-}++mkWordRangeHex+ :: (Word -> Word -> RE c Word) -- Hexadecimal digit range+ -> (Word, Word) -- Low high+ -> RE c Word+mkWordRangeHex d (l,h) = mkWordRangeBase 16 quotRemPow16 pow16 len16 d l h+ where+ quotRemPow16 i x = (x `unsafeShiftR` (4*i), x .&. (pow16 i - 1))+{-# INLINE mkWordRangeHex #-}++mkSignedIntRange+ :: RE c minus+ -> RE c plus+ -> ((Word, Word) -> RE c Word) -- Word range+ -> (Int, Int) -- Low high+ -> RE c Int+mkSignedIntRange minus plus wordRangeDec (low,high) = case (negR, nonNegR) of+ (Nothing, Nothing) -> empty+ (Nothing, Just r2) -> r2+ (Just r1, Nothing) -> r1+ (Just r1, Just r2) -> r1 <|> r2+ where+ negR+ | low > 0 = Nothing+ | otherwise = Just $+ minus *>+ R.fmap' (negate . fromIntegral)+ (wordRangeDec (absw (min 0 high), absw low))+ nonNegR+ | high < 0 = Nothing+ | otherwise = Just $+ (void plus <|> pure ()) *>+ R.fmap' fromIntegral+ (wordRangeDec (fromIntegral (max 0 low), fromIntegral high))+{-# INLINE mkSignedIntRange #-}++absw :: Int -> Word+absw x = if x == minBound+ then fromIntegral (abs (x+1) + 1)+ else fromIntegral (abs x)++-------------------+-- Parsing ranges+-------------------++-- Make a tree based on the range. Keep the tree size small where possible.+-- This is hard to explain in words, so see here for some pictures:+-- https://github.com/meooow25/parser-regex/wiki/Visualizations#int-range++mkWordRangeBase+ :: forall c.+ Word -- Base+ -> (Int -> Word -> (Word, Word)) -- quotRemPowBase+ -> (Int -> Word) -- powBase+ -> (Word -> Int) -- baseLen+ -> (Word -> Word -> RE c Word) -- Decimal digit range+ -> Word -- Low+ -> Word -- High+ -> RE c Word+mkWordRangeBase _ _ _ _ _ low high | low > high = empty+mkWordRangeBase base quotRemPowBase powBase baseLen d low high+ = goTop (baseLen high - 1) True low high+ where+ goTop :: Int -> Bool -> Word -> Word -> RE c Word+ goTop 0 _ l h = d l h+ goTop i lz l h+ | dl == dh = leading pBase dh dh (goTop (i-1) False l' h')+ | fullL && fullH = leading pBase dl dh (goFull (i-1))+ | fullH = leading pBase (dl+1) dh (goFull (i-1)) <|> reL+ | fullL = reH <|> leading pBase dl (dh-1) (goFull (i-1))+ | dl + 1 == dh = reH <|> reL+ | otherwise = reH <|> reM <|> reL+ where+ pBase = powBase i+ (dl,l') = quotRemPowBase i l+ (dh,h') = quotRemPowBase i h+ lz' = lz && dl == 0+ fullL = not lz' && l' == 0+ fullH = h' + 1 == pBase+ reL = if lz'+ then goL (i-1) True l'+ else leading pBase dl dl (goL (i-1) False l')+ reH = leading pBase dh dh (goH (i-1) h')+ reM = leading pBase (dl+1) (dh-1) (goFull (i-1))++ goL :: Int -> Bool -> Word -> RE c Word+ goL 0 _ l = d l (base-1)+ goL i lz l+ | not lz && l == 0 = goFull i+ | dl == base-1 = reL+ | otherwise = reM <|> reL+ where+ pBase = powBase i+ (dl,l') = quotRemPowBase i l+ reL = if lz && dl == 0+ then goL (i-1) True l'+ else leading pBase dl dl (goL (i-1) False l')+ reM = leading pBase (dl+1) (base-1) (goFull (i-1))++ goH :: Int -> Word -> RE c Word+ goH 0 h = d 0 h+ goH i h+ | h + 1 == pBase * base = goFull i+ | dh == 0 = reH+ | otherwise = reH <|> reM+ where+ pBase = powBase i+ (dh,h') = quotRemPowBase i h+ reH = leading pBase dh dh (goH (i-1) h')+ reM = leading pBase 0 (dh-1) (goFull (i-1))++ goFull :: Int -> RE c Word+ goFull 0 = d 0 (base-1)+ goFull i = leading (powBase i) 0 (base-1) (goFull (i-1))++ leading :: Word -> Word -> Word -> RE c Word -> RE c Word+ leading !pBase dl dh = R.liftA2' (\x y -> x * pBase + y) (d dl dh)+{-# INLINE mkWordRangeBase #-}++---------------------------------+-- Parsing hexadecimal Naturals+---------------------------------++-- 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.++stepHex :: NatParseState -> Word -> NatParseState+stepHex (NatParseState acc len ns) d+ | len < maxBoundWordHexLen = NatParseState (acc*16 + d) (len+1) ns+ | otherwise = NatParseState d 1 (WCons acc ns)++finishHex+ :: Word -- ^ Leading digit+ -> NatParseState -- ^ Everything else+ -> Natural+finishHex !ld (NatParseState acc0 len0 ns0) = case ns0 of+ WNil -> Nat.naturalFromWord (ld `unsafeShiftL` (4*(len0-1)) + acc0)+ WCons n ns1 ->+ let lns = lengthWList ns1 + 2+ wsz = WORD_SIZE_IN_BITS+ !(PrimArray byteArray) = runPrimArray $ do+ ma <- newPrimArray lns+ if len0 == maxBoundWordHexLen+ then do+ let go i n1 WNil = do+ let n1' = ld `unsafeShiftL` (4*(maxBoundWordHexLen-1)) + n1+ writePrimArray ma i n1'+ go i n1 (WCons n2 ns2) = do+ writePrimArray ma i n1+ go (i+1) n2 ns2+ writePrimArray ma 0 acc0+ go 1 n ns1+ else do+ let go i prv n1 WNil = do+ let n1' = ld `unsafeShiftL` (4*(maxBoundWordHexLen-1)) + n1+ writePrimArray ma i (prv + n1' `unsafeShiftL` (4*len0))+ writePrimArray ma (i+1) (n1' `unsafeShiftR` (wsz - 4*len0))+ go i prv n1 (WCons n2 ns2) = do+ writePrimArray ma i (prv + n1 `unsafeShiftL` (4*len0))+ go (i+1) (n1 `unsafeShiftR` (wsz - 4*len0)) n2 ns2+ go 0 acc0 n ns1+ pure ma+ in Nat.NB byteArray+-- finishHex does a bunch of unsafe stuff, so make sure things are correct:+-- * Bit shifts are in [0..wsz-1]+-- * 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.++-----------------------------+-- Parsing decimal Naturals+-----------------------------++-- The implementation below is adapted from the bytestring package.+-- https://github.com/haskell/bytestring/blob/7e11412b9bfb13bcd6b8e7c04765b8f5bd90fd34/Data/ByteString/Lazy/ReadNat.hs+--+-- Step 1: Accumulate the digits, packed into Words.+-- Step 2: Combine the packed Words bottom-up into the result. This is what+-- makes it better than foldl (\acc d -> acc * 10 + d)).+--+-- 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.+--+-- 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++stepDec :: NatParseState -> Word -> NatParseState+stepDec (NatParseState acc len ns) d+ | len < safeWordDecLen = NatParseState (10*acc + d) (len+1) ns+ | otherwise = NatParseState d 1 (WCons acc ns)++finishDec+ :: Word -- ^ Leading digit+ -> NatParseState -- ^ Everything else+ -> Natural+finishDec !ld (NatParseState acc0 len0 ns0) = combine acc0 len0 ns0+ where+ combine !acc !len ns = case ns of+ WNil -> w2n (10^(len-1) * ld + acc)+ WCons n ns1 -> 10^len * combine1 safeBaseDec (go n ns1) + w2n acc+ where+ go n WNil = let !n' = w2n (highMulDec * ld + n) in [n']+ go n (WCons m WNil) =+ let !n' = w2n (highMulDec * ld + m) * safeBaseDec + w2n n in [n']+ go n (WCons m (WCons n1 ns1)) =+ let !n' = w2n m * safeBaseDec + w2n n in n' : go n1 ns1++ combine1 _ [n] = n+ combine1 base ns1 = combine1 base1 (go ns1)+ where+ !base1 = base * base+ go (n:m:ns) = let !n' = m * base1 + n in n' : go ns+ go ns = ns++w2n :: Word -> Natural+w2n = fromIntegral++safeBaseDec :: Natural+safeBaseDec = fromIntegral (pow10 safeWordDecLen)++highMulDec :: Word+highMulDec = pow10 (safeWordDecLen - 1)++---------------------------+-- Common Natural parsing+---------------------------++data WList = WCons {-# UNPACK #-} !Word !WList | WNil++data NatParseState = NatParseState+ {-# UNPACK #-} !Word -- ^ acc+ {-# UNPACK #-} !Int -- ^ length of acc in some base+ !WList -- ^ accs, little endian++lengthWList :: WList -> Int+lengthWList = go 0+ where+ go !acc WNil = acc+ go acc (WCons _ ns) = go (acc+1) ns++--------------------+-- Low level stuff+--------------------++-- | Length in base 16.+len16 :: Word -> Int+len16 0 = 1+len16 x = maxBoundWordHexLen - (countLeadingZeros x `div` 4)++-- | 16^i. i must not be large enough to overflow a Word.+pow16 :: Int -> Word+pow16 i = 1 `unsafeShiftL` (4*i)++-- | Length in base 10.+len10 :: Word -> Int+len10 x = go 1 1+ where+ x' = x `quot` 10+ go p i | x' < p = i+ go p i = go (p*10) (i+1)++-- | "999..." repeated safeWordDecLen times is guaranteed to fit in a Word.+safeWordDecLen :: Int++-- | Decimal length of (maxBound :: Word)+maxBoundWordDecLen :: Int++-- | Hexadecimal length of (maxBound :: Word)+maxBoundWordHexLen :: Int++-- | 10^i. i must not be large enough to overflow a Word.+pow10 :: Int -> Word++#if WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64++#if WORD_SIZE_IN_BITS == 64+safeWordDecLen = 19+maxBoundWordDecLen = 20+maxBoundWordHexLen = 16+#else+safeWordDecLen = 9+maxBoundWordDecLen = 10+maxBoundWordHexLen = 8+#endif++pow10 p = case p of+ 0 -> 1+ 1 -> 10+ 2 -> 100+ 3 -> 1000+ 4 -> 10000+ 5 -> 100000+ 6 -> 1000000+ 7 -> 10000000+ 8 -> 100000000+ 9 -> 1000000000+#if WORD_SIZE_IN_BITS == 64+ 10 -> 10000000000+ 11 -> 100000000000+ 12 -> 1000000000000+ 13 -> 10000000000000+ 14 -> 100000000000000+ 15 -> 1000000000000000+ 16 -> 10000000000000000+ 17 -> 100000000000000000+ 18 -> 1000000000000000000+ 19 -> 10000000000000000000+#endif+ _ -> errorWithoutStackTrace "Regex.Internal.Int.pow10: p too large"+#else+#error "unsupported word size"+#endif
+ src/Regex/Internal/Parser.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Regex.Internal.Parser+ ( Parser(..)+ , Node(..)+ , compile+ , compileBounded++ , ParserState+ , prepareParser+ , stepParser+ , finishParser+ , Foldr+ , parseFoldr+ ) where++import Control.Applicative+import Control.Monad.Trans.State.Strict+import Control.Monad.Fix+import Data.Maybe (isJust)+import Data.Primitive.SmallArray+import qualified Data.Foldable as F++import Regex.Internal.Regex (RE(..), Strictness(..), Greediness(..))+import Regex.Internal.Unique (Unique(..), UniqueSet)+import qualified Regex.Internal.Unique as U++----------+-- Types+----------++-- | 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_ :: !(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+ PEmpty :: Parser c a+ PAlt :: !Unique -> !(Parser c a) -> !(Parser c a) -> !(SmallArray (Parser c a)) -> Parser c a+ PFoldGr :: !Unique -> !Strictness -> !(a -> a1 -> a) -> a -> !(Parser c a1) -> Parser c a+ PFoldMn :: !Unique -> !Strictness -> !(a -> a1 -> a) -> a -> !(Parser c a1) -> Parser c a+ PMany :: !Unique -> !(a1 -> a) -> !(a2 -> a) -> !(a2 -> a1 -> a2) -> !a2 -> !(Parser c a1) -> Parser c a++-- | A node in the NFA. Used for recognition.+data Node c a where+ NAccept :: a -> Node c a+ NGuard :: !Unique -> Node c a -> Node c a+ NToken :: !(c -> Maybe a1) -> !(Node c a) -> Node c a+ NEmpty :: Node c a+ NAlt :: !(Node c a) -> !(Node c a) -> !(SmallArray (Node c a)) -> Node c a+-- Note that NGuard is lazy in the node. We have to introduce laziness in+-- at least one place, to make a graph with loops possible.++------------+-- Compile+------------++-- | \(O(m)\). Compile a @RE c a@ to a @Parser c a@.+--+-- Note: @compile@ does not limit the size of the @RE@. See 'compileBounded'+-- if you would like to limit the size.+-- @RE@s with size greater than @(maxBound::Int) \`div\` 2@ are not supported+-- and the behavior of such a @RE@ is undefined.+compile :: RE c a -> Parser c a+compile re = evalState (compileToParser re) (Unique 0)++nxtU :: State Unique Unique+nxtU = state $ \u -> let !u' = Unique (unUnique u + 1) in (u, u')++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_ a re1 -> PFmap_ <$> compileToNode a re1+ RPure a -> pure $ PPure a+ RLiftA2 st f re1 re2 ->+ 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+ pure $ PAlt u p1 p2 (smallArrayFromList ps)+ RFold st gr 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+ RMany f1 f2 f z re1 -> do+ u <- nxtU+ _localU <- nxtU+ PMany u f1 f2 f z <$> compileToParser re1++compileToNode :: forall c a a1. a -> RE c a1 -> State Unique (Node c a)+compileToNode a re0 = go re0 (NAccept a)+ where+ 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+ RPure _ -> pure nxt+ RLiftA2 _ _ re1 re2 -> go re2 nxt >>= go re1+ REmpty -> pure NEmpty+ RAlt re01 re02 -> do+ u <- nxtU+ let nxt1 = NGuard u nxt+ (re1,re2,res) = gatherAlts re01 re02+ n1 <- go re1 nxt1+ n2 <- go re2 nxt1+ ns <- 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+ 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)++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"+ where+ go (RAlt re1 re2) = go re1 . go re2+ go re = (re:)++--------------------+-- Compile bounded+--------------------++-- | \(O(\min(l,m))\). Compile a @RE c a@ to a @Parser c a@.+--+-- Returns @Nothing@ if the size of the @RE@ is greater than the provided limit+-- \(l\). You may want to use this if you suspect that the @RE@ may be too+-- large, for instance if the regex is constructed from an untrusted source.+--+-- While the exact size of a @RE@ depends on an internal representation, it can+-- be assumed to be in the same order as the length of a+-- [regex pattern](https://en.wikipedia.org/wiki/Regular_expression#Syntax)+-- corresponding to the @RE@.+compileBounded :: Int -> RE c a -> Maybe (Parser c a)+compileBounded lim re =+ if checkSize lim re+ then Just $! compile re+ else Nothing++checkSize :: Int -> RE c a -> Bool+checkSize lim re0 = isJust (evalStateT (go re0) 0)+ where+ go :: RE c a1 -> StateT Int Maybe ()+ go re = case re of+ RToken _ -> inc+ RFmap _ _ re1 -> inc *> go re1+ RFmap_ _ re1 -> inc *> go re1+ RPure _ -> inc+ RLiftA2 _ _ re1 re2 -> inc *> go re1 *> go re2+ REmpty -> inc+ RAlt re1 re2 -> inc *> go re1 *> go re2+ RMany _ _ _ _ re1 -> inc *> go re1+ RFold _ _ _ _ re1 -> inc *> go re1+ inc = do+ n <- get+ if n == lim+ then empty+ else put $! n+1++----------+-- Parse+----------++data Cont c b a where+ CTop :: Cont c a a+ CFmap :: !Strictness -> !(b -> 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+ CAlt :: !Unique -> !(Cont c b a) -> Cont c b a+ CFoldGr :: !Unique -> !Strictness -> !(Parser c b) -> !(a1 -> b -> a1) -> a1 -> !(Cont c a1 a) -> Cont c b a+ CFoldMn :: !Unique -> !Strictness -> !(Parser c b) -> !(a1 -> b -> a1) -> a1 -> !(Cont c a1 a) -> Cont c b a+ CMany :: !Unique -> !(Parser c b) -> !(b -> a2) -> !(a1 -> a2) -> !(a1 -> b -> 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+ NeedCNil :: NeedCList c a++data StepState c a = StepState+ { sSet :: {-# UNPACK #-} !UniqueSet+ , sNeed :: !(NeedCList c a)+ , sResult :: !(Maybe a)+ }++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 -> State (StepState c a) Bool+sMember u = gets $ \pt -> U.member u (sSet pt)++sInsert :: Unique -> State (StepState c a) ()+sInsert u = modify' $ \pt -> pt { sSet = U.insert u (sSet pt) }++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_ n -> downNode n ct pt+ PPure b -> up b ct pt+ PLiftA2 st f p1 p2 -> down p1 (CLiftA2A st 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++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++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_ 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++localU :: Unique -> Unique+localU = Unique . (+1) . unUnique++--------------------+-- Running a Parser+--------------------++-- | The state maintained for parsing.+data ParserState c a = ParserState+ { psNeed :: !(NeedCList c a)+ , psResult :: !(Maybe a)+ }++-- | \(O(m \log m)\). Prepare a parser for input.+prepareParser :: Parser c a -> ParserState c a+prepareParser p = toParserState (down p CTop stepStateZero)++-- | \(O(m \log m)\). Step a parser by feeding a single element @c@. Returns+-- @Nothing@ if the parse 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+ NeedCNil -> Nothing+ needs -> Just $! toParserState (go needs)+ where+ go (NeedCCons t ct rest) =+ let !pt = go rest+ in maybe pt (\b -> up b ct pt) (t c)+ go NeedCNil = stepStateZero+{-# INLINE stepParser #-}++-- | \(O(1)\). Get the parse result for the input fed into the parser so far.+finishParser :: ParserState c a -> Maybe a+finishParser = psResult++toParserState :: StepState c a -> ParserState c a+toParserState pt = ParserState+ { psNeed = sNeed pt+ , psResult = sResult pt+ }++-- | A fold function.+type Foldr f a = forall b. (a -> b -> b) -> b -> f -> b++-- | \(O(mn \log m)\). Run a parser given a sequence @f@ and a fold of @f@.+parseFoldr :: Foldr f c -> Parser c a -> f -> Maybe a+parseFoldr fr = \p xs -> fr f finishParser xs (prepareParser p)+ where+ f c k = \ps -> stepParser ps c >>= k+{-# INLINE parseFoldr #-}++---------+-- Util+---------++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM mb mx = do+ b <- mb+ if b then pure () else mx++----------+-- Notes+----------++-- Note [About the algorithm]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- To parse using a regex, we compile the regex into a non-deterministic finite+-- automata (NFA). Actually, we only only do this for recognition, i.e. checking+-- whether a sequence satisfies a regex. This is done if the regex is a RFmap_.+--+-- To parse into a value, we have to do more work. We keep the regex as a tree+-- (Parser), but we preserve the path taken down the tree, like a zipper.+-- This lets us go up the tree and continue parsing, once we parse a c.+-- If you squint your eyes, this is also an NFA, only each edge of the NFA is+-- broken into multiple steps up and down the tree.+--+-- Recognition using the NFA is faster than parsing, unsurprisingly.+-- A Parser tree can have NFAs as children. This means that if some subtree of+-- the regex only attempts to recognize some input, it doesn't pay the extra+-- cost of parsing.+--+-- Key objective: O(mn log m) time parsing. This means that for every c fed into+-- the parser, we are allowed to take no more than O(m log m) time.+--+-- How is this ensured?+-- 1. The compiled regex must have O(m) nodes and O(m) edges. The Parser tree+-- satisfies this, of course, since it reflects the regex itself. The NFA+-- also satisfies this, implemented as Thompson's construction:+-- https://en.wikipedia.org/wiki/Thompson%27s_construction+-- 2. For every c, no edge is traversed twice. Tree edges are bidirectional+-- unlike NFA edges, so an NFA edge may be traversed only once and a tree+-- edge may be traversed once in each direction.+--+-- NFA guards: To ensure each NFA edge can be traversed only once, guard nodes+-- (NGuard) carry a Unique which can be stored in a set (sSet). Guard nodes are+-- created during compilation whenever two nodes would lead into one node:+-- A->C, B->C. A guard node is added, such that it becomes A->G, B->G, G->C.+--+-- Parser guards: Parser guards are more tricky.+-- Alt: There are two ways into an Alt node when going up. So, an Alt node+-- carries a Unique is stored in sSet and guards upward travel through the+-- node.+-- FoldGr: There are two ways into a FoldGr node, one going down and one going+-- up. But, we can't just a use a Unique to guard entry into it because we+-- want to handle loopy cases correctly! A loopy case is where we reach the+-- same node in the tree by going up and down the edges without consuming+-- input. To detect this, we use a separate Unique (localU) when going down.+-- If we find it set when going up, we are looping. When we send up a value,+-- looping or not, we guard entry into the node using its (not localU) Unique.+-- Many: A Many node is just like FoldlGr, only the looping case is handled+-- specially.+-- FoldMn: Like FoldGr, there are two ways into a FoldlMn node, one going down+-- and one going up, and we must handle loopy cases correctly. A FoldMn sends+-- a value up before going down. So, the localU is set when going up and if+-- we find it when going down, we are looping. When we send down a value, we+-- guard entry into the node using its (not localU) Unique.++-- Note [Regex optimizations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Currently, the only optimization performed is+--+-- * Gather multiple RAlts into a single multi-way branching PAlt/NAlt. It's+-- better to multi-way branch at a flat array instead of nested 2-way+-- branches, much less pointer-chasing.+--+-- Other possible optimizations are possible when compiling, such as removing+-- paths going to REmpty. Or even at the RE level by applying laws, such as+-- liftA2 f REmpty x = REmpty or liftA2 f (RPure x) y = RFmap (f x) y.+-- I don't know yet if this is worth doing.
+ src/Regex/Internal/Regex.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+module Regex.Internal.Regex+ ( RE(..)+ , Strictness(..)+ , Greediness(..)+ , Many(..)++ , token+ , anySingle+ , single+ , satisfy++ , foldlMany+ , foldlManyMin+ , manyr+ , optionalMin+ , someMin+ , manyMin+ , atLeast+ , atMost+ , betweenCount+ , atLeastMin+ , atMostMin+ , betweenCountMin+ , sepBy+ , sepBy1+ , endBy+ , endBy1+ , sepEndBy+ , sepEndBy1+ , chainl1+ , chainr1+ , toFind+ , toFindMany++ , fmap'+ , liftA2'+ , foldlMany'+ , foldlManyMin'+ ) where++import Control.Applicative+import Control.DeepSeq (NFData(..), NFData1(..), rnf1)+import Control.Monad+import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), showsUnaryWith)+import Data.Semigroup (Semigroup(..))+import qualified Data.Foldable as F++---------------------------------+-- RE and constructor functions+---------------------------------++-- | A regular expression. Operates on a sequence of elements of type @c@ and+-- capable of parsing into an @a@.+--+-- A @RE@ is a Functor, Applicative, and Alternative.+--+-- * 'pure': Succeed without consuming input.+-- * 'liftA2', '<*>', '*>', '<*': Sequential composition.+-- * 'empty': Fail.+-- * '<|>': Alternative composition. Left-biased, i.e. the result of parsing+-- using @a \<|> b@ is the result of parsing using @a@ if it succeeds,+-- otherwise it is the result of parsing using @b@ if it succeeds,+-- otherwise parsing fails.+-- * 'many': Zero or more. @many a@ parses multiple @a@s sequentially. Biased+-- towards matching more. Use 'manyMin' for a bias towards matching less.+-- Also see the section "Looping parsers".+-- * 'some': One or more. @some a@ parses multiple @a@s sequentially. Biased+-- towards matching more. Use 'someMin' for a bias towards matching less.+--+-- In addition to expected Functor, Applicative, and Alternative laws,+-- @RE@ obeys these Applicative-Alternative laws:+--+-- @+-- a \<*> empty = empty+-- empty \<*> a = empty+-- (a \<|> b) \<*> c = (a \<*> c) \<|> (b \<*> c)+-- a \<*> (b \<|> c) = (a \<*> b) \<|> (a \<*> c)+-- @+--+-- Note that, because of bias, it is /not true/ that @a \<|> b = b \<|> a@.+--+-- /Performance note/: Prefer the smaller of equivalent regexes, i.e. prefer+-- @(a \<|> b) \<*> c@ over @(a \<*> c) \<|> (b \<*> c)@.+--+data RE c a where+ RToken :: !(c -> Maybe a) -> RE c a+ RFmap :: !Strictness -> !(a1 -> 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+ 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++instance Functor (RE c) where+ fmap = RFmap NonStrict+ (<$) = RFmap_++fmap' :: (a -> b) -> RE c a -> RE c b+fmap' = RFmap Strict++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)++liftA2' :: (a1 -> a2 -> b) -> RE c a1 -> RE c a2 -> RE c b+liftA2' = RLiftA2 Strict++instance Alternative (RE c) where+ empty = REmpty+ (<|>) = RAlt+ some re = liftA2' (:) re (many re)+ many = fmap reverse . foldlMany' (flip (:)) []++-- | @(<>) = liftA2 (<>)@+instance Semigroup a => Semigroup (RE c a) where+ (<>) = liftA2 (<>)+ sconcat = fmap sconcat . sequenceA+ {-# INLINE sconcat #-}++-- | @mempty = pure mempty@+instance Monoid a => Monoid (RE c a) where+ mempty = pure mempty+ mconcat = fmap mconcat . sequenceA+ {-# INLINE mconcat #-}+-- Use the underlying type's sconcat/mconcat because it may be more efficient+-- than the default right-associative definition.+-- stimes is not defined here since there is no way to delegate to the stimes+-- of a.++-- | Parse a @c@ into an @a@ if the given function returns @Just@.+token :: (c -> Maybe a) -> RE c a+token = RToken++-- | Zero or more. Biased towards matching more.+--+-- Also see the section "Looping parsers".+manyr :: RE c a -> RE c (Many a)+manyr = RMany Repeat (Finite . reverse) (flip (:)) []++-- | 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' :: (b -> a -> b) -> b -> RE c a -> RE c b+foldlMany' f !z = RFold Strict Greedy f z++-- | 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' :: (b -> a -> b) -> b -> RE c a -> RE c b+foldlManyMin' f !z = RFold Strict Minimal f z++-- | Parse a @c@ if it satisfies the given predicate.+satisfy :: (c -> Bool) -> RE c c+satisfy p = token (\c -> if p c then Just c else Nothing)+{-# INLINE satisfy #-}++-- | Parse the given @c@.+single :: Eq c => c -> RE c c+single !c = satisfy (c==)++-- | Parse any @c@.+anySingle :: RE c c+anySingle = token Just++---------+-- Many+---------++data Many a+ = Repeat a -- ^ A single value repeating indefinitely+ | Finite [a] -- ^ A finite list+ deriving (Eq, Show)++instance Ord a => Ord (Many a) where+ compare (Repeat x) (Repeat y) = compare x y+ compare xs ys = compare (F.toList xs) (F.toList ys)++instance Eq1 Many where+ liftEq f m1 m2 = case (m1,m2) of+ (Repeat x, Repeat y) -> f x y+ (Finite xs, Finite ys) -> liftEq f xs ys+ _ -> False++instance Ord1 Many where+ liftCompare f m1 m2 = case (m1,m2) of+ (Repeat x, Repeat y) -> f x y+ _ -> liftCompare f (F.toList m1) (F.toList m2)++instance Show1 Many where+ liftShowsPrec sp sl p m = case m of+ Repeat x -> showsUnaryWith sp "Repeat" p x+ Finite xs -> showParen (p > 10) $+ showString "Finite" . showChar ' ' . sl xs++instance Functor Many where+ fmap f m = case m of+ Repeat x -> Repeat (f x)+ Finite xs -> Finite (map f xs)++instance 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++ foldl' f z m = case m of+ Repeat _ -> error "Foldable Many: Repeat: foldl'"+ Finite xs -> F.foldl' f z xs++ foldl f z m = case m of+ Repeat _ -> error "Foldable Many: Repeat: foldl"+ Finite xs -> foldl f z xs++ toList m = case m of+ Repeat x -> repeat x+ Finite xs -> xs++instance NFData a => NFData (Many a) where+ rnf = rnf1++instance NFData1 Many where+ liftRnf f m = case m of+ Repeat x -> f x+ Finite xs -> liftRnf f xs++----------------+-- Combinators+----------------++-- | Zero or one. Minimal, i.e. biased towards zero.+--+-- @Use Control.Applicative.'optional'@ for the same but biased towards one.+optionalMin :: RE c a -> RE c (Maybe a)+optionalMin re = pure Nothing <|> Just <$> re++-- | One or more. Minimal, i.e. biased towards matching less.+someMin :: RE c a -> RE c [a]+someMin re = liftA2' (:) re (manyMin re)++-- | Zero or more. Minimal, i.e. biased towards matching less.+manyMin :: RE c a -> RE c [a]+manyMin = fmap reverse . foldlManyMin' (flip (:)) []++-- | At least n times. Biased towards matching more.+atLeast :: Int -> RE c a -> RE c [a]+atLeast n re = replicateAppendM (max n 0) re (many re)++-- | At most n times. Biased towards matching more.+atMost :: Int -> RE c a -> RE c [a]+atMost n = betweenCount (0,n)++-- | Between m and n times (inclusive). Biased towards matching more.+betweenCount :: (Int, Int) -> RE c a -> RE c [a]+betweenCount (l,h) re+ | l' > h = empty+ | otherwise = replicateAppendM l' re (go (h - l'))+ where+ l' = max l 0+ go 0 = pure []+ go n = liftA2' (:) re (go (n-1)) <|> pure []++-- | At least n times. Minimal, i.e. biased towards matching less.+atLeastMin :: Int -> RE c a -> RE c [a]+atLeastMin n re = replicateAppendM (max n 0) re (manyMin re)++-- | At most n times. Minimal, i.e. biased towards matching less.+atMostMin :: Int -> RE c a -> RE c [a]+atMostMin n = betweenCountMin (0,n)++-- | Between m and n times (inclusive). Minimal, i.e. biased towards matching+-- less.+betweenCountMin :: (Int, Int) -> RE c a -> RE c [a]+betweenCountMin (l,h) re+ | l' > h = empty+ | otherwise = replicateAppendM l' re (go (h - l'))+ where+ l' = max l 0+ go 0 = pure []+ go n = pure [] <|> liftA2' (:) re (go (n-1))++-- n0 must be >= 0+replicateAppendM :: Int -> RE c a -> RE c [a] -> RE c [a]+replicateAppendM n0 re re1 = go n0+ where+ go 0 = re1+ go n = liftA2' (:) re (go (n-1))++-- | @r \`sepBy\` sep@ parses zero or more occurences of @r@, separated by+-- @sep@. Biased towards matching more.+sepBy :: RE c a -> RE c sep -> RE c [a]+sepBy re sep = sepBy1 re sep <|> pure []++-- | @r \`sepBy1\` sep@ parses one or more occurences of @r@, separated by+-- @sep@. Biased towards matching more.+sepBy1 :: RE c a -> RE c sep -> RE c [a]+sepBy1 re sep = liftA2' (:) re (many (sep *> re))++-- | @r \`endBy\` sep@ parses zero or more occurences of @r@, separated and+-- ended by @sep@. Biased towards matching more.+endBy :: RE c a -> RE c sep -> RE c [a]+endBy re sep = many (re <* sep)++-- | @r \`endBy1\` sep@ parses one or more occurences of @r@, separated and+-- ended by @sep@. Biased towards matching more.+endBy1 :: RE c a -> RE c sep -> RE c [a]+endBy1 re sep = some (re <* sep)++-- | @r \`sepEndBy\` sep@ parses zero or more occurences of @r@, separated and+-- optionally ended by @sep@. Biased towards matching more.+sepEndBy :: RE c a -> RE c sep -> RE c [a]+sepEndBy re sep = sepEndBy1 re sep <|> pure []++-- | @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++-- | @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+ where+ rest = foldlMany (flip (.)) id (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+ where+ rest = foldlMany (.) id (liftA2 (flip id) re op)++-- | Results in the first occurence of the given @RE@. Fails if no occurence+-- is found.+toFind :: RE c a -> RE c a+toFind re = manyMin anySingle *> re <* many anySingle++-- | Results in all non-overlapping occurences of the given @RE@. Always+-- succeeds.+toFindMany :: RE c a -> RE c [a]+toFindMany re =+ reverse <$>+ foldlMany' (flip ($)) [] ((:) <$> re <|> id <$ anySingle)
+ src/Regex/Internal/Text.hs view
@@ -0,0 +1,602 @@+{-# LANGUAGE BangPatterns #-}+module Regex.Internal.Text+ (+ TextToken+ , REText++ , token+ , satisfy+ , char+ , charIgnoreCase+ , anyChar+ , oneOf+ , text+ , textIgnoreCase+ , manyText+ , someText+ , manyTextMin+ , someTextMin+ , manyTextOf+ , someTextOf+ , manyTextOfMin+ , someTextOfMin++ , naturalDec+ , integerDec+ , naturalHex+ , integerHex+ , wordRangeDec+ , intRangeDec+ , wordRangeHex+ , intRangeHex+ , wordDecN+ , wordHexN++ , toMatch+ , withMatch++ , reParse+ , ParserText+ , parse+ , parseSure++ , find+ , findAll+ , splitOn+ , replace+ , replaceAll+ ) where++import Control.Applicative+import Data.Char+import Data.Foldable (foldl')+import Data.Maybe (fromMaybe)+import Numeric.Natural+import Data.Text (Text)+import qualified Data.Text as T+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++import Data.CharSet (CharSet)+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 qualified Regex.Internal.Regex as R+import qualified Regex.Internal.Num as RNum+import qualified Regex.Internal.Generated.CaseFold as CF++----------------------+-- Token and Text REs+----------------------++-- | The token type used for parsing @Text@.++-- 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.+data TextToken = TextToken+ { tArr :: {-# UNPACK #-} !TArray.Array+ , tOffset :: {-# UNPACK #-} !Int+ , tChar :: {-# UNPACK #-} !Char+ }++-- | A type alias for convenience.+--+-- A function which accepts a @RE c a@ will accept a @REText a@.+type REText = RE TextToken++-- | A type alias for convenience.+--+-- A function which accepts a @Parser c a@ will accept a @ParserText a@.+type ParserText = Parser TextToken++-- | Parse a @Char@ into an @a@ if the given function returns @Just@.+token :: (Char -> Maybe a) -> REText a+token t = R.token (\ !tok -> t (tChar tok))+{-# INLINE token #-}++-- | Parse a @Char@ if it satisfies the given predicate.+satisfy :: (Char -> Bool) -> REText Char+satisfy p = token $ \c -> if p c then Just c else Nothing+{-# INLINE satisfy #-}++-- | Parse the given @Char@.+char :: Char -> REText Char+char !c = satisfy (c==)++-- | Parse the given @Char@, ignoring case.+--+-- Comparisons are performed after applying+-- [simple case folding](https://www.unicode.org/reports/tr44/#Simple_Case_Folding)+-- as described by the Unicode standard.+charIgnoreCase :: Char -> REText Char+charIgnoreCase c = satisfy $ (c'==) . CF.caseFoldSimple+ where+ !c' = CF.caseFoldSimple c+-- See Note [Why simple case fold]++-- | Parse any @Char@.+anyChar :: REText Char+anyChar = token Just++-- | Parse a @Char@ if it is a member of the @CharSet@.+oneOf :: CharSet -> REText Char+oneOf !cs = satisfy (`CS.member` cs)++-- | Parse the given @Text@.+text :: Text -> REText Text+text t = t <$ T.foldr' ((*>) . char) (pure ()) t++-- | Parse the given @Text@, ignoring case.+--+-- Comparisons are performed after applying+-- [simple case folding](https://www.unicode.org/reports/tr44/#Simple_Case_Folding)+-- as described by the Unicode standard.+textIgnoreCase :: Text -> REText Text+textIgnoreCase t =+ T.foldr' (\c cs -> R.liftA2' adjacentAppend (ignoreCaseTokenMatch c) cs)+ (pure T.empty)+ t+-- See Note [Why simple case fold]++-- | Parse any @Text@. Biased towards matching more.+manyText :: REText Text+manyText = R.foldlMany' adjacentAppend T.empty anyTokenMatch++-- | Parse any non-empty @Text@. Biased towards matching more.+someText :: REText Text+someText = R.liftA2' adjacentAppend anyTokenMatch manyText++-- | Parse any @Text@. Minimal, i.e. biased towards matching less.+manyTextMin :: REText Text+manyTextMin = R.foldlManyMin' adjacentAppend T.empty anyTokenMatch++-- | Parse any non-empty @Text@. Minimal, i.e. biased towards matching less.+someTextMin :: REText Text+someTextMin = R.liftA2' adjacentAppend anyTokenMatch manyTextMin++-- | Parse any @Text@ containing members of the @CharSet@.+-- Biased towards matching more.+manyTextOf :: CharSet -> REText Text+manyTextOf !cs = R.foldlMany' adjacentAppend T.empty (oneOfTokenMatch cs)++-- | Parse any non-empty @Text@ containing members of the @CharSet@.+-- Biased towards matching more.+someTextOf :: CharSet -> REText Text+someTextOf !cs = R.liftA2' adjacentAppend (oneOfTokenMatch cs) (manyTextOf cs)++-- | Parse any @Text@ containing members of the @CharSet@.+-- Minimal, i.e. biased towards matching less.+manyTextOfMin :: CharSet -> REText Text+manyTextOfMin !cs = R.foldlManyMin' adjacentAppend T.empty (oneOfTokenMatch cs)++-- | Parse any non-empty @Text@ containing members of the @CharSet@.+-- Minimal, i.e. biased towards matching less.+someTextOfMin :: CharSet -> REText Text+someTextOfMin !cs =+ R.liftA2' adjacentAppend (oneOfTokenMatch cs) (manyTextOfMin cs)++-----------------+-- Numeric REs+-----------------++-- | Parse a decimal @Natural@.+-- Leading zeros are not accepted. Biased towards matching more.+naturalDec :: REText Natural+naturalDec = RNum.mkNaturalDec digitRange++-- | Parse a decimal @Integer@. Parse an optional sign, @\'-\'@ or @\'+\'@,+-- followed by the given @RE@, followed by the absolute value of the integer.+-- Leading zeros are not accepted. Biased towards matching more.+integerDec :: REText a -> REText Integer+integerDec sep = RNum.mkSignedInteger minus plus (sep *> naturalDec)++-- | Parse a hexadecimal @Natural@. Both uppercase @\'A\'..\'F\'@ and lowercase+-- @\'a\'..\'f\'@ are accepted.+-- Leading zeros are not accepted. Biased towards matching more.+naturalHex :: REText Natural+naturalHex = RNum.mkNaturalHex hexDigitRange++-- | Parse a hexadecimal @Integer@. Parse an optional sign, @\'-\'@ or @\'+\'@,+-- followed by the given @RE@, followed by the absolute value of the integer.+-- Both uppercase @\'A\'..\'F\'@ and lowercase @\'a\'..\'f\'@ are accepted.+-- Leading zeros are not accepted. Biased towards matching more.+integerHex :: REText a -> REText Integer+integerHex sep = RNum.mkSignedInteger minus plus (sep *> naturalHex)++-- | Parse a decimal @Word@ in the range @[low..high]@.+-- Leading zeros are not accepted. Biased towards matching more.+wordRangeDec :: (Word, Word) -> REText Word+wordRangeDec lh = RNum.mkWordRangeDec digitRange lh++-- | Parse a decimal @Int@ in the range @[low..high]@. Parse an optional sign,+-- @\'-\'@ or @\'+\'@, followed by the given @RE@, followed by the absolute+-- value of the integer.+-- Leading zeros are not accepted. Biased towards matching more.+intRangeDec :: REText a -> (Int, Int) -> REText Int+intRangeDec sep lh =+ RNum.mkSignedIntRange minus plus ((sep *>) . wordRangeDec) lh++-- | Parse a hexadecimal @Word@ in the range @[low..high]@. Both uppercase+-- @\'A\'..\'F\'@ and lowercase @\'a\'..\'f\'@ are accepted.+-- Leading zeros are not accepted. Biased towards matching more.+wordRangeHex :: (Word, Word) -> REText Word+wordRangeHex lh = RNum.mkWordRangeHex hexDigitRange lh++-- | Parse a hexadecimal @Int@ in the range @[low..high]@. Parse an optional+-- sign, @\'-\'@ or @\'+\'@, followed by the given @RE@, followed by the+-- absolute value of the integer.+-- Both uppercase @\'A\'..\'F\'@ and lowercase @\'a\'..\'f\'@ are accepted.+-- Leading zeros are not accepted. Biased towards matching more.+intRangeHex :: REText a -> (Int, Int) -> REText Int+intRangeHex sep lh =+ RNum.mkSignedIntRange minus plus ((sep *>) . wordRangeHex) lh++-- | Parse a @Word@ of exactly n decimal digits, including any leading zeros.+-- Will not parse values that do not fit in a @Word@.+-- Biased towards matching more.+wordDecN :: Int -> REText Word+wordDecN n = RNum.mkWordDecN digitRange n++-- | Parse a @Word@ of exactly n hexadecimal digits, including any leading+-- zeros. Both uppercase @\'A\'..\'F\'@ and lowercase @\'a\'..\'f\'@ are+-- accepted. Will not parse values that do not fit in a @Word@.+-- Biased towards matching more.+wordHexN :: Int -> REText Word+wordHexN n = RNum.mkWordHexN hexDigitRange n++minus, plus :: REText ()+minus = token $ \c -> if c == '-' then Just () else Nothing+plus = token $ \c -> if c == '+' then Just () else Nothing++-- l and h must be in [0..9]+digitRange :: Word -> Word -> REText Word+digitRange !l !h = token $ \c ->+ let d = fromIntegral (ord c - ord '0')+ in if l <= d && d <= h then Just d else Nothing++-- l and h must be in [0..15]+hexDigitRange :: Word -> Word -> REText Word+hexDigitRange !l !h = token $ \c ->+ let dec = fromIntegral (ord c - ord '0')+ hexl = fromIntegral (ord c - ord 'a')+ hexu = fromIntegral (ord c - ord 'A')+ in do+ d <- case () of+ _ | dec <= 9 -> Just dec+ | hexl <= 5 -> Just $! 10 + hexl+ | hexu <= 5 -> Just $! 10 + hexu+ | otherwise -> Nothing+ if l <= d && d <= h then Just d else Nothing+-- TODO: This can surely be optimized++----------------+-- Match stuff+----------------++tokenToSlice :: TextToken -> Text+tokenToSlice t =+ TInternal.Text (tArr t) (tOffset t) (TInternalUtf8.utf8Length (tChar t))++tokenMatch :: (TextToken -> Maybe a) -> REText Text+tokenMatch t = R.token (\ !tok -> tokenToSlice tok <$ t tok)++tokenWithMatch :: (TextToken -> Maybe a) -> REText (WithMatch a)+tokenWithMatch t = R.token (\ !tok -> WM (tokenToSlice tok) <$> t tok)++anyTokenMatch :: REText Text+anyTokenMatch = R.token (\tok -> Just $! tokenToSlice tok)++ignoreCaseTokenMatch :: Char -> REText Text+ignoreCaseTokenMatch c = R.token $ \tok ->+ if CF.caseFoldSimple (tChar tok) == c'+ then Just $! tokenToSlice tok+ else Nothing+ where+ !c' = CF.caseFoldSimple c++oneOfTokenMatch :: CharSet -> REText Text+oneOfTokenMatch !cs = R.token $ \tok ->+ if CS.member (tChar tok) cs+ then Just $! tokenToSlice tok+ else Nothing++-- | Rebuild the @RE@ such that the result is the matched @Text@ instead.+toMatch :: REText a -> REText Text+toMatch = go+ where+ go :: REText b -> REText Text+ go re = case re of+ RToken t -> tokenMatch t+ RFmap _ _ re1 -> go re1+ RFmap_ _ re1 -> go re1+ RPure _ -> RPure T.empty+ RLiftA2 _ _ re1 re2 -> RLiftA2 Strict adjacentAppend (go re1) (go re2)+ REmpty -> REmpty+ RAlt re1 re2 -> RAlt (go re1) (go re2)+ RMany _ _ _ _ re1 -> RFold Strict Greedy adjacentAppend T.empty (go re1)+ RFold _ gr _ _ re1 -> RFold Strict gr adjacentAppend T.empty (go re1)++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++instance Applicative WithMatch where+ pure = WM T.empty+ liftA2 f (WM t1 x) (WM t2 y) = WM (adjacentAppend t1 t2) (f x y)++liftA2WM' :: (a1 -> a2 -> b) -> WithMatch a1 -> WithMatch a2 -> WithMatch b+liftA2WM' f (WM t1 x) (WM t2 y) = WM (adjacentAppend 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)+ 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 -> liftA2 f+ in RLiftA2 Strict g (go re1) (go re2)+ REmpty -> REmpty+ RAlt re1 re2 -> RAlt (go re1) (go re2)+ 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 -> liftA2 f+ in RFold Strict gr g (pure z) (go re1)++----------+-- Parse+----------++tokenFoldr :: (TextToken -> b -> b) -> b -> Text -> b+tokenFoldr 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 tokenFoldr #-}++-- | \(O(mn \log m)\). Parse a @Text@ with a @REText@.+--+-- Uses 'Regex.Text.compile', see the note there.+--+-- If parsing multiple @Text@s using the same @RE@, it is wasteful to compile+-- the @RE@ every time. So, prefer to+--+-- * Compile once with 'Regex.Text.compile' or 'Regex.Text.compileBounded' and+-- use the compiled 'ParserText' with 'parse' as many times as required.+-- * Alternately, partially apply this function to a @RE@ and use the function+-- as many times as required.+reParse :: REText a -> Text -> Maybe a+reParse re = let !p = P.compile re in parse p+{-# INLINE reParse #-}++-- | \(O(mn \log m)\). Parse a @Text@ with a @ParserText@.+parse :: ParserText a -> Text -> Maybe a+parse = P.parseFoldr tokenFoldr++-- | \(O(mn \log m)\). Parse a @Text@ with a @ParserText@. Calls 'error' on+-- parse failure.+--+-- For use with parsers that are known to never fail.+parseSure :: ParserText a -> Text -> a+parseSure p = fromMaybe parseSureError . parse p++parseSureError :: a+parseSureError = errorWithoutStackTrace+ "Regex.Text.parseSure: parse failed; if parsing can fail use 'parse' instead"++reParseSure :: REText a -> Text -> a+reParseSure re = fromMaybe parseSureError . reParse re+{-# INLINE reParseSure #-}++-- | \(O(mn \log m)\). Find the first occurence of the given @RE@ in a @Text@.+--+-- ==== __Examples__+--+-- >>> find (text "meow") "homeowner"+-- Just "meow"+--+-- To test whether a @Text@ is present in another @Text@, like above, prefer+-- @Data.Text.'T.isInfixOf'@.+--+-- >>> find (textIgnoreCase "haskell") "Look I'm Haskelling!"+-- Just "Haskell"+-- >>> find (text "backtracking") "parser-regex"+-- Nothing+--+find :: REText a -> Text -> Maybe a+find = reParse . R.toFind+{-# INLINE find #-}++-- | \(O(mn \log m)\). Find all non-overlapping occurences of the given @RE@ in+-- the @Text@.+--+-- ==== __Examples__+--+-- >>> findAll (text "ana") "banananana"+-- ["ana","ana"]+--+-- @+-- data Roll = Roll+-- Natural -- ^ Rolls+-- Natural -- ^ Faces on the die+-- deriving Show+--+-- roll :: REText Roll+-- roll = Roll \<$> ('naturalDec' \<|> pure 1) \<* 'char' \'d\' \<*> naturalDec+-- @+--+-- >>> findAll roll "3d6, d10, 2d10"+-- [Roll 3 6,Roll 1 10,Roll 2 10]+--+findAll :: REText a -> Text -> [a]+findAll = reParseSure . R.toFindMany+{-# INLINE findAll #-}++-- | \(O(mn \log m)\). Split a @Text@ at occurences of the given @RE@.+--+-- ==== __Examples__+--+-- >>> splitOn (char ' ') "Glasses are really versatile"+-- ["Glasses","are","really","versatile"]+--+-- For simple splitting, like above, prefer @Data.Text.'Data.Text.words'@,+-- @Data.Text.'Data.Text.lines'@, @Data.Text.'Data.Text.split'@ or+-- @Data.Text.'Data.Text.splitOn'@, whichever is applicable.+--+-- >>> splitOn (char ' ' *> oneOf "+-=" *> char ' ') "3 - 1 + 1/2 - 2 = 0"+-- ["3","1","1/2","2","0"]+--+-- If the @Text@ starts or ends with a delimiter, the result will contain+-- empty @Text@s at those positions.+--+-- >>> splitOn (char 'a') "ayaya"+-- ["","y","y",""]+--+splitOn :: REText a -> Text -> [Text]+splitOn = reParseSure . toSplitOn+{-# INLINE splitOn #-}++toSplitOn :: REText a -> REText [Text]+toSplitOn re = manyTextMin `R.sepBy` re++-- | \(O(mn \log m)\). Replace the first match of the given @RE@ with its+-- result. If there is no match, the result is @Nothing@.+--+-- ==== __Examples__+--+-- >>> replace ("world" <$ text "Haskell") "Hello, Haskell!"+-- Just "Hello, world!"+--+-- >>> replace ("," <$ some (char '.')) "one...two...ten"+-- Just "one,two...ten"+--+replace :: REText Text -> Text -> Maybe Text+replace = reParse . toReplace+{-# INLINE replace #-}++toReplace :: REText Text -> REText Text+toReplace re = liftA2 f manyTextMin re <*> manyText+ where+ f a b c = reverseConcat [c,b,a]++-- | \(O(mn \log m)\). Replace non-overlapping matches of the given @RE@ with+-- their results.+--+-- ==== __Examples__+--+-- >>> replaceAll (" and " <$ text ", ") "red, blue, green"+-- "red and blue and green"+--+-- For simple replacements like above, prefer @Data.Text.'Data.Text.replace'@.+--+-- >>> replaceAll ("Fruit" <$ text "Time" <|> "banana" <$ text "arrow") "Time flies like an arrow"+-- "Fruit flies like a banana"+--+-- @+-- sep = 'oneOf' "-./"+-- digits n = 'toMatch' ('replicateM_' n (oneOf 'Data.CharSet.digit'))+-- toYmd d m y = mconcat [y, \"-\", m, \"-\", d]+-- date = toYmd \<$> digits 2 \<* sep+-- \<*> digits 2 \<* sep+-- \<*> digits 4+-- @+-- >>> replaceAll date "01/01/1970, 01-04-1990, 03.07.2011"+-- "1970-01-01, 1990-04-01, 2011-07-03"+--+replaceAll :: REText Text -> Text -> Text+replaceAll = reParseSure . toReplaceMany+{-# INLINE replaceAll #-}++toReplaceMany :: REText Text -> REText Text+toReplaceMany re =+ reverseConcat <$> R.foldlMany' (flip (:)) [] (re <|> anyTokenMatch)++-------------------------+-- Low level Text stuff+-------------------------++-- WARNING: If t1 and t2 are not empty, they must be adjacent slices of the+-- same Text. In other words, sameByteArray# a1 _a2 && o1 + l1 == _o2.+adjacentAppend :: Text -> Text -> Text+adjacentAppend t1@(TInternal.Text a1 o1 l1) t2@(TInternal.Text _a2 _o2 l2)+ | T.null t1 = t2+ | T.null t2 = t1+ | otherwise = TInternal.Text a1 o1 (l1+l2)++-- reverseConcat = T.concat . reverse+reverseConcat :: [Text] -> Text+reverseConcat ts = case ts of+ [] -> T.empty+ [t] -> t+ _ | len == 0 -> T.empty+ | otherwise -> TInternal.Text arr 0 len+ where+ flen acc (TInternal.Text _ _ l)+ | acc' >= 0 = acc'+ | otherwise = reverseConcatOverflowError+ where+ acc' = acc + l+ len = foldl' flen 0 ts+ arr = TArray.run $ do+ marr <- TArray.new len+ let loop !_ [] = pure marr+ loop i (TInternal.Text a o l : ts') =+ TArray.copyI l marr (i-l) a o *> loop (i-l) ts'+ loop len ts++reverseConcatOverflowError :: a+reverseConcatOverflowError =+ errorWithoutStackTrace "Regex.Text.reverseConcat: size overflow"++----------+-- Notes+----------++-- Note [Why simple case fold]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Unicode defines two different ways to case fold, "simple" and "full". Full is+-- superior to simple, and capable of folding more pairs of texts to the same+-- text. This is what is used by Data.Text.toCaseFold.+--+-- However, full maps a Char to one or more Chars, for instance "ß" maps to+-- "ss". Since we operate on one Char at a time without backtracking, we must+-- have branching in our regex corresponding to possible texts that case fold to+-- a target text. For instance, to match "sssss" with full case fold given the+-- above mapping, possible inputs are+--+-- sssss, sssß, ssßs, sßss, ßsss, sßß, ßsß, ßßs+--+-- Fun fact: the number of strings that match "s"*n is Fibonacci(n+1).+-- Of course, we can't have textIgnoreCase take a text and explode into a regex+-- of exponential size.+--+-- So, we restrict ourselves to simple case folding. Simple case folding+-- maps a single Char to a single Char. And it's easy to test that the required+-- Char and a Char in the input case fold to the same Char.+--+-- Note that charIgnoreCase could possibly use full case folding. Only a small+-- number of texts would case fold to the case fold of a single Char. But we+-- stick with simple case fold for consistency.
+ src/Regex/Internal/Unique.hs view
@@ -0,0 +1,31 @@+module Regex.Internal.Unique+ ( Unique(..)+ , UniqueSet+ , empty+ , member+ , insert+ ) where++import Data.Bits+import qualified Data.IntSet as IS++-- | A unique ID. Must be >= 0.+newtype Unique = Unique { unUnique :: Int }++-- | A set of 'Unique's. The bitmask is a set for IDs 0..63 (0..31 if 32-bit).+-- Set operations on this are very fast and speed up the common case of small+-- regexes a little bit, at the cost of a little more memory.+data UniqueSet = UniqueSet {-# UNPACK #-} !Int !IS.IntSet++empty :: UniqueSet+empty = UniqueSet 0 IS.empty++member :: Unique -> UniqueSet -> Bool+member (Unique u) (UniqueSet m is)+ | u < finiteBitSize (0 :: Int) = m .&. (1 `unsafeShiftL` u) /= 0+ | otherwise = u `IS.member` is++insert :: Unique -> UniqueSet -> UniqueSet+insert (Unique u) (UniqueSet m is)+ | u < finiteBitSize (0 :: Int) = UniqueSet (m .|. (1 `unsafeShiftL` u)) is+ | otherwise = UniqueSet m (IS.insert u is)
+ src/Regex/List.hs view
@@ -0,0 +1,210 @@+-- | This module offers regexes, combinators, and operations to work with the+-- list type (@[]@), and also specifically 'String's, which are lists of+-- 'Char's.+--+module Regex.List+ (+ -- * @RE@s+ R.RE+ , R.token+ , R.satisfy+ , R.single+ , R.anySingle+ , L.list+ , L.manyList+ , L.someList+ , L.manyListMin+ , L.someListMin++ -- * @Char@ @RE@s+ , L.charIgnoreCase+ , L.oneOfChar+ , L.stringIgnoreCase+ , L.manyStringOf+ , L.someStringOf+ , L.manyStringOfMin+ , L.someStringOfMin++ -- * Numeric @Char@ @RE@s+ , L.naturalDec+ , L.integerDec+ , L.naturalHex+ , L.integerHex+ , L.wordRangeDec+ , L.intRangeDec+ , L.wordRangeHex+ , L.intRangeHex+ , L.wordDecN+ , L.wordHexN++ -- * Combinators+ , R.foldlMany+ , R.foldlManyMin+ , L.toMatch+ , L.withMatch+ , R.Many(..)+ , R.manyr+ , R.optionalMin+ , R.someMin+ , R.manyMin+ , R.atLeast+ , R.atMost+ , R.betweenCount+ , R.atLeastMin+ , R.atMostMin+ , R.betweenCountMin+ , R.sepBy+ , R.sepBy1+ , R.endBy+ , R.endBy1+ , R.sepEndBy+ , R.sepEndBy1+ , R.chainl1+ , R.chainr1++ -- * Combinators in @base@+ -- $combase++ -- * Compile and parse+ , L.reParse+ , P.Parser+ , P.compile+ , P.compileBounded+ , L.parse+ , L.parseSure++ -- * List operations+ , L.find+ , L.findAll+ , L.splitOn+ , L.replace+ , L.replaceAll++ -- * Additional information+ -- $info+ ) where++import qualified Regex.Internal.Regex as R+import qualified Regex.Internal.Parser as P+import qualified Regex.Internal.List as L+++-- $combase+--+-- Various combinators are available in @base@ that work with @RE@s, by virtue+-- of @RE@ being @Applicative@ and @Alternative@.+-- Since this package does not attempt to redefine or re-export such+-- combinators, you need to import and use them. Commonly used combinators+-- are:+--+-- * "Control.Applicative": @liftA2@, @\<|>@, @empty@, @many@, @some@,+-- @optional@+-- * "Control.Monad": @void@, @replicateM@, @replicateM_@+-- * "Data.Foldable": @traverse_@, @for_@, @sequenceA_@, @asum@+-- * "Data.Traversable": @traverse@, @for@, @sequenceA@+--++-- $info+--+-- == Recursive definitions+--+-- It is not possible to define a @RE@ recursively. If it were permitted, it+-- would be capable of parsing more than+-- [regular languages](https://en.wikipedia.org/wiki/Regular_language).+-- Unfortunately, there is no good way\* to make it impossible to write such+-- a regex in the first place. So it must be avoided by the programmer. As an+-- example, avoid this:+--+-- @+-- re :: RE Char [String]+-- re = liftA2 (:) (list "ha") re \<|> [] \<$ list "!" -- diverges!+-- @+--+-- Instead, use appropriate combinators from this module:+--+-- @+-- re = many (list "ha") <* list "!"+-- @+--+-- For the same reason, be cautious when using combinators from the other+-- packages on @RE@s. Make sure that they do not attempt to construct a+-- recursive @RE@.+--+-- If you find that your regex is impossible to write without recursion,+-- you are attempting to parse a non-regular language! You need a more powerful+-- parser than what this library has to offer.+--+-- \* [Unlifted datatypes](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/primitives.html#unlifted-datatypes)+-- can serve this purpose but they are too inconvenient to work with.+--+-- == Laziness+--+-- Parsing is lazy in the result value, i.e. the @a@ in @RE c a@ or+-- @Parser c a@. In fact, for the algorithm used in this library, this laziness+-- is essential for good runtime complexity. However, there is little reason+-- to be lazy in other aspects, such as the values of the sequence, @c@, or the+-- functions and regexes used in combinators. Functions are strict in such+-- arguments.+--+-- @+-- -- Lazy in the result+-- reParse (pure ⊥) "" = Just ⊥+-- reParse (fmap (\\_ -> ⊥) (char \'a\')) "a" = Just ⊥+--+-- -- Strict in places like+-- single ⊥ = ⊥+-- fmap ⊥ r = ⊥+-- liftA2 f r ⊥ = ⊥+-- @+--+-- == Looping parsers+--+-- What should be the result of @reParse (many (pure ())) ""@?+--+-- Since @many r@ parses @r@ as many times as possible, and @pure ()@ succeeds+-- without consuming input, the result should arguably be the infinite list+-- @repeat ()@. Similarly, @reParse (foldlMany f z (pure ())) ""@ should+-- diverge. Note that this applies to not just @pure x@, but any regex that+-- can succeed without consuming input, such as @many x@, @manyMin x@, etc.+--+-- This library considers that such an outcome is not desirable in practice. It+-- would be surprising to get an infinite structure from your parser. So, in the+-- case that @many@ succeeds an infinite number of times, this library treats it+-- as succeeding /zero/ times.+--+-- By this rule, @reParse (many (pure ())) ""@ parses as @[]@ and+-- @reParse (foldlMany f z (pure ())) ""@ parses as @z@.+--+-- This behavior makes it impossible to distinguish between zero parses and+-- infinite parses. To address this, an alternate combinator 'Regex.List.manyr'+-- is provided. This parses into a 'Regex.List.Many', a type that clearly+-- indicates if parsing succeeded without consuming input into an infinite list,+-- or if it succeeded a finite number of times.+--+-- == Performance+--+-- This section may be useful for someone looking to understand the performance+-- of this library without diving into the source code.+--+-- Parsing with a @RE@ is done in two distinct steps.+--+-- 1. A @RE@ is compiled to a @Parser@ in \(O(m)\) time, where \(m\) is the size+-- of the @RE@. This is a+-- [nondeterministic finite automaton](https://en.wikipedia.org/wiki/Nondeterministic_finite_automaton)+-- (NFA).+-- 2. The @Parser@ is run on a list in \(O(mn \log m)\) time, where \(n\) is+-- the length of the list. Assumes every @Char@ is parsed in \(O(1)\).+--+-- /Performance note/: Use @(\<$)@ over @(\<$>)@, and @(\<*)@\/@(*>)@ over+-- @liftA2@\/@(\<*>)@ when ignoring the result of a @RE@. Knowing the result is+-- ignored allows compiling to a faster parser.+--+-- Memory usage for parsing is \(O(nm)\).+--+-- * If the result of a @RE@ is ignored using @(\<$)@, @(\<*)@, or @(*>)@, only+-- \(O(m)\) memory is required.+--+-- This applies even as subcomponents. So, any subcomponent @RE@ of a larger+-- @RE@ that is only recognizing a section of the list is cheaper in terms of+-- memory.+--
+ src/Regex/Text.hs view
@@ -0,0 +1,213 @@+-- | This module offers regexes, combinators, and operations to work with the+-- 'Data.Text.Text' type from the @text@ package.+--+module Regex.Text+ (+ -- * @RE@s+ R.RE+ , T.TextToken+ , T.REText+ , T.token+ , T.satisfy+ , T.char+ , T.charIgnoreCase+ , T.anyChar+ , T.oneOf+ , T.text+ , T.textIgnoreCase+ , T.manyText+ , T.someText+ , T.manyTextMin+ , T.someTextMin+ , T.manyTextOf+ , T.someTextOf+ , T.manyTextOfMin+ , T.someTextOfMin++ -- * Numeric @RE@s+ , T.naturalDec+ , T.integerDec+ , T.naturalHex+ , T.integerHex+ , T.wordRangeDec+ , T.intRangeDec+ , T.wordRangeHex+ , T.intRangeHex+ , T.wordDecN+ , T.wordHexN++ -- * Combinators+ , R.foldlMany+ , R.foldlManyMin+ , T.toMatch+ , T.withMatch+ , R.Many(..)+ , R.manyr+ , R.optionalMin+ , R.someMin+ , R.manyMin+ , R.atLeast+ , R.atMost+ , R.betweenCount+ , R.atLeastMin+ , R.atMostMin+ , R.betweenCountMin+ , R.sepBy+ , R.sepBy1+ , R.endBy+ , R.endBy1+ , R.sepEndBy+ , R.sepEndBy1+ , R.chainl1+ , R.chainr1++ -- * Combinators in @base@+ -- $combase++ -- * Compile and parse+ , T.reParse+ , P.Parser+ , T.ParserText+ , P.compile+ , P.compileBounded+ , T.parse+ , T.parseSure++ -- * Text operations+ , T.find+ , T.findAll+ , T.splitOn+ , T.replace+ , T.replaceAll++ -- * Additional information+ -- $info+ ) where++import qualified Regex.Internal.Regex as R+import qualified Regex.Internal.Parser as P+import qualified Regex.Internal.Text as T+++-- $combase+--+-- Various combinators are available in @base@ that work with @RE@s, by virtue+-- of @RE@ being @Applicative@ and @Alternative@.+-- Since this package does not attempt to redefine or re-export such+-- combinators, you need to import and use them. Commonly used combinators+-- are:+--+-- * "Control.Applicative": @liftA2@, @\<|>@, @empty@, @many@, @some@,+-- @optional@+-- * "Control.Monad": @void@, @replicateM@, @replicateM_@+-- * "Data.Foldable": @traverse_@, @for_@, @sequenceA_@, @asum@+-- * "Data.Traversable": @traverse@, @for@, @sequenceA@+--++-- $info+--+-- == Recursive definitions+--+-- It is not possible to define a @RE@ recursively. If it were permitted, it+-- would be capable of parsing more than+-- [regular languages](https://en.wikipedia.org/wiki/Regular_language).+-- Unfortunately, there is no good way\* to make it impossible to write such+-- a regex in the first place. So it must be avoided by the programmer. As an+-- example, avoid this:+--+-- @+-- re :: REText [Text]+-- re = liftA2 (:) (text "ha") re \<|> [] \<$ text "!" -- diverges!+-- @+--+-- Instead, use appropriate combinators from this module:+--+-- @+-- re = many (text "ha") <* text "!"+-- @+--+-- For the same reason, be cautious when using combinators from the other+-- packages on @RE@s. Make sure that they do not attempt to construct a+-- recursive @RE@.+--+-- If you find that your regex is impossible to write without recursion,+-- you are attempting to parse a non-regular language! You need a more powerful+-- parser than what this library has to offer.+--+-- \* [Unlifted datatypes](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/primitives.html#unlifted-datatypes)+-- can serve this purpose but they are too inconvenient to work with.+--+-- == Laziness+--+-- Parsing is lazy in the result value, i.e. the @a@ in @RE c a@ or+-- @Parser c a@. In fact, for the algorithm used in this library, this laziness+-- is essential for good runtime complexity. However, there is little reason+-- to be lazy in other aspects, such as the values of the sequence, @c@, or the+-- functions and regexes used in combinators. Functions are strict in such+-- arguments.+--+-- @+-- -- Lazy in the result+-- reParse (pure ⊥) "" = Just ⊥+-- reParse (fmap (\\_ -> ⊥) (char \'a\')) "a" = Just ⊥+--+-- -- Strict in places like+-- char ⊥ = ⊥+-- fmap ⊥ r = ⊥+-- liftA2 f r ⊥ = ⊥+-- @+--+-- == Looping parsers+--+-- What should be the result of @reParse (many (pure ())) ""@?+--+-- Since @many r@ parses @r@ as many times as possible, and @pure ()@ succeeds+-- without consuming input, the result should arguably be the infinite list+-- @repeat ()@. Similarly, @reParse (foldlMany f z (pure ())) ""@ should+-- diverge. Note that this applies to not just @pure x@, but any regex that+-- can succeed without consuming input, such as @many x@, @manyMin x@, etc.+--+-- This library considers that such an outcome is not desirable in practice. It+-- would be surprising to get an infinite structure from your parser. So, in the+-- case that @many@ succeeds an infinite number of times, this library treats it+-- as succeeding /zero/ times.+--+-- By this rule, @reParse (many (pure ())) ""@ parses as @[]@ and+-- @reParse (foldlMany f z (pure ())) ""@ parses as @z@.+--+-- This behavior makes it impossible to distinguish between zero parses and+-- infinite parses. To address this, an alternate combinator 'Regex.Text.manyr'+-- is provided. This parses into a 'Regex.Text.Many', a type that clearly+-- indicates if parsing succeeded without consuming input into an infinite list,+-- or if it succeeded a finite number of times.+--+-- == Performance+--+-- This section may be useful for someone looking to understand the performance+-- of this library without diving into the source code.+--+-- Parsing with a @RE@ is done in two distinct steps.+--+-- 1. A @RE@ is compiled to a @Parser@ in \(O(m)\) time, where \(m\) is the size+-- of the @RE@. This is a+-- [nondeterministic finite automaton](https://en.wikipedia.org/wiki/Nondeterministic_finite_automaton)+-- (NFA).+-- 2. The @Parser@ is run on a @Text@ in \(O(mn \log m)\) time, where \(n\) is+-- the length of the @Text@. Assumes every @Char@ is parsed in \(O(1)\).+--+-- /Performance note/: Use @(\<$)@ over @(\<$>)@, and @(\<*)@\/@(*>)@ over+-- @liftA2@\/@(\<*>)@ when ignoring the result of a @RE@. Knowing the result is+-- ignored allows compiling to a faster parser.+--+-- Memory usage for parsing is \(O(nm)\).+--+-- * If the result of a @RE@ is ignored using @(\<$)@, @(\<*)@, or @(*>)@, only+-- \(O(m)\) memory is required.+-- * To parse some slice of the input @Text@ (using one of @manyText@,+-- @manyTextOf@, etc.), memory required is \(O(1)\). For @toMatch r@, memory+-- required is \(O(m' \min (m',n))\) where \(m'\) is the size of @r@.+--+-- This applies even as subcomponents. So, any subcomponent @RE@ of a larger+-- @RE@ that is only recognizing text or parsing a slice is cheaper in terms of+-- memory.+--
+ test/Test.hs view
@@ -0,0 +1,1685 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- Arbitrary instances++import Control.Applicative+import Control.Monad+import Data.Char+import qualified Data.List as L+import Data.Maybe+import Data.List.NonEmpty (NonEmpty(..))+import Data.Proxy+import Data.Semigroup+import Data.String+import qualified Numeric as Num+import Numeric.Natural+import Data.Text (Text)+import qualified Data.Text as T++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.QuickCheck.Classes.Base+import Test.QuickCheck.Poly++import qualified Data.CharSet as CS+import qualified Regex.Base as R+import qualified Regex.List as RL+import qualified Regex.Text as RT++main :: IO ()+main = defaultMain $ localOption (QuickCheckTests 5000) $ testGroup "Tests"+ [ testGroup "Regex.Text"+ [ textReTests+ , combinatorTests+ , compileTests+ , textOpTests+ ]+ , testGroup "Regex.List"+ [ listReTests+ , listCombinatorTests+ , stringOpTests+ ]+ , manyTests+ , charSetTests+ ]++----------------+-- Various REs+---------------++textReTests :: TestTree+textReTests = testGroup "Text RE"+ [ testGroup "char"+ [ testPM "a, a, ok" (RT.char 'a') "a" (Just 'a')+ , testPM "a, b, fail" (RT.char 'a') "b" Nothing+ , testPM "a, <e>, fail" (RT.char 'a') "" Nothing+ , testProperty "random" $ \c1 c2 ->+ RT.reParse (RT.char c1) (T.singleton c2) ===+ if c1 == c2 then Just c1 else Nothing+ ]+ , 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+ , testGroup "anyChar"+ [ testProperty "random" $ \c ->+ RT.reParse RT.anyChar (T.singleton c) === Just c+ ]+ , testGroup "oneOf"+ [ testProperty "random" $ \cs c ->+ RT.reParse (RT.oneOf cs) (T.singleton c) ===+ if CS.member c cs then Just c else Nothing+ ]+ , testGroup "text"+ [ testPM "foo, foo, ok" (RT.text "foo") "foo" (Just "foo")+ , testPM "foo, bar, fail" (RT.text "foo") "bar" Nothing+ , testPM "foo, <e>, fail" (RT.text "foo") "" Nothing+ , testProperty "random" $ \t ->+ RT.reParse (RT.text t) t === Just t+ ]+ , testGroup "textIgnoreCase"+ [ testPM "foo, foo, ok" (RT.textIgnoreCase "foo") "foo" (Just "foo")+ , testPM "foo, FOO, ok" (RT.textIgnoreCase "foo") "FOO" (Just "FOO")+ , testPM "foo, fOO, ok" (RT.textIgnoreCase "foo") "fOO" (Just "fOO")+ , testPM "foo, bar, fail" (RT.textIgnoreCase "foo") "bar" Nothing+ , testPM "foo, <e>, fail" (RT.textIgnoreCase "foo") "" Nothing+ , testPM "dznuts, DzNuts, ok" (RT.textIgnoreCase "dznuts") "DzNuts" (Just "DzNuts")+ , testPM ":)" (RT.textIgnoreCase ":)") ":)" (Just ":)")+ , testProperty "random theta" $+ let gt = T.pack <$> listOf (elements "θϴϑΘ") in+ forAll ((,) <$> gt <*> gt) $ \(t1,t2) ->+ RT.reParse (RT.textIgnoreCase t1 <* RT.manyText) t2 ===+ if T.length t1 <= T.length t2 then Just (T.take (T.length t1) t2) else Nothing+ ]+ , testGroup "manyText"+ [ testProperty "random" $ \t ->+ RT.reParse RT.manyText t === Just t+ ]+ , testGroup "someText"+ [ testProperty "random" $ \t ->+ RT.reParse RT.someText t === if T.null t then Nothing else Just t+ ]+ , testGroup "manyTextMin"+ [ testProperty "random" $ \t ->+ RT.reParse RT.manyTextMin t === Just t+ ]+ , testGroup "someTextMin"+ [ testProperty "random" $ \t ->+ RT.reParse RT.someTextMin t === if T.null t then Nothing else Just t+ ]+ , testGroup "many some Text bias" $+ let f (name,re1,re2,g) = testProperty name $ \t ->+ RT.reParse (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 ->+ fmap (fmap T.singleton) (T.unsnoc t))+ , ("manyText manyTextMin", RT.manyText, RT.manyTextMin, \t -> Just (t,""))+ , ("manyText someTextMin", RT.manyText, RT.someTextMin, \t ->+ fmap (fmap T.singleton) (T.unsnoc t))+ , ("someText manyText", RT.someText, RT.manyText, \t ->+ if T.null t then Nothing else Just (t,""))+ , ("someText someText", RT.someText, RT.someText, \t -> do+ (t',c) <- T.unsnoc t+ _ <- T.uncons t'+ pure (t', T.singleton c))+ , ("someText manyTextMin", RT.someText, RT.manyTextMin, \t ->+ if T.null t then Nothing else Just (t,""))+ , ("someText someTextMin", RT.someText, RT.someTextMin, \t -> do+ (t',c) <- T.unsnoc t+ _ <- T.uncons t'+ pure (t', T.singleton c))+ , ("manyTextMin manyText", RT.manyTextMin, RT.manyText, \t -> Just ("",t))+ , ("manyTextMin someText", RT.manyTextMin, RT.someText, \t ->+ if T.null t then Nothing else Just ("",t))+ , ("manyTextMin manyTextMin", RT.manyTextMin, RT.manyTextMin, \t -> Just ("",t))+ , ("manyTextMin someTextMin", RT.manyTextMin, RT.someTextMin, \t ->+ if T.null t then Nothing else Just ("",t))+ , ("someTextMin manyText", RT.someTextMin, RT.manyText, \t ->+ fmap (\(c,t') -> (T.singleton c,t')) (T.uncons t))+ , ("someTextMin someText", RT.someTextMin, RT.someText, \t -> do+ (c,t') <- T.uncons t+ _ <- T.uncons t'+ pure (T.singleton c,t'))+ , ("someTextMin manyTextMin", RT.someTextMin, RT.manyTextMin, \t ->+ fmap (\(c,t') -> (T.singleton c,t')) (T.uncons t))+ , ("someTextMin someTextMin", RT.someTextMin, RT.someTextMin, \t -> do+ (c,t') <- T.uncons t+ _ <- T.uncons t'+ pure (T.singleton c,t'))+ ]+ , testGroup "manyTextOf"+ [ testProperty "random" $+ forAll zeroOneText $ \t ->+ RT.reParse (RT.manyTextOf "0") t ===+ if T.all (=='0') t then Just t else Nothing+ , testPM "bias" (RT.manyTextOf "0" <* RT.manyText) "0000" (Just "0000")+ ]+ , testGroup "someTextOf"+ [ testProperty "random" $+ forAll zeroOneText $ \t ->+ RT.reParse (RT.someTextOf "0") t ===+ if not (T.null t) && T.all (=='0') t then Just t else Nothing+ , testPM "bias" (RT.someTextOf "0" <* RT.manyText) "0000" (Just "0000")+ ]+ , testGroup "manyTextOfMin"+ [ testProperty "random" $+ forAll zeroOneText $ \t ->+ RT.reParse (RT.manyTextOfMin "0") t ===+ if T.all (=='0') t then Just t else Nothing+ , testPM "bias" (RT.manyTextOfMin "0" <* RT.manyText) "0000" (Just "")+ ]+ , testGroup "someTextOfMin"+ [ testProperty "random" $+ forAll zeroOneText $ \t ->+ RT.reParse (RT.someTextOfMin "0") t ===+ if not (T.null t) && T.all (=='0') t then Just t else Nothing+ , testPM "bias" (RT.someTextOfMin "0" <* RT.manyText) "0000" (Just "0")+ ]+ , textNumericTests+ ]++listReTests :: TestTree+listReTests = testGroup "List RE"+ [ testGroup "single"+ [ testLPM "a, a, ok" (RL.single 'a') "a" (Just 'a')+ , testLPM "a, b, fail" (RL.single 'a') "b" Nothing+ , testLPM "a, <e>, fail" (RL.single 'a') "" Nothing+ , testProperty "random" $ \c1 c2 ->+ RL.reParse @Char (RL.single c1) [c2] ===+ if c1 == c2 then Just c1 else Nothing+ ]+ , testGroup "charIgnoreCase" $+ let f c1 c2 = testLPM ([c1] <> ", " <> [c2] <> ", ok")+ (RL.charIgnoreCase c1) [c2] (Just c2)+ in ["aA", "DZDzdz", "θϴϑΘ"] >>= \cs -> liftA2 f cs cs+ , testGroup "anyChar"+ [ testProperty "random" $ \c ->+ RL.reParse @Char RL.anySingle [c] === Just c+ ]+ , testGroup "oneOf"+ [ testProperty "random" $ \cs c ->+ RL.reParse (RL.oneOfChar cs) [c] ===+ if CS.member c cs then Just c else Nothing+ ]+ , testGroup "list"+ [ testLPM "foo, foo, ok" (RL.list "foo") "foo" (Just "foo")+ , testLPM "foo, bar, fail" (RL.list "foo") "bar" Nothing+ , testLPM "foo, <e>, fail" (RL.list "foo") "" Nothing+ , testProperty "random" $ \t ->+ RL.reParse @Char (RL.list t) t === Just t+ ]+ , testGroup "stringIgnoreCase"+ [ testLPM "foo, foo, ok" (RL.stringIgnoreCase "foo") "foo" (Just "foo")+ , testLPM "foo, FOO, ok" (RL.stringIgnoreCase "foo") "FOO" (Just "FOO")+ , testLPM "foo, fOO, ok" (RL.stringIgnoreCase "foo") "fOO" (Just "fOO")+ , testLPM "foo, bar, fail" (RL.stringIgnoreCase "foo") "bar" Nothing+ , testLPM "foo, <e>, fail" (RL.stringIgnoreCase "foo") "" Nothing+ , testLPM "dznuts, DzNuts, ok" (RL.stringIgnoreCase "dznuts") "DzNuts" (Just "DzNuts")+ , testLPM ":)" (RL.stringIgnoreCase ":)") ":)" (Just ":)")+ , testProperty "random theta" $+ let gt = listOf (elements "θϴϑΘ") in+ forAll ((,) <$> gt <*> gt) $ \(t1,t2) ->+ RL.reParse (RL.stringIgnoreCase t1 <* RL.manyList) t2 ===+ if length t1 <= length t2 then Just (take (length t1) t2) else Nothing+ ]+ , testGroup "manyList"+ [ testProperty "random" $ \t ->+ RL.reParse @Char RL.manyList t === Just t+ ]+ , testGroup "someList"+ [ testProperty "random" $ \t ->+ RL.reParse @Char RL.someList t === if null t then Nothing else Just t+ ]+ , testGroup "manyListMin"+ [ testProperty "random" $ \t ->+ RL.reParse @Char RL.manyListMin t === Just t+ ]+ , testGroup "someListMin"+ [ testProperty "random" $ \t ->+ RL.reParse @Char RL.someListMin t === if null t then Nothing else Just t+ ]+ , testGroup "many some Text bias" $+ let f (name,re1,re2,g) = testProperty name $ \t ->+ RL.reParse (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 ->+ fmap (fmap (:[])) (unsnoc t))+ , ("manyList manyListMin", RL.manyList, RL.manyListMin, \t -> Just (t,""))+ , ("manyList someListMin", RL.manyList, RL.someListMin, \t ->+ fmap (fmap (:[])) (unsnoc t))+ , ("someList manyList", RL.someList, RL.manyList, \t ->+ if null t then Nothing else Just (t,""))+ , ("someList someList", RL.someList, RL.someList, \t -> do+ (t',c) <- unsnoc t+ _ <- L.uncons t'+ pure (t', [c]))+ , ("someList manyListMin", RL.someList, RL.manyListMin, \t ->+ if null t then Nothing else Just (t,""))+ , ("someList someListMin", RL.someList, RL.someListMin, \t -> do+ (t',c) <- unsnoc t+ _ <- L.uncons t'+ pure (t', [c]))+ , ("manyListMin manyList", RL.manyListMin, RL.manyList, \t -> Just ("",t))+ , ("manyListMin someList", RL.manyListMin, RL.someList, \t ->+ if null t then Nothing else Just ("",t))+ , ("manyListMin manyListMin", RL.manyListMin, RL.manyListMin, \t -> Just ("",t))+ , ("manyListMin someListMin", RL.manyListMin, RL.someListMin, \t ->+ if null t then Nothing else Just ("",t))+ , ("someListMin manyList", RL.someListMin, RL.manyList, \t ->+ fmap (\(c,t') -> ([c],t')) (L.uncons t))+ , ("someListMin someList", RL.someListMin, RL.someList, \t -> do+ (c,t') <- L.uncons t+ _ <- L.uncons t'+ pure ([c],t'))+ , ("someListMin manyListMin", RL.someListMin, RL.manyListMin, \t ->+ fmap (\(c,t') -> ([c],t')) (L.uncons t))+ , ("someListMin someListMin", RL.someListMin, RL.someListMin, \t -> do+ (c,t') <- L.uncons t+ _ <- L.uncons t'+ pure ([c],t'))+ ]+ , testGroup "manyListOf"+ [ testProperty "random" $+ forAll zeroOneString $ \t ->+ RL.reParse (RL.manyStringOf "0") t ===+ if all (=='0') t then Just t else Nothing+ , testLPM "bias" (RL.manyStringOf "0" <* RL.manyList) "0000" (Just "0000")+ ]+ , testGroup "someListOf"+ [ testProperty "random" $+ forAll zeroOneString $ \t ->+ RL.reParse (RL.someStringOf "0") t ===+ if not (null t) && all (=='0') t then Just t else Nothing+ , testLPM "bias" (RL.someStringOf "0" <* RL.manyList) "0000" (Just "0000")+ ]+ , testGroup "manyListOfMin"+ [ testProperty "random" $+ forAll zeroOneString $ \t ->+ RL.reParse (RL.manyStringOfMin "0") t ===+ if all (=='0') t then Just t else Nothing+ , testLPM "bias" (RL.manyStringOfMin "0" <* RL.manyList) "0000" (Just "")+ ]+ , testGroup "someListOfMin"+ [ testProperty "random" $+ forAll zeroOneString $ \t ->+ RL.reParse (RL.someStringOfMin "0") t ===+ if not (null t) && all (=='0') t then Just t else Nothing+ , testLPM "bias" (RL.someStringOfMin "0" <* RL.manyList) "0000" (Just "0")+ ]+ , stringNumericTests+ ]++------------------+-- Numeric tests+------------------++textNumericTests :: TestTree+textNumericTests = testGroup "Text numeric"+ [ testGroup "naturalDec"+ [ testPM "<empty>, fail" RT.naturalDec "" Nothing+ , testPM "1a, fail" RT.naturalDec "1a" Nothing+ , testPM "1a2, fail" RT.naturalDec "1a2" Nothing+ , testPM "0, ok" RT.naturalDec "0" (Just 0)+ , testPM "1, ok" RT.naturalDec "1" (Just 1)+ , testPM "-1, fail" RT.naturalDec "-1" Nothing+ , testPM "+1, fail" RT.naturalDec "+1" Nothing+ , testPM "01, fail" RT.naturalDec "01" Nothing+ , testPM "123456789123456789123456789, ok" RT.naturalDec "123456789123456789123456789" (Just 123456789123456789123456789)+ , testPM "18446744073709551615, ok" RT.naturalDec "18446744073709551615" (Just 18446744073709551615)+ , testPM "18446744073709551616, ok" RT.naturalDec "18446744073709551616" (Just 18446744073709551616)+ , testProperty "random dec" $+ forAll decText $ \t ->+ RT.reParse RT.naturalDec t === Just (read (T.unpack t))+ , testProperty "random" $+ forAll abDecText $ \t ->+ let ex = parseDecNoLz (T.unpack t)+ in classify (isJust ex) "ok" $+ RT.reParse RT.naturalDec t === ex+ ]+ , testGroup "integerDec"+ [ testPM "pure (), 1, ok" (RT.integerDec (pure ())) "1" (Just 1)+ , testPM "pure (), +1, ok" (RT.integerDec (pure ())) "+1" (Just 1)+ , testPM "pure (), -1, ok" (RT.integerDec (pure ())) "-1" (Just (-1))+ , testPM "pure (), 001, fail" (RT.integerDec (pure ())) "001" Nothing+ , testPM "pure (), +001, fail" (RT.integerDec (pure ())) "+001" Nothing+ , testPM "pure (), -001, fail" (RT.integerDec (pure ())) "-001" Nothing+ , testPM "lz, 1, ok" (RT.integerDec (many (RT.char '0'))) "1" (Just 1)+ , testPM "lz, +1, ok" (RT.integerDec (many (RT.char '0'))) "+1" (Just 1)+ , testPM "lz, -1, ok" (RT.integerDec (many (RT.char '0'))) "-1" (Just (-1))+ , 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)+ , testPM "lz, -001, ok" (RT.integerDec (many (RT.char '0'))) "-001" (Just (-1))+ , testProperty "random" $+ forAll (liftA2 (<>) (elements ["-","+",""]) abDecText) $ \t ->+ let ex = parseInteger parseDecNoLz (T.unpack t)+ in classify (isJust ex) "ok" $+ RT.reParse (RT.integerDec (pure ())) t === ex+ ]+ , testGroup "naturalHex"+ [ testPM "<empty>, fail" RT.naturalHex "" Nothing+ , testPM "1g, fail" RT.naturalHex "1g" Nothing+ , testPM "1g2, fail" RT.naturalHex "1g2" Nothing+ , testPM "0, ok" RT.naturalHex "0" (Just 0)+ , testPM "1, ok" RT.naturalHex "1" (Just 1)+ , testPM "f, ok" RT.naturalHex "f" (Just 15)+ , testPM "F, ok" RT.naturalHex "F" (Just 15)+ , testPM "-1, fail" RT.naturalHex "-1" Nothing+ , testPM "+1, fail" RT.naturalHex "+1" Nothing+ , testPM "01, fail" RT.naturalHex "01" Nothing+ , testPM "123456789abcdef123456789abcdef, ok" RT.naturalHex "123456789abcdef123456789abcdef" (Just 0x123456789abcdef123456789abcdef)+ , testPM "ffffffffffffffff, ok" RT.naturalHex "ffffffffffffffff" (Just 0xffffffffffffffff)+ , testPM "10000000000000000, ok" RT.naturalHex "10000000000000000" (Just 0x10000000000000000)+ , testProperty "random hex" $+ forAll hexText $ \t ->+ RT.reParse RT.naturalHex t === Just (read ("0x" ++ T.unpack t))+ , testProperty "random" $+ forAll pqHexText $ \t ->+ let ex = parseHexNoLz (T.unpack t)+ in classify (isJust ex) "ok" $+ RT.reParse RT.naturalHex t === ex+ ]+ , testGroup "integerHex"+ [ testPM "pure (), 1, ok" (RT.integerHex (pure ())) "1" (Just 1)+ , testPM "pure (), +1, ok" (RT.integerHex (pure ())) "+1" (Just 1)+ , testPM "pure (), -1, ok" (RT.integerHex (pure ())) "-1" (Just (-1))+ , testPM "pure (), 001, fail" (RT.integerHex (pure ())) "001" Nothing+ , testPM "pure (), +001, fail" (RT.integerHex (pure ())) "+001" Nothing+ , testPM "pure (), -001, fail" (RT.integerHex (pure ())) "-001" Nothing+ , testPM "lz, 1, ok" (RT.integerHex (many (RT.char '0'))) "1" (Just 1)+ , testPM "lz, +1, ok" (RT.integerHex (many (RT.char '0'))) "+1" (Just 1)+ , testPM "lz, -1, ok" (RT.integerHex (many (RT.char '0'))) "-1" (Just (-1))+ , 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)+ , testPM "lz, -001, ok" (RT.integerHex (many (RT.char '0'))) "-001" (Just (-1))+ , testProperty "random" $+ forAll (liftA2 (<>) (elements ["-","+",""]) pqHexText) $ \t ->+ let ex = parseInteger parseHexNoLz (T.unpack t)+ in classify (isJust ex) "ok" $+ RT.reParse (RT.integerHex (pure ())) t === ex+ ]+ , testGroup "wordRangeDec"+ [ testPM "(0,0) 0 ok" (RT.wordRangeDec (0,0)) "0" (Just 0)+ , testPM "(0,0) 1 fail" (RT.wordRangeDec (0,0)) "1" Nothing+ , testPM "(0,0) -1 fail" (RT.wordRangeDec (0,0)) "-1" Nothing+ , testPM "(1,0) 0 fail" (RT.wordRangeDec (1,0)) "1" Nothing+ , testPM "(1,0) 1 fail" (RT.wordRangeDec (1,0)) "0" Nothing+ , testPM "(0,19) 00 fail" (RT.wordRangeDec (0,19)) "00" Nothing+ , testPM "(100,999) 0 fail" (RT.wordRangeDec (100,999)) "0" Nothing+ , testPM "(100,999) 1 fail" (RT.wordRangeDec (100,999)) "1" Nothing+ , testPM "(100,999) 123 ok" (RT.wordRangeDec (100,999)) "123" (Just 123)+ , testPM "(100,999) 1234 fail" (RT.wordRangeDec (100,999)) "1234" Nothing+ , testPM "(0,1) 01 fail" (RT.wordRangeDec (0,1)) "01" Nothing+ , testPM "(0,maxBound) maxBound ok"+ (RT.wordRangeDec (0,maxBound))+ (T.pack (show (maxBound :: Word)))+ (Just maxBound)+ , testPM "(0,maxBound) (maxBound+1) fail"+ (RT.wordRangeDec (0,maxBound))+ (T.pack (show (fromIntegral (maxBound :: Word) + 1 :: Integer)))+ Nothing+ , testPM "(maxBound,maxBound) (maxBound-1) fail"+ (RT.wordRangeDec (maxBound,maxBound))+ (T.pack (show (maxBound - 1 :: Word)))+ Nothing+ , testGroup "bias"+ [ let re = RT.wordRangeDec (1,999) in+ testPM "(1,999) 2222 (222,2)" (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))+ ]+ , testProperty "any word" $ \(Large n) ->+ RT.reParse (RT.wordRangeDec (minBound,maxBound)) (T.pack (show n)) ===+ Just n+ , testGroup "random dec" $+ let f low high n =+ let ex = inRange n (low,high) in+ classify ex "inRange" $+ RT.reParse (RT.wordRangeDec (low,high)) (T.pack (show n)) ===+ if ex then Just n else Nothing+ in+ [ testProperty "small" f+ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n+ ]+ , testProperty "random" $ \low high ->+ forAll abDecText $ \t ->+ let ex = do+ x <- parseDecNoLz (T.unpack t)+ guard $ fromIntegral low <= x && x <= fromIntegral high+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RT.reParse (RT.wordRangeDec (low,high)) t === ex+ ]+ , testGroup "intRangeDec"+ [ testPM "pure (), (-1,1), 1, ok" (RT.intRangeDec (pure ()) (-1,1)) "1" (Just 1)+ , testPM "pure (), (-1,1), +1, ok" (RT.intRangeDec (pure ()) (-1,1)) "+1" (Just 1)+ , testPM "pure (), (-1,1), -1, ok" (RT.intRangeDec (pure ()) (-1,1)) "-1" (Just (-1))+ , testPM "pure (), (-1,1), 001, fail" (RT.intRangeDec (pure ()) (-1,1)) "001" Nothing+ , testPM "pure (), (-1,1), +001, fail" (RT.intRangeDec (pure ()) (-1,1)) "+001" Nothing+ , testPM "pure (), (-1,1), -001, fail" (RT.intRangeDec (pure ()) (-1,1)) "-001" Nothing+ , testPM "lz, (-1,1), 1, ok" (RT.intRangeDec (many (RT.char '0')) (-1,1)) "1" (Just 1)+ , testPM "lz, (-1,1), +1, ok" (RT.intRangeDec (many (RT.char '0')) (-1,1)) "+1" (Just 1)+ , testPM "lz, (-1,1), -1, ok" (RT.intRangeDec (many (RT.char '0')) (-1,1)) "-1" (Just (-1))+ , testPM "lz, (-1,1), 001, ok" (RT.intRangeDec (many (RT.char '0')) (-1,1)) "001" (Just 1)+ , testPM "lz, (-1,1), +001, ok" (RT.intRangeDec (many (RT.char '0')) (-1,1)) "+001" (Just 1)+ , testPM "lz, (-1,1), -001, ok" (RT.intRangeDec (many (RT.char '0')) (-1,1)) "-001" (Just (-1))+ , testPM "(minBound,maxBound) maxBound ok"+ (RT.intRangeDec (pure ()) (minBound,maxBound))+ (T.pack (show (maxBound :: Int)))+ (Just maxBound)+ , testPM "(minBound,maxBound) minBound ok"+ (RT.intRangeDec (pure ()) (minBound,maxBound))+ (T.pack (show (minBound :: Int)))+ (Just minBound)+ , testPM "(minBound,maxBound) (maxBound+1) fail"+ (RT.intRangeDec (pure ()) (minBound,maxBound))+ (T.pack (show (fromIntegral (maxBound :: Int) + 1 :: Integer)))+ Nothing+ , testPM "(minBound,maxBound) (minBound+1) fail"+ (RT.intRangeDec (pure ()) (minBound,maxBound))+ (T.pack (show (fromIntegral (minBound :: Int) - 1 :: Integer)))+ Nothing+ , testPM "(maxBound,maxBound) (maxBound-1) fail"+ (RT.intRangeDec (pure ()) (maxBound,maxBound))+ (T.pack (show (maxBound - 1 :: Int)))+ Nothing+ , testPM "(minBound,minBound) (minBound+1) fail"+ (RT.intRangeDec (pure ()) (minBound,minBound))+ (T.pack (show (minBound + 1 :: Int)))+ Nothing+ , testProperty "any int" $ \(Large n) ->+ RT.reParse (RT.intRangeDec (pure ()) (minBound,maxBound)) (T.pack (show n)) === Just n+ , testGroup "random dec" $+ let f low high n = forAll (showIntDecExtraSign n) $ \nstr ->+ let ex = inRange n (low,high) in+ classify ex "inRange" $+ RT.reParse (RT.intRangeDec (pure ()) (low,high)) (T.pack nstr) ===+ if ex then Just n else Nothing+ in+ [ testProperty "small" f+ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n+ ]+ , testProperty "random" $ \low high ->+ forAll (liftA2 (<>) (elements ["-","+",""]) abDecText) $ \t ->+ let ex = do+ x <- parseInteger parseDecNoLz (T.unpack t)+ guard $ fromIntegral low <= x && x <= fromIntegral high+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RT.reParse (RT.intRangeDec (pure ()) (low,high)) t === ex+ ]+ , testGroup "wordRangeHex"+ [ testPM "(0,0) 0 ok" (RT.wordRangeHex (0,0)) "0" (Just 0)+ , testPM "(0,0) 1 fail" (RT.wordRangeHex (0,0)) "1" Nothing+ , testPM "(0,0) -1 fail" (RT.wordRangeHex (0,0)) "-1" Nothing+ , testPM "(1,0) 0 fail" (RT.wordRangeHex (1,0)) "1" Nothing+ , testPM "(1,0) 1 fail" (RT.wordRangeHex (1,0)) "0" Nothing+ , testPM "(0,1f) 00 fail" (RT.wordRangeHex (0,0x1f)) "00" Nothing+ , testPM "(100,fff) 0 fail" (RT.wordRangeHex (0x100,0xfff)) "0" Nothing+ , testPM "(100,fff) 1 fail" (RT.wordRangeHex (0x100,0xfff)) "1" Nothing+ , testPM "(100,fff) 123 ok" (RT.wordRangeHex (0x100,0xfff)) "123" (Just 0x123)+ , testPM "(100,fff) 1234 fail" (RT.wordRangeHex (0x100,0xfff)) "1234" Nothing+ , testPM "(0,1) 01 fail" (RT.wordRangeHex (0,1)) "01" Nothing+ , testPM "(0,maxBound) maxBound ok"+ (RT.wordRangeHex (0,maxBound))+ (T.pack (showHex (maxBound :: Word)))+ (Just maxBound)+ , testPM "(0,maxBound) (maxBound+1) fail"+ (RT.wordRangeHex (0,maxBound))+ (T.pack (showHex (fromIntegral (maxBound :: Word) + 1 :: Integer)))+ Nothing+ , testPM "(maxBound,maxBound) (maxBound-1) fail"+ (RT.wordRangeHex (maxBound,maxBound))+ (T.pack (showHex (maxBound - 1 :: Word)))+ Nothing+ , testGroup "bias"+ [ let re = RT.wordRangeHex (0x1,0x999) in+ testPM "(1,999) 2222 (222,2)" (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))+ ]+ , testProperty "any word" $ \(Large n) ->+ RT.reParse (RT.wordRangeHex (minBound,maxBound)) (T.pack (showHex n)) ===+ Just n+ , testGroup "random hex" $+ let f low high n =+ let ex = inRange n (low,high) in+ classify ex "inRange" $+ RT.reParse (RT.wordRangeHex (low,high)) (T.pack (showHex n)) ===+ if ex then Just n else Nothing+ in+ [ testProperty "small" f+ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n+ ]+ , testProperty "random" $ \low high ->+ forAll pqHexText $ \t ->+ let ex = do+ x <- parseHexNoLz (T.unpack t)+ guard $ fromIntegral low <= x && x <= fromIntegral high+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RT.reParse (RT.wordRangeHex (low,high)) t === ex+ ]+ , testGroup "intRangeHex"+ [ testPM "pure (), (-1,1), 1, ok" (RT.intRangeHex (pure ()) (-1,1)) "1" (Just 1)+ , testPM "pure (), (-1,1), +1, ok" (RT.intRangeHex (pure ()) (-1,1)) "+1" (Just 1)+ , testPM "pure (), (-1,1), -1, ok" (RT.intRangeHex (pure ()) (-1,1)) "-1" (Just (-1))+ , testPM "pure (), (-1,1), 001, fail" (RT.intRangeHex (pure ()) (-1,1)) "001" Nothing+ , testPM "pure (), (-1,1), +001, fail" (RT.intRangeHex (pure ()) (-1,1)) "+001" Nothing+ , testPM "pure (), (-1,1), -001, fail" (RT.intRangeHex (pure ()) (-1,1)) "-001" Nothing+ , testPM "lz, (-1,1), 1, ok" (RT.intRangeHex (many (RT.char '0')) (-1,1)) "1" (Just 1)+ , testPM "lz, (-1,1), +1, ok" (RT.intRangeHex (many (RT.char '0')) (-1,1)) "+1" (Just 1)+ , testPM "lz, (-1,1), -1, ok" (RT.intRangeHex (many (RT.char '0')) (-1,1)) "-1" (Just (-1))+ , testPM "lz, (-1,1), 001, ok" (RT.intRangeHex (many (RT.char '0')) (-1,1)) "001" (Just 1)+ , testPM "lz, (-1,1), +001, ok" (RT.intRangeHex (many (RT.char '0')) (-1,1)) "+001" (Just 1)+ , testPM "lz, (-1,1), -001, ok" (RT.intRangeHex (many (RT.char '0')) (-1,1)) "-001" (Just (-1))+ , testPM "(minBound,maxBound) maxBound ok"+ (RT.intRangeHex (pure ()) (minBound,maxBound))+ (T.pack (showHex (maxBound :: Int)))+ (Just maxBound)+ , testPM "(minBound,maxBound) minBound ok"+ (RT.intRangeHex (pure ()) (minBound,maxBound))+ (T.pack (showHex (minBound :: Int)))+ (Just minBound)+ , testPM "(minBound,maxBound) (maxBound+1) fail"+ (RT.intRangeHex (pure ()) (minBound,maxBound))+ (T.pack (showHex (fromIntegral (maxBound :: Int) + 1 :: Integer)))+ Nothing+ , testPM "(minBound,maxBound) (minBound+1) fail"+ (RT.intRangeHex (pure ()) (minBound,maxBound))+ (T.pack (showHex (fromIntegral (minBound :: Int) - 1 :: Integer)))+ Nothing+ , testPM "(maxBound,maxBound) (maxBound-1) fail"+ (RT.intRangeHex (pure ()) (maxBound,maxBound))+ (T.pack (showHex (maxBound - 1 :: Int)))+ Nothing+ , testPM "(minBound,minBound) (minBound+1) fail"+ (RT.intRangeHex (pure ()) (minBound,minBound))+ (T.pack (showHex (minBound + 1 :: Int)))+ Nothing+ , testProperty "any int" $ \(Large n) ->+ RT.reParse (RT.intRangeHex (pure ()) (minBound,maxBound)) (T.pack (showHex n)) === Just n+ , testGroup "random hex" $+ let f low high n = forAll (showIntHexExtraSign n) $ \nstr ->+ let ex = inRange n (low,high) in+ classify ex "inRange" $+ RT.reParse (RT.intRangeHex (pure ()) (low,high)) (T.pack nstr) ===+ if ex then Just n else Nothing+ in+ [ testProperty "small" f+ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n+ ]+ , testProperty "random" $ \low high ->+ forAll (liftA2 (<>) (elements ["-","+",""]) pqHexText) $ \t ->+ let ex = do+ x <- parseInteger parseHexNoLz (T.unpack t)+ guard $ fromIntegral low <= x && x <= fromIntegral high+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RT.reParse (RT.intRangeHex (pure ()) (low,high)) t === ex+ ]+ , testGroup "wordDecN"+ [ let n = maxBound :: Word+ t = T.pack (show n)+ in+ testPM "maxBound ok" (RT.wordDecN (T.length t)) t (Just n)+ , let n = fromIntegral (maxBound :: Word) + 1 :: Integer+ t = T.pack (show n)+ in+ testPM "(maxBound+1) fail" (RT.wordDecN (T.length t)) t Nothing+ , testPM "<29 0, 1 1> ok" (RT.wordDecN 30) (T.replicate 29 "0" <> "1") (Just 1)+ , testProperty "random dec" $ \n ->+ forAll (let d = elements decDigits+ in frequency [(3, vectorOf n d), (1, listOf d)]) $ \s ->+ let ok = n > 0+ && length s == n+ && (read s :: Integer) < fromIntegral (maxBound :: Word)+ in classify ok "ok" $+ RT.reParse (RT.wordDecN n) (T.pack s) ===+ if ok then Just (read s) else Nothing+ , testProperty "random" $ \n ->+ forAll abDecText $ \t ->+ let ex = do+ guard $ n > 0 && T.length t == n+ x <- if T.all (=='0') t+ then Just 0+ else parseDecNoLz $ dropWhile (=='0') $ T.unpack t+ guard $ x <= fromIntegral (maxBound :: Word)+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RT.reParse (RT.wordDecN n) t === ex+ ]+ , testGroup "wordHexN"+ [ let n = maxBound :: Word+ t = T.pack (showHex n)+ in+ testPM "maxBound ok" (RT.wordHexN (T.length t)) t (Just n)+ , let n = fromIntegral (maxBound :: Word) + 1 :: Integer+ t = T.pack (showHex n)+ in+ testPM "(maxBound+1) fail" (RT.wordHexN (T.length t)) t Nothing+ , testPM "<29 0, 1 1> ok" (RT.wordHexN 30) (T.replicate 29 "0" <> "1") (Just 1)+ , testProperty "random hex" $ \n ->+ forAll (let d = elements hexDigits+ in frequency [(3, vectorOf n d), (1, listOf d)]) $ \s ->+ let ok = n > 0+ && length s == n+ && (read ("0x" ++ s) :: Integer) < fromIntegral (maxBound :: Word)+ in+ classify ok "ok" $+ RT.reParse (RT.wordHexN n) (T.pack s) ===+ if ok then Just (read ("0x" ++ s)) else Nothing+ , testProperty "random" $ \n ->+ forAll pqHexText $ \t ->+ let ex = do+ guard $ n > 0 && T.length t == n+ x <- if T.all (=='0') t+ then Just 0+ else parseHexNoLz $ dropWhile (=='0') $ T.unpack t+ guard $ x <= fromIntegral (maxBound :: Word)+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RT.reParse (RT.wordHexN n) t === ex+ ]+ ]++stringNumericTests :: TestTree+stringNumericTests = testGroup "Text numeric"+ [ testGroup "naturalDec"+ [ testLPM "<empty>, fail" RL.naturalDec "" Nothing+ , testLPM "1a, fail" RL.naturalDec "1a" Nothing+ , testLPM "1a2, fail" RL.naturalDec "1a2" Nothing+ , testLPM "0, ok" RL.naturalDec "0" (Just 0)+ , testLPM "1, ok" RL.naturalDec "1" (Just 1)+ , testLPM "-1, fail" RL.naturalDec "-1" Nothing+ , testLPM "+1, fail" RL.naturalDec "+1" Nothing+ , testLPM "01, fail" RL.naturalDec "01" Nothing+ , testLPM "123456789123456789123456789, ok" RL.naturalDec "123456789123456789123456789" (Just 123456789123456789123456789)+ , testLPM "18446744073709551615, ok" RL.naturalDec "18446744073709551615" (Just 18446744073709551615)+ , testLPM "18446744073709551616, ok" RL.naturalDec "18446744073709551616" (Just 18446744073709551616)+ , testProperty "random dec" $+ forAll decString $ \t ->+ RL.reParse RL.naturalDec t === Just (read t)+ , testProperty "random" $+ forAll abDecString $ \t ->+ let ex = parseDecNoLz t+ in classify (isJust ex) "ok" $+ RL.reParse RL.naturalDec t === ex+ ]+ , testGroup "integerDec"+ [ testLPM "pure (), 1, ok" (RL.integerDec (pure ())) "1" (Just 1)+ , testLPM "pure (), +1, ok" (RL.integerDec (pure ())) "+1" (Just 1)+ , testLPM "pure (), -1, ok" (RL.integerDec (pure ())) "-1" (Just (-1))+ , testLPM "pure (), 001, fail" (RL.integerDec (pure ())) "001" Nothing+ , testLPM "pure (), +001, fail" (RL.integerDec (pure ())) "+001" Nothing+ , testLPM "pure (), -001, fail" (RL.integerDec (pure ())) "-001" Nothing+ , testLPM "lz, 1, ok" (RL.integerDec (many (RL.single '0'))) "1" (Just 1)+ , testLPM "lz, +1, ok" (RL.integerDec (many (RL.single '0'))) "+1" (Just 1)+ , testLPM "lz, -1, ok" (RL.integerDec (many (RL.single '0'))) "-1" (Just (-1))+ , 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)+ , testLPM "lz, -001, ok" (RL.integerDec (many (RL.single '0'))) "-001" (Just (-1))+ , testProperty "random" $+ forAll (liftA2 (<>) (elements ["-","+",""]) abDecString) $ \t ->+ let ex = parseInteger parseDecNoLz t+ in classify (isJust ex) "ok" $+ RL.reParse (RL.integerDec (pure ())) t === ex+ ]+ , testGroup "naturalHex"+ [ testLPM "<empty>, fail" RL.naturalHex "" Nothing+ , testLPM "1g, fail" RL.naturalHex "1g" Nothing+ , testLPM "1g2, fail" RL.naturalHex "1g2" Nothing+ , testLPM "0, ok" RL.naturalHex "0" (Just 0)+ , testLPM "1, ok" RL.naturalHex "1" (Just 1)+ , testLPM "f, ok" RL.naturalHex "f" (Just 15)+ , testLPM "F, ok" RL.naturalHex "F" (Just 15)+ , testLPM "-1, fail" RL.naturalHex "-1" Nothing+ , testLPM "+1, fail" RL.naturalHex "+1" Nothing+ , testLPM "01, fail" RL.naturalHex "01" Nothing+ , testLPM "123456789abcdef123456789abcdef, ok" RL.naturalHex "123456789abcdef123456789abcdef" (Just 0x123456789abcdef123456789abcdef)+ , testLPM "ffffffffffffffff, ok" RL.naturalHex "ffffffffffffffff" (Just 0xffffffffffffffff)+ , testLPM "10000000000000000, ok" RL.naturalHex "10000000000000000" (Just 0x10000000000000000)+ , testProperty "random hex" $+ forAll hexString $ \t ->+ RL.reParse RL.naturalHex t === Just (read ("0x" ++ t))+ , testProperty "random" $+ forAll pqHexString $ \t ->+ let ex = parseHexNoLz t+ in classify (isJust ex) "ok" $+ RL.reParse RL.naturalHex t === ex+ ]+ , testGroup "integerHex"+ [ testLPM "pure (), 1, ok" (RL.integerHex (pure ())) "1" (Just 1)+ , testLPM "pure (), +1, ok" (RL.integerHex (pure ())) "+1" (Just 1)+ , testLPM "pure (), -1, ok" (RL.integerHex (pure ())) "-1" (Just (-1))+ , testLPM "pure (), 001, fail" (RL.integerHex (pure ())) "001" Nothing+ , testLPM "pure (), +001, fail" (RL.integerHex (pure ())) "+001" Nothing+ , testLPM "pure (), -001, fail" (RL.integerHex (pure ())) "-001" Nothing+ , testLPM "lz, 1, ok" (RL.integerHex (many (RL.single '0'))) "1" (Just 1)+ , testLPM "lz, +1, ok" (RL.integerHex (many (RL.single '0'))) "+1" (Just 1)+ , testLPM "lz, -1, ok" (RL.integerHex (many (RL.single '0'))) "-1" (Just (-1))+ , 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)+ , testLPM "lz, -001, ok" (RL.integerHex (many (RL.single '0'))) "-001" (Just (-1))+ , testProperty "random" $+ forAll (liftA2 (<>) (elements ["-","+",""]) pqHexString) $ \t ->+ let ex = parseInteger parseHexNoLz t+ in classify (isJust ex) "ok" $+ RL.reParse (RL.integerHex (pure ())) t === ex+ ]+ , testGroup "wordRangeDec"+ [ testLPM "(0,0) 0 ok" (RL.wordRangeDec (0,0)) "0" (Just 0)+ , testLPM "(0,0) 1 fail" (RL.wordRangeDec (0,0)) "1" Nothing+ , testLPM "(0,0) -1 fail" (RL.wordRangeDec (0,0)) "-1" Nothing+ , testLPM "(1,0) 0 fail" (RL.wordRangeDec (1,0)) "1" Nothing+ , testLPM "(1,0) 1 fail" (RL.wordRangeDec (1,0)) "0" Nothing+ , testLPM "(0,19) 00 fail" (RL.wordRangeDec (0,19)) "00" Nothing+ , testLPM "(100,999) 0 fail" (RL.wordRangeDec (100,999)) "0" Nothing+ , testLPM "(100,999) 1 fail" (RL.wordRangeDec (100,999)) "1" Nothing+ , testLPM "(100,999) 123 ok" (RL.wordRangeDec (100,999)) "123" (Just 123)+ , testLPM "(100,999) 1234 fail" (RL.wordRangeDec (100,999)) "1234" Nothing+ , testLPM "(0,1) 01 fail" (RL.wordRangeDec (0,1)) "01" Nothing+ , testLPM "(0,maxBound) maxBound ok"+ (RL.wordRangeDec (0,maxBound))+ (show (maxBound :: Word))+ (Just maxBound)+ , testLPM "(0,maxBound) (maxBound+1) fail"+ (RL.wordRangeDec (0,maxBound))+ (show (fromIntegral (maxBound :: Word) + 1 :: Integer))+ Nothing+ , testLPM "(maxBound,maxBound) (maxBound-1) fail"+ (RL.wordRangeDec (maxBound,maxBound))+ (show (maxBound - 1 :: Word))+ Nothing+ , testGroup "bias"+ [ let re = RL.wordRangeDec (1,999) in+ testLPM "(1,999) 2222 (222,2)" (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))+ ]+ , testProperty "any word" $ \(Large n) ->+ RL.reParse (RL.wordRangeDec (minBound,maxBound)) (show n) ===+ Just n+ , testGroup "random dec" $+ let f low high n =+ let ex = inRange n (low,high) in+ classify ex "inRange" $+ RL.reParse (RL.wordRangeDec (low,high)) (show n) ===+ if ex then Just n else Nothing+ in+ [ testProperty "small" f+ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n+ ]+ , testProperty "random" $ \low high ->+ forAll abDecString $ \t ->+ let ex = do+ x <- parseDecNoLz t+ guard $ fromIntegral low <= x && x <= fromIntegral high+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RL.reParse (RL.wordRangeDec (low,high)) t === ex+ ]+ , testGroup "intRangeDec"+ [ testLPM "pure (), (-1,1), 1, ok" (RL.intRangeDec (pure ()) (-1,1)) "1" (Just 1)+ , testLPM "pure (), (-1,1), +1, ok" (RL.intRangeDec (pure ()) (-1,1)) "+1" (Just 1)+ , testLPM "pure (), (-1,1), -1, ok" (RL.intRangeDec (pure ()) (-1,1)) "-1" (Just (-1))+ , testLPM "pure (), (-1,1), 001, fail" (RL.intRangeDec (pure ()) (-1,1)) "001" Nothing+ , testLPM "pure (), (-1,1), +001, fail" (RL.intRangeDec (pure ()) (-1,1)) "+001" Nothing+ , testLPM "pure (), (-1,1), -001, fail" (RL.intRangeDec (pure ()) (-1,1)) "-001" Nothing+ , testLPM "lz, (-1,1), 1, ok" (RL.intRangeDec (many (RL.single '0')) (-1,1)) "1" (Just 1)+ , testLPM "lz, (-1,1), +1, ok" (RL.intRangeDec (many (RL.single '0')) (-1,1)) "+1" (Just 1)+ , testLPM "lz, (-1,1), -1, ok" (RL.intRangeDec (many (RL.single '0')) (-1,1)) "-1" (Just (-1))+ , testLPM "lz, (-1,1), 001, ok" (RL.intRangeDec (many (RL.single '0')) (-1,1)) "001" (Just 1)+ , testLPM "lz, (-1,1), +001, ok" (RL.intRangeDec (many (RL.single '0')) (-1,1)) "+001" (Just 1)+ , testLPM "lz, (-1,1), -001, ok" (RL.intRangeDec (many (RL.single '0')) (-1,1)) "-001" (Just (-1))+ , testLPM "(minBound,maxBound) maxBound ok"+ (RL.intRangeDec (pure ()) (minBound,maxBound))+ (show (maxBound :: Int))+ (Just maxBound)+ , testLPM "(minBound,maxBound) minBound ok"+ (RL.intRangeDec (pure ()) (minBound,maxBound))+ (show (minBound :: Int))+ (Just minBound)+ , testLPM "(minBound,maxBound) (maxBound+1) fail"+ (RL.intRangeDec (pure ()) (minBound,maxBound))+ (show (fromIntegral (maxBound :: Int) + 1 :: Integer))+ Nothing+ , testLPM "(minBound,maxBound) (minBound+1) fail"+ (RL.intRangeDec (pure ()) (minBound,maxBound))+ (show (fromIntegral (minBound :: Int) - 1 :: Integer))+ Nothing+ , testLPM "(maxBound,maxBound) (maxBound-1) fail"+ (RL.intRangeDec (pure ()) (maxBound,maxBound))+ (show (maxBound - 1 :: Int))+ Nothing+ , testLPM "(minBound,minBound) (minBound+1) fail"+ (RL.intRangeDec (pure ()) (minBound,minBound))+ (show (minBound + 1 :: Int))+ Nothing+ , testProperty "any int" $ \(Large n) ->+ RL.reParse (RL.intRangeDec (pure ()) (minBound,maxBound)) (show n) === Just n+ , testGroup "random dec" $+ let f low high n = forAll (showIntDecExtraSign n) $ \nstr ->+ let ex = inRange n (low,high) in+ classify ex "inRange" $+ RL.reParse (RL.intRangeDec (pure ()) (low,high)) nstr ===+ if ex then Just n else Nothing+ in+ [ testProperty "small" f+ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n+ ]+ , testProperty "random" $ \low high ->+ forAll (liftA2 (<>) (elements ["-","+",""]) abDecString) $ \t ->+ let ex = do+ x <- parseInteger parseDecNoLz t+ guard $ fromIntegral low <= x && x <= fromIntegral high+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RL.reParse (RL.intRangeDec (pure ()) (low,high)) t === ex+ ]+ , testGroup "wordRangeHex"+ [ testLPM "(0,0) 0 ok" (RL.wordRangeHex (0,0)) "0" (Just 0)+ , testLPM "(0,0) 1 fail" (RL.wordRangeHex (0,0)) "1" Nothing+ , testLPM "(0,0) -1 fail" (RL.wordRangeHex (0,0)) "-1" Nothing+ , testLPM "(1,0) 0 fail" (RL.wordRangeHex (1,0)) "1" Nothing+ , testLPM "(1,0) 1 fail" (RL.wordRangeHex (1,0)) "0" Nothing+ , testLPM "(0,1f) 00 fail" (RL.wordRangeHex (0,0x1f)) "00" Nothing+ , testLPM "(100,fff) 0 fail" (RL.wordRangeHex (0x100,0xfff)) "0" Nothing+ , testLPM "(100,fff) 1 fail" (RL.wordRangeHex (0x100,0xfff)) "1" Nothing+ , testLPM "(100,fff) 123 ok" (RL.wordRangeHex (0x100,0xfff)) "123" (Just 0x123)+ , testLPM "(100,fff) 1234 fail" (RL.wordRangeHex (0x100,0xfff)) "1234" Nothing+ , testLPM "(0,1) 01 fail" (RL.wordRangeHex (0,1)) "01" Nothing+ , testLPM "(0,maxBound) maxBound ok"+ (RL.wordRangeHex (0,maxBound))+ (showHex (maxBound :: Word))+ (Just maxBound)+ , testLPM "(0,maxBound) (maxBound+1) fail"+ (RL.wordRangeHex (0,maxBound))+ (showHex (fromIntegral (maxBound :: Word) + 1 :: Integer))+ Nothing+ , testLPM "(maxBound,maxBound) (maxBound-1) fail"+ (RL.wordRangeHex (maxBound,maxBound))+ (showHex (maxBound - 1 :: Word))+ Nothing+ , testGroup "bias"+ [ let re = RL.wordRangeHex (0x1,0x999) in+ testLPM "(1,999) 2222 (222,2)" (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))+ ]+ , testProperty "any word" $ \(Large n) ->+ RL.reParse (RL.wordRangeHex (minBound,maxBound)) (showHex n) ===+ Just n+ , testGroup "random hex" $+ let f low high n =+ let ex = inRange n (low,high) in+ classify ex "inRange" $+ RL.reParse (RL.wordRangeHex (low,high)) (showHex n) ===+ if ex then Just n else Nothing+ in+ [ testProperty "small" f+ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n+ ]+ , testProperty "random" $ \low high ->+ forAll pqHexString $ \t ->+ let ex = do+ x <- parseHexNoLz t+ guard $ fromIntegral low <= x && x <= fromIntegral high+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RL.reParse (RL.wordRangeHex (low,high)) t === ex+ ]+ , testGroup "intRangeHex"+ [ testLPM "pure (), (-1,1), 1, ok" (RL.intRangeHex (pure ()) (-1,1)) "1" (Just 1)+ , testLPM "pure (), (-1,1), +1, ok" (RL.intRangeHex (pure ()) (-1,1)) "+1" (Just 1)+ , testLPM "pure (), (-1,1), -1, ok" (RL.intRangeHex (pure ()) (-1,1)) "-1" (Just (-1))+ , testLPM "pure (), (-1,1), 001, fail" (RL.intRangeHex (pure ()) (-1,1)) "001" Nothing+ , testLPM "pure (), (-1,1), +001, fail" (RL.intRangeHex (pure ()) (-1,1)) "+001" Nothing+ , testLPM "pure (), (-1,1), -001, fail" (RL.intRangeHex (pure ()) (-1,1)) "-001" Nothing+ , testLPM "lz, (-1,1), 1, ok" (RL.intRangeHex (many (RL.single '0')) (-1,1)) "1" (Just 1)+ , testLPM "lz, (-1,1), +1, ok" (RL.intRangeHex (many (RL.single '0')) (-1,1)) "+1" (Just 1)+ , testLPM "lz, (-1,1), -1, ok" (RL.intRangeHex (many (RL.single '0')) (-1,1)) "-1" (Just (-1))+ , testLPM "lz, (-1,1), 001, ok" (RL.intRangeHex (many (RL.single '0')) (-1,1)) "001" (Just 1)+ , testLPM "lz, (-1,1), +001, ok" (RL.intRangeHex (many (RL.single '0')) (-1,1)) "+001" (Just 1)+ , testLPM "lz, (-1,1), -001, ok" (RL.intRangeHex (many (RL.single '0')) (-1,1)) "-001" (Just (-1))+ , testLPM "(minBound,maxBound) maxBound ok"+ (RL.intRangeHex (pure ()) (minBound,maxBound))+ (showHex (maxBound :: Int))+ (Just maxBound)+ , testLPM "(minBound,maxBound) minBound ok"+ (RL.intRangeHex (pure ()) (minBound,maxBound))+ (showHex (minBound :: Int))+ (Just minBound)+ , testLPM "(minBound,maxBound) (maxBound+1) fail"+ (RL.intRangeHex (pure ()) (minBound,maxBound))+ (showHex (fromIntegral (maxBound :: Int) + 1 :: Integer))+ Nothing+ , testLPM "(minBound,maxBound) (minBound+1) fail"+ (RL.intRangeHex (pure ()) (minBound,maxBound))+ (showHex (fromIntegral (minBound :: Int) - 1 :: Integer))+ Nothing+ , testLPM "(maxBound,maxBound) (maxBound-1) fail"+ (RL.intRangeHex (pure ()) (maxBound,maxBound))+ (showHex (maxBound - 1 :: Int))+ Nothing+ , testLPM "(minBound,minBound) (minBound+1) fail"+ (RL.intRangeHex (pure ()) (minBound,minBound))+ (showHex (minBound + 1 :: Int))+ Nothing+ , testProperty "any int" $ \(Large n) ->+ RL.reParse (RL.intRangeHex (pure ()) (minBound,maxBound)) (showHex n) === Just n+ , testGroup "random hex" $+ let f low high n = forAll (showIntHexExtraSign n) $ \nstr ->+ let ex = inRange n (low,high) in+ classify ex "inRange" $+ RL.reParse (RL.intRangeHex (pure ()) (low,high)) nstr ===+ if ex then Just n else Nothing+ in+ [ testProperty "small" f+ , testProperty "large" $ \(Large low) (Large high) (Large n) -> f low high n+ ]+ , testProperty "random" $ \low high ->+ forAll (liftA2 (<>) (elements ["-","+",""]) pqHexString) $ \t ->+ let ex = do+ x <- parseInteger parseHexNoLz t+ guard $ fromIntegral low <= x && x <= fromIntegral high+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RL.reParse (RL.intRangeHex (pure ()) (low,high)) t === ex+ ]+ , testGroup "wordDecN"+ [ let n = maxBound :: Word+ t = show n+ in+ testLPM "maxBound ok" (RL.wordDecN (length t)) t (Just n)+ , let n = fromIntegral (maxBound :: Word) + 1 :: Integer+ t = show n+ in+ testLPM "(maxBound+1) fail" (RL.wordDecN (length t)) t Nothing+ , testLPM "<29 0, 1 1> ok" (RL.wordDecN 30) (replicate 29 '0' <> "1") (Just 1)+ , testProperty "random dec" $ \n ->+ forAll (let d = elements decDigits+ in frequency [(3, vectorOf n d), (1, listOf d)]) $ \s ->+ let ok = n > 0+ && length s == n+ && (read s :: Integer) < fromIntegral (maxBound :: Word)+ in classify ok "ok" $+ RL.reParse (RL.wordDecN n) s ===+ if ok then Just (read s) else Nothing+ , testProperty "random" $ \n ->+ forAll abDecString $ \t ->+ let ex = do+ guard $ n > 0 && length t == n+ x <- if all (=='0') t+ then Just 0+ else parseDecNoLz $ dropWhile (=='0') t+ guard $ x <= fromIntegral (maxBound :: Word)+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RL.reParse (RL.wordDecN n) t === ex+ ]+ , testGroup "wordHexN"+ [ let n = maxBound :: Word+ t = showHex n+ in+ testLPM "maxBound ok" (RL.wordHexN (length t)) t (Just n)+ , let n = fromIntegral (maxBound :: Word) + 1 :: Integer+ t = showHex n+ in+ testLPM "(maxBound+1) fail" (RL.wordHexN (length t)) t Nothing+ , testLPM "<29 0, 1 1> ok" (RL.wordHexN 30) (replicate 29 '0' <> "1") (Just 1)+ , testProperty "random hex" $ \n ->+ forAll (let d = elements hexDigits+ in frequency [(3, vectorOf n d), (1, listOf d)]) $ \s ->+ let ok = n > 0+ && length s == n+ && (read ("0x" ++ s) :: Integer) < fromIntegral (maxBound :: Word)+ in+ classify ok "ok" $+ RL.reParse (RL.wordHexN n) s ===+ if ok then Just (read ("0x" ++ s)) else Nothing+ , testProperty "random" $ \n ->+ forAll pqHexString $ \t ->+ let ex = do+ guard $ n > 0 && length t == n+ x <- if all (=='0') t+ then Just 0+ else parseHexNoLz $ dropWhile (=='0') t+ guard $ x <= fromIntegral (maxBound :: Word)+ pure $ fromIntegral x+ in classify (isJust ex) "ok" $+ RL.reParse (RL.wordHexN n) t === ex+ ]+ ]++decString :: Gen String+decString = do+ s <- listOf (elements decDigits)+ let s' = dropWhile (=='0') s+ pure $ if null s' then "0" else s'++decText :: Gen Text+decText = T.pack <$> decString++hexString :: Gen String+hexString = do+ s <- listOf (elements hexDigits)+ let s' = dropWhile (=='0') s+ pure $ if null s' then "0" else s'++hexText :: Gen Text+hexText = T.pack <$> hexString++decDigits :: String+decDigits = "0123456789"++hexDigits :: String+hexDigits = "0123456789ABCDEFabcdef"++abDecString :: Gen String+abDecString = listOf (elements ("ab" ++ decDigits))++abDecText :: Gen Text+abDecText = T.pack <$> abDecString++pqHexString :: Gen String+pqHexString = listOf (elements ("pq" ++ hexDigits))++pqHexText :: Gen Text+pqHexText = T.pack <$> pqHexString++showHex :: Integral a => a -> String+showHex n = (if n < 0 then ('-':) else id)+ (Num.showHex (abs (fromIntegral n :: Integer)) "")++showIntDecExtraSign :: Int -> Gen String+showIntDecExtraSign n = (<> show n) <$> sgn n+ where+ sgn x = case compare 0 x of+ LT -> elements ["+", ""]+ EQ -> elements ["-", "+", ""]+ GT -> pure ""++showIntHexExtraSign :: Int -> Gen String+showIntHexExtraSign n = (<> showHex n) <$> sgn n+ where+ sgn x = case compare 0 x of+ LT -> elements ["+", ""]+ EQ -> elements ["-", "+", ""]+ GT -> pure ""++parseInteger :: (String -> Maybe Natural) -> String -> Maybe Integer+parseInteger p s = case s of+ '-':s' -> negate . fromIntegral <$> p s'+ '+':s' -> fromIntegral <$> p s'+ _ -> fromIntegral <$> p s++parseDecNoLz :: String -> Maybe Natural+parseDecNoLz s = case s of+ "" -> Nothing+ "0" -> Just 0+ ('0':_) -> Nothing+ _ | (s1,[]) <- span isDigit s -> Just (read s1)+ | otherwise -> Nothing++parseHexNoLz :: String -> Maybe Natural+parseHexNoLz s = case s of+ "" -> Nothing+ "0" -> Just 0+ ('0':_) -> Nothing+ _ | (s1,[]) <- span isHexDigit s -> Just (read ("0x" ++ s1))+ | otherwise -> Nothing++----------------+-- Combinators+----------------++combinatorTests :: TestTree+combinatorTests = testGroup "Combinators"+ [ testGroup "pure"+ [ testPM "pure (), <e>, ok" (pure ()) "" (Just ())+ , testPM "pure (), a, fail" (pure ()) "a" Nothing+ ]+ , testGroup "liftA2" $+ let re = 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+ , testPM "a b, ab, ok" re "ab" (Just ('a','b'))+ ]+ , testGroup "<|>" $+ let ab = RT.char 'a' <|> RT.char 'b' in+ [ testPM "a <|> b, <e>, fail" ab "" Nothing+ , testPM "a <|> b, a, ok" ab "a" (Just 'a')+ , testPM "a <|> b, b, ok" ab "b" (Just 'b')+ , testGroup "bias"+ [ let re = (1 :: Int) <$ RT.char 'a' <|> 2 <$ RT.char 'a' in+ testPM "1 <$ a <|> 2 <$ a, a, ok" re "a" (Just 1)+ ]+ ]+ , testGroup "Semigroup,Monoid" $+ let go abc =+ [ testPM "<e>, fail" abc "" Nothing+ , testPM "a, fail" abc "a" Nothing+ , testPM "bc, fail" abc "bc" Nothing+ , testPM "abc, ok" abc "abc" (Just "abc")+ ]+ in+ [ testGroup "<>" $ go (RT.text "a" <> RT.text "bc")+ , testGroup "<> mempty" $ go (RT.text "abc" <> mempty)+ , testGroup "mempty <>" $ go (mempty <> RT.text "abc")+ , testGroup "sconcat" $ go (sconcat (RT.text "a" :| [RT.text "b", RT.text "c"]))+ , testGroup "mconcat" $ go (mconcat [RT.text "a", RT.text "b", RT.text "c"])+ ]+ , testGroup "many" $+ let a = many (RT.char 'a')+ pr = many (pure ())+ in+ [ testPM "many a, aa, ok" a "aa" (Just "aa")+ , testPM "many a, a, ok" a "a" (Just "a")+ , testPM "many a, <e>, ok" a "" (Just "")+ , testPM "many (pure ()), <e>, ok" pr "" (Just [])+ , testPM "many (pure ()), aaa, fail" pr "aaa" Nothing+ ]+ , testGroup "some" $+ let a = some (RT.char 'a') in+ [ testPM "some a, aa, ok" a "aa" (Just "aa")+ , testPM "some a, a, ok" a "a" (Just "a")+ , testPM "some a, <e>, fail" a "" Nothing+ ]+ , testGroup "manyMin" $+ let a = RT.manyMin (RT.char 'a')+ pr = RT.manyMin (pure ())+ in+ [ testPM "manyMin a, aa, ok" a "aa" (Just "aa")+ , testPM "manyMin a, a, ok" a "a" (Just "a")+ , testPM "manyMin a, <e>, ok" a "" (Just "")+ , testPM "manyMin (pure ()), <e>, ok" pr "" (Just [])+ , testPM "manyMin (pure ()), aaa, fail" pr "aaa" Nothing+ ]+ , testGroup "someMin" $+ let a = RT.someMin (RT.char 'a') in+ [ testPM "someMin a, aa, ok" a "aa" (Just "aa")+ , testPM "someMin a, a, ok" a "a" (Just "a")+ , testPM "someMin a, <e>, fail" a "" Nothing+ ]+ , testGroup "manyr" $+ let a = RT.manyr (RT.char 'a')+ pr = RT.manyr (pure ())+ in+ [ testPM "manyr a, <e>, ok" a "" (Just (RT.Finite ""))+ , testPM "manyr a, aaa, ok" a "aaa" (Just (RT.Finite "aaa"))+ , testPM "manyr (pure ()), <e>, ok" pr "" (Just (RT.Repeat ()))+ , testPM "manyr (pure ()), aaa, fail" pr "aaa" Nothing+ ]+ , testGroup "atLeast"+ [ testProperty "random" $ \m (NonNegative l) ->+ let t = T.replicate l "a" in+ RT.reParse (RT.atLeast m (RT.char 'a')) t ===+ if m <= l then Just (T.unpack t) else Nothing+ , testPM "bias" (RT.atLeast 2 RT.anyChar <* RT.manyText) "aaaa" (Just "aaaa")+ ]+ , testGroup "atMost"+ [ testProperty "random" $ \n (NonNegative l) ->+ let t = T.replicate l "a" in+ RT.reParse (RT.atMost n (RT.char 'a')) t ===+ if n >= l then Just (T.unpack t) else Nothing+ , testPM "bias" (RT.atMost 2 RT.anyChar <* RT.manyText) "aaaa" (Just "aa")+ ]+ , testGroup "betweenCount"+ [ testProperty "random" $ \mn (NonNegative l) ->+ let t = T.replicate l "a" in+ RT.reParse (RT.betweenCount mn (RT.char 'a')) t ===+ if inRange l mn then Just (T.unpack t) else Nothing+ , testPM "bias" (RT.betweenCount (2,3) RT.anyChar <* RT.manyText) "aaaa" (Just "aaa")+ ]+ , testGroup "atLeastMin"+ [ testProperty "random" $ \m (NonNegative l) ->+ let t = T.replicate l "a" in+ RT.reParse (RT.atLeastMin m (RT.char 'a')) t ===+ if m <= l then Just (T.unpack t) else Nothing+ , testPM "bias" (RT.atLeastMin 2 RT.anyChar <* RT.manyText) "aaaa" (Just "aa")+ ]+ , testGroup "atMostMin"+ [ testProperty "random" $ \n (NonNegative l) ->+ let t = T.replicate l "a" in+ RT.reParse (RT.atMostMin n (RT.char 'a')) t ===+ if n >= l then Just (T.unpack t) else Nothing+ , testPM "bias" (RT.atMostMin 2 RT.anyChar <* RT.manyText) "aaaa" (Just "")+ ]+ , testGroup "betweenCountMin"+ [ testProperty "random" $ \mn (NonNegative l) ->+ let t = T.replicate l "a" in+ RT.reParse (RT.betweenCountMin mn (RT.char 'a')) t ===+ if inRange l mn then Just (T.unpack t) else Nothing+ , testPM "bias" (RT.betweenCountMin (2,3) RT.anyChar <* RT.manyText) "aaaa" (Just "aa")+ ]+ , testGroup "sepBy" $+ let re = RT.char 'A' `RT.sepBy` RT.char 'x' in+ [ testGroup "A `sepBy` x"+ [ testPM "AxAx, fail" re "AxAx" Nothing+ , testPM "AxA, ok" re "AxA" (Just "AA")+ , testPM "Ax, fail" re "Ax" Nothing+ , testPM "A, ok" re "A" (Just "A")+ , testPM "<e>, ok" re "" (Just "")+ , testPM "x, fail" re "x" Nothing+ ]+ ]+ , testGroup "sepBy1" $+ let re = RT.char 'A' `RT.sepBy1` RT.char 'x' in+ [ testGroup "A `sepBy1` x"+ [ testPM "AxAx, fail" re "AxAx" Nothing+ , testPM "AxA, ok" re "AxA" (Just "AA")+ , testPM "Ax, fail" re "Ax" Nothing+ , testPM "A, ok" re "A" (Just "A")+ , testPM "<e>, fail" re "" Nothing+ , testPM "x, fail" re "x" Nothing+ ]+ ]+ , testGroup "endBy" $+ let re = RT.char 'A' `RT.endBy` RT.char 'x' in+ [ testGroup "A `endBy` x"+ [ testPM "AxAx, ok" re "AxAx" (Just "AA")+ , testPM "AxA, fail" re "AxA" Nothing+ , testPM "Ax, ok" re "Ax" (Just "A")+ , testPM "A, fail" re "A" Nothing+ , testPM "<e>, ok" re "" (Just "")+ , testPM "x, fail" re "x" Nothing+ ]+ ]+ , testGroup "endBy1" $+ let re = RT.char 'A' `RT.endBy1` RT.char 'x' in+ [ testGroup "A `endBy1` x"+ [ testPM "AxAx, ok" re "AxAx" (Just "AA")+ , testPM "AxA, fail" re "AxA" Nothing+ , testPM "Ax, ok" re "Ax" (Just "A")+ , testPM "A, fail" re "A" Nothing+ , testPM "<e>, fail" re "" Nothing+ , testPM "x, fail" re "x" Nothing+ ]+ ]+ , testGroup "sepEndBy" $+ let re = RT.char 'A' `RT.sepEndBy` RT.char 'x' in+ [ testGroup "A `sepEndBy` x"+ [ testPM "AxAx, ok" re "AxAx" (Just "AA")+ , testPM "AxA, ok" re "AxA" (Just "AA")+ , testPM "Ax, ok" re "Ax" (Just "A")+ , testPM "A, ok" re "A" (Just "A")+ , testPM "<e>, ok" re "" (Just "")+ , testPM "x, fail" re "x" Nothing+ ]+ ]+ , testGroup "sepEndBy1" $+ let re = RT.char 'A' `RT.sepEndBy1` RT.char 'x' in+ [ testGroup "A `sepEndBy1` x"+ [ testPM "AxAx, ok" re "AxAx" (Just "AA")+ , testPM "AxA, ok" re "AxA" (Just "AA")+ , testPM "Ax, ok" re "Ax" (Just "A")+ , testPM "A, ok" re "A" (Just "A")+ , testPM "<e>, fail" re "" Nothing+ , testPM "x, fail" re "x" Nothing+ ]+ ]+ , testGroup "chainl1" $+ let re = RT.chainl1 (One <$> RT.anyChar)+ (TwoA <$ RT.char 'F' <|> TwoB <$ RT.char 'T')+ in+ [ testPM "<e>, fail" re "" Nothing+ , testPM "aa, fail" re "aFFa" Nothing+ , testPM "aFFa, fail" re "aFFa" Nothing+ , testProperty "random ok" $ \(x,opxs) ->+ let t = T.pack $ x : (opxs >>= \(op,y) -> [if op then 'T' else 'F', y])+ e = foldl (\acc (op,y) -> (if op then TwoB else TwoA) acc (One y)) (One x) opxs+ in+ RT.reParse re t === Just e+ ]+ , testGroup "chainr1" $+ let re = RT.chainr1 (One <$> RT.anyChar)+ (TwoA <$ RT.char 'F' <|> TwoB <$ RT.char 'T')+ in+ [ testPM "<e>, fail" re "" Nothing+ , testPM "aa, fail" re "aFFa" Nothing+ , testPM "aFFa, fail" re "aFFa" Nothing+ , testProperty "random ok" $ \(xops,x) ->+ let t = T.pack $ (xops >>= \(y,op) -> [y, if op then 'T' else 'F']) ++ [x]+ e = foldr (\(y,op) acc -> (if op then TwoB else TwoA) (One y) acc) (One x) xops+ in+ RT.reParse re t === Just e+ ]+ , testGroup "many many"+ [ testPM "many (many a)" (many (many (RT.char 'a'))) "" (Just [])+ , testPM "many (many a), aaa" (many (many (RT.char 'a'))) "aaa" (Just ["aaa"])+ , testPM "many (manyr a)" (many (RT.manyr (RT.char 'a'))) "" (Just [])+ , testPM "many (manyr a), aaa" (many (RT.manyr (RT.char 'a'))) "aaa" (Just [RT.Finite "aaa"])+ , testPM "many (manyMin a)" (many (RT.manyMin (RT.char 'a'))) "" (Just [])+ , testPM "many (manyMin a), aaa" (many (RT.manyMin (RT.char 'a'))) "aaa" (Just ["a","a","a"])+ , testPM "manyr (many a)" (RT.manyr (many (RT.char 'a'))) "" (Just (RT.Repeat []))+ , testPM "manyr (many a), aaa" (RT.manyr (many (RT.char 'a'))) "aaa" (Just (RT.Finite ["aaa"]))+ , testPM "manyr (manyr a)" (RT.manyr (RT.manyr (RT.char 'a'))) "" (Just (RT.Repeat (RT.Finite "")))+ , testPM "manyr (manyr a), aaa" (RT.manyr (RT.manyr (RT.char 'a'))) "aaa" (Just (RT.Finite [RT.Finite "aaa"]))+ , testPM "manyr (manyMin a)" (RT.manyr (RT.manyMin (RT.char 'a'))) "" (Just (RT.Repeat []))+ , testPM "manyr (manyMin a), aaa" (RT.manyr (RT.manyMin (RT.char 'a'))) "aaa" (Just (RT.Finite ["a","a","a"]))+ , testPM "manyMin (many a)" (RT.manyMin (many (RT.char 'a'))) "" (Just [])+ , testPM "manyMin (many a), aaa" (RT.manyMin (many (RT.char 'a'))) "aaa" (Just ["aaa"])+ , testPM "manyMin (manyr a)" (RT.manyMin (RT.manyr (RT.char 'a'))) "" (Just [])+ , testPM "manyMin (manyr a), aaa" (RT.manyMin (RT.manyr (RT.char 'a'))) "aaa" (Just [RT.Finite "aaa"])+ , testPM "manyMin (manyMin a)" (RT.manyMin (RT.manyMin (RT.char 'a'))) "" (Just [])+ , testPM "manyMin (manyMin a), aaa" (RT.manyMin (RT.manyMin (RT.char 'a'))) "aaa" (Just ["a","a","a"])+ ]+ , testGroup "toMatch"+ [ testPM "many (a *> (b <|> c)) abacac"+ (RT.toMatch $ many (RT.char 'a' *> (RT.char 'b' <|> RT.char 'c')))+ "abacac"+ (Just "abacac")+ ]+ , testGroup "withMatch"+ [ testPM "many (a *> (b <|> c)) abacac"+ (RT.withMatch $ many (RT.char 'a' *> (RT.char 'b' <|> RT.char 'c')))+ "abacac"+ (Just ("abacac", "bcc"))+ ]+ ]+-- TODO: Would be good to have more tests for toMatch and withMatch++listCombinatorTests :: TestTree+listCombinatorTests = testGroup "List combinators"+ [ testGroup "toMatch"+ [ testLPM "many (a *> (b <|> c)) abacac"+ (RL.toMatch $ many (RL.single 'a' *> (RL.single 'b' <|> RL.single 'c')))+ "abacac"+ (Just "abacac")+ ]+ , testGroup "withMatch"+ [ testLPM "many (a *> (b <|> c)) abacac"+ (RL.withMatch $ many (RL.single 'a' *> (RL.single 'b' <|> RL.single 'c')))+ "abacac"+ (Just ("abacac", "bcc"))+ ]+ ]++-- | Test parse and match+testPM :: (Eq a, Show a) => String -> RT.REText a -> T.Text -> Maybe a -> TestTree+testPM name re t res = testGroup name+ [ testCase "parse" $ RT.parse (RT.compile re) t @?= res+ , testCase "test" $ RT.parse (RT.compile (void re)) t @?= void res+ ]++-- | Test parse and match+testLPM :: (Eq a, Show a) => String -> RL.RE c a -> [c] -> Maybe a -> TestTree+testLPM name re t res = testGroup name+ [ testCase "parse" $ RL.parse (RL.compile re) t @?= res+ , testCase "test" $ RL.parse (RL.compile (void re)) t @?= void res+ ]++zeroOneString :: Gen String+zeroOneString = listOf (elements "01")++zeroOneText :: Gen Text+zeroOneText = T.pack <$> zeroOneString++------------+-- Compile+------------++compileTests :: TestTree+compileTests = testGroup "Compile tests"+ [ testGroup "compileBounded"+ [ testCase "mixRE 15" $+ assertBool "isJust" $ isJust (R.compileBounded 15 mixRE)+ , testCase "mixRE 14" $+ assertBool "isNothing" $ isNothing (R.compileBounded 14 mixRE)+ ]+ ]+-- the exact size may change in the future, just test that there is _some_+-- threshold++mixRE :: R.RE c ()+mixRE =+ (() <$) .+ R.manyr .+ many .+ (\r -> liftA2 (\_ _ -> ()) r r) .+ (\r -> r <|> r) .+ fmap (const ()) $+ R.token (const (Just ()))++--------------------+-- Operations+--------------------++textOpTests :: TestTree+textOpTests = testGroup "Text operations"+ [ testGroup "find"+ [ testCase "abc abc ok" $ RT.find (RT.text "abc") "abc" @?= Just "abc"+ , testCase "abc abcd ok" $ RT.find (RT.text "abc") "abcd" @?= Just "abc"+ , testCase "bcd abcd ok" $ RT.find (RT.text "bcd") "abcd" @?= Just "bcd"+ , testCase "bcd abcde ok" $ RT.find (RT.text "bcd") "abcde" @?= Just "bcd"+ , testCase "abc abcabc ok" $ RT.find (RT.text "abc") "abcabc" @?= Just "abc"+ , testCase "aba ababababa ok" $ RT.find (RT.text "aba") "ababababa" @?= Just "aba"+ , testCase "abc ab fail" $ RT.find (RT.text "abc") "ab" @?= Nothing+ ]+ , testGroup "findAll"+ [ testCase "abc abc 1" $ RT.findAll (RT.text "abc") "abc" @?= ["abc"]+ , testCase "abc abcd 1" $ RT.findAll (RT.text "abc") "abcd" @?= ["abc"]+ , testCase "bcd abcd 1" $ RT.findAll (RT.text "bcd") "abcd" @?= ["bcd"]+ , testCase "bcd abcde 1" $ RT.findAll (RT.text "bcd") "abcde" @?= ["bcd"]+ , testCase "abc abcabc 2" $ RT.findAll (RT.text "abc") "abcabc" @?= ["abc","abc"]+ , testCase "aba ababababa 2" $ RT.findAll (RT.text "aba") "ababababa" @?= ["aba","aba"]+ , testCase "abc ab 0" $ RT.findAll (RT.text "abc") "ab" @?= []+ ]+ , testGroup "splitOn"+ [ testCase "abc abc" $ RT.splitOn (RT.text "abc") "abc" @?= ["",""]+ , testCase "abc abcd" $ RT.splitOn (RT.text "abc") "abcd" @?= ["","d"]+ , testCase "bcd abcd" $ RT.splitOn (RT.text "bcd") "abcd" @?= ["a",""]+ , testCase "bcd abcde" $ RT.splitOn (RT.text "bcd") "abcde" @?= ["a","e"]+ , testCase "abc abcabc" $ RT.splitOn (RT.text "abc") "abcabc" @?= ["","",""]+ , testCase "aba ababababa" $ RT.splitOn (RT.text "aba") "ababababa" @?= ["","b","ba"]+ , testCase "abc ab" $ RT.splitOn (RT.text "abc") "ab" @?= ["ab"]+ ]+ , testGroup "replace"+ [ testCase "abc xyz abc" $ RT.replace ("xyz" <$ RT.text "abc") "abc" @?= Just "xyz"+ , testCase "abc xyz abcd" $ RT.replace ("xyz" <$ RT.text "abc") "abcd" @?= Just "xyzd"+ , testCase "bcd xyz abcd" $ RT.replace ("xyz" <$ RT.text "bcd") "abcd" @?= Just "axyz"+ , testCase "bcd xyz abcde" $ RT.replace ("xyz" <$ RT.text "bcd") "abcde" @?= Just "axyze"+ , testCase "abc xyz abcabc" $ RT.replace ("xyz" <$ RT.text "abc") "abcabc" @?= Just "xyzabc"+ , testCase "aba xyz ababababa" $ RT.replace ("xyz" <$ RT.text "aba") "ababababa" @?= Just "xyzbababa"+ , testCase "abc xyz ab" $ RT.replace ("xyz" <$ RT.text "abc") "ab" @?= Nothing+ ]+ , testGroup "replaceAll"+ [ testCase "abc xyz abc" $ RT.replaceAll ("xyz" <$ RT.text "abc") "abc" @?= "xyz"+ , testCase "abc xyz abcd" $ RT.replaceAll ("xyz" <$ RT.text "abc") "abcd" @?= "xyzd"+ , testCase "bcd xyz abcd" $ RT.replaceAll ("xyz" <$ RT.text "bcd") "abcd" @?= "axyz"+ , testCase "bcd xyz abcde" $ RT.replaceAll ("xyz" <$ RT.text "bcd") "abcde" @?= "axyze"+ , testCase "abc xyz abcabc" $ RT.replaceAll ("xyz" <$ RT.text "abc") "abcabc" @?= "xyzxyz"+ , testCase "aba xyz ababababa" $ RT.replaceAll ("xyz" <$ RT.text "aba") "ababababa" @?= "xyzbxyzba"+ , testCase "abc xyz ab" $ RT.replaceAll ("xyz" <$ RT.text "abc") "ab" @?= "ab"+ ]+ ]++stringOpTests :: TestTree+stringOpTests = testGroup "String operations"+ [ testGroup "find"+ [ testCase "abc abc ok" $ RL.find (RL.list "abc") "abc" @?= Just "abc"+ , testCase "abc abcd ok" $ RL.find (RL.list "abc") "abcd" @?= Just "abc"+ , testCase "bcd abcd ok" $ RL.find (RL.list "bcd") "abcd" @?= Just "bcd"+ , testCase "bcd abcde ok" $ RL.find (RL.list "bcd") "abcde" @?= Just "bcd"+ , testCase "abc abcabc ok" $ RL.find (RL.list "abc") "abcabc" @?= Just "abc"+ , testCase "aba ababababa ok" $ RL.find (RL.list "aba") "ababababa" @?= Just "aba"+ , testCase "abc ab fail" $ RL.find (RL.list "abc") "ab" @?= Nothing+ ]+ , testGroup "findAll"+ [ testCase "abc abc 1" $ RL.findAll (RL.list "abc") "abc" @?= ["abc"]+ , testCase "abc abcd 1" $ RL.findAll (RL.list "abc") "abcd" @?= ["abc"]+ , testCase "bcd abcd 1" $ RL.findAll (RL.list "bcd") "abcd" @?= ["bcd"]+ , testCase "bcd abcde 1" $ RL.findAll (RL.list "bcd") "abcde" @?= ["bcd"]+ , testCase "abc abcabc 2" $ RL.findAll (RL.list "abc") "abcabc" @?= ["abc","abc"]+ , testCase "aba ababababa 2" $ RL.findAll (RL.list "aba") "ababababa" @?= ["aba","aba"]+ , testCase "abc ab 0" $ RL.findAll (RL.list "abc") "ab" @?= []+ ]+ , testGroup "splitOn"+ [ testCase "abc abc" $ RL.splitOn (RL.list "abc") "abc" @?= ["",""]+ , testCase "abc abcd" $ RL.splitOn (RL.list "abc") "abcd" @?= ["","d"]+ , testCase "bcd abcd" $ RL.splitOn (RL.list "bcd") "abcd" @?= ["a",""]+ , testCase "bcd abcde" $ RL.splitOn (RL.list "bcd") "abcde" @?= ["a","e"]+ , testCase "abc abcabc" $ RL.splitOn (RL.list "abc") "abcabc" @?= ["","",""]+ , testCase "aba ababababa" $ RL.splitOn (RL.list "aba") "ababababa" @?= ["","b","ba"]+ , testCase "abc ab" $ RL.splitOn (RL.list "abc") "ab" @?= ["ab"]+ ]+ , testGroup "replace"+ [ testCase "abc xyz abc" $ RL.replace ("xyz" <$ RL.list "abc") "abc" @?= Just "xyz"+ , testCase "abc xyz abcd" $ RL.replace ("xyz" <$ RL.list "abc") "abcd" @?= Just "xyzd"+ , testCase "bcd xyz abcd" $ RL.replace ("xyz" <$ RL.list "bcd") "abcd" @?= Just "axyz"+ , testCase "bcd xyz abcde" $ RL.replace ("xyz" <$ RL.list "bcd") "abcde" @?= Just "axyze"+ , testCase "abc xyz abcabc" $ RL.replace ("xyz" <$ RL.list "abc") "abcabc" @?= Just "xyzabc"+ , testCase "aba xyz ababababa" $ RL.replace ("xyz" <$ RL.list "aba") "ababababa" @?= Just "xyzbababa"+ , testCase "abc xyz ab" $ RL.replace ("xyz" <$ RL.list "abc") "ab" @?= Nothing+ ]+ , testGroup "replaceAll"+ [ testCase "abc xyz abc" $ RL.replaceAll ("xyz" <$ RL.list "abc") "abc" @?= "xyz"+ , testCase "abc xyz abcd" $ RL.replaceAll ("xyz" <$ RL.list "abc") "abcd" @?= "xyzd"+ , testCase "bcd xyz abcd" $ RL.replaceAll ("xyz" <$ RL.list "bcd") "abcd" @?= "axyz"+ , testCase "bcd xyz abcde" $ RL.replaceAll ("xyz" <$ RL.list "bcd") "abcde" @?= "axyze"+ , testCase "abc xyz abcabc" $ RL.replaceAll ("xyz" <$ RL.list "abc") "abcabc" @?= "xyzxyz"+ , testCase "aba xyz ababababa" $ RL.replaceAll ("xyz" <$ RL.list "aba") "ababababa" @?= "xyzbxyzba"+ , testCase "abc xyz ab" $ RL.replaceAll ("xyz" <$ RL.list "abc") "ab" @?= "ab"+ ]+ ]++---------+-- Many+---------++manyTests :: TestTree+manyTests = testGroup "Many" $ map testLaws+ [ eqLaws (Proxy :: Proxy (RT.Many A))+ , ordLaws (Proxy :: Proxy (RT.Many OrdA))+ , functorLaws (Proxy :: Proxy RT.Many)+ ]+-- Cannot use foldableLaws because it cannot handle infinite structures.++------------+-- CharSet+------------++charSetTests :: TestTree+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+ ]+ , testGroup "fromList"+ [ testProperty "valid" $ \s -> validCS (CS.fromList s)+ , testProperty "member" $ \s c -> elem c s === CS.member c (CS.fromList s)+ ]+ , testGroup "insert"+ [ testProperty "valid" $ \c cs -> validCS (CS.insert c cs)+ , testProperty "member" $ \c cs -> CS.member c (CS.insert c cs)+ ]+ , testGroup "insertRange"+ [ testProperty "valid" $ \g cs -> validCS (CS.insertRange g cs)+ , testProperty "member" $+ \g cs c ->+ (CS.member c cs || inRange c g) == CS.member c (CS.insertRange g cs)+ ]+ , testGroup "delete"+ [ testProperty "valid" $ \c cs -> validCS (CS.delete c cs)+ , testProperty "member" $ \c cs -> not (CS.member c (CS.delete c cs))+ ]+ , testGroup "deleteRange"+ [ testProperty "valid" $ \g cs -> validCS (CS.deleteRange g cs)+ , testProperty "member" $+ \g cs c ->+ (CS.member c cs && not (inRange c g))+ == CS.member c (CS.deleteRange g cs)+ ]+ , testGroup "map"+ [ testProperty "valid" $ \cs (Fn f) -> validCS (CS.map f cs)+ , testProperty "member c . map f = elem c . map f . elems" $+ \cs c (Fn f) -> CS.member c (CS.map f cs) === elem c (map f (CS.elems cs))+ ]+ , testGroup "not"+ [ testProperty "valid" $ \cs -> validCS (CS.not cs)+ , testProperty "member" $+ \cs c -> CS.member c cs === CS.notMember c (CS.not cs)+ , testProperty "not . not = id" $ \cs -> CS.not (CS.not cs) === cs+ ]+ , testGroup "union"+ [ testProperty "valid" $ \lcs rcs -> validCS (CS.union lcs rcs)+ , testProperty "member" $+ \lcs rcs c ->+ (CS.member c lcs || CS.member c rcs) === CS.member c (CS.union lcs rcs)+ ]+ , testGroup "difference"+ [ testProperty "valid" $ \lcs rcs -> validCS (CS.difference lcs rcs)+ , testProperty "member" $+ \lcs rcs c ->+ (CS.member c lcs && CS.notMember c rcs)+ === CS.member c (CS.difference lcs rcs)+ ]+ , testGroup "intersection"+ [ testProperty "valid" $ \lcs rcs -> validCS (CS.intersection lcs rcs)+ , testProperty "member" $+ \lcs rcs c ->+ (CS.member c lcs && CS.member c rcs)+ === CS.member c (CS.intersection lcs rcs)+ ]+ , testProperty "fromString" $ \s -> fromString s === CS.fromList s+ , testProperty "<>" $ \lcs rcs -> lcs <> rcs === CS.union lcs rcs+ , testProperty "singleton" $ \c -> CS.singleton c === CS.fromList [c]+ , testProperty "fromRange" $ \cl cr c ->+ CS.member c (CS.fromRange (cl,cr)) === inRange c (cl,cr)+ , testProperty "ranges" $ \cs c ->+ CS.member c cs === any (inRange c) (CS.ranges cs)+ ]++validCS :: CS.CharSet -> Property+validCS cs = counterexample (show cs) $ CS.valid cs++-----------------+-- Common utils+-----------------++data T = TA | TB | TC deriving Show++instance Arbitrary T where+ arbitrary = elements [TA,TB,TC]++data Chain a+ = One a+ | TwoA (Chain a) (Chain a)+ | TwoB (Chain a) (Chain a)+ deriving (Eq, Show)++inRange :: Ord a => a -> (a, a) -> Bool+inRange x (l,h) = l <= x && x <= h++testLaws :: Laws -> TestTree+testLaws (Laws class_ tests) =+ testGroup class_ (map (uncurry testProperty) tests)++instance Arbitrary a => Arbitrary (RT.Many a) where+ arbitrary = frequency [ (1, RT.Repeat <$> arbitrary)+ , (3, RT.Finite <$> arbitrary)+ ]++instance Arbitrary CS.CharSet where+ arbitrary = CS.fromList <$> arbitrary+ shrink = map CS.fromList . shrink . CS.elems++instance Arbitrary Text where+ arbitrary = T.pack <$> arbitrary+ -- Arbitrary Char generates valid Unicode (perhaps it shouldn't) so this+ -- is fine.++ shrink = map T.pack . shrink . T.unpack++-- Available in Data.List in base >= 4.19+unsnoc :: [a] -> Maybe ([a], a)+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing