diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +### 0.1.0.0 -- 2024-03-04 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,105 @@ +# parser-regex + +[![Hackage](https://img.shields.io/hackage/v/parser-regex?logo=haskell&color=blue)](https://hackage.haskell.org/package/parser-regex) +[![Haskell-CI](https://github.com/meooow25/parser-regex/actions/workflows/haskell-ci.yml/badge.svg)](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. diff --git a/parser-regex.cabal b/parser-regex.cabal new file mode 100644 --- /dev/null +++ b/parser-regex.cabal @@ -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 diff --git a/src/Data/CharSet.hs b/src/Data/CharSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/CharSet.hs @@ -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 diff --git a/src/Regex/Base.hs b/src/Regex/Base.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Base.hs @@ -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. +-- diff --git a/src/Regex/Internal/CharSet.hs b/src/Regex/Internal/CharSet.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/CharSet.hs @@ -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))) diff --git a/src/Regex/Internal/CharSets.hs b/src/Regex/Internal/CharSets.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/CharSets.hs @@ -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') diff --git a/src/Regex/Internal/Debug.hs b/src/Regex/Internal/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/Debug.hs @@ -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 diff --git a/src/Regex/Internal/Generated/CaseFold.hs b/src/Regex/Internal/Generated/CaseFold.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/Generated/CaseFold.hs @@ -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 #-} diff --git a/src/Regex/Internal/List.hs b/src/Regex/Internal/List.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/List.hs @@ -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 diff --git a/src/Regex/Internal/Num.hs b/src/Regex/Internal/Num.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/Num.hs @@ -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 diff --git a/src/Regex/Internal/Parser.hs b/src/Regex/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/Parser.hs @@ -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. diff --git a/src/Regex/Internal/Regex.hs b/src/Regex/Internal/Regex.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/Regex.hs @@ -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) diff --git a/src/Regex/Internal/Text.hs b/src/Regex/Internal/Text.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/Text.hs @@ -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. diff --git a/src/Regex/Internal/Unique.hs b/src/Regex/Internal/Unique.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Internal/Unique.hs @@ -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) diff --git a/src/Regex/List.hs b/src/Regex/List.hs new file mode 100644 --- /dev/null +++ b/src/Regex/List.hs @@ -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. +-- diff --git a/src/Regex/Text.hs b/src/Regex/Text.hs new file mode 100644 --- /dev/null +++ b/src/Regex/Text.hs @@ -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. +-- diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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, , 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, , 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, , 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, , 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, , 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, , 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 ", 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 ", 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 ", 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 ", 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 (), , 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, , 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, , 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 ", 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, , ok" a "" (Just "") + , testPM "many (pure ()), , 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, , 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, , ok" a "" (Just "") + , testPM "manyMin (pure ()), , 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, , fail" a "" Nothing + ] + , testGroup "manyr" $ + let a = RT.manyr (RT.char 'a') + pr = RT.manyr (pure ()) + in + [ testPM "manyr a, , ok" a "" (Just (RT.Finite "")) + , testPM "manyr a, aaa, ok" a "aaa" (Just (RT.Finite "aaa")) + , testPM "manyr (pure ()), , 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 ", 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 ", 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 ", 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 ", 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 ", 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 ", 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 ", 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 ", 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