diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/regex-genex.cabal b/regex-genex.cabal --- a/regex-genex.cabal +++ b/regex-genex.cabal @@ -1,5 +1,5 @@ Name : regex-genex -Version : 0.1.20110524 +Version : 0.1.20110525 license : OtherLicense license-file : LICENSE cabal-version : >= 1.6