diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,29 @@ For the package version policy (PVP), see http://pvp.haskell.org/faq . +### 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_ @@ -9,12 +33,12 @@ ### 1.3.1.0 Revision 2 _2021-02-20, Andreas Abel_ -- Compatibility with `base-4.15` (GHC 9.0) and `bytestring-0.11` +- 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) +- Compatibility with `base-4.14` (GHC 8.10). ## 1.3.1.0 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,202 @@ +# 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.1 +``` + +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" =~ "[0-9]+" :: 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[a-z]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 + +### 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. + +## The relevant links + +This documentation is also available in [Text.Regex.TDFA haddock](http://hackage.haskell.org/package/regex-tdfa-1.2.3.2/docs/Text-Regex-TDFA.html). + +This was also documented at the [Haskell wiki](https://wiki.haskell.org/Regular_expressions#regex-tdfa). The original Darcs repository was at [code.haskell.org](http://code.haskell.org/regex-tdfa/). When not updated, this was forked and 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 . + +## 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"). + +## Other related packages + +You can find several other related packages by searching for "tdfa" on [hackage](http://hackage.haskell.org/packages/search?terms=tdfa). + +## Document notes + +This was written 2016-04-30. 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 @@ -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 @@ -2,7 +2,7 @@ Module: Text.Regex.TDFA Copyright: (c) Chris Kuklewicz 2007-2009 SPDX-License-Identifier: BSD-3-Clause -Maintainer: hvr@gnu.org, Andreas Abel +Maintainer: Andreas Abel Stability: stable The "Text.Regex.TDFA" module provides a backend for regular 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 @@ -68,7 +68,7 @@ noWin :: WinTags -> Bool noWin = null --- | Used to track elements of the pattern that accept characters or +-- | Used to track elements of the pattern that accept characters or -- are anchors newtype DoPa = DoPa {dopaIndex :: Int} deriving (Eq,Ord) @@ -116,7 +116,7 @@ -- | GroupIndex is for indexing submatches from capturing -- parenthesized groups (PGroup\/Group) type GroupIndex = Int --- | GroupInfo collects the parent and tag information for an instance +-- | GroupInfo collects the parent and tag information for an instance -- of a group data GroupInfo = GroupInfo { thisIndex, parentIndex :: GroupIndex @@ -290,7 +290,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,6 +34,7 @@ ,TestInfo,OP(..),SetTestInfo(..),NullView ,patternToQ,cleanNullView,cannotAccept,mustAccept) where +import Control.Monad (liftM2, forM, replicateM) import Control.Monad.RWS {- all -} import Data.Array.IArray(Array,(!),accumArray,listArray) import Data.List(sort) @@ -249,7 +250,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,10 +265,10 @@ -- -- 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 PM = RWS (Maybe GroupIndex) [Either Tag GroupInfo] ([OP]->[OP],Tag) type HHQ = HandleTag -- m1 : info about left boundaary / preTag -> HandleTag -- m2 : info about right boundary / postTag -> PM Q @@ -298,7 +299,7 @@ -- 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 @@ -374,7 +375,7 @@ -- 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 @@ -630,5 +631,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 @@ -69,7 +75,7 @@ {-# 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] #-} @@ -100,7 +106,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 @@ -237,7 +243,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 +291,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,7 +305,7 @@ 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) []) $ getMQ earlyStart winQ @@ -376,7 +383,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 @@ -437,7 +444,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 +505,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 -} @@ -560,7 +567,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 +616,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 +637,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 -} @@ -718,7 +725,7 @@ case unsafeCoerce# memcpy 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 +736,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.Exts(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#) -{- --- #else -import Control.Monad.ST(ST) -import Data.Array.ST(STArray) --- #endif --} import Prelude hiding ((!!)) import Control.Monad(when,unless,forM,forM_,liftM2,foldM) @@ -28,6 +29,7 @@ import qualified Data.IntMap as IMap(null,toList,lookup,insert) import Data.Maybe(catMaybes) 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) @@ -60,12 +62,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 +83,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 @@ -170,6 +173,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 +188,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 +218,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 +246,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 @@ -256,6 +272,7 @@ -- (futher 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 +288,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 +376,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 -} @@ -419,7 +438,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 +446,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 +467,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 +505,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 +535,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 -} @@ -576,7 +622,7 @@ case unsafeCoerce# memcpy 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 +633,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 @@ -52,7 +52,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 +199,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/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) 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,6 @@ -- | 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(..) @@ -88,7 +88,7 @@ else x:'-':(toEnum (pred n+fromEnum x)):[] -} paren s = ('(':s)++")" - + data PatternSet = PatternSet (Maybe (Set Char)) (Maybe (Set PatternSetCharacterClass)) (Maybe (Set PatternSetCollatingElement)) @@ -128,7 +128,7 @@ instance Show PatternSetEquivalenceClass where showsPrec _ p = showChar '[' . showChar '=' . shows (unSEC p) . showChar '=' . showChar ']' --- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- | Do the transformation and simplification in a single traversal. -- This removes the PPlus, PQuest, and PBound values, changing to POr @@ -200,7 +200,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 +225,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 +236,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*! @@ -323,7 +323,7 @@ -- 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 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 @@ -56,14 +56,14 @@ 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 atom = try $ between (char '{') (char '}') (p_bound_spec atom) 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 @@ -78,9 +78,9 @@ -- An anchor cannot be modified by a repetition specifier 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 = do (gi,ci) <- getState @@ -92,7 +92,7 @@ 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 @@ -127,7 +127,7 @@ p_set_elem_coll = liftM BEColl $ try (between (string "[.") (string ".]") (many1 $ noneOf ".]")) -p_set_elem_range = try $ do +p_set_elem_range = try $ do start <- noneOf "]-" _ <- char '-' end <- noneOf "]" @@ -136,7 +136,7 @@ then return (BEChars [start..end]) else unexpected "End point of dashed character range is less than starting point" -p_set_elem_char = do +p_set_elem_char = do c <- noneOf "]" when (c == '-') $ do atEnd <- (lookAhead (char ']') >> return True) <|> (return False) 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. 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 @@ -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 @@ -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 @@ -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 @@ -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 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 @@ -8,7 +8,7 @@ -- | "Text.Regex.TDFA.TNFA" converts the CorePattern Q\/P data (and its -- Pattern leafs) 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 @@ -26,7 +26,7 @@ -- 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 @@ -86,7 +86,7 @@ msg = unlines [ show q ] in debug msg (qToNFA compOpt q,tags,groups) --- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- Query function on Q nullable :: Q -> Bool @@ -105,7 +105,7 @@ usesQNFA (Q {wants=WantsQNFA}) = True usesQNFA _ = False --- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- Functions related to QT -- dumb smart constructor used by qToQNFA @@ -148,7 +148,7 @@ preferNullViews [] win = win preferNullViews nvs win = foldl' (dominate win) win (reverse $ cleanNullView nvs) where -{- +{- dominate is common to applyNullViews and preferNullViews above. Even I no longer understand it without study. @@ -171,7 +171,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 +204,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 @@ -302,7 +302,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 +330,7 @@ put $! (futureI, oldQs . ((thisI,qnfa):)) return qnfa --- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- E related functions fromQNFA :: QNFA -> E @@ -439,7 +439,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 +530,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 +619,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 +660,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 @@ -761,13 +761,13 @@ 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 diff --git a/regex-tdfa.cabal b/regex-tdfa.cabal --- a/regex-tdfa.cabal +++ b/regex-tdfa.cabal @@ -1,17 +1,15 @@ cabal-version: 1.12 name: regex-tdfa -version: 1.3.1.1 +version: 1.3.1.2 build-Type: Simple license: BSD3 license-file: LICENSE copyright: Copyright (c) 2007-2009, Christopher Kuklewicz author: Christopher Kuklewicz -maintainer: - Herbert Valerio Riedel , - Andreas Abel +maintainer: Andreas Abel homepage: https://wiki.haskell.org/Regular_expressions -bug-reports: https://github.com/hvr/regex-tdfa/issues +bug-reports: https://github.com/haskell-hvr/regex-tdfa/issues category: Text synopsis: Pure Haskell Tagged DFA Backend for "Text.Regex" (regex-base) @@ -23,6 +21,7 @@ extra-source-files: CHANGELOG.md + README.md test/cases/*.txt tested-with: @@ -35,17 +34,18 @@ GHC == 8.4.4 GHC == 8.6.5 GHC == 8.8.4 - GHC == 8.10.4 - GHC == 9.0.1 + GHC == 8.10.7 + GHC == 9.0.2 + GHC == 9.2.1 source-repository head type: git - location: https://github.com/hvr/regex-tdfa.git + location: https://github.com/haskell-hvr/regex-tdfa.git source-repository this type: git - location: https://github.com/hvr/regex-tdfa.git - tag: v1.3.1.1 + location: https://github.com/haskell-hvr/regex-tdfa.git + tag: v1.3.1.2 flag force-O2 default: False @@ -97,13 +97,13 @@ build-depends: fail == 4.9.* , semigroups == 0.18.* || == 0.19.* build-depends: array >= 0.4 && < 0.6 - , base >= 4.5 && < 4.16 + , base >= 4.5 && < 4.17 , bytestring >= 0.9.2 && < 0.12 , containers >= 0.4.2 && < 0.7 - , mtl >= 2.1.3 && < 2.3 + , mtl >= 2.1.3 && < 2.4 , parsec == 3.1.* , regex-base == 0.94.* - , text >= 1.2.3 && < 1.3 + , text >= 1.2.3 && < 2.1 default-language: Haskell2010 default-extensions: BangPatterns @@ -116,6 +116,7 @@ MultiParamTypeClasses NondecreasingIndentation RecursiveDo + ScopedTypeVariables TypeOperators TypeSynonymInstances UnboxedTuples @@ -124,6 +125,9 @@ ghc-options: -Wall -funbox-strict-fields -fspec-constr-count=10 -fno-warn-orphans + if impl(ghc >= 8.0) + ghc-options: -Wcompat + if flag(force-O2) ghc-options: -O2 @@ -162,6 +166,9 @@ other-extensions: GeneralizedNewtypeDeriving ghc-options: -Wall -funbox-strict-fields + + if impl(ghc >= 8.0) + ghc-options: -Wcompat if flag(force-O2) ghc-options: -O2 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MonoLocalBinds #-} +#if __GLASGOW_HASKELL__ >= 902 +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +#endif + module Main where import Control.Applicative as App @@ -9,7 +14,7 @@ import Data.Array import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as UTF8 -import Data.List +import Data.List (isInfixOf, mapAccumL, sort) import Data.String import Data.Typeable import Data.Version () @@ -115,7 +120,7 @@ readTestCases :: FilePath -> IO [(String, String)] readTestCases folder = do - fns <- filter (isSuffixOf ".txt") <$> getDirectoryContents folder + fns <- filter (".txt" `isInfixOf`) <$> getDirectoryContents folder when (null fns) $ fail ("readTestCases: No test-cases found in " ++ show folder) forM (sort fns) $ \fn -> do