regex-genex 0.1.20110524 → 0.1.20110525
raw patch · 2 files changed
+93/−79 lines, 2 files
Files
- Main.hs +92/−78
- regex-genex.cabal +1/−1
Main.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ImplicitParams, NamedFieldPuns #-}+{-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-} import Data.SBV import Data.Set (toList) import Data.List (sort, nub)@@ -18,7 +18,8 @@ import System.Environment type Len = Int-type Str = [SWord8]+type SChar = SWord8+type Str = [SChar] type Offset = SWord8 type Flips = SWord64 type Captures = SWord64@@ -29,6 +30,7 @@ maxRepeat = 3 -- 7 and 15 are also good lengths p = IntSet.toList . fst $ runState (possibleLengths $ parse p) mempty+minLen p = IntSet.findMin . fst $ runState (possibleLengths p) mempty defaultRegex = "a(b|c)d{2,3}e*" parse r = case parseRegex r of@@ -39,6 +41,7 @@ possibleLengths :: Pattern -> State GroupLens IntSet possibleLengths pat = case pat of+ _ | isOne pat -> one PGroup (Just idx) p -> do lenP <- possibleLengths p modify $ IntMap.insert idx lenP@@ -47,15 +50,9 @@ PCarat{} -> zero PDollar{} -> zero PQuest p -> fmap (`mappend` IntSet.singleton 0) $ possibleLengths p- PDot{} -> one POr ps -> fmap mconcat $ mapM possibleLengths ps- PChar{} -> one- PConcat [] -> return mempty+ PConcat [] -> zero PConcat ps -> fmap (foldl1 sumSets) (mapM possibleLengths ps)- where- sumSets s1 s2 = IntSet.unions [ IntSet.map (+elm) s2 | elm <- IntSet.elems s1 ]- PAny {} -> one- PAnyNot {} -> one PEscape {getPatternChar = ch} | ch `elem` "ntrfaedwsWSD" -> one | ch `elem` "b" -> zero@@ -66,13 +63,15 @@ PBound low _ p -> manyTimes p low (low+maxRepeat) PPlus p -> manyTimes p 1 (maxRepeat+1) PStar _ p -> manyTimes p 0 maxRepeat+ PEmpty -> zero _ -> error $ show pat where one = return $ IntSet.singleton 1 zero = return $ IntSet.singleton 0+ sumSets s1 s2 = IntSet.unions [ IntSet.map (+elm) s2 | elm <- IntSet.elems s1 ] manyTimes p low high = do lenP <- possibleLengths p- return $ IntSet.unions [ IntSet.map (*i) lenP | i <- [low..high] ]+ return $ IntSet.unions [ foldl sumSets (IntSet.singleton 0) (replicate i lenP) | i <- [low..high] ] charToDigit ch = Data.Char.ord ch - Data.Char.ord '0' @@ -92,9 +91,8 @@ ite (ok s &&& pos s .== toEnum len) (match s{ pos = 0, captureAt = minBound, captureLen = minBound }) s{ ok = false, pos = maxBound, flips = maxBound }- let finalStatus = foldl runPat initialStatus ?pats- return $- (flips finalStatus .== 0 &&& pos finalStatus .== toEnum len &&& ok finalStatus)+ let finalStatus@Status{ ok, pos, flips } = foldl runPat initialStatus ?pats+ return (flips .== 0 &&& pos .== toEnum len &&& ok) data Status = Status { ok :: SBool@@ -104,8 +102,6 @@ , captureLen :: Captures } -type Idx = Word8- instance Mergeable Status where symbolicMerge t s1 s2 = Status { ok = symbolicMerge t (ok s1) (ok s2)@@ -137,15 +133,69 @@ log2 1 = 0 log2 n = 1 + log2 ((n + 1) `div` 2) -writeCapture :: Captures -> Int -> SWord8 -> Captures+writeCapture :: Captures -> Int -> Offset -> Captures writeCapture cap idx val = foldl writeBit cap ([0..7] `zip` blastLE val) where writeBit c (i, bit) = setBitTo c (idx * 8 + i) bit readCapture cap idx = fromBitsLE [ bitValue cap (idx * 8 + i) | i <- [ 0..7 ] ] +isOne PChar{} = True+isOne PDot{} = True+isOne PAny {} = True+isOne PAnyNot {} = True+isOne (PGroup Nothing p) = isOne p+isOne PEscape {getPatternChar = ch}+ | ch `elem` "ntrfaedwsWSD" = True+ | ch `elem` "b" = False+ | Data.Char.isDigit ch = False+ | Data.Char.isAlpha ch = error $ "Unsupported escape: " ++ [ch]+ | otherwise = True+isOne _ = False++matchOne :: (?pat :: Pattern) => SChar -> SBool+matchOne cur = case ?pat of+ PChar {getPatternChar = ch} -> isChar ch+ PDot{} -> isDot+ PGroup Nothing p -> let ?pat = p in matchOne cur+ PAny {getPatternSet = pset} -> case pset of+ PatternSet (Just cset) _ _ _ -> oneOf $ toList cset+ _ -> error "TODO"+ PAnyNot {getPatternSet = pset} -> case pset of+ PatternSet (Just cset) _ _ _ -> noneOf $ toList cset+ _ -> error "TODO"+ PEscape {getPatternChar = ch} -> case ch of+ 'n' -> isChar '\n'+ 't' -> isChar '\t'+ 'r' -> isChar '\r'+ 'f' -> isChar '\f'+ 'a' -> isChar '\a'+ 'e' -> isChar '\ESC'+ 'd' -> isDigit+ 'w' -> isWordChar+ 's' -> isWhiteSpace+ 'W' -> (isDot &&& bnot isWordChar)+ 'S' -> (isDot &&& bnot isWhiteSpace)+ 'D' -> (isDot &&& bnot isDigit)+ _ -> isChar ch+ _ -> false+ where+ ord = toEnum . Data.Char.ord+ isChar ch = cur .== ord ch+ isDot = (cur .>= ord ' ' &&& cur .<= ord '~')+ oneOf cs = bOr [ ord ch .== cur | ch <- cs ]+ noneOf cs = bAnd ((cur .>= ord ' ') : (cur .<= ord '~') : [ ord ch ./= cur | ch <- cs ])+ isDigit = (ord '0' .<= cur &&& ord '9' .>= cur)+ isWordChar = (cur .>= ord 'A' &&& cur .<= ord 'Z')+ ||| (cur .>= ord 'a' &&& cur .<= ord 'z')+ ||| (cur .== ord '_')+ isWhiteSpace = cur .== 32 ||| (9 .<= cur &&& 13 .>= cur &&& 11 ./= cur)++ match :: (?str :: Str, ?pat :: Pattern) => Status -> Status-match s@Status{ ok, pos, flips, captureAt, captureLen } = ite (isFailedMatch ||| isOutOfBounds) __FAIL__ $ case ?pat of+match s@Status{ ok, pos, flips, captureAt, captureLen }+ | isOne ?pat = ite (pos .>= strLen) __FAIL__ one+ | otherwise = ite (pos + (toEnum $ minLen ?pat) .> strLen) __FAIL__ $ case ?pat of PGroup (Just idx) p -> let s'@Status{ pos = pos' } = next p in s' { captureAt = writeCapture captureAt idx pos , captureLen = writeCapture captureLen idx (pos' - pos)@@ -154,44 +204,35 @@ PCarat{} -> ite (isBegin ||| (charAt (pos-1) .== ord '\n')) s __FAIL__ PDollar{} -> ite (isEnd ||| (charAt (pos+1) .== ord '\n')) s __FAIL__ PQuest p -> choice flips [\b -> let ?pat = p in match s{ flips = b }, \b -> s{ flips = b }]- PDot{} -> cond isDot POr [p] -> next p POr ps -> choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps- PChar{ getPatternChar = ch } -> cond (ord ch .== cur) PConcat [] -> s PConcat [p] -> next p- PConcat ps -> step ps s+ PConcat ps+ | all isOne ps -> ite (+ ((pos + toEnum (length ps)) .<= strLen)+ &&&+ (bAnd [ let ?pat = p in matchOne (charAt (pos+i))+ | p <- ps+ | i <- [0..]+ ])+ ) s{ pos = pos + toEnum (length ps) } __FAIL__+ | (ones@(_:_:_), rest) <- span isOne ps -> step [PConcat ones, PConcat rest] s+ | (nones@(_:_), rest@(_:_:_)) <- span (not . isOne) ps -> step (nones ++ [PConcat rest]) s+ | otherwise -> step ps s where step [] s' = s' step (p:ps) s' = - let s''@Status{ ok } = let ?pat = p in match s'+ let s''@Status{ ok } = (let ?pat = p in match s') res = step ps s'' in ite ok res __FAIL__- PAny {getPatternSet = pset} -> case pset of- PatternSet (Just cset) _ _ _ -> oneOf $ toList cset- _ -> error "TODO"- PAnyNot {getPatternSet = pset} -> case pset of- PatternSet (Just cset) _ _ _ -> noneOf $ toList cset- _ -> error "TODO" PEscape {getPatternChar = ch} -> case ch of- 'n' -> condChar '\n'- 't' -> condChar '\t'- 'r' -> condChar '\r'- 'f' -> condChar '\f'- 'a' -> condChar '\a'- 'e' -> condChar '\ESC'- 'd' -> cond isDigit- 'w' -> cond (isWordCharAt pos)- 's' -> cond isWhiteSpace- 'W' -> cond (isDot &&& bnot (isWordCharAt pos))- 'S' -> cond (isDot &&& bnot isWhiteSpace)- 'D' -> cond (isDot &&& bnot isDigit) 'b' -> ite isWordBoundary s __FAIL__ _ | Data.Char.isDigit ch -> let from = readCapture captureAt num len = readCapture captureLen num num = charToDigit ch- in ite (matchCapture (from :: SWord8) len 0) s{ pos = pos+len } __FAIL__+ in ite (matchCapture (from :: Offset) len 0) s{ pos = pos+len } __FAIL__ | 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@@ -202,8 +243,10 @@ res = let ?pat = PStar True p in match s' in ite ok res s' PStar _ p -> next $ PBound 0 Nothing p+ PEmpty -> s _ -> error $ show ?pat where+ one = cond $ matchOne cur next p = let ?pat = p in match s isDot = (cur .>= ord ' ' &&& cur .<= ord '~') isOutOfBounds = pos .> strLen@@ -224,14 +267,11 @@ oneOf cs = cond $ bOr [ ord ch .== cur | ch <- cs ] noneOf cs = cond $ bAnd ((cur .>= ord ' ') : (cur .<= ord '~') : [ ord ch ./= cur | ch <- cs ]) ord = toEnum . Data.Char.ord- matchCapture :: SWord8 -> SWord8 -> SWord8 -> SBool matchCapture from len off = (len .<= off) ||| (charAt (pos+off) .== charAt (from+off) &&& matchCapture from len (off+1)) __FAIL__ = s{ ok = false, pos = maxBound, flips = maxBound } isEnd = (pos .== toEnum (length ?str)) isBegin = (pos .== 0)- isWhiteSpace = cur .== 32 ||| (9 .<= cur &&& 13 .>= cur &&& 11 ./= cur)- isDigit = (ord '0' .<= cur &&& ord '9' .>= cur) isWordCharAt at = let char = charAt at in (char .>= ord 'A' &&& char .<= ord 'Z') |||@@ -257,7 +297,7 @@ runMany regexes = do let ?pats = map parse regexes let lens = IntSet.toAscList $ foldl1 IntSet.intersection (map lenOf ?pats)- tryWith lens 0+ tryWith (filter (<= maxLength) lens) 0 where lenOf p = fst $ runState (possibleLengths p) mempty @@ -272,42 +312,16 @@ where showResult [] a = tryWith lens a showResult (r:rs) a = do- disp' $ getModel r+ disp $ getModel r if (a+1 >= maxHits) then return () else showResult rs (a+1) -disp' :: ([Word8], Word64) -> IO ()-disp' (str, choices) = do+disp :: ([Word8], Word64) -> IO ()+disp (str, choices) = do putStr $ show (length str) ++ "."- putStr $ binToOct $ decToBin choices- putStr "\t["- putStr $ map chr str- putStr "]\n"- where- chr :: Word8 -> Char- chr = Data.Char.chr . fromEnum--binToOct [] = "0"-binToOct [False] = "0"-binToOct [True] = "4"-binToOct [False,False] = "0"-binToOct [False,True] = "2"-binToOct [True,False] = "4"-binToOct [True,True] = "6"-binToOct (False:False:False:xs) = ('0':binToOct xs)-binToOct (False:False:True:xs) = ('1':binToOct xs)-binToOct (False:True:False:xs) = ('2':binToOct xs)-binToOct (False:True:True:xs) = ('3':binToOct xs)-binToOct (True:False:False:xs) = ('4':binToOct xs)-binToOct (True:False:True:xs) = ('5':binToOct xs)-binToOct (True:True:False:xs) = ('6':binToOct xs)-binToOct (True:True:True:xs) = ('7':binToOct xs)--decToBin 0 = []-decToBin y = let (a,b) = quotRem y 2 in ((b == 1):decToBin a)--disp :: [Word8] -> IO ()-disp str = do- putStrLn $ map chr str+ let n = show choices+ putStr (replicate (8 - length n) '0')+ putStr n+ putStr "\t\t"+ print $ map chr str where- chr :: Word8 -> Char chr = Data.Char.chr . fromEnum
regex-genex.cabal view
@@ -1,5 +1,5 @@ Name : regex-genex-Version : 0.1.20110524+Version : 0.1.20110525 license : OtherLicense license-file : LICENSE cabal-version : >= 1.6