regex-genex 0.2.0 → 0.2.1
raw patch · 3 files changed
+141/−72 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Regex.Genex.Normalize: normalize :: BackReferences -> Pattern -> Pattern
Files
- regex-genex.cabal +2/−2
- src/Regex/Genex.hs +33/−70
- src/Regex/Genex/Normalize.hs +106/−0
regex-genex.cabal view
@@ -1,5 +1,5 @@ Name : regex-genex-Version : 0.2.0+Version : 0.2.1 license : OtherLicense license-file : LICENSE cabal-version : >= 1.6@@ -16,7 +16,7 @@ library hs-source-dirs: . src- exposed-modules: Regex.Genex+ exposed-modules: Regex.Genex Regex.Genex.Normalize extensions : ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards build-depends: base >= 3 && < 5, haskell98, mtl, containers, sbv, regex-tdfa
src/Regex/Genex.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-} module Regex.Genex (Model(..), genex, genexPrint, genexModels) where import Data.SBV+import Data.SBV.Internals (SBV) import Data.Set (toList) import Data.Monoid import Control.Monad.State@@ -12,6 +13,7 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import System.IO.Unsafe (unsafeInterleaveIO)+import Regex.Genex.Normalize (normalize) -- | Given a list of regular repressions, returns all possible strings that matches all of them. genex :: [String] -> IO [String]@@ -32,18 +34,23 @@ genexPrint :: [String] -> IO () genexPrint = genexWith displayString -type Len = Int+type Len = Word16 type SChar = SWord8 type Str = [SChar]-type Offset = SWord8+type Offset = SBV Len type Flips = SWord64-type Captures = SFunArray Word8 Word8+type Captures = SFunArray Word8 Len+type Hits = Word16 -maxHits, maxLength, maxRepeat :: Int-maxHits = 65535-maxLength = 255+maxHits :: Hits+maxHits = maxBound -- 65535++maxRepeat :: Int maxRepeat = 3 -- 7 and 15 are also good +maxLength :: Len+maxLength = maxBound -- 65535+ -- lengths p = let ?grp = mempty in IntSet.toList . fst $ runState (possibleLengths $ parse p) mempty minLen :: (?grp :: GroupLens) => Pattern -> Int@@ -61,37 +68,6 @@ type GroupLens = IntMap IntSet type BackReferences = IntSet -simplify :: (?refs :: BackReferences) => Pattern -> Pattern-simplify pat = case pat of- PGroup (Just idx) p -> if idx `IntSet.member` ?refs then PGroup (Just idx) (simplify p) else simplify p- PGroup _ p -> simplify p- PQuest p -> case simplify p of- PEmpty -> PEmpty- p' -> PQuest p'- PAny {getPatternSet = pset, getDoPa} -> case pset of- PatternSet (Just cset) _ _ _ -> case toList cset of- [ch] -> PChar { getPatternChar = ch, getDoPa }- _ -> pat- _ -> pat- POr [] -> PEmpty- POr [p] -> simplify p- POr ps -> POr (map simplify ps)- PConcat [] -> PEmpty- PConcat [p] -> simplify p- PConcat ps -> case concatMap (fromConcat . simplify) ps of- [] -> PEmpty- ps' -> PConcat ps'- where- fromConcat (PConcat ps') = ps'- fromConcat PEmpty = []- fromConcat p = [p]- PBound low (Just high) p- | high == low -> simplify $ PConcat (replicate low (simplify p))- PBound low high p -> PBound low high (simplify p)- PPlus p -> PPlus (simplify p)- PStar x p -> PStar x (simplify p)- _ -> pat- possibleLengths :: (?grp :: GroupLens) => Pattern -> State (GroupLens, BackReferences) IntSet possibleLengths pat = case pat of _ | isOne pat -> one@@ -142,24 +118,25 @@ exactMatch :: (?pats :: [(Pattern, GroupLens)]) => Len -> Symbolic SBool exactMatch len = do- str <- mkFreeVars len+ str <- mkFreeVars $ fromEnum len initialFlips <- free "flips"- at' <- newArray_ (Just minBound)- len' <- newArray_ (Just minBound)+ captureAt <- newArray_ (Just minBound)+ captureLen <- newArray_ (Just minBound) let ?str = str let initialStatus = Status { ok = true- , pos = toEnum len+ , pos = strLen , flips = initialFlips- , captureAt = at'- , captureLen = writeCapture len' 1 1+ , captureAt = captureAt+ , captureLen = captureLen }+ strLen = literal len runPat s (pat, groupLens) = let ?pat = pat in let ?grp = groupLens in- ite (ok s &&& pos s .== toEnum len)- (match s{ pos = 0, captureAt = at', captureLen = len' })+ ite (ok s &&& pos s .== strLen)+ (match s{ pos = 0, captureAt, captureLen }) s{ ok = false, pos = maxBound, flips = maxBound } let Status{ ok, pos, flips } = foldl runPat initialStatus ?pats- return (flips .== 0 &&& pos .== toEnum len &&& ok)+ return (flips .== 0 &&& pos .== strLen &&& ok) data Status = Status { ok :: SBool@@ -184,11 +161,6 @@ choice flips [a, b] = ite (lsb flips) (b flips') (a flips') where flips' = flips `shiftR` 1- {--choice flips (x:xs) = ite (lsb flips) (choice flips' xs) (x flips')- where- flips' = flips `shiftR` 1- -} choice flips xs = select (map ($ flips') xs) (head xs thisFlip){ ok = false } thisFlip where bits = log2 $ length xs@@ -201,16 +173,9 @@ writeCapture :: Captures -> Int -> Offset -> Captures writeCapture cap idx val = writeArray cap (toEnum idx) val--- writeCapture cap idx val = (take (idx-1) (cap ++ [0..])) ++ (val : drop idx cap)-{--writeCapture cap idx val = foldl writeBit cap ([0..7] `zip` blastLE val)- where- writeBit c (i, bit) = setBitTo c (idx * 8 + i) bit--} -readCapture :: Captures -> Int -> SChar+readCapture :: Captures -> Int -> Offset readCapture a = readArray a . toEnum---readCapture cap idx = fromBitsLE [ bitValue cap (idx * 8 + i) | i <- [ 0..7 ] ] isOne :: Pattern -> Bool isOne PChar{} = True@@ -284,8 +249,6 @@ PConcat [p] -> next p PConcat ps | all isOne ps -> ite (- ((pos + toEnum (length ps)) .<= strLen)- &&& (bAnd [ let ?pat = p in matchOne (charAt (pos+i)) | p <- ps | i <- [0..]@@ -315,7 +278,7 @@ | Data.Char.isAlpha ch -> error $ "Unsupported escape: " ++ [ch] | otherwise -> cond (ord ch .== cur) PBound low (Just high) p -> let s'@Status{ ok = ok' } = (let ?pat = PConcat (replicate low p) in match s) in- ite ok' (let ?pat = p in (manyTimes s' $ high - low)) s'+ if low == high then s' else ite ok' (let ?pat = p in (manyTimes s' $ high - low)) s' PBound low _ p -> let ?pat = (PBound low (Just $ low+maxRepeat) p) in match s PPlus p -> let s'@Status{ok} = next p@@ -362,7 +325,7 @@ (isWordCharAt (pos-1) <+> isWordCharAt pos) -displayString :: [SMTResult] -> Int -> (Int -> IO ()) -> IO ()+displayString :: [SMTResult] -> Hits -> (Hits -> IO ()) -> IO () displayString [] a next = next a displayString (r:rs) a next = do let (chars, rank) = getModel r@@ -377,28 +340,28 @@ where chr = Data.Char.chr . fromEnum -genexWith :: Monoid a => ([SMTResult] -> Int -> (Int -> IO a) -> IO a) -> [[Char]] -> IO a+genexWith :: Monoid a => ([SMTResult] -> Hits -> (Hits -> IO a) -> IO a) -> [[Char]] -> IO a genexWith f regexes = do let ?grp = mempty let p'lens = [ ((p', groupLens), lens) | p <- [ if r == "" then PEmpty else parse r | r <- regexes ] , let (lens, (groupLens, backRefs)) = runState (possibleLengths p) mempty- , let p' = let ?refs = backRefs in simplify p+ , let p' = normalize backRefs p ] let ?pats = map fst p'lens let lens = IntSet.toAscList $ foldl1 IntSet.intersection (map snd p'lens)- tryWith f (filter (<= maxLength) lens) 0+ tryWith f (filter (<= maxLength) $ map toEnum lens) 0 tryWith :: (?pats :: [(Pattern, GroupLens)]) => - Monoid a => ResultHandler a -> [Int] -> Int -> IO a+ Monoid a => ResultHandler a -> [Len] -> Hits -> IO a tryWith _ [] _ = return mempty tryWith f (len:lens) acc = if len > maxLength then return mempty else do AllSatResult allRes <- allSat $ exactMatch len f allRes acc $ tryWith f lens -type ResultHandler a = [SMTResult] -> Int -> (Int -> IO a) -> IO a+type ResultHandler a = [SMTResult] -> Hits -> (Hits -> IO a) -> IO a -getStringWith :: (Model -> a) -> [SMTResult] -> Int -> (Int -> IO [a]) -> IO [a]+getStringWith :: (Model -> a) -> [SMTResult] -> Hits -> (Hits -> IO [a]) -> IO [a] getStringWith _ [] a next = next a getStringWith f (r:rs) a next = do let (chars, rank) = getModel r@@ -406,7 +369,7 @@ unsafeInterleaveIO $ getStringWith f rs (a+1) next return (f (Model chars rank):rest) -getString :: [SMTResult] -> Int -> (Int -> IO [String]) -> IO [String]+getString :: [SMTResult] -> Hits -> (Hits -> IO [String]) -> IO [String] getString = getStringWith $ \Model{ modelChars } -> map chr modelChars where chr = Data.Char.chr . fromEnum
+ src/Regex/Genex/Normalize.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE ImplicitParams, NamedFieldPuns #-}+module Regex.Genex.Normalize (normalize) where+import Data.Set (toList, Set)+import Text.Regex.TDFA.Pattern+import Text.Regex.TDFA.ReadRegex (parseRegex)+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set++type BackReferences = IntSet++-- | Normalize a regex into "strong star normal form", as defined in the paper+-- "Simplifying Regular Expressions: A Quantitative Perspective".+normalize :: BackReferences -> Pattern -> Pattern+normalize refs p = black $ let ?refs = refs in simplify p++nullable pat = case pat of+ PGroup _ p -> nullable p+ PQuest{} -> True+ POr ps -> any nullable ps+ PConcat ps -> all nullable ps+ PBound 0 _ _ -> True+ PBound _ _ _ -> False+ PStar{} -> True+ PEmpty -> True+ _ -> False++white pat = case pat of+ PQuest p -> white p+ PStar _ p -> white p+ PGroup x p -> PGroup x $ white p+ POr ps -> POr (map white ps)+ PConcat ps -> if nullable pat+ then POr (map white ps)+ else pat+ PPlus p -> if nullable pat+ then PConcat [p, white p]+ else pat+ _ -> pat++black pat = case pat of+ POr ps -> POr (map black ps)+ PConcat ps -> PConcat (map black ps)+ PGroup x p -> PGroup x $ black p+ PStar x p -> PStar x $ white (black p)+ PPlus p -> PConcat [p, PStar (nullable p) (white $ black p)]+ PBound 0 Nothing p -> PStar (nullable p) (white $ black p)+ PBound x Nothing p -> PConcat [PBound x (Just x) p, PStar (nullable p) (white $ black p)]+ PBound x y p -> PBound x y $ black p+ PQuest p -> if nullable p+ then black p+ else PQuest $ black p+ _ -> pat++parse :: String -> Pattern+parse r = case parseRegex r of+ Right (pattern, _) -> pattern+ Left x -> error $ show x++foldChars :: (Set Char, [Pattern]) -> Pattern -> (Set Char, [Pattern])+foldChars (cset, rest) pat = case pat of+ PChar { getPatternChar = ch } -> (Set.insert ch cset, rest)+ PAny {getPatternSet = PatternSet (Just cset') _ _ _} -> (Set.union cset cset', rest)+ _ -> (cset, pat:rest)++simplify :: (?refs :: BackReferences) => Pattern -> Pattern+simplify pat = case pat of+ PGroup (Just idx) p -> if idx `IntSet.member` ?refs then PGroup (Just idx) (simplify p) else simplify p+ PGroup _ p -> simplify p+ PQuest p -> case simplify p of+ PEmpty -> PEmpty+ p' -> PQuest p'+ PAny {getPatternSet = pset, getDoPa} -> case pset of+ PatternSet (Just cset) _ _ _ -> case toList cset of+ [ch] -> PChar { getPatternChar = ch, getDoPa }+ _ -> pat+ _ -> pat+ POr [] -> PEmpty+ POr [p] -> simplify p+ POr ps -> let ps' = map simplify ps in + case foldl foldChars (Set.empty, []) ps' of+ (cset, rest)+ | null rest -> anySet+ | Set.null cset -> POr rest+ | [r] <- rest -> POr [anySet, r]+ | otherwise -> POr [anySet, POr rest]+ where+ anySet = case Set.size cset of+ 1 -> PChar { getPatternChar = Set.findMin cset, getDoPa = toEnum 0 }+ _ -> PAny { getPatternSet = PatternSet (Just cset) Nothing Nothing Nothing, getDoPa = toEnum 0 }+ PConcat [] -> PEmpty+ PConcat [p] -> simplify p+ PConcat ps -> case concatMap (fromConcat . simplify) ps of+ [] -> PEmpty+ ps' -> PConcat ps'+ where+ fromConcat (PConcat ps') = ps'+ fromConcat PEmpty = []+ fromConcat p = [p]+ PBound low (Just high) p+ | high == low -> simplify $ PConcat (replicate low (simplify p))+ PBound low high p -> PBound low high (simplify p)+ PPlus p -> PPlus (simplify p)+ PStar x p -> PStar x (simplify p)+ _ -> pat+