packages feed

regex-tdfa 1.2.3.3 → 1.3.2.5

raw patch · 29 files changed

Files

CHANGELOG.md view
@@ -1,62 +1,211 @@-# 1.2.3.3+### 1.3.2.5 +_2025-09-29 Andreas Abel_++- Bump `cabal-version` to 2.0 to support field `autogen-modules` ([#70](https://github.com/haskell-hvr/regex-tdfa/pull/70))+- SPECIALIZE pragmas for faster `Text` matching ([#72](https://github.com/haskell-hvr/regex-tdfa/pull/72))+- Address deprecation warning for `sizeofMutualByteArray#` ([#71](https://github.com/haskell-hvr/regex-tdfa/issues/71))+- Tested with GHC 8.0 - 9.12.2++### 1.3.2.4++_2025-05-09 Andreas Abel_++- Fix definition of `[[:graph:]]` character class ([#66](https://github.com/haskell-hvr/regex-tdfa/issues/66))+- Tested with GHC 8.0 - 9.12.2++### 1.3.2.3++_2025-03-02 Andreas Abel_++- Drop support for GHC 7+- Allow `containers < 1`+- Tested with GHC 8.0 - 9.12.1++### 1.3.2.2++_2023-08-02, Andreas Abel_++- Fix return type in `memcpy` FFI signature ([#52](https://github.com/haskell-hvr/regex-tdfa/pull/52))+- Refactor `regexec` to avoid partial functions `tail` and `(!0)`+- Tested with GHC 7.4 - 9.8.1-alpha1++### 1.3.2.1++_2023-05-19, Andreas Abel_++- Fix haddock rendering of code examples in top-level documentation+  ([#50](https://github.com/haskell-hvr/regex-tdfa/issues/50))+- Tested with GHC 7.4 - 9.6++## 1.3.2++_2022-07-18, Andreas Abel_++- Export `decodePatternSet` and `decodeCharacterClass` from `Text.Regex.TDFA.Pattern`+  ([#16](https://github.com/haskell-hvr/regex-tdfa/issues/16))+- Extend and correct docs for `Pattern` module+- Tested with GHC 7.4 - 9.4++### 1.3.1.5++_2022-07-18, Andreas Abel_++- Allow dash (`-`) as start of a range, e.g. `[--z]`+  ([#1](https://github.com/haskell-hvr/regex-tdfa/issues/1),+  [#45](https://github.com/haskell-hvr/regex-tdfa/pull/45))+- Tested with GHC 7.4 - 9.4++### 1.3.1.4++_2022-07-17, Andreas Abel_++- Fix parsing of dashes in bracket expressions, e.g. `[-a-z]` ([#1](https://github.com/haskell-hvr/regex-tdfa/issues/1))+- Fix a deprecation warning except for on GHC 8.2 ([#21](https://github.com/haskell-hvr/regex-tdfa/issues/21))+- Documentation: link `defaultComptOpt` to its definition  ([#13](https://github.com/haskell-hvr/regex-tdfa/issues/13))+- Verify documentation examples with new `doc-test` testsuite+- Tested with GHC 7.4 - 9.4++### 1.3.1.3++_2022-07-14, Andreas Abel_++- Fix an `undefined` in `Show PatternSet` ([#37](https://github.com/haskell-hvr/regex-tdfa/issues/37))+- Document POSIX character classes (e.g. `[[:digit:]]`) in README+- Tested with GHC 7.4 - 9.4++### 1.3.1.2 Revision 1++_2022-05-25, Andreas Abel_++- Allow `base >= 4.17` (GHC 9.4)++### 1.3.1.2++_2022-02-19, Andreas Abel_+- No longer rely on the `MonadFail` instance for `ST`+  (future `base` library change, see [#29](https://github.com/haskell-hvr/regex-tdfa/pull/29)).+- Silence warning `incomplete-uni-patterns` (GHC >= 9.2).+- Import from `Data.List` explicitly or qualified (warning `compat-unqualified-imports`).+- Import from `Control.Monad` to allow `mtl-2.3` in its `rc3` incarnation.++### 1.3.1.1 Revision 3++_2022-01-31, Andreas Abel_+- Speculatively allow unreleased `mtl-2.3` (works with release candidate `mtl-2.3-rc4`).++### 1.3.1.1 Revision 2++_2021-12-26, Andreas Abel_+- Allow `text-2.0`.++### 1.3.1.1 Revision 1++_2021-08-12, Andreas Abel_+- Compatibility with `base-4.16` (GHC 9.2).++### 1.3.1.1++_2021-06-03, Andreas Abel_+- Removed extension `NoMonoPatBinds` from `.cabal`-file for GHC 9.2 compatibility.+- Removed some outdated documentation.++### 1.3.1.0 Revision 2++_2021-02-20, Andreas Abel_+- Compatibility with `base-4.15` (GHC 9.0) and `bytestring-0.11`.++### 1.3.1.0 Revision 1++_2020-03-26, phadej_+- Compatibility with `base-4.14` (GHC 8.10).++## 1.3.1.0++_2019-11-26, hvr_+- Merge <http://hackage.haskell.org/package/regex-tdfa-text> into `regex-tdfa`; see <https://github.com/haskell-hvr/regex-tdfa/issues/4>.+- Don't inject `ghc-options: -O2` by default anymore (see #7 for rationale) and introduce `force-O2` cabal flag to control the injection of `ghc-options: -O2`.+  Note that you can conveniently control optimization levels on a per-package granularity via `cabal.project` files; see [cabal's user-guide](https://cabal.readthedocs.io/en/latest/nix-local-build.html#configuring-builds-with-cabal-project) for more details.++## 1.3.0 Revision 1++_2019-11-26, hvr_+- Tighten bounds on `base`, `mtl`, `parsec` and fail.++# 1.3.0++_2019-09-29, Artyom_+- Same as 1.2.3.3 release, but in accordance to PVP;+  see <https://github.com/ChrisKuklewicz/regex-tdfa/issues/29>.+- Compatibility with GHC 8.8 and regex-base-0.9.4 (h/t @asr).+- Turned `regex-tdfa-unittest` into a `regex-tdfa` testsuite.++### 1.2.3.3 (deprecated, not following PVP)+ * Compatibility with GHC 8.8 and regex-base-0.9.4 (h/t @asr). * Turned `regex-tdfa-unittest` into a `regex-tdfa` testsuite. -# 1.2.3.2+### 1.2.3.2 +_2019-05-09, Artyom_ * Significantly improved documentation (h/t William Yao). -# 1.2.3.1+### 1.2.3.1 +_2018-06-22, Artyom_ * Compatibility with `containers-0.6`. -# 1.2.3+## 1.2.3 +_2018-03-10, Artyom_ * Added `Semigroup` instances for some types (h/t Herbert Valerio Riedel). -# 1.2.2+## 1.2.2 +_2016-04-28, Artyom_ * New maintainer. * Now we don't reexport the problematic `Show` instance for functions. -# 1.2.1+## 1.2.1 +_2015-08-29, Chris Kuklewicz_ * Updated dependency versions.  # 1.2.0 -"Almost ghc-7.8" with the array 0.4 changes for `Data.Array.Unsafe`+_2014-02-02, Chris Kuklewicz_+* "Almost ghc-7.8" with the array 0.4 changes for `Data.Array.Unsafe` -# 1.1.8 -Make ghc-7.0.2 on platorm 2011.2.0.0.0 happy+## 1.1.8 -# 1.1.7+Make ghc-7.0.2 on platform 2011.2.0.0.0 happy +## 1.1.7+ fix url below -# 1.1.6+## 1.1.6  Fix bug preventing `[]] [-] [^]] [^-]` (thanks to Maxime Henrion) -# 1.1.5+## 1.1.5  try `needUniqTags` in `POr` in CorePattern.hs, try `toAdvice b` for `PStar child` -# 1.1.4+## 1.1.4  fixed -# 1.1.3+## 1.1.3  BROKEN after 100 characters the `compressOrbit` dies! -# 1.1.2+## 1.1.2  worked -# 1.1.1+## 1.1.1  add gnu escapes @@ -64,19 +213,19 @@  NewDFA code working -# 1.0.7+## 1.0.7  make NewDFA directory and String_NC -# 1.0.6+## 1.0.6  try NewDFATest_SBS with `uncons` -# 1.0.5+## 1.0.5  use `uncons` on SBS -# 1.0.4+## 1.0.4  try repaired NewDFATest_SBS @@ -93,11 +242,11 @@ * np3:  `!off` the multi? No * np2:  comment out all Testing code? No -# 1.0.3+## 1.0.3  try to alter `matchTest` to not have the `Bool` args? No -# 1.0.2+## 1.0.2  arg, the prof is fast and the normal slow! @@ -105,70 +254,70 @@  add NewDFATest.hs -# 0.99.20+## 0.99.20  go to many vs single? -# 0.99.19+## 0.99.19  try for pre-comparison of orbit-logs! -# 0.99.18+## 0.99.18  try alternate lazy/strict strategy in NewDFA. Fix offset laziness. -# 0.99.17+## 0.99.17  radical removal of flag array and adding of `SetVal` to handle groups -# 0.99.16+## 0.99.16  performance? up to v15 -# 0.99.15+## 0.99.15  get string with NewDFA testing, unit tests and 1000 random regex pass -# 0.99.14+## 0.99.14  start changing to the new real DFA -# 0.99.13+## 0.99.13  more cleanup -# 0.99.12+## 0.99.12  try to debug 0.99.11: fixed `updateWinner` -# 0.99.11+## 0.99.11  improve above fix and make stuff work better – HAS BUG, along with old TDFA! -# 0.99.10+## 0.99.10  fixed `((.?)*)*` patterns by changing `PStar nullView` when `mayFirstBeNull` -# 0.99.9+## 0.99.9  testing changing `bestTrans`/`chooseWith`/`choose` to include `enterOrbit`/`newFlags`/`(_,True)` info -# 0.99.8+## 0.99.8  testing changing `Maximize` to `Minimize` for `Tag`s, decide `(a*)*` is canonical problem -# 0.99.7+## 0.99.7  Use `(PGroup Nothing)` in `Pattern` to decompose `PBound` -# 0.99.6+## 0.99.6  change to nested `nonEmpty` calls for `PBound` -# 0.99.5+## 0.99.5  remove `PNonEmpty` constructor -# 0.99.4+## 0.99.4  tests `pnonempty' = \ p -> POr [ PEmpty, p ]` instead of `PNonEmpty`
LICENSE view
@@ -1,4 +1,4 @@-This modile is under this "3 clause" BSD license:+This module is under this "3 clause" BSD license:  Copyright (c) 2007-2009, Christopher Kuklewicz All rights reserved.
+ README.md view
@@ -0,0 +1,221 @@+[![Hackage version](https://img.shields.io/hackage/v/regex-tdfa.svg?label=Hackage&color=informational)](http://hackage.haskell.org/package/regex-tdfa)+[![Stackage Nightly](http://stackage.org/package/regex-tdfa/badge/nightly)](http://stackage.org/nightly/package/regex-tdfa)+[![Stackage LTS](http://stackage.org/package/regex-tdfa/badge/lts)](http://stackage.org/lts/package/regex-tdfa)+[![Haskell-CI](https://github.com/haskell-hvr/regex-tdfa/actions/workflows/haskell-ci.yml/badge.svg?branch=master&event=push)](https://github.com/haskell-hvr/regex-tdfa/actions/workflows/haskell-ci.yml)+[![License](https://img.shields.io/badge/License-BSD_3--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause)+# regex-tdfa++This is [`regex-tdfa`](http://hackage.haskell.org/package/regex-tdfa) which is a pure Haskell regular expression library (for POSIX extended regular expressions) originally written by Christopher Kuklewicz.++The name "tdfa" stands for Tagged-DFA.++## Getting started++### Importing and using++[Declare a dependency](https://www.haskell.org/cabal/users-guide/developing-packages.html#pkg-field-build-depends) on the `regex-tdfa` library in your `.cabal` file:++```+build-depends: regex-tdfa ^>= 1.3.2+```++In Haskell modules where you need to use regexes `import` the respective `regex-tdfa` module:++```haskell+import Text.Regex.TDFA+```++### Basics++```haskell+λ> emailRegex = "[a-zA-Z0-9+._-]+@[a-zA-Z-]+\\.[a-z]+"+λ> "my email is email@email.com" =~ emailRegex :: Bool+>>> True++-- non-monadic+<to-match-against> =~ <regex>++-- monadic, uses 'fail' on lack of match+<to-match-against> =~~ <regex>+```++`(=~)` and `(=~~)` are polymorphic in their return type. This is so that+regex-tdfa can pick the most efficient way to give you your result based on+what you need. For instance, if all you want is to check whether the regex+matched or not, there's no need to allocate a result string. If you only want+the first match, rather than all the matches, then the matching engine can stop+after finding a single hit.++This does mean, though, that you may sometimes have to explicitly specify the+type you want, especially if you're trying things out at the REPL.++### Common use cases++#### Get the first match++```haskell+-- returns empty string if no match+a =~ b :: String  -- or ByteString, or Text...++λ> "alexis-de-tocqueville" =~ "[a-z]+" :: String+>>> "alexis"++λ> "alexis-de-tocqueville" =~ "[[:digit:]]+" :: String+>>> ""+```++#### Check if it matched at all++```haskell+a =~ b :: Bool++λ> "alexis-de-tocqueville" =~ "[a-z]+" :: Bool+>>> True+```++#### Get first match + text before/after++```haskell+-- if no match, will just return whole+-- string in the first element of the tuple+a =~ b :: (String, String, String)++λ> "alexis-de-tocqueville" =~ "de" :: (String, String, String)+>>> ("alexis-", "de", "-tocqueville")++λ> "alexis-de-tocqueville" =~ "kant" :: (String, String, String)+>>> ("alexis-de-tocqueville", "", "")+```++#### Get first match + submatches++```haskell+-- same as above, but also returns a list of /just/ submatches+-- submatch list is empty if regex doesn't match at all+a =~ b :: (String, String, String, [String])++λ> "div[attr=1234]" =~ "div\\[([a-z]+)=([^]]+)\\]"+     :: (String, String, String, [String])+>>> ("", "div[attr=1234]", "", ["attr","1234"])+```++#### Get all non-overlapping matches++```haskell+-- can also return Data.Array instead of List+getAllTextMatches (a =~ b) :: [String]++λ> getAllTextMatches ("john anne yifan" =~ "[a-z]+") :: [String]+>>> ["john","anne","yifan"]++λ> getAllTextMatches ("0a0b0" =~ "0[[:lower:]]0") :: [String]+>>> ["0a0"]+```+Note that `"0b0"` is not included in the result since it overlaps with `"0a0"`.++#### Special characters++`regex-tdfa` only supports a small set of special characters and is much less+featureful than some other regex engines you might be used to, such as PCRE.++* ``\` `` &mdash; Match start of entire text (similar to `^` in other regex engines)+* `\'` &mdash; Match end of entire text (similar to `$` in other regex engines)+* `\<` &mdash; Match beginning of word+* `\>` &mdash; Match end of word+* `\b` &mdash; Match beginning or end of word+* `\B` &mdash; Match neither beginning nor end of word++While shorthands like `\d` (for digit) are not recognized, one can use the respective+POSIX character class inside `[...]`.  E.g., `[[:digit:][:lower:]_]` is short for+`[0-9a-z_]`.  The supported character classes are listed on+[Wikipedia](https://en.wikipedia.org/w/index.php?title=Regular_expression&oldid=1095256273#Character_classes)+and defined in module+[`TNFA`](https://github.com/haskell-hvr/regex-tdfa/blob/95d47cb982d2cf636b2cb6260a866f9907341c45/lib/Text/Regex/TDFA/TNFA.hs#L804-L816).++Please also consult a variant of this documentation which is part of the+[Text.Regex.TDFA haddock](http://hackage.haskell.org/package/regex-tdfa/docs/Text-Regex-TDFA.html),+and the original documentation at the [Haskell wiki](https://wiki.haskell.org/Regular_expressions#regex-tdfa).++### Less common stuff++#### Get match indices++```haskell+-- can also return Data.Array instead of List+getAllMatches (a =~ b) :: [(Int, Int)]  -- (index, length)++λ> getAllMatches ("john anne yifan" =~ "[a-z]+") :: [(Int, Int)]+>>> [(0,4), (5,4), (10,5)]+``````++#### Get submatch indices++```haskell+-- match of __entire__ regex is first element, not first capture+-- can also return Data.Array instead of List+getAllSubmatches (a =~ b) :: [(Int, Int)]  -- (index, length)++λ> getAllSubmatches ("div[attr=1234]" =~ "div\\[([a-z]+)=([^]]+)\\]")+     :: [(Int, Int)]+>>> [(0,14), (4,4), (9,4)]+```++### Replacement++`regex-tdfa` does not provide find-and-replace.++## Avoiding backslashes++If you find yourself writing a lot of regexes, take a look at+[raw-strings-qq](http://hackage.haskell.org/package/raw-strings-qq). It'll+let you write regexes without needing to escape all your backslashes.++```haskell+{-# LANGUAGE QuasiQuotes #-}++import Text.RawString.QQ+import Text.Regex.TDFA++λ> "2 * (3 + 1) / 4" =~ [r|\([^)]+\)|] :: String+>>> "(3 + 1)"+```++## Known bugs and infelicities++* Regexes with large character classes combined with `{m,n}` are very slow and memory-hungry ([#3][]).++  > An example of such a regex is `^[\x0020-\xD7FF]{1,255}$`.++* POSIX submatch semantics are broken in some rare cases ([#2][]).++[#2]: https://github.com/haskell-hvr/regex-tdfa/issues/2+[#3]: https://github.com/haskell-hvr/regex-tdfa/issues/3++## About this package++This was inspired by the algorithm (and Master's thesis) behind the regular expression library known as [TRE or libtre](https://github.com/laurikari/tre/).  This was created by Ville Laurikari and tackled the difficult issue of efficient sub-match capture for POSIX regular expressions.++By building on this thesis and adding a few more optimizations, regex-tdfa matching input text of length N should have O(N) runtime, and should have a maximum memory bounded by the pattern size that does not scale with N. It should do this while returning well defined (and correct) values for the parenthesized sub-matches.++Regardless of performance, nearly every single OS and Libra for POSIX regular expressions has bugs in sub-matches.  This was detailed on the [Regex POSIX Haskell wiki page](https://wiki.haskell.org/Regex_Posix), and can be demonstrated with the [regex-posix-unittest](http://hackage.haskell.org/package/regex-posix-unittest) suite of checks.  Test [regex-tdfa-unittest](http://hackage.haskell.org/package/regex-tdfa-unittest) should show regex-tdfa passing these same checks.  I owe my understanding of the correct behvior and many of these unit tests to Glenn Fowler at AT&T ("An Interpretation of the POSIX regex Standard").++### Maintenance history++The original Darcs repository was at [code.haskell.org](http://code.haskell.org/regex-tdfa/).+For a while a fork was maintained by Roman Cheplyaka as+[regex-tdfa-rc](http://hackage.haskell.org/package/regex-tdfa-rc).++Then the repository moved to <https://github.com/ChrisKuklewicz/regex-tdfa>,+which was primarily maintained by [Artyom (neongreen)](https://github.com/neongreen).++Finally, maintainership was passed on again and the repository moved to its current location+at <https://github.com/haskell-hvr/regex-tdfa>.++## Other related packages++Searching for "tdfa" on [hackage](http://hackage.haskell.org/packages/search?terms=tdfa)+finds some related packages (unmaintained as of 2022-07-14).++## Document notes++This README was originally written 2016-04-30.
− Setup.hs 
@@ -1,6 +0,0 @@-#!/usr/bin/env runhaskell---- I usually compile this with "ghc --make -o setup Setup.hs"--import Distribution.Simple(defaultMain)-main = defaultMain
lib/Data/IntMap/CharMap2.hs view
@@ -9,7 +9,7 @@ import Data.Char as C(ord) import Data.List as L (map) import qualified Data.IntMap as M-#if MIN_VERSION_containers(0,6,0)+#if MIN_VERSION_containers(0,5,11) import qualified Data.IntMap.Internal.Debug as MD #else import qualified Data.IntMap as MD
lib/Data/IntMap/EnumMap2.hs view
@@ -2,9 +2,9 @@  module Data.IntMap.EnumMap2 where -import Data.Foldable(Foldable(..))+import Data.Foldable as F (Foldable(foldMap)) import qualified Data.IntMap as M-#if MIN_VERSION_containers(0,6,0)+#if MIN_VERSION_containers(0,5,11) import qualified Data.IntMap.Internal.Debug as MD #else import qualified Data.IntMap as MD@@ -27,8 +27,8 @@ instance Ord k => Functor (EnumMap k) where   fmap f (EnumMap m) = EnumMap (fmap f m) -instance Ord k => Foldable (EnumMap k) where-  foldMap f (EnumMap m) = foldMap f m+instance Ord k => F.Foldable (EnumMap k) where+  foldMap f (EnumMap m) = F.foldMap f m  (!) :: (Enum key) => EnumMap key a -> key -> a (!) (EnumMap m) k = (M.!) m (fromEnum k)@@ -50,7 +50,7 @@  {-# INLINE lookup #-} lookup :: (Enum key) => key -> EnumMap key a -> Maybe a-lookup k (EnumMap m) = maybe (fail "EnumMap.lookup failed") return $ M.lookup (fromEnum k) m+lookup k (EnumMap m) = M.lookup (fromEnum k) m  findWithDefault :: (Enum key) => a -> key -> EnumMap key a -> a findWithDefault a k (EnumMap m) = M.findWithDefault a (fromEnum k) m
lib/Text/Regex/TDFA.hs view
@@ -1,4 +1,9 @@ {-|+Module: Text.Regex.TDFA+Copyright: (c) Chris Kuklewicz 2007-2009+SPDX-License-Identifier: BSD-3-Clause+Maintainer: Andreas Abel+Stability: stable  The "Text.Regex.TDFA" module provides a backend for regular expressions. It provides instances for the classes defined and@@ -7,33 +12,39 @@ qualified imports (with renaming for convenience).  This regex-tdfa package implements, correctly, POSIX extended regular-expressions.  It is highly unlikely that the regex-posix package on+expressions.  It is highly unlikely that the @regex-posix@ package on your operating system is correct, see <http://www.haskell.org/haskellwiki/Regex_Posix> for examples of your OS's bugs.  = Importing and using -Add to your package.yaml/cabal file:--> dependencies:->   - regex-tdfa+Declare a dependency on the @regex-tdfa@ library in your @.cabal@ file: -In modules where you need to use regexes:+> build-depends: regex-tdfa ^>= 1.3.2 -> import Text.Regex.TDFA+In Haskell modules where you want to use regexes simply @import@ /this/ module: -Note that regex-tdfa does not provide support for @Text@ by default.-If you need this functionality, add <https://hackage.haskell.org/package/regex-tdfa-text regex-tdfa-text>-as a dependency and @import Text.Regex.TDFA.Text ()@.+@+import "Text.Regex.TDFA"+@  = Basics -@-λ> let emailRegex = "[a-zA-Z0-9+.\_-]+\@[a-zA-Z-]+\\\\.[a-z]+"-λ> "my email is email@email.com" '=~' emailRegex :: Bool->>> True+>>> let emailRegex = "[a-zA-Z0-9+._-]+\\@[-a-zA-Z]+\\.[a-z]+"+>>> "my email is first-name.lastname_1974@e-mail.com" =~ emailRegex :: Bool+True +>>> "invalid@mail@com" =~ emailRegex :: Bool+False++>>> "invalid@mail.COM" =~ emailRegex :: Bool+False++>>> "#@invalid.com" =~ emailRegex :: Bool+False++@ /-- non-monadic/ λ> \<to-match-against\> '=~' \<regex\> @@ -58,36 +69,36 @@ @ /-- returns empty string if no match/ a '=~' b :: String  /-- or ByteString, or Text.../+@ -λ> "alexis-de-tocqueville" '=~' "[a-z]+" :: String->>> "alexis"+>>> "alexis-de-tocqueville" =~ "[a-z]+" :: String+"alexis" -λ> "alexis-de-tocqueville" '=~' "[0-9]+" :: String->>> ""-@+>>> "alexis-de-tocqueville" =~ "[0-9]+" :: String+""  == Check if it matched at all  @ a '=~' b :: Bool--λ> "alexis-de-tocqueville" '=~' "[a-z]+" :: Bool->>> True @ +>>> "alexis-de-tocqueville" =~ "[a-z]+" :: Bool+True+ == Get first match + text before/after  @ /-- if no match, will just return whole/ /-- string in the first element of the tuple/ a =~ b :: (String, String, String)+@ -λ> "alexis-de-tocqueville" '=~' "de" :: (String, String, String)->>> ("alexis-", "de", "-tocqueville")+>>> "alexis-de-tocqueville" =~ "de" :: (String, String, String)+("alexis-","de","-tocqueville") -λ> "alexis-de-tocqueville" '=~' "kant" :: (String, String, String)->>> ("alexis-de-tocqueville", "", "")-@+>>> "alexis-de-tocqueville" =~ "kant" :: (String, String, String)+("alexis-de-tocqueville","","")  == Get first match + submatches @@ -95,31 +106,31 @@ /-- same as above, but also returns a list of just submatches./ /-- submatch list is empty if regex doesn't match at all/ a '=~' b :: (String, String, String, [String])--λ> "div[attr=1234]" '=~' "div\\\\[([a-z]+)=([^]]+)\\\\]" :: (String, String, String, [String])->>> ("", "div[attr=1234]", "", ["attr","1234"]) @ +>>> "div[attr=1234]" =~ "div\\[([a-z]+)=([^]]+)\\]" :: (String, String, String, [String])+("","div[attr=1234]","",["attr","1234"])+ == Get /all/ matches  @ /-- can also return Data.Array instead of List/ 'getAllTextMatches' (a '=~' b) :: [String]--λ> 'getAllTextMatches' ("john anne yifan" '=~' "[a-z]+") :: [String]->>> ["john","anne","yifan"] @ +>>> getAllTextMatches ("john anne yifan" =~ "[a-z]+") :: [String]+["john","anne","yifan"]++>>> getAllTextMatches ("* - . a + z" =~ "[--z]+") :: [String]+["-",".","a","z"]+ = Feature support  This package does provide captured parenthesized subexpressions.  Depending on the text being searched this package supports Unicode.-The @[Char]@ and @(Seq Char)@ text types support Unicode.  The @ByteString@-and @ByteString.Lazy@ text types only support ASCII.  It is possible to-support utf8 encoded @ByteString.Lazy@ by using regex-tdfa and-<http://hackage.haskell.org/package/regex-tdfa-utf8 regex-tdfa-utf8>-packages together (required the utf8-string package).+The @[Char]@, @Text@, @Text.Lazy@, and @(Seq Char)@ text types support Unicode.  The @ByteString@+and @ByteString.Lazy@ text types only support ASCII.  As of version 1.1.1 the following GNU extensions are recognized, all anchors:@@ -144,6 +155,10 @@ ASCII only, valid classes are alnum, digit, punct, alpha, graph, space, blank, lower, upper, cntrl, print, xdigit, word. +>>> getAllTextMatches ("john anne yifan" =~ "[[:lower:]]+") :: [String]+["john","anne","yifan"]++ This package does not provide "basic" regular expressions.  This package does not provide back references inside regular expressions. @@ -166,7 +181,7 @@ import Text.Regex.TDFA  λ> "2 * (3 + 1) / 4" '=~' [r|\\([^)]+\\)|] :: String->>> "(3 + 1)"+"(3 + 1)" @  -}@@ -182,6 +197,8 @@ import Text.Regex.TDFA.String() import Text.Regex.TDFA.ByteString() import Text.Regex.TDFA.ByteString.Lazy()+import Text.Regex.TDFA.Text()+import Text.Regex.TDFA.Text.Lazy() import Text.Regex.TDFA.Sequence() import Text.Regex.TDFA.Common(Regex,CompOption(..),ExecOption(..)) --import Text.Regex.TDFA.Wrap(Regex,CompOption(..),ExecOption(..),(=~),(=~~))
lib/Text/Regex/TDFA/ByteString.hs view
@@ -63,18 +63,16 @@     Left err -> Left ("parseRegex for Text.Regex.TDFA.ByteString failed:"++show err)     Right pattern -> Right (patternToRegex pattern compOpt execOpt) -execute :: Regex      -- ^ Compiled regular expression+execute :: Regex        -- ^ Compiled regular expression         -> B.ByteString -- ^ ByteString to match against         -> Either String (Maybe MatchArray) execute r bs = Right (matchOnce r bs) -regexec :: Regex      -- ^ Compiled regular expression+regexec :: Regex        -- ^ Compiled regular expression         -> B.ByteString -- ^ ByteString to match against         -> Either String (Maybe (B.ByteString, B.ByteString, B.ByteString, [B.ByteString]))-regexec r bs =-  case matchOnceText r bs of-    Nothing -> Right (Nothing)-    Just (pre,mt,post) ->-      let main = fst (mt!0)-          rest = map fst (tail (elems mt)) -- will be []-      in Right (Just (pre,main,post,rest))+regexec r txt = Right $+  case matchOnceText r txt of+    Just (pre, mt, post) | main:rest <- map fst (elems mt)+      -> Just (pre, main, post, rest)+    _ -> Nothing
lib/Text/Regex/TDFA/ByteString/Lazy.hs view
@@ -79,18 +79,16 @@     Left err -> Left ("parseRegex for Text.Regex.TDFA.ByteString failed:"++show err)     Right pattern -> Right (patternToRegex pattern compOpt execOpt) -execute :: Regex      -- ^ Compiled regular expression+execute :: Regex        -- ^ Compiled regular expression         -> L.ByteString -- ^ ByteString to match against         -> Either String (Maybe MatchArray) execute r bs = Right (matchOnce r bs) -regexec :: Regex      -- ^ Compiled regular expression+regexec :: Regex        -- ^ Compiled regular expression         -> L.ByteString -- ^ ByteString to match against         -> Either String (Maybe (L.ByteString, L.ByteString, L.ByteString, [L.ByteString]))-regexec r bs =-  case matchOnceText r bs of-    Nothing -> Right (Nothing)-    Just (pre,mt,post) ->-      let main = fst (mt!0)-          rest = map fst (tail (elems mt)) -- will be []-      in Right (Just (pre,main,post,rest))+regexec r txt = Right $+  case matchOnceText r txt of+    Just (pre, mt, post) | main:rest <- map fst (elems mt)+      -> Just (pre, main, post, rest)+    _ -> Nothing
lib/Text/Regex/TDFA/Common.hs view
@@ -1,7 +1,9 @@ {-# OPTIONS -funbox-strict-fields #-}--- | Common provides simple functions to the backend.  It defines most--- of the data types.  All modules should call error via the--- common_error function below.++-- | Common provides simple functions to the backend.+-- It defines most of the data types.+-- All modules should call 'error' via the 'common_error' function below.+ module Text.Regex.TDFA.Common where  import Text.Regex.Base(RegexOptions(..))@@ -26,19 +28,19 @@  common_error :: String -> String -> a common_error moduleName message =-  error ("Explict error in module "++moduleName++" : "++message)+  error ("Explicit error in module "++moduleName++" : "++message)  on :: (t1 -> t1 -> t2) -> (t -> t1) -> t -> t -> t2 f `on` g = (\x y -> (g x) `f` (g y)) --- | after 'sort' or 'sortBy' the use of 'nub'\/'nubBy' can be replaced by 'norep'\/'norepBy'+-- | After 'sort' or 'sortBy' the use of 'nub' or 'nubBy' can be replaced by 'norep' or 'norepBy'. norep :: (Eq a) => [a]->[a] norep [] = [] norep x@[_] = x norep (a:bs@(c:cs)) | a==c = norep (a:cs)                     | otherwise = a:norep bs --- | after 'sort' or 'sortBy' the use of 'nub'\/'nubBy' can be replaced by 'norep'\/'norepBy'+-- | After 'sort' or 'sortBy' the use of 'nub' or 'nubBy' can be replaced by 'norep' or 'norepBy'. norepBy :: (a -> a -> Bool) -> [a] -> [a] norepBy _ [] = [] norepBy _ x@[_] = x@@ -68,8 +70,7 @@ noWin :: WinTags -> Bool noWin = null --- | Used to track elements of the pattern that accept characters or --- are anchors+-- | Used to track elements of the pattern that accept characters or are anchors. newtype DoPa = DoPa {dopaIndex :: Int} deriving (Eq,Ord)  instance Enum DoPa where@@ -82,48 +83,58 @@ -- | Control whether the pattern is multiline or case-sensitive like Text.Regex and whether to -- capture the subgroups (\\1, \\2, etc).  Controls enabling extra anchor syntax. data CompOption = CompOption {-    caseSensitive :: Bool    -- ^ True in blankCompOpt and defaultCompOpt-  , multiline :: Bool {- ^ False in blankCompOpt, True in defaultCompOpt. Compile for-                      newline-sensitive matching.  "By default, newline is a completely ordinary-                      character with no special meaning in either REs or strings.  With this flag,-                      inverted bracket expressions and . never match newline, a ^ anchor matches the-                      null string after any newline in the string in addition to its normal-                      function, and the $ anchor matches the null string before any newline in the-                      string in addition to its normal function." -}-  , rightAssoc :: Bool       -- ^ True (and therefore Right associative) in blankCompOpt and defaultCompOpt-  , newSyntax :: Bool        -- ^ False in blankCompOpt, True in defaultCompOpt. Add the extended non-POSIX syntax described in "Text.Regex.TDFA" haddock documentation.-  , lastStarGreedy ::  Bool  -- ^ False by default.  This is POSIX correct but it takes space and is slower.-                            -- Setting this to true will improve performance, and should be done-                            -- if you plan to set the captureGroups execoption to False.+    caseSensitive :: Bool+      -- ^ True in 'blankCompOpt' and 'defaultCompOpt'.+  , multiline :: Bool+      -- ^ False in 'blankCompOpt', True in 'defaultCompOpt'.+      -- Compile for newline-sensitive matching.+      --+      -- From [regexp man page](https://www.tcl.tk/man/tcl8.4/TclCmd/regexp.html#M8):+      -- "By default, newline is a completely ordinary character with no special meaning in either REs or strings.+      -- With this flag, inverted bracket expressions @[^@ and @.@ never match newline,+      -- a @^@ anchor matches the null string after any newline in the string in addition to its normal function,+      -- and the @$@ anchor matches the null string before any newline in the string in addition to its normal function."+  , rightAssoc :: Bool+      -- ^ True (and therefore right associative) in 'blankCompOpt' and 'defaultCompOpt'.+  , newSyntax :: Bool+      -- ^ False in 'blankCompOpt', True in 'defaultCompOpt'.+      -- Enables the extended non-POSIX syntax described in "Text.Regex.TDFA" haddock documentation.+  , lastStarGreedy ::  Bool+      -- ^ False by default.  This is POSIX correct but it takes space and is slower.+      -- Setting this to True will improve performance, and should be done+      -- if you plan to set the 'captureGroups' 'ExecOption' to False.   } deriving (Read,Show)  data ExecOption = ExecOption {     captureGroups :: Bool    -- ^ True by default.  Set to False to improve speed (and space).   } deriving (Read,Show) --- | Used by implementation to name certain Postions during--- matching. Identity of Position tag to set during a transition+-- | Used by implementation to name certain 'Position's during+-- matching. Identity of 'Position' tag to set during a transition. type Tag = Int--- | Internal use to indicate type of tag and preference for larger or smaller Positions++-- | Internal use to indicate type of tag and preference for larger or smaller 'Position's. data OP = Maximize | Minimize | Orbit | Ignore deriving (Eq,Show)--- | Internal NFA node identity number++-- | Internal NFA node identity number. type Index = Int--- | Internal DFA identity is this Set of NFA Index++-- | Internal DFA identity is this 'Set' of NFA 'Index'. type SetIndex = IntSet {- Index -}--- | Index into the text being searched++-- | Index into the text being searched. type Position = Int --- | GroupIndex is for indexing submatches from capturing--- parenthesized groups (PGroup\/Group)+-- | 'GroupIndex' is for indexing submatches from capturing parenthesized groups ('PGroup' or 'Group'). type GroupIndex = Int--- | GroupInfo collects the parent and tag information for an instance --- of a group++-- | 'GroupInfo' collects the parent and tag information for an instance of a group. data GroupInfo = GroupInfo {     thisIndex, parentIndex :: GroupIndex   , startTag, stopTag, flagTag :: Tag   } deriving Show --- | The TDFA backend specific 'Regex' type, used by this module's RegexOptions and RegexMaker+-- | The TDFA backend specific 'Regex' type, used by this module's 'RegexOptions' and 'RegexMaker'. data Regex = Regex {     regex_dfa :: DFA                             -- ^ starting DFA state   , regex_init :: Index                          -- ^ index of starting state@@ -161,10 +172,10 @@               | WinTest WhichTest (Maybe WinEmpty) (Maybe WinEmpty)   deriving Show --- | Internal NFA node type+-- | Internal NFA node type. data QNFA = QNFA {q_id :: Index, q_qt :: QT} --- | Internal to QNFA type.+-- | Internal to 'QNFA' type. data QT = Simple { qt_win :: WinTags -- ^ empty transitions to the virtual winning state                  , qt_trans :: CharMap QTrans -- ^ all ways to leave this QNFA to other or the same QNFA                  , qt_other :: QTrans -- ^ default ways to leave this QNFA to other or the same QNFA@@ -182,29 +193,38 @@ -- Also support for GNU extensions is being added: \\\` beginning of -- buffer, \\\' end of buffer, \\\< and \\\> for begin and end of words, \\b -- and \\B for word boundary and not word boundary.-data WhichTest = Test_BOL | Test_EOL -- '^' and '$' (affected by multiline option)-               | Test_BOB | Test_EOB -- \` and \' begin and end buffer-               | Test_BOW | Test_EOW -- \< and \> begin and end word-               | Test_EdgeWord | Test_NotEdgeWord -- \b and \B word boundaries+data WhichTest+  = Test_BOL          -- ^ @^@ (affected by multiline option)+  | Test_EOL          -- ^ @$@ (affected by multiline option)+  | Test_BOB          -- ^ @\\`@ beginning of buffer+  | Test_EOB          -- ^ @\\'@ end ofbuffer+  | Test_BOW          -- ^ @\\<@ beginning of word+  | Test_EOW          -- ^ @\\>@ end of word+  | Test_EdgeWord     -- ^ @\\b@ word boundary+  | Test_NotEdgeWord  -- ^ @\\B@ not word boundary   deriving (Show,Eq,Ord,Enum) --- | The things that can be done with a Tag.  TagTask and--- ResetGroupStopTask are for tags with Maximize or Minimize OP--- values.  ResetOrbitTask and EnterOrbitTask and LeaveOrbitTask are+-- | The things that can be done with a Tag.  'TagTask' and+-- 'ResetGroupStopTask' are for tags with Maximize or Minimize OP+-- values.  'ResetOrbitTask' and 'EnterOrbitTask' and 'LeaveOrbitTask' are -- for tags with Orbit OP value. data TagTask = TagTask | ResetGroupStopTask | SetGroupStopTask              | ResetOrbitTask | EnterOrbitTask | LeaveOrbitTask deriving (Show,Eq) --- | Ordered list of tags and their associated Task+-- | Ordered list of tags and their associated Task. type TagTasks = [(Tag,TagTask)]+ -- | When attached to a QTrans the TagTask can be done before or after -- accepting the character. data TagUpdate = PreUpdate TagTask | PostUpdate TagTask deriving (Show,Eq)+ -- | Ordered list of tags and their associated update operation. type TagList = [(Tag,TagUpdate)]+ -- | A TagList and the location of the item in the original pattern -- that is being accepted. type TagCommand = (DoPa,TagList)+ -- | Ordered list of tags and their associated update operation to -- perform on an empty transition to the virtual winning state. type WinTags = TagList@@ -226,27 +246,26 @@                    , dt_a,dt_b :: DT      -- ^ use dt_a if test is True else use dt_b                    } --- | Internal type to repesent the commands for the tagged transition.--- The outer IntMap is for the destination Index and the inner IntMap+-- | Internal type to represent the commands for the tagged transition.+-- The outer 'IntMap' is for the destination Index and the inner 'IntMap' -- is for the Source Index.  This is convenient since all runtime data -- going to the same destination must be compared to find the best. ----- A Destination IntMap entry may have an empty Source IntMap if and--- only if the destination is the starting index and the NFA\/DFA.+-- A Destination 'IntMap' entry may have an empty Source 'IntMap' if and+-- only if the destination is the starting index and the NFA or DFA. -- This instructs the matching engine to spawn a new entry starting at -- the post-update position. type DTrans = IntMap {- Index of Destination -} (IntMap {- Index of Source -} (DoPa,Instructions)) -- type DTrans = IntMap {- Index of Destination -} (IntMap {- Index of Source -} (DoPa,RunState ()))--- | Internal convenience type for the text display code++-- | Internal convenience type for the text display code. type DTrans' = [(Index, [(Index, (DoPa, ([(Tag, (Position,Bool))],[String])))])] --- | Positions for which a * was re-started while looping.  Need to+-- | Positions for which a @*@ was re-started while looping.  Need to -- append locations at back but compare starting with front, so use--- Seq as a Queue.  The initial position is saved in basePos (and a--- Maximize Tag), the middle positions in the Seq, and the final+-- 'Seq' as a queue.  The initial position is saved in 'basePos' (and a+-- Maximize Tag), the middle positions in the 'Seq', and the final -- position is NOT saved in the Orbits (only in a Maximize Tag).------ The orderinal code is being written XXX TODO document it. data Orbits = Orbits   { inOrbit :: !Bool        -- True if enterOrbit, False if LeaveOrbit   , basePos :: Position@@ -290,7 +309,7 @@   where foo :: CharMap QTrans -> [(Char,[(Index,[TagCommand])])]         foo = mapSnd foo' . Map.toAscList         foo' :: QTrans -> [(Index,[TagCommand])]-        foo' = IMap.toList +        foo' = IMap.toList showQT (Testing test dopas a b) = "{Testing "++show test++" "++show (Set.toList dopas)                               ++"\n"++indent' a                               ++"\n"++indent' b++"}"
lib/Text/Regex/TDFA/CorePattern.hs view
@@ -34,8 +34,11 @@                                   ,TestInfo,OP(..),SetTestInfo(..),NullView                                   ,patternToQ,cleanNullView,cannotAccept,mustAccept) where -import Control.Monad.RWS {- all -}+import Control.Monad (liftM2, forM, replicateM)+import Control.Monad.RWS (RWS, runRWS, ask, local, listens, tell, get, put)+ import Data.Array.IArray(Array,(!),accumArray,listArray)+import Data.Either (partitionEithers, rights) import Data.List(sort) import Data.IntMap.EnumMap2(EnumMap) import qualified Data.IntMap.EnumMap2 as Map(singleton,null,assocs,keysSet)@@ -43,6 +46,7 @@ import Data.IntSet.EnumSet2(EnumSet) import qualified Data.IntSet.EnumSet2 as Set(singleton,toList,isSubsetOf) import Data.Semigroup as Sem+ import Text.Regex.TDFA.Common {- all -} import Text.Regex.TDFA.Pattern(Pattern(..),starTrans) -- import Debug.Trace@@ -249,7 +253,7 @@ -- from the dfs of the children and simultaneously down in the form of -- pre and post HandleTag data.  This bidirectional flow is handled -- declaratively by using the MonadFix (i.e. mdo).--- +-- -- Invariant: A tag should exist in Q in exactly one place (and will -- be in a preTag,postTag, or getOrbit field).  This is partly because -- PGroup needs to know the tags are around precisely the expression@@ -264,11 +268,11 @@ -- -- There is a final "qwin of Q {postTag=ISet.singleton 1}" and an -- implied initial index tag of 0.--- +-- -- favoring pushing Apply into the child postTag makes PGroup happier -type PM = RWS (Maybe GroupIndex) [Either Tag GroupInfo] ([OP]->[OP],Tag) -type HHQ = HandleTag  -- m1 : info about left boundaary / preTag+type PM = RWS (Maybe GroupIndex) [Either Tag GroupInfo] ([OP]->[OP],Tag)+type HHQ = HandleTag  -- m1 : info about left boundary / preTag         -> HandleTag  -- m2 : info about right boundary / postTag         -> PM Q @@ -277,18 +281,6 @@ makeGroupArray maxGroupIndex groups = accumArray (\earlier later -> later:earlier) [] (1,maxGroupIndex) filler     where filler = map (\gi -> (thisIndex gi,gi)) groups -fromRight :: [Either Tag GroupInfo] -> [GroupInfo]-fromRight [] = []-fromRight ((Right x):xs) = x:fromRight xs-fromRight ((Left _):xs) = fromRight xs--partitionEither :: [Either Tag GroupInfo] -> ([Tag],[GroupInfo])-partitionEither = helper id id where-  helper :: ([Tag]->[Tag]) -> ([GroupInfo]->[GroupInfo]) -> [Either Tag GroupInfo] -> ([Tag],[GroupInfo])-  helper ls rs [] = (ls [],rs [])-  helper ls rs ((Right x):xs) = helper  ls      (rs.(x:)) xs-  helper ls rs ((Left  x):xs) = helper (ls.(x:)) rs       xs- -- Partial function: assumes starTrans has been run on the Pattern -- Note that the lazy dependency chain for this very zigzag: --   varies information is sent up the tree@@ -298,13 +290,13 @@ --       and lazily looks resetGroupTags from aGroups, the result of all writer (Right _) --       preReset stores the resetGroupTags result of the lookup in the tree --     makeOrbit sends some tags to the writer (Left _)---     withOrbit listens to children send orbit info to writer for resetOrbitTags +--     withOrbit listens to children send orbit info to writer for resetOrbitTags --   nullQ depends m1 m2 and resetOrbitTags and resetGroupTags and is sent up the tree patternToQ :: CompOption -> (Pattern,(GroupIndex,DoPa)) -> (Q,Array Tag OP,Array GroupIndex [GroupInfo]) patternToQ compOpt (pOrig,(maxGroupIndex,_)) = (tnfa,aTags,aGroups) where   (tnfa,(tag_dlist,nextTag),groups) = runRWS monad startReader startState   aTags = listArray (0,pred nextTag) (tag_dlist [])-  aGroups = makeGroupArray maxGroupIndex (fromRight groups)+  aGroups = makeGroupArray maxGroupIndex (rights groups)    -- implicitly inside a PGroup 0 converted into a GroupInfo 0 undefined 0 1   monad = go (starTrans pOrig) (Advice 0) (Advice 1)@@ -353,8 +345,7 @@   -- withOrbit uses MonadWriter(listens to makeOrbit/Left), collects   -- children at all depths   withOrbit :: PM a -> PM (a,[Tag])-  withOrbit = listens childStars-    where childStars x = let (ts,_) = partitionEither x in ts+  withOrbit = listens $ fst . partitionEithers    {-# INLINE makeGroup #-}   -- makeGroup usesMonadWriter(tell/Right)@@ -374,12 +365,12 @@   -- withParent uses MonadReader(local) to set getParentIndex to return (Just this)   -- withParent uses MonadWriter(listens to makeGroup/Right) to return contained group indices (stopTag)   -- withParent is only safe if getParentIndex has been checked to be not equal to Nothing (see PGroup below)-  -- Note use of laziness: the immediate children's group index is used to look up all copies of the +  -- Note use of laziness: the immediate children's group index is used to look up all copies of the   -- group in aGroups, including copies that are not immediate children.   withParent :: GroupIndex -> PM a -> PM (a,[Tag])   withParent this = local (const (Just this)) . listens childGroupInfo     where childGroupInfo x =-            let (_,gs) = partitionEither x+            let gs = snd $ partitionEithers x                 children :: [GroupIndex]                 children = norep . sort . map thisIndex                            -- filter to get only immediate children (efficiency)@@ -388,7 +379,7 @@    -- combineConcat is a partial function: Must not pass in an empty list   -- Policy choices:-  --  * pass tags to apply to children and have no preTag or postTag here (so none addded to nullQ)+  --  * pass tags to apply to children and have no preTag or postTag here (so none added to nullQ)   --  * middle 'mid' tag: give to left/front child as postTag so a Group there might claim it as a stopTag   --  * if parent is Group then preReset will become non-empty   combineConcat :: [Pattern] -> HHQ@@ -464,7 +455,7 @@                newUniq = if needUniqTags then uniq "POr branch" else return bAdvice --           trace ("\nPOr sub "++show aAdvice++" "++show bAdvice++"needsTags is "++show needTags) $ return ()            -- The "bs" values are allocated in left-to-right order before the children in "qs"-           -- optimiztion: low priority for last branch is implicit, do not create separate tag here.+           -- optimization: low priority for last branch is implicit, do not create separate tag here.            bs <- fmap (++[bAdvice]) $ replicateM (pred $ length branches) newUniq -- 2 <= length ps            -- create all the child branches in left-to-right order after the "bs"            qs <- forM (zip branches bs) (\(branch,bTag) ->  (go branch aAdvice bTag))@@ -543,7 +534,7 @@          --          -- If the parent index is Nothing then this is part of a          -- non-capturing subtree and ignored.  This is a lazy and-         -- efficient alternative to rebuidling the tree with PGroup+         -- efficient alternative to rebuilding the tree with PGroup          -- Nothing replacing PGroup (Just _).          --          -- Guarded by the getParentIndex /= Nothing check is the@@ -592,7 +583,7 @@          -- PNonEmpty means the child pattern p can be skipped by          -- bypassing the pattern.  This is only used in the case p          -- can accept 0 and can accept more than zero characters-         -- (thus the assertions, enforcted by CorePattern.starTrans).+         -- (thus the assertions, enforced by CorePattern.starTrans).          -- The important thing about this case is intercept the          -- "accept 0" possibility and replace with "skip".          PNonEmpty p -> mdo@@ -630,5 +621,5 @@   -- xxx todo--- +-- -- see of PNonEmpty -> NonEmpty -> TNFA is really smarter than POr about tags
lib/Text/Regex/TDFA/NewDFA/Engine.hs view
@@ -1,6 +1,12 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 902+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#endif+ -- | This is the code for the main engine.  This captures the posix subexpressions. This 'execMatch' -- also dispatches to "Engine_NC", "Engine_FA", and "Engine_FC_NA"--- +-- -- It is polymorphic over the internal Uncons type class, and specialized to produce the needed -- variants. module Text.Regex.TDFA.NewDFA.Engine(execMatch) where@@ -10,7 +16,8 @@ -- #ifdef __GLASGOW_HASKELL__ import GHC.Arr(STArray(..)) import GHC.ST(ST(..))-import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#)+import GHC.Exts(MutableByteArray#,RealWorld,Int#,getSizeofMutableByteArray#,State#)+import Unsafe.Coerce (unsafeCoerce) {- -- #else import Control.Monad.ST(ST)@@ -26,10 +33,11 @@ import Data.IntMap(IntMap) import qualified Data.IntMap as IMap(null,toList,lookup,insert) import Data.Maybe(catMaybes)-import Data.Monoid(Monoid(..))+import Data.Monoid as Mon(Monoid(..)) import qualified Data.IntSet as ISet(toAscList) import Data.Array.IArray((!))-import Data.List(partition,sort,foldl',sortBy,groupBy)+import Data.List(partition,sort,sortBy,groupBy)+import qualified Data.List as List import Data.STRef(STRef,newSTRef,readSTRef,writeSTRef) import qualified Control.Monad.ST.Lazy as L(ST,runST,strictToLazyST) import qualified Control.Monad.ST.Strict as S(ST)@@ -37,6 +45,9 @@ import qualified Data.Sequence as Seq(null) import qualified Data.ByteString.Char8 as SBS(ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Foreign.Ptr(Ptr)  import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) import qualified Text.Regex.TDFA.IntArrTrieSet as Trie(lookupAsc)@@ -69,11 +80,13 @@ {-# INLINE set #-} set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s () set = unsafeWrite- + {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> ([] Char) -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-}+{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> T.Text -> [MatchArray] #-}+{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> TL.Text -> [MatchArray] #-} execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray] execMatch r@(Regex { regex_dfa = DFA {d_id=didIn,d_dt=dtIn}                    , regex_init = startState@@ -100,7 +113,7 @@   orbitTags :: [Tag]   !orbitTags = map fst . filter ((Orbit==).snd) . assocs $ aTags -  !test = mkTest newline         +  !test = mkTest newline    comp :: C s   comp = {-# SCC "matchHere.comp" #-} ditzyComp'3 aTags@@ -172,7 +185,7 @@ -- position and the basePos position.  Entries in different groups -- will never be comparable in the future so they can be processed -- separately.  Groups could probably be even more finely--- distinguished, as a futher optimization, but the justification will+-- distinguished, as a further optimization, but the justification will -- be tricky. -- -- Current Tag-0 values are at most offset and all newly spawned@@ -187,7 +200,7 @@ -- is avoided. -- -- An entry in a group can only collide with that group's--- descendents. compressOrbit sends each group to the compressGroup+-- descendants. compressOrbit sends each group to the compressGroup -- command. -- -- compressGroup on a single record checks whether it's Seq can be@@ -195,19 +208,19 @@ -- this this not particularly important). -- -- compressGroup on many records sorts and groups the members and zips--- the groups with their new ordinal value.  The comparision is based+-- the groups with their new ordinal value.  The comparison is based -- on the old ordinal value, then the inOrbit value, and then the (Seq -- Position) data. -- -- The old ordinals of the group will all be Nothing or all be Just, -- but this condition is neither checked nor violations detected.--- This comparision is justified because once records get different+-- This comparison is justified because once records get different -- ordinals assigned they will never change places. -- -- The inOrbit Bool is only different if one of them has set the stop--- position to at most (succ offset).  They will obly be compared if+-- position to at most (succ offset).  They will only be compared if -- the other one leaves, an its stop position will be at least offset.--- The previous sentence is justified by inspectin of the "assemble"+-- The previous sentence is justified by inspection of the "assemble" -- function in the TDFA module: there is no (PostUpdate -- LeaveOrbitTask) so the largest possible value for the stop Tag is -- (pred offset). Thus the record with inOrbit==False would beat (be@@ -215,7 +228,7 @@ -- -- The Seq comparison is safe because the largest existing Position -- value is (pred offset) and the smallest future Position value is--- offset.  The previous sentence is justified by inspectin of the+-- offset.  The previous sentence is justified by inspection of the -- "assemble" function in the TDFA module: there is no (PostUpdate -- EnterOrbitTags) so the largest possible value in the Seq is (pred -- offset).@@ -237,7 +250,7 @@                                     _ -> return Nothing )                 let compressGroup [((state,_),orbit)] | Seq.null (getOrbits orbit) = return ()                                                       | otherwise =-                      set (m_orbit s1) state +                      set (m_orbit s1) state                       . (IMap.insert tag $! (orbit { ordinal = Nothing, getOrbits = mempty}))                       =<< m_orbit s1 !! state @@ -285,7 +298,8 @@                     challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.findTrans.challenge" #-} do                       check <- comp offset x1 (newPos ins1) x2 (newPos ins2)                       if check==LT then return x2 else return x1-                (first:rest) <- mapM prep (IMap.toList sources)+                first_rest <- mapM prep (IMap.toList sources)+                let first:rest = first_rest                 set which destIndex =<< foldM challenge first rest           let dl = IMap.toList dtrans           mapM_ findTransTo dl@@ -298,9 +312,9 @@           earlyStart <- fmap minimum $ mapM performTransTo dl           -- findTrans part 3           earlyWin <- readSTRef (mq_earliest winQ)-          if earlyWin < earlyStart +          if earlyWin < earlyStart             then do-              winners <- fmap (foldl' (\ rest ws -> ws : rest) []) $+              winners <- fmap (List.foldl' (\ rest ws -> ws : rest) []) $                            getMQ earlyStart winQ               writeSTRef storeNext (next s2 s1 did' dt' (succ offset) prev' input')               mapM (tagsToGroupsST aGroups) winners@@ -316,7 +330,7 @@ -- A non-empty winner from the startState might obscure a potential -- empty winner (form the startState at the current offset).  This -- winEmpty possibility is also checked for. (unit test pattern ".*")--- (futher test "(.+|.+.)*" on "aa\n")+-- (further test "(.+|.+.)*" on "aa\n")          {-# INLINE processWinner #-}         processWinner s1 did dt w offset = {-# SCC "goNext.newWinnerThenProceed" #-} do@@ -376,7 +390,7 @@           set newerPos 0 preTag           doActions preTag newerPos (newPos winInstructions)           putMQ (WScratch newerPos) winQ-                +         newWinner preTag ((_sourceIndex,winInstructions),oldPos,_newOrbit) = {-# SCC "goNext.newWinner" #-} do           newerPos <- newA_ b_tags           copySTU oldPos newerPos@@ -384,7 +398,7 @@           putMQ (WScratch newerPos) winQ          finalizeWinners = do-          winners <- fmap (foldl' (\ rest mqa -> mqa_ws mqa : rest) []) $+          winners <- fmap (List.foldl' (\ rest mqa -> mqa_ws mqa : rest) []) $                        readSTRef (mq_list winQ) -- reverses the winner list           resetMQ winQ           writeSTRef storeNext (return [])@@ -437,7 +451,7 @@     then writeSTRef earliest start >> writeSTRef list [mqa]     else do   old <- readSTRef list-  let !rest = dropWhile (\ m -> start <= mqa_start m) old +  let !rest = dropWhile (\ m -> start <= mqa_start m) old       !new = mqa : rest   writeSTRef list new @@ -498,7 +512,7 @@ showWS :: WScratch s -> ST s String showWS (WScratch pos) = do   a <- getAssocs pos-  return $ unlines [ "WScratch" +  return $ unlines [ "WScratch"                    , indent (show a)] -} {- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -}@@ -523,7 +537,7 @@ newMScratch :: (Index,Index) -> S.ST s (MScratch s) newMScratch b_index = do   pos's <- newArray b_index Nothing-  orbit's <- newArray b_index mempty+  orbit's <- newArray b_index Mon.mempty   return (MScratch pos's orbit's)  {- COMPOSE A FUNCTION CLOSURE TO COMPARE TAG VALUES -}@@ -560,7 +574,7 @@    allcomps :: Tag -> [F s]   allcomps tag | tag > top = [F (\ _ _ _ _ _ _ -> return EQ)]-               | otherwise = +               | otherwise =     case aTagOP ! tag of       Orbit -> F (challenge_Orb tag) : allcomps (succ tag)       Maximize -> F (challenge_Max tag) : allcomps (succ tag)@@ -609,7 +623,7 @@               else return (compare p1 p2)   challenge_Max _ [] _ _ _ _ _ = err "impossible 9384324" -  challenge_Orb !tag (F next:comps) preTag x1@(_state1,_pos1,orbit1') np1 x2@(_state2,_pos2,orbit2') np2 = +  challenge_Orb !tag (F next:comps) preTag x1@(_state1,_pos1,orbit1') np1 x2@(_state2,_pos2,orbit2') np2 =     let s1 = IMap.lookup tag orbit1'         s2 = IMap.lookup tag orbit2'     in case (s1,s2) of@@ -630,7 +644,7 @@ comparePos EmptyL EmptyL = EQ comparePos EmptyL _      = GT comparePos _      EmptyL = LT-comparePos (p1 :< ps1) (p2 :< ps2) = +comparePos (p1 :< ps1) (p2 :< ps2) =   compare p1 p2 `mappend` comparePos (viewl ps1) (viewl ps2)  {- CONVERT WINNERS TO MATCHARRAY -}@@ -698,8 +712,11 @@  -- #ifdef __GLASGOW_HASKELL__ foreign import ccall unsafe "memcpy"-    memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO ()+    memcpyIO :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO (Ptr a) +memcpyST :: MutableByteArray# s -> MutableByteArray# s -> Int# -> State# s -> (# State# s, Ptr a #)+memcpyST = unsafeCoerce memcpyIO+ {- Prelude Data.Array.Base> :i STUArray data STUArray s i e@@ -709,16 +726,16 @@ -- This has been updated for ghc 6.8.3 and still works with ghc 6.10.1 {-# INLINE copySTU #-} copySTU :: (Show i,Ix i,MArray (STUArray s) e (S.ST s)) => STUArray s i e -> STUArray s i e -> S.ST s () -- (STUArray s i e)-copySTU _souce@(STUArray _ _ _ msource) _destination@(STUArray _ _ _ mdest) =+copySTU _source@(STUArray _ _ _ msource) _destination@(STUArray _ _ _ mdest) = -- do b1 <- getBounds s1 --  b2 <- getBounds s2 --  when (b1/=b2) (error ("\n\nWTF copySTU: "++show (b1,b2)))   ST $ \s1# ->-    case sizeofMutableByteArray# msource        of { n# ->-    case unsafeCoerce# memcpy mdest msource n# s1# of { (# s2#, () #) ->+    case getSizeofMutableByteArray# msource s1# of { (# s1'#, n# #) ->+    case memcpyST mdest msource n# s1'# of { (# s2#, _ #) ->     (# s2#, () #) }} {--#else /* !__GLASGOW_HASKELL__ */+-- #else /* !__GLASGOW_HASKELL__ */  copySTU :: (MArray (STUArray s) e (S.ST s))=> STUArray s Tag e -> STUArray s Tag e -> S.ST s (STUArray s i e) copySTU source destination = do@@ -729,5 +746,5 @@   forM_ (range b) $ \index ->     set destination index =<< source !! index   return destination-#endif /* !__GLASGOW_HASKELL__ */+-- #endif /* !__GLASGOW_HASKELL__ */ -}
lib/Text/Regex/TDFA/NewDFA/Engine_FA.hs view
@@ -1,22 +1,23 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 902+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#endif+ -- | This is the code for the main engine.  This captures the posix -- subexpressions.  There is also a non-capturing engine, and a -- testing engine.--- +-- -- It is polymorphic over the internal Uncons type class, and -- specialized to produce the needed variants.+ module Text.Regex.TDFA.NewDFA.Engine_FA(execMatch) where  import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..))--- #ifdef __GLASGOW_HASKELL__+ import GHC.Arr(STArray(..)) import GHC.ST(ST(..))-import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#)-{---- #else-import Control.Monad.ST(ST)-import Data.Array.ST(STArray)--- #endif--}+import GHC.Exts(MutableByteArray#,RealWorld,Int#,getSizeofMutableByteArray#,unsafeCoerce#,State#)  import Prelude hiding ((!!)) import Control.Monad(when,unless,forM,forM_,liftM2,foldM)@@ -27,7 +28,8 @@ import Data.IntMap(IntMap) import qualified Data.IntMap as IMap(null,toList,lookup,insert) import Data.Maybe(catMaybes)-import Data.Monoid(Monoid(..))+import Data.Monoid as Mon(Monoid(..))+import Data.IntSet(IntSet) import qualified Data.IntSet as ISet(toAscList,null) import Data.Array.IArray((!)) import Data.List(sortBy,groupBy)@@ -37,6 +39,7 @@ import qualified Data.Sequence as Seq(null) import qualified Data.ByteString.Char8 as SBS(ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString)+import Foreign.Ptr(Ptr)  import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) import Text.Regex.TDFA.Common hiding (indent)@@ -60,12 +63,12 @@  noSource :: ((Index, Instructions),STUArray s Tag Position,OrbitLog) noSource = ((-1,err "noSource"),err "noSource",err "noSource")- + {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> ([] Char) -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-}-execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray]+execMatch :: forall text. Uncons text => Regex -> Position -> Char -> text -> [MatchArray] execMatch (Regex { regex_dfa =  DFA {d_id=didIn,d_dt=dtIn}                  , regex_init = startState                  , regex_b_index = b_index@@ -81,12 +84,13 @@   orbitTags :: [Tag]   !orbitTags = map fst . filter ((Orbit==).snd) . assocs $ aTags -  !test = mkTest newline         +  test :: WhichTest -> Index -> Char -> text -> Bool+  !test = mkTest newline    comp :: C s   comp = {-# SCC "matchHere.comp" #-} ditzyComp'3 aTags -  goNext :: ST s [MatchArray]+  goNext :: forall s. ST s [MatchArray]   goNext = {-# SCC "goNext" #-} do     (SScratch s1In s2In (winQ,blank,which)) <- newScratch b_index b_tags     spawnAt b_tags blank startState s1In offsetIn@@ -112,14 +116,14 @@ -- compressOrbit. -- -- compressOrbit on such a Tag loops through all the NFS states'--- m_orbit record, discardind ones that are Nothing and discarding+-- m_orbit record, discarding ones that are Nothing and discarding -- ones that are too new to care about (after the cutoff value). -- -- compressOrbit then groups the Orbits records by the Tag-0 start--- position and the basePos position.  Entried in different groups+-- position and the basePos position.  Entries in different groups -- will never be comparable in the future so they can be processed -- separately.  Groups could probably be even more finely--- distinguished, as a futher optimization, but the justification will+-- distinguished, as a further optimization, but the justification will -- be tricky. -- -- Current Tag-0 values are at most offset and all newly spawned@@ -134,7 +138,7 @@ -- is avoided. -- -- An entry in a group can only collide with that group's--- descendents. compressOrbit sends each group to the compressGroup+-- descendants. compressOrbit sends each group to the compressGroup -- command. -- -- compressGroup on a single record checks whether it's Seq can be@@ -142,19 +146,19 @@ -- this this not particularly important). -- -- compressGroup on many records sorts and groups the members and zips--- the groups with their new ordinal value.  The comparision is based+-- the groups with their new ordinal value.  The comparison is based -- on the old ordinal value, then the inOrbit value, and then the (Seq -- Position) data. -- -- The old ordinals of the group will all be Nothing or all be Just, -- but this condition is neither checked nor violations detected.--- This comparision is justified because once records get different+-- This comparison is justified because once records get different -- ordinals assigned they will never change places. -- -- The inOrbit Bool is only different if one of them has set the stop -- position to at most (succ offset).  They will obly be compared if -- the other one leaves, an its stop position will be at least offset.--- The previous sentence is justified by inspectin of the "assemble"+-- The previous sentence is justified by inspection of the "assemble" -- function in the TDFA module: there is no (PostUpdate -- LeaveOrbitTask) so the largest possible value for the stop Tag is -- (pred offset). Thus the record with inOrbit==False would beat (be@@ -162,7 +166,7 @@ -- -- The Seq comparison is safe because the largest existing Position -- value is (pred offset) and the smallest future Position value is--- offset.  The previous sentence is justified by inspectin of the+-- offset.  The previous sentence is justified by inspection of the -- "assemble" function in the TDFA module: there is no (PostUpdate -- EnterOrbitTags) so the largest possible value in the Seq is (pred -- offset).@@ -170,6 +174,7 @@ -- The updated Orbits get the new ordinal value and an empty (Seq -- Position). +        compressOrbits :: MScratch s -> IntSet -> Position -> ST s ()         compressOrbits s1 did offset = do           let getStart state = do start <- maybe (err "compressOrbit,1") (!! 0) =<< m_pos s1 !! state                                   return (state,start)@@ -184,7 +189,7 @@                                     _ -> return Nothing )                 let compressGroup [((state,_),orbit)] | Seq.null (getOrbits orbit) = return ()                                                       | otherwise =-                      set (m_orbit s1) state +                      set (m_orbit s1) state                       . (IMap.insert tag $! (orbit { ordinal = Nothing, getOrbits = mempty}))                       =<< m_orbit s1 !! state @@ -214,6 +219,17 @@ -- "storeNext".  If no winners are ready to be released then the -- computation continues immediately. +        findTrans+          :: MScratch s+          -> MScratch s+          -> IntSet+          -> SetIndex+          -> DT+          -> DTrans+          -> Index+          -> Char+          -> text+          -> ST s [MatchArray]         findTrans s1 s2 did did' dt' dtrans offset prev' input' =  {-# SCC "goNext.findTrans" #-} do           -- findTrans part 0           -- MAGIC TUNABLE CONSTANT 100 (and 100-1). TODO: (offset .&. 127 == 127) instead?@@ -231,7 +247,8 @@                     challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.findTrans.challenge" #-} do                       check <- comp offset x1 (newPos ins1) x2 (newPos ins2)                       if check==LT then return x2 else return x1-                (first:rest) <- mapM prep (IMap.toList sources)+                first_rest <- mapM prep (IMap.toList sources)+                let first:rest = first_rest                 set which destIndex =<< foldM challenge first rest           let dl = IMap.toList dtrans           mapM_ findTransTo dl@@ -253,9 +270,10 @@ -- A non-empty winner from the startState might obscure a potential -- empty winner (form the startState at the current offset).  This -- winEmpty possibility is also checked for. (unit test pattern ".*")--- (futher test "(.+|.+.)*" on "aa\n")+-- (further test "(.+|.+.)*" on "aa\n")          {-# INLINE processWinner #-}+        processWinner :: MScratch s -> IntMap Instructions -> Position -> ST s ()         processWinner s1 w offset = {-# SCC "goNext.newWinnerThenProceed" #-} do           let prep x@(sourceIndex,instructions) = {-# SCC "goNext.newWinnerThenProceed.prep" #-} do                 pos <- maybe (err "newWinnerThenProceed,1") return =<< m_pos s1 !! sourceIndex@@ -271,12 +289,14 @@             [] -> return ()             (first:rest) -> newWinner offset =<< foldM challenge first rest +        newWinner :: Position -> ((a, Instructions), STUArray s Tag Position, c) -> ST s ()         newWinner preTag ((_sourceIndex,winInstructions),oldPos,_newOrbit) = {-# SCC "goNext.newWinner" #-} do           newerPos <- newA_ b_tags           copySTU oldPos newerPos           doActions preTag newerPos (newPos winInstructions)           putMQ (WScratch newerPos) winQ +        finalizeWinner :: ST s [MatchArray]         finalizeWinner = do           mWinner <- readSTRef (mq_mWin winQ)           case mWinner of@@ -357,7 +377,7 @@ showWS :: WScratch s -> ST s String showWS (WScratch pos) = do   a <- getAssocs pos-  return $ unlines [ "WScratch" +  return $ unlines [ "WScratch"                    , indent (show a)] -} {- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -}@@ -382,7 +402,7 @@ newMScratch :: (Index,Index) -> S.ST s (MScratch s) newMScratch b_index = do   pos's <- newArray b_index Nothing-  orbit's <- newArray b_index mempty+  orbit's <- newArray b_index Mon.mempty   return (MScratch pos's orbit's)  {- COMPOSE A FUNCTION CLOSURE TO COMPARE TAG VALUES -}@@ -419,7 +439,7 @@    allcomps :: Tag -> [F s]   allcomps tag | tag > top = [F (\ _ _ _ _ _ _ -> return EQ)]-               | otherwise = +               | otherwise =     case aTagOP ! tag of       Orbit -> F (challenge_Orb tag) : allcomps (succ tag)       Maximize -> F (challenge_Max tag) : allcomps (succ tag)@@ -427,6 +447,15 @@       Minimize -> err "allcomps Minimize"    where top = snd (bounds aTagOP) +  challenge_Ignore+    :: Int+    -> [F s1]+    -> Position+    -> ((Int, Instructions), STUArray s1 Tag Position, IntMap Orbits)+    -> [(Int, Action)]+    -> ((Int, Instructions), STUArray s1 Tag Position, IntMap Orbits)+    -> [(Int, Action)]+    -> ST s1 Ordering   challenge_Ignore !tag (F next:comps) preTag x1 np1 x2 np2 =     case np1 of       ((t1,_):rest1) | t1==tag ->@@ -439,6 +468,15 @@           _ ->  next comps preTag x1 np1 x2 np2   challenge_Ignore _ [] _ _ _ _ _ = err "impossible 2347867" +  challenge_Max+    :: Int+    -> [F s1]+    -> Position+    -> ((Int, Instructions), STUArray s1 Tag Position, IntMap Orbits)+    -> [(Int, Action)]+    -> ((Int, Instructions), STUArray s1 Tag Position, IntMap Orbits)+    -> [(Int, Action)]+    -> ST s1 Ordering   challenge_Max !tag (F next:comps) preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 =     case np1 of       ((t1,b1):rest1) | t1==tag ->@@ -468,7 +506,16 @@               else return (compare p1 p2)   challenge_Max _ [] _ _ _ _ _ = err "impossible 9384324" -  challenge_Orb !tag (F next:comps) preTag x1@(_state1,_pos1,orbit1') np1 x2@(_state2,_pos2,orbit2') np2 = +  challenge_Orb+    :: Int+    -> [F s1]+    -> Position+    -> ((Int, Instructions), STUArray s1 Tag Position, IntMap Orbits)+    -> [(Int, Action)]+    -> ((Int, Instructions), STUArray s1 Tag Position, IntMap Orbits)+    -> [(Int, Action)]+    -> ST s1 Ordering+  challenge_Orb !tag (F next:comps) preTag x1@(_state1,_pos1,orbit1') np1 x2@(_state2,_pos2,orbit2') np2 =     let s1 = IMap.lookup tag orbit1'         s2 = IMap.lookup tag orbit2'     in case (s1,s2) of@@ -489,7 +536,7 @@ comparePos EmptyL EmptyL = EQ comparePos EmptyL _      = GT comparePos _      EmptyL = LT-comparePos (p1 :< ps1) (p2 :< ps2) = +comparePos (p1 :< ps1) (p2 :< ps2) =   compare p1 p2 `mappend` comparePos (viewl ps1) (viewl ps2)  {- CONVERT WINNERS TO MATCHARRAY -}@@ -556,8 +603,11 @@  -- #ifdef __GLASGOW_HASKELL__ foreign import ccall unsafe "memcpy"-    memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO ()+    memcpyIO :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO (Ptr a) +memcpyST :: MutableByteArray# s -> MutableByteArray# s -> Int# -> State# s -> (# State# s, Ptr a #)+memcpyST = unsafeCoerce# memcpyIO+ {- Prelude Data.Array.Base> :i STUArray data STUArray s i e@@ -567,16 +617,16 @@ -- This has been updated for ghc 6.8.3 and still works with ghc 6.10.1 {-# INLINE copySTU #-} copySTU :: (Show i,Ix i,MArray (STUArray s) e (S.ST s)) => STUArray s i e -> STUArray s i e -> S.ST s () -- (STUArray s i e)-copySTU _souce@(STUArray _ _ _ msource) _destination@(STUArray _ _ _ mdest) =+copySTU _source@(STUArray _ _ _ msource) _destination@(STUArray _ _ _ mdest) = -- do b1 <- getBounds s1 --  b2 <- getBounds s2 --  when (b1/=b2) (error ("\n\nWTF copySTU: "++show (b1,b2)))   ST $ \s1# ->-    case sizeofMutableByteArray# msource        of { n# ->-    case unsafeCoerce# memcpy mdest msource n# s1# of { (# s2#, () #) ->+    case getSizeofMutableByteArray# msource s1# of { (# s1'#, n# #) ->+    case memcpyST mdest msource n# s1'# of { (# s2#, _ #) ->     (# s2#, () #) }} {--#else /* !__GLASGOW_HASKELL__ */+-- #else /* !__GLASGOW_HASKELL__ */  copySTU :: (MArray (STUArray s) e (S.ST s))=> STUArray s Tag e -> STUArray s Tag e -> S.ST s (STUArray s i e) copySTU source destination = do@@ -587,5 +637,5 @@   forM_ (range b) $ \index ->     set destination index =<< source !! index   return destination-#endif /* !__GLASGOW_HASKELL__ */+-- #endif /* !__GLASGOW_HASKELL__ */ -}
lib/Text/Regex/TDFA/NewDFA/Engine_NC.hs view
@@ -18,6 +18,8 @@ import Data.Sequence(Seq) import qualified Data.ByteString.Char8 as SBS(ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL  import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) import qualified Text.Regex.TDFA.IntArrTrieSet as Trie(lookupAsc)@@ -44,6 +46,8 @@ {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-}+{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> T.Text -> [MatchArray] #-}+{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> TL.Text -> [MatchArray] #-} execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray] execMatch (Regex { regex_dfa = (DFA {d_id=didIn,d_dt=dtIn})                  , regex_init = startState@@ -52,7 +56,7 @@                  , regex_compOptions = CompOption { multiline = newline } } )           offsetIn prevIn inputIn = L.runST runCaptureGroup where -  !test = mkTest newline         +  !test = mkTest newline    runCaptureGroup = {-# SCC "runCaptureGroup" #-} do     obtainNext <- L.strictToLazyST constructNewEngine@@ -199,7 +203,7 @@     then writeSTRef earliest start >> writeSTRef list [ws]     else do       old <- readSTRef list-      let !rest = dropWhile (\ w -> start <= ws_start w) old +      let !rest = dropWhile (\ w -> start <= ws_start w) old           !new = ws : rest       writeSTRef list new
lib/Text/Regex/TDFA/NewDFA/Engine_NC_FA.hs view
@@ -16,6 +16,8 @@ import Data.Sequence(Seq) import qualified Data.ByteString.Char8 as SBS(ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL  import Text.Regex.Base(MatchArray,MatchOffset,MatchLength) import Text.Regex.TDFA.Common hiding (indent)@@ -31,6 +33,8 @@ {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-} {-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-}+{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> T.Text -> [MatchArray] #-}+{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> TL.Text -> [MatchArray] #-} execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray] execMatch (Regex { regex_dfa = DFA {d_dt=dtIn} })           offsetIn _prevIn inputIn = S.runST goNext where
lib/Text/Regex/TDFA/NewDFA/Tester.hs view
@@ -1,5 +1,5 @@ -- | Like Engine, but merely checks to see whether any match at all is found.--- +-- module Text.Regex.TDFA.NewDFA.Tester(matchTest) where  import qualified Data.IntMap.CharMap2 as CMap(findWithDefault)@@ -9,6 +9,8 @@ import Data.Sequence(Seq) import qualified Data.ByteString.Char8 as SBS(ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL  import Text.Regex.Base() import Text.Regex.TDFA.Common hiding (indent)@@ -19,6 +21,8 @@ {-# SPECIALIZE matchTest :: Regex -> (Seq Char) -> Bool #-} {-# SPECIALIZE matchTest :: Regex -> SBS.ByteString -> Bool #-} {-# SPECIALIZE matchTest :: Regex -> LBS.ByteString -> Bool #-}+{-# SPECIALIZE matchTest :: Regex -> T.Text -> Bool #-}+{-# SPECIALIZE matchTest :: Regex -> TL.Text -> Bool #-} matchTest :: Uncons text => Regex -> text -> Bool matchTest (Regex { regex_dfa = dfaIn                  , regex_isFrontAnchored = ifa } )
lib/Text/Regex/TDFA/NewDFA/Uncons.hs view
@@ -3,6 +3,8 @@ import qualified Data.ByteString.Char8 as SBS(ByteString,uncons) import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString,uncons) import Data.Sequence(Seq,viewl,ViewL(EmptyL,(:<)))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL  class Uncons a where   {- INLINE uncons #-}@@ -26,3 +28,13 @@ instance Uncons LBS.ByteString where   {- INLINE uncons #-}   uncons = LBS.uncons++-- | @since 1.3.1+instance Uncons T.Text where+  {- INLINE uncons #-}+  uncons = T.uncons++-- | @since 1.3.1+instance Uncons TL.Text where+  {- INLINE uncons #-}+  uncons = TL.uncons
lib/Text/Regex/TDFA/Pattern.hs view
@@ -1,6 +1,9 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+ -- | This "Text.Regex.TDFA.Pattern" module provides the 'Pattern' data -- type and its subtypes.  This 'Pattern' type is used to represent--- the parsed form of a Regular Expression.  +-- the parsed form of a regular expression.+ module Text.Regex.TDFA.Pattern     (Pattern(..)     ,PatternSet(..)@@ -9,52 +12,82 @@     ,PatternSetEquivalenceClass(..)     ,GroupIndex     ,DoPa(..)+    ,decodeCharacterClass, decodePatternSet     ,showPattern -- ** Internal use     ,starTrans--- ** Internal use, Operations to support debugging under ghci+-- ** Internal use, operations to support debugging under @ghci@     ,starTrans',simplify',dfsPattern     ) where  {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}  import Data.List(intersperse,partition)-import qualified Data.Set as Set(toAscList,toList)-import Data.Set(Set) -- XXX EnumSet+import qualified Data.Set as Set+import Data.Set (Set) import Text.Regex.TDFA.Common(DoPa(..),GroupIndex,common_error)  err :: String -> a err = common_error "Text.Regex.TDFA.Pattern" --- | Pattern is the type returned by the regular expression parser.--- This is consumed by the CorePattern module and the tender leaves--- are nibbled by the TNFA module.-data Pattern = PEmpty-             | PGroup  (Maybe GroupIndex) Pattern -- Nothing to indicate non-matching PGroup (Nothing never used!)-             | POr     [Pattern]                  -- flattened by starTrans-             | PConcat [Pattern]                  -- flattened by starTrans-             | PQuest  Pattern                    -- eliminated by starTrans-             | PPlus   Pattern                    -- eliminated by starTrans-             | PStar   Bool Pattern               -- True means mayFirstBeNull is True-             | PBound  Int (Maybe Int) Pattern    -- eliminated by starTrans-             -- The rest of these need an index of where in the regex string it is from-             | PCarat  {getDoPa::DoPa}-             | PDollar {getDoPa::DoPa}-             -- The following test and accept a single character-             | PDot    {getDoPa::DoPa}            -- Any character (newline?) at all-             | PAny    {getDoPa::DoPa,getPatternSet::PatternSet} -- Square bracketed things-             | PAnyNot {getDoPa::DoPa,getPatternSet::PatternSet} -- Inverted square bracketed things-             | PEscape {getDoPa::DoPa,getPatternChar::Char}      -- Backslashed Character-             | PChar   {getDoPa::DoPa,getPatternChar::Char}      -- Specific Character-             -- The following are semantic tags created in starTrans, not the parser-             | PNonCapture Pattern               -- introduced by starTrans-             | PNonEmpty Pattern                 -- introduced by starTrans-               deriving (Eq,Show)+-- | 'Pattern' is the type returned by the regular expression parser 'parseRegex'.+-- This is consumed by the "Text.Regex.TDFA.CorePattern" module and the tender leaves+-- are nibbled by the "Text.Regex.TDFA.TNFA" module.+--+-- The 'DoPa' field is the index of the component in the regex string @r@.+data Pattern+  = PEmpty+      -- ^ @()@, matches the empty string.+  | PGroup  (Maybe GroupIndex) Pattern+      -- ^ Group @(r)@.  @Nothing@ indicates non-matching 'PGroup'+      -- (never produced by parser 'parseRegex').+  | POr     [Pattern]+      -- ^ Alternative @r|s@ (flattened by 'starTrans').+  | PConcat [Pattern]+      -- ^ Sequence @rs@ (flattened by 'starTrans').+  | PQuest  Pattern+      -- ^ Zero or one repetitions @r?@ (eliminated by 'starTrans').+  | PPlus   Pattern+      -- ^ One or more repetitions @r+@ (eliminated by 'starTrans').+  | PStar   Bool Pattern+      -- ^ Zero or more repetitions @r*@.+      -- @True@ (default) means may accept the empty string on its first iteration.+  | PBound  Int (Maybe Int) Pattern+      -- ^ Given number or repetitions @r{n}@ or @r{n,m}@+      -- (eliminated by 'starTrans'). --- | I have not been checking, but this should have the property that--- parsing the resulting string should result in an identical Pattern.--- This is not true if starTrans has created PNonCapture and PNonEmpty--- values or a (PStar False).  The contents of a "[ ]" grouping are+  -- The rest of these need an index of where in the regex string it is from+  | PCarat  { getDoPa :: DoPa }+      -- ^ @^@ matches beginning of input.+  | PDollar { getDoPa :: DoPa }+      -- ^ @$@ matches end of input.++  -- The following test and accept a single character+  | PDot    { getDoPa :: DoPa }+      -- ^ @.@ matches any character.+  | PAny    { getDoPa :: DoPa, getPatternSet :: PatternSet }+      -- ^ Bracket expression @[...]@.+  | PAnyNot { getDoPa :: DoPa, getPatternSet :: PatternSet }+      -- ^ Inverted bracket expression @[^...]@.+  | PEscape { getDoPa :: DoPa, getPatternChar :: Char }+      -- ^ Backslashed character @\c@, may have special meaning.+  | PChar   { getDoPa :: DoPa, getPatternChar :: Char }+      -- ^ Single character, matches given character.++  -- The following are semantic tags created in starTrans, not the parser+  | PNonCapture Pattern+     -- ^ Tag for internal use, introduced by 'starTrans'.+  | PNonEmpty Pattern+     -- ^ Tag for internal use, introduced by 'starTrans'.+  deriving (Eq, Show)++-- Andreas Abel, 2022-07-18, issue #47:+-- The following claim is FALSE:+--+-- I have not been checking, but this should have the property that+-- parsing the resulting string should result in an identical 'Pattern'.+-- This is not true if 'starTrans' has created 'PNonCapture' and 'PNonEmpty'+-- values or a @'PStar' False@.  The contents of a @[...]@ grouping are -- always shown in a sorted canonical order. showPattern :: Pattern -> String showPattern pIn =@@ -88,13 +121,20 @@                             else x:'-':(toEnum (pred n+fromEnum x)):[] -}         paren s = ('(':s)++")"-       ++-- | Content of a bracket expression @[...]@ organized into+-- characters,+-- POSIX character classes (e.g. @[[:alnum:]]@),+-- collating elements (e.g. @[.ch.]@, unused), and+-- equivalence classes (e.g. @[=a=]@, treated as characters).+-- data PatternSet = PatternSet (Maybe (Set Char))                              (Maybe (Set PatternSetCharacterClass))                              (Maybe (Set PatternSetCollatingElement))                              (Maybe (Set PatternSetEquivalenceClass))                              deriving (Eq) +-- | Hand-rolled implementation, giving textual rather than Haskell representation. instance Show PatternSet where   showsPrec i (PatternSet s scc sce sec) =     let (special,normal) = maybe ("","") ((partition (`elem` "]-")) . Set.toAscList) s@@ -105,44 +145,88 @@     in shows charSpec        . showsPrec i scc' . showsPrec i sce' . showsPrec i sec'        . if '-' `elem` special then showChar '-' else id-    where byRange xAll@(x:xs) | length xAll <=3 = xAll-                              | otherwise = groupRange x 1 xs-          byRange _ = undefined+    where byRange xAll@(~(x:xs))+            | length xAll <=3 = xAll+            | otherwise       = groupRange x 1 xs           groupRange x n (y:ys) = if (fromEnum y)-(fromEnum x) == n then groupRange x (succ n) ys                                   else (if n <=3 then take n [x..]                                         else x:'-':(toEnum (pred n+fromEnum x)):[]) ++ groupRange y 1 ys           groupRange x n [] = if n <=3 then take n [x..]                               else x:'-':(toEnum (pred n+fromEnum x)):[] +-- | Content of @[: :]@, e.g. @"alnum"@ for @[:alnum:]@. newtype PatternSetCharacterClass   = PatternSetCharacterClass   {unSCC::String}   deriving (Eq,Ord)++-- | Content of @[. .]@, e.g. @"ch"@ for @[.ch.]@. newtype PatternSetCollatingElement = PatternSetCollatingElement {unSCE::String}   deriving (Eq,Ord)++-- | Content of @[= =]@, e.g. @"a"@ for @[=a=]@. newtype PatternSetEquivalenceClass = PatternSetEquivalenceClass {unSEC::String}   deriving (Eq,Ord) +-- | Hand-rolled implementation, giving textual rather than Haskell representation. instance Show PatternSetCharacterClass where   showsPrec _ p = showChar '[' . showChar ':' . shows (unSCC p) . showChar ':' . showChar ']'++-- | Hand-rolled implementation, giving textual rather than Haskell representation. instance Show PatternSetCollatingElement where   showsPrec _ p = showChar '[' . showChar '.' . shows (unSCE p) . showChar '.' . showChar ']'++-- | Hand-rolled implementation, giving textual rather than Haskell representation. instance Show PatternSetEquivalenceClass where   showsPrec _ p = showChar '[' . showChar '=' . shows (unSEC p) . showChar '=' . showChar ']' --- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- | @decodePatternSet@ cannot handle collating element and treats+-- equivalence classes as just their definition and nothing more.+--+-- @since 1.3.2+decodePatternSet :: PatternSet -> Set Char+decodePatternSet (PatternSet msc mscc _ msec) =+  let baseMSC = maybe Set.empty id msc+      withMSCC = foldl (flip Set.insert) baseMSC  (maybe [] (concatMap decodeCharacterClass . Set.toAscList) mscc)+      withMSEC = foldl (flip Set.insert) withMSCC (maybe [] (concatMap unSEC . Set.toAscList) msec)+  in withMSEC +-- | This returns the strictly ascending list of characters+-- represented by @[: :]@ POSIX character classes.+-- Unrecognized class names return an empty string.+--+-- @since 1.3.2+decodeCharacterClass :: PatternSetCharacterClass -> String+decodeCharacterClass (PatternSetCharacterClass s) =+  case s of+    "alnum"  -> ['0'..'9']++['A'..'Z']++['a'..'z']+    "digit"  -> ['0'..'9']+    "punct"  -> ['\33'..'\47']++['\58'..'\64']++['\91'..'\96']++['\123'..'\126']+    "alpha"  -> ['A'..'Z']++['a'..'z']+    "graph"  -> ['\33'..'\126']+    "space"  -> "\t\n\v\f\r "+    "blank"  -> "\t "+    "lower"  -> ['a'..'z']+    "upper"  -> ['A'..'Z']+    "cntrl"  -> ['\0'..'\31']++"\127" -- with NUL+    "print"  -> ['\32'..'\126']+    "xdigit" -> ['0'..'9']++['A'..'F']++['a'..'f']+    "word"   -> ['0'..'9']++['A'..'Z']++"_"++['a'..'z']+    _ -> []++-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- ==+ -- | Do the transformation and simplification in a single traversal.--- This removes the PPlus, PQuest, and PBound values, changing to POr--- and PEmpty and PStar True\/False.  For some PBound values it adds--- PNonEmpty and PNonCapture semantic marker.  It also simplifies to--- flatten out nested POr and PConcat instances and eliminate some--- unneeded PEmpty values.+-- This removes the 'PPlus', 'PQuest', and 'PBound' values, changing to 'POr'+-- and 'PEmpty' and 'PStar'.  For some 'PBound' values it adds+-- 'PNonEmpty' and 'PNonCapture' semantic marker.  It also simplifies to+-- flatten out nested 'POr' and 'PConcat' instances and eliminate some+-- unneeded 'PEmpty' values. starTrans :: Pattern -> Pattern starTrans = dfsPattern (simplify' . starTrans') --- | Apply a Pattern transfomation function depth first-dfsPattern :: (Pattern -> Pattern)  -- ^ The transformation function-           -> Pattern               -- ^ The Pattern to transform-           -> Pattern               -- ^ The transformed Pattern+-- | Apply a 'Pattern' transformation function depth first.+dfsPattern :: (Pattern -> Pattern)  -- ^ The transformation function.+           -> Pattern               -- ^ The 'Pattern' to transform.+           -> Pattern               -- ^ The transformed 'Pattern'. dfsPattern f = dfs  where unary c = f . c . dfs        dfs pattern = case pattern of@@ -200,7 +284,7 @@    simplicity, only use ! when p can match 0 characters but not only 0    characters. -   Call this (PNonEmpty p) in the Pattern type. +   Call this (PNonEmpty p) in the Pattern type.    p! is PNonEmpty p is POr [PEmpty,p]    IS THIS TRUE?  Use QuickCheck? @@ -225,8 +309,8 @@    if p can match 0 or non-zero characters then cases are    p{0,0} is (), p{0,1} is (p)?, p{0,2} is (pp!)?, p{0,3} is (pp!p!)?    p{1,1} is p, p{1,2} is pp!, p{1,3} is pp!p!, p{1,4} is pp!p!p!-   p{2,2} is p'p, -   p{2,3} is p'pp!, +   p{2,2} is p'p,+   p{2,3} is p'pp!,    p{2,4} is p'pp!p! or p'p(pp!)!    p{2,5} is p'pp!p!p! or p'p(p(pp!)!)!    p{3,3} is p'p'p, p{3,4} is p'p'pp!, p{3,5} is p'p'pp!p!, p{3,6} is p'p'pp!p!p!@@ -236,7 +320,7 @@    p{0,1} is p?, p{0,2} is (pp?)?, p{0,3} is (p(pp?)?)?, p{0,4} is (pp{0,3})?    p{1,1} is p, p{1,j} is pp{0,pred j}    p{2,2} is p'p, p{2,3} is p'pp?, p{2,4} is p'p(pp?)?, p{2,5} = p'p{1,4} = p'(pp{0,3})-   p{3,3} is p'p'p, p{3,4} is p'p'pp?, p{3,5} is p'p'p(pp?)?, p{3,6} is +   p{3,3} is p'p'p, p{3,4} is p'p'pp?, p{3,5} is p'p'p(pp?)?, p{3,6} is     And by this logic, the PStar False is really p*!  So p{0,} is p*    and p{1,} is pp*! and p{2,} is p'pp*! and p{3,} is p'p'pp*!@@ -320,10 +404,10 @@     pass = pIn  -- | Function to transform a pattern into an equivalent, but less--- redundant form.  Nested 'POr' and 'PConcat' are flattened. PEmpty+-- redundant form.  Nested 'POr' and 'PConcat' are flattened. 'PEmpty' -- is propagated. simplify' :: Pattern -> Pattern-simplify' x@(POr _) = +simplify' x@(POr _) =   let ps' = case span notPEmpty (flatten x) of               (notEmpty,[]) -> notEmpty               (notEmpty,_:rest) -> notEmpty ++ (PEmpty:filter notPEmpty rest) -- keep 1st PEmpty only@@ -342,7 +426,7 @@ --simplify' (PNonEmpty PEmpty) = err "simplify' (PNonEmpty PEmpty) = should be Impossible!" -- 2009 simplify' other = other --- | Function to flatten nested POr or nested PConcat applicataions.+-- | Function to flatten nested 'POr' or nested 'PConcat' applicataions. flatten :: Pattern -> [Pattern] flatten (POr ps) = (concatMap (\x -> case x of                                        POr ps' -> ps'@@ -356,8 +440,8 @@ notPEmpty PEmpty = False notPEmpty _      = True --- | Determines if pIn will fail or accept [] and never accept any--- characters. Treat PCarat and PDollar as True.+-- | Determines if 'Pattern' will fail or accept @[]@ and never accept any+-- characters. Treat 'PCarat' and 'PDollar' as @True@. canOnlyMatchNull :: Pattern -> Bool canOnlyMatchNull pIn =   case pIn of
lib/Text/Regex/TDFA/ReadRegex.hs view
@@ -1,24 +1,32 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -- | This is a POSIX version of parseRegex that allows NUL characters. -- Lazy\/Possessive\/Backrefs are not recognized.  Anchors \^ and \$ are -- recognized. ----- The PGroup returned always have (Maybe GroupIndex) set to (Just _)--- and never to Nothing.+-- A 'PGroup' returned always has @(Maybe 'GroupIndex')@ set to @(Just _)@+-- and never to @Nothing@.+ module Text.Regex.TDFA.ReadRegex (parseRegex) where  {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}  import Text.Regex.TDFA.Pattern {- all -} import Text.ParserCombinators.Parsec((<|>), (<?>),-  unexpected, try, runParser, many, getState, setState, CharParser, ParseError,+  try, runParser, many, getState, setState, CharParser, ParseError,   sepBy1, option, notFollowedBy, many1, lookAhead, eof, between,   string, noneOf, digit, char, anyChar)-import Control.Monad(liftM, when, guard)++import Control.Monad (liftM, guard)++import Data.Foldable (asum) import qualified Data.Set as Set(fromList) --- | BracketElement is internal to this module-data BracketElement = BEChar Char | BEChars String | BEColl String | BEEquiv String | BEClass String+-- | An element inside @[...]@, denoting a character class.+data BracketElement+  = BEChar  Char       -- ^ A single character.+  | BERange Char Char  -- ^ A character range (e.g. @a-z@).+  | BEColl  String     -- ^ @foo@ in @[.foo.]@.+  | BEEquiv String     -- ^ @bar@ in @[=bar=]@.+  | BEClass String     -- ^ A POSIX character class (candidate), e.g. @alpha@ parsed from @[:alpha:]@.  -- | Return either an error message or a tuple of the Pattern and the -- largest group index and the largest DoPa index (both have smallest@@ -30,40 +38,49 @@                              (lastGroupIndex,lastDopa) <- getState                              return (pat,(lastGroupIndex,DoPa lastDopa))) (0,0) x x -p_regex :: CharParser (GroupIndex,Int) Pattern+type P = CharParser (GroupIndex, Int)++p_regex :: P Pattern p_regex = liftM POr $ sepBy1 p_branch (char '|') --- man re_format helps alot, it says one-or-more pieces so this is+-- man re_format helps a lot, it says one-or-more pieces so this is -- many1 not many.  Use "()" to indicate an empty piece.+p_branch :: P Pattern p_branch = liftM PConcat $ many1 p_piece +p_piece :: P Pattern p_piece = (p_anchor <|> p_atom) >>= p_post_atom -- correct specification +p_atom :: P Pattern p_atom =  p_group <|> p_bracket <|> p_char <?> "an atom" -group_index :: CharParser (GroupIndex,Int) (Maybe GroupIndex)+group_index :: P (Maybe GroupIndex) group_index = do   (gi,ci) <- getState   let index = succ gi   setState (index,ci)   return (Just index) +p_group :: P Pattern p_group = lookAhead (char '(') >> do   index <- group_index   liftM (PGroup index) $ between (char '(') (char ')') p_regex  -- p_post_atom takes the previous atom as a parameter+p_post_atom :: Pattern -> P Pattern p_post_atom atom = (char '?' >> return (PQuest atom))                <|> (char '+' >> return (PPlus atom))                <|> (char '*' >> return (PStar True atom))-               <|> p_bound atom +               <|> p_bound atom                <|> return atom +p_bound :: Pattern -> P Pattern p_bound atom = try $ between (char '{') (char '}') (p_bound_spec atom) +p_bound_spec :: Pattern -> P Pattern p_bound_spec atom = do lowS <- many1 digit                        let lowI = read lowS-                       highMI <- option (Just lowI) $ try $ do +                       highMI <- option (Just lowI) $ try $ do                                    _ <- char ','   -- parsec note: if 'many digits' fails below then the 'try' ensures   -- that the ',' will not match the closing '}' in p_bound, same goes@@ -76,36 +93,41 @@                        return (PBound lowI highMI atom)  -- An anchor cannot be modified by a repetition specifier+p_anchor :: P Pattern p_anchor = (char '^' >> liftM PCarat char_index)        <|> (char '$' >> liftM PDollar char_index)-       <|> try (do _ <- string "()" +       <|> try (do _ <- string "()"                    index <- group_index-                   return $ PGroup index PEmpty) +                   return $ PGroup index PEmpty)        <?> "empty () or anchor ^ or $" +char_index :: P DoPa char_index = do (gi,ci) <- getState                 let ci' = succ ci                 setState (gi,ci')                 return (DoPa ci') +p_char :: P Pattern p_char = p_dot <|> p_left_brace <|> p_escaped <|> p_other_char where   p_dot = char '.' >> char_index >>= return . PDot   p_left_brace = try $ (char '{' >> notFollowedBy digit >> char_index >>= return . (`PChar` '{'))   p_escaped = char '\\' >> anyChar >>= \c -> char_index >>= return . (`PEscape` c)-  p_other_char = noneOf specials >>= \c -> char_index >>= return . (`PChar` c) +  p_other_char = noneOf specials >>= \c -> char_index >>= return . (`PChar` c)     where specials  = "^.[$()|*+?{\\"  -- parse [bar] and [^bar] sets of characters+p_bracket :: P Pattern p_bracket = (char '[') >> ( (char '^' >> p_set True) <|> (p_set False) ) --- p_set :: Bool -> GenParser Char st Pattern-p_set invert = do initial <- (option "" ((char ']' >> return "]") <|> (char '-' >> return "-")))+p_set :: Bool -> P Pattern+p_set invert = do initial <- option "" (char ']' >> return "]")                   values <- if null initial then many1 p_set_elem else many p_set_elem                   _ <- char ']'                   ci <- char_index-                  let chars = maybe'set $ initial-                                          ++ [c | BEChar c <- values ]-                                          ++ concat [s | BEChars s <- values ]+                  let chars = maybe'set $ concat $+                        initial :+                        [ c | BEChar c <- values ] :+                        [ [start..end] | BERange start end <- values ]                       colls = maybe'set [PatternSetCollatingElement coll | BEColl coll <- values ]                       equivs = maybe'set [PatternSetEquivalenceClass equiv | BEEquiv equiv <- values]                       class's = maybe'set [PatternSetCharacterClass a'class | BEClass a'class <- values]@@ -115,31 +137,57 @@  -- From here down the code is the parser and functions for pattern [ ] set things -p_set_elem = p_set_elem_class <|> p_set_elem_equiv <|> p_set_elem_coll-         <|> p_set_elem_range <|> p_set_elem_char <?> "Failed to parse bracketed string"+p_set_elem :: P BracketElement+p_set_elem = checkBracketElement =<< asum+  [ p_set_elem_class+  , p_set_elem_equiv+  , p_set_elem_coll+  , p_set_elem_range+  , p_set_elem_char+  , fail "Failed to parse bracketed string"+  ] +p_set_elem_class :: P BracketElement p_set_elem_class = liftM BEClass $   try (between (string "[:") (string ":]") (many1 $ noneOf ":]")) +p_set_elem_equiv :: P BracketElement p_set_elem_equiv = liftM BEEquiv $   try (between (string "[=") (string "=]") (many1 $ noneOf "=]")) +p_set_elem_coll :: P BracketElement p_set_elem_coll =  liftM BEColl $   try (between (string "[.") (string ".]") (many1 $ noneOf ".]")) -p_set_elem_range = try $ do -  start <- noneOf "]-"+p_set_elem_range :: P BracketElement+p_set_elem_range = try $ do+  start <- noneOf "]"   _  <- char '-'   end <- noneOf "]"-  -- bug fix: check start <= end before "return (BEChars [start..end])"-  if start <= end-    then return (BEChars [start..end])-    else unexpected "End point of dashed character range is less than starting point"+  return $ BERange start end -p_set_elem_char = do +p_set_elem_char :: P BracketElement+p_set_elem_char = do   c <- noneOf "]"-  when (c == '-') $ do-    atEnd <- (lookAhead (char ']') >> return True) <|> (return False)-    when (not atEnd) (unexpected "A dash is in the wrong place in a bracket")   return (BEChar c) +-- | Fail when 'BracketElement' is invalid, e.g. empty range @1-0@.+-- This failure should not be caught.+--+checkBracketElement :: BracketElement -> P BracketElement+checkBracketElement e =+  case e of+    BERange start end+      | start > end -> fail $ unwords+          [ "End point"+          , show end+          , "of dashed character range is less than starting point"+          , show start+          ]+      | otherwise -> ok+    BEChar  _ -> ok+    BEClass _ -> ok+    BEColl  _ -> ok+    BEEquiv _ -> ok+  where+    ok = return e
lib/Text/Regex/TDFA/Sequence.hs view
@@ -61,25 +61,23 @@  compile :: CompOption -- ^ Flags (summed together)         -> ExecOption -- ^ Flags (summed together)-        -> (Seq Char) -- ^ The regular expression to compile+        -> Seq Char   -- ^ The regular expression to compile         -> Either String Regex -- ^ Returns: the compiled regular expression compile compOpt execOpt bs =   case parseRegex (F.toList bs) of     Left err -> Left ("parseRegex for Text.Regex.TDFA.Sequence failed:"++show err)     Right pattern -> Right (patternToRegex pattern compOpt execOpt) -execute :: Regex      -- ^ Compiled regular expression-        -> (Seq Char) -- ^ ByteString to match against+execute :: Regex    -- ^ Compiled regular expression+        -> Seq Char -- ^ String to match against         -> Either String (Maybe MatchArray) execute r bs = Right (matchOnce r bs) -regexec :: Regex      -- ^ Compiled regular expression-        -> (Seq Char) -- ^ ByteString to match against-        -> Either String (Maybe ((Seq Char), (Seq Char), (Seq Char), [(Seq Char)]))-regexec r bs =-  case matchOnceText r bs of-    Nothing -> Right (Nothing)-    Just (pre,mt,post) ->-      let main = fst (mt!0)-          rest = map fst (tail (elems mt)) -- will be []-      in Right (Just (pre,main,post,rest))+regexec :: Regex    -- ^ Compiled regular expression+        -> Seq Char -- ^ String to match against+        -> Either String (Maybe (Seq Char, Seq Char, Seq Char, [Seq Char]))+regexec r txt = Right $+  case matchOnceText r txt of+    Just (pre, mt, post) | main:rest <- map fst (elems mt)+      -> Just (pre, main, post, rest)+    _ -> Nothing
lib/Text/Regex/TDFA/String.hs view
@@ -1,4 +1,4 @@-{- | +{- | This modules provides 'RegexMaker' and 'RegexLike' instances for using 'String' with the TDFA backend. @@ -58,15 +58,13 @@ regexec :: Regex      -- ^ Compiled regular expression         -> String     -- ^ String to match against         -> Either String (Maybe (String, String, String, [String]))-regexec r s =-  case matchOnceText r s of-    Nothing -> Right Nothing-    Just (pre,mt,post) ->-      let main = fst (mt!0)-          rest = map fst (tail (elems mt)) -- will be []-      in Right (Just (pre,main,post,rest))+regexec r txt = Right $+  case matchOnceText r txt of+    Just (pre, mt, post) | main:rest <- map fst (elems mt)+      -> Just (pre, main, post, rest)+    _ -> Nothing --- Minimal defintion for now+-- Minimal definition for now instance RegexLike Regex String where   matchOnce r s = listToMaybe (matchAll r s)   matchAll r s = execMatch r 0 '\n' s
lib/Text/Regex/TDFA/TDFA.hs view
@@ -1,12 +1,12 @@ -- | "Text.Regex.TDFA.TDFA" converts the QNFA from TNFA into the DFA.--- A DFA state corresponds to a Set of QNFA states, repesented as list+-- A DFA state corresponds to a Set of QNFA states, represented as list -- of Index which are used to lookup the DFA state in a lazy Trie -- which holds all possible subsets of QNFA states. module Text.Regex.TDFA.TDFA(patternToRegex,DFA(..),DT(..)                             ,examineDFA,nfaToDFA,dfaMap) where  --import Control.Arrow((***))-import Data.Monoid(Monoid(..))+import Data.Monoid as Mon(Monoid(..)) import Control.Monad.State(State,MonadState(..),execState) import Data.Array.IArray(Array,(!),bounds,{-assocs-}) import Data.IntMap(IntMap)@@ -18,7 +18,7 @@ import qualified Data.IntMap.CharMap2 as Map(empty) --import Data.IntSet(IntSet) import qualified Data.IntSet as ISet(empty,singleton,null)-import Data.List(foldl')+import qualified Data.List as List import qualified Data.Map (Map,empty,member,insert,elems) import Data.Sequence as S((|>),{-viewl,ViewL(..)-}) @@ -138,7 +138,7 @@                    -> [(IMap.Key, Transition)]               fuse [] y = fmap (fmap (mergeDTrans o1)) y               fuse x [] = fmap (fmap (mergeDTrans o2)) x-              fuse x@((xc,xa):xs) y@((yc,ya):ys) = +              fuse x@((xc,xa):xs) y@((yc,ya):ys) =                 case compare xc yc of                   LT -> (xc,mergeDTrans o2 xa) : fuse xs y                   EQ -> (xc,mergeDTrans xa ya) : fuse xs ys@@ -165,7 +165,7 @@     if i `Data.Map.member` old       then old       else let new = Data.Map.insert i d old-           in foldl' seen new (flattenDT dt)+           in List.foldl' seen new (flattenDT dt)  -- Get all trans_many states flattenDT :: DT -> [DFA]@@ -211,7 +211,7 @@ -- is free to mutatate the old state.  If the QTrans has only one -- entry then all we need to do is mutate that entry when making a -- transition.--- +-- pickQTrans :: Array Tag OP -> QTrans -> [({-Destination-}Index,(DoPa,Instructions))] pickQTrans op tr = mapSnd (bestTrans op) . IMap.toList $ tr @@ -223,7 +223,7 @@ bestTrans aTagOP (f:fs) | null fs = canonical f                         | otherwise = answer -- if null toDisplay then answer else trace toDisplay answer  where-  answer = foldl' pick (canonical f) fs+  answer = List.foldl' pick (canonical f) fs   {- toDisplay | null fs = ""                | otherwise = unlines $ "bestTrans" : show (answer) : "from among" : concatMap (\x -> [show x, show (toInstructions (snd x))]) (f:fs) -}   canonical :: TagCommand -> (DoPa,Instructions)@@ -246,7 +246,7 @@    mergeTagOrbit xx [] = xx   mergeTagOrbit [] yy = yy-  mergeTagOrbit xx@(x:xs) yy@(y:ys) = +  mergeTagOrbit xx@(x:xs) yy@(y:ys) =     case compare (fst x) (fst y) of       GT -> y : mergeTagOrbit xx ys       LT -> x : mergeTagOrbit xs yy@@ -264,14 +264,14 @@                     -- this needs a leading Minimize tag inside at least the parent * operator       Ignore -> GT -- XXX this is a guess in analogy with Maximize for the end bit of a group       Orbit -> LT -- trace ("choose LT! Just "++show tag++" < Nothing") LT -- 2009 XXX : comment out next line and use the Orbit instead---      Orbit -> err $ "bestTrans.choose : Very Unexpeted Orbit in Just Nothing: "++show (tag,post,aTagOP,f:fs)+--      Orbit -> err $ "bestTrans.choose : Very Unexpected Orbit in Just Nothing: "++show (tag,post,aTagOP,f:fs)   choose (Just (tag,post1)) (Just (_,post2)) =     case aTagOP!tag of       Maximize -> order       Minimize -> flipOrder order       Ignore -> EQ       Orbit -> EQ---      Orbit -> err $ "bestTrans.choose : Very Unexpeted Orbit in Just Just: "++show (tag,(post1,post2),aTagOP,f:fs)+--      Orbit -> err $ "bestTrans.choose : Very Unexpected Orbit in Just Just: "++show (tag,(post1,post2),aTagOP,f:fs)    where order = case (post1,post2) of                    (SetPre,SetPre) -> EQ                    (SetPost,SetPost) -> EQ@@ -293,7 +293,7 @@     cw xx [] = foldr (\x rest -> comp (Just x) Nothing  `mappend` rest) mempty xx     cw [] yy = foldr (\y rest -> comp Nothing  (Just y) `mappend` rest) mempty yy -                   + isDFAFrontAnchored :: DFA -> Bool isDFAFrontAnchored = isDTFrontAnchored . d_dt  where@@ -424,7 +424,7 @@   newOrbit pos = Orbits { inOrbit = inOrbit'                         , basePos = pos                         , ordinal = Nothing-                        , getOrbits = mempty}+                        , getOrbits = Mon.mempty}   updateOrbit pos _tag new old | inOrbit old = old { inOrbit = inOrbit'                                                    , getOrbits = getOrbits old |> pos }                                | otherwise = new
lib/Text/Regex/TDFA/TNFA.hs view
@@ -7,11 +7,11 @@ -- (That will require re-organizing the continuation data a bit)  -- | "Text.Regex.TDFA.TNFA" converts the CorePattern Q\/P data (and its--- Pattern leafs) to a QNFA tagged non-deterministic finite automata.--- +-- Pattern leaves) to a QNFA tagged non-deterministic finite automata.+-- -- This holds every possible way to follow one state by another, while -- in the DFA these will be reduced by picking a single best--- transition for each (soure,destination) pair.  The transitions are+-- transition for each (source,destination) pair.  The transitions are -- heavily and often redundantly annotated with tasks to perform, and -- this redundancy is reduced when picking the best transition.  So -- far, keeping all this information has helped fix bugs in both the@@ -19,18 +19,20 @@ -- -- The QNFA for a Pattern with a starTraned Q\/P form with N one -- character accepting leaves has at most N+1 nodes.  These nodes--- repesent the future choices after accepting a leaf.  The processing+-- represent the future choices after accepting a leaf.  The processing -- of Or nodes often reduces this number by sharing at the end of the -- different paths.  Turning off capturing while compiling the pattern -- may (future extension) reduce this further for some patterns by -- processing Star with optimizations.  This compact design also means -- that tags are assigned not just to be updated before taking a -- transition (PreUpdate) but also after the transition (PostUpdate).--- +-- -- Uses recursive do notation. -module Text.Regex.TDFA.TNFA(patternToNFA-                            ,QNFA(..),QT(..),QTrans,TagUpdate(..)) where+module Text.Regex.TDFA.TNFA+  ( patternToNFA+  , QNFA(..), QT(..), QTrans, TagUpdate(..)+  ) where  {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} @@ -38,7 +40,7 @@ import Control.Monad.State(State,runState,execState,get,put,modify) import Data.Array.IArray(Array,array) import Data.Char(toLower,toUpper,isAlpha,ord)-import Data.List(foldl')+import qualified Data.List as List import Data.IntMap (IntMap) import qualified Data.IntMap as IMap(toAscList,null,unionWith,singleton,fromList,fromDistinctAscList) import Data.IntMap.CharMap2(CharMap(..))@@ -47,8 +49,8 @@ import Data.IntSet.EnumSet2(EnumSet) import qualified Data.IntSet.EnumSet2 as Set(singleton,toList,insert) import Data.Maybe(catMaybes,isNothing)-import Data.Monoid(mempty,mappend)-import qualified Data.Set as S(Set,insert,toAscList,empty)+import Data.Monoid as Mon(Monoid(..))+import qualified Data.Set as S (insert, toAscList)  import Text.Regex.TDFA.Common(QT(..),QNFA(..),QTrans,TagTask(..),TagUpdate(..),DoPa(..)                              ,CompOption(..)@@ -57,8 +59,7 @@ import Text.Regex.TDFA.CorePattern(Q(..),P(..),OP(..),WhichTest,cleanNullView,NullView                                   ,SetTestInfo(..),Wanted(..),TestInfo                                   ,mustAccept,cannotAccept,patternToQ)-import Text.Regex.TDFA.Pattern(Pattern(..),PatternSet(..),unSEC,PatternSetCharacterClass(..))---import Debug.Trace+import Text.Regex.TDFA.Pattern (Pattern(..), decodePatternSet)  ecart :: String -> a -> a ecart _ = id@@ -71,7 +72,7 @@  qtwin,qtlose :: QT -- qtwin is the continuation after matching the whole pattern.  It has--- no futher transitions and sets tag #1 to the current position.+-- no further transitions and sets tag #1 to the current position. qtwin = Simple {qt_win=[(1,PreUpdate TagTask)],qt_trans=mempty,qt_other=mempty} -- qtlose is the continuation to nothing, used when ^ or $ tests fail. qtlose = Simple {qt_win=mempty,qt_trans=mempty,qt_other=mempty}@@ -86,7 +87,7 @@       msg = unlines [ show q ]   in debug msg (qToNFA compOpt q,tags,groups) --- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- Query function on Q  nullable :: Q -> Bool@@ -105,7 +106,7 @@ usesQNFA (Q {wants=WantsQNFA}) = True usesQNFA _ = False --- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- Functions related to QT  -- dumb smart constructor used by qToQNFA@@ -138,7 +139,7 @@ -- processing Or. applyNullViews :: NullView -> QT -> QT applyNullViews [] win = win-applyNullViews nvs win = foldl' (dominate win) qtlose (reverse $ cleanNullView nvs) where+applyNullViews nvs win = List.foldl' (dominate win) qtlose (reverse $ cleanNullView nvs)  -- This is used to prefer to view "win" through NullView.  Losing is -- replaced by the plain win.  This is employed by Star patterns to@@ -146,9 +147,9 @@ -- skipping the NullView occurs if the match fails. preferNullViews :: NullView -> QT -> QT preferNullViews [] win = win-preferNullViews nvs win = foldl' (dominate win) win (reverse $ cleanNullView nvs) where+preferNullViews nvs win = List.foldl' (dominate win) win (reverse $ cleanNullView nvs) -{- +{- dominate is common to applyNullViews and preferNullViews above.  Even I no longer understand it without study.@@ -171,7 +172,7 @@ dominate win lose x@(SetTestInfo sti,tags) = debug ("dominate "++show x) $   let -- The winning states are reached through the SetTag       win' = prependTags' tags win-      -- get the SetTestInfo +      -- get the SetTestInfo       winTests = listTestInfo win $ mempty       allTests = (listTestInfo lose $ winTests) `mappend` (EMap.keysSet sti)       -- The first and second arguments of useTest are sorted@@ -204,7 +205,7 @@   applyTest' q@(Simple {}) =     mkTesting $ Testing {qt_test = wt                         ,qt_dopas = Set.singleton dopa-                        ,qt_a = q +                        ,qt_a = q                         ,qt_b = qtlose}   applyTest' q@(Testing {qt_test=wt'}) =     case compare wt wt' of@@ -221,7 +222,7 @@ -- are handled. -- -- mergeQT_2nd is used by the NonEmpty case and always discards the--- first argument's win and uses the second argment's win.+-- first argument's win and uses the second argument's win. -- -- mergeAltQT is used by the Or cases and is biased to the first -- argument's winning transition, if present.@@ -238,7 +239,7 @@               | nullQT q2 = q1  -- union wins               | otherwise = mergeQTWith mappend q1 q2 -- no preference, win with combined SetTag XXX is the wrong thing! "(.?)*" --- This takes a function which implements a policy on mergining+-- This takes a function which implements a policy on merging -- winning transitions and then merges all the transitions.  It opens -- the CharMap newtype for more efficient operation, then rewraps it. mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT@@ -302,7 +303,7 @@          , qt_other = prependQTrans o }   where prependQTrans = fmap (map (\(d,tcs) -> (d,tcs' `mappend` tcs))) --- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- define type S which is a State monad, this allows the creation of the uniq QNFA ids and storing the QNFA -- in an ascending order difference list for later placement in an array. @@ -330,7 +331,7 @@   put $! (futureI, oldQs . ((thisI,qnfa):))   return qnfa --- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- E related functions  fromQNFA :: QNFA -> E@@ -408,7 +409,7 @@ getE (eLoop,Just accepting,_) = fromQT (mergeQT (getQT eLoop) (getQT accepting)) getE (eLoop,Nothing,_) = eLoop --- 2009: See coment for addTest.  Here is a case where the third component might be a (Just qnfa) and it+-- 2009: See comment for addTest.  Here is a case where the third component might be a (Just qnfa) and it -- is being lost even though the added test might be redundant. addTestAC :: TestInfo -> ActCont -> ActCont addTestAC ti (e,mE,_) = (addTest ti e@@ -439,7 +440,7 @@ addWinTagsAC wtags (e,mE,mQNFA) = (addWinTags wtags e                                   ,fmap (addWinTags wtags) mE                                   ,fmap (addWinTags wtags) mQNFA)--- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- ==  -- Initial preTag of 0th tag is implied. No other general pre-tags would be expected. -- The qtwin contains the preTag of the 1st tag and is only set when a match is completed.@@ -530,7 +531,7 @@                                                                  | otherwise =     debug (">< inStar/2 "++show qIn++" <>") $     return . fmap (prependGroupResets resets . prependPreTag pre) =<< inStarNullableTagless qIn (addTag post . addGroupSets sets $ eLoop)-    +   inStarNullableTagless qIn eLoop = debug (">< inStarNullableTagless "++show qIn++" <>") $ do     case unQ qIn of       Empty -> return Nothing -- with Or this discards () branch in "(^|foo|())*"@@ -619,7 +620,7 @@   actNullableTagless qIn ac@(eLoop,mAccepting,mQNFA) = debug (">< actNullableTagless "++show (qIn)++" <>") $ do     case unQ qIn of       Seq q1 q2 -> actNullable q1 =<< actNullable q2 ac   -- We know q1 and q2 are nullable-                      +       Or [] -> return ac       Or [q] -> actNullableTagless q ac       Or qs -> do@@ -660,7 +661,7 @@                             in ((nQ eLoop,fmap nQ mAccepting,Nothing),False)         if cannotAccept q then return ac0 else mdo           mChildAccepting <- act q (this,Nothing,Nothing)-          (thisAC@(this,_,_),ansAC) <- +          (thisAC@(this,_,_),ansAC) <-             case mChildAccepting of               Nothing -> err $ "Weird pattern in getTransTagless/Star: " ++ show (qTop,qIn)               Just childAccepting -> do@@ -756,22 +757,22 @@            let trans = toMap mempty . S.toAscList . addNewline . decodePatternSet $ ps            in Simple { qt_win = mempty, qt_trans = trans, qt_other = target }          _ -> err ("Cannot acceptTrans pattern "++show (qTop,pIn))-    where  -- Take a common destination and a sorted list of unique chraceters+    where  -- Take a common destination and a sorted list of unique characters            -- and create a map from those characters to the common destination       toMap :: IntMap [(DoPa,[(Tag, TagUpdate)])] -> [Char]             -> CharMap (IntMap [(DoPa,[(Tag, TagUpdate)])])       toMap dest | caseSensitive compOpt = CharMap . IMap.fromDistinctAscList . map (\c -> (ord c,dest))-                 | otherwise = CharMap . IMap.fromList . ($ []) +                 | otherwise = CharMap . IMap.fromList . ($ [])                                . foldr (\c dl -> if isAlpha c                                                    then (dl.((ord (toUpper c),dest):)                                                            .((ord (toLower c),dest):)                                                         )                                                    else (dl.((ord c,dest):))-                                       ) id +                                       ) id       addNewline | multiline compOpt = S.insert '\n'                  | otherwise = id       dotTrans | multiline compOpt = Map.singleton '\n' mempty-               | otherwise = mempty+               | otherwise = Mon.mempty  {- @@ -783,44 +784,5 @@   ADD ORPHAN ID check and make this a fatal error while testing---}---- | decodePatternSet cannot handle collating element and treats--- equivalence classes as just their definition and nothing more.-decodePatternSet :: PatternSet -> S.Set Char-decodePatternSet (PatternSet msc mscc _ msec) =-  let baseMSC = maybe S.empty id msc-      withMSCC = foldl (flip S.insert) baseMSC  (maybe [] (concatMap decodeCharacterClass . S.toAscList) mscc)-      withMSEC = foldl (flip S.insert) withMSCC (maybe [] (concatMap unSEC . S.toAscList) msec)-  in withMSEC---- | This returns the disctince ascending list of characters--- represented by [: :] values in legalCharacterClasses; unrecognized--- class names return an empty string-decodeCharacterClass :: PatternSetCharacterClass -> String-decodeCharacterClass (PatternSetCharacterClass s) =-  case s of-    "alnum" -> ['0'..'9']++['a'..'z']++['A'..'Z']-    "digit" -> ['0'..'9']-    "punct" -> ['\33'..'\47']++['\58'..'\64']++['\91'..'\95']++"\96"++['\123'..'\126']-    "alpha" -> ['a'..'z']++['A'..'Z']-    "graph" -> ['\41'..'\126']-    "space" -> "\t\n\v\f\r "-    "blank" -> "\t "-    "lower" -> ['a'..'z']-    "upper" -> ['A'..'Z']-    "cntrl" -> ['\0'..'\31']++"\127" -- with NUL-    "print" -> ['\32'..'\126']-    "xdigit" -> ['0'..'9']++['a'..'f']++['A'..'F']-    "word" -> ['0'..'9']++['a'..'z']++['A'..'Z']++"_"-    _ -> []--{---- | This is the list of recognized [: :] character classes, others--- are decoded as empty.-legalCharacterClasses :: [String]-legalCharacterClasses = ["alnum","digit","punct","alpha","graph"-  ,"space","blank","lower","upper","cntrl","print","xdigit","word"]  -}
+ lib/Text/Regex/TDFA/Text.hs view
@@ -0,0 +1,99 @@+{-|+Module      :  Text.Regex.TDFA.Text+Copyright   :  Chris Kuklewicz 2007-2009, shelarcy 2012+License     :  BSD-style (see the file LICENSE)++This modules provides 'RegexMaker' and 'RegexLike' instances for using+'Text' with the TDFA backend ("Text.Regex.TDFA.NewDFA.Engine" and+"Text.Regex.TDFA.NewDFA.Tester").++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.++@since 1.3.1+-}+module Text.Regex.TDFA.Text(+  Regex+ ,CompOption+ ,ExecOption+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array((!),elems)+import qualified Data.Text as T(Text,unpack)++import Text.Regex.Base(RegexLike(..),RegexMaker(..),Extract(..),MatchArray,RegexContext(..))+import Text.Regex.Base.Impl(polymatch,polymatchM)+import Text.Regex.TDFA.ReadRegex(parseRegex)+import Text.Regex.TDFA.String() -- piggyback on RegexMaker for String+import Text.Regex.TDFA.TDFA(patternToRegex)+import Text.Regex.TDFA.Common(Regex(..),CompOption,ExecOption(captureGroups),Position)++import Data.Maybe(listToMaybe)+import Text.Regex.TDFA.NewDFA.Uncons(Uncons)+import qualified Text.Regex.TDFA.NewDFA.Engine as Engine(execMatch)+import qualified Text.Regex.TDFA.NewDFA.Tester as Tester(matchTest)++-- | @since 1.3.1+instance RegexContext Regex T.Text T.Text where+  match = polymatch+  matchM = polymatchM++-- | @since 1.3.1+instance RegexMaker Regex CompOption ExecOption T.Text where+  makeRegexOptsM c e source = makeRegexOptsM c e (T.unpack source)++-- | @since 1.3.1+{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> T.Text -> [MatchArray] #-}+execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray]+execMatch = Engine.execMatch++-- | @since 1.3.1+{-# SPECIALIZE myMatchTest :: Regex -> T.Text -> Bool #-}+myMatchTest :: Uncons text => Regex -> text -> Bool+myMatchTest = Tester.matchTest++-- | @since 1.3.1+instance RegexLike Regex T.Text where+  matchOnce r s = listToMaybe (matchAll r s)+  matchAll r s = execMatch r 0 '\n' s+  matchCount r s = length (matchAll r' s)+    where r' = r { regex_execOptions = (regex_execOptions r) {captureGroups = False} }+  matchTest = myMatchTest+  matchOnceText regex source =+    fmap (\ma -> let (o,l) = ma!0+                 in (before o source+                    ,fmap (\ol -> (extract ol source,ol)) ma+                    ,after (o+l) source))+         (matchOnce regex source)+  matchAllText regex source =+    map (fmap (\ol -> (extract ol source,ol)))+        (matchAll regex source)++-- | @since 1.3.1+compile :: CompOption -- ^ Flags (summed together)+        -> ExecOption -- ^ Flags (summed together)+        -> T.Text -- ^ The regular expression to compile+        -> Either String Regex -- ^ Returns: the compiled regular expression+compile compOpt execOpt txt =+  case parseRegex (T.unpack txt) of+    Left err -> Left ("parseRegex for Text.Regex.TDFA.Text failed:"++show err)+    Right pattern -> Right (patternToRegex pattern compOpt execOpt)++-- | @since 1.3.1+execute :: Regex  -- ^ Compiled regular expression+        -> T.Text -- ^ Text to match against+        -> Either String (Maybe MatchArray)+execute r txt = Right (matchOnce r txt)++-- | @since 1.3.1+regexec :: Regex  -- ^ Compiled regular expression+        -> T.Text -- ^ Text to match against+        -> Either String (Maybe (T.Text, T.Text, T.Text, [T.Text]))+regexec r txt = Right $+  case matchOnceText r txt of+    Just (pre, mt, post) | main:rest <- map fst (elems mt)+      -> Just (pre, main, post, rest)+    _ -> Nothing
+ lib/Text/Regex/TDFA/Text/Lazy.hs view
@@ -0,0 +1,107 @@+{-|+Module      :  Text.Regex.TDFA.Text.Lazy+Copyright   :  Chris Kuklewicz 2007-2009, shelarcy 2012+License     :  BSD-style (see the file LICENSE)++This modules provides 'RegexMaker' and 'RegexLike' instances for using+'Text' with the TDFA backend ("Text.Regex.TDFA.NewDFA.Engine" and+"Text.Regex.TDFA.NewDFA.Tester").++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.++@since 1.3.1+-}+module Text.Regex.TDFA.Text.Lazy(+  Regex+ ,CompOption+ ,ExecOption+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array.IArray(Array,(!),elems)+import qualified Data.Text.Lazy as L(Text,unpack)++import Text.Regex.Base(MatchArray,RegexContext(..),Extract(..),RegexMaker(..),RegexLike(..))+import Text.Regex.Base.Impl(polymatch,polymatchM)+import Text.Regex.TDFA.ReadRegex(parseRegex)+import Text.Regex.TDFA.String() -- piggyback on RegexMaker for String+import Text.Regex.TDFA.TDFA(patternToRegex)+import Text.Regex.TDFA.Common(Regex(..),CompOption,ExecOption(captureGroups),Position)++import Data.Maybe(listToMaybe)+import Text.Regex.TDFA.NewDFA.Uncons(Uncons)+import qualified Text.Regex.TDFA.NewDFA.Engine as Engine(execMatch)+import qualified Text.Regex.TDFA.NewDFA.Tester as Tester(matchTest)++-- | @since 1.3.1+instance RegexContext Regex L.Text L.Text where+  match = polymatch+  matchM = polymatchM++-- | @since 1.3.1+instance RegexMaker Regex CompOption ExecOption L.Text where+  makeRegexOptsM c e source = makeRegexOptsM c e (L.unpack source)++-- | @since 1.3.1+{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> L.Text -> [MatchArray] #-}+execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray]+execMatch = Engine.execMatch++-- | @since 1.3.1+{-# SPECIALIZE myMatchTest :: Regex -> L.Text -> Bool #-}+myMatchTest :: Uncons text => Regex -> text -> Bool+myMatchTest = Tester.matchTest++-- | @since 1.3.1+instance RegexLike Regex L.Text where+  matchOnce r s = listToMaybe (matchAll r s)+  matchAll r s = execMatch r 0 '\n' s+  matchCount r s = length (matchAll r' s)+    where r' = r { regex_execOptions = (regex_execOptions r) {captureGroups = False} }+  matchTest = myMatchTest+  matchOnceText regex source =+    fmap (\ ma ->+            let (o,l) = ma!0+            in (before o source+               ,fmap (\ ol -> (extract ol source,ol)) ma+               ,after (o+l) source))+         (matchOnce regex source)+  matchAllText regex source =+    let go :: Int -> L.Text -> [Array Int (Int, Int)] -> [Array Int (L.Text, (Int, Int))]+        go i _ _ | i `seq` False = undefined+        go _i _t [] = []+        go i t (x:xs) =+          let (off0,len0) = x!0+              trans pair@(off,len) = (extract (off-i,len) t,pair)+              t' = after (off0+(len0-i)) t+          in fmap trans x : seq t' (go (off0+len0) t' xs)+    in go 0 source (matchAll regex source)++-- | @since 1.3.1+compile :: CompOption -- ^ Flags (summed together)+        -> ExecOption -- ^ Flags (summed together)+        -> L.Text -- ^ The regular expression to compile+        -> Either String Regex -- ^ Returns: the compiled regular expression+compile compOpt execOpt txt =+  case parseRegex (L.unpack txt) of+    Left err -> Left ("parseRegex for Text.Regex.TDFA.Text.Lazy failed:"++show err)+    Right pattern -> Right (patternToRegex pattern compOpt execOpt)++-- | @since 1.3.1+execute :: Regex  -- ^ Compiled regular expression+        -> L.Text -- ^ Text to match against+        -> Either String (Maybe MatchArray)+execute r txt = Right (matchOnce r txt)++-- | @since 1.3.1+regexec :: Regex  -- ^ Compiled regular expression+        -> L.Text -- ^ Text to match against+        -> Either String (Maybe (L.Text, L.Text, L.Text, [L.Text]))+regexec r txt = Right $+  case matchOnceText r txt of+    Just (pre, mt, post) | main:rest <- map fst (elems mt)+      -> Just (pre, main, post, rest)+    _ -> Nothing
regex-tdfa.cabal view
@@ -1,99 +1,185 @@-Name:                   regex-tdfa-Version:                1.2.3.3-License:                BSD3-License-File:           LICENSE-Copyright:              Copyright (c) 2007, Christopher Kuklewicz-Author:                 Christopher Kuklewicz-Maintainer:             Artyom <yom@artyom.me>, Christopher Kuklewicz <TextRegexLazy@personal.mightyreason.com>-Stability:              Seems to work, but not POSIX yet-Homepage:               https://github.com/ChrisKuklewicz/regex-tdfa-Bug-Reports:            https://github.com/ChrisKuklewicz/regex-tdfa/issues-Synopsis:               Replaces/Enhances Text.Regex-Description:            A new all Haskell "tagged" DFA regex engine, inspired by libtre-Category:               Text-Tested-With:            GHC==7.6.3-                      , GHC==7.8.4-                      , GHC==7.10.3-                      , GHC==8.0.2-                      , GHC==8.2.2-                      , GHC==8.4.4-                      , GHC==8.6.5-                      , GHC==8.8.1-Build-Type:             Simple-extra-source-files:+cabal-version:          2.0+name:                   regex-tdfa+version:                1.3.2.5++build-Type:             Simple+license:                BSD3+license-file:           LICENSE+copyright:              Copyright (c) 2007-2009, Christopher Kuklewicz+author:                 Christopher Kuklewicz+maintainer:             Andreas Abel+homepage:               https://wiki.haskell.org/Regular_expressions+bug-reports:            https://github.com/haskell-hvr/regex-tdfa/issues++category:               Text+synopsis:               Pure Haskell Tagged DFA Backend for "Text.Regex" (regex-base)+description:+  This package provides a pure Haskell \"Tagged\" DFA regex engine for <//hackage.haskell.org/package/regex-base regex-base>. This implementation was inspired by the algorithm (and Master's thesis) behind the regular expression library known as <https://github.com/laurikari/tre/ TRE or libtre>.+  .+  Please consult the "Text.Regex.TDFA" module for API documentation including a tutorial with usage examples;+  see also <https://wiki.haskell.org/Regular_expressions> for general information about regular expression support in Haskell.++extra-doc-files:   CHANGELOG.md+  README.md++extra-source-files:   test/cases/*.txt-Cabal-Version:          >= 1.8 +tested-with:+  GHC == 9.12.2+  GHC == 9.10.3+  GHC == 9.8.4+  GHC == 9.6.7+  GHC == 9.4.8+  GHC == 9.2.8+  GHC == 9.0.2+  GHC == 8.10.7+  GHC == 8.8.4+  GHC == 8.6.5+  GHC == 8.4.4+  GHC == 8.2.2+  GHC == 8.0.2+ source-repository head   type:                git-  location:            git://github.com/ChrisKuklewicz/regex-tdfa.git+  location:            https://github.com/haskell-hvr/regex-tdfa.git -flag devel-  description: enable flags that are useful for development+source-repository this+  type:                git+  location:            https://github.com/haskell-hvr/regex-tdfa.git+  tag:                 v1.3.2.5++flag force-O2   default: False   manual: True+  description:+    Force building @regex-tdfa@ with \"@ghc-options: -O2@\".+    .+    __NOTE__: This flag is mostly provided for legacy use-cases. Nowadays you can conveniently control optimization levels on a per-package granularity via @cabal.project@ files; see <https://cabal.readthedocs.io/en/latest/nix-local-build.html#configuring-builds-with-cabal-project cabal's user-guide> for more details. +flag doctest+  default: True+  manual: False+  description:+    Include test-suite doctest.+ library   hs-source-dirs:       lib-  Build-Depends:        array              >= 0.4 && < 0.6-                      , base               >= 4 && < 5-                      , bytestring         >= 0.10 && < 0.11-                      , containers         >= 0.5 && < 0.7-                      , ghc-prim-                      , mtl                == 2.*-                      , parsec             == 3.*-                      , regex-base         >= 0.93.1 && < 0.95 -  -- Support Semigroup instances uniformly-  ---  -- See also-  --  https://prime.haskell.org/wiki/Libraries/Proposals/SemigroupMonoid#RecommendedVariant-  ---  -- NB: This is the same logic `parsec.cabal` uses, so this doesn't-  -- add any new dependency that isn't already incurred by-  -- `regex-tdfa`'s transitive deps-  if !impl(ghc >= 8.0)-    build-depends:      fail-                      , semigroups == 0.18.*+  exposed-modules:      Data.IntMap.CharMap2+                        Data.IntMap.EnumMap2+                        Data.IntSet.EnumSet2+                        Text.Regex.TDFA+                        Text.Regex.TDFA.ByteString+                        Text.Regex.TDFA.ByteString.Lazy+                        Text.Regex.TDFA.Common+                        Text.Regex.TDFA.CorePattern+                        Text.Regex.TDFA.IntArrTrieSet+                        Text.Regex.TDFA.NewDFA.Engine+                        Text.Regex.TDFA.NewDFA.Engine_FA+                        Text.Regex.TDFA.NewDFA.Engine_NC+                        Text.Regex.TDFA.NewDFA.Engine_NC_FA+                        Text.Regex.TDFA.NewDFA.Tester+                        Text.Regex.TDFA.NewDFA.Uncons+                        Text.Regex.TDFA.NewDFA.MakeTest+                        Text.Regex.TDFA.Pattern+                        Text.Regex.TDFA.ReadRegex+                        Text.Regex.TDFA.Sequence+                        Text.Regex.TDFA.String+                        Text.Regex.TDFA.TDFA+                        Text.Regex.TDFA.TNFA+                        Text.Regex.TDFA.Text+                        Text.Regex.TDFA.Text.Lazy -  other-modules:          Paths_regex_tdfa-  Exposed-Modules:        Data.IntMap.CharMap2-                          Data.IntMap.EnumMap2-                          Data.IntSet.EnumSet2-                          Text.Regex.TDFA-                          Text.Regex.TDFA.ByteString-                          Text.Regex.TDFA.ByteString.Lazy-                          Text.Regex.TDFA.Common-                          Text.Regex.TDFA.CorePattern-                          Text.Regex.TDFA.IntArrTrieSet-                          Text.Regex.TDFA.NewDFA.Engine-                          Text.Regex.TDFA.NewDFA.Engine_FA-                          Text.Regex.TDFA.NewDFA.Engine_NC-                          Text.Regex.TDFA.NewDFA.Engine_NC_FA-                          Text.Regex.TDFA.NewDFA.Tester-                          Text.Regex.TDFA.NewDFA.Uncons-                          Text.Regex.TDFA.NewDFA.MakeTest-                          Text.Regex.TDFA.Pattern-                          Text.Regex.TDFA.ReadRegex-                          Text.Regex.TDFA.Sequence-                          Text.Regex.TDFA.String-                          Text.Regex.TDFA.TDFA-                          Text.Regex.TDFA.TNFA-  Buildable:              True-  Extensions:             MultiParamTypeClasses, FunctionalDependencies, BangPatterns, MagicHash, RecursiveDo, NoMonoPatBinds, ForeignFunctionInterface, UnboxedTuples, TypeOperators, FlexibleContexts, ExistentialQuantification, UnliftedFFITypes, TypeSynonymInstances, FlexibleInstances-  GHC-Options:            -Wall -funbox-strict-fields -fspec-constr-count=10 -O2 -fno-warn-orphans-  if flag(devel)-    ghc-prof-options: -auto-all+  autogen-modules:      Paths_regex_tdfa+  other-modules:        Paths_regex_tdfa +  build-depends:        array              >= 0.5    && < 0.6+                      , base               >= 4.9    && < 5+                      , bytestring         >= 0.10   && < 0.13+                      , containers         >= 0.5    && < 1+                          -- containers >= 0.5.11.0 (GHC 8.4) will allow to drop some #if+                      , mtl                >= 2.1.3  && < 2.4+                      , parsec             == 3.1.*+                      , regex-base         == 0.94.*+                      , text               >= 1.2.3  && < 2.2++  default-language:     Haskell2010+  default-extensions:   BangPatterns+                        ExistentialQuantification+                        FlexibleContexts+                        FlexibleInstances+                        ForeignFunctionInterface+                        FunctionalDependencies+                        MagicHash+                        MultiParamTypeClasses+                        NondecreasingIndentation+                        RecursiveDo+                        ScopedTypeVariables+                        TypeOperators+                        TypeSynonymInstances+                        UnboxedTuples+                        UnliftedFFITypes+  other-extensions:     CPP++  ghc-options:+      -funbox-strict-fields+      -fspec-constr-count=10+      -Wall+      -Wno-orphans+      -Wcompat++  if flag(force-O2)+    ghc-options:+      -O2++ test-suite regex-tdfa-unittest   type:                 exitcode-stdio-1.0-  build-depends:        regex-base >= 0.93.1, base >=4  && < 5, regex-tdfa >= 0.92, bytestring, containers, array, mtl, file-embed, filepath, utf8-string+   hs-source-dirs:       test   main-is:              Main.hs-  extensions:           FlexibleInstances, FlexibleContexts,Rank2Types-  GHC-Options:          -Wall -O2 -funbox-strict-fields-  if flag(devel)-    ghc-prof-options: -auto-all-  if !impl(ghc >= 8.0)-    build-depends:      fail++  -- intra-package dependency+  build-depends:        regex-tdfa++  -- dependencies whose version constraints are inherited via intra-package 'regex-tdfa' dependency+  build-depends:        array+                      , base+                      , bytestring+                      , filepath+                      , regex-base++  -- component-specific dependencies not inherited via 'regex-tdfa'+                      , directory          >= 1.1.0  && < 1.4+                      , filepath           >= 1.3.0  && < 1.6+                      , utf8-string        >= 1.0.1  && < 1.1++  default-language:     Haskell2010+  default-extensions:   FlexibleInstances+                        FlexibleContexts+                        Rank2Types+  other-extensions:     GeneralizedNewtypeDeriving++  ghc-options:          -funbox-strict-fields+                        -Wall+                        -Wcompat++  if flag(force-O2)+    ghc-options:        -O2++test-suite doctest+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        DocTestMain.hs++  build-depends:+      base             >= 4.9    && < 5+    , doctest-parallel >= 0.2.2+        -- doctest-parallel-0.2.2 is the first to filter out autogen-modules++  default-language:     Haskell2010++  if !flag(doctest)+    buildable: False
+ test/DocTestMain.hs view
@@ -0,0 +1,16 @@+module Main where++import System.Environment+         ( getArgs )+import Test.DocTest+         ( mainFromLibrary )+import Test.DocTest.Helpers+         ( extractSpecificCabalLibrary, findCabalPackage )++main :: IO ()+main = do+  args <- getArgs+  pkg  <- findCabalPackage "regex-tdfa"+  -- Need to give the library name, otherwise the parser does not find it.+  lib  <- extractSpecificCabalLibrary Nothing pkg+  mainFromLibrary lib args
test/Main.hs view
@@ -1,28 +1,30 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MonoLocalBinds             #-} +#if __GLASGOW_HASKELL__ >= 900+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#endif+ module Main where -import Control.Monad-import Control.Monad.Error()-import Data.Array-import Data.List-import Control.Applicative---import Data.Monoid-import Data.Sequence(Seq)-import Data.String-import Data.Typeable-import Data.Version()-import System.Environment-import Text.Regex.Base-import qualified Data.Foldable as F-import Data.FileEmbed+import           Control.Applicative  as App+import           Control.Monad+import qualified Control.Monad.Fail   as Fail+import           Data.Array+import qualified Data.ByteString      as BS import qualified Data.ByteString.UTF8 as UTF8-import qualified Control.Monad.Fail as Fail-import System.Exit+import           Data.List            (isInfixOf, mapAccumL, sort)+import           Data.String+import           Data.Typeable+import           Data.Version         ()+import           System.Directory     (getDirectoryContents)+import           System.Environment+import           System.Exit+import           System.FilePath      ((</>))+import           Text.Regex.Base -import qualified Text.Regex.TDFA.Common as TDFA-import qualified Text.Regex.TDFA as TDFA+import qualified Text.Regex.TDFA      as TDFA  default(Int) @@ -55,18 +57,18 @@  toTest :: String -> (Int,String,String,String) toTest line = let [n,regex,input,output] = words line-                  noQ [] = []+                  noQ []       = []                   noQ ('?':xs) = '-':'1':noQ xs-                  noQ (x:xs) = x:noQ xs+                  noQ (x:xs)   = x:noQ xs                   input' = if input == "NULL" then "" else unN input               in (read n,regex,input',noQ output)  toTest' :: String -> String -> (String,(Int,String,String,String)) toTest' oldRegex line =   let [n,regex,input,output] = words line-      noQ [] = []+      noQ []       = []       noQ ('?':xs) = '-':'1':noQ xs-      noQ (x:xs) = x:noQ xs+      noQ (x:xs)   = x:noQ xs       input' = if input == "NULL" then "" else input       regex' = if regex == "SAME" then oldRegex else regex   in (regex',(read n,regex',input',noQ output))@@ -107,22 +109,26 @@                 p ("Actual result  : "++show output')                 return (if n<0 then [] else [n]) -checkFile :: (RType -> RSource -> Result A) -> (String, String) -> IO (String,[Int])+checkFile :: (RType -> RSource -> Result A) -> (FilePath, String) -> IO (FilePath,[Int]) checkFile opM (filepath, contents) = do   putStrLn $ "\nUsing Tests from: "++filepath   vals <- liftM concat (mapM (checkTest opM) (load' contents))   return (filepath,vals) -checkTests :: (RType -> RSource -> Result A) -> IO [(String, [Int])]-checkTests opM = mapM (checkFile opM) testCases+checkTests :: (RType -> RSource -> Result A) -> [(FilePath,String)] -> IO [(String, [Int])]+checkTests opM testCases = mapM (checkFile opM) testCases -testCases :: [(String, String)]-testCases =-  map (\(filename, contents) -> (filename, UTF8.toString contents)) $-  $(embedDir =<< makeRelativeToProject "test/cases")+readTestCases :: FilePath -> IO [(String, String)]+readTestCases folder = do+  fns <- filter (".txt" `isInfixOf`) <$> getDirectoryContents folder+  when (null fns) $+    fail ("readTestCases: No test-cases found in " ++ show folder)+  forM (sort fns) $ \fn -> do+    bs <- BS.readFile (folder </> fn)+    return (fn, UTF8.toString bs)  newtype Result a = Result (Either String a)-  deriving (Eq, Show, Functor, Applicative, Monad)+  deriving (Eq, Show, Functor, App.Applicative, Monad)  instance Fail.MonadFail Result where   fail = Result . Left@@ -137,8 +143,8 @@  unN :: String -> String unN ('\\':'n':xs) = '\n':unN xs-unN (x:xs) = x:unN xs-unN [] = []+unN (x:xs)        = x:unN xs+unN []            = []  manual :: [String] -> IO () manual [sIn,rIn] = do@@ -172,13 +178,13 @@       putStrLn $ "Explanation and discussion of these tests on the wiki at http://www.haskell.org/haskellwiki/Regex_Posix including comparing results from different operating systems"       putStrLn $ "Questions about this package to the author at email <TextRegexLazy@personal.mightyreason.com>"       putStrLn $ "The type of both the pattern and test is " ++ show (typeOf (undefined :: RType))-      putStrLn $ "Without extactly two arguments:"+      putStrLn $ "Without exactly two arguments:"       putStrLn $ "    This program runs all test files listed in test/data-dir/test-manifest.txt"       putStrLn $ "    Lines with negative number are expected to fail, others are expected to pass."       putStrLn $ "With exactly two arguments:"       putStrLn $ "    The first argument is the text to be searched."       putStrLn $ "    The second argument is the regular expression pattern to search with."-      vals <- checkTests posix+      vals <- checkTests posix =<< readTestCases ("test" </> "cases")       if null (concatMap snd vals)         then putStrLn "\nWow, all the tests passed!"         else do
test/cases/basic3.txt view
@@ -140,3 +140,6 @@    144		.*(/000).*			/000			(0,4)(0,4)    145		.*(\\000).*			\000			(0,4)(0,4)    146		\\000				\000			(0,4)+   147		[[:graph:]]+		!#}~		(0,4)+   148		[[:xdigit:]]+		dE4db3eF		(0,8)+   149		[[:print:]]+		!#}~		(0,4)