diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 into `regex-tdfa`; see . +- 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 . +- 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` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + =~ + +-- monadic, uses 'fail' on lack of match + =~~ +``` + +`(=~)` 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. + +* ``\` `` — Match start of entire text (similar to `^` in other regex engines) +* `\'` — Match end of entire text (similar to `$` in other regex engines) +* `\<` — Match beginning of word +* `\>` — Match end of word +* `\b` — Match beginning or end of word +* `\B` — 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 , +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 . + +## 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. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -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 diff --git a/lib/Data/IntMap/CharMap2.hs b/lib/Data/IntMap/CharMap2.hs --- a/lib/Data/IntMap/CharMap2.hs +++ b/lib/Data/IntMap/CharMap2.hs @@ -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 diff --git a/lib/Data/IntMap/EnumMap2.hs b/lib/Data/IntMap/EnumMap2.hs --- a/lib/Data/IntMap/EnumMap2.hs +++ b/lib/Data/IntMap/EnumMap2.hs @@ -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 diff --git a/lib/Text/Regex/TDFA.hs b/lib/Text/Regex/TDFA.hs --- a/lib/Text/Regex/TDFA.hs +++ b/lib/Text/Regex/TDFA.hs @@ -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 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 -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/ λ> \ '=~' \ @@ -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 - -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(..),(=~),(=~~)) diff --git a/lib/Text/Regex/TDFA/ByteString.hs b/lib/Text/Regex/TDFA/ByteString.hs --- a/lib/Text/Regex/TDFA/ByteString.hs +++ b/lib/Text/Regex/TDFA/ByteString.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/ByteString/Lazy.hs b/lib/Text/Regex/TDFA/ByteString/Lazy.hs --- a/lib/Text/Regex/TDFA/ByteString/Lazy.hs +++ b/lib/Text/Regex/TDFA/ByteString/Lazy.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/Common.hs b/lib/Text/Regex/TDFA/Common.hs --- a/lib/Text/Regex/TDFA/Common.hs +++ b/lib/Text/Regex/TDFA/Common.hs @@ -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++"}" diff --git a/lib/Text/Regex/TDFA/CorePattern.hs b/lib/Text/Regex/TDFA/CorePattern.hs --- a/lib/Text/Regex/TDFA/CorePattern.hs +++ b/lib/Text/Regex/TDFA/CorePattern.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/NewDFA/Engine.hs b/lib/Text/Regex/TDFA/NewDFA/Engine.hs --- a/lib/Text/Regex/TDFA/NewDFA/Engine.hs +++ b/lib/Text/Regex/TDFA/NewDFA/Engine.hs @@ -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__ */ -} diff --git a/lib/Text/Regex/TDFA/NewDFA/Engine_FA.hs b/lib/Text/Regex/TDFA/NewDFA/Engine_FA.hs --- a/lib/Text/Regex/TDFA/NewDFA/Engine_FA.hs +++ b/lib/Text/Regex/TDFA/NewDFA/Engine_FA.hs @@ -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__ */ -} diff --git a/lib/Text/Regex/TDFA/NewDFA/Engine_NC.hs b/lib/Text/Regex/TDFA/NewDFA/Engine_NC.hs --- a/lib/Text/Regex/TDFA/NewDFA/Engine_NC.hs +++ b/lib/Text/Regex/TDFA/NewDFA/Engine_NC.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/NewDFA/Engine_NC_FA.hs b/lib/Text/Regex/TDFA/NewDFA/Engine_NC_FA.hs --- a/lib/Text/Regex/TDFA/NewDFA/Engine_NC_FA.hs +++ b/lib/Text/Regex/TDFA/NewDFA/Engine_NC_FA.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/NewDFA/Tester.hs b/lib/Text/Regex/TDFA/NewDFA/Tester.hs --- a/lib/Text/Regex/TDFA/NewDFA/Tester.hs +++ b/lib/Text/Regex/TDFA/NewDFA/Tester.hs @@ -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 } ) diff --git a/lib/Text/Regex/TDFA/NewDFA/Uncons.hs b/lib/Text/Regex/TDFA/NewDFA/Uncons.hs --- a/lib/Text/Regex/TDFA/NewDFA/Uncons.hs +++ b/lib/Text/Regex/TDFA/NewDFA/Uncons.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/Pattern.hs b/lib/Text/Regex/TDFA/Pattern.hs --- a/lib/Text/Regex/TDFA/Pattern.hs +++ b/lib/Text/Regex/TDFA/Pattern.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/ReadRegex.hs b/lib/Text/Regex/TDFA/ReadRegex.hs --- a/lib/Text/Regex/TDFA/ReadRegex.hs +++ b/lib/Text/Regex/TDFA/ReadRegex.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/Sequence.hs b/lib/Text/Regex/TDFA/Sequence.hs --- a/lib/Text/Regex/TDFA/Sequence.hs +++ b/lib/Text/Regex/TDFA/Sequence.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/String.hs b/lib/Text/Regex/TDFA/String.hs --- a/lib/Text/Regex/TDFA/String.hs +++ b/lib/Text/Regex/TDFA/String.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/TDFA.hs b/lib/Text/Regex/TDFA/TDFA.hs --- a/lib/Text/Regex/TDFA/TDFA.hs +++ b/lib/Text/Regex/TDFA/TDFA.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/TNFA.hs b/lib/Text/Regex/TDFA/TNFA.hs --- a/lib/Text/Regex/TDFA/TNFA.hs +++ b/lib/Text/Regex/TDFA/TNFA.hs @@ -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"] -} diff --git a/lib/Text/Regex/TDFA/Text.hs b/lib/Text/Regex/TDFA/Text.hs new file mode 100644 --- /dev/null +++ b/lib/Text/Regex/TDFA/Text.hs @@ -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 diff --git a/lib/Text/Regex/TDFA/Text/Lazy.hs b/lib/Text/Regex/TDFA/Text/Lazy.hs new file mode 100644 --- /dev/null +++ b/lib/Text/Regex/TDFA/Text/Lazy.hs @@ -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 diff --git a/regex-tdfa.cabal b/regex-tdfa.cabal --- a/regex-tdfa.cabal +++ b/regex-tdfa.cabal @@ -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 , Christopher Kuklewicz -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 . This implementation was inspired by the algorithm (and Master's thesis) behind the regular expression library known as . + . + Please consult the "Text.Regex.TDFA" module for API documentation including a tutorial with usage examples; + see also 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 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 diff --git a/test/DocTestMain.hs b/test/DocTestMain.hs new file mode 100644 --- /dev/null +++ b/test/DocTestMain.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 " 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 diff --git a/test/cases/basic3.txt b/test/cases/basic3.txt --- a/test/cases/basic3.txt +++ b/test/cases/basic3.txt @@ -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)