regex-applicative 0.1.3 → 0.1.4
raw patch · 13 files changed
+261/−175 lines, 13 filesdep +monads-tfdep +vectordep ~base
Dependencies added: monads-tf, vector
Dependency ranges changed: base
Files
- CHANGES.md +5/−0
- CREDITS.md +6/−2
- README.md +4/−4
- Text/Regex/Applicative.hs +3/−0
- Text/Regex/Applicative/Compile.hs +44/−0
- Text/Regex/Applicative/Implementation.hs +63/−94
- Text/Regex/Applicative/Interface.hs +30/−14
- Text/Regex/Applicative/Priorities.hs +0/−51
- Text/Regex/Applicative/Reference.hs +3/−3
- Text/Regex/Applicative/StateQueue.hs +65/−0
- Text/Regex/Applicative/Types.hs +26/−0
- regex-applicative.cabal +11/−6
- test.hs +1/−1
CHANGES.md view
@@ -1,6 +1,11 @@ Changes ======= +0.1.4+-----+* Completely rewrite the engine. Now it's faster and runs in constant space.+* Add 'string' function and 'IsString' instance.+ 0.1.3 ----- * Fix a .cabal-file issue introduced in 0.1.2
CREDITS.md view
@@ -1,4 +1,8 @@-The implementation is heavily based on the ideas from ["A Play on Regular-Expressions"][play] by Sebastian Fischer, Frank Huch and Thomas Wilke.+The current implementation is based on ideas [publicized][cox] by Russ Cox. +The original implementation was inspired and heavily based on the ideas from ["A+Play on Regular Expressions"][play] by Sebastian Fischer, Frank Huch and Thomas+Wilke.++[cox]: http://swtch.com/~rsc/regexp/ [play]: http://sebfisch.github.com/haskell-regexp/regexp-play.pdf
README.md view
@@ -22,20 +22,20 @@ Documentation --------------The [API reference][haddock] is available from Hackage+The [API reference][haddock] is available from Hackage. +To get started, see some [examples][examples] on the wiki.+ Other resources --------------- * [This package on Hackage][hackage] * [Issue tracker][issues] * [Repository][github]-* ["A Play on Regular Expressions"][play] paper explains, to some extent,- how this works +[examples]: https://github.com/feuerbach/regex-applicative/wiki/Examples [haddock]: http://hackage.haskell.org/packages/archive/regex-applicative/latest/doc/html/Text-Regex-Applicative.html [hackage]: http://hackage.haskell.org/package/regex-applicative [issues]: https://github.com/feuerbach/regex-applicative/issues [github]: https://github.com/feuerbach/regex-applicative-[play]: http://sebfisch.github.com/haskell-regexp/regexp-play.pdf
Text/Regex/Applicative.hs view
@@ -7,6 +7,8 @@ -- Maintainer: Roman Cheplyaka <roma@ro-che.info> -- Stability : experimental --+-- To get started, see some examples on the wiki:+-- <https://github.com/feuerbach/regex-applicative/wiki/Examples> -------------------------------------------------------------------- module Text.Regex.Applicative@@ -14,6 +16,7 @@ , sym , psym , anySym+ , string , reFoldl , (=~) , module Control.Applicative
+ Text/Regex/Applicative/Compile.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE GADTs, ScopedTypeVariables, ViewPatterns #-}+{-# OPTIONS_GHC -fno-do-lambda-eta-expansion #-}+module Text.Regex.Applicative.Compile (compile) where++import Text.Regex.Applicative.Types++compile :: forall a s r . Regexp s ThreadId a -> (a -> [Thread s r]) -> [Thread s r]+compile e k = compile2 e k k++-- The whole point of this module is this function, compile2, which needs to be+-- compiled with -fno-do-lambda-eta-expansion for efficiency.+--+-- Since this option would make other code perform worse, we place this+-- function in a separate module and make sure it's not inlined.+--+-- The point of "-fno-do-lambda-eta-expansion" is to make sure the tree is+-- "compiled" only once.+--+-- compile2 function takes two continuations: one when the match is empty and+-- one when the match is non-empty. See the "Rep" case for the reason.+compile2 :: forall a s r . Regexp s ThreadId a -> (a -> [Thread s r]) -> (a -> [Thread s r]) -> [Thread s r]+compile2 e =+ case e of+ Eps -> \ke _kn -> ke $ error "empty"+ Symbol i p -> \_ke kn -> [t kn] where+ t :: (a -> [Thread s r]) -> Thread s r+ t k = Thread i $ \s ->+ if p s then k s else []+ App (compile2 -> a1) (compile2 -> a2) -> \ke kn ->+ a1+ -- empty+ (\a1_value -> a2 (ke . a1_value) (kn . a1_value))+ -- non-empty+ (\a1_value -> a2 (kn . a1_value) (kn . a1_value))+ Alt (compile2 -> a1) (compile2 -> a2) ->+ \ke kn -> a1 ke kn ++ a2 ke kn+ Fmap f (compile2 -> a) -> \ke kn -> a (ke . f) (kn . f)+ -- This is actually the point where we use the difference between+ -- continuations. For the inner regexp the empty continuation is a+ -- "failing" one in order to avoid non-termination.+ Rep f b (compile2 -> a) ->+ let threads b ke kn =+ a (\_ -> []) (\v -> let b' = f b v in threads b' kn kn) ++ ke b+ in threads b
Text/Regex/Applicative/Implementation.hs view
@@ -1,103 +1,72 @@-{-# LANGUAGE GADTs, TupleSections, DeriveFunctor #-}-module Text.Regex.Applicative.Implementation where-import Control.Applicative-import Data.List-import Text.Regex.Applicative.Priorities+{-# LANGUAGE GADTs, TypeFamilies, ViewPatterns, PatternGuards #-}+module Text.Regex.Applicative.Implementation (match, Regexp(..)) where+import Prelude+import Control.Applicative hiding (empty)+import Control.Monad.State hiding (foldM)+import Text.Regex.Applicative.StateQueue+import Control.Monad.ST+import Text.Regex.Applicative.Types+import Text.Regex.Applicative.Compile -data Regexp s r a where- Eps :: Regexp s r a- Symbol :: (s -> Bool) -> Regexp s r s- Alt :: RegexpNode s r a -> RegexpNode s r a -> Regexp s r a- App :: RegexpNode s (a -> r) (a -> b) -> RegexpNode s r a -> Regexp s r b- Fmap :: (a -> b) -> RegexpNode s r a -> Regexp s r b- Rep :: (b -> a -> b) -- folding function (like in foldl)- -> b -- the value for zero matches, and also the initial value- -- for the folding function- -> RegexpNode s (b, b -> r) a- -- Elements of the 2-tuple are the value accumulated so far- -- and the continuation- -> Regexp s r b+fresh :: (MonadState m, StateType m ~ ThreadId) => m ThreadId+fresh = do+ i <- get+ put $! i+1+ return i -data RegexpNode s r a = RegexpNode- { active :: !Bool- , skip :: !(Priority a)- , final_ :: !(Priority r)- , reg :: !(Regexp s r a)- }+renumber :: Regexp s i a -> (Regexp s ThreadId a, ThreadId)+renumber e = flip runState 1 $ compile e+ where+ compile :: Regexp s i a -> State ThreadId (Regexp s ThreadId a)+ compile e =+ case e of+ Eps -> return Eps+ Symbol _ p -> Symbol <$> fresh <*> pure p+ Alt a1 a2 -> Alt <$> compile a1 <*> compile a2+ App a1 a2 -> App <$> compile a1 <*> compile a2+ Fmap f a -> Fmap f <$> compile a+ Rep f b a -> Rep f b <$> compile a -emptyChoice p1 p2 = withPriority 1 p1 <|> withPriority 0 p2 -final r = if active r then final_ r else empty+threadId :: Thread s a -> ThreadId+threadId Accept {} = 0+threadId Thread { threadId_ = i } = i -epsNode :: RegexpNode s r a-epsNode = RegexpNode- { active = False- , skip = pure $ error "epsNode"- , final_ = empty- , reg = Eps- } -symbolNode :: (s -> Bool) -> RegexpNode s r s-symbolNode c = RegexpNode- { active = False- , skip = empty- , final_ = empty- , reg = Symbol c- }--altNode :: RegexpNode s r a -> RegexpNode s r a -> RegexpNode s r a-altNode a1 a2 = RegexpNode- { active = active a1 || active a2- , skip = skip a1 `emptyChoice` skip a2- , final_ = final a1 <|> final a2- , reg = Alt a1 a2- }--appNode :: RegexpNode s (a -> r) (a -> b) -> RegexpNode s r a -> RegexpNode s r b-appNode a1 a2 = RegexpNode- { active = active a1 || active a2- , skip = skip a1 <*> skip a2- , final_ = final a1 <*> skip a2 <|> final a2- , reg = App a1 a2- }--fmapNode :: (a -> b) -> RegexpNode s r a -> RegexpNode s r b-fmapNode f a = RegexpNode- { active = active a- , skip = fmap f $ skip a- , final_ = final a- , reg = Fmap f a- }+run :: StateQueue st (Thread s r)+ -> StateQueue st (Thread s r)+ -> [s] -> ST st (Maybe r)+run queue _ [] = fold f Nothing queue+ where f a@Just{} _ _ = return a+ f Nothing _ x | Accept r <- x = return $ Just r+ | otherwise = return Nothing+run queue newQueue (s:ss) = do+ let accum q _ t =+ case t of+ Accept {} -> return q+ Thread _ c ->+ foldM (\q x -> tryInsert x q) q $ c s+ newQueue <- fold accum newQueue queue+ let veryNewQueue = clear queue+ run newQueue veryNewQueue ss -repNode :: (b -> a -> b) -> b -> RegexpNode s (b, b -> r) a -> RegexpNode s r b-repNode f b a = RegexpNode- { active = active a- , skip = withPriority 0 $ pure b- , final_ = withPriority 0 $ (\(b, f) -> f b) <$> final a- , reg = Rep f b a- }+tryInsert :: Thread s r -> StateQueue st (Thread s r) -> ST st (StateQueue st (Thread s r))+tryInsert t@(threadId -> ThreadId i) queue = do+ alreadyPresent <- member i queue+ if alreadyPresent+ then return queue+ else insert i t queue -shift :: Priority (a -> r) -> RegexpNode s r a -> s -> RegexpNode s r a-shift k r _ | not (active r) && not (isOK k) = r-shift k re s =- case reg re of- Eps -> re- Symbol predicate ->- let f = k <*> if predicate s then pure s else empty- in re { final_ = f, active = isOK f }- Alt a1 a2 -> altNode (shift (withPriority 1 k) a1 s) (shift (withPriority 0 k) a2 s)- App a1 a2 -> appNode- (shift kc a1 s)- (shift (kc <*> skip a1 <|> final a1) a2 s)- where kc = fmap (.) k- Fmap f a -> fmapNode f $ shift (fmap (. f) k) a s- Rep f b a -> repNode f b $ shift k' a s- where- k' = withPriority 1 $- (\(b, k) -> \a -> (f b a, k)) <$>- ((b,) <$> k <|> final a)+match :: Regexp s a r -> [s] -> Maybe r+match r s = runST $ do+ let (rr, ThreadId numStates) = renumber r+ q1 <- empty numStates+ q2 <- empty numStates+ let threads = compile rr (\x -> [Accept x])+ q1 <- foldM (\q t -> tryInsert t q) q1 threads+ run q1 q2 s -match :: RegexpNode s r r -> [s] -> Priority r-match r [] = skip r-match r (s:ss) = final $- foldl' (\r s -> shift empty r s) (shift (pure id) r s) ss+-- This turns out to be much faster than the standard foldM,+-- because of inlining.+foldM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a+foldM f a l = foldr (\x k a -> f a x >>= k) return l $ a
Text/Regex/Applicative/Interface.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE Rank2Types, FlexibleInstances, TypeFamilies #-} module Text.Regex.Applicative.Interface where import Control.Applicative hiding (empty) import qualified Control.Applicative import Data.Traversable+import Data.String import Text.Regex.Applicative.Implementation-import Text.Regex.Applicative.Priorities -- | Type of regular expressions that recognize symbols of type @s@ and -- produce a result of type @a@.@@ -30,23 +30,26 @@ -- -- * 'many' @ra@ matches concatenation of zero or more strings matched by @ra@ -- and returns the list of @ra@'s return values on those strings.-newtype RE s a = RE { unRE :: forall r . RegexpNode s r a }+newtype RE s a = RE (forall i . Regexp s i a) instance Functor (RE s) where- fmap f (RE a) = RE $ fmapNode f a+ fmap f (RE x) = RE $ Fmap f x instance Applicative (RE s) where- pure x = const x <$> RE epsNode- (RE a1) <*> (RE a2) = RE $ appNode a1 a2+ pure x = const x <$> RE Eps+ (RE a1) <*> (RE a2) = RE $ App a1 a2 instance Alternative (RE s) where- (RE a1) <|> (RE a2) = RE $ altNode a1 a2- empty = error "noMatch" <$> psym (const False)- many a = reverse <$> reFoldl (flip (:)) [] a+ (RE a1) <|> (RE a2) = RE $ Alt a1 a2+ empty = RE Eps+ many (RE a) = reverse <$> RE (Rep (flip (:)) [] a) +instance (char ~ Char, string ~ String) => IsString (RE char string) where+ fromString = string+ -- | Matches and returns a single symbol which satisfies the predicate psym :: (s -> Bool) -> RE s s-psym p = RE $ symbolNode p+psym p = RE $ Symbol (error "Not numbered symbol") p -- | Matches and returns the given symbol sym :: Eq s => s -> RE s s@@ -56,16 +59,29 @@ anySym :: RE s s anySym = psym (const True) --- | Matches and returns the given sequence of symbols+-- | Matches and returns the given sequence of symbols.+--+-- Note that you there is an 'IsString' instance for regular expression, so+-- if you enable the @OverloadedStrings@ language extension, you can write+-- @string \"foo\"@ simply as @\"foo\"@.+--+-- Example:+--+-- >{-# LANGUAGE OverloadedStrings #-}+-- >import Text.Regex.Applicative+-- >+-- >number = "one" *> pure 1 <|> "two" *> pure 2+-- >+-- >main = print $ "two" =~ number string :: Eq a => [a] -> RE a [a]-string = sequenceA . map sym+string = traverse sym -- | Greedily matches zero or more symbols, which are combined using the given -- folding function reFoldl :: (b -> a -> b) -> b -> RE s a -> RE s b-reFoldl f b (RE a) = RE $ repNode f b a+reFoldl f b (RE a) = RE $ Rep f b a -- | Attempts to match a string of symbols against the regular expression (=~) :: [s] -> RE s a -> Maybe a-s =~ (RE r) = priorityToMaybe $ match r s+s =~ (RE a) = match a s infix 2 =~
− Text/Regex/Applicative/Priorities.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Text.Regex.Applicative.Priorities- ( Priority- , PrNum- , withPriority- , priorityToMaybe- , isOK- ) where-import Control.Applicative-import qualified Data.Sequence as Sequence---- | An applicative functor similar to Maybe, but it's '<|>' method honors--- priority.-data Priority a = Priority { priority :: !PrSeq, pValue :: a } | Fail- deriving (Functor, Show)-type PrSeq = Sequence.Seq PrNum-type PrNum = Int--instance Applicative Priority where- pure x = Priority Sequence.empty x- Priority p1 f <*> Priority p2 x = Priority (p1 Sequence.>< p2) (f x)- _ <*> _ = Fail--instance Alternative Priority where- empty = Fail- p@Priority {} <|> Fail = p- Fail <|> p@Priority {} = p- Fail <|> Fail = Fail- p1@Priority {} <|> p2@Priority {} = {-# SCC "compare_priorities" #-}- case compare (priority p1) (priority p2) of- LT -> p2- GT -> p1- EQ -> error $- "Two priorities are the same! Should not happen.\n" ++ show (priority p1)---- | Adds priority to the end-withPriority :: PrNum -> Priority a -> Priority a-withPriority p (Priority ps x) = Priority (ps Sequence.|> p) x-withPriority _ Fail = Fail---- | Discards priority information-priorityToMaybe :: Priority a -> Maybe a-priorityToMaybe p =- case p of- Priority { pValue = x } -> Just x- Fail -> Nothing--isOK p =- case p of- Fail -> False- Priority {} -> True
Text/Regex/Applicative/Reference.hs view
@@ -45,11 +45,11 @@ [] -> [] c:cs -> [(c,cs)] -re2monad :: RegexpNode s r a -> P s a+re2monad :: Regexp s r a -> P s a re2monad r =- case reg r of+ case r of Eps -> return $ error "eps"- Symbol p -> do+ Symbol _ p -> do c <- getChar if p c then return c else empty Alt a1 a2 -> re2monad a1 <|> re2monad a2
+ Text/Regex/Applicative/StateQueue.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE RecordWildCards #-}+module Text.Regex.Applicative.StateQueue+ ( StateQueue+ , empty+ , insert+ , member+ , fold+ , clear+ ) where++import Prelude hiding (read, lookup, replicate)+import Data.Vector.Mutable hiding (clear)+import Control.Monad+import Control.Monad.ST++data IndexedValue a = IndexedValue+ { ixKey :: !Int+ , _ixValue :: !a+ }++data StateQueue s a = StateQueue+ { dense :: !(MVector s (IndexedValue a))+ , sparseToDense :: !(MVector s Int)+ , size :: !Int+ }++{-# INLINE empty #-}+empty :: Int -> ST st (StateQueue st a)+empty maxSize = do+ d <- replicate maxSize (IndexedValue 0 $ error "SQ: Uninitialized value")+ s2d <- replicate maxSize 0+ return StateQueue+ { dense = d+ , sparseToDense = s2d+ , size = 0+ }++{-# INLINE insert #-}+insert+ :: Int -> a -> StateQueue st a+ -> ST st (StateQueue st a)+insert i v sq@StateQueue { size = size } = do+ write (sparseToDense sq) i size+ write (dense sq) size (IndexedValue i v)+ return $ sq { size = size + 1 }++{-# INLINE member #-}+member+ :: Int -> StateQueue st a -> ST st Bool+member i StateQueue {..} = {-# SCC "member" #-} do+ di <- read sparseToDense i+ if (di >= size) then return False else do+ IndexedValue { ixKey = dvKey } <- read dense di+ return $ dvKey == i++{-# INLINE fold #-}+fold :: (a -> Int -> x -> ST st a) -> a -> StateQueue st x -> ST st a+fold f acc0 sq = foldM step acc0 [0 .. size sq - 1]+ where+ step acc n = do+ IndexedValue i v <- read (dense sq) n+ f acc i v++{-# INLINE clear #-}+clear sq = sq { size = 0 }
+ Text/Regex/Applicative/Types.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-do-lambda-eta-expansion #-}+module Text.Regex.Applicative.Types where++newtype ThreadId = ThreadId Int+ deriving (Show, Eq, Ord, Num)++data Thread s a+ = Thread+ { threadId_ :: ThreadId+ , _threadCont :: s -> [Thread s a]+ }+ | Accept a++data Regexp s i a where+ Eps :: Regexp s i a+ Symbol :: i -> (s -> Bool) -> Regexp s i s+ Alt :: Regexp s i a -> Regexp s i a -> Regexp s i a+ App :: Regexp s i (a -> b) -> Regexp s i a -> Regexp s i b+ Fmap :: (a -> b) -> Regexp s i a -> Regexp s i b+ Rep :: (b -> a -> b) -- folding function (like in foldl)+ -> b -- the value for zero matches, and also the initial value+ -- for the folding function+ -> Regexp s i a+ -> Regexp s i b+
regex-applicative.cabal view
@@ -9,7 +9,7 @@ -- standards guiding when and how versions should be incremented. -- DO NOT FORGET TO UPDATE THE GIT TAG BELOW!!!-Version: 0.1.3+Version: 0.1.4 -- A short (one-line) description of the package. Synopsis: Regex-based parsing with applicative interface@@ -56,13 +56,16 @@ Source-repository this type: git location: git://github.com/feuerbach/regex-applicative.git- tag: v0.1.3+ tag: v0.1.4 Library -- Packages needed in order to build this package.- Build-depends: base == 4.3.*,- containers >= 0.3 && < 0.5+ Build-depends: base >= 4.2 && < 4.4,+ containers >= 0.3 && < 0.5,+ monads-tf == 0.1.*,+ vector == 0.7.* + -- Modules exported by the library. Exposed-modules: Text.Regex.Applicative Text.Regex.Applicative.Reference@@ -70,9 +73,11 @@ -- Modules not exported by this package. Other-modules: Text.Regex.Applicative.Interface Text.Regex.Applicative.Implementation- Text.Regex.Applicative.Priorities+ Text.Regex.Applicative.Types+ Text.Regex.Applicative.Compile+ Text.Regex.Applicative.StateQueue -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: - GHC-Options: -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures+ GHC-Options: -O2 -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
test.hs view
@@ -60,7 +60,7 @@ re8 = (,) <$> many (sym 'a' <|> sym 'b') <*> many (sym 'b' <|> sym 'c') -prop re f (map f -> s) = reference re s == s =~ re+prop re f (map f -> s) = reference re s == (s =~ re) tests = [ depthCheck 10 $ prop re1 a