regex-genex (empty) → 0.1.20110523
raw patch · 4 files changed
+444/−0 lines, 4 filesdep +basedep +containersdep +haskell98setup-changed
Dependencies added: base, containers, haskell98, mtl, regex-tdfa, sbv
Files
- LICENSE +131/−0
- Main.hs +281/−0
- Setup.lhs +6/−0
- regex-genex.cabal +26/−0
+ LICENSE view
@@ -0,0 +1,131 @@+++++ The "Artistic License"++ Preamble++The intent of this document is to state the conditions under which a+Package may be copied, such that the Copyright Holder maintains some+semblance of artistic control over the development of the package,+while giving the users of the package the right to use and distribute+the Package in a more-or-less customary fashion, plus the right to make+reasonable modifications.++Definitions:++ "Package" refers to the collection of files distributed by the+ Copyright Holder, and derivatives of that collection of files+ created through textual modification.++ "Standard Version" refers to such a Package if it has not been+ modified, or has been modified in accordance with the wishes+ of the Copyright Holder as specified below.++ "Copyright Holder" is whoever is named in the copyright or+ copyrights for the package.++ "You" is you, if you're thinking about copying or distributing+ this Package.++ "Reasonable copying fee" is whatever you can justify on the+ basis of media cost, duplication charges, time of people involved,+ and so on. (You will not be required to justify it to the+ Copyright Holder, but only to the computing community at large+ as a market that must bear the fee.)++ "Freely Available" means that no fee is charged for the item+ itself, though there may be fees involved in handling the item.+ It also means that recipients of the item may redistribute it+ under the same conditions they received it.++1. You may make and give away verbatim copies of the source form of the+Standard Version of this Package without restriction, provided that you+duplicate all of the original copyright notices and associated disclaimers.++2. You may apply bug fixes, portability fixes and other modifications+derived from the Public Domain or from the Copyright Holder. A Package+modified in such a way shall still be considered the Standard Version.++3. You may otherwise modify your copy of this Package in any way, provided+that you insert a prominent notice in each changed file stating how and+when you changed that file, and provided that you do at least ONE of the+following:++ a) place your modifications in the Public Domain or otherwise make them+ Freely Available, such as by posting said modifications to Usenet or+ an equivalent medium, or placing the modifications on a major archive+ site such as uunet.uu.net, or by allowing the Copyright Holder to include+ your modifications in the Standard Version of the Package.++ b) use the modified Package only within your corporation or organization.++ c) rename any non-standard executables so the names do not conflict+ with standard executables, which must also be provided, and provide+ a separate manual page for each non-standard executable that clearly+ documents how it differs from the Standard Version.++ d) make other distribution arrangements with the Copyright Holder.++4. You may distribute the programs of this Package in object code or+executable form, provided that you do at least ONE of the following:++ a) distribute a Standard Version of the executables and library files,+ together with instructions (in the manual page or equivalent) on where+ to get the Standard Version.++ b) accompany the distribution with the machine-readable source of+ the Package with your modifications.++ c) give non-standard executables non-standard names, and clearly+ document the differences in manual pages (or equivalent), together+ with instructions on where to get the Standard Version.++ d) make other distribution arrangements with the Copyright Holder.++5. You may charge a reasonable copying fee for any distribution of this+Package. You may charge any fee you choose for support of this+Package. You may not charge a fee for this Package itself. However,+you may distribute this Package in aggregate with other (possibly+commercial) programs as part of a larger (possibly commercial) software+distribution provided that you do not advertise this Package as a+product of your own. You may embed this Package's interpreter within+an executable of yours (by linking); this shall be construed as a mere+form of aggregation, provided that the complete Standard Version of the+interpreter is so embedded.++6. The scripts and library files supplied as input to or produced as+output from the programs of this Package do not automatically fall+under the copyright of this Package, but belong to whoever generated+them, and may be sold commercially, and may be aggregated with this+Package. If such scripts or library files are aggregated with this+Package via the so-called "undump" or "unexec" methods of producing a+binary executable image, then distribution of such an image shall+neither be construed as a distribution of this Package nor shall it+fall under the restrictions of Paragraphs 3 and 4, provided that you do+not represent such an executable image as a Standard Version of this+Package.++7. C subroutines (or comparably compiled subroutines in other+languages) supplied by you and linked into this Package in order to+emulate subroutines and variables of the language defined by this+Package shall not be considered part of this Package, but are the+equivalent of input as in Paragraph 6, provided these subroutines do+not change the language in any way that would cause it to fail the+regression tests for the language.++8. Aggregation of this Package with a commercial distribution is always+permitted provided that the use of this Package is embedded; that is,+when no overt attempt is made to make this Package's interfaces visible+to the end user of the commercial distribution. Such use shall not be+construed as a distribution of this Package.++9. The name of the Copyright Holder may not be used to endorse or promote+products derived from this software without specific prior written permission.++10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED+WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.++ The End
+ Main.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE ImplicitParams, NamedFieldPuns #-}+import Data.SBV+import Data.Set (toList)+import Data.List (sort, nub)+import Data.Bits+import Data.Monoid+import System.IO+import Control.Monad (foldM)+import Control.Monad.State+import Control.Monad.Trans (MonadIO, liftIO)+import qualified Data.Char+import Text.Regex.TDFA.Pattern+import Text.Regex.TDFA.ReadRegex (parseRegex)+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import System.Environment++type Len = Int+type Str = [SWord8]+type Offset = SWord8+type Flips = SWord64+type Captures = SWord64++maxHits = 65535+minLength = 0+maxLength = 255+maxRepeat = 3 -- 7 and 15 are also good++lengths p = IntSet.toList . fst $ runState (possibleLengths $ parse p) mempty++defaultRegex = "a(b|c)d{2,3}e*"+parse r = case parseRegex r of+ Right (pattern, _) -> pattern+ Left x -> error $ show x++type GroupLens = IntMap IntSet++possibleLengths :: Pattern -> State GroupLens IntSet+possibleLengths pat = case pat of+ PGroup (Just idx) p -> do+ lenP <- possibleLengths p+ modify $ IntMap.insert idx lenP+ return lenP+ PGroup _ p -> possibleLengths p+ 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 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+ | Data.Char.isDigit ch -> gets (IntMap.findWithDefault (error $ "No such capture: " ++ [ch]) (charToDigit ch))+ | Data.Char.isAlpha ch -> error $ "Unsupported escape: " ++ [ch]+ | otherwise -> one+ PBound low (Just high) p -> manyTimes p low high+ PBound low _ p -> manyTimes p low (low+maxRepeat)+ PPlus p -> manyTimes p 1 (maxRepeat+1)+ PStar _ p -> manyTimes p 0 maxRepeat+ _ -> error $ show pat+ where+ one = return $ IntSet.singleton 1+ zero = return $ IntSet.singleton 0+ manyTimes p low high = do+ lenP <- possibleLengths p+ return $ IntSet.unions [ IntSet.map (*i) lenP | i <- [low..high] ]++charToDigit ch = Data.Char.ord ch - Data.Char.ord '0'++exactMatch :: (?pats :: [Pattern]) => Len -> Symbolic SBool+exactMatch len = do+ str <- mkFreeVars len+ initialBits <- free "bits"+ let ?str = str+ let initialStatus = Status+ { ok = true+ , pos = toEnum len+ , bits = initialBits+ , captureAt = minBound+ , captureLen = minBound+ }+ runPat s pat = let ?pat = pat in+ ite (ok s &&& pos s .== toEnum len)+ (match s{ pos = 0, captureAt = minBound, captureLen = minBound })+ s{ ok = false, pos = maxBound, bits = maxBound }+ let finalStatus = foldl runPat initialStatus ?pats+ return $+ (bits finalStatus .== 0 &&& pos finalStatus .== toEnum len &&& ok finalStatus)++data Status = Status+ { ok :: SBool+ , pos :: Offset+ , bits :: Flips+ , captureAt :: Captures+ , captureLen :: Captures+ }++type Idx = Word8++instance Mergeable Status where+ symbolicMerge t s1 s2 = Status+ { ok = symbolicMerge t (ok s1) (ok s2)+ , pos = symbolicMerge t (pos s1) (pos s2)+ , bits = symbolicMerge t (bits s1) (bits s2)+ , captureAt = symbolicMerge t (captureAt s1) (captureAt s2)+ , captureLen = symbolicMerge t (captureLen s1) (captureLen s2)+ }++choice :: (?str :: Str, ?pat :: Pattern) => Flips -> [Flips -> Status] -> Status+choice _ [] = error "X"+choice bits [a] = a bits+choice bits [a, b] = ite (lsb bits) (a bits') (b bits')+ where+ bits' = bits `shiftR` 1+choice bits xs = ite (lsb bits)+ (choice bits' $ take half xs)+ (choice bits' $ drop half xs)+ where+ half = length xs `div` 2+ bits' = bits `shiftR` 1++writeCapture :: Captures -> Int -> SWord8 -> 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 ] ]+ +match :: (?str :: Str, ?pat :: Pattern) => Status -> Status+match s@Status{ ok, pos, bits, captureAt, captureLen } = ite (isFailedMatch ||| isOutOfBounds) __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)+ }+ PGroup _ p -> next p+ PCarat{} -> ite (isBegin ||| (charAt (pos-1) .== ord '\n')) s __FAIL__+ PDollar{} -> ite (isEnd ||| (charAt (pos+1) .== ord '\n')) s __FAIL__+ PQuest p -> choice bits [\b -> let ?pat = p in match s{ bits = b }, const s]+ PDot{} -> cond isDot+ POr [p] -> next p+ POr ps -> choice bits $ map (\p -> \b -> let ?pat = p in match s{ bits = b }) ps+ PChar{ getPatternChar = ch } -> cond (ord ch .== cur)+ PConcat [p] -> next p+ PConcat ps -> step ps s+ where+ step [] s' = s'+ step (p:ps) 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__+ | 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'+ PBound low _ p -> let ?pat = (PBound low (Just $ low+maxRepeat) p) in match s+ PPlus p ->+ let s'@Status{ ok = ok, pos = pos'} = next p+ res = let ?pat = PStar True p in match s'+ in ite ok res s'+ PStar _ p -> next $ PBound 0 Nothing p+ _ -> error $ show ?pat+ where+ next p = let ?pat = p in match s+ isDot = (cur .>= ord ' ' &&& cur .<= ord '~')+ isOutOfBounds = pos .> toEnum (length ?str)+ isFailedMatch = bnot ok+ manyTimes s n+ | n <= 0 = s+ | otherwise = let s'@Status{ ok = ok' } = match s in+ ite ok' (choice bits [\b -> s{ bits = b }, \b -> manyTimes s'{ bits = b } (n-1)]) s+ cur = charAt pos+ charAt = select ?str 0+ condChar ch = cond (ord ch .== cur)+ cond b = ite b s{ pos = pos+1 } __FAIL__+ 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, bits = 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')+ |||+ (char .>= ord 'a' &&& char .<= ord 'z')+ |||+ (char .== ord '_')+ isWordBoundary = case length ?str of+ 0 -> false+ _ -> (isEnd &&& isWordCharAt (pos-1)) |||+ (isBegin &&& isWordCharAt pos) |||+ (isWordCharAt (pos-1) <+> isWordCharAt pos)++main = do+ hSetBuffering stdout NoBuffering+ args <- getArgs+ case args of+ [] -> do+ prog <- getProgName+ if prog == "<interactive>" then run defaultRegex else do+ fail $ "Usage: " ++ prog ++ " regex [regex...]"+ rx -> runMany rx++runMany regexes = do+ let ?pats = map parse regexes+ let lens = IntSet.toAscList $ foldl1 IntSet.intersection (map lenOf ?pats)+ tryWith lens 0+ where+ lenOf p = fst $ runState (possibleLengths p) mempty++run :: String -> IO ()+run regex = runMany [regex]++tryWith :: (?pats :: [Pattern]) => [Int] -> Int -> IO ()+tryWith [] acc = return ()+tryWith (len:lens) acc = if len > maxLength then return () else do+ AllSatResult allRes <- allSat $ exactMatch len+ showResult allRes acc+ where+ showResult [] a = tryWith lens a+ showResult (r:rs) a = do+ disp' $ getModel r+ if (a+1 >= maxHits) then return () else showResult rs (a+1)++disp' :: ([Word8], Word64) -> IO ()+disp' (str, choices) = do+ print $ map chr str+ {-+ putStr (show choices)+ putStr "\t["+ putStr $ map chr str+ putStr "]\n"+ -}+ where+ chr :: Word8 -> Char+ chr = Data.Char.chr . fromEnum++disp :: [Word8] -> IO ()+disp str = do+ putStrLn $ map chr str+ where+ chr :: Word8 -> Char+ chr = Data.Char.chr . fromEnum
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/env runghc+> import Distribution.Simple+> import System.Cmd (rawSystem)+> +> main :: IO ()+> main = defaultMainWithHooks simpleUserHooks
+ regex-genex.cabal view
@@ -0,0 +1,26 @@+Name : regex-genex+Version : 0.1.20110523+license : OtherLicense+license-file : LICENSE+cabal-version : >= 1.6+copyright : 2011 Audrey Tang+maintainer : Audrey Tang <audreyt@audreyt.org>+category : Text, Regex+stability : experimental+build-type : Simple+homepage : https://github.com/audreyt/regex-genex+synopsis : From a regex, generate all possible strings it can match+description : From a regex, generate all possible strings it can match+author : Audrey Tang <audreyt@audreyt.org>+Tested-With: GHC==7.0.2++executable genex+ main-is: Main.hs+ hs-source-dirs: .++ build-depends:+ base >= 3 && < 5, haskell98, mtl, containers, sbv, regex-tdfa++source-repository head+ type: git+ location: http://github.com/audreyt/regex-genex