packages feed

regex-parsec (empty) → 0.90

raw patch · 15 files changed

+2219/−0 lines, 15 filesdep +basedep +parsecdep +regex-basebuild-type:Customsetup-changed

Dependencies added: base, parsec, regex-base

Files

+ LICENSE view
@@ -0,0 +1,12 @@+This modile is under this "3 clause" BSD license:++Copyright (c) 2007, Christopher Kuklewicz+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,6 @@+#!/usr/bin/env runhaskell++-- I usually compile this with "ghc --make -o setup Setup.hs"++import Distribution.Simple(defaultMain)+main = defaultMain
+ Text/Regex/Parsec.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-|+The "Text.Regex.Parsec" module provides a backend for regular+expressions. To use it should be imported along with+"Text.Regex.Base".  If you import this along with other backends, then+you should do so with qualified imports, perhaps renamed for+convenience.++The main data type exported is 'Regex'. The 'CompOption' provides some+different choices when compiling the regular expression. The+'ExecOption' type is simply newtype'd () at this time.  The main+functions are '=~' and '=~~' which use the DFA 'Regex' type.  These+are all exported by "Text.Regex.Lib.WrapLazy".++This backend uses "Text.ParserCombinators.Parsec" to create parsers to+perform the regular expression matching.  It allows for the syntax of+the original "Text.Regex" plus enhancements:++1. Substring capture with back-references in the regular expression++2. Controlled matching repetitions with {n} {n,} {,m} {n,m} forms++3. Lazy matching with ?? +? *? {n,m}? forms++4. Possessive matching with ?+ ++ *+ {n,m}+ forms++5. Longest match, leftmost match, and rightmost matching strategies (see 'CompOption')++6. Can handle NUL characters in both regular expression and search string++7. This backend tries not to break when doing multiple matches with a regular expression that can match 0 characters++The parsec parser operators on ['Char'], so 'ByteString' input is+converted to such a list during processing.++There are two main modes for the CompOption strategy:+ Find_LongestMatch is the default, similary to Posix and the DFA+ Find_FirstLeft is like PCRE++Find_LongestMatch requires that nested subexpressions always capture+nested segments of the source sting.  Find_FirstLeft requires that+subexpressions capture the last successful use of that subexpression,+and so nested subexpression may or may not captured nested segments of+the source string.  Quickcheck and I cannot find any differences+between Find_FirstLeft and the regex-pcre backend.++Find_LongestMatch runs into the problem that while the+leftmost-longest whole match is well defined, the choice for what the+subpatterns and subexpressions match has not been well defined.  The+actual choice made is currently in flux as I develop it further, but+the 0.75 version now maximizes (as leftmost-longest) each captured+subexpression in order.  This can produce results that differ from+regex-posix and regex-tre.  Opinions on the desired behavior are+welcome.++-}++module Text.Regex.Parsec(getVersion_Text_Regex_Parsec+  ,module Text.Regex.Base+  ,module Text.Regex.Parsec.Wrap+  ,module Text.Regex.Parsec.String+  ,module Text.Regex.Parsec.ByteString+  ,module Text.Regex.Parsec.ByteString.Lazy+  ,module Text.Regex.Parsec.Sequence) where++import Data.Version(Version(..))+import Text.Regex.Parsec.Wrap(Regex,RegexOptionStrategy(..)+                             ,CompOption(..),ExecOption(..),(=~),(=~~))+import Text.Regex.Parsec.String()+import Text.Regex.Parsec.ByteString()+import Text.Regex.Parsec.ByteString.Lazy()+import Text.Regex.Parsec.Sequence()+import Text.Regex.Base++getVersion_Text_Regex_Parsec :: Version+getVersion_Text_Regex_Parsec =+  Version { versionBranch = [0,90]+          , versionTags = ["parsec","unstable"]+          }
+ Text/Regex/Parsec/ByteString.hs view
@@ -0,0 +1,85 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+{-|+This offers type class instances for 'RegexMaker' and+'RegexLike'. This is usually used via import "Text.Regex.Full".++It is worth noting that 'RegexMaker' and 'RegexLike' methods for+'ByteString' are built on those for 'String' except the default+'matchOnceText' and 'matchAllText' are used since they are already+efficient for use on 'ByteString' (and they use 'matchOnce' and+'matchAll').++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.+-}+module Text.Regex.Parsec.ByteString(+  -- ** Types+  Regex+ ,MatchOffset+ ,MatchLength+ ,CompOption(..)+ ,ExecOption(..)+  -- ** Medium level API functions+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array(Array,elems,accumArray)+import qualified Data.IntMap as I (toList,(!))+import Text.Regex.Parsec.Common(MatchedStrings)+import Text.Regex.Base.RegexLike(RegexMaker(..),RegexLike(..),RegexContext(..),MatchText,MatchArray,MatchOffset,MatchLength)+import Text.Regex.Parsec.Wrap(Regex(..),CompOption(..),ExecOption(..),wrapCompile,wrapMatch)+import Text.Regex.Parsec.String() -- build on these instances for RegexMaker and RegexLike+import Data.ByteString.Char8(ByteString)+import qualified Data.ByteString.Char8 as B(empty,unpack,take,drop)+import Text.Regex.Base.Impl(polymatch,polymatchM)++instance RegexContext Regex ByteString ByteString where+  match = polymatch+  matchM = polymatchM++instance RegexMaker Regex CompOption ExecOption ByteString where+  makeRegexOpts opts e source = makeRegexOpts opts e (B.unpack source)+  makeRegexOptsM opts e source = makeRegexOptsM opts e (B.unpack source)++instance RegexLike Regex ByteString where+  matchOnce r bs = matchOnce r (B.unpack bs)+  matchAll r bs = matchAll r (B.unpack bs)+  matchTest r bs = matchTest r (B.unpack bs)+  matchCount r bs = matchCount r (B.unpack bs)+-- Use default matchOnceText and matchAllText++compile  :: CompOption -- ^ Flags (summed together)+         -> ExecOption -- ^ Flags (summed together)+         -> ByteString -- ^ The regular expression to compile+         -> Either String Regex -- ^ Returns: the compiled regular expression+compile c e bs = wrapCompile c e (B.unpack bs)++execute :: Regex      -- ^ Compiled regular expression+        -> ByteString -- ^ ByteString to match against+        -> Either String (Maybe (Array Int (MatchOffset,MatchLength)))+execute r@(Regex {groups=g}) bs = either Left (Right . (fmap (toArr g))) (wrapMatch 0 r (B.unpack bs))++regexec :: Regex      -- ^ Compiled regular expression+        -> ByteString -- ^ ByteString to match against+        -> Either String (Maybe (ByteString, ByteString, ByteString, [ByteString]))+regexec r@(Regex {groups=g}) bs =+  case wrapMatch 0 r (B.unpack bs) of+    Left err -> Left err+    Right Nothing -> Right Nothing+    Right (Just ms) -> Right . Just $+      let (_,(o,l)) = ms I.! 0+      in (B.take o bs+         ,B.take l (B.drop o bs)+         ,B.drop (o+l) bs+         ,map (\(_,(o',l')) -> if (-1)==o' +                                 then B.empty+                                 else B.take l' (B.drop o' bs))+              (tail (elems (toMT g ms))))++toMT :: Int -> MatchedStrings -> MatchText String+toMT maxSubs ms =  accumArray (\_ new->new) ("",(-1,0)) (0,maxSubs) (I.toList ms)++toArr :: Int -> MatchedStrings -> MatchArray+toArr maxSubs ms = accumArray (\_ (_,ol)->ol) (-1,0) (0,maxSubs) (I.toList ms)
+ Text/Regex/Parsec/ByteString/Lazy.hs view
@@ -0,0 +1,85 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+{-|+This offers type class instances for 'RegexMaker' and+'RegexLike'. This is usually used via import "Text.Regex.Full".++It is worth noting that 'RegexMaker' and 'RegexLike' methods for+'ByteString' are built on those for 'String' except the default+'matchOnceText' and 'matchAllText' are used since they are already+efficient for use on 'ByteString' (and they use 'matchOnce' and+'matchAll').++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.+-}+module Text.Regex.Parsec.ByteString.Lazy(+  -- ** Types+  Regex+ ,MatchOffset+ ,MatchLength+ ,CompOption(..)+ ,ExecOption(..)+  -- ** Medium level API functions+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array(Array,elems,accumArray)+import qualified Data.IntMap as I (toList,(!))+import Text.Regex.Parsec.Common(MatchedStrings)+import Text.Regex.Base.RegexLike(RegexMaker(..),RegexLike(..),RegexContext(..),MatchText,MatchArray,MatchOffset,MatchLength)+import Text.Regex.Parsec.Wrap(Regex(..),CompOption(..),ExecOption(..),wrapCompile,wrapMatch)+import Text.Regex.Parsec.String() -- build on these instances for RegexMaker and RegexLike+import Data.ByteString.Lazy.Char8(ByteString)+import qualified Data.ByteString.Lazy.Char8 as B(empty,unpack,take,drop)+import Text.Regex.Base.Impl(polymatch,polymatchM)++instance RegexContext Regex ByteString ByteString where+  match = polymatch+  matchM = polymatchM++instance RegexMaker Regex CompOption ExecOption ByteString where+  makeRegexOpts opts e source = makeRegexOpts opts e (B.unpack source)+  makeRegexOptsM opts e source = makeRegexOptsM opts e (B.unpack source)++instance RegexLike Regex ByteString where+  matchOnce r bs = matchOnce r (B.unpack bs)+  matchAll r bs = matchAll r (B.unpack bs)+  matchTest r bs = matchTest r (B.unpack bs)+  matchCount r bs = matchCount r (B.unpack bs)+-- Use default matchOnceText and matchAllText++compile  :: CompOption -- ^ Flags (summed together)+         -> ExecOption -- ^ Flags (summed together)+         -> ByteString -- ^ The regular expression to compile+         -> Either String Regex -- ^ Returns: the compiled regular expression+compile c e bs = wrapCompile c e (B.unpack bs)++execute :: Regex      -- ^ Compiled regular expression+        -> ByteString -- ^ ByteString to match against+        -> Either String (Maybe (Array Int (MatchOffset,MatchLength)))+execute r@(Regex {groups=g}) bs = either Left (Right . (fmap (toArr g))) (wrapMatch 0 r (B.unpack bs))++regexec :: Regex      -- ^ Compiled regular expression+        -> ByteString -- ^ ByteString to match against+        -> Either String (Maybe (ByteString, ByteString, ByteString, [ByteString]))+regexec r@(Regex {groups=g}) bs =+  case wrapMatch 0 r (B.unpack bs) of+    Left err -> Left err+    Right Nothing -> Right Nothing+    Right (Just ms) -> Right . Just $+      let (_,(o,l)) = ms I.! 0+      in (B.take (toEnum o) bs+         ,B.take (toEnum l) (B.drop (toEnum o) bs)+         ,B.drop (toEnum (o+l)) bs+         ,map (\(_,(o',l')) -> if (-1)==o' +                                 then B.empty+                                 else B.take (toEnum l') (B.drop (toEnum o') bs))+              (tail (elems (toMT g ms))))++toMT :: Int -> MatchedStrings -> MatchText String+toMT maxSubs ms =  accumArray (\_ new->new) ("",(-1,0)) (0,maxSubs) (I.toList ms)++toArr :: Int -> MatchedStrings -> MatchArray+toArr maxSubs ms = accumArray (\_ (_,ol)->ol) (-1,0) (0,maxSubs) (I.toList ms)
+ Text/Regex/Parsec/Common.hs view
@@ -0,0 +1,76 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}+-- | Common supports the Lazy Parsec backend.  It defines all the data+-- types except Pattern and exports everything but the contructors of+-- Pattern.+module Text.Regex.Parsec.Common where++import Data.IntMap(IntMap)+import Text.ParserCombinators.Parsec(GenParser)+import Text.Regex.Parsec.Pattern(Pattern)++-- | 'RegexOption' control whether the pattern is multiline or+-- case-sensitive like Text.Regex and whether to capture the subgroups+-- (\1, \2, etc).+data CompOption = CompOption {multiline :: Bool+                             ,caseSensitive :: Bool+                             ,captureGroups :: Bool+                             ,strategy::RegexOptionStrategy}++data RegexOptionStrategy = Find_LongestMatch +                         | Find_FirstLeft +                         | Find_FirstRight +                         | Find_All++newtype ExecOption = ExecOption ()+{-+-- | This is a convenience value of RegexOption with multiline,+-- caseSensitive, and captureGroups all True and longestMatch False.+defaultRegexOption :: RegexOption+defaultRegexOption = RegexOption {multiline = True+                                 ,caseSensitive = True+                                 ,captureGroups = True+                                 ,strategy = Find_LongestMatch+                                 }+-}++-- | 'FullState' is the opaque data type used to hold the RegexParser+-- state and a user defined state.+data FullState userStateType = FullState {userState :: !userStateType+                                         ,accepted :: !Int+                                         ,openSub :: !(IntMap (String,Int))+                                         ,closedSub :: !MatchedStrings+                                         ,posixSub :: !Opened}++data Opened = Opened [Closed] Int (String,Int) Opened | EndOpened [Closed] deriving (Show)+data Closed = Closed [Closed] Int (String,(Int,Int)) deriving (Show)++-- | 'MatchedStrings' is an IntMap where the keys are PatternIndex+-- numbers and the values are completed substring captures.+--+-- This has now been augmented to also remember the offset and length+-- of the matched string.+type MatchedStrings = IntMap (String,(Int,Int))++-- | 'RegexParser' is the type of CharParser that uses the state from this module.+type RegexParser userState = GenParser Char (FullState userState)++type RegexP = RegexParser () [MatchedStrings]+type RegexPS s = RegexParser s [MatchedStrings]+type BoolMultiline = Bool+type BoolCaseSensitive = Bool+type StringRegex = String+type StringInput = String+type StringBeforeMatch = String+type StringOfMatch = String+type StringAfterMatch = String+type StringSubgroups = String+type StringSubPattern = String+type AboutMatch = (StringBeforeMatch,StringOfMatch,StringAfterMatch,[StringSubgroups])++-- | Datatype memo-izing the parsed regular expression and meta-data+data Regex = Regex {asString::StringRegex,asPattern::Pattern+                   ,capture::RegexP,capture'::RegexPS ShowS+                   ,noCapture::RegexP,noCapture'::RegexPS ([String]->[String])+                   ,userInt :: RegexPS Int+                   ,allMatches::RegexP,frontAnchor::Bool+                   ,groups::Int}
+ Text/Regex/Parsec/FullParsec.hs view
@@ -0,0 +1,294 @@+-- | This module is similar to CompatParsec, but produces a parser+-- with a configurable strategy.  CompatParsec takes all branches and+-- finds the longest match, but FullParsec can also take the branches+-- in left to right order and stop on the first successful match to+-- the full pattern.  This choice is made via the longestMatch field+-- of RegexOption.  To help control the the parser, this module+-- accepts lazy and possessive modifiers to help guide matching.+--+-- Unlike Text.Regex or Text.Regex.Lazy.Compat, NUL characters get no+-- special treatement and are permitted in the string form of regular+-- expressions and in the input to be matched.+--+-- Repetitions of a sub-pattern that accepts an empty string are+-- detected to prevent inifinite looping.  These checks for accepting+-- an empty string are not done if the sub-pattern can be proven to+-- never accept and empty string.+--+-- Capturing sub-group strings is all or nothing at the moment and is+-- controlled by RegexOption.  In neither case is the whole string+-- (group 0) captured.  That can be added by calling initState and+-- finalState before and after the parser returned by patternToParsec.+module Text.Regex.Parsec.FullParsec +    (patternToParsec+    ,patternToParsecCont+    ,hasFrontCarat) where++{- By Chris Kuklewicz, 2006. BSD License, see the LICENSE file. -}++import qualified Text.Regex.Parsec.FullParsecPosix as Posix+import Text.Regex.Parsec.Common(RegexParser, MatchedStrings,+  RegexOptionStrategy(..), CompOption(..))+import Text.Regex.Parsec.Pattern(hasFrontCarat, cannotMatchNull, simplify,+  Pattern(..))+import Text.Regex.Parsec.ReadRegex(decodePatternSet)+import Text.Regex.Parsec.RegexParsecState(lookupAccepted, initState, eqSubs,+  lookupSubs, lookupSub, stopSub, startSub, plusState, incState, finalState)+import Control.Monad(liftM, when, replicateM_, msum)+import Control.Monad.Fix(fix)+import Data.Char(toUpper, toLower)+import Data.List(sort, nub)+import qualified Data.Set as Set(toList)+-- import qualified Data.IntMap as I+import Text.ParserCombinators.Parsec((<|>), unexpected, try, setParserState,+  pzero, getPosition, getParserState, sourceLine, sourceColumn, optional,+  lookAhead, eof, string, oneOf, noneOf, char, anyChar)++-- | This applies 'simplify' to the provided pattern and wraps the+-- parsec parser in initState and finalState so that the whole+-- matching string is assigned to group 0.+--+-- The returned parser does nothing to the user state.+--+-- For ill-formed patterns this may call 'error', such as for PBound+-- values with negative mino or max or with min > max.  It is also an+-- error if the Pattern contains back references but the captureGroups+-- RegexOption is set to False.  It is also an error if PLazy is+-- applied to anything but PQuest, PPlus, PStar, or PBound.+patternToParsec :: CompOption -> Pattern -> RegexParser userState [MatchedStrings]+patternToParsec opt@(CompOption {strategy=Find_LongestMatch}) p = Posix.patternToParsec opt p+patternToParsec opt p = initState >> patternToParsecCont opt (simplify p) (finalState >>= return.(:[]))++-- | This takes an option structure and a Pattern and parser to act as+-- the continuation of the parser created from the Pattern.  This is+-- used to build patternToParsec.+--+-- The returned parser does nothing to the user state.+--+-- For ill-formed patterns this may call 'error', such as for PBound+-- values with negative mino or max or with min > max.  It is also an+-- error if the Pattern contains back references but the captureGroups+-- RegexOption is set to False.  It is also an error if PLazy is+-- applied to anything but PQuest, PPlus, PStar, or PBound.+patternToParsecCont :: CompOption+		    -> Pattern+		    -> RegexParser userState [b]+		    -> RegexParser userState [b]+patternToParsecCont (CompOption {multiline=multi+                                ,caseSensitive=sensitive+                                ,captureGroups=captureG+                                ,strategy=find}) = reflectParsec+ where+  reflectParsec :: Pattern -> RegexParser userState [b] -> RegexParser userState [b]+  reflectParsec pIn cont = +    case pIn of+      PEmpty -> cont+      PCarat -> if multi+                  then do col <- liftM sourceColumn getPosition+                          when (1/=col) (unexpected "Not anchored at start of line")+                          cont+                  else do pos <- getPosition+                          let (line,col) = (sourceLine pos,sourceColumn pos)+                          when (1/=line || 1/=col) (unexpected "Not anchored at start of input")+                          cont+      PDollar -> if multi then (lookAhead ((char '\n' >> return ()) <|> eof)) >> cont+                          else eof >> cont+      PGroup i p -> if captureG then startSub i >> reflectParsec p (stopSub i >> cont)+                                else reflectParsec p cont+-- There should be no empty POr patterns in a well-formed Pattern, but+-- 'error' is hard to catch so let it slide.+--    POr [] -> error "Empty POr Pattern"+      POr [] -> cont+-- Need to make a longest-match version of POr+      POr ps -> case find of+                  Find_LongestMatch -> let branches = map (\p -> reflectParsec p cont) ps +                                       in longestMatch branches+                  Find_FirstLeft -> let branches = map (\p -> try (reflectParsec p cont)) ps+                                    in msum branches+                  Find_FirstRight -> let branches = map (\p -> try (reflectParsec p cont)) (reverse ps)+                                     in msum branches+                  Find_All -> let branches = map (\p -> reflectParsec p cont) ps +                              in allBranches branches+-- There should be no empty PConcat patterns in a well-formed Pattern, but+-- 'error' is hard to catch so let it slide+--    PConcat [] -> error "Error PConcat Pattern"+      PConcat [] -> cont+      PConcat ps -> foldr reflectParsec cont ps+      -- Greedy is the default+      PQuest p -> greedyOpt p cont+      PPlus p -> reflectParsec p (greedy p)+      PStar p -> greedy p+      PBound 0 Nothing p -> greedy p+      PBound i Nothing p | i>0 -> exact i p (greedy p)+                         | otherwise -> error $ "PBound with invalude parameters: "++show i++" and Nothing"+      PBound i (Just j) p | i==j -> exact i p cont+                          | 0<=i && i<j  -> exact i p (greedyTo p (j-i))+                          | otherwise -> error $ "PBound with invalude parameters: "++show i++" and "++show j+      -- Lazy+      PLazy (PQuest p) -> lazyOpt p cont+      PLazy (PPlus p) -> reflectParsec p (lazy p)+      PLazy (PStar p) -> lazy p+      PLazy (PBound 0 Nothing p) -> lazy p+      PLazy (PBound i Nothing p) | i>0 -> exact i p (lazy p)+                                 | otherwise -> error $ "PBound with invalude parameters: "++show i++" and Nothing"+      PLazy (PBound i (Just j) p) | i==j -> exact i p cont+                                  | 0<=i && i<j  -> exact i p (lazyTo p (j-i))+                                  | otherwise -> error $ "PBound with invalude parameters: "++show i++" and "++show j+-- Applying PLazy to non-repeating patterns makes no sense and is an error+      PLazy err -> error $ "PLazy applied to invalid pattern : "++show err+      -- Possessive+      PPossessive (PQuest p) -> possessiveOpt p+      PPossessive (PPlus p) -> reflectParsec p (possessive p)+      PPossessive (PStar p) -> possessive p+      PPossessive (PBound 0 Nothing p) -> possessive p+      PPossessive (PBound i Nothing p) | i>0 -> exactPos i p (possessive p)+                                       | otherwise -> error $ "PBound with invalude parameters: "++show i++" and Nothing"+      PPossessive (PBound i (Just j) p) | i==j -> exactPos i p cont+                                        | 0<=i && i<j  -> exactPos i p (possessiveTo p (j-i))+                                        | otherwise -> error $ "PBound with invalude parameters: "++show i++" and "++show j+-- Applying PPossessive to other patterns makes sense, so instead of+-- an error...+--    PPossessive err -> error $ "PPossessive applied to invalid pattern : "++show err+-- ...the pattern is handled by giving a (reOk) continuation.+-- This will prevent backtracking to any 'try' statements created by+-- reflectParsec p once all of p matches.+      PPossessive p -> reflectParsec p (reOk) >> cont+++-- The operations below actually check the input for a match, accept+-- valid characters, and advance the state+      PDot -> if multi then parseChar (noneOf "\n") >> cont+                       else parseChar anyChar >> cont+      PAny patset -> if sensitive+                       then let chars = Set.toList . decodePatternSet $ patset+                            in parseChar (oneOf chars) >> cont+                       else let chars = nub . sort $ concatMap ($ Set.toList (decodePatternSet patset)) [map toLower,map toUpper]+                            in parseChar (oneOf chars) >> cont+      PAnyNot patset -> if sensitive+                          then let chars = Set.toList . decodePatternSet $ patset+                               in parseChar (noneOf chars) >> cont+                          else let chars = nub . sort $ concatMap ($ Set.toList (decodePatternSet patset)) [map toLower,map toUpper]+                               in parseChar (noneOf chars) >> cont+      PEscape c -> acceptChar c >> cont+      PBack i -> if captureG+                   then do maybeSub <- lookupSub i+                           case maybeSub of Nothing -> unexpected ("Cannot find subexpression \\"++show i)+                                            Just sub -> acceptString sub >> cont+                   else error "Pattern with back reference used with RegexOption captureGroups set to False"+      PChar c -> acceptChar c >> cont+      PString s -> acceptString s >> cont++    where+      -- Define longestMatch for Find_LongestMatch+      howFar branch = lookAhead (do result <- try branch+                                    len <- lookupAccepted+                                    subs <- lookupSubs+                                    saveGame <- getParserState+                                    return (Just (len,subs,(saveGame,result))))+                      <|> return Nothing+      -- Need to compare sub-expression captures with http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap09.html+{-+      compareSubs s1 s2 =+        let s1s = I.toAscList s1+            s2s = I.toAscList s2+            check [] [] = EQ -- neither is "better" than the other+            check _  [] = GT -- x is more defined, so is "better"+            check [] _  = LT -- y is more defined, so is "better"+            check ((xKey,(_,(xOff,xLen))):xs) ((yKey,(_,(yOff,yLen))):ys) =+              case compare xKey yKey of+                EQ -> case compare xLen yLen of+                        EQ -> check xs ys -- recursion+                        GT -> GT -- x is longer, so is "better"+                        LT -> LT -- y is longer, so is "better"+                LT -> GT -- x is more defined, so is "better"+                GT -> LT -- y is more defined, so is "better"+        in check s1s s2s+-}+      longestMatch branches = do+        allFar <- mapM howFar branches+        let best = foldl maxFst Nothing allFar+            maxFst a Nothing = a+            maxFst Nothing b = b+            maxFst a@(Just (aL,_,_)) b@(Just (bL,_,_)) =+              case compare aL bL of+                GT -> a -- a is longer, so is "better"+                LT -> b -- b is longer, so is "better"+                EQ -> a -- break ties to the left+        case best of Nothing -> pzero+                     Just (_,_,(saveGame,result)) -> do setParserState saveGame+                                                        return result+{-+      longestMatch branches = do+        allFar <- mapM howFar branches+        let best = foldl maxFst Nothing allFar+            maxFst a Nothing = a+            maxFst Nothing b = b+            maxFst a@(Just (aL,aS,_)) b@(Just (bL,bS,_)) =+              case compare aL bL of+                GT -> a -- a is longer, so is "better"+                LT -> b -- b is longer, so is "better"+                EQ -> case compareSubs aS bS of+                        GT -> a -- aS is "better"+                        LT -> b -- bS is "better"+                        EQ -> a  -- break tie in favor of leftmost branch+        case best of Nothing -> pzero+                     Just (_,_,(saveGame,result)) -> do setParserState saveGame+                                                        return result+-}+      -- Define allBranches for Find_All+      maybeBranch branch = lookAhead (try branch) <|> return []+      allBranches branches = liftM concat (mapM maybeBranch branches)+      (<||>) = case find of+                 Find_LongestMatch -> \a b -> longestMatch [a,b]+                 Find_FirstLeft -> (<|>)+                 Find_FirstRight -> (<|>)+                 Find_All -> \a b -> allBranches [a,b]+      -- Provide shortcut to 'cont' when 'cps' matches zero characters and same Subs are in effect+      -- This effectively brackets the matching of cps.+      whenNull cps c = do before <- lookupAccepted+                          beforeSubs <- lookupSubs+                          cps (do +                            after <- lookupAccepted+                            if after > before +                              then c -- progress+                              else do +                                afterSubs <- lookupSubs+                                if eqSubs afterSubs beforeSubs+                                  then cont -- shortcut+                                  else c)+      -- p{i} p{i,i}  There is no attempt to short-circuit accepting "" here+      exact i p cont' = foldr reflectParsec cont' (replicate i p)+      exactPos i p cont' = let p' = reflectParsec p (reOk)+                           in replicateM_ i p' >> cont'+      -- main p? p?* p?+ when you don't worry about accepting ""+      greedyOpt      p c = try (reflectParsec p c) <||> cont+      lazyOpt        p c = try cont                <||> (reflectParsec p c)+      possessiveOpt  p   = optional (reflectParsec p (reOk)) >> cont+      possessiveOpt' p c = (try (reflectParsec p (reOk)) >> c) <||> cont+      -- helper p? p?* p?+ when you are worried about accepting ""+      greedySafe     p c = try (whenNull (reflectParsec p) c) <||> cont+      lazySafe       p c = try cont <||> whenNull (reflectParsec p) c+      possessiveSafe p c = whenNull (try (reflectParsec p (reOk)) >>) c+      -- p* p*? p*++      greedy     p = if cannotMatchNull p then fix (greedyOpt p)      else fix (greedySafe p)+      lazy       p = if cannotMatchNull p then fix (lazyOpt p)        else fix (lazySafe p)+      possessive p = if cannotMatchNull p then fix (possessiveOpt' p) else fix (possessiveSafe p)+      -- p{0,n} p{0,n}? p{0,n}++      useTo n use = foldr ($) cont (replicate n use)+      greedyTo     p n = useTo n $ if cannotMatchNull p then greedyOpt p else greedySafe p+      lazyTo       p n = useTo n $ if cannotMatchNull p then lazyOpt p else lazySafe p+      possessiveTo p n = useTo n $ if cannotMatchNull p then possessiveOpt' p else possessiveSafe p+      -- Do bookeeping when advancing, check for case sensitivity option+      parseChar :: RegexParser userState Char -> RegexParser userState ()+      parseChar c = c >> incState+      acceptChar :: Char -> RegexParser userState ()+      acceptChar c = if sensitive then char c >> incState+                                  else foo c >> incState+      acceptString :: String -> RegexParser userState ()+      acceptString s = if (not sensitive) && (map toLower s /= map toUpper s)+                         then sequence (map foo s) >> plusState (length s)+                         else string s  >> plusState (length s)+      foo :: Char -> RegexParser userState Char+      foo c | toLower c /= toUpper c = oneOf [toLower c, toUpper c]+            | otherwise              = char c+      reOk = return []
+ Text/Regex/Parsec/FullParsecPosix.hs view
@@ -0,0 +1,453 @@+{-|+This is a cloned copy of FullParsec which is being used to explore how+to change from PCRE leftmost semantics to posix longest semantics.++The other semantics are being ripped out to clarify things.++First: Need to fix this bug with capturing:+*Text.Regex.Impl.Test> fiddle "ba" "((a)*(b)*)*"+"PCRE"+"(0,2)(2,2)(1,2)(0,1)"+"Parsec/pcre"+"(0,2)(2,2)(1,2)(0,1)"+"PosixRE"+"(0,2)(2,2)(-1,-1)(-1,-1)"+"Parsec/posix"+"(0,2)(2,2)(1,2)(0,1)"+"TRE"+"(0,2)(1,2)(1,2)(-1,-1)"++*Text.Regex.Impl.Test> fiddle' "ba" "((a)*(b)*)*"+"PCRE"+("","ba","",["","a","b"])+"Parsec/pcre"+("","ba","",["","a","b"])+"PosixRE"+("","ba","",["","",""])+"Parsec/posix"+("","ba","",["","a","b"])+"TRE"+("","ba","",["a","a",""])++These show the backref is cleared as soon as the parent group is reopened, unlike PCRE:++*Text.Regex.Impl.Test> fiddle' "aaabac" "((a)*b|\\2)*"+"PCRE"+("","aaaba","c",["a","a"])+"Parsec/pcre"+("","aaaba","c",["a","a"])+"PosixRE"+("","aaab","ac",["aaab","a"])+"Parsec/posix"+("","aaaba","c",["a","a"])+"TRE"+("","aaab","ac",["aaab","a"])++*Text.Regex.Impl.Test> fiddle' "aaabac" "((b\\3c)|(a)*)*"+"PCRE"+("","aaabac","",["","bac","a"])+"Parsec/pcre"+("","aaabac","",["","bac","a"])+"PosixRE"+("","aaa","bac",["","",""])+"Parsec/posix"+("","aaabac","",["","bac","a"])+"TRE"+("","aaa","bac",["aaa","","a"])++This means keeping track of the nesting of sub-expressions (the PGroup+patterns).  Everything is okay until a PGroup which was previously+captures is opened.  Now we need to destroy all the nested captures.++The current state is interesting:++data Closed = Closed i data [Closed]+data Opened = Opened i data [Closed] (Maybe Opened)++Initially it is (ignoring the data):+Opened 0 [] Nothing+When a group #1 is opened this is updated to+Opened 0 [] (Just (Opened 1 [] Nothing))+Then a subgroup #2 is opened+Opened 0 [] (Just (Opened 1 [] (Just Opened 2 [] Nothing)))+It should now be impossible to close #1.  This is a dynamic property.+This #2 is later closed:+Opened 0 [] (Just (Opened 1 [Closed 2 []] Nothing))+If #2 is opened, then go back to the previous step, else close #1 and get+Opened 0 [Closed 1 [Closed 2 []]] Nothing+It should now be impossible for #2 to be re-opened.  This is a dynamic property.+If #1 is re-opened then it's closed list is supposed to be cleared:+Opened 0 [] (Just (Opened 1 [] Nothing))++data Closed = Closed i data [Closed]+data Opened = Opened i data [Closed] Opened+            | End [Closed]++Consider the nesting:+0 1 2 2 3 3 1 4 5 5 4 0  <= group number+( ( ( ) ( ) ) ( ( ) ) )+ 0 1 2 3 4 5 6 7 8 9 A B <= stage index below++data Closed = Closed [Closed] i (String,(offset,length))+data Opened = Opened [Closed] i (String,(offset)) Opened+            | End [Closed]++Try it with the reverse nesting and re-ordering the arguments...+0 Opened [] 0 (End [])+1 Opened [] 1 (Opened [] 0 (End []))+2 Opened [] 2 (Opened [] 1 (Opened [] 0 (End [])))+3 Opened [Closed [] 2] 1 (Opened [] 0 (End []))+4 Opened [] 3 (Opened [Closed [] 2] 1 (Opened [] 0 (End [])))+5 Opened [Closed [] 3,Closed [] 2] 1 (Opened [] 0 (End []))+6 Opened [Closed [Closed [] 3,Closed [] 2] 1] 0 (End [])+7 Opened [] 4 (Opened [Closed [Closed [] 3,Closed [] 2] 1] 0 (End []))+8 Opened [] 5 (Opened [] 4 (Opened [Closed [Closed [] 3,Closed [] 2] 1] 0 (End [])))+9 Opened [Closed [] 5] 4 (Opened [Closed [Closed [] 3,Closed [] 2] 1] 0 (End [])))+A Opened [Closed [Closed [] 5] 4,Closed [Closed [] 3,Closed [] 2] 1] 0 (End [])+B End [Closed [Closed [Closed [] 5] 4,Closed [Closed [] 3,Closed [] 2] 1] 0]+-- we could open more groups here without problems...++What could have been closed at any of the stages?+Only the outermost Opened group.++What could have been re-opened at any of the stages?+3 : 2 => 2+5 : 3 (leaving group 2 closed) => 4+6 : 1 (clearing groups 2 and 3) => 1+9 : 5 (leaving groups 1(2 3) closed ) => 8+A : 4 (clearing group 5, leaving groups 1(2 3) closed) => 7+B : 0 (clearing groups 1(2 3) 4(5)) => 0++In a more general Pattern, one could imaging repeating subpatterns+that are not also subexpressions, but that do contain concatenated+subexpressions.  In which case you could also re-open:+5 : 2 (clearing group 3) => 2+A : 1 (clearing groups 2 3 4 5) => 1++Creation:++The outermost opened group may be turned into a child of a new outermost Opened++Closing:++The outermost group may be deleted and it's closed group prepended to it's opened child's outmost group's closed list++Re-Opening:++The head of the closed list of the outermost Opened may be removed and turned into a new outermost Opened+or more generally (for repeated subpatterns which are not also subexpressions):+An element of the closed list of the outermost Opened may be removed (leaving the tail and removing previous elements) and turned into a new outermost Opened.++Lookup of Back-reference:++Consider (9).  You are looking for index x:+The top Opened is index 4+  if x>4 then search 4's closed list+    the first Closed element is index 5+      if x>5 then then look in (Closed [] 5)'s empty closed list and fail+      if x<5 then look at the rest of the empty list and fail+  if x<4 then search the child Opened+    this Opened is index 0+    if x>0 then search the closed list+      the first Closed element is index 3+        if x>3 then look in (Closed [] 3)'s empty list and fail+        if x<3 then look at the rest of the list+          the next Closed element is index 2+            if x>2 then look in (Closed [] 2)'s empty list and fail+            if x<2 then look at the rest of the empty list and fail+    if x<0 then search the child End's empty list and fail+      +This module is similar to CompatParsec, but produces a parser with a+configurable strategy.  CompatParsec takes all branches and finds the+longest match, but FullParsec can also take the branches in left to+right order and stop on the first successful match to the full+pattern.  This choice is made via the longestMatch field of+RegexOption.  To help control the the parser, this module accepts lazy+and possessive modifiers to help guide matching.++Unlike Text.Regex or Text.Regex.Lazy.Compat, NUL characters get no+special treatement and are permitted in the string form of regular+expressions and in the input to be matched.++Repetitions of a sub-pattern that accepts an empty string are detected+to prevent inifinite looping.  These checks for accepting an empty+string are not done if the sub-pattern can be proven to never accept+and empty string.++Capturing sub-group strings is all or nothing at the moment and is+controlled by RegexOption.  In neither case is the whole string (group+0) captured.  That can be added by calling initState and finalState+before and after the parser returned by patternToParsec.++-}+module Text.Regex.Parsec.FullParsecPosix+    (patternToParsec+    ,patternToParsecCont+    ,hasFrontCarat) where++{- By Chris Kuklewicz, 2006. BSD License, see the LICENSE file. -}++import Text.Regex.Parsec.Common(RegexParser, MatchedStrings,+  RegexOptionStrategy(..), CompOption(..))+import Text.Regex.Parsec.Pattern(hasFrontCarat, cannotMatchNull, simplify,+  Pattern(..))+import Text.Regex.Parsec.ReadRegex(decodePatternSet)+import Text.Regex.Parsec.RegexParsecState+  (initStateP, finalStateP, eqSubs+  ,plusState, incState,   lookupAccepted+  ,lookupSubsP, lookupSubP, stopSubP, startSubP+  )+import Control.Monad(liftM, when, replicateM_ {- ,msum -})+import Control.Monad.Fix(fix)+import Data.Char(toUpper, toLower)+import Data.List(sort, nub)+import qualified Data.Set as Set(toList)+import qualified Data.IntMap as I+import Text.ParserCombinators.Parsec((<|>), unexpected, try, setParserState,+  pzero, getPosition, getParserState, sourceLine, sourceColumn, optional,+  lookAhead, eof, string, oneOf, noneOf, char, anyChar)++-- | This applies 'simplify' to the provided pattern and wraps the+-- parsec parser in initState and finalState so that the whole+-- matching string is assigned to group 0.+--+-- The returned parser does nothing to the user state.+--+-- For ill-formed patterns this may call 'error', such as for PBound+-- values with negative mino or max or with min > max.  It is also an+-- error if the Pattern contains back references but the captureGroups+-- RegexOption is set to False.  It is also an error if PLazy is+-- applied to anything but PQuest, PPlus, PStar, or PBound.+patternToParsec :: CompOption -> Pattern -> RegexParser userState [MatchedStrings]+patternToParsec opt p = do +  initStateP+  patternToParsecCont opt (simplify p) (do f <- finalStateP+                                           return [f])++-- | This takes an option structure and a Pattern and parser to act as+-- the continuation of the parser created from the Pattern.  This is+-- used to build patternToParsec.+--+-- The returned parser does nothing to the user state.+--+-- For ill-formed patterns this may call 'error', such as for PBound+-- values with negative mino or max or with min > max.  It is also an+-- error if the Pattern contains back references but the captureGroups+-- RegexOption is set to False.  It is also an error if PLazy is+-- applied to anything but PQuest, PPlus, PStar, or PBound.+patternToParsecCont :: CompOption+		    -> Pattern+		    -> RegexParser userState [b]+		    -> RegexParser userState [b]+patternToParsecCont (CompOption {multiline=multi+                                ,caseSensitive=sensitive+                                ,captureGroups=captureG+                                ,strategy=find}) = reflectParsec+ where+  reflectParsec :: Pattern -> RegexParser userState [b] -> RegexParser userState [b]+  reflectParsec pIn cont = +    case pIn of+      PEmpty -> cont+      PCarat -> if multi+                  then do col <- liftM sourceColumn getPosition+                          when (1/=col) (unexpected "Not anchored at start of line")+                          cont+                  else do pos <- getPosition+                          let (line,col) = (sourceLine pos,sourceColumn pos)+                          when (1/=line || 1/=col) (unexpected "Not anchored at start of input")+                          cont+      PDollar -> if multi then (lookAhead ((char '\n' >> return ()) <|> eof)) >> cont+                          else eof >> cont+      PGroup i p -> if captureG then startSubP i >> reflectParsec p (stopSubP i >> cont)+                                else reflectParsec p cont+-- There should be no empty POr patterns in a well-formed Pattern, but+-- 'error' is hard to catch so let it slide.+--    POr [] -> error "Empty POr Pattern"+      POr [] -> cont+-- Need to make a longest-match version of POr+      POr ps -> case find of+                  Find_LongestMatch -> let branches = map (\p -> reflectParsec p cont) ps +                                       in longestMatch branches+                  _ -> undefined+-- There should be no empty PConcat patterns in a well-formed Pattern, but+-- 'error' is hard to catch so let it slide+--    PConcat [] -> error "Error PConcat Pattern"+      PConcat [] -> cont+      PConcat ps -> foldr reflectParsec cont ps+      -- Greedy is the default+      PQuest p -> greedyOpt p cont+      PPlus p -> reflectParsec p (greedy p)+      PStar p -> greedy p+      PBound 0 Nothing p -> greedy p+      PBound i Nothing p | i>0 -> exact i p (greedy p)+                         | otherwise -> error $ "PBound with invalude parameters: "++show i++" and Nothing"+      PBound i (Just j) p | i==j -> exact i p cont+                          | 0<=i && i<j  -> exact i p (greedyTo p (j-i))+                          | otherwise -> error $ "PBound with invalude parameters: "++show i++" and "++show j+      -- Lazy+      PLazy (PQuest p) -> lazyOpt p cont+      PLazy (PPlus p) -> reflectParsec p (lazy p)+      PLazy (PStar p) -> lazy p+      PLazy (PBound 0 Nothing p) -> lazy p+      PLazy (PBound i Nothing p) | i>0 -> exact i p (lazy p)+                                 | otherwise -> error $ "PBound with invalude parameters: "++show i++" and Nothing"+      PLazy (PBound i (Just j) p) | i==j -> exact i p cont+                                  | 0<=i && i<j  -> exact i p (lazyTo p (j-i))+                                  | otherwise -> error $ "PBound with invalude parameters: "++show i++" and "++show j+-- Applying PLazy to non-repeating patterns makes no sense and is an error+      PLazy err -> error $ "PLazy applied to invalid pattern : "++show err+      -- Possessive+      PPossessive (PQuest p) -> possessiveOpt p+      PPossessive (PPlus p) -> reflectParsec p (possessive p)+      PPossessive (PStar p) -> possessive p+      PPossessive (PBound 0 Nothing p) -> possessive p+      PPossessive (PBound i Nothing p) | i>0 -> exactPos i p (possessive p)+                                       | otherwise -> error $ "PBound with invalude parameters: "++show i++" and Nothing"+      PPossessive (PBound i (Just j) p) | i==j -> exactPos i p cont+                                        | 0<=i && i<j  -> exactPos i p (possessiveTo p (j-i))+                                        | otherwise -> error $ "PBound with invalude parameters: "++show i++" and "++show j+-- Applying PPossessive to other patterns makes sense, so instead of+-- an error...+--    PPossessive err -> error $ "PPossessive applied to invalid pattern : "++show err+-- ...the pattern is handled by giving a (reOk) continuation.+-- This will prevent backtracking to any 'try' statements created by+-- reflectParsec p once all of p matches.+      PPossessive p -> reflectParsec p (reOk) >> cont+++-- The operations below actually check the input for a match, accept+-- valid characters, and advance the state+      PDot -> if multi then parseChar (noneOf "\n") >> cont+                       else parseChar anyChar >> cont+      PAny patset -> if sensitive+                       then let chars = Set.toList . decodePatternSet $ patset+                            in parseChar (oneOf chars) >> cont+                       else let chars = nub . sort $ concatMap ($ Set.toList (decodePatternSet patset)) [map toLower,map toUpper]+                            in parseChar (oneOf chars) >> cont+      PAnyNot patset -> if sensitive+                          then let chars = Set.toList . decodePatternSet $ patset+                               in parseChar (noneOf chars) >> cont+                          else let chars = nub . sort $ concatMap ($ Set.toList (decodePatternSet patset)) [map toLower,map toUpper]+                               in parseChar (noneOf chars) >> cont+      PEscape c -> acceptChar c >> cont+      PBack i -> if captureG+                   then do maybeSubP <- lookupSubP i+                           case maybeSubP of Nothing -> unexpected ("Cannot find subexpression \\"++show i)+                                             Just sub -> acceptString sub >> cont+                   else error "Pattern with back reference used with RegexOption captureGroups set to False"+      PChar c -> acceptChar c >> cont+      PString s -> acceptString s >> cont++    where+      -- Define longestMatch for Find_LongestMatch+      howFar branch = lookAhead (do result <- try branch+                                    len <- lookupAccepted+                                    subs <- lookupSubsP+                                    saveGame <- getParserState+                                    return (Just (len,subs,(saveGame,result))))+                      <|> return Nothing+      -- Who to copy?  I'll choose http://www.boost.org/libs/regex/doc/faq.html+      -- This is also from http://www.opengroup.org/onlinepubs/009695399/xrat/xbd_chap09.html+      -- This implements leftmost-longest rule for each subexpression in order of group #.+      compareSubs s1 s2 =+        let s1s = I.toAscList s1+            s2s = I.toAscList s2+            check [] [] = EQ -- neither is "better" than the other+            check _  [] = GT -- x is more defined, so is "better"+            check [] _  = LT -- y is more defined, so is "better"+            check ((xKey,(_,(xOff,xLen))):xs) ((yKey,(_,(yOff,yLen))):ys) =+              case compare xKey yKey of+                LT -> GT -- x is more defined, so is "better"+                GT -> LT -- y is more defined, so is "better"+                EQ -> case compare xOff yOff of+                        LT -> GT -- x is leftmost, so is "better"+                        GT -> LT -- y is leftmost, so is "bettern+                        EQ -> case compare xLen yLen of+                                GT -> GT -- x is longer, so is "better"+                                LT -> LT -- y is longer, so is "better"+                                EQ -> check xs ys -- x==y, apply recursion+        in check s1s s2s+      longestMatch branches = do+        allFar <- mapM howFar branches+        let best = foldl maxFst Nothing allFar+            maxFst a Nothing = a+            maxFst Nothing b = b+            maxFst a@(Just (aL,aS,_)) b@(Just (bL,bS,_)) =+              case compare aL bL of+                GT -> a -- a is longer, so is "better"+                LT -> b -- b is longer, so is "better"+                EQ -> case compareSubs aS bS of+                        GT -> a -- aS is "better"+                        LT -> b -- bS is "better"+                        EQ -> a  -- break tie in favor of leftmost branch+        case best of Nothing -> pzero+                     Just (_,_,(saveGame,result)) -> do setParserState saveGame+                                                        return result+{-+      longestMatch branches = do+        allFar <- mapM howFar branches+        let best = foldl maxFst Nothing allFar+            maxFst a Nothing = a+            maxFst Nothing b = b+            maxFst a@(Just (aL,_,_)) b@(Just (bL,_,_)) =+              case compare aL bL of+                GT -> a -- a is longer, so is "better"+                LT -> b -- b is longer, so is "better"+                EQ -> a -- break ties to the left+        case best of Nothing -> pzero+                     Just (_,_,(saveGame,result)) -> do setParserState saveGame+                                                        return result+-}+      -- Define allBranches for Find_All+      (<||>) = case find of+                 Find_LongestMatch -> \a b -> longestMatch [a,b]+                 _ -> undefined+      -- Provide shortcut to 'cont' when 'cps' matches zero characters and same Subs are in effect+      -- This effectively brackets the matching of cps.+      whenNull cps c = do before <- lookupAccepted+                          beforeSubs <- lookupSubsP+                          cps (do +                            after <- lookupAccepted+                            if after > before +                              then c -- progress+                              else do +                                afterSubs <- lookupSubsP+                                if eqSubs afterSubs beforeSubs+                                  then cont -- shortcut+                                  else c)+      -- p{i} p{i,i}  There is no attempt to short-circuit accepting "" here+      exact i p cont' = foldr reflectParsec cont' (replicate i p)+      exactPos i p cont' = let p' = reflectParsec p (reOk)+                           in replicateM_ i p' >> cont'+      -- main p? p?* p?+ when you don't worry about accepting ""+      greedyOpt      p c = try (reflectParsec p c) <||> cont+      lazyOpt        p c = try cont                <||> (reflectParsec p c)+      possessiveOpt  p   = optional (reflectParsec p (reOk)) >> cont+      possessiveOpt' p c = (try (reflectParsec p (reOk)) >> c) <||> cont+      -- helper p? p?* p?+ when you are worried about accepting ""+      greedySafe     p c = try (whenNull (reflectParsec p) c) <||> cont+      lazySafe       p c = try cont <||> whenNull (reflectParsec p) c+      possessiveSafe p c = whenNull (try (reflectParsec p (reOk)) >>) c+      -- p* p*? p*++      greedy     p = if cannotMatchNull p then fix (greedyOpt p)      else fix (greedySafe p)+      lazy       p = if cannotMatchNull p then fix (lazyOpt p)        else fix (lazySafe p)+      possessive p = if cannotMatchNull p then fix (possessiveOpt' p) else fix (possessiveSafe p)+      -- p{0,n} p{0,n}? p{0,n}++      useTo n use = foldr ($) cont (replicate n use)+      greedyTo     p n = useTo n $ if cannotMatchNull p then greedyOpt p else greedySafe p+      lazyTo       p n = useTo n $ if cannotMatchNull p then lazyOpt p else lazySafe p+      possessiveTo p n = useTo n $ if cannotMatchNull p then possessiveOpt' p else possessiveSafe p+      -- Do bookeeping when advancing, check for case sensitivity option+      parseChar :: RegexParser userState Char -> RegexParser userState ()+      parseChar c = c >> incState+      acceptChar :: Char -> RegexParser userState ()+      acceptChar c = if sensitive then char c >> incState+                                  else foo c >> incState+      acceptString :: String -> RegexParser userState ()+      acceptString s = if (not sensitive) && (map toLower s /= map toUpper s)+                         then sequence (map foo s) >> plusState (length s)+                         else string s  >> plusState (length s)+      foo :: Char -> RegexParser userState Char+      foo c | toLower c /= toUpper c = oneOf [toLower c, toUpper c]+            | otherwise              = char c+      reOk = return []
+ Text/Regex/Parsec/Pattern.hs view
@@ -0,0 +1,368 @@+-- | This 'Text.Regex.Lazy.Pattern' module provides the 'Pattern' data+-- type and its subtypes.  This 'Pattern' type is used to represent+-- the parsed form of a Regular Expression and is syntax independent.+--+-- It is possible to construct values of 'Pattern' that are invalid+-- regular expressions.+module Text.Regex.Parsec.Pattern +    (Pattern(..)+    ,PatternSet(..)+    ,PatternSetCharacterClass(..),PatternSetCollatingElement(..),PatternSetEquivalenceClass(..)+    ,PatternIndex+    ,showPattern+    ,foldPattern,dfsPattern+    ,simplify+    ,backReferences,dfaClean+    ,alwaysOnlyMatchNull,cannotMatchNull+    ,hasFrontCarat,hasBackDollar) where++{- By Chris Kuklewicz, 2006. BSD License, see the LICENSE file. -}++-- import Control.Monad.State+import Data.List(intersperse,partition)+import qualified Data.Set as Set(toAscList,toList)+import Data.Set(Set)++data Pattern = PEmpty | PCarat | PDollar+             | PGroup  PatternIndex Pattern+--             | PGroup' PatternIndex (Maybe PatternIndex) Pattern -- used in longest match+             | POr     [Pattern]+             | PConcat [Pattern]+             | PQuest  Pattern+             | PPlus   Pattern+             | PStar   Pattern+             | PBound  Int (Maybe Int) Pattern+             -- | PLazy indicates the pattern should find the shortest match first+             | PLazy   Pattern    -- non-greedy wrapper (for ?+*{} followed by ?)+             -- | PPossessive indicates the pattern can only find the longest match+             | PPossessive Pattern -- possessive modifier (for ?+*{} followed by +)+             | PDot               -- Any character (newline?) at all+             | PAny    PatternSet -- Square bracketed things+             | PAnyNot PatternSet -- Inverted square bracketed things+             | PEscape Char       -- Backslashed Character+             | PBack   PatternIndex -- Backslashed digits as natural number+             | PChar   Char       -- Specific Character+               -- After simplify / mergeCharToString, adjacent PChar are merge'd into PString+             | PString String+               deriving (Eq,Show)++showPattern :: Pattern -> String+showPattern pIn =+  case pIn of+    PEmpty -> "()"+    PCarat -> "^"+    PDollar -> "$"+    PGroup _ p -> ('(':showPattern p)++")"+    POr ps -> concat $ intersperse "|" (map showPattern ps)+    PConcat ps -> concatMap showPattern ps+    PQuest p -> (showPattern p)++"?"+    PPlus p -> (showPattern p)++"+"+    PStar p -> (showPattern p)++"*"+    PLazy p | isPostAtom p -> (showPattern p)++"?"+            | otherwise -> "<Cannot print PLazy of "++show p++">"+    PPossessive p | isPostAtom p -> (showPattern p)++"+"+                  | otherwise -> "<Cannot print PPossessive of "++show p++">"+    PBound i (Just j) p | i==j -> showPattern p ++ ('{':show i)++"}"+    PBound i mj p -> showPattern p ++ ('{':show i) ++ maybe ",}" (\j -> ',':show j++"}") mj+    PDot -> "."+    PAny (PatternSet s scc sce sec) ->+        let (special,normal) = maybe ("","") ((partition (`elem` "]-")) . Set.toAscList) s+            charSpec = (if ']' `elem` special then (']':) else id) (byRange normal)+            scc' = maybe "" ((concatMap (\ss -> "[:"++unSCC ss++":]")) . Set.toList) scc+            sce' = maybe "" ((concatMap (\ss -> "[."++unSCE ss++".]")) . Set.toList) sce+            sec' = maybe "" ((concatMap (\ss -> "[="++unSEC ss++"=]")) . Set.toList) sec+        in concat ['[':charSpec,scc',sce',sec',if '-' `elem` special then "-]" else "]"]+    PAnyNot (PatternSet s scc sce sec) ->+        let (special,normal) = maybe ("","") ((partition (`elem` "]-")) . Set.toAscList) s+            charSpec = (if ']' `elem` special then (']':) else id) (byRange normal)+            scc' = maybe "" ((concatMap (\ss -> "[:"++unSCC ss++":]")) . Set.toList) scc+            sce' = maybe "" ((concatMap (\ss -> "[."++unSCE ss++".]")) . Set.toList) sce+            sec' = maybe "" ((concatMap (\ss -> "[="++unSEC ss++"=]")) . Set.toList) sec+        in concat ["[^",charSpec,scc',sce',sec',if '-' `elem` special then "-]" else "]"]+    PEscape c -> '\\':c:[]+    PBack i -> '\\':(show i)+    PChar c -> [c]+    PString s -> s+  where byRange xAll@(x:xs) | length xAll <=3 = xAll+                            | otherwise = groupRange x 1 xs+        byRange _ = undefined+        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)):[]+++data PatternSet = PatternSet (Maybe (Set Char))  (Maybe (Set (PatternSetCharacterClass)))+   (Maybe (Set PatternSetCollatingElement)) (Maybe (Set PatternSetEquivalenceClass)) deriving (Eq,Show)++newtype PatternSetCharacterClass   = PatternSetCharacterClass   {unSCC::String} deriving (Eq,Ord,Show) -- [: :]+newtype PatternSetCollatingElement = PatternSetCollatingElement {unSCE::String} deriving (Eq,Ord,Show) -- [. .]+newtype PatternSetEquivalenceClass = PatternSetEquivalenceClass {unSEC::String} deriving (Eq,Ord,Show) -- [= =]++-- | PatternIndex is for indexing submatches from  parenthesized groups (PGroup)+type PatternIndex = Int++-- helper function+isPostAtom :: Pattern -> Bool+isPostAtom p = case p of+                 PQuest _ -> True+                 PPlus _ -> True+                 PStar _ -> True+                 PBound _ _ _ -> True+                 _ -> False+       +-- -- -- Transformations on Pattern++simplify :: Pattern -> Pattern+simplify = dfsPattern simplify'++foldPattern :: (Pattern -> a -> a) -> a -> Pattern -> a+foldPattern f = foldP+  where foldP a pIn = let unary p = f pIn (f p a) in+          case pIn of+            POr ps -> f pIn (foldr (flip foldP) a ps)      -- was foldr f+            PConcat ps -> f pIn (foldr (flip foldP) a ps)  -- was foldr f+            PGroup _ p -> unary p+            PQuest p -> unary p+            PPlus p -> unary p+            PStar p -> unary p+            PLazy p -> unary p+            PPossessive p -> unary p+            PBound _ _ p -> unary p+            _ -> f pIn a++-- | Apply a Pattern transfomation 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+       children c = f . c . (map dfs)+       dfs pattern = case pattern of+                       PGroup i p -> unary (PGroup i) p+                       POr ps -> children POr ps                  -- f (POr (map dfs ps))+                       PConcat ps -> children PConcat ps          -- f (PConcat (map dfs ps))+                       PQuest p -> unary PQuest p+                       PPlus p -> unary PPlus p+                       PStar p -> unary PStar p+                       PLazy p -> unary PLazy p+                       PPossessive p -> unary PPossessive p+                       PBound i mi p -> unary (PBound i mi) p+                       _ -> f pattern+++++++-- | Function to flatten nested POr or nested PConcat applicataions.+-- Other patterns are returned unchanged+flatten :: Pattern -> [Pattern]+flatten (POr ps) = (concatMap (\x -> case x of+                                       POr ps' -> ps'+                                       p -> [p]) ps)++flatten (PConcat ps) = (concatMap (\x -> case x of+                                           PConcat ps' -> ps'+                                           p -> [p]) ps)+flatten _ = []++-- | Function to transform a pattern into an equivalent, but less+-- redundant form+simplify' :: Pattern -> Pattern+simplify' x@(POr _) = +  let ps' = flatten x+  in case ps' of+       [] -> PEmpty+       [p] -> p+       _ -> POr ps'++simplify' x@(PConcat _) =+  let ps'' = mergeCharToString (filter notPEmpty (flatten x))+      notPEmpty PEmpty = False+      notPEmpty _ = True+      mergeCharToString :: [Pattern] -> [Pattern]+      mergeCharToString ps = merge ps+        where merge ((PChar c1):(PChar c2):xs) = merge $ (PString [c1,c2]):xs+              merge ((PString s):(PChar c):xs) = merge $ (PString (s++[c])):xs+              merge ((PString s1):(PString s2):xs) = merge $ (PString (s1++s2)):xs+              merge ((PChar c):(PString s):xs) = merge $ (PString (c:s)):xs+              merge (y:ys) = y:merge ys+              merge [] = []+  in case ps'' of+       [] -> PEmpty+       [p] -> p+       _ -> PConcat ps''++simplify' (PBound _ (Just 0) _) = PEmpty  -- May erase a PGroup, but who cares?++simplify' other = other++-- -- Analyze Pattern++-- | This provides an unordered list of the PatternIndex values that+-- have back references in the pattern.  This does not mean the+-- pattern will have these captured substrings, just that the pattern+-- referes to these indices.+backReferences :: Pattern -> [PatternIndex]+backReferences = foldPattern f []+  where f (PBack x) xs = (x:xs)+        f _ xs = xs++-- | Determines if pIn will always accept [] and never accept any characters+-- Treat PCarat and PDollar as False, since they do not always accept []+-- Trest PBack as False since the capture may not always be []+alwaysOnlyMatchNull :: Pattern -> Bool+alwaysOnlyMatchNull pIn =+  case pIn of+    PEmpty -> True+    PCarat -> False+    PDollar -> False+    PGroup _ p -> alwaysOnlyMatchNull p+    POr [] -> True+    POr ps -> all alwaysOnlyMatchNull ps+    PConcat [] -> True+    PConcat ps -> all alwaysOnlyMatchNull ps+    PLazy p -> alwaysOnlyMatchNull p+    PPossessive p -> alwaysOnlyMatchNull p+    PQuest p -> alwaysOnlyMatchNull p+    PPlus p -> alwaysOnlyMatchNull p+    PStar p -> alwaysOnlyMatchNull p+    PBound _ (Just 0) _ -> True+    PBound _ _ p -> alwaysOnlyMatchNull p+    PBack _ -> False+    _ ->False++-- | If 'cannotMatchNull' returns 'True' then it is known that the+-- 'Pattern' will never accept an empty string.  If 'cannotMatchNull'+-- returns 'False' then it is possible but not definite that the+-- 'Pattern' could accept an empty string.  'PBack' is 'False' since+-- it may sometimes be [].+cannotMatchNull :: Pattern -> Bool+cannotMatchNull pIn =+  case pIn of+    PEmpty -> False+    PCarat -> False+    PDollar -> False+    PGroup _ p -> cannotMatchNull p+    POr [] -> False+    POr ps -> all cannotMatchNull ps+    PConcat [] -> False+    PConcat ps -> any cannotMatchNull ps+    PLazy p -> cannotMatchNull p+    PPossessive p -> cannotMatchNull p+    PQuest _ -> False+    PPlus p -> cannotMatchNull p+    PStar _ -> False+    PBound 0 _ _ -> False+    PBound _ _ p -> cannotMatchNull p+    PBack _ -> False+    _ -> True++-- | Determines if pIn is always anchored at the front with PCarat+hasFrontCarat,hasBackDollar,dfaClean::Pattern -> Bool+hasFrontCarat pIn =+  case pIn of+    PCarat -> True+    POr [] -> False+    POr ps -> all hasFrontCarat ps+    PConcat [] -> False+    PConcat ps -> case dropWhile alwaysOnlyMatchNull ps of+                    [] -> False+                    (p:_) -> hasFrontCarat p+    _ -> False++-- | Determines if pIn is always anchored at then back with PDollar+hasBackDollar pIn =+  case pIn of+    PDollar -> True+    POr [] -> False+    POr ps -> all hasBackDollar ps+    PConcat [] -> False+    PConcat ps -> case dropWhile alwaysOnlyMatchNull (reverse ps) of+                    [] -> False+                    (p:_) -> hasBackDollar p+    _ -> False++-- | Determines if the pattern has no lazy modifiers, possessive+-- modifiers, carats, dollars, or back references.+-- +-- If so, then the pattern could be tranformed into a simple DFA.+dfaClean pIn = foldPattern f True pIn+  where f p b = case p of+                  PLazy _ -> False+                  PPossessive _ -> False+                  PCarat -> False+                  PDollar -> False+                  PBack _ -> False+                  _ -> b++{-+isGroupFree :: Pattern -> Bool+isGroupFree pIn = foldPattern f True pIn+  where f (PGroup _ _) _ = False+        f (PGroup' _ _ _) _ = False+        f _ b = b++toPGroup' :: Pattern -> (Pattern,Int)+toPGroup' p = runState (regroup p) 1++regroup :: Pattern -> State Int Pattern+regroup pIn =+  if isGroupFree pIn+    then wrap pIn+    else case pIn of+           PGroup i p -> do n <- newIndex+                            p' <- resub p+                            return (PGroup' n (Just i) p')+           PGroup' _ _ _ -> error "toGroup' is being run more than once"+           POr ps -> liftM POr (mapM regroup ps)+           PConcat ps -> do ps' <- recat ps+                            return $ case ps' of+                                       [] -> PEmpty+                                       [p] -> p+                                       _ -> PConcat ps'+           PQuest p -> unary PQuest p+           PPlus p -> unary PPlus p+           PStar p -> unary PStar p+           PBound i j p -> unary (PBound i j) p+           PLazy p -> unary PLazy p+           PPossessive p -> unary PPossessive p+           _ -> wrap pIn+  where unary f p = liftM f (regroup p)+        newIndex = do s <- get+                      put $! succ s+                      return s+        wrap p = do n <- newIndex+                    return (PGroup' n Nothing p)+        isGroup (PGroup _ _) = True+        isGroup _ = False+        recat [] = return []+        recat xs = case break isGroup xs of+                     ([],g:rest) -> liftM2 (:) (regroup g) (recat rest)+                     (ps,[]) -> liftM (:[]) (wrap (PConcat ps))+                     (ps,g:rest) -> liftM3 (\a b c -> a:b:c) (wrap (PConcat ps)) (regroup g) (recat rest)++resub :: Pattern -> State Int Pattern+resub p =+  case p of+    PGroup i p' -> do n <- newIndex+                      p'' <- resub p'+                      return (PGroup' n (Just i) p'')+    PGroup' _ _ _ -> error "toGroup' is being run more than once"+    POr ps -> children POr ps+    PConcat ps -> children PConcat ps+    PQuest p' -> unary PQuest p'+    PPlus p' -> unary PPlus p'+    PStar p' -> unary PStar p'+    PBound i j p' -> unary (PBound i j) p'+    PLazy p' -> unary PLazy p'+    PPossessive p' -> unary PPossessive p'+    _ -> return p+  where unary f p' = liftM f (resub p')+        children f ps = liftM f (mapM resub ps)+        newIndex = do s <- get+                      put $! succ s+                      return s+-}
+ Text/Regex/Parsec/ReadRegex.hs view
@@ -0,0 +1,187 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+-- | 'ReadRegex' parses string regular expressions with all the+-- extensions : lazy and possessive modifiers and back-references.+--+-- "man re_format" on OS X 10.4.4 was the guide for most of the format+-- (the new extended format, not the old basic format).  Currently,+-- only word-boundaries are not recognized and handled.+-- +module Text.Regex.Parsec.ReadRegex+  (PatternIndex+  ,parseRegex+  ,legalCharacterClasses+  ,decodePatternSet+  ,p_regex) where++import Text.Regex.Parsec.Common(StringRegex)+import Text.Regex.Parsec.Pattern(+  Pattern(PStar, PQuest, PPossessive, PPlus, POr, PLazy, PGroup,+    PEscape, PEmpty, PDot, PDollar, PConcat, PChar, PCarat, PBound,+    PBack, PAnyNot, PAny),+  PatternIndex, PatternSetEquivalenceClass(..),+  PatternSetCollatingElement(PatternSetCollatingElement),+  PatternSetCharacterClass(PatternSetCharacterClass), PatternSet(..))+import Text.ParserCombinators.Parsec((<|>), (<?>), updateState,+  unexpected, try, runParser, many, getState, GenParser, ParseError,+  sepBy1, option, notFollowedBy, many1, lookAhead, eof, between,+  string, noneOf, digit, char, anyChar)+import Control.Monad(liftM, when, guard)+import Data.Set(Set)+import qualified Data.Set as Set(fromList, toList, insert, empty, Set)++-- BracketElement is internal only+data BracketElement = BEChar Char | BEChars String | BEColl String | BEEquiv String | BEClass String++-- | This runs the p_regex parser on the input string (with initial+-- state 0), and returns (Left ParseError) on failure or Right+-- (Pattern,PatternIndex) where the PatternIndex is the number of+-- parenthesized subgroups in the Pattern (i.e. the final state of the+-- parser).  If the entire input is not consumed then 'parseRegex'+-- returns a parse error.  If you need to parse a regular expression+-- that is not the entire input string then you will need to utilize+-- p_regex.+parseRegex :: StringRegex -> Either ParseError (Pattern,PatternIndex)+parseRegex x = runParser (do pat <- p_regex+                             eof+                             subs <- getState+                             return (pat,subs)) 0 x x++-- | This is the Parsec parser that performs the interpretation. The+-- state is a PatternIndex which is incremented and read (in that+-- order) to assign a unique 'PatternIndex' to each parenthesized+-- group.  It does not check that the regex is followed by the end of+-- the input.+p_regex :: GenParser Char PatternIndex Pattern+p_regex = liftM POr $ sepBy1 p_branch (char '|')++-- man re_format helps alot, it says one-or-more pieces so this uses+-- many1 instead of many.  Use "()" to indicate an empty piece.+p_branch = liftM PConcat $ many1 p_piece++p_piece = (p_anchor <|> p_atom) >>= p_post_atom++p_anchor = (char '^' >> return PCarat)+       <|> (char '$' >> return PDollar)+       <?> "empty () or anchor ^ or $"++p_atom =  p_empty <|> p_group <|> p_bracket <|> p_char <?> "an atom"++p_empty = try (do string "()" +                  index <- updateState (+1) >> getState+                  return $ PGroup index PEmpty)++p_group = lookAhead (char '(') >> do+  index <- updateState (+1) >> getState+  liftM (PGroup index) $ between (char '(') (char ')') p_regex++-- p_post_atom takes the previous atom as a parameter+p_post_atom atom = ( ( (char '?' >> return (PQuest atom))+                   <|> (char '+' >> return (PPlus  atom))+                   <|> (char '*' >> return (PStar  atom))+                   <|> p_bound atom) >>= p_post_atom_ng) <|> (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 +                                   char ','+                                   highS <- many digit+                                   if null highS then return Nothing -- no upper bound+                                     else do let highI = read highS+                                             guard (lowI <= highI)+                                             return (Just (read highS))+                       return (PBound lowI highMI atom)++-- Look for another '?' to make into a Lazy matcher (non-greedy)+p_post_atom_ng atom = ((char '?' <?> "lazy ? modifier") >> return (PLazy atom))+                  <|> ((char '+' <?> "possessive + modifier") >> return (PPossessive atom))+                  <|> return atom++p_char = p_dot <|> p_left_brace <|> p_escaped <|> p_other_char+    where p_dot = char '.' >> return PDot+          p_left_brace = try $ (char '{' >> notFollowedBy digit >> return (PChar '{'))+          p_escaped = char '\\' >> (liftM (PBack . read) (many1 digit) <|> liftM PEscape anyChar)+          p_other_char = liftM PChar (noneOf specials)+          specials  = "^.[$()|*+?{\\"++-- parse [bar] and [^bar] sets of characters+p_bracket = (char '[') >> ( (char '^' >> p_set True) <|> (p_set False) )++-- p_set does not support [.ch.] or [=y=] or [:foo:]+p_set :: Bool -> GenParser Char st Pattern+p_set invert = do initial <- (option "" ((char ']' >> return "]") <|> (char '-' >> return "-")))+                  values <- many1 p_set_elem+                  char ']'+                  let chars = maybe'set $ initial ++ [c | BEChar c <- values ] ++ concat [s | BEChars s <- 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]+                      maybe'set x = if null x then Nothing else Just (Set.fromList x)+                      sets = PatternSet chars class's colls equivs+                  sets `seq` return $ if invert then PAnyNot sets else PAny sets++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_class = liftM BEClass $+  try (between (string "[:") (string ":]") (many1 $ noneOf ":]"))++p_set_elem_equiv = liftM BEEquiv $+  try (between (string "[=") (string "=]") (many1 $ noneOf "=]"))++p_set_elem_coll =  liftM BEColl $+  try (between (string "[.") (string ".]") (many1 $ noneOf ".]"))++p_set_elem_range = try $ do +  start <- noneOf "]-"+  char '-'+  end <- noneOf "]"+  return (BEChars [start..end])++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)++-- | This takes a 'PatternSet' and returns 'Set' 'Char'.  The+-- character classes in legalCharacterClasses are expanded to their+-- members.+--+-- 'decodePatternSet' ignores collating element and treats equivalence+-- classes as just their defining character(s).+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.toList) mscc)+      withMSEC = foldl (flip Set.insert) withMSCC (maybe [] (concatMap unSEC . Set.toList) msec)+  in withMSEC++-- | This is the list of [:foo:] character classes that are recognized+-- by decodePatternSet.  This is the whole list including the+-- "word" extension which is "alnum" and the underscore '_' character.+--+-- The NUL character is included as part of the "cntrl" character class.+legalCharacterClasses :: [String]+legalCharacterClasses = ["alnum","digit","punct","alpha","graph"+  ,"space","blank","lower","upper","cntrl","print","xdigit","word"]++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']++"_"+    _ -> []
+ Text/Regex/Parsec/RegexParsecState.hs view
@@ -0,0 +1,224 @@+{-# OPTIONS -funbox-strict-fields #-}+-- | The Parsec parser needs to keep track of various state+-- information while matching a regular expression.  This includes the+-- number of accepted characters and the in-progross and completed+-- substring matches.  This module defines that state and some+-- convenience functions.+--+-- A user defined state can be maintained via newState, getUserState,+-- setUserState, and updateUserState.+--+-- The 'FullState' type is opaque, allowing for better abstraction.+-- Note that calling stopSub when startSub has not been called will+-- trigger an 'error', and that initState/finalState call startSub+-- 0/stopSub 0 respectively.+module Text.Regex.Parsec.RegexParsecState +    (+ -- ** Create the full state of the parsec parser+     initState,finalState,newState,initStateP,finalStateP+ -- ** Manipulate the user state of the parser+    ,getUserState,setUserState,updateUserState+ -- ** Manupulate the accepted character counter+    ,incState,plusState,lookupAccepted+-- ** Compare Matched Strings+    ,eqSubs+ -- ** Manipulate the captured substrings, PCRE style+    ,startSub,stopSub,lookupSub,lookupSubs+ -- ** Manipulate the captured substrings, Posix style+    ,startSubP,stopSubP,lookupSubP,lookupSubsP+    ) where++{- By Chris Kuklewicz, 2006. BSD License, see the LICENSE file. -}++import Text.Regex.Parsec.Common(RegexParser, MatchedStrings, FullState(..), Opened(..), Closed(..))+import Text.ParserCombinators.Parsec(updateState, setState, getState, getInput)+import Control.Monad(liftM)+import qualified Data.IntMap as I(fromAscList,toAscList, updateLookupWithKey,insert, empty, lookup)++trace :: a -> b -> b+trace _ b = b++-- | 'initState' forgets all substring matching (in-progress or+-- complete) and starts sub 0 (the whole match).  This operation+-- preserves the user state and accepted character count+initState :: RegexParser userState ()+initState = do -- keep only userState and accepted, reset capture+  updateState $ \state -> state {openSub = I.empty, closedSub = I.empty,posixSub = EndOpened []}+  startSub 0++initStateP :: RegexParser userState ()+initStateP = do -- keep only userState and accepted, reset capture+  updateState $ \state -> state {openSub = I.empty, closedSub = I.empty,posixSub = EndOpened []}+  startSubP 0++-- | 'finalState' stops sub 0 (the whole match) and returns an IntMap+-- of all the completed substring matches.  Any in-progress matches+-- are ignored.+finalState :: RegexParser userState MatchedStrings+finalState = do stopSub 0+                lookupSubs++-- | 'finalState' stops sub 0 (the whole match) and returns an IntMap+-- of all the completed substring matches.  Any in-progress matches+-- are ignored.+finalStateP :: RegexParser userState MatchedStrings+finalStateP = do stopSubP 0+                 lookupSubsP++-- | This takes a value of the user state and returns the full parsec+-- state with zero accepted characters to n and no in-progress or completed+-- substring matches.+newState :: Int -> userState -> FullState userState+newState n user = FullState {userState = user+                            ,accepted = n+                            ,posixSub = EndOpened []+                            ,openSub = I.empty+                            ,closedSub = I.empty}++-- | This returns the value of the user state+getUserState :: RegexParser userState userState+getUserState = liftM userState getState++-- | The replaces the user state with the provided value+setUserState :: userState -> RegexParser userState ()+setUserState user = do state <- getState+                       setState $ state {userState = user}++-- | This applies the given function to the current value of the user state+updateUserState :: (userState -> userState) -> RegexParser userState ()+updateUserState f = updateState (\state@FullState{userState=user}->state{userState=f user})++-- | This adds one to the number of accepted characters+incState :: RegexParser userState ()+incState = updateState (\state@(FullState {accepted=pos})->state {accepted=succ pos})++-- | This adds the provided number to the count of accepted characters+plusState :: Int -> RegexParser userState ()+plusState n = updateState (\state@(FullState {accepted=pos})->state {accepted=n + pos})+++-- | 'lookupAccepted' return the number of accepted input characters.+-- This is typicaly counted from the call to initState.+lookupAccepted :: RegexParser userState Int+lookupAccepted = liftM accepted getState++-- | Called with PatternIndex i, this makes the i'th substring match+-- inprogress and marks the start of the i'th substring match at the+-- current position.  This does affect any value for the completed+-- i'th substring match.+startSub :: Int -> RegexParser userState ()+startSub i = do +  state@(FullState {accepted=n,openSub=open}) <- getState+  here <- getInput+  let open' = I.insert i (here,n) open+      state' = state {openSub = open'}+  setState state'++-- | Called with PatternIndex i, this captures the input from point+-- where startSub i was called until the current location.  It removes+-- the in-progress i'th substring and sets the i'th completed+-- substring to the new value, overwriting any previous value.+--+-- The completed value is available from lookupSub i or in the map+-- provided by lookupSubs.+--+-- If the i'th substring is not open when this is called then stopSub+-- will call 'error'.+stopSub :: Int -> RegexParser userState ()+stopSub i = do+  state@(FullState {accepted=n,openSub=open,closedSub=closed}) <- getState+  let (mEntry,open') = I.updateLookupWithKey del i open+      del _ _ = Nothing+  case mEntry of+    Nothing -> error ("RegexParsecState: Could not closeSub "++show i)+    Just (here,pos) -> let len = n-pos+                           sub = take len here+                           closed' = I.insert i (sub,(pos,len)) closed+                           state' = state {openSub=open',closedSub=closed'}+                       in setState state'++-- | 'lookupSub' i returns Just the completed captured between 'startSub'+-- i and 'stopSub' i or Nothing if there has been no capture.+lookupSub :: Int -> RegexParser userState (Maybe String)+lookupSub i = do msol <- liftM ((I.lookup i).closedSub) getState+                 case msol of+                   Nothing -> return Nothing+                   Just (sub,_) -> return (Just sub)++-- | 'lookupSubs' returns an IntMap of all the completed substring captures.+lookupSubs :: RegexParser userState MatchedStrings+lookupSubs = liftM closedSub getState++eqSubs :: MatchedStrings -> MatchedStrings -> Bool+eqSubs a b = let a' = map (\ (k,(_,ol)) -> (k,ol)) . I.toAscList $ a+                 b' = map (\ (k,(_,ol)) -> (k,ol)) . I.toAscList $ b+             in a' == b'++startSubP :: Int -> RegexParser userState ()+startSubP i = trace ("startSub: "++show i) $ do+  state@(FullState {accepted=pos,posixSub=sub}) <- getState+  trace (">startSubP "++show i++" : "++show sub) $ return ()  +  here <- getInput+  let sub' = +        case sub of+          Opened closed j dat next ->+            case break (\(Closed _ k _)->i==k) closed of+              (_,[]) -> Opened [] i (here,pos) sub+              (_,_:closed') -> Opened [] i (here,pos) (Opened closed' j dat next)+          EndOpened closed ->+            case break (\(Closed _ k _)->i==k) closed of+              (_,[]) -> Opened [] i (here,pos) sub+              (_,_:closed') -> Opened [] i (here,pos) (EndOpened closed')+  setState (state {posixSub=sub'})+  trace ("<startSubP "++show i++" : "++show sub') $ return ()  ++stopSubP :: Int -> RegexParser userstate ()+stopSubP i = trace ("stopSub: "++show i) $ do+  state@(FullState {accepted=pos',posixSub=sub}) <- getState+  trace (">stopSubP "++show i++" : "++show sub) $ return ()  +  let sub' =+        case sub of+          Opened closed j (here,pos) next | j==i ->+            let len = pos'-pos+                capture = Closed closed i (take len here,(pos,len))+            in case next of+                 Opened closed' j' dat' next' ->+                   Opened (capture:closed') j' dat' next'+                 EndOpened closed' ->+                   EndOpened (capture:closed')+                                          | otherwise ->+            error ("Malformed nesting when stopSubP group #"++show i++" when Opened group was #"++show j)+          EndOpened _ -> error ("Malformed nesting when stopSubP group #"++show i++" when Opened group was EndOpened")+  setState (state {posixSub=sub'})+  trace ("<stopSubP "++show i++" : "++show sub') $ return ()  ++lookupSubP :: Int -> RegexParser userstate (Maybe String)+lookupSubP i =+  let fetchOpen (EndOpened closed) = fetchClosed closed+      fetchOpen (Opened greater j (string,_) lesser) =+        case compare i j of+          GT -> fetchClosed greater+          EQ -> Just string+          LT -> fetchOpen lesser+      fetchClosed [] = Nothing+      fetchClosed (Closed greater j (string,_) : lesser) =+        case compare i j of+          GT -> fetchClosed greater+          EQ -> Just string+          LT -> fetchClosed lesser+  in trace ("lookupSub: "++show i) $ liftM (fetchOpen . posixSub) getState++lookupSubsP :: RegexParser userstate MatchedStrings+lookupSubsP = +  let traverseOpen acc (EndOpened closed) = traverseClosed acc closed+      traverseOpen acc (Opened greater _ _ lesser) =+        let acc' = traverseClosed acc greater+        in traverseOpen acc' lesser+      traverseClosed acc [] = acc+      traverseClosed acc (Closed greater j dat : lesser) =+        let acc' = (j,dat) : traverseClosed acc greater+        in traverseClosed acc' lesser+  in do (FullState {posixSub=sub}) <- getState+        let value = I.fromAscList . (traverseOpen []) $ sub +        trace ("lookupSubs " ++ show sub ++ "\n" ++ show value) $ return value+
+ Text/Regex/Parsec/Sequence.hs view
@@ -0,0 +1,92 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+{-|+This offers type class instances for 'RegexMaker' and+'RegexLike'. This is usually used via import "Text.Regex.Full".++It is worth noting that 'RegexMaker' and 'RegexLike' methods for+'ByteString' are built on those for 'String' except the default+'matchOnceText' and 'matchAllText' are used since they are already+efficient for use on 'ByteString' (and they use 'matchOnce' and+'matchAll').++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.+-}+module Text.Regex.Parsec.Sequence(+  -- ** Types+  Regex+ ,MatchOffset+ ,MatchLength+ ,CompOption(..)+ ,ExecOption(..)+  -- ** Medium level API functions+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array(Array,elems,accumArray)+import qualified Data.IntMap as I (toList,(!))+import Text.Regex.Parsec.Common(MatchedStrings)+import Text.Regex.Base.RegexLike(RegexMaker(..),RegexLike(..),RegexContext(..),MatchText,MatchArray,MatchOffset,MatchLength)+import Text.Regex.Parsec.Wrap(Regex(..),CompOption(..),ExecOption(..),wrapCompile,wrapMatch)+import Text.Regex.Parsec.String() -- build on these instances for RegexMaker and RegexLike+import Data.Sequence(Seq)+import Data.Sequence(ViewL(..))+import qualified Data.Sequence as S+import Text.Regex.Base.Impl(polymatch,polymatchM)++instance RegexContext Regex (Seq Char) (Seq Char) where+  match = polymatch+  matchM = polymatchM++instance RegexMaker Regex CompOption ExecOption (Seq Char) where+  makeRegexOpts opts e source = makeRegexOpts opts e (unpack source)+  makeRegexOptsM opts e source = makeRegexOptsM opts e (unpack source)++instance RegexLike Regex (Seq Char) where+  matchOnce r bs = matchOnce r (unpack bs)+  matchAll r bs = matchAll r (unpack bs)+  matchTest r bs = matchTest r (unpack bs)+  matchCount r bs = matchCount r (unpack bs)+-- Use default matchOnceText and matchAllText++{-# INLINE unpack #-}+unpack :: (Seq Char) -> String+unpack s = case S.viewl s of+             EmptyL -> []+             (h :< t) -> h : unpack t++compile  :: CompOption -- ^ Flags (summed together)+         -> ExecOption -- ^ Flags (summed together)+         -> (Seq Char) -- ^ The regular expression to compile+         -> Either String Regex -- ^ Returns: the compiled regular expression+compile c e bs = wrapCompile c e (unpack bs)++execute :: Regex      -- ^ Compiled regular expression+        -> (Seq Char) -- ^ (Seq Char) to match against+        -> Either String (Maybe (Array Int (MatchOffset,MatchLength)))+execute r@(Regex {groups=g}) bs = either Left (Right . (fmap (toArr g))) (wrapMatch 0 r (unpack bs))++regexec :: Regex      -- ^ Compiled regular expression+        -> (Seq Char) -- ^ (Seq Char) to match against+        -> Either String (Maybe ((Seq Char), (Seq Char), (Seq Char), [(Seq Char)]))+regexec r@(Regex {groups=g}) bs =+  case wrapMatch 0 r (unpack bs) of+    Left err -> Left err+    Right Nothing -> Right Nothing+    Right (Just ms) -> Right . Just $+      let (_,(o,l)) = ms I.! 0+      in (S.take o bs+         ,S.take l (S.drop o bs)+         ,S.drop (o+l) bs+         ,map (\(_,(o',l')) -> if (-1)==o' +                                 then S.empty+                                 else S.take l' (S.drop o' bs))+              (tail (elems (toMT g ms))))++toMT :: Int -> MatchedStrings -> MatchText String+toMT maxSubs ms =  accumArray (\_ new->new) ("",(-1,0)) (0,maxSubs) (I.toList ms)++toArr :: Int -> MatchedStrings -> MatchArray+toArr maxSubs ms = accumArray (\_ (_,ol)->ol) (-1,0) (0,maxSubs) (I.toList ms)
+ Text/Regex/Parsec/String.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+{-|+This offers type class instances for 'RegexMaker' and+'RegexLike'. This is usually used via import "Text.Regex.Full".++It is worth noting all methods in 'RegexLike' are re-implemented for+efficiency instead of taking the default definitions.++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.+-}+module Text.Regex.Parsec.String(+  -- ** Types+  Regex+ ,MatchOffset+ ,MatchLength+ ,CompOption(..)+ ,ExecOption(..)+  -- ** Medium level API functions+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array(Array,elems,accumArray)+import Text.Regex.Base.RegexLike(RegexMaker(..),RegexLike(..),RegexContext(..),MatchArray,MatchText,MatchOffset,MatchLength)+import Text.Regex.Parsec.Wrap(wrapTest,wrapCount,wrapMatch,wrapMatchAll,wrapCompile+                             ,Regex(Regex,groups),CompOption(..),ExecOption(..),MatchedStrings)+import qualified Data.IntMap as I (toList,(!))+import Text.Regex.Base.Impl(polymatch,polymatchM)++instance RegexContext Regex String String where+  match = polymatch+  matchM = polymatchM++instance RegexMaker Regex CompOption ExecOption String where+  makeRegexOpts opts e source = unwrap $+    wrapCompile opts e source+  makeRegexOptsM opts e source = either fail return $+    wrapCompile opts e source++instance RegexLike Regex String where+  matchTest r s =  unwrap $ wrapTest r s+  matchCount r s = unwrap $ wrapCount r s+  matchOnce r@(Regex {groups=g}) s =+    fmap (toArr g) (unwrap (wrapMatch 0 r s))+  matchOnceText r@(Regex {groups=g}) s =+    fmap (\mt -> let (_,(o,l)) = mt I.! 0+                 in (take o s,toMT g mt,drop (o+l) s) )+         (unwrap (wrapMatch 0 r s))+  matchAll r@(Regex {groups=g}) s = map (toArr g) (unwrap $ wrapMatchAll r s)+  matchAllText r@(Regex {groups=g}) s = map (toMT g) (unwrap $ wrapMatchAll r s)++unwrap :: Either String v -> v+unwrap x = case x of Left err -> error ("Text.Regex.Parsec.String died: "++ err)+                     Right v -> v++toArr :: Int -> MatchedStrings -> MatchArray+toArr maxSubs ms = accumArray (\_ (_,ol)->ol) (-1,0) (0,maxSubs) (I.toList ms)++toMT :: Int -> MatchedStrings -> MatchText String+toMT maxSubs ms =  accumArray (\_ new->new) ("",(-1,0)) (0,maxSubs) (I.toList ms)++compile  :: CompOption -- ^ Flags (summed together)+         -> ExecOption -- ^ Flags (summed together)+         -> String     -- ^ The regular expression to compile (ASCII only, no null bytes)+         -> Either String Regex -- ^ Returns: the compiled regular expression+compile = wrapCompile++execute :: Regex      -- ^ Compiled regular expression+        -> String     -- ^ String to match against+        -> Either String (Maybe (Array Int (MatchOffset,MatchLength)))+execute r@(Regex {groups=g}) s = either Left (Right . (fmap (toArr g))) (wrapMatch 0 r s)++regexec :: Regex      -- ^ Compiled regular expression+        -> String     -- ^ String to match against+        -> Either String (Maybe (String, String, String, [String]))+regexec r@(Regex {groups=g}) s =+  case wrapMatch 0 r s of+    Left err -> Left err+    Right Nothing -> Right Nothing+    Right (Just ms) -> Right . Just $+      let (main,(o,l)) = ms I.! 0+      in (take o s+         ,main+         ,drop (o+l) s+         ,map fst (tail (elems (toMT g ms))))
+ Text/Regex/Parsec/Wrap.hs view
@@ -0,0 +1,119 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+module Text.Regex.Parsec.Wrap(+  Regex(..),CompOption(..),ExecOption(..),(=~),(=~~),RegexOptionStrategy(..),+  MatchedStrings,wrapCompile,wrapMatch,wrapMatchAll,wrapCount,wrapTest) where++import Text.Regex.Base.RegexLike(RegexOptions(..),RegexMaker(..),RegexContext(..))+import Text.Regex.Parsec.Common(Regex(..),CompOption(..),RegexOptionStrategy(..),ExecOption(..),+                                StringRegex,MatchedStrings,FullState)+import Text.Regex.Parsec.ReadRegex(parseRegex)+import Text.Regex.Parsec.RegexParsecState(newState,updateUserState,getUserState,incState,lookupAccepted)+import Text.Regex.Parsec.FullParsec(patternToParsec,hasFrontCarat)+import Text.ParserCombinators.Parsec(GenParser,(<|>),option,runParser,getInput,try,anyChar,eof)++-- | This is a newtype of 'RegexOption' in "Text.Regex.Lazy.Common".++instance RegexOptions Regex CompOption ExecOption where+  blankCompOpt = CompOption {multiline = False+                            ,caseSensitive = True+                            ,captureGroups = True+                            ,strategy = Find_LongestMatch}+  defaultCompOpt = CompOption  {multiline = True+                               ,caseSensitive = True+                               ,captureGroups = True+                               ,strategy = Find_LongestMatch}+  blankExecOpt = ExecOption ()+  defaultExecOpt = ExecOption ()+  setExecOpts _ r = r+  getExecOpts _ = ExecOption ()++(=~) ::(RegexMaker Regex CompOption ExecOption source,RegexContext Regex source1 target) => source1 -> source -> target+(=~) x r = let q :: Regex+               q = makeRegex r+           in match q x++(=~~) ::(RegexMaker Regex CompOption ExecOption source,RegexContext Regex source1 target,Monad m) => source1 -> source -> m target+(=~~) x r = do (q :: Regex) <- makeRegexM r+               matchM q x++wrapCompile :: CompOption+            -> ExecOption+            -> StringRegex+            -> Either String Regex+wrapCompile options _ s =+  case parseRegex s of+    Left parseError -> Left (show parseError)+    Right (pat,maxSubs) ->+      let r0  = patternToParsec (options)  pat+          r1  = patternToParsec (options {captureGroups=False}) pat+          r2  = patternToParsec (options {strategy=Find_All})   pat+          r3  = patternToParsec (options {captureGroups=False}) pat -- Int+          r = Regex {asString=s,asPattern=pat+                    ,capture=r0,capture'=r0+                    ,noCapture=r1,noCapture'=r1+                    ,allMatches=r2,userInt=r3+                    ,frontAnchor=(hasFrontCarat pat) && (not (multiline options))+                    ,groups=maxSubs}+      in Right r++-- I think the above could be built on a "matchHere with offset" thing+wrapMatch :: Int -> Regex -> [Char] -> Either String (Maybe MatchedStrings)+wrapMatch index (Regex {capture=regex,frontAnchor=anchored}) source =+  let parser = (try regex) +           <|> (anyChar >> incState >> parser)+           <|> (eof >> return [])+      once = option [] (try regex)+      result = runParser (if anchored then once else parser) (newState index ()) "wrapMatch" source+  in case result of+       Left err -> Left (show err)+       Right [] -> Right Nothing+       Right (x:_) -> Right (Just x)++wrapMatchAll :: Regex -> [Char] -> Either String [MatchedStrings]+wrapMatchAll r@(Regex {capture=regex,frontAnchor=anchored}) source = +  let parser = (try regex >>= found)+           <|> (anyChar >> incState >> parser)+           <|> (eof >> return Nothing)+      found [] = return Nothing+      found (x:_) = do pos <- lookupAccepted+                       here <- getInput+                       return (Just (x,pos,here))+      loop acc pos here =+        let result = runParser parser (newState pos ()) "wrapMatchAll" here+        in case result of+             Left err -> Left (show err)+             Right Nothing -> Right (acc [])+             Right (Just (x,pos',here')) ->+               if pos'>pos+                 then loop (acc.(x:)) pos' here'+                 else Right (acc [x])+   in if anchored -- punt to wrapMatch+        then either Left (Right . (maybe [] (:[]))) (wrapMatch 0 r source)+        else loop id 0 source++wrapTest :: Regex -> [Char] -> Either String Bool+wrapTest (Regex {noCapture=regex,frontAnchor=anchored}) source =+  let parser = (try regex >> return True)+           <|> (anyChar >> parser)+           <|> (eof >> return False)+      once = option False (try regex >> return True)+      use :: GenParser Char (FullState ()) Bool+      use = if anchored then once else parser+      result = runParser use (newState 0 ()) "wrapTest" source+  in case result of+       Left err -> Left (show err)+       Right x -> Right x++wrapCount :: Regex -> [Char] -> Either String Int+wrapCount r@(Regex {userInt=regex,frontAnchor=anchored}) source =+  let parser = (try regex >> updateUserState succ >> parser)+           <|> (anyChar >> parser)+           <|> (eof >> getUserState)+  in if anchored -- punt to wrapMatch+       then case wrapMatch 0 r source of+              Left err -> Left err+              Right Nothing -> Right 0+              Right (Just _) -> Right 1+       else case runParser parser (newState 0 0) "wrapCount" source of+              Left err -> Left (show err)+              Right n -> Right n
+ regex-parsec.cabal view
@@ -0,0 +1,52 @@+Name:                   regex-parsec+Version:                0.90+-- Cabal-Version:       >=1.1.4+License:                BSD3+License-File:           LICENSE+Copyright:              Copyright (c) 2006, Christopher Kuklewicz+Author:                 Christopher Kuklewicz+Maintainer:             TextRegexLazy@personal.mightyreason.com+Stability:              Seems to work, passes a few tests+Homepage:               http://sourceforge.net/projects/lazy-regex+Package-URL:            http://darcs.haskell.org/packages/regex-unstable/regex-parsec/+Synopsis:               Replaces/Enhances Text.Regex+Description:            A better performance, lazy, powerful replacement of Text.Regex and JRegex+Category:               Text+Tested-With:            GHC+Build-Depends:          base >= 2.0, regex-base >= 0.80, parsec+-- Data-Files:+-- Extra-Source-Files:+-- Extra-Tmp-Files:+-- This is the library+Exposed-Modules:        Text.Regex.Parsec+                        Text.Regex.Parsec.Wrap+                        Text.Regex.Parsec.String+                        Text.Regex.Parsec.ByteString+                        Text.Regex.Parsec.ByteString.Lazy+                        Text.Regex.Parsec.Sequence+                        Text.Regex.Parsec.Common+                        Text.Regex.Parsec.FullParsec+                        Text.Regex.Parsec.FullParsecPosix+                        Text.Regex.Parsec.Pattern+                        Text.Regex.Parsec.ReadRegex+                        Text.Regex.Parsec.RegexParsecState+-- Futher fields+Buildable:              True+-- Other-Modules:+-- be backward compatible until 6.4.2 is futher deployed+-- HS-Source-Dirs:         "."+Extensions:             MultiParamTypeClasses, FunctionalDependencies+-- GHC-Options:            -Wall -Werror+GHC-Options:            -Wall -Werror -O2+-- GHC-Options:            -Wall -ddump-minimal-imports+-- GHC-Prof-Options: +-- Hugs-Options:+-- NHC-Options:+-- Includes:+-- Include-Dirs:+-- C-Sources:+-- Extra-Libraries:+-- Extra-Lib-Dirs:+-- CC-Options:+-- LD-Options:+-- Frameworks: