regex-applicative 0.1.5 → 0.2
raw patch · 9 files changed
+327/−75 lines, 9 filesdep +transformersdep −monads-tfdep ~basedep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies added: transformers
Dependencies removed: monads-tf
Dependency ranges changed: base, containers
API changes (from Hackage documentation)
+ Text.Regex.Applicative: findFirstInfix :: RE s a -> [s] -> Maybe ([s], a, [s])
+ Text.Regex.Applicative: findLongestInfix :: RE s a -> [s] -> Maybe ([s], a, [s])
+ Text.Regex.Applicative: findShortestInfix :: RE s a -> [s] -> Maybe ([s], a, [s])
Files
- CHANGES.md +7/−0
- Text/Regex/Applicative.hs +3/−0
- Text/Regex/Applicative/Compile.hs +108/−25
- Text/Regex/Applicative/Interface.hs +126/−6
- Text/Regex/Applicative/Object.hs +11/−9
- Text/Regex/Applicative/StateQueue.hs +4/−4
- Text/Regex/Applicative/Types.hs +13/−4
- regex-applicative.cabal +10/−6
- test.hs +45/−21
CHANGES.md view
@@ -1,6 +1,13 @@ Changes ======= +0.2+---+* Infix matching functions+* Improved documentation+* Improved performance+* Improved portability+ 0.1.5 ----- * Expose Object interface
Text/Regex/Applicative.hs view
@@ -25,6 +25,9 @@ , findFirstPrefix , findLongestPrefix , findShortestPrefix+ , findFirstInfix+ , findLongestInfix+ , findShortestInfix , module Control.Applicative ) where
Text/Regex/Applicative/Compile.hs view
@@ -1,12 +1,35 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, ViewPatterns #-}+{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-do-lambda-eta-expansion #-} module Text.Regex.Applicative.Compile (compile) where +import Control.Monad.Trans.State import Text.Regex.Applicative.Types+import Control.Applicative+import Data.Maybe+import qualified Data.IntMap as IntMap -compile :: forall a s r . RE s a -> (a -> [Thread s r]) -> [Thread s r]-compile e k = compile2 e k k+compile :: RE s a -> (a -> [Thread s r]) -> [Thread s r]+compile e k = compile2 e (SingleCont k) +data Cont a = SingleCont !a | EmptyNonEmpty !a !a++instance Functor Cont where+ fmap f k =+ case k of+ SingleCont a -> SingleCont (f a)+ EmptyNonEmpty a b -> EmptyNonEmpty (f a) (f b)++emptyCont :: Cont a -> a+emptyCont k =+ case k of+ SingleCont a -> a+ EmptyNonEmpty a _ -> a+nonEmptyCont :: Cont a -> a+nonEmptyCont k =+ case k of+ SingleCont a -> a+ EmptyNonEmpty _ a -> a+ -- The whole point of this module is this function, compile2, which needs to be -- compiled with -fno-do-lambda-eta-expansion for efficiency. --@@ -18,33 +41,93 @@ -- -- 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 . RE s a -> (a -> [Thread s r]) -> (a -> [Thread s r]) -> [Thread s r]+compile2 :: RE s a -> Cont (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+ Eps -> \k -> emptyCont k $ error "empty"+ Symbol i p -> \k -> [t $ nonEmptyCont k] 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)+ App n1 n2 ->+ let a1 = compile2 n1+ a2 = compile2 n2+ in \k -> case k of+ SingleCont k -> a1 $ SingleCont $ \a1_value -> a2 $ SingleCont $ k . a1_value+ EmptyNonEmpty ke kn ->+ a1 $ EmptyNonEmpty+ -- empty+ (\a1_value -> a2 $ EmptyNonEmpty (ke . a1_value) (kn . a1_value))+ -- non-empty+ (\a1_value -> a2 $ EmptyNonEmpty (kn . a1_value) (kn . a1_value))+ Alt n1 n2 ->+ let a1 = compile2 n1+ a2 = compile2 n2+ in \k -> a1 k ++ a2 k+ Fmap f n -> let a = compile2 n in \k -> a $ fmap (. f) k -- This is actually the point where we use the difference between -- continuations. For the inner RE the empty continuation is a -- "failing" one in order to avoid non-termination.- Rep g f b (compile2 -> a) ->- let combine continue stop =- case g of- Greedy -> continue ++ stop- NonGreedy -> stop ++ continue- threads b ke kn =- combine- (a (\_ -> []) (\v -> let b' = f b v in threads b' kn kn))- (ke b)+ Rep g f b n ->+ let a = compile2 n+ threads b k =+ combine g+ (a $ EmptyNonEmpty (\_ -> []) (\v -> let b' = f b v in threads b' (SingleCont $ nonEmptyCont k)))+ (emptyCont k b) in threads b+ Void n -> let a = compile2_ n in \k -> a $ fmap ($ ()) k++data FSMState+ = SAccept+ | STransition ThreadId++type FSMMap s = IntMap.IntMap (s -> Bool, [FSMState])++mkNFA :: RE s a -> ([FSMState], (FSMMap s))+mkNFA e =+ flip runState IntMap.empty $+ go e [SAccept]+ where+ go :: RE s a -> [FSMState] -> State (FSMMap s) [FSMState]+ go e k =+ case e of+ Eps -> return k+ Symbol i@(ThreadId n) p -> do+ modify $ IntMap.insert n $+ (p, k)+ return [STransition i]+ App n1 n2 -> go n1 =<< go n2 k+ Alt n1 n2 -> (++) <$> go n1 k <*> go n2 k+ Fmap _ n -> go n k+ Rep g _ _ n ->+ let entries = findEntries n+ cont = combine g entries k+ in+ -- return value of 'go' is ignored -- it should be a subset of+ -- 'cont'+ go n cont >> return cont+ Void n -> go n k++ findEntries :: RE s a -> [FSMState]+ findEntries e =+ -- A simple (although a bit inefficient) way to find all entry points is+ -- just to use 'go'+ evalState (go e []) IntMap.empty++compile2_ :: RE s a -> Cont [Thread s r] -> [Thread s r]+compile2_ e =+ let (entries, fsmap) = mkNFA e+ mkThread _ k1 (STransition i@(ThreadId n)) =+ let (p, cont) = fromMaybe (error "Unknown id") $ IntMap.lookup n fsmap+ in [Thread i $ \s ->+ if p s+ then concatMap (mkThread k1 k1) cont+ else []]+ mkThread k0 _ SAccept = k0++ in \k -> concatMap (mkThread (emptyCont k) (nonEmptyCont k)) entries++combine g continue stop =+ case g of+ Greedy -> continue ++ stop+ NonGreedy -> stop ++ continue
Text/Regex/Applicative/Interface.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE Rank2Types, FlexibleInstances, TypeFamilies, TupleSections #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Text.Regex.Applicative.Interface where import Control.Applicative hiding (empty) import qualified Control.Applicative+import Control.Arrow import Data.Traversable import Data.String import Data.Maybe@@ -11,15 +12,19 @@ instance Functor (RE s) where fmap f x = Fmap f x+ f <$ x = pure f <* x instance Applicative (RE s) where pure x = const x <$> Eps a1 <*> a2 = App a1 a2+ a *> b = pure (const id) <*> Void a <*> b+ a <* b = pure const <*> a <*> Void b instance Alternative (RE s) where a1 <|> a2 = Alt a1 a2 empty = Eps many a = reverse <$> Rep Greedy (flip (:)) [] a+ some a = (:) <$> a <*> many a instance (char ~ Char, string ~ String) => IsString (RE char string) where fromString = string@@ -77,7 +82,7 @@ -- | @s =~ a = match a s@ (=~) :: [s] -> RE s a -> Maybe a-s =~ a = match a s+(=~) = flip match infix 2 =~ -- | Attempt to match a string of symbols against the regular expression.@@ -91,10 +96,10 @@ -- >Nothing -- match :: RE s a -> [s] -> Maybe a-match re str =+match re = let obj = compile re in \str -> listToMaybe $ results $- foldl (flip step) (compile re) str+ foldl (flip step) obj str -- | Find a string prefix which is matched by the regular expression. --@@ -126,7 +131,7 @@ go obj str resOld = case walk emptyObject $ threads obj of (obj', resThis) ->- let res = ((,str) <$> resThis) <|> resOld+ let res = ((flip (,) str) <$> resThis) <|> resOld in case str of [] -> res@@ -153,7 +158,7 @@ findLongestPrefix re str = go (compile re) str Nothing where go obj str resOld =- let res = (fmap (,str) $ listToMaybe $ results obj) <|> resOld+ let res = (fmap (flip (,) str) $ listToMaybe $ results obj) <|> resOld in case str of [] -> res@@ -172,3 +177,118 @@ [] -> Nothing _ | failed obj -> Nothing s:ss -> go (step s obj) ss++-- | Find the leftmost substring that is matched by the regular expression.+-- Otherwise behaves like 'findFirstPrefix'. Returns the result together with+-- the prefix and suffix of the string surrounding the match.+findFirstInfix :: RE s a -> [s] -> Maybe ([s], a, [s])+findFirstInfix re str =+ fmap (\((first, res), last) -> (first, res, last)) $+ findFirstPrefix ((,) <$> few anySym <*> re) str++-- Auxiliary function for findExtremeInfix+prefixCounter :: RE s (Int, [s])+prefixCounter = second reverse <$> reFoldl NonGreedy f (0, []) anySym+ where+ f (i, prefix) s = ((,) $! (i+1)) $ s:prefix++data InfixMatchingState s a = GotResult+ { prefixLen :: !Int+ , prefixStr :: [s]+ , result :: a+ , postfixStr :: [s]+ }+ | NoResult++-- a `preferOver` b chooses one of a and b, giving preference to a+preferOver+ :: InfixMatchingState s a+ -> InfixMatchingState s a+ -> InfixMatchingState s a+preferOver NoResult b = b+preferOver b NoResult = b+preferOver a b =+ case prefixLen a `compare` prefixLen b of+ GT -> b -- prefer b when it has smaller prefix+ _ -> a -- otherwise, prefer a++mkInfixMatchingState+ :: [s] -- rest of input+ -> Thread s ((Int, [s]), a)+ -> InfixMatchingState s a+mkInfixMatchingState rest thread =+ case getResult thread of+ Just ((pLen, pStr), res) ->+ GotResult+ { prefixLen = pLen+ , prefixStr = pStr+ , result = res+ , postfixStr = rest+ }+ Nothing -> NoResult++gotResult :: InfixMatchingState s a -> Bool+gotResult GotResult {} = True+gotResult _ = False++-- Algorithm for finding leftmost longest infix match:+--+-- 1. Add a thread /.*?/ to the begginning of the regexp+-- 2. As soon as we get first accept, we delete that thread+-- 3. When we get more than one accept, we choose one by the following criteria:+-- 3.1. Compare by the length of prefix (since we are looking for the leftmost+-- match)+-- 3.2. If they are produced on the same step, choose the first one (left-biased+-- choice)+-- 3.3. If they are produced on the different steps, choose the later one (since+-- they have the same prefixes, later means longer)+findExtremalInfix+ :: -- function to combine a later result (first arg) to an earlier one (second+ -- arg)+ (InfixMatchingState s a -> InfixMatchingState s a -> InfixMatchingState s a)+ -> RE s a+ -> [s]+ -> Maybe ([s], a, [s])+findExtremalInfix newOrOld re str =+ case go (compile $ (,) <$> prefixCounter <*> re) str NoResult of+ NoResult -> Nothing+ r@GotResult{} ->+ Just (prefixStr r, result r, postfixStr r)+ where+ {-+ go :: ReObject s ((Int, [s]), a)+ -> [s]+ -> InfixMatchingState s a+ -> InfixMatchingState s a+ -}+ go obj str resOld =+ let resThis =+ foldl+ (\acc t -> acc `preferOver` mkInfixMatchingState str t)+ NoResult $+ threads obj+ res = resThis `newOrOld` resOld+ obj' =+ -- If we just found the first result, kill the "prefixCounter" thread.+ -- We rely on the fact that it is the last thread of the object.+ if gotResult resThis && not (gotResult resOld)+ then fromThreads $ init $ threads obj+ else obj+ in+ case str of+ [] -> res+ _ | failed obj -> res+ (s:ss) -> go (step s obj') ss res+++-- | Find the leftmost substring that is matched by the regular expression.+-- Otherwise behaves like 'findLongestPrefix'. Returns the result together with+-- the prefix and suffix of the string surrounding the match.+findLongestInfix :: RE s a -> [s] -> Maybe ([s], a, [s])+findLongestInfix = findExtremalInfix preferOver++-- | Find the leftmost substring that is matched by the regular expression.+-- Otherwise behaves like 'findShortestPrefix'. Returns the result together with+-- the prefix and suffix of the string surrounding the match.+findShortestInfix :: RE s a -> [s] -> Maybe ([s], a, [s])+findShortestInfix = findExtremalInfix $ flip preferOver
Text/Regex/Applicative/Object.hs view
@@ -9,7 +9,7 @@ -- -- This is a low-level interface to the regex engine. ---------------------------------------------------------------------{-# LANGUAGE TypeFamilies, GADTs #-}+{-# LANGUAGE GADTs #-} module Text.Regex.Applicative.Object ( ReObject , compile@@ -32,7 +32,8 @@ import qualified Text.Regex.Applicative.StateQueue as SQ import qualified Text.Regex.Applicative.Compile as Compile import Data.Maybe-import Control.Monad.State+import Data.List+import Control.Monad.Trans.State import Control.Applicative hiding (empty) -- | The state of the engine is represented as a \"regex object\" of type@@ -50,7 +51,7 @@ -- threads come from the same 'ReObject', unless you know what you're doing. -- However, it should be safe to filter out or rearrange threads. fromThreads :: [Thread s r] -> ReObject s r-fromThreads ts = foldl (flip addThread) emptyObject ts+fromThreads ts = foldl' (flip addThread) emptyObject ts -- | Check whether a thread is a result thread isResult :: Thread s r -> Bool@@ -84,7 +85,7 @@ case t of Accept {} -> q Thread _ c ->- foldl (\q x -> addThread x q) q $ c s+ foldl' (\q x -> addThread x q) q $ c s newQueue = SQ.fold accum emptyObject sq in newQueue @@ -115,7 +116,7 @@ renumber renumber :: RE s a -> RE s a-renumber e = flip evalState 1 $ go e+renumber e = flip evalState (ThreadId 1) $ go e where go :: RE s a -> State ThreadId (RE s a) go e =@@ -126,9 +127,10 @@ App a1 a2 -> App <$> go a1 <*> go a2 Fmap f a -> Fmap f <$> go a Rep g f b a -> Rep g f b <$> go a+ Void a -> Void <$> go a -fresh :: (MonadState m, StateType m ~ ThreadId) => m ThreadId+fresh :: State ThreadId ThreadId fresh = do- i <- get- put $! i+1- return i+ t@(ThreadId i) <- get+ put $! ThreadId (i+1)+ return t
Text/Regex/Applicative/StateQueue.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} module Text.Regex.Applicative.StateQueue ( StateQueue , empty@@ -10,10 +9,11 @@ import Prelude hiding (read, lookup, replicate) import qualified Data.IntSet as IntSet+import Data.List (foldl') data StateQueue a = StateQueue { elements :: [a]- , ids :: IntSet.IntSet+ , ids :: !IntSet.IntSet } getElements :: StateQueue a -> [a]@@ -32,7 +32,7 @@ -> a -> StateQueue a -> StateQueue a-insertUnique i v sq@StateQueue {..} =+insertUnique i v sq@StateQueue { ids = ids, elements = elements } = if i `IntSet.member` ids then sq else sq { elements = v : elements@@ -48,4 +48,4 @@ {-# INLINE fold #-} fold :: (a -> x -> a) -> a -> StateQueue x -> a-fold f acc0 sq = foldl f acc0 (reverse $ elements sq)+fold f acc0 sq = foldl' f acc0 (reverse $ elements sq)
Text/Regex/Applicative/Types.hs view
@@ -1,9 +1,14 @@-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-do-lambda-eta-expansion #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-do-lambda-eta-expansion -fno-warn-unused-imports #-} module Text.Regex.Applicative.Types where +import Control.Applicative+-- The above import is needed for haddock to properly generate links to+-- Applicative methods. But it's not actually used in the code, hence+-- -fno-warn-unused-imports.++ newtype ThreadId = ThreadId Int- deriving (Show, Eq, Ord, Num, Real, Enum, Integral) -- | A thread either is a result or corresponds to a symbol in the regular -- expression, which is expected by that thread.@@ -43,10 +48,13 @@ -- * @ra@ '<|>' @rb@ matches a string which is accepted by either @ra@ or @rb@. -- It is left-biased, so if both can match, the result of @ra@ is used. ----- * 'Control.Applicative.empty' is a regular expression which does not match any string.+-- * 'empty' is a regular expression which does not match any string. -- -- * 'many' @ra@ matches concatenation of zero or more strings matched by @ra@ -- and returns the list of @ra@'s return values on those strings.+--+-- * 'some' @ra@ matches concatenation of one or more strings matched by @ra@+-- and returns the list of @ra@'s return values on those strings. data RE s a where Eps :: RE s a Symbol :: ThreadId -> (s -> Bool) -> RE s s@@ -59,3 +67,4 @@ -- for the folding function -> RE s a -> RE s b+ Void :: RE s a -> RE s ()
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.5+Version: 0.2 -- A short (one-line) description of the package. Synopsis: Regex-based parsing with applicative interface@@ -56,13 +56,13 @@ Source-repository this type: git location: git://github.com/feuerbach/regex-applicative.git- tag: v0.1.5+ tag: v0.2 Library -- Packages needed in order to build this package.- Build-depends: base >= 4.2 && < 4.5,- containers >= 0.3 && < 0.5,- monads-tf == 0.1.*+ Build-depends: base < 5,+ containers,+ transformers -- Modules exported by the library.@@ -78,4 +78,8 @@ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: - GHC-Options: -O2 -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures+ GHC-Options: -O2+ -Wall+ -fno-warn-name-shadowing+ -fno-warn-missing-signatures+ -fno-warn-orphans
test.hs view
@@ -1,12 +1,16 @@-{-# LANGUAGE ViewPatterns #-} import Text.Regex.Applicative import Text.Regex.Applicative.Reference import Control.Applicative import Control.Monad-import Test.SmallCheck import Data.Traversable+import Data.Maybe import Text.Printf +import Test.SmallCheck+import Test.SmallCheck.Series+import Test.Framework+import Test.Framework.Providers.SmallCheck+ -- Small alphabets as SmallCheck's series newtype A = A { a :: Char } deriving Show instance Serial A where@@ -60,25 +64,45 @@ re8 = (,) <$> many (sym 'a' <|> sym 'b') <*> many (sym 'b' <|> sym 'c') -prop re f (map f -> s) = reference re s == (s =~ re)+-- NB: we don't test these against the reference impl, 'cause it will loop!+re9 = many (sym 'a' <|> empty) <* sym 'b'+re10 = few (sym 'a' <|> empty) <* sym 'b' -tests =- [ depthCheck 10 $ prop re1 a- , depthCheck 10 $ prop re2 ab- , depthCheck 10 $ prop re3 ab- , depthCheck 10 $ prop re4 ab- , depthCheck 10 $ prop re5 a- , depthCheck 10 $ prop re6 a- , depthCheck 7 $ prop re7 abc- , depthCheck 7 $ prop re8 abc- ]+prop re f s =+ let fs = map f s in+ reference re fs == (fs =~ re) -main = do- foldM runTest (1 :: Int) tests- return ()+-- Because we have 2 slightly different algorithms for recognition and parsing,+-- we test that they agree+testRecognitionAgainstParsing re f s =+ let fs = map f s in+ isJust (fs =~ re) == isJust (fs =~ (re *> pure ()))++tests =+ [ testGroup "Engine tests"+ [ t "re1" 10 $ prop re1 a+ , t "re2" 10 $ prop re2 ab+ , t "re3" 10 $ prop re3 ab+ , t "re4" 10 $ prop re4 ab+ , t "re5" 10 $ prop re5 a+ , t "re6" 10 $ prop re6 a+ , t "re7" 7 $ prop re7 abc+ , t "re8" 7 $ prop re8 abc+ ]+ , testGroup "Recognition vs parsing"+ [ t "re1" 10 $ testRecognitionAgainstParsing re1 a+ , t "re2" 10 $ testRecognitionAgainstParsing re2 ab+ , t "re3" 10 $ testRecognitionAgainstParsing re3 ab+ , t "re4" 10 $ testRecognitionAgainstParsing re4 ab+ , t "re5" 10 $ testRecognitionAgainstParsing re5 a+ , t "re6" 10 $ testRecognitionAgainstParsing re6 a+ , t "re7" 7 $ testRecognitionAgainstParsing re7 abc+ , t "re8" 7 $ testRecognitionAgainstParsing re8 abc+ , t "re8" 10 $ testRecognitionAgainstParsing re9 ab+ , t "re8" 10 $ testRecognitionAgainstParsing re10 ab+ ]+ ] where- runTest n test = do- printf "Running test case %d...\n" n- test- printf "\n"- return $ n+1+ t name n = withDepth n . testProperty name++main = defaultMain tests