regex-tdfa 0.97.4 → 1.0.0
raw patch · 25 files changed
+2728/−2639 lines, 25 filesdep ~regex-base
Dependency ranges changed: regex-base
Files
- Data/IntMap/CharMap.hs +0/−319
- Data/IntMap/CharMap2.hs +319/−0
- Data/IntMap/EnumMap.hs +0/−248
- Data/IntMap/EnumMap2.hs +248/−0
- Data/IntSet/EnumSet.hs +0/−106
- Data/IntSet/EnumSet2.hs +106/−0
- LICENSE +1/−1
- Text/Regex/TDFA.hs +5/−4
- Text/Regex/TDFA/ByteString.hs +15/−11
- Text/Regex/TDFA/ByteString/Lazy.hs +23/−11
- Text/Regex/TDFA/Common.hs +159/−63
- Text/Regex/TDFA/CorePattern.hs +291/−161
- Text/Regex/TDFA/MutRun.hs +0/−190
- Text/Regex/TDFA/MutRunBS.hs +0/−169
- Text/Regex/TDFA/MutRunLBS.hs +0/−168
- Text/Regex/TDFA/MutRunSeq.hs +0/−184
- Text/Regex/TDFA/NewDFA.hs +884/−0
- Text/Regex/TDFA/Pattern.hs +129/−118
- Text/Regex/TDFA/ReadRegex.hs +8/−3
- Text/Regex/TDFA/RunMutState.hs +0/−632
- Text/Regex/TDFA/Sequence.hs +16/−11
- Text/Regex/TDFA/String.hs +8/−10
- Text/Regex/TDFA/TDFA.hs +245/−51
- Text/Regex/TDFA/TNFA.hs +225/−142
- regex-tdfa.cabal +46/−37
− Data/IntMap/CharMap.hs
@@ -1,319 +0,0 @@-{-# LANGUAGE CPP #-}-module Data.IntMap.CharMap where--#ifdef __GLASGOW_HASKELL__-import GHC.Base(unsafeChr)-#else-import Data.Char (chr)-#endif-import Data.Char as C(ord)-import Data.List as L (map)-import qualified Data.IntMap as M-import qualified Data.IntSet as S(IntSet)-import Data.Monoid(Monoid(..))--#ifndef __GLASGOW_HASKELL__-unsafeChr = chr-#endif--newtype CharMap a = CharMap {unCharMap :: M.IntMap a} deriving (Eq,Ord,Read,Show)--instance Monoid (CharMap a) where- mempty = CharMap mempty- CharMap x `mappend` CharMap y = CharMap (x `mappend` y)--instance Functor CharMap where- fmap f (CharMap m) = CharMap (fmap f m)--type Key = Char--(!) :: CharMap a -> Key -> a-(!) (CharMap m) k = (M.!) m (C.ord k)--(\\) :: CharMap a -> CharMap b -> CharMap a-(\\) (CharMap m1) (CharMap m2) = CharMap ((M.\\) m1 m2)--null :: CharMap a -> Bool-null (CharMap m) = M.null m--size :: CharMap a -> Int-size (CharMap m) = M.size m--member :: Key -> CharMap a -> Bool-member k (CharMap m) = M.member (C.ord k) m--notMember :: Key -> CharMap a -> Bool-notMember k (CharMap m) = M.notMember (C.ord k) m--lookup :: Key -> CharMap a -> Maybe a-lookup k (CharMap m) = M.lookup (C.ord k) m--findWithDefault :: a -> Key -> CharMap a -> a-findWithDefault a k (CharMap m) = M.findWithDefault a (C.ord k) m--empty :: CharMap a-empty = CharMap M.empty--singleton :: Key -> a -> CharMap a-singleton k a = CharMap (M.singleton (C.ord k) a)--insert :: Key -> a -> CharMap a -> CharMap a-insert k a (CharMap m) = CharMap (M.insert (C.ord k) a m)--insertWith :: (a -> a -> a) -> Key -> a -> CharMap a -> CharMap a-insertWith f k a (CharMap m) = CharMap (M.insertWith f (C.ord k) a m)--insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> CharMap a -> CharMap a-insertWithKey f k a (CharMap m) = CharMap (M.insertWithKey f' (C.ord k) a m)- where f' b a1 a2 = f (unsafeChr b) a1 a2--insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> CharMap a -> (Maybe a, CharMap a)-insertLookupWithKey f k a (CharMap m) = (ma,CharMap m')- where (ma,m') = M.insertLookupWithKey f' (C.ord k) a m- f' b a1 a2 = f (unsafeChr b) a1 a2--delete :: Key -> CharMap a -> CharMap a-delete k (CharMap m) = CharMap (M.delete (C.ord k) m)--adjust :: (a -> a) -> Key -> CharMap a -> CharMap a-adjust f k (CharMap m) = CharMap (M.adjust f (C.ord k) m)--adjustWithKey :: (Key -> a -> a) -> Key -> CharMap a -> CharMap a-adjustWithKey f k (CharMap m) = CharMap (M.adjustWithKey f' (C.ord k) m)- where f' b a = f (unsafeChr b) a--update :: (a -> Maybe a) -> Key -> CharMap a -> CharMap a-update f k (CharMap m) = CharMap (M.update f (C.ord k) m)--updateWithKey :: (Key -> a -> Maybe a) -> Key -> CharMap a -> CharMap a-updateWithKey f k (CharMap m) = CharMap (M.updateWithKey f' (C.ord k) m)- where f' b a = f (unsafeChr b) a--updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> CharMap a -> (Maybe a, CharMap a)-updateLookupWithKey f k (CharMap m) = (a,CharMap m')- where (a,m') = M.updateLookupWithKey f' (C.ord k) m- f' b a1 = f (unsafeChr b) a1--union :: CharMap a -> CharMap a -> CharMap a-union (CharMap m1) (CharMap m2) = CharMap (M.union m1 m2)--unionWith :: (a -> a -> a) -> CharMap a -> CharMap a -> CharMap a-unionWith f (CharMap m1) (CharMap m2) = CharMap (M.unionWith f m1 m2)--unionWithKey :: (Key -> a -> a -> a) -> CharMap a -> CharMap a -> CharMap a-unionWithKey f (CharMap m1) (CharMap m2) = CharMap (M.unionWithKey f' m1 m2)- where f' b a1 a2 = f (unsafeChr b) a1 a2--unions :: [CharMap a] -> CharMap a-unions cs = CharMap (M.unions (L.map unCharMap cs))--unionsWith :: (a -> a -> a) -> [CharMap a] -> CharMap a-unionsWith f cs = CharMap (M.unionsWith f (L.map unCharMap cs))--difference :: CharMap a -> CharMap b -> CharMap a-difference (CharMap m1) (CharMap m2) = CharMap (M.difference m1 m2)--differenceWith :: (a -> b -> Maybe a) -> CharMap a -> CharMap b -> CharMap a-differenceWith f (CharMap m1) (CharMap m2) = CharMap (M.differenceWith f m1 m2)--differenceWithKey :: (Key -> a -> b -> Maybe a) -> CharMap a -> CharMap b -> CharMap a-differenceWithKey f (CharMap m1) (CharMap m2) = CharMap (M.differenceWithKey f' m1 m2)- where f' b a1 a2 = f (unsafeChr b) a1 a2--intersection :: CharMap a -> CharMap b -> CharMap a-intersection (CharMap m1) (CharMap m2) = CharMap (M.intersection m1 m2)--intersectionWith :: (a -> b -> a) -> CharMap a -> CharMap b -> CharMap a-intersectionWith f (CharMap m1) (CharMap m2) = CharMap (M.intersectionWith f m1 m2)--intersectionWithKey :: (Key -> a -> b -> a) -> CharMap a -> CharMap b -> CharMap a-intersectionWithKey f (CharMap m1) (CharMap m2) = CharMap (M.intersectionWithKey f' m1 m2)- where f' b a1 a2 = f (unsafeChr b) a1 a2--map :: (a -> b) -> CharMap a -> CharMap b-map f (CharMap m) = CharMap (M.map f m)--mapWithKey :: (Key -> a -> b) -> CharMap a -> CharMap b-mapWithKey f (CharMap m) = CharMap (M.mapWithKey f' m)- where f' b a = f (unsafeChr b) a--mapAccum :: (a -> b -> (a, c)) -> a -> CharMap b -> (a, CharMap c)-mapAccum f a (CharMap m) = (a',CharMap m')- where (a',m') = M.mapAccum f a m--mapAccumWithKey :: (a -> Key -> b -> (a, c)) -> a -> CharMap b -> (a, CharMap c)-mapAccumWithKey f a (CharMap m) = (a',CharMap m')- where (a',m') = M.mapAccumWithKey f' a m- f' a1 b a2 = f a1 (unsafeChr b) a2--fold :: (a -> b -> b) -> b -> CharMap a -> b-fold f a (CharMap m) = M.fold f a m--foldWithKey :: (Key -> a -> b -> b) -> b -> CharMap a -> b-foldWithKey f a (CharMap m) = M.foldWithKey f' a m- where f' b a1 a2 = f (unsafeChr b) a1 a2--elems :: CharMap a -> [a]-elems (CharMap m) = M.elems m--keys :: CharMap a -> [Key]-keys (CharMap m) = L.map unsafeChr (M.keys m)--keysSet :: CharMap a -> S.IntSet-keysSet (CharMap m) = M.keysSet m--assocs :: CharMap a -> [(Key, a)]-assocs (CharMap m) = L.map (\(b,a) -> (unsafeChr b,a)) (M.assocs m)--toList :: CharMap a -> [(Key, a)]-toList (CharMap m) = L.map (\(b,a) -> (unsafeChr b,a)) (M.toList m)--fromList :: [(Key, a)] -> CharMap a-fromList ka = CharMap (M.fromList (L.map (\(k,a) -> (C.ord k,a)) ka))--fromListWith :: (a -> a -> a) -> [(Key, a)] -> CharMap a-fromListWith f ka = CharMap (M.fromListWith f (L.map (\(k,a) -> (C.ord k,a)) ka))--fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> CharMap a-fromListWithKey f ka = CharMap (M.fromListWithKey f' (L.map (\(k,a) -> (C.ord k,a)) ka))- where f' b a1 a2 = f (unsafeChr b) a1 a2--toAscList :: CharMap a -> [(Key, a)]-toAscList (CharMap m) = L.map (\(b,a) -> (unsafeChr b,a)) (M.toAscList m)--fromAscList :: [(Key, a)] -> CharMap a-fromAscList ka = CharMap (M.fromAscList (L.map (\(k,a) -> (C.ord k,a)) ka))--fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> CharMap a-fromAscListWith f ka = CharMap (M.fromAscListWith f (L.map (\(k,a) -> (C.ord k,a)) ka))--fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> CharMap a-fromAscListWithKey f ka = CharMap (M.fromAscListWithKey f' (L.map (\(k,a) -> (C.ord k,a)) ka))- where f' b a1 a2 = f (unsafeChr b) a1 a2--fromDistinctAscList :: [(Key, a)] -> CharMap a-fromDistinctAscList ka = CharMap (M.fromDistinctAscList (L.map (\(k,a) -> (C.ord k,a)) ka))--filter :: (a -> Bool) -> CharMap a -> CharMap a-filter f (CharMap m) = CharMap (M.filter f m)--filterWithKey :: (Key -> a -> Bool) -> CharMap a -> CharMap a-filterWithKey f (CharMap m) = CharMap (M.filterWithKey f' m)- where f' b a = f (unsafeChr b) a--partition :: (a -> Bool) -> CharMap a -> (CharMap a, CharMap a)-partition f (CharMap m) = (CharMap m1', CharMap m2')- where (m1',m2') = M.partition f m--partitionWithKey :: (Key -> a -> Bool) -> CharMap a -> (CharMap a, CharMap a)-partitionWithKey f (CharMap m) = (CharMap m1', CharMap m2')- where (m1',m2') = M.partitionWithKey f' m- f' b a = f (unsafeChr b) a--mapMaybe :: (a -> Maybe b) -> CharMap a -> CharMap b-mapMaybe f (CharMap m) = CharMap (M.mapMaybe f m)--mapMaybeWithKey :: (Key -> a -> Maybe b) -> CharMap a -> CharMap b-mapMaybeWithKey f (CharMap m) = CharMap (M.mapMaybeWithKey f' m)- where f' b a = f (unsafeChr b) a--mapEither :: (a -> Either b c) -> CharMap a -> (CharMap b, CharMap c)-mapEither f (CharMap m) = (CharMap m1', CharMap m2')- where (m1',m2') = M.mapEither f m--mapEitherWithKey :: (Key -> a -> Either b c) -> CharMap a -> (CharMap b, CharMap c)-mapEitherWithKey f (CharMap m) = (CharMap m1', CharMap m2')- where (m1',m2') = M.mapEitherWithKey f' m- f' b a = f (unsafeChr b) a--split :: Key -> CharMap a -> (CharMap a, CharMap a)-split k (CharMap m) = (CharMap m1', CharMap m2')- where (m1',m2') = M.split (C.ord k) m--splitLookup :: Key -> CharMap a -> (CharMap a, Maybe a, CharMap a)-splitLookup k (CharMap m) = (CharMap m1', a, CharMap m2')- where (m1',a,m2') = M.splitLookup (C.ord k) m--isSubmapOf :: Eq a => CharMap a -> CharMap a -> Bool-isSubmapOf (CharMap m1) (CharMap m2) = M.isSubmapOf m1 m2--isSubmapOfBy :: (a -> b -> Bool) -> CharMap a -> CharMap b -> Bool-isSubmapOfBy f (CharMap m1) (CharMap m2) = M.isSubmapOfBy f m1 m2--isProperSubmapOf :: Eq a => CharMap a -> CharMap a -> Bool-isProperSubmapOf (CharMap m1) (CharMap m2) = M.isProperSubmapOf m1 m2--isProperSubmapOfBy :: (a -> b -> Bool) -> CharMap a -> CharMap b -> Bool-isProperSubmapOfBy f (CharMap m1) (CharMap m2) = M.isProperSubmapOfBy f m1 m2--showTree :: Show a => CharMap a -> String-showTree (CharMap m) = M.showTree m--showTreeWith :: Show a => Bool -> Bool -> CharMap a -> String-showTreeWith b1 b2 (CharMap m) = M.showTreeWith b1 b2 m-{-# INLINE (!) #-}-{-# INLINE (\\) #-}-{-# INLINE null #-}-{-# INLINE size #-}-{-# INLINE member #-}-{-# INLINE notMember #-}-{-# INLINE lookup #-}-{-# INLINE findWithDefault #-}-{-# INLINE empty #-}-{-# INLINE singleton #-}-{-# INLINE insert #-}-{-# INLINE insertWith #-}-{-# INLINE insertWithKey #-}-{-# INLINE insertLookupWithKey #-}-{-# INLINE delete #-}-{-# INLINE adjust #-}-{-# INLINE adjustWithKey #-}-{-# INLINE update #-}-{-# INLINE updateWithKey #-}-{-# INLINE updateLookupWithKey #-}-{-# INLINE union #-}-{-# INLINE unionWith #-}-{-# INLINE unionWithKey #-}-{-# INLINE unions #-}-{-# INLINE unionsWith #-}-{-# INLINE difference #-}-{-# INLINE differenceWith #-}-{-# INLINE differenceWithKey #-}-{-# INLINE intersection #-}-{-# INLINE intersectionWith #-}-{-# INLINE intersectionWithKey #-}-{-# INLINE map #-}-{-# INLINE mapWithKey #-}-{-# INLINE mapAccum #-}-{-# INLINE mapAccumWithKey #-}-{-# INLINE fold #-}-{-# INLINE foldWithKey #-}-{-# INLINE elems #-}-{-# INLINE keys #-}-{-# INLINE keysSet #-}-{-# INLINE assocs #-}-{-# INLINE toList #-}-{-# INLINE fromList #-}-{-# INLINE fromListWith #-}-{-# INLINE fromListWithKey #-}-{-# INLINE toAscList #-}-{-# INLINE fromAscList #-}-{-# INLINE fromAscListWith #-}-{-# INLINE fromAscListWithKey #-}-{-# INLINE fromDistinctAscList #-}-{-# INLINE filter #-}-{-# INLINE filterWithKey #-}-{-# INLINE partition #-}-{-# INLINE partitionWithKey #-}-{-# INLINE mapMaybe #-}-{-# INLINE mapMaybeWithKey #-}-{-# INLINE mapEither #-}-{-# INLINE mapEitherWithKey #-}-{-# INLINE split #-}-{-# INLINE splitLookup #-}-{-# INLINE isSubmapOf #-}-{-# INLINE isSubmapOfBy #-}-{-# INLINE isProperSubmapOf #-}-{-# INLINE isProperSubmapOfBy #-}-{-# INLINE showTree #-}-{-# INLINE showTreeWith #-}
+ Data/IntMap/CharMap2.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE CPP #-}+module Data.IntMap.CharMap2 where++#ifdef __GLASGOW_HASKELL__+import GHC.Base(unsafeChr)+#else+import Data.Char (chr)+#endif+import Data.Char as C(ord)+import Data.List as L (map)+import qualified Data.IntMap as M+import qualified Data.IntSet as S(IntSet)+import Data.Monoid(Monoid(..))++#ifndef __GLASGOW_HASKELL__+unsafeChr = chr+#endif++newtype CharMap a = CharMap {unCharMap :: M.IntMap a} deriving (Eq,Ord,Read,Show)++instance Monoid (CharMap a) where+ mempty = CharMap mempty+ CharMap x `mappend` CharMap y = CharMap (x `mappend` y)++instance Functor CharMap where+ fmap f (CharMap m) = CharMap (fmap f m)++type Key = Char++(!) :: CharMap a -> Key -> a+(!) (CharMap m) k = (M.!) m (C.ord k)++(\\) :: CharMap a -> CharMap b -> CharMap a+(\\) (CharMap m1) (CharMap m2) = CharMap ((M.\\) m1 m2)++null :: CharMap a -> Bool+null (CharMap m) = M.null m++size :: CharMap a -> Int+size (CharMap m) = M.size m++member :: Key -> CharMap a -> Bool+member k (CharMap m) = M.member (C.ord k) m++notMember :: Key -> CharMap a -> Bool+notMember k (CharMap m) = M.notMember (C.ord k) m++lookup :: Key -> CharMap a -> Maybe a+lookup k (CharMap m) = M.lookup (C.ord k) m++findWithDefault :: a -> Key -> CharMap a -> a+findWithDefault a k (CharMap m) = M.findWithDefault a (C.ord k) m++empty :: CharMap a+empty = CharMap M.empty++singleton :: Key -> a -> CharMap a+singleton k a = CharMap (M.singleton (C.ord k) a)++insert :: Key -> a -> CharMap a -> CharMap a+insert k a (CharMap m) = CharMap (M.insert (C.ord k) a m)++insertWith :: (a -> a -> a) -> Key -> a -> CharMap a -> CharMap a+insertWith f k a (CharMap m) = CharMap (M.insertWith f (C.ord k) a m)++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> CharMap a -> CharMap a+insertWithKey f k a (CharMap m) = CharMap (M.insertWithKey f' (C.ord k) a m)+ where f' b a1 a2 = f (unsafeChr b) a1 a2++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> CharMap a -> (Maybe a, CharMap a)+insertLookupWithKey f k a (CharMap m) = (ma,CharMap m')+ where (ma,m') = M.insertLookupWithKey f' (C.ord k) a m+ f' b a1 a2 = f (unsafeChr b) a1 a2++delete :: Key -> CharMap a -> CharMap a+delete k (CharMap m) = CharMap (M.delete (C.ord k) m)++adjust :: (a -> a) -> Key -> CharMap a -> CharMap a+adjust f k (CharMap m) = CharMap (M.adjust f (C.ord k) m)++adjustWithKey :: (Key -> a -> a) -> Key -> CharMap a -> CharMap a+adjustWithKey f k (CharMap m) = CharMap (M.adjustWithKey f' (C.ord k) m)+ where f' b a = f (unsafeChr b) a++update :: (a -> Maybe a) -> Key -> CharMap a -> CharMap a+update f k (CharMap m) = CharMap (M.update f (C.ord k) m)++updateWithKey :: (Key -> a -> Maybe a) -> Key -> CharMap a -> CharMap a+updateWithKey f k (CharMap m) = CharMap (M.updateWithKey f' (C.ord k) m)+ where f' b a = f (unsafeChr b) a++updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> CharMap a -> (Maybe a, CharMap a)+updateLookupWithKey f k (CharMap m) = (a,CharMap m')+ where (a,m') = M.updateLookupWithKey f' (C.ord k) m+ f' b a1 = f (unsafeChr b) a1++union :: CharMap a -> CharMap a -> CharMap a+union (CharMap m1) (CharMap m2) = CharMap (M.union m1 m2)++unionWith :: (a -> a -> a) -> CharMap a -> CharMap a -> CharMap a+unionWith f (CharMap m1) (CharMap m2) = CharMap (M.unionWith f m1 m2)++unionWithKey :: (Key -> a -> a -> a) -> CharMap a -> CharMap a -> CharMap a+unionWithKey f (CharMap m1) (CharMap m2) = CharMap (M.unionWithKey f' m1 m2)+ where f' b a1 a2 = f (unsafeChr b) a1 a2++unions :: [CharMap a] -> CharMap a+unions cs = CharMap (M.unions (L.map unCharMap cs))++unionsWith :: (a -> a -> a) -> [CharMap a] -> CharMap a+unionsWith f cs = CharMap (M.unionsWith f (L.map unCharMap cs))++difference :: CharMap a -> CharMap b -> CharMap a+difference (CharMap m1) (CharMap m2) = CharMap (M.difference m1 m2)++differenceWith :: (a -> b -> Maybe a) -> CharMap a -> CharMap b -> CharMap a+differenceWith f (CharMap m1) (CharMap m2) = CharMap (M.differenceWith f m1 m2)++differenceWithKey :: (Key -> a -> b -> Maybe a) -> CharMap a -> CharMap b -> CharMap a+differenceWithKey f (CharMap m1) (CharMap m2) = CharMap (M.differenceWithKey f' m1 m2)+ where f' b a1 a2 = f (unsafeChr b) a1 a2++intersection :: CharMap a -> CharMap b -> CharMap a+intersection (CharMap m1) (CharMap m2) = CharMap (M.intersection m1 m2)++intersectionWith :: (a -> b -> a) -> CharMap a -> CharMap b -> CharMap a+intersectionWith f (CharMap m1) (CharMap m2) = CharMap (M.intersectionWith f m1 m2)++intersectionWithKey :: (Key -> a -> b -> a) -> CharMap a -> CharMap b -> CharMap a+intersectionWithKey f (CharMap m1) (CharMap m2) = CharMap (M.intersectionWithKey f' m1 m2)+ where f' b a1 a2 = f (unsafeChr b) a1 a2++map :: (a -> b) -> CharMap a -> CharMap b+map f (CharMap m) = CharMap (M.map f m)++mapWithKey :: (Key -> a -> b) -> CharMap a -> CharMap b+mapWithKey f (CharMap m) = CharMap (M.mapWithKey f' m)+ where f' b a = f (unsafeChr b) a++mapAccum :: (a -> b -> (a, c)) -> a -> CharMap b -> (a, CharMap c)+mapAccum f a (CharMap m) = (a',CharMap m')+ where (a',m') = M.mapAccum f a m++mapAccumWithKey :: (a -> Key -> b -> (a, c)) -> a -> CharMap b -> (a, CharMap c)+mapAccumWithKey f a (CharMap m) = (a',CharMap m')+ where (a',m') = M.mapAccumWithKey f' a m+ f' a1 b a2 = f a1 (unsafeChr b) a2++fold :: (a -> b -> b) -> b -> CharMap a -> b+fold f a (CharMap m) = M.fold f a m++foldWithKey :: (Key -> a -> b -> b) -> b -> CharMap a -> b+foldWithKey f a (CharMap m) = M.foldWithKey f' a m+ where f' b a1 a2 = f (unsafeChr b) a1 a2++elems :: CharMap a -> [a]+elems (CharMap m) = M.elems m++keys :: CharMap a -> [Key]+keys (CharMap m) = L.map unsafeChr (M.keys m)++keysSet :: CharMap a -> S.IntSet+keysSet (CharMap m) = M.keysSet m++assocs :: CharMap a -> [(Key, a)]+assocs (CharMap m) = L.map (\(b,a) -> (unsafeChr b,a)) (M.assocs m)++toList :: CharMap a -> [(Key, a)]+toList (CharMap m) = L.map (\(b,a) -> (unsafeChr b,a)) (M.toList m)++fromList :: [(Key, a)] -> CharMap a+fromList ka = CharMap (M.fromList (L.map (\(k,a) -> (C.ord k,a)) ka))++fromListWith :: (a -> a -> a) -> [(Key, a)] -> CharMap a+fromListWith f ka = CharMap (M.fromListWith f (L.map (\(k,a) -> (C.ord k,a)) ka))++fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> CharMap a+fromListWithKey f ka = CharMap (M.fromListWithKey f' (L.map (\(k,a) -> (C.ord k,a)) ka))+ where f' b a1 a2 = f (unsafeChr b) a1 a2++toAscList :: CharMap a -> [(Key, a)]+toAscList (CharMap m) = L.map (\(b,a) -> (unsafeChr b,a)) (M.toAscList m)++fromAscList :: [(Key, a)] -> CharMap a+fromAscList ka = CharMap (M.fromAscList (L.map (\(k,a) -> (C.ord k,a)) ka))++fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> CharMap a+fromAscListWith f ka = CharMap (M.fromAscListWith f (L.map (\(k,a) -> (C.ord k,a)) ka))++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> CharMap a+fromAscListWithKey f ka = CharMap (M.fromAscListWithKey f' (L.map (\(k,a) -> (C.ord k,a)) ka))+ where f' b a1 a2 = f (unsafeChr b) a1 a2++fromDistinctAscList :: [(Key, a)] -> CharMap a+fromDistinctAscList ka = CharMap (M.fromDistinctAscList (L.map (\(k,a) -> (C.ord k,a)) ka))++filter :: (a -> Bool) -> CharMap a -> CharMap a+filter f (CharMap m) = CharMap (M.filter f m)++filterWithKey :: (Key -> a -> Bool) -> CharMap a -> CharMap a+filterWithKey f (CharMap m) = CharMap (M.filterWithKey f' m)+ where f' b a = f (unsafeChr b) a++partition :: (a -> Bool) -> CharMap a -> (CharMap a, CharMap a)+partition f (CharMap m) = (CharMap m1', CharMap m2')+ where (m1',m2') = M.partition f m++partitionWithKey :: (Key -> a -> Bool) -> CharMap a -> (CharMap a, CharMap a)+partitionWithKey f (CharMap m) = (CharMap m1', CharMap m2')+ where (m1',m2') = M.partitionWithKey f' m+ f' b a = f (unsafeChr b) a++mapMaybe :: (a -> Maybe b) -> CharMap a -> CharMap b+mapMaybe f (CharMap m) = CharMap (M.mapMaybe f m)++mapMaybeWithKey :: (Key -> a -> Maybe b) -> CharMap a -> CharMap b+mapMaybeWithKey f (CharMap m) = CharMap (M.mapMaybeWithKey f' m)+ where f' b a = f (unsafeChr b) a++mapEither :: (a -> Either b c) -> CharMap a -> (CharMap b, CharMap c)+mapEither f (CharMap m) = (CharMap m1', CharMap m2')+ where (m1',m2') = M.mapEither f m++mapEitherWithKey :: (Key -> a -> Either b c) -> CharMap a -> (CharMap b, CharMap c)+mapEitherWithKey f (CharMap m) = (CharMap m1', CharMap m2')+ where (m1',m2') = M.mapEitherWithKey f' m+ f' b a = f (unsafeChr b) a++split :: Key -> CharMap a -> (CharMap a, CharMap a)+split k (CharMap m) = (CharMap m1', CharMap m2')+ where (m1',m2') = M.split (C.ord k) m++splitLookup :: Key -> CharMap a -> (CharMap a, Maybe a, CharMap a)+splitLookup k (CharMap m) = (CharMap m1', a, CharMap m2')+ where (m1',a,m2') = M.splitLookup (C.ord k) m++isSubmapOf :: Eq a => CharMap a -> CharMap a -> Bool+isSubmapOf (CharMap m1) (CharMap m2) = M.isSubmapOf m1 m2++isSubmapOfBy :: (a -> b -> Bool) -> CharMap a -> CharMap b -> Bool+isSubmapOfBy f (CharMap m1) (CharMap m2) = M.isSubmapOfBy f m1 m2++isProperSubmapOf :: Eq a => CharMap a -> CharMap a -> Bool+isProperSubmapOf (CharMap m1) (CharMap m2) = M.isProperSubmapOf m1 m2++isProperSubmapOfBy :: (a -> b -> Bool) -> CharMap a -> CharMap b -> Bool+isProperSubmapOfBy f (CharMap m1) (CharMap m2) = M.isProperSubmapOfBy f m1 m2++showTree :: Show a => CharMap a -> String+showTree (CharMap m) = M.showTree m++showTreeWith :: Show a => Bool -> Bool -> CharMap a -> String+showTreeWith b1 b2 (CharMap m) = M.showTreeWith b1 b2 m+{-# INLINE (!) #-}+{-# INLINE (\\) #-}+{-# INLINE null #-}+{-# INLINE size #-}+{-# INLINE member #-}+{-# INLINE notMember #-}+{-# INLINE lookup #-}+{-# INLINE findWithDefault #-}+{-# INLINE empty #-}+{-# INLINE singleton #-}+{-# INLINE insert #-}+{-# INLINE insertWith #-}+{-# INLINE insertWithKey #-}+{-# INLINE insertLookupWithKey #-}+{-# INLINE delete #-}+{-# INLINE adjust #-}+{-# INLINE adjustWithKey #-}+{-# INLINE update #-}+{-# INLINE updateWithKey #-}+{-# INLINE updateLookupWithKey #-}+{-# INLINE union #-}+{-# INLINE unionWith #-}+{-# INLINE unionWithKey #-}+{-# INLINE unions #-}+{-# INLINE unionsWith #-}+{-# INLINE difference #-}+{-# INLINE differenceWith #-}+{-# INLINE differenceWithKey #-}+{-# INLINE intersection #-}+{-# INLINE intersectionWith #-}+{-# INLINE intersectionWithKey #-}+{-# INLINE map #-}+{-# INLINE mapWithKey #-}+{-# INLINE mapAccum #-}+{-# INLINE mapAccumWithKey #-}+{-# INLINE fold #-}+{-# INLINE foldWithKey #-}+{-# INLINE elems #-}+{-# INLINE keys #-}+{-# INLINE keysSet #-}+{-# INLINE assocs #-}+{-# INLINE toList #-}+{-# INLINE fromList #-}+{-# INLINE fromListWith #-}+{-# INLINE fromListWithKey #-}+{-# INLINE toAscList #-}+{-# INLINE fromAscList #-}+{-# INLINE fromAscListWith #-}+{-# INLINE fromAscListWithKey #-}+{-# INLINE fromDistinctAscList #-}+{-# INLINE filter #-}+{-# INLINE filterWithKey #-}+{-# INLINE partition #-}+{-# INLINE partitionWithKey #-}+{-# INLINE mapMaybe #-}+{-# INLINE mapMaybeWithKey #-}+{-# INLINE mapEither #-}+{-# INLINE mapEitherWithKey #-}+{-# INLINE split #-}+{-# INLINE splitLookup #-}+{-# INLINE isSubmapOf #-}+{-# INLINE isSubmapOfBy #-}+{-# INLINE isProperSubmapOf #-}+{-# INLINE isProperSubmapOfBy #-}+{-# INLINE showTree #-}+{-# INLINE showTreeWith #-}
− Data/IntMap/EnumMap.hs
@@ -1,248 +0,0 @@-module Data.IntMap.EnumMap where--import Data.Foldable(Foldable(..))-import qualified Data.IntMap as M-import qualified Data.IntSet.EnumSet as S (EnumSet(..))-import Data.Monoid(Monoid(..))-import Prelude-import qualified Prelude as L (map)--newtype EnumMap k a = EnumMap {unEnumMap :: M.IntMap a}- deriving (Eq,Ord,Read,Show)--instance Ord k => Monoid (EnumMap k a) where- mempty = EnumMap mempty- EnumMap x `mappend` EnumMap y = EnumMap (x `mappend` y)--instance Ord k => Functor (EnumMap k) where- fmap f (EnumMap m) = EnumMap (fmap f m)--instance Ord k => Foldable (EnumMap k) where- foldMap f (EnumMap m) = foldMap f m--(!) :: (Enum key) => EnumMap key a -> key -> a-(!) (EnumMap m) k = (M.!) m (fromEnum k)--(\\) :: (Enum key) => EnumMap key a -> EnumMap key b -> EnumMap key a-(\\) (EnumMap m1) (EnumMap m2) = EnumMap ((M.\\) m1 m2)--null :: (Enum key) => EnumMap key a -> Bool-null (EnumMap m) = M.null m--size :: (Enum key) => EnumMap key a -> Int-size (EnumMap m) = M.size m--member :: (Enum key) => key -> EnumMap key a -> Bool-member k (EnumMap m) = M.member (fromEnum k) m--notMember :: (Enum key) => key -> EnumMap key a -> Bool-notMember k (EnumMap m) = M.notMember (fromEnum k) m--{-# INLINE lookup #-}-lookup :: (Enum key,Monad m) => key -> EnumMap key a -> m a-lookup k (EnumMap m) = maybe (fail "EnumMap.lookup failed") return $ M.lookup (fromEnum k) m--findWithDefault :: (Enum key) => a -> key -> EnumMap key a -> a-findWithDefault a k (EnumMap m) = M.findWithDefault a (fromEnum k) m--empty :: (Enum key) => EnumMap key a-empty = EnumMap M.empty--singleton :: (Enum key) => key -> a -> EnumMap key a-singleton k a = EnumMap (M.singleton (fromEnum k) a)--insert :: (Enum key) => key -> a -> EnumMap key a -> EnumMap key a-insert k a (EnumMap m) = EnumMap (M.insert (fromEnum k) a m)--insertWith :: (Enum key) => (a -> a -> a) -> key -> a -> EnumMap key a -> EnumMap key a-insertWith f k a (EnumMap m) = EnumMap (M.insertWith f (fromEnum k) a m)--insertWithKey :: (Enum key) => (key -> a -> a -> a) -> key -> a -> EnumMap key a -> EnumMap key a-insertWithKey f k a (EnumMap m) = EnumMap (M.insertWithKey f' (fromEnum k) a m)- where f' b a1 a2 = f (toEnum b) a1 a2--insertLookupWithKey :: (Enum key) => (key -> a -> a -> a) -> key -> a -> EnumMap key a -> (Maybe a, EnumMap key a)-insertLookupWithKey f k a (EnumMap m) = (ma,EnumMap m')- where (ma,m') = M.insertLookupWithKey f' (fromEnum k) a m- f' b a1 a2 = f (toEnum b) a1 a2--delete :: (Enum key) => key -> EnumMap key a -> EnumMap key a-delete k (EnumMap m) = EnumMap (M.delete (fromEnum k) m)--adjust :: (Enum key) => (a -> a) -> key -> EnumMap key a -> EnumMap key a-adjust f k (EnumMap m) = EnumMap (M.adjust f (fromEnum k) m)--adjustWithKey :: (Enum key) => (key -> a -> a) -> key -> EnumMap key a -> EnumMap key a-adjustWithKey f k (EnumMap m) = EnumMap (M.adjustWithKey f' (fromEnum k) m)- where f' b a = f (toEnum b) a--update :: (Enum key) => (a -> Maybe a) -> key -> EnumMap key a -> EnumMap key a-update f k (EnumMap m) = EnumMap (M.update f (fromEnum k) m)--updateWithKey :: (Enum key) => (key -> a -> Maybe a) -> key -> EnumMap key a -> EnumMap key a-updateWithKey f k (EnumMap m) = EnumMap (M.updateWithKey f' (fromEnum k) m)- where f' b a = f (toEnum b) a--updateLookupWithKey :: (Enum key) => (key -> a -> Maybe a) -> key -> EnumMap key a -> (Maybe a, EnumMap key a)-updateLookupWithKey f k (EnumMap m) = (a,EnumMap m')- where (a,m') = M.updateLookupWithKey f' (fromEnum k) m- f' b a1 = f (toEnum b) a1--union :: (Enum key) => EnumMap key a -> EnumMap key a -> EnumMap key a-union (EnumMap m1) (EnumMap m2) = EnumMap (M.union m1 m2)--unionWith :: (Enum key) => (a -> a -> a) -> EnumMap key a -> EnumMap key a -> EnumMap key a-unionWith f (EnumMap m1) (EnumMap m2) = EnumMap (M.unionWith f m1 m2)--unionWithKey :: (Enum key) => (key -> a -> a -> a) -> EnumMap key a -> EnumMap key a -> EnumMap key a-unionWithKey f (EnumMap m1) (EnumMap m2) = EnumMap (M.unionWithKey f' m1 m2)- where f' b a1 a2 = f (toEnum b) a1 a2--unions :: (Enum key) => [EnumMap key a] -> EnumMap key a-unions cs = EnumMap (M.unions (L.map unEnumMap cs))--unionsWith :: (Enum key) => (a -> a -> a) -> [EnumMap key a] -> EnumMap key a-unionsWith f cs = EnumMap (M.unionsWith f (L.map unEnumMap cs))--difference :: (Enum key) => EnumMap key a -> EnumMap key b -> EnumMap key a-difference (EnumMap m1) (EnumMap m2) = EnumMap (M.difference m1 m2)--differenceWith :: (Enum key) => (a -> b -> Maybe a) -> EnumMap key a -> EnumMap key b -> EnumMap key a-differenceWith f (EnumMap m1) (EnumMap m2) = EnumMap (M.differenceWith f m1 m2)--differenceWithKey :: (Enum key) => (key -> a -> b -> Maybe a) -> EnumMap key a -> EnumMap key b -> EnumMap key a-differenceWithKey f (EnumMap m1) (EnumMap m2) = EnumMap (M.differenceWithKey f' m1 m2)- where f' b a1 a2 = f (toEnum b) a1 a2--intersection :: (Enum key) => EnumMap key a -> EnumMap key b -> EnumMap key a-intersection (EnumMap m1) (EnumMap m2) = EnumMap (M.intersection m1 m2)--intersectionWith :: (Enum key) => (a -> b -> a) -> EnumMap key a -> EnumMap key b -> EnumMap key a-intersectionWith f (EnumMap m1) (EnumMap m2) = EnumMap (M.intersectionWith f m1 m2)--intersectionWithKey :: (Enum key) => (key -> a -> b -> a) -> EnumMap key a -> EnumMap key b -> EnumMap key a-intersectionWithKey f (EnumMap m1) (EnumMap m2) = EnumMap (M.intersectionWithKey f' m1 m2)- where f' b a1 a2 = f (toEnum b) a1 a2--map :: (Enum key) => (a -> b) -> EnumMap key a -> EnumMap key b-map f (EnumMap m) = EnumMap (M.map f m)--mapWithKey :: (Enum key) => (key -> a -> b) -> EnumMap key a -> EnumMap key b-mapWithKey f (EnumMap m) = EnumMap (M.mapWithKey f' m)- where f' b a = f (toEnum b) a--mapAccum :: (Enum key) => (a -> b -> (a, c)) -> a -> EnumMap key b -> (a, EnumMap key c)-mapAccum f a (EnumMap m) = (a',EnumMap m')- where (a',m') = M.mapAccum f a m--mapAccumWithKey :: (Enum key) => (a -> key -> b -> (a, c)) -> a -> EnumMap key b -> (a, EnumMap key c)-mapAccumWithKey f a (EnumMap m) = (a',EnumMap m')- where (a',m') = M.mapAccumWithKey f' a m- f' a1 b a2 = f a1 (toEnum b) a2--fold :: (Enum key) => (a -> b -> b) -> b -> EnumMap key a -> b-fold f a (EnumMap m) = M.fold f a m--foldWithKey :: (Enum key) => (key -> a -> b -> b) -> b -> EnumMap key a -> b-foldWithKey f a (EnumMap m) = M.foldWithKey f' a m- where f' b a1 a2 = f (toEnum b) a1 a2--elems :: (Enum key) => EnumMap key a -> [a]-elems (EnumMap m) = M.elems m--keys :: (Enum key) => EnumMap key a -> [key]-keys (EnumMap m) = L.map toEnum (M.keys m)---- Have to break cover until I have CharSet-keysSet :: (Enum key) => EnumMap key a -> S.EnumSet key-keysSet (EnumMap m) = S.EnumSet (M.keysSet m)--assocs :: (Enum key) => EnumMap key a -> [(key, a)]-assocs (EnumMap m) = L.map (\(b,a) -> (toEnum b,a)) (M.assocs m)--toList :: (Enum key) => EnumMap key a -> [(key, a)]-toList (EnumMap m) = L.map (\(b,a) -> (toEnum b,a)) (M.toList m)--fromList :: (Enum key) => [(key, a)] -> EnumMap key a-fromList ka = EnumMap (M.fromList (L.map (\(k,a) -> (fromEnum k,a)) ka))--fromListWith :: (Enum key) => (a -> a -> a) -> [(key, a)] -> EnumMap key a-fromListWith f ka = EnumMap (M.fromListWith f (L.map (\(k,a) -> (fromEnum k,a)) ka))--fromListWithKey :: (Enum key) => (key -> a -> a -> a) -> [(key, a)] -> EnumMap key a-fromListWithKey f ka = EnumMap (M.fromListWithKey f' (L.map (\(k,a) -> (fromEnum k,a)) ka))- where f' b a1 a2 = f (toEnum b) a1 a2--toAscList :: (Enum key) => EnumMap key a -> [(key, a)]-toAscList (EnumMap m) = L.map (\(b,a) -> (toEnum b,a)) (M.toAscList m)--fromAscList :: (Enum key) => [(key, a)] -> EnumMap key a-fromAscList ka = EnumMap (M.fromAscList (L.map (\(k,a) -> (fromEnum k,a)) ka))--fromAscListWith :: (Enum key) => (a -> a -> a) -> [(key, a)] -> EnumMap key a-fromAscListWith f ka = EnumMap (M.fromAscListWith f (L.map (\(k,a) -> (fromEnum k,a)) ka))--fromAscListWithKey :: (Enum key) => (key -> a -> a -> a) -> [(key, a)] -> EnumMap key a-fromAscListWithKey f ka = EnumMap (M.fromAscListWithKey f' (L.map (\(k,a) -> (fromEnum k,a)) ka))- where f' b a1 a2 = f (toEnum b) a1 a2--fromDistinctAscList :: (Enum key) => [(key, a)] -> EnumMap key a-fromDistinctAscList ka = EnumMap (M.fromDistinctAscList (L.map (\(k,a) -> (fromEnum k,a)) ka))--filter :: (Enum key) => (a -> Bool) -> EnumMap key a -> EnumMap key a-filter f (EnumMap m) = EnumMap (M.filter f m)--filterWithKey :: (Enum key) => (key -> a -> Bool) -> EnumMap key a -> EnumMap key a-filterWithKey f (EnumMap m) = EnumMap (M.filterWithKey f' m)- where f' b a = f (toEnum b) a--partition :: (Enum key) => (a -> Bool) -> EnumMap key a -> (EnumMap key a, EnumMap key a)-partition f (EnumMap m) = (EnumMap m1', EnumMap m2')- where (m1',m2') = M.partition f m--partitionWithKey :: (Enum key) => (key -> a -> Bool) -> EnumMap key a -> (EnumMap key a, EnumMap key a)-partitionWithKey f (EnumMap m) = (EnumMap m1', EnumMap m2')- where (m1',m2') = M.partitionWithKey f' m- f' b a = f (toEnum b) a--mapMaybe :: (Enum key) => (a -> Maybe b) -> EnumMap key a -> EnumMap key b-mapMaybe f (EnumMap m) = EnumMap (M.mapMaybe f m)--mapMaybeWithKey :: (Enum key) => (key -> a -> Maybe b) -> EnumMap key a -> EnumMap key b-mapMaybeWithKey f (EnumMap m) = EnumMap (M.mapMaybeWithKey f' m)- where f' b a = f (toEnum b) a--mapEither :: (Enum key) => (a -> Either b c) -> EnumMap key a -> (EnumMap key b, EnumMap key c)-mapEither f (EnumMap m) = (EnumMap m1', EnumMap m2')- where (m1',m2') = M.mapEither f m--mapEitherWithKey :: (Enum key) => (key -> a -> Either b c) -> EnumMap key a -> (EnumMap key b, EnumMap key c)-mapEitherWithKey f (EnumMap m) = (EnumMap m1', EnumMap m2')- where (m1',m2') = M.mapEitherWithKey f' m- f' b a = f (toEnum b) a--split :: (Enum key) => key -> EnumMap key a -> (EnumMap key a, EnumMap key a)-split k (EnumMap m) = (EnumMap m1', EnumMap m2')- where (m1',m2') = M.split (fromEnum k) m--splitLookup :: (Enum key) => key -> EnumMap key a -> (EnumMap key a, Maybe a, EnumMap key a)-splitLookup k (EnumMap m) = (EnumMap m1', a, EnumMap m2')- where (m1',a,m2') = M.splitLookup (fromEnum k) m--isSubmapOf :: (Enum key,Eq a) => EnumMap key a -> EnumMap key a -> Bool-isSubmapOf (EnumMap m1) (EnumMap m2) = M.isSubmapOf m1 m2--isSubmapOfBy :: (Enum key) => (a -> b -> Bool) -> EnumMap key a -> EnumMap key b -> Bool-isSubmapOfBy f (EnumMap m1) (EnumMap m2) = M.isSubmapOfBy f m1 m2--isProperSubmapOf :: (Enum key,Eq a) => EnumMap key a -> EnumMap key a -> Bool-isProperSubmapOf (EnumMap m1) (EnumMap m2) = M.isProperSubmapOf m1 m2--isProperSubmapOfBy :: (Enum key) => (a -> b -> Bool) -> EnumMap key a -> EnumMap key b -> Bool-isProperSubmapOfBy f (EnumMap m1) (EnumMap m2) = M.isProperSubmapOfBy f m1 m2--showTree :: (Enum key,Show a) => EnumMap key a -> String-showTree (EnumMap m) = M.showTree m--showTreeWith :: (Enum key,Show a) => Bool -> Bool -> EnumMap key a -> String-showTreeWith b1 b2 (EnumMap m) = M.showTreeWith b1 b2 m
+ Data/IntMap/EnumMap2.hs view
@@ -0,0 +1,248 @@+module Data.IntMap.EnumMap2 where++import Data.Foldable(Foldable(..))+import qualified Data.IntMap as M+import qualified Data.IntSet.EnumSet2 as S (EnumSet(..))+import Data.Monoid(Monoid(..))+import Prelude+import qualified Prelude as L (map)++newtype EnumMap k a = EnumMap {unEnumMap :: M.IntMap a}+ deriving (Eq,Ord,Read,Show)++instance Ord k => Monoid (EnumMap k a) where+ mempty = EnumMap mempty+ EnumMap x `mappend` EnumMap y = EnumMap (x `mappend` y)++instance Ord k => Functor (EnumMap k) where+ fmap f (EnumMap m) = EnumMap (fmap f m)++instance Ord k => Foldable (EnumMap k) where+ foldMap f (EnumMap m) = foldMap f m++(!) :: (Enum key) => EnumMap key a -> key -> a+(!) (EnumMap m) k = (M.!) m (fromEnum k)++(\\) :: (Enum key) => EnumMap key a -> EnumMap key b -> EnumMap key a+(\\) (EnumMap m1) (EnumMap m2) = EnumMap ((M.\\) m1 m2)++null :: (Enum key) => EnumMap key a -> Bool+null (EnumMap m) = M.null m++size :: (Enum key) => EnumMap key a -> Int+size (EnumMap m) = M.size m++member :: (Enum key) => key -> EnumMap key a -> Bool+member k (EnumMap m) = M.member (fromEnum k) m++notMember :: (Enum key) => key -> EnumMap key a -> Bool+notMember k (EnumMap m) = M.notMember (fromEnum k) m++{-# INLINE lookup #-}+lookup :: (Enum key) => key -> EnumMap key a -> Maybe a+lookup k (EnumMap m) = maybe (fail "EnumMap.lookup failed") return $ M.lookup (fromEnum k) m++findWithDefault :: (Enum key) => a -> key -> EnumMap key a -> a+findWithDefault a k (EnumMap m) = M.findWithDefault a (fromEnum k) m++empty :: (Enum key) => EnumMap key a+empty = EnumMap M.empty++singleton :: (Enum key) => key -> a -> EnumMap key a+singleton k a = EnumMap (M.singleton (fromEnum k) a)++insert :: (Enum key) => key -> a -> EnumMap key a -> EnumMap key a+insert k a (EnumMap m) = EnumMap (M.insert (fromEnum k) a m)++insertWith :: (Enum key) => (a -> a -> a) -> key -> a -> EnumMap key a -> EnumMap key a+insertWith f k a (EnumMap m) = EnumMap (M.insertWith f (fromEnum k) a m)++insertWithKey :: (Enum key) => (key -> a -> a -> a) -> key -> a -> EnumMap key a -> EnumMap key a+insertWithKey f k a (EnumMap m) = EnumMap (M.insertWithKey f' (fromEnum k) a m)+ where f' b a1 a2 = f (toEnum b) a1 a2++insertLookupWithKey :: (Enum key) => (key -> a -> a -> a) -> key -> a -> EnumMap key a -> (Maybe a, EnumMap key a)+insertLookupWithKey f k a (EnumMap m) = (ma,EnumMap m')+ where (ma,m') = M.insertLookupWithKey f' (fromEnum k) a m+ f' b a1 a2 = f (toEnum b) a1 a2++delete :: (Enum key) => key -> EnumMap key a -> EnumMap key a+delete k (EnumMap m) = EnumMap (M.delete (fromEnum k) m)++adjust :: (Enum key) => (a -> a) -> key -> EnumMap key a -> EnumMap key a+adjust f k (EnumMap m) = EnumMap (M.adjust f (fromEnum k) m)++adjustWithKey :: (Enum key) => (key -> a -> a) -> key -> EnumMap key a -> EnumMap key a+adjustWithKey f k (EnumMap m) = EnumMap (M.adjustWithKey f' (fromEnum k) m)+ where f' b a = f (toEnum b) a++update :: (Enum key) => (a -> Maybe a) -> key -> EnumMap key a -> EnumMap key a+update f k (EnumMap m) = EnumMap (M.update f (fromEnum k) m)++updateWithKey :: (Enum key) => (key -> a -> Maybe a) -> key -> EnumMap key a -> EnumMap key a+updateWithKey f k (EnumMap m) = EnumMap (M.updateWithKey f' (fromEnum k) m)+ where f' b a = f (toEnum b) a++updateLookupWithKey :: (Enum key) => (key -> a -> Maybe a) -> key -> EnumMap key a -> (Maybe a, EnumMap key a)+updateLookupWithKey f k (EnumMap m) = (a,EnumMap m')+ where (a,m') = M.updateLookupWithKey f' (fromEnum k) m+ f' b a1 = f (toEnum b) a1++union :: (Enum key) => EnumMap key a -> EnumMap key a -> EnumMap key a+union (EnumMap m1) (EnumMap m2) = EnumMap (M.union m1 m2)++unionWith :: (Enum key) => (a -> a -> a) -> EnumMap key a -> EnumMap key a -> EnumMap key a+unionWith f (EnumMap m1) (EnumMap m2) = EnumMap (M.unionWith f m1 m2)++unionWithKey :: (Enum key) => (key -> a -> a -> a) -> EnumMap key a -> EnumMap key a -> EnumMap key a+unionWithKey f (EnumMap m1) (EnumMap m2) = EnumMap (M.unionWithKey f' m1 m2)+ where f' b a1 a2 = f (toEnum b) a1 a2++unions :: (Enum key) => [EnumMap key a] -> EnumMap key a+unions cs = EnumMap (M.unions (L.map unEnumMap cs))++unionsWith :: (Enum key) => (a -> a -> a) -> [EnumMap key a] -> EnumMap key a+unionsWith f cs = EnumMap (M.unionsWith f (L.map unEnumMap cs))++difference :: (Enum key) => EnumMap key a -> EnumMap key b -> EnumMap key a+difference (EnumMap m1) (EnumMap m2) = EnumMap (M.difference m1 m2)++differenceWith :: (Enum key) => (a -> b -> Maybe a) -> EnumMap key a -> EnumMap key b -> EnumMap key a+differenceWith f (EnumMap m1) (EnumMap m2) = EnumMap (M.differenceWith f m1 m2)++differenceWithKey :: (Enum key) => (key -> a -> b -> Maybe a) -> EnumMap key a -> EnumMap key b -> EnumMap key a+differenceWithKey f (EnumMap m1) (EnumMap m2) = EnumMap (M.differenceWithKey f' m1 m2)+ where f' b a1 a2 = f (toEnum b) a1 a2++intersection :: (Enum key) => EnumMap key a -> EnumMap key b -> EnumMap key a+intersection (EnumMap m1) (EnumMap m2) = EnumMap (M.intersection m1 m2)++intersectionWith :: (Enum key) => (a -> b -> a) -> EnumMap key a -> EnumMap key b -> EnumMap key a+intersectionWith f (EnumMap m1) (EnumMap m2) = EnumMap (M.intersectionWith f m1 m2)++intersectionWithKey :: (Enum key) => (key -> a -> b -> a) -> EnumMap key a -> EnumMap key b -> EnumMap key a+intersectionWithKey f (EnumMap m1) (EnumMap m2) = EnumMap (M.intersectionWithKey f' m1 m2)+ where f' b a1 a2 = f (toEnum b) a1 a2++map :: (Enum key) => (a -> b) -> EnumMap key a -> EnumMap key b+map f (EnumMap m) = EnumMap (M.map f m)++mapWithKey :: (Enum key) => (key -> a -> b) -> EnumMap key a -> EnumMap key b+mapWithKey f (EnumMap m) = EnumMap (M.mapWithKey f' m)+ where f' b a = f (toEnum b) a++mapAccum :: (Enum key) => (a -> b -> (a, c)) -> a -> EnumMap key b -> (a, EnumMap key c)+mapAccum f a (EnumMap m) = (a',EnumMap m')+ where (a',m') = M.mapAccum f a m++mapAccumWithKey :: (Enum key) => (a -> key -> b -> (a, c)) -> a -> EnumMap key b -> (a, EnumMap key c)+mapAccumWithKey f a (EnumMap m) = (a',EnumMap m')+ where (a',m') = M.mapAccumWithKey f' a m+ f' a1 b a2 = f a1 (toEnum b) a2++fold :: (Enum key) => (a -> b -> b) -> b -> EnumMap key a -> b+fold f a (EnumMap m) = M.fold f a m++foldWithKey :: (Enum key) => (key -> a -> b -> b) -> b -> EnumMap key a -> b+foldWithKey f a (EnumMap m) = M.foldWithKey f' a m+ where f' b a1 a2 = f (toEnum b) a1 a2++elems :: (Enum key) => EnumMap key a -> [a]+elems (EnumMap m) = M.elems m++keys :: (Enum key) => EnumMap key a -> [key]+keys (EnumMap m) = L.map toEnum (M.keys m)++-- Have to break cover until I have CharSet+keysSet :: (Enum key) => EnumMap key a -> S.EnumSet key+keysSet (EnumMap m) = S.EnumSet (M.keysSet m)++assocs :: (Enum key) => EnumMap key a -> [(key, a)]+assocs (EnumMap m) = L.map (\(b,a) -> (toEnum b,a)) (M.assocs m)++toList :: (Enum key) => EnumMap key a -> [(key, a)]+toList (EnumMap m) = L.map (\(b,a) -> (toEnum b,a)) (M.toList m)++fromList :: (Enum key) => [(key, a)] -> EnumMap key a+fromList ka = EnumMap (M.fromList (L.map (\(k,a) -> (fromEnum k,a)) ka))++fromListWith :: (Enum key) => (a -> a -> a) -> [(key, a)] -> EnumMap key a+fromListWith f ka = EnumMap (M.fromListWith f (L.map (\(k,a) -> (fromEnum k,a)) ka))++fromListWithKey :: (Enum key) => (key -> a -> a -> a) -> [(key, a)] -> EnumMap key a+fromListWithKey f ka = EnumMap (M.fromListWithKey f' (L.map (\(k,a) -> (fromEnum k,a)) ka))+ where f' b a1 a2 = f (toEnum b) a1 a2++toAscList :: (Enum key) => EnumMap key a -> [(key, a)]+toAscList (EnumMap m) = L.map (\(b,a) -> (toEnum b,a)) (M.toAscList m)++fromAscList :: (Enum key) => [(key, a)] -> EnumMap key a+fromAscList ka = EnumMap (M.fromAscList (L.map (\(k,a) -> (fromEnum k,a)) ka))++fromAscListWith :: (Enum key) => (a -> a -> a) -> [(key, a)] -> EnumMap key a+fromAscListWith f ka = EnumMap (M.fromAscListWith f (L.map (\(k,a) -> (fromEnum k,a)) ka))++fromAscListWithKey :: (Enum key) => (key -> a -> a -> a) -> [(key, a)] -> EnumMap key a+fromAscListWithKey f ka = EnumMap (M.fromAscListWithKey f' (L.map (\(k,a) -> (fromEnum k,a)) ka))+ where f' b a1 a2 = f (toEnum b) a1 a2++fromDistinctAscList :: (Enum key) => [(key, a)] -> EnumMap key a+fromDistinctAscList ka = EnumMap (M.fromDistinctAscList (L.map (\(k,a) -> (fromEnum k,a)) ka))++filter :: (Enum key) => (a -> Bool) -> EnumMap key a -> EnumMap key a+filter f (EnumMap m) = EnumMap (M.filter f m)++filterWithKey :: (Enum key) => (key -> a -> Bool) -> EnumMap key a -> EnumMap key a+filterWithKey f (EnumMap m) = EnumMap (M.filterWithKey f' m)+ where f' b a = f (toEnum b) a++partition :: (Enum key) => (a -> Bool) -> EnumMap key a -> (EnumMap key a, EnumMap key a)+partition f (EnumMap m) = (EnumMap m1', EnumMap m2')+ where (m1',m2') = M.partition f m++partitionWithKey :: (Enum key) => (key -> a -> Bool) -> EnumMap key a -> (EnumMap key a, EnumMap key a)+partitionWithKey f (EnumMap m) = (EnumMap m1', EnumMap m2')+ where (m1',m2') = M.partitionWithKey f' m+ f' b a = f (toEnum b) a++mapMaybe :: (Enum key) => (a -> Maybe b) -> EnumMap key a -> EnumMap key b+mapMaybe f (EnumMap m) = EnumMap (M.mapMaybe f m)++mapMaybeWithKey :: (Enum key) => (key -> a -> Maybe b) -> EnumMap key a -> EnumMap key b+mapMaybeWithKey f (EnumMap m) = EnumMap (M.mapMaybeWithKey f' m)+ where f' b a = f (toEnum b) a++mapEither :: (Enum key) => (a -> Either b c) -> EnumMap key a -> (EnumMap key b, EnumMap key c)+mapEither f (EnumMap m) = (EnumMap m1', EnumMap m2')+ where (m1',m2') = M.mapEither f m++mapEitherWithKey :: (Enum key) => (key -> a -> Either b c) -> EnumMap key a -> (EnumMap key b, EnumMap key c)+mapEitherWithKey f (EnumMap m) = (EnumMap m1', EnumMap m2')+ where (m1',m2') = M.mapEitherWithKey f' m+ f' b a = f (toEnum b) a++split :: (Enum key) => key -> EnumMap key a -> (EnumMap key a, EnumMap key a)+split k (EnumMap m) = (EnumMap m1', EnumMap m2')+ where (m1',m2') = M.split (fromEnum k) m++splitLookup :: (Enum key) => key -> EnumMap key a -> (EnumMap key a, Maybe a, EnumMap key a)+splitLookup k (EnumMap m) = (EnumMap m1', a, EnumMap m2')+ where (m1',a,m2') = M.splitLookup (fromEnum k) m++isSubmapOf :: (Enum key,Eq a) => EnumMap key a -> EnumMap key a -> Bool+isSubmapOf (EnumMap m1) (EnumMap m2) = M.isSubmapOf m1 m2++isSubmapOfBy :: (Enum key) => (a -> b -> Bool) -> EnumMap key a -> EnumMap key b -> Bool+isSubmapOfBy f (EnumMap m1) (EnumMap m2) = M.isSubmapOfBy f m1 m2++isProperSubmapOf :: (Enum key,Eq a) => EnumMap key a -> EnumMap key a -> Bool+isProperSubmapOf (EnumMap m1) (EnumMap m2) = M.isProperSubmapOf m1 m2++isProperSubmapOfBy :: (Enum key) => (a -> b -> Bool) -> EnumMap key a -> EnumMap key b -> Bool+isProperSubmapOfBy f (EnumMap m1) (EnumMap m2) = M.isProperSubmapOfBy f m1 m2++showTree :: (Enum key,Show a) => EnumMap key a -> String+showTree (EnumMap m) = M.showTree m++showTreeWith :: (Enum key,Show a) => Bool -> Bool -> EnumMap key a -> String+showTreeWith b1 b2 (EnumMap m) = M.showTreeWith b1 b2 m
− Data/IntSet/EnumSet.hs
@@ -1,106 +0,0 @@-module Data.IntSet.EnumSet where--import qualified Data.IntSet as S-import qualified Data.List as L (map)-import Data.Monoid(Monoid(..))--newtype EnumSet e = EnumSet {unEnumSet :: S.IntSet}- deriving (Eq,Ord,Read,Show)--instance Monoid (EnumSet e) where- mempty = EnumSet mempty- EnumSet x `mappend` EnumSet y = EnumSet (x `mappend` y)--(\\) :: (Enum e) => EnumSet e -> EnumSet e -> EnumSet e-(\\) (EnumSet s1) (EnumSet s2) = EnumSet ((S.\\) s1 s2)--null :: (Enum e) => EnumSet e -> Bool-null (EnumSet s) = S.null s--size :: (Enum e) => EnumSet e -> Int-size (EnumSet s) = S.size s--member :: (Enum e) => e -> EnumSet e -> Bool-member e (EnumSet s) = S.member (fromEnum e) s--notMember :: (Enum e) => Int -> EnumSet e -> Bool-notMember e (EnumSet s) = S.notMember (fromEnum e) s--isSubsetOf :: (Enum e) => EnumSet e -> EnumSet e -> Bool-isSubsetOf (EnumSet e1) (EnumSet e2) = S.isSubsetOf e1 e2--isProperSubsetOf :: (Enum e) => EnumSet e -> EnumSet e -> Bool-isProperSubsetOf (EnumSet e1) (EnumSet e2) = S.isProperSubsetOf e1 e2--empty :: (Enum e) => EnumSet e-empty = EnumSet (S.empty)--singleton :: (Enum e) => e -> EnumSet e-singleton e = EnumSet (S.singleton (fromEnum e))--insert :: (Enum e) => e -> EnumSet e -> EnumSet e-insert e (EnumSet s) = EnumSet (S.insert (fromEnum e) s)--delete :: (Enum e) => e -> EnumSet e -> EnumSet e-delete e (EnumSet s) = EnumSet (S.delete (fromEnum e) s)--union :: (Enum e) => EnumSet e -> EnumSet e -> EnumSet e-union (EnumSet s1) (EnumSet s2) = EnumSet (S.union s1 s2)--unions :: (Enum e) => [EnumSet e] -> EnumSet e-unions es = EnumSet (S.unions (L.map unEnumSet es))--difference :: (Enum e) => EnumSet e -> EnumSet e -> EnumSet e-difference (EnumSet e1) (EnumSet e2) = EnumSet (S.difference e1 e2)--intersection :: (Enum e) => EnumSet e -> EnumSet e -> EnumSet e-intersection (EnumSet e1) (EnumSet e2) = EnumSet (S.intersection e1 e2)--filter :: (Enum e) => (e -> Bool) -> EnumSet e -> EnumSet e-filter f (EnumSet s) = EnumSet (S.filter f' s)- where f' b = f (toEnum b)--partition :: (Enum e) => (e -> Bool) -> EnumSet e -> (EnumSet e, EnumSet e)-partition f (EnumSet s) = (EnumSet s1', EnumSet s2')- where (s1',s2') = S.partition f' s- f' b = f (toEnum b)--split :: (Enum e) => e -> EnumSet e -> (EnumSet e, EnumSet e)-split e (EnumSet s) = (EnumSet s1', EnumSet s2')- where (s1',s2') = S.split (fromEnum e) s--splitMember :: (Enum e) => e -> EnumSet e -> (EnumSet e, Bool, EnumSet e)-splitMember e (EnumSet s) = (EnumSet s1',a,EnumSet s2')- where (s1',a,s2') = S.splitMember (fromEnum e) s--map :: (Enum e) => (e -> e) -> EnumSet e -> EnumSet e-map f (EnumSet s) = EnumSet (S.map f' s)- where f' b = fromEnum (f (toEnum b))--fold :: (Enum e) => (e -> b -> b) -> b -> EnumSet e -> b-fold f a (EnumSet s) = S.fold f' a s- where f' b a1 = f (toEnum b) a1--elems :: (Enum e) => EnumSet e -> [e]-elems (EnumSet s) = L.map toEnum (S.elems s)--toList :: (Enum e) => EnumSet e -> [e]-toList (EnumSet s) = L.map toEnum (S.toList s)--fromList :: (Enum e) => [e] -> EnumSet e-fromList es = EnumSet (S.fromList (L.map fromEnum es))--toAscList :: (Enum e) => EnumSet e -> [e]-toAscList (EnumSet s) = L.map toEnum (S.toAscList s)--fromAscList :: (Enum e) => [e] -> EnumSet e-fromAscList es = EnumSet (S.fromAscList (L.map fromEnum es))--fromDistinctAscList :: (Enum e) => [e] -> EnumSet e-fromDistinctAscList es = EnumSet (S.fromDistinctAscList (L.map fromEnum es))--showTree :: (Enum e) => EnumSet e -> String-showTree (EnumSet s) = S.showTree s--showTreeWith :: (Enum e) => Bool -> Bool -> EnumSet e -> String-showTreeWith a1 a2 (EnumSet s) = S.showTreeWith a1 a2 s
+ Data/IntSet/EnumSet2.hs view
@@ -0,0 +1,106 @@+module Data.IntSet.EnumSet2 where++import qualified Data.IntSet as S+import qualified Data.List as L (map)+import Data.Monoid(Monoid(..))++newtype EnumSet e = EnumSet {unEnumSet :: S.IntSet}+ deriving (Eq,Ord,Read,Show)++instance Monoid (EnumSet e) where+ mempty = EnumSet mempty+ EnumSet x `mappend` EnumSet y = EnumSet (x `mappend` y)++(\\) :: (Enum e) => EnumSet e -> EnumSet e -> EnumSet e+(\\) (EnumSet s1) (EnumSet s2) = EnumSet ((S.\\) s1 s2)++null :: (Enum e) => EnumSet e -> Bool+null (EnumSet s) = S.null s++size :: (Enum e) => EnumSet e -> Int+size (EnumSet s) = S.size s++member :: (Enum e) => e -> EnumSet e -> Bool+member e (EnumSet s) = S.member (fromEnum e) s++notMember :: (Enum e) => Int -> EnumSet e -> Bool+notMember e (EnumSet s) = S.notMember (fromEnum e) s++isSubsetOf :: (Enum e) => EnumSet e -> EnumSet e -> Bool+isSubsetOf (EnumSet e1) (EnumSet e2) = S.isSubsetOf e1 e2++isProperSubsetOf :: (Enum e) => EnumSet e -> EnumSet e -> Bool+isProperSubsetOf (EnumSet e1) (EnumSet e2) = S.isProperSubsetOf e1 e2++empty :: (Enum e) => EnumSet e+empty = EnumSet (S.empty)++singleton :: (Enum e) => e -> EnumSet e+singleton e = EnumSet (S.singleton (fromEnum e))++insert :: (Enum e) => e -> EnumSet e -> EnumSet e+insert e (EnumSet s) = EnumSet (S.insert (fromEnum e) s)++delete :: (Enum e) => e -> EnumSet e -> EnumSet e+delete e (EnumSet s) = EnumSet (S.delete (fromEnum e) s)++union :: (Enum e) => EnumSet e -> EnumSet e -> EnumSet e+union (EnumSet s1) (EnumSet s2) = EnumSet (S.union s1 s2)++unions :: (Enum e) => [EnumSet e] -> EnumSet e+unions es = EnumSet (S.unions (L.map unEnumSet es))++difference :: (Enum e) => EnumSet e -> EnumSet e -> EnumSet e+difference (EnumSet e1) (EnumSet e2) = EnumSet (S.difference e1 e2)++intersection :: (Enum e) => EnumSet e -> EnumSet e -> EnumSet e+intersection (EnumSet e1) (EnumSet e2) = EnumSet (S.intersection e1 e2)++filter :: (Enum e) => (e -> Bool) -> EnumSet e -> EnumSet e+filter f (EnumSet s) = EnumSet (S.filter f' s)+ where f' b = f (toEnum b)++partition :: (Enum e) => (e -> Bool) -> EnumSet e -> (EnumSet e, EnumSet e)+partition f (EnumSet s) = (EnumSet s1', EnumSet s2')+ where (s1',s2') = S.partition f' s+ f' b = f (toEnum b)++split :: (Enum e) => e -> EnumSet e -> (EnumSet e, EnumSet e)+split e (EnumSet s) = (EnumSet s1', EnumSet s2')+ where (s1',s2') = S.split (fromEnum e) s++splitMember :: (Enum e) => e -> EnumSet e -> (EnumSet e, Bool, EnumSet e)+splitMember e (EnumSet s) = (EnumSet s1',a,EnumSet s2')+ where (s1',a,s2') = S.splitMember (fromEnum e) s++map :: (Enum e) => (e -> e) -> EnumSet e -> EnumSet e+map f (EnumSet s) = EnumSet (S.map f' s)+ where f' b = fromEnum (f (toEnum b))++fold :: (Enum e) => (e -> b -> b) -> b -> EnumSet e -> b+fold f a (EnumSet s) = S.fold f' a s+ where f' b a1 = f (toEnum b) a1++elems :: (Enum e) => EnumSet e -> [e]+elems (EnumSet s) = L.map toEnum (S.elems s)++toList :: (Enum e) => EnumSet e -> [e]+toList (EnumSet s) = L.map toEnum (S.toList s)++fromList :: (Enum e) => [e] -> EnumSet e+fromList es = EnumSet (S.fromList (L.map fromEnum es))++toAscList :: (Enum e) => EnumSet e -> [e]+toAscList (EnumSet s) = L.map toEnum (S.toAscList s)++fromAscList :: (Enum e) => [e] -> EnumSet e+fromAscList es = EnumSet (S.fromAscList (L.map fromEnum es))++fromDistinctAscList :: (Enum e) => [e] -> EnumSet e+fromDistinctAscList es = EnumSet (S.fromDistinctAscList (L.map fromEnum es))++showTree :: (Enum e) => EnumSet e -> String+showTree (EnumSet s) = S.showTree s++showTreeWith :: (Enum e) => Bool -> Bool -> EnumSet e -> String+showTreeWith a1 a2 (EnumSet s) = S.showTreeWith a1 a2 s
LICENSE view
@@ -1,6 +1,6 @@ This modile is under this "3 clause" BSD license: -Copyright (c) 2007, Christopher Kuklewicz+Copyright (c) 2007-2009, Christopher Kuklewicz All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
Text/Regex/TDFA.hs view
@@ -11,11 +11,12 @@ {-| + The "Text.Regex.TDFA" module provides a backend for regular-expressions. To use it should be imported along with-"Text.Regex.Base". If you import this along with other backends, then-you should do so with qualified imports, perhaps renamed for-convenience.+expressions. It provides instances for the classes defined and+documented in "Text.Regex.Base" and re-exported by this module. If+you import this along with other backends then you should do so with+qualified imports (with renaming for convenience). Todo: compNoCapture to avoid creating any tags and optimize inStar stuff...
Text/Regex/TDFA/ByteString.hs view
@@ -24,8 +24,7 @@ import Text.Regex.Base.Impl(polymatch,polymatchM) import Text.Regex.TDFA.ReadRegex(parseRegex) import Text.Regex.TDFA.String() -- piggyback on RegexMaker for String-import Text.Regex.TDFA.TDFA(patternToDFA)-import Text.Regex.TDFA.MutRunBS(findMatch,findMatchAll,countMatchAll)+import Text.Regex.TDFA.TDFA(patternToRegex) import Text.Regex.TDFA.Wrap(Regex(..),CompOption,ExecOption) {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}@@ -38,12 +37,19 @@ makeRegexOptsM c e source = makeRegexOptsM c e (B.unpack source) instance RegexLike Regex B.ByteString where- matchOnce = findMatch- matchAll = findMatchAll- matchCount = countMatchAll--- matchTest--- matchOnceText--- matchTextAll+ matchOnce r = matchOnce r . B.unpack+ matchAll r = matchAll r . B.unpack+ matchCount r = matchCount r . B.unpack+ matchTest r = matchTest r . B.unpack+ matchOnceText regex source = + fmap (\ma -> let (o,l) = ma!0+ in (B.take o source+ ,fmap (\ol@(off,len) -> (B.take len (B.drop off source),ol)) ma+ ,B.drop (o+l) source))+ (matchOnce regex source)+ matchAllText regex source =+ map (fmap (\ol@(off,len) -> (B.take len (B.drop off source),ol)))+ (matchAll regex source) compile :: CompOption -- ^ Flags (summed together) -> ExecOption -- ^ Flags (summed together)@@ -52,9 +58,7 @@ compile compOpt execOpt bs = case parseRegex (B.unpack bs) of Left err -> Left ("parseRegex for Text.Regex.TDFA.ByteString failed:"++show err)- Right pattern ->- let (dfa,i,tags,groups) = patternToDFA compOpt pattern- in Right (Regex dfa i tags groups compOpt execOpt)+ Right pattern -> Right (patternToRegex pattern compOpt execOpt) execute :: Regex -- ^ Compiled regular expression -> B.ByteString -- ^ ByteString to match against
Text/Regex/TDFA/ByteString/Lazy.hs view
@@ -24,8 +24,7 @@ import Text.Regex.Base.Impl(polymatch,polymatchM) import Text.Regex.TDFA.ReadRegex(parseRegex) import Text.Regex.TDFA.String() -- piggyback on RegexMaker for String-import Text.Regex.TDFA.TDFA(patternToDFA)-import Text.Regex.TDFA.MutRunLBS(findMatch,findMatchAll,countMatchAll)+import Text.Regex.TDFA.TDFA(patternToRegex) import Text.Regex.TDFA.Wrap(Regex(..),CompOption,ExecOption) {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}@@ -38,13 +37,28 @@ makeRegexOptsM c e source = makeRegexOptsM c e (L.unpack source) instance RegexLike Regex L.ByteString where- matchOnce = findMatch- matchAll = findMatchAll- matchCount = countMatchAll--- matchTest--- matchOnceText--- matchTextAll+ matchOnce r = matchOnce r . L.unpack+ matchAll r = matchAll r . L.unpack+ matchCount r = matchCount r . L.unpack+ matchTest r = matchTest r . L.unpack+ matchOnceText regex source = + fmap (\ma ->+ let (o32,l32) = ma!0+ o = fi o32+ l = fi l32+ in (L.take o source+ ,fmap (\ol@(off32,len32) ->+ let off = fi off32+ len = fi len32+ in (L.take len (L.drop off source),ol)) ma+ ,L.drop (o+l) source))+ (matchOnce regex source)+ matchAllText regex source =+ map (fmap (\ol@(off32,len32) -> (L.take (fi len32) (L.drop (fi off32) source),ol)))+ (matchAll regex source) +fi = fromIntegral+ compile :: CompOption -- ^ Flags (summed together) -> ExecOption -- ^ Flags (summed together) -> L.ByteString -- ^ The regular expression to compile@@ -52,9 +66,7 @@ compile compOpt execOpt bs = case parseRegex (L.unpack bs) of Left err -> Left ("parseRegex for Text.Regex.TDFA.ByteString failed:"++show err)- Right pattern ->- let (dfa,i,tags,groups) = patternToDFA compOpt pattern- in Right (Regex dfa i tags groups compOpt execOpt)+ Right pattern -> Right (patternToRegex pattern compOpt execOpt) execute :: Regex -- ^ Compiled regular expression -> L.ByteString -- ^ ByteString to match against
Text/Regex/TDFA/Common.hs view
@@ -7,15 +7,22 @@ {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} import Text.Show.Functions()-import Control.Monad.State(State)+--import Control.Monad.State(State)+import Data.Monoid(mempty,mappend)+import Data.Foldable(Foldable(..)) import Data.Array.IArray(Array)-import Data.IntSet.EnumSet(EnumSet)-import Data.IntMap as IMap (IntMap,findWithDefault,assocs)+import Data.IntSet.EnumSet2(EnumSet)+import qualified Data.IntSet.EnumSet2 as Set(toList)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IMap (findWithDefault,assocs,toList,null) import Data.IntSet(IntSet)-import Data.IntMap.CharMap as Map (CharMap,assocs)+import Data.IntMap.CharMap2(CharMap)+import qualified Data.IntMap.CharMap2 as Map (assocs,toAscList,null) import Data.Sequence(Seq) --import Debug.Trace +import Text.Regex.TDFA.IntArrTrieSet(TrieSet)+ {-# INLINE look #-} look :: Int -> IntMap a -> a look key imap = IMap.findWithDefault (common_error "Text.Regex.DFA.Common" ("key "++show key++" not found in look")) key imap@@ -81,7 +88,7 @@ data CompOption = CompOption { caseSensitive :: Bool -- ^ True by default , multiline :: Bool -- ^ True by default, implies "." and "[^a]" will not match '\n' , rightAssoc :: Bool -- ^ False (and therefore left associative) by default- , lastStarGreedy :: Bool -- ^ False by default. This is POSIX correct by takes space and is slower.+ , lastStarGreedy :: Bool -- ^ False by default. This is POSIX correct but it takes space and is slower. -- Setting this to true will improve performance, and should be done -- if you plan to set the captureGroups execoption to False. } deriving (Read,Show)@@ -89,16 +96,13 @@ , testMatch :: Bool -- ^ False by default. Set to True to quickly return shortest match (w/o groups). [ UNUSED ] } deriving (Read,Show) --- | Used by implementation to name certain Positions during matching-type Tag = Int+-- | Used by implementation to name certain Postions during matching+type Tag = Int -- ^ identity of Position tag to set during a transition -- | Internal use to indicate type of tag and preference for larger or smaller Positions-data OP = Maximize | Minimize | Orbit deriving (Eq,Show)--- | Internal NFA node identity number-type Index = Int--- | Internal DFA identity is this Set of NFA Index-type SetIndex = IntSet {- Index -}--- | Index into the text being searched-type Position = Int+data OP = Maximize | Minimize | Orbit | Ignore deriving (Eq,Show)+type Index = Int -- ^ Internal NFA node identity number+type SetIndex = IntSet {- Index -} -- ^ Internal DFA identity is this Set of NFA Index+type Position = Int -- ^ Index into the text being searched -- | GroupIndex is for indexing submatches from capturing -- parenthesized groups (PGroup/Group)@@ -106,17 +110,24 @@ -- | GroupInfo collects the parent and tag information for an instance -- of a group data GroupInfo = GroupInfo {thisIndex,parentIndex::GroupIndex- ,startTag,stopTag::Tag+ ,startTag,stopTag,flagTag::Tag } deriving Show -- | The TDFA backend specific 'Regex' type, used by this module's RegexOptions and RegexMaker-data Regex = Regex {regex_dfa::DFA -- ^ starting DFA state- ,regex_init::Index -- ^ index of starting DFA state- ,regex_tags::Array Tag OP -- ^ information about each tag- ,regex_groups::Array GroupIndex [GroupInfo] -- ^ information about each group- ,regex_compOptions::CompOption- ,regex_execOptions::ExecOption}+data Regex = Regex {regex_dfa :: DFA -- ^ starting DFA state+ ,regex_init :: Index -- ^ index of starting state+ ,regex_b_index :: (Index,Index) -- ^ indexes of smallest and largest states+ ,regex_b_tags :: (Tag,Tag) -- ^ indexes of smallest and largest tags+ ,regex_trie :: TrieSet DFA -- ^ All DFA states+ ,regex_tags :: Array Tag OP -- ^ information about each tag+ ,regex_groups :: Array GroupIndex [GroupInfo] -- ^ information about each group+ ,regex_compOptions :: CompOption -- + ,regex_execOptions :: ExecOption} +data WinEmpty = WinEmpty Instructions+ | WinTest WhichTest (Maybe WinEmpty) (Maybe WinEmpty)+ deriving Show+ -- | Internal NFA node type data QNFA = QNFA {q_id :: Index ,q_qt :: QT}@@ -141,7 +152,7 @@ -- ResetGroupStopTask are for tags with Maximize or Minimize OP -- values. ResetOrbitTask and EnterOrbitTask and LeaveOrbitTask are -- for tags with Orbit OP value.-data TagTask = TagTask | ResetGroupStopTask+data TagTask = TagTask | ResetGroupStopTask | SetGroupStopTask | ResetOrbitTask | EnterOrbitTask | LeaveOrbitTask deriving (Show,Eq) -- | Ordered list of tags and their associated Task type TagTasks = [(Tag,TagTask)]@@ -159,72 +170,157 @@ -- | Internal DFA node, identified by the Set of indices of the QNFA -- nodes it represents.-data DFA = DFA { d_id :: SetIndex, d_dt :: DT} deriving(Show)+data DFA = DFA { d_id :: SetIndex, d_dt :: DT } deriving(Show)+data Transition = Transition { trans_many :: DFA -- ^ where to go (maximal), including respawning+ , trans_single :: DFA -- ^ where to go, not including respawning+ , trans_how :: DTrans -- ^ how to go, including respawning+ } -- | Internal to the DFA node-data DT = Simple' { dt_win :: IntMap {- Index -} Instructions -- ^ Actions to perform to win- , dt_trans :: CharMap (DFA,DTrans) -- ^ Transition to accept Char- , dt_other :: Maybe (DFA,DTrans) -- ^ Optional default accepting transition+data DT = Simple' { dt_win :: IntMap {- Source Index -} Instructions -- ^ Actions to perform to win+ , dt_trans :: CharMap Transition -- ^ Transition to accept Char+ , dt_other :: Maybe Transition -- ^ Optional default accepting transition } | Testing' { dt_test :: WhichTest -- ^ The test to perform , dt_dopas :: EnumSet DoPa -- ^ location(s) of the anchor(s) in the original regexp , dt_a,dt_b :: DT -- ^ use dt_a if test is True else use dt_b } -instance Show DT where show = showDT--showDT :: DT -> String-showDT (Simple' w t o) = "Simple' { dt_win = " ++ (unlines . map show . IMap.assocs $ w)- ++ "\n , dt_trans = " ++ (unlines . map (\(char,(dfa,dtrans)) -> "("++show char++", "++show (d_id dfa)++", "- ++ seeDTrans dtrans ++")") . Map.assocs $ t)- ++ "\n , dt_other = " ++ maybe "None" (\(dfa,dtrans) -> "("++show (d_id dfa)++", "++ seeDTrans dtrans++")") o- ++ "\n }"--showDT (Testing' wt d a b) = "Testing' { dt_test = " ++ show wt- ++ "\n , dt_dopas = " ++ show d- ++ "\n , dt_a = " ++ indent a- ++ "\n , dt_b = " ++ indent b- ++ "\n }"- where indent = init . unlines . (\(h:t) -> h : (map (spaces ++) t)) . lines . showDT- spaces = replicate 10 ' '--seeDTrans :: DTrans -> String-seeDTrans x = concatMap (\(dest,y) -> unlines . map (\(source,ins) -> show (dest,source,ins) ) . IMap.assocs $ y) (IMap.assocs x)-- -- | Internal type to repesent the commands for the tagged transition. -- The outer IntMap is for the destination Index and the inner IntMap -- is for the Source Index. This is convenient since all runtime data -- going to the same destination must be compared to find the best.+--+-- A Destination IntMap entry may have an empty Source IntMap if and+-- only if the destination is the starting index and the NFA/DFA.+-- This instructs the matching engine to spawn a new entry starting at+-- the post-update position. type DTrans = IntMap {- Index of Destination -} (IntMap {- Index of Source -} (DoPa,Instructions)) -- type DTrans = IntMap {- Index of Destination -} (IntMap {- Index of Source -} (DoPa,RunState ())) -- | Internal convenience type for the text display code type DTrans' = [(Index, [(Index, (DoPa, ([(Tag, (Position,Bool))],[String])))])] -- | Positions for which a * was re-started while looping. Need to--- append locations but compare starting with front, so use Seq as a--- Queue.+-- append locations at back but compare starting with front, so use+-- Seq as a Queue. The initial position is saved in basePos (and a+-- Maximize Tag), the middle positions in the Seq, and the final+-- position is NOT saved in the Orbits (only in a Maximize Tag).+--+-- The orderinal code is being written XXX TODO document it. data Orbits = Orbits { inOrbit :: !Bool -- True if enterOrbit, False if LeaveOrbit+ , basePos :: Position+ , ordinal :: (Maybe Int) , getOrbits :: !(Seq Position) } deriving (Show) +-- | The 'newPos' and 'newFlags' lists in Instructions are sorted by, and unique in, the Tag values data Instructions = Instructions- { newPos :: ![(Tag,Bool)] -- False is preUpdate, True is postUpdate- , newFlags :: ![(Tag,Bool)] -- apply to scratchFlags+ { newPos :: ![(Tag,Action)] -- False is preUpdate, True is postUpdate (there are no Orbit tags here) -- 2009 : Change to enum from bool? , newOrbits :: !(Maybe (Position -> OrbitTransformer)) } deriving (Show)--type OrbitLog = IntMap Orbits+data Action = SetPre | SetPost | SetVal Int deriving (Show,Eq) type OrbitTransformer = OrbitLog -> OrbitLog+type OrbitLog = IntMap Orbits -type CompileInstructions a = State- ( IntMap Bool- , IntMap Bool- , IntMap AlterOrbit- ) a+instance Show QNFA where+ show (QNFA {q_id = i, q_qt = qt}) = "QNFA {q_id = "++show i+ ++"\n ,q_qt = "++ show qt+ ++"\n}" -data AlterOrbit = AlterReset -- Delete Orbits- | AlterLeave -- set inOrbit to False if it exists- | AlterModify { newInOrbit :: Bool -- new inOrbit value- , freshOrbit :: Bool} -- True means getOrbits=Seq.empty- deriving (Show) -- False means try appening position or else Seq.empty+instance Show QT where+ show = showQT++showQT :: QT -> String+showQT (Simple win trans other) = "{qt_win=" ++ show win+ ++ "\n, qt_trans=" ++ show (foo trans)+ ++ "\n, qt_other=" ++ show (foo' other) ++ "}"+ where foo :: CharMap QTrans -> [(Char,[(Index,[TagCommand])])]+ foo = mapSnd foo' . Map.toAscList+ foo' :: QTrans -> [(Index,[TagCommand])]+ foo' = IMap.toList +showQT (Testing test dopas a b) = "{Testing "++show test++" "++show (Set.toList dopas)+ ++"\n"++indent' a+ ++"\n"++indent' b++"}"+ where indent' = init . unlines . map (spaces++) . lines . showQT+ spaces = replicate 9 ' '++instance Show DT where show = showDT++indent :: [String] -> String+indent = unlines . map (\x -> ' ':' ':x)++showDT :: DT -> String+showDT (Simple' w t o) =+ "Simple' { dt_win = " ++ seeWin1+ ++ "\n , dt_trans = " ++ seeTrans1+ ++ "\n , dt_other = " ++ seeOther1 o+ ++ "\n }"+ where+ seeWin1 | IMap.null w = "No win"+ | otherwise = indent . map show . IMap.assocs $ w++ seeTrans1 :: String+ seeTrans1 | Map.null t = "No (Char,Transition)"+ | otherwise = ('\n':) . indent $+ map (\(char,Transition {trans_many=dfa,trans_single=dfa2,trans_how=dtrans}) ->+ concat ["("+ ,show char+ ,", MANY "+ ,show (d_id dfa)+ ,", SINGLE "+ ,show (d_id dfa2)+ ,", \n"+ ,seeDTrans dtrans+ ,")"]) (Map.assocs t)++ seeOther1 Nothing = "None"+ seeOther1 (Just (Transition {trans_many=dfa,trans_single=dfa2,trans_how=dtrans})) =+ concat ["(MANY "+ ,show (d_id dfa)+ ,", SINGLE "+ ,show (d_id dfa2)+ ,", \n"+ ,seeDTrans dtrans+ ,")"]++showDT (Testing' wt d a b) = "Testing' { dt_test = " ++ show wt+ ++ "\n , dt_dopas = " ++ show d+ ++ "\n , dt_a = " ++ indent' a+ ++ "\n , dt_b = " ++ indent' b+ ++ "\n }"+ where indent' = init . unlines . (\(h:t) -> h : (map (spaces ++) t)) . lines . showDT+ spaces = replicate 10 ' '+++seeDTrans :: DTrans -> String+--seeDTrans x = concatMap (\(dest,y) -> unlines . map (\(source,ins) -> show (dest,source,ins) ) . IMap.assocs $ y) (IMap.assocs x)+seeDTrans x | IMap.null x = "No DTrans"+seeDTrans x = concatMap seeSource (IMap.assocs x)+ where seeSource (dest,srcMap) | IMap.null srcMap = indent [show (dest,"SPAWN")]+ | otherwise = indent . map (\(source,ins) -> show (dest,source,ins) ) . IMap.assocs $ srcMap+-- spawnIns = Instructions { newPos = [(0,SetPost)], newOrbits = Nothing }++data SList a = !a :! !(SList a) | SEnd++infixr :!++instance Functor SList where+ fmap f = go where go SEnd = SEnd+ go (a :! b) = f a :! go b++instance Foldable SList where+ fold SEnd = mempty+ fold (a :! b) = a `mappend` fold b+ foldMap f = go where go SEnd = mempty+ go (a :! b) = f a `mappend` go b+ foldr f x = go where go (a :! b) = f a (go b)+ go SEnd = x+ foldr1 f = go where go (a :! SEnd) = a+ go (a :! b) = f a (go b)+ go SEnd = error "foldr1 on SEnd"+ foldl f x = go x where go c (a :! b) = go (f c a) b+ go c SEnd = c+ foldl1 f = start where start SEnd = error "foldl1 on SEnd"+ start (a :! b) = go a b+ go c (a :! b) = go (f c a) b+ go c SEnd = c
Text/Regex/TDFA/CorePattern.hs view
@@ -20,6 +20,16 @@ -- in nullView, which is eliminated by cleanNullView. -- -- Uses recursive do notation.+--+-- 2009 XXX TODO: we can avoid needing tags in the part of the pattern+-- after the last capturing group (when right-associative). This is+-- flipped for left-associative where the front of the pattern before+-- the first capturing group needs no tags. The edge of these regions+-- is subtle: both case needs a Maximize tag. One ought to be able to+-- check the Pattern: if the root is PConcat then a scan from the end+-- (start) looking for the first with an embedded PGroup can be found+-- and the PGroup free elements can be wrapped in some new PNOTAG+-- semantic indicator. module Text.Regex.TDFA.CorePattern(Q(..),P(..),WhichTest(..),Wanted(..) ,TestInfo,OP(..),SetTestInfo(..),NullView ,patternToQ,cleanNullView,cannotAccept,mustAccept) where@@ -27,44 +37,47 @@ import Control.Monad.RWS {- all -} import Data.Array.IArray(Array,(!),accumArray,listArray) import Data.List(sort)-import Data.IntMap.EnumMap(EnumMap)-import qualified Data.IntMap.EnumMap as Map(singleton,null,assocs,keysSet)-import Data.Maybe(isNothing)-import Data.IntSet.EnumSet(EnumSet)-import qualified Data.IntSet.EnumSet as Set(singleton,toList,isSubsetOf)+import Data.IntMap.EnumMap2(EnumMap)+import qualified Data.IntMap.EnumMap2 as Map(singleton,null,assocs,keysSet)+--import Data.Maybe(isNothing)+import Data.IntSet.EnumSet2(EnumSet)+import qualified Data.IntSet.EnumSet2 as Set(singleton,toList,isSubsetOf) import Text.Regex.TDFA.Common {- all -} import Text.Regex.TDFA.Pattern(Pattern(..),starTrans)--- import Debug.Trace+--import Debug.Trace {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} -err :: String -> a-err = common_error "Text.Regex.TDFA.CorePattern"+--err :: String -> a+--err = common_error "Text.Regex.TDFA.CorePattern" -debug :: (Show a) => a -> b -> b-debug _ = id+--debug :: (Show a) => a -> b -> b+--debug _ = id -- Core Pattern Language-data P = Empty+data P = Empty -- Could be replaced by (Test Nothing)?? | Or [Q] | Seq Q Q- | Star { getOrbit :: Maybe Tag -- tag to prioritize the need to keep track of length of each pass though q- , resetOrbits :: [Tag] -- child star's orbits to reset (ResetOrbitTask)- , firstNull :: Bool -- Usually True meaning the first pass may match 0 characters+ | Star { getOrbit :: Maybe Tag -- tag to prioritize the need to keep track of length of each pass though q+ , resetOrbits :: [Tag] -- child star's orbits to reset (ResetOrbitTask) at all depths+ , firstNull :: Bool -- Usually True to mean the first pass may match 0 characters , unStar :: Q}- | Test TestInfo -- Require the test to be true- | OneChar Pattern -- Bring the Pattern element that accepts a character- | NonEmpty Q -- Don't let the Q pattern match nothing+ | Test TestInfo -- Require the test to be true (merge with empty as (Test (Maybe TestInfo)) ??)+ | OneChar Pattern -- Bring the Pattern element that accepts a character+ | NonEmpty Q -- Don't let the Q pattern match nothing deriving (Show,Eq) --- The diagnostics about the pattern-data Q = Q {nullQ :: NullView -- Ordered list of nullable views- ,takes :: (Position,Maybe Position) -- Range of number of accepted characters- ,preReset :: [Tag] -- Tags to "reset" (ResetGroupStopTask) (Only immediate children)- ,preTag,postTag :: Maybe Tag -- Tags assigned around this pattern (TagTask)- ,tagged :: Bool -- Whether this node should be tagged -- patternToQ use only- ,childGroups :: Bool -- Whether unQ has any PGroups -- patternToQ use only- ,wants :: Wanted -- What kind of continuation is used by this pattern+-- The diagnostics about the pattern. Note that when unQ is 'Seq' the+-- the preTag and postTag are Nothing but the preReset might have tags+-- from PGroup injecting them.+data Q = Q {nullQ :: NullView -- Ordered list of nullable views+ ,takes :: (Position,Maybe Position) -- Range of number of accepted characters+ ,preReset :: [Tag] -- Tags to "reset" (ResetGroupStopTask) (Only immediate children for efficiency)+ ,postSet :: [Tag] -- Tags to "set" (SetGroupStopTask)+ ,preTag,postTag :: Maybe Tag -- Tags assigned around this pattern (TagTask)+ ,tagged :: Bool -- Whether this node should be tagged -- patternToQ use only+ ,childGroups :: Bool -- Whether unQ has any PGroups -- patternToQ use only+ ,wants :: Wanted -- What kind of continuation is used by this pattern ,unQ :: P} deriving (Eq) type TestInfo = (WhichTest,DoPa)@@ -84,9 +97,10 @@ -- (i.e. with a Test) or unconditionally accept 0 characters. These -- are in the list in order of preference, with most preferred listed -- first.-type NullView = [(SetTestInfo,WinTags)] -- Ordered list of null views, each is a set of tests and tags+type NullView = [(SetTestInfo,TagList)] -- Ordered list of null views, each is a set of tests and tags --- During the depth first traversal, children are told about tags by the parent+-- During the depth first traversal, children are told about tags by the parent.+-- They may change Apply to Advice and they may generate new tags. data HandleTag = NoTag -- No tag at this boundary | Advice Tag -- tag at this boundary, applied at higher level in tree | Apply Tag -- tag at this boundary, may be applied at this node or passed to one child@@ -96,6 +110,9 @@ -- prefer to be passed when processing. This makes it possible to -- create a smaller number of QNFA states and avoid creating wasteful -- QNFA states that won't be reachable in the final automata.+--+-- In practice WantsBoth is treated identically to WantsQNFA and+-- WantsBoth could be removed. data Wanted = WantsQNFA | WantsQT | WantsBoth | WantsEither deriving (Eq,Show) instance Show Q where@@ -105,24 +122,58 @@ showQ q = "Q { nullQ = "++show (nullQ q)++ "\n , takes = "++show (takes q)++ "\n , preReset = "++show (preReset q)+++ "\n , postSet = "++show (postSet q)++ "\n , preTag = "++show (preTag q)++ "\n , postTag = "++show (postTag q)++ "\n , tagged = "++show (tagged q)++ "\n , wants = "++show (wants q)++- "\n , unQ = "++ indent (unQ q)++" }"- where indent = unlines . (\(h:t) -> h : (map (spaces ++) t)) . lines . show+ "\n , unQ = "++ indent' (unQ q)++" }"+ where indent' = unlines . (\(h:t) -> h : (map (spaces ++) t)) . lines . show spaces = replicate 10 ' ' -- Smart constructors for NullView notNull :: NullView notNull = [] -emptyNull :: WinTags -> NullView-emptyNull tags = (mempty, tags) : []+-- Shorthand for combining a preTag and a postTag+-- preTags :: Maybe Tag -> Maybe Tag -> TagList+-- preTags a b = promote a `mappend` promote b+-- where promote = maybe [] (\x -> [(x,PreUpdate TagTask)]) -testNull :: TestInfo -> WinTags -> NullView-testNull (w,d) tags = (SetTestInfo (Map.singleton w (Set.singleton d)), tags) : []+promotePreTag :: HandleTag -> TagList+promotePreTag = maybe [] (\x -> [(x,PreUpdate TagTask)]) . apply +makeEmptyNullView :: HandleTag -> HandleTag -> NullView+makeEmptyNullView a b = [(mempty, promotePreTag a ++ promotePreTag b)]++makeTestNullView :: TestInfo -> HandleTag -> HandleTag -> NullView+makeTestNullView (w,d) a b = [(SetTestInfo (Map.singleton w (Set.singleton d)), promotePreTag a ++ promotePreTag b)]++tagWrapNullView :: HandleTag -> HandleTag -> NullView -> NullView+tagWrapNullView a b oldNV =+ case (promotePreTag a, promotePreTag b) of+ ([],[]) -> oldNV+ (pre,post) -> do+ (oldTests,oldTasks) <- oldNV+ return (oldTests,pre++oldTasks++post)++-- For PGroup, need to prepend reset tasks before others in nullView+addGroupResetsToNullView :: [Tag] -> Tag -> NullView -> NullView+addGroupResetsToNullView groupResets groupSet nv = [ (test, prepend (append tags) ) | (test,tags) <- nv ]+ where prepend = foldr (\h t -> (h:).t) id . map (\tag->(tag,PreUpdate ResetGroupStopTask)) $ groupResets+ append = (++[(groupSet,PreUpdate SetGroupStopTask)])++-- For PStar, need to put in the orbit TagTasks+orbitWrapNullView :: Maybe Tag -> [Tag] -> NullView -> NullView+orbitWrapNullView mOrbit orbitResets oldNV =+ case (mOrbit,orbitResets) of+ (Nothing,[]) -> oldNV+ (Nothing,_) -> do (oldTests,oldTasks) <- oldNV+ return (oldTests,prepend oldTasks)+ (Just o,_) -> do (oldTests,oldTasks) <- oldNV+ return (oldTests,prepend $ [(o,PreUpdate EnterOrbitTask)] ++ oldTasks ++ [(o,PreUpdate LeaveOrbitTask)])+ where prepend = foldr (\h t -> (h:).t) id . map (\tag->(tag,PreUpdate ResetOrbitTask)) $ orbitResets+ -- The NullViews are ordered, and later test sets that contain the -- tests from any earlier entry will never be chosen. This function -- returns a list with these redundant elements removed. Note that@@ -144,29 +195,6 @@ return (mappend test1 test2,mappend tag1 tag2) -- mergeNullViews = cleanNullView $ liftM2 (mappend *** mappend) --- Prepend tags to nullView-addTagsToNullView :: WinTags -> NullView -> NullView-addTagsToNullView [] nv = nv-addTagsToNullView tags nv= do- (test,tags') <- nv- return (test,tags `mappend` tags')---- For PStar, need to put in the orbit TagTasks-orbitWrapNullView :: Maybe Tag -> [Tag] -> NullView -> NullView-orbitWrapNullView mOrbit orbitResets oldNV =- case (mOrbit,orbitResets) of- (Nothing,[]) -> oldNV- (Nothing,_) -> do (oldTests,oldTasks) <- oldNV- return (oldTests,prepend oldTasks)- (Just o,_) -> do (oldTests,oldTasks) <- oldNV- return (oldTests,prepend $ [(o,PreUpdate EnterOrbitTask)] ++ oldTasks ++ [(o,PreUpdate LeaveOrbitTask)])- where prepend = foldr (\h t -> (h:).t) id . map (\tag->(tag,PreUpdate ResetOrbitTask)) $ orbitResets---- For PGroup, need to prepend reset tasks before others in nullView-addResetsToNullView :: [Tag]-> NullView -> NullView-addResetsToNullView resetTags nv = [ (test, prepend tags) | (test,tags) <- nv ]- where prepend = foldr (\h t -> (h:).t) id . map (\tag->(tag,PreUpdate ResetGroupStopTask)) $ resetTags- -- Concatenated two ranges of number of accepted characters seqTake :: (Int, Maybe Int) -> (Int, Maybe Int) -> (Int, Maybe Int) seqTake (x1,y1) (x2,y2) = (x1+x2,liftM2 (+) y1 y2)@@ -192,13 +220,6 @@ fromHandleTag (Advice tag) = tag fromHandleTag _ = error "fromHandleTag" --- Shorthand for combining a preTag and a postTag-winTags :: Maybe Tag -> Maybe Tag -> WinTags-winTags (Just a) (Just b) = [(a,PreUpdate TagTask),(b,PreUpdate TagTask)]-winTags (Just a) Nothing = [(a,PreUpdate TagTask)]-winTags Nothing (Just b) = [(b,PreUpdate TagTask)]-winTags Nothing Nothing = mempty- -- Predicates on the range of number of accepted characters varies :: Q -> Bool varies Q {takes = (_,Nothing)} = True@@ -220,17 +241,19 @@ -- created top down and passed to children. Thus information flows up -- from the dfs of the children and simultaneously down in the form of -- pre and post HandleTag data. This bidirectional flow is handled--- declaratively by using the MonadFix (i.e. mdo) instance of State.+-- declaratively by using the MonadFix (i.e. mdo). -- --- Invariant: A tag should exist in Q in exactly one place. This is--- because PGroup needs to know the tags are around precisely the--- expression that it wants to record. If the same tag were in other--- branches then this would no longer be true.+-- Invariant: A tag should exist in Q in exactly one place (and will+-- be in a preTag,postTag, or getOrbit field). This is partly because+-- PGroup needs to know the tags are around precisely the expression+-- that it wants to record. If the same tag were in other branches+-- then this would no longer be true. The tag may or may not also+-- show up in one or more preReset list or resetOrbits list. -- -- This invariant is enforced by each node either taking -- responsibility (apply) for a passed in / created tag or sending it -- to exactly one child node. Other child nodes need to receive it--- via toAdvice.+-- via toAdvice. Leaf nodes are forced to apply any passed tags. -- -- There is a final "qwin of Q {postTag=ISet.singleton 1}" and an -- implied initial index tag of 0.@@ -268,30 +291,70 @@ -- implicitly inside a PGroup 0 converted into a GroupInfo 0 undefined 0 1 monad = go (starTrans pOrig) (Advice 0) (Advice 1)+ -- startReader is accessed by getParentIndex and changed by nonCapture and withParent startReader :: Maybe GroupIndex startReader = Just 0 -- start inside group 0, capturing enabled+ -- The startState is only acted upon in the "uniq" command+ -- Tag 0 is Minimized and Tag 1 is maximized, next tag has value of 2+ -- This is regarless of right or left associativity startState :: ([OP]->[OP],Tag)- startState = ( (Minimize:) . (Maximize:) , 2) -- Tag 0 is Minimized and Tag 1 is maximized.+ startState = ( (Minimize:) . (Maximize:) , 2) + -- uniq uses MonadState and always returns an "Apply _" tag+ {-# INLINE uniq #-}+ uniq :: String -> PM HandleTag+ uniq _msg = do x <- fmap Apply (uniq' Maximize)+-- trace (_msg ++ " Maximize "++show x) $ return x+ return x++ ignore :: String -> PM Tag+ ignore _msg = do x <- uniq' Ignore+-- trace (_msg ++ " Ignore "++show x) $ return x+ return x++ {-# NOINLINE uniq' #-}+ uniq' :: OP -> PM Tag+ uniq' newOp = do+ (op,s) <- get -- generate the next tag with bias newOp+ let op' = op . (newOp:)+ s' = succ s+ put $! (op',s')+ return s++ {-# INLINE makeOrbit #-} -- Specialize the monad operations and give more meaningful names+ -- makeOrbit uses MonadState(uniq) and MonadWriter(tell/Left) makeOrbit :: PM (Maybe Tag)- makeOrbit = do Apply x <- uniq Orbit+ makeOrbit = do x <- uniq' Orbit+-- trace ("PStar Orbit "++show x) $ do tell [Left x] return (Just x) + {-# INLINE withOrbit #-}+ -- withOrbit uses MonadWriter(listens to makeOrbit/Left), collects+ -- children at all depths withOrbit :: PM a -> PM (a,[Tag]) withOrbit = listens childStars where childStars x = let (ts,_) = partitionEither x in ts - getParentIndex :: PM (Maybe GroupIndex)- getParentIndex = ask-+ {-# INLINE makeGroup #-}+ -- makeGroup usesMonadWriter(tell/Right) makeGroup :: GroupInfo -> PM () makeGroup = tell . (:[]) . Right + {-# INLINE getParentIndex #-}+ -- getParentIndex uses MonadReader(ask)+ getParentIndex :: PM (Maybe GroupIndex)+ getParentIndex = ask++ {-# INLINE nonCapture #-}+ -- nonCapture uses MonadReader(local) to suppress getParentIndex to return Nothing nonCapture :: PM a -> PM a nonCapture = local (const Nothing) + -- withParent uses MonadReader(local) to set getParentIndex to return (Just this)+ -- withParent uses MonadWriter(listens to makeGroup/Right) to return contained group indices (stopTag)+ -- withParent is only safe if getParentIndex has been checked to be not equal to Nothing (see PGroup below) withParent :: GroupIndex -> PM a -> PM (a,[Tag]) withParent this = local (const (Just this)) . listens childGroupInfo where childGroupInfo x =@@ -300,75 +363,87 @@ children = norep . sort . map thisIndex -- filter to get only immediate children (efficiency) . filter ((this==).parentIndex) $ gs- in concatMap (map stopTag . (aGroups!)) (this:children)-- uniq :: OP -> PM HandleTag- uniq newOp = do (op,s) <- get -- generate the next tag with bias newOp- let op' = op . (newOp:)- s' = succ s- put $! debug ("\n"++show (s,newOp)++"\n") (op',s')- return (Apply s) -- someone will need to apply it+ in concatMap (map flagTag . (aGroups!)) (this:children) - -- Partial function: Must not pass in an empty list+ -- combineConcat is a partial function: Must not pass in an empty list -- Policy choices: -- * pass tags to apply to children and have no preTag or postTag here (so none addded to nullQ)- -- * middle 'mid' tag: give to left/front child as postTag so a Group there might claims as stopTag+ -- * middle 'mid' tag: give to left/front child as postTag so a Group there might claim it as a stopTag -- * if parent is Group then preReset will become non-empty combineConcat :: [Pattern] -> HHQ- combineConcat | rightAssoc compOpt = (\ps -> foldr combineSeq (go (last ps)) (map go $ init ps))- | otherwise = (\ps -> foldl combineSeq (go (head ps)) (map go $ tail ps)) -- libtre default- where combineSeq :: HHQ -> HHQ -> HHQ+ combineConcat | rightAssoc compOpt = foldr1 combineSeq . map go+ | otherwise = foldl1 combineSeq . map go -- libtre default+ where {-# INLINE front'end #-}+ front'end | rightAssoc compOpt = liftM2 (,)+ | otherwise = flip (liftM2 (flip (,)))+ combineSeq :: HHQ -> HHQ -> HHQ combineSeq pFront pEnd = (\ m1 m2 -> mdo let bothVary = varies qFront && varies qEnd- a <- if noTag m1 && bothVary then uniq Minimize else return m1- b <- if noTag m2 && bothVary then uniq Maximize else return m2+ a <- if noTag m1 && bothVary then uniq "combineSeq start" else return m1+ b <- if noTag m2 && bothVary then uniq "combineSeq stop" else return m2 mid <- case (noTag a,canAccept qFront,noTag b,canAccept qEnd) of (False,False,_,_) -> return (toAdvice a) (_,_,False,False) -> return (toAdvice b)- _ -> if tagged qFront || tagged qEnd then uniq Maximize else return NoTag- qFront <- pFront a mid- qEnd <- pEnd (toAdvice mid) b+ _ -> if tagged qFront || tagged qEnd then uniq "combineSeq mid" else return NoTag+-- qFront <- pFront a mid+-- qEnd <- pEnd (toAdvice mid) b+ (qFront,qEnd) <- front'end (pFront a mid) (pEnd (toAdvice mid) b)+ -- XXX: Perhaps a "produces" should be created to compliment "wants",+ -- then "produces qEnd" could be compared to "wants qFront" let wanted = if WantsEither == wants qEnd then wants qFront else wants qEnd- return $ Q (mergeNullViews (nullQ qFront) (nullQ qEnd))- (seqTake (takes qFront) (takes qEnd))- [] Nothing Nothing- bothVary (childGroups qFront || childGroups qEnd) wanted- (Seq qFront qEnd)+ return $ Q { nullQ = mergeNullViews (nullQ qFront) (nullQ qEnd)+ , takes = seqTake (takes qFront) (takes qEnd)+ , preReset = [], postSet = [], preTag = Nothing, postTag = Nothing+ , tagged = bothVary+ , childGroups = childGroups qFront || childGroups qEnd+ , wants = wanted+ , unQ = Seq qFront qEnd } ) go :: Pattern -> HHQ go pIn m1 m2 = let die = error $ "patternToQ cannot handle "++show pIn- nil = return $ Q {nullQ=emptyNull (winTags (apply m1) (apply m2))+ nil = return $ Q {nullQ=makeEmptyNullView m1 m2 ,takes=(0,Just 0)- ,preReset=[],preTag=apply m1,postTag=apply m2+ ,preReset=[],postSet=[],preTag=apply m1,postTag=apply m2 ,tagged=False,childGroups=False,wants=WantsEither ,unQ=Empty} one = return $ Q {nullQ=notNull ,takes=(1,Just 1)- ,preReset=[],preTag=apply m1,postTag=apply m2+ ,preReset=[],postSet=[],preTag=apply m1,postTag=apply m2 ,tagged=False,childGroups=False,wants=WantsQNFA ,unQ = OneChar pIn}- test myTest = return $ Q {nullQ=testNull myTest (winTags (apply m1) (apply m2))+ test myTest = return $ Q {nullQ=makeTestNullView myTest m1 m2 ,takes=(0,Just 0)- ,preReset=[],preTag=apply m1,postTag=apply m2+ ,preReset=[],postSet=[],preTag=apply m1,postTag=apply m2 ,tagged=False,childGroups=False,wants=WantsQT ,unQ=Test myTest } in case pIn of PEmpty -> nil POr [] -> nil- POr [p] -> go p m1 m2- POr ps -> mdo+ POr [branch] -> go branch m1 m2+ POr branches -> mdo+ -- 2009 : The PNonEmpty p as POr [PEmpty,p] takes no branch tracking tag.+ -- I claim this is because only accepting branches need tags,+ -- and the last accepting branch does not need a tag.+ -- Non-accepting possibilities can all commute to the front and+ -- become part of the nullQ. The accepting bits then need prioritizing.+ -- Does the above require changes in POr handling in TNFA? Yes.+ -- Have to always use nullQ instead of recapitulating it.+ -- Could also create a constant-writing tag instead of many index tags. -- Exasperation: This POr recursive mdo is very easy to make loop and lockup the program- let canVary = varies ans || childGroups ans -- childGroups detects that "abc|a(b)c" needs tags- a <- if noTag m1 && canVary then uniq Minimize else return m1- b <- if noTag m2 && canVary then uniq Maximize else return m2- let aAdvice = toAdvice a- bAdvice = toAdvice b- -- Due to the recursive-do, it seems that I have to put the if canVary into the op'- op' = if canVary then uniq Maximize else return bAdvice- -- Preference for last branch is implicit: do not need op' to create uniq tag:- cs <- fmap (++[bAdvice]) $ replicateM (pred $ length ps) op'- qs <- mapM (\(p,c) -> go p aAdvice c) (zip ps cs)+ -- if needTags is False then there is no way to disambiguate branches so fewer tags are needed+ let needTags = varies ans || childGroups ans -- childGroups detects that "abc|a(b)c" needs tags+ a <- if noTag m1 && needTags then uniq "POr start" else return m1 -- whole POr+ b <- if noTag m2 && needTags then uniq "POr stop" else return m2 -- whole POr+ let aAdvice = toAdvice a -- all branches share 'aAdvice'+ bAdvice = toAdvice b -- last branch gets 'bAdvice', others may get own tag+ -- Due to the recursive-do, it seems that I have to put the if needTags into the op'+ newUniq = if needTags then uniq "POr branch" else return bAdvice+ -- The "bs" values are allocated in left-to-right order before the children in "qs"+ -- optimiztion: low priority for last branch is implicit, do not create separate tag here.+ bs <- fmap (++[bAdvice]) $ replicateM (pred $ length branches) newUniq -- 2 <= length ps+ -- create all the child branches in left-to-right order after the "bs"+ qs <- forM (zip branches bs) (\(branch,bTag) -> go branch aAdvice bTag) let wqs = map wants qs wanted = if any (WantsBoth==) wqs then WantsBoth else case (any (WantsQNFA==) wqs,any (WantsQT==) wqs) of@@ -376,40 +451,50 @@ (True,False) -> WantsQNFA (False,True) -> WantsQT (False,False) -> WantsEither- nullView = addTagsToNullView (winTags (apply a) (apply b)) . cleanNullView . concatMap nullQ $ qs- -- The nullView computed above takes the nullQ of the- -- branches and combines them. This assumes that the- -- pre/post tags of the children are also part of the- -- nullQ values. So for consistency, POr must then add- -- its own pre/post tags to its nullQ value.- let ans = Q nullView- (orTakes . map takes $ qs)- [] (apply a) (apply b)- canVary (any childGroups qs) wanted- (Or qs)+ nullView = cleanNullView . tagWrapNullView a b . concatMap nullQ $ qs+ -- The nullView computed above takes the nullQ of the branches and combines them. This+ -- assumes that the pre/post tags of the children are also part of the nullQ values. So+ -- for consistency, POr must then add its own pre/post tags to its nullQ value. Note that+ -- concatMap sets the left-to-right preference when choosing the null views.+ let ans = Q { nullQ = nullView+ , takes = orTakes . map takes $ qs+ , preReset = [], postSet = []+ , preTag = apply a, postTag = apply b+ , tagged = needTags+ , childGroups = any childGroups qs+ , wants = wanted+ , unQ = Or qs } return ans PConcat [] -> nil -- fatal to pass [] to combineConcat PConcat ps -> combineConcat ps m1 m2 PStar mayFirstBeNull p -> mdo let accepts = canAccept q- needsOrbit = varies q && childGroups q -- otherwise it cannot matter or be observed which path is taken- needsTags = needsOrbit || accepts -- important that needsOrbit implies needsTags- a <- if noTag m1 && needsTags then uniq Minimize else return m1- b <- if noTag m2 && needsTags then uniq Maximize else return m2- c <- if needsOrbit then makeOrbit else return Nothing -- any Orbit tag is created after the pre and post tags- (q,resetTags) <- withOrbit (go p NoTag NoTag)--- 2009-02-09 eliminate because this breaks (()*)* and ((.?)*)*--- let nullView = emptyNull (winTags (apply a) (apply b)) -- chosen to represent skipping sub-pattern+ -- if needsOrbit is False then there is no need to disambiguate captures on each orbit+ -- Both checks are useful because (varies q) of True does not imply (childGroups q) of True when under PNonCapture+ needsOrbit = varies q && childGroups q+ -- if needsOrbit then must check start/stop before the Orbit tag+ -- if accepts then must check start/stop of whole pattern+ needsTags = needsOrbit || accepts -- important that needsOrbit implies needsTags+ a <- if noTag m1 && needsTags then uniq "PStar start" else return m1+ b <- if noTag m2 && needsTags then uniq "PStar stop" else return m2+ mOrbit <- if needsOrbit then makeOrbit else return Nothing -- any Orbit tag is created after the pre and post tags+-- test1 <- if tagged q then uniq "not-TEST1" Minimize else return NoTag+ (q,resetOrbitTags) <- withOrbit (go p NoTag NoTag) -- all contained orbit tags get listened to (not including this one). let nullView | mayFirstBeNull = cleanNullView $ childViews ++ skipView | otherwise = skipView- where childViews = addTagsToNullView (winTags (apply a) (apply b)) - . orbitWrapNullView c resetTags $ nullQ q- skipView = emptyNull (winTags (apply a) (apply b))- return $ Q nullView- (0,if accepts then Nothing else (Just 0))- [] (apply a) (apply b)- needsTags (childGroups q) WantsQT- (Star c resetTags mayFirstBeNull q)+ where childViews = tagWrapNullView a b . orbitWrapNullView mOrbit resetOrbitTags $ nullQ q+ skipView = makeEmptyNullView a b+ return $ Q { nullQ = nullView+ , takes = (0,if accepts then Nothing else (Just 0))+ , preReset = [], postSet = []+ , preTag = apply a, postTag = apply b+ , tagged = needsTags+ , childGroups = childGroups q+ , wants = WantsQT+ , unQ =Star { getOrbit = mOrbit+ , resetOrbits = resetOrbitTags+ , firstNull = mayFirstBeNull+ , unStar = q } } PCarat dopa -> test (Test_BOL,dopa) PDollar dopa -> test (Test_EOL,dopa) PChar {} -> one@@ -424,33 +509,58 @@ -- down an Apply postTag. -- -- If the parent index is Nothing then this is part of a- -- non-capturing subtree and ignored.+ -- non-capturing subtree and ignored. This is a lazy and+ -- efficient alternative to rebuidling the tree with PGroup+ -- Nothing replacing PGroup (Just _).+ --+ -- Guarded by the getParentIndex /= Nothing check is the+ -- withParent command. PGroup Nothing p -> go p m1 m2 PGroup (Just this) p -> do mParent <- getParentIndex case mParent of- Nothing -> go p m1 m2+ Nothing -> go p m1 m2 -- just like PGrop Nothing p Just parent -> do- a <- if noTag m1 then uniq Minimize else return m1- b <- if isNothing (apply m2) then uniq Maximize else return m2- (q,resetTags) <- withParent this (go p a b)- makeGroup (GroupInfo this parent (fromHandleTag a) (fromHandleTag b))- return $ q { nullQ = addResetsToNullView resetTags (nullQ q)+ -- 'a' may be Advice or Apply from parent or Apply created here+ a <- if noTag m1 then uniq "PGroup start" else return m1+ b <- if noTag m2 then uniq "PGroup stop" else return m2+ flag <- ignore "PGroup ignore"+{-+ -- 'b' may be Apply from parent or Apply created here+ b <- if isNothing (apply m2) then uniq "PGroup" else return m2+-}+ (q,resetGroupTags) <- withParent this (go p a b) -- all immediate child groups stop tags get listened to.+ -- 2009: makeGroup performs a tell, why after withParent? I am no longer sure.+ makeGroup (GroupInfo this parent (fromHandleTag a) (fromHandleTag b) flag)+ return $ q { nullQ = addGroupResetsToNullView resetGroupTags flag (nullQ q) , tagged = True , childGroups = True- , preReset = resetTags `mappend` (preReset q) }+ , preReset = resetGroupTags `mappend` (preReset q)+ , postSet = (postSet q) `mappend` [flag]+ } -- A PNonCapture node in the Pattern tree does not become a -- node in the Q/P tree. It sets the parent to Nothing while -- processing the sub-tree. PNonCapture p -> nonCapture (go p m1 m2) + -- these are here for completeness of the case branches, currently starTrans replaces them all+ PPlus {} -> die+ PQuest {} -> die+ PBound {} -> die+ -- PNonEmpty is deprecated, and not produced in Pattern by starTrans anymore+ PNonEmpty {} -> die++{-+Similar to change in WinTags for QT/QNFA:+Change the NullView to use a tasktags instead of wintags since they are all PreUpdate+ -- PNonEmpty means the child pattern p can be skipped by -- bypassing the pattern. This is only used in the case p -- can accept 0 and can accept more than zero characters- -- (thus the assertions, enforcted by CorePattern.starTrans). The important thing about this case- -- is intercept the "accept 0" possibility and replace with- -- "skip".+ -- (thus the assertions, enforcted by CorePattern.starTrans).+ -- The important thing about this case is intercept the+ -- "accept 0" possibility and replace with "skip". PNonEmpty p -> mdo let needsTags = canAccept q a <- if noTag m1 && needsTags then uniq Minimize else return m1@@ -458,13 +568,33 @@ q <- go p (toAdvice a) (toAdvice b) when (not needsTags) (err $ "PNonEmpty could not accept characters: "++show (p,pOrig)) when (mustAccept q) (err $ "patternToQ : PNonEmpty provided with a *mustAccept* pattern: "++show (p,pOrig))- return $ Q (emptyNull (winTags (apply a) (apply b))) -- The magic of NonEmpty- (0,snd (takes q)) -- like Or- [] (apply a) (apply b) -- own the closing tag so it will not end a PGroup- needsTags (childGroups q) (wants q) -- the test case is "x" =~ "(.|$){1,3}"- (NonEmpty q)+ return $ Q { nullQ = emptyNull (preTags (apply a) (apply b)) -- The meaning of NonEmpty+ , takes = (0,snd (takes q)) -- like Or, drop lower bound to 0+ , preReset = []+ , preTag = apply a, postTag = apply b -- own the closing tag so it will not end a PGroup+ , tagged = needsTags+ , childGroups = childGroups q+ , wants = wants q -- the test case is "x" =~ "(.|$){1,3}"+ , unQ = NonEmpty q } - -- these are here for completeness of the case branches, currently starTrans replaces them all- PPlus {} -> die- PQuest {} -> die- PBound {} -> die+-}+{-+emptyNull :: TagList -> NullView+emptyNull tags = (mempty, tags) : []++testNull :: TestInfo -> TagList -> NullView+testNull (w,d) tags = (SetTestInfo (Map.singleton w (Set.singleton d)), tags) : []++-- Prepend tags to nullView+addTagsToNullView :: TagList -> NullView -> NullView+addTagsToNullView [] oldNV = oldNV+addTagsToNullView tags oldNV= do+ (oldTest,oldTags) <- oldNV+ return (oldTest,tags `mappend` oldTags)++-}+++-- xxx todo+-- +-- see of PNonEmpty -> NonEmpty -> TNFA is really smarter than POr about tags
− Text/Regex/TDFA/MutRun.hs
@@ -1,190 +0,0 @@--- | "Text.Regex.TDFA.Run" is the main module for matching a DFA--- against a String. Many of the associated functions are exported to--- other modules to help match against other types.------ 2009-January: logic changes to capturing in matchHere (need to change noCap XXX TODO):--- The logic below has been changed to recognize an empty match at the end of the string.--- The logic below has been changed to proceed after the first empty match.-module Text.Regex.TDFA.MutRun (findMatch,findMatchAll,countMatchAll) where--import Control.Monad(MonadPlus(..))-import Control.Monad.ST(ST)-import qualified Control.Monad.ST.Lazy as Lazy(ST,runST,strictToLazyST)-import Data.Array.IArray((!),array,bounds)-import Data.Array.MArray(rangeSize)-import qualified Data.IntMap.CharMap as Map(lookup,null)-import qualified Data.IntMap as IMap(null)-import Data.Maybe(isNothing)--import Text.Regex.Base(MatchArray,RegexOptions(..))-import Text.Regex.TDFA.Common-import Text.Regex.TDFA.TDFA(isDFAFrontAnchored)-import Text.Regex.TDFA.RunMutState(TagEngine(..),newTagEngine,tagsToGroupsST,newScratch,resetScratch,SScratch(..))-import Text.Regex.TDFA.Wrap()--- import Debug.Trace--{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}--{-# INLINE lazy #-}-lazy :: ST s a -> Lazy.ST s a-lazy = Lazy.strictToLazyST---- err :: String -> a--- err = common_error "Text.Regex.TDFA.MutRun"--{-# INLINE findMatch #-}-findMatch :: Regex -> String -> Maybe MatchArray-findMatch regexIn stringIn = case matchHere regexIn 0 '\n' stringIn of- [] -> Nothing- (ma:_) -> Just ma--{-# INLINE findMatchAll #-}-findMatchAll :: Regex -> String -> [MatchArray]-findMatchAll regexIn stringIn = matchHere regexIn 0 '\n' stringIn--{-# INLINE countMatchAll #-}-countMatchAll :: Regex -> String -> Int-countMatchAll regexIn stringIn = length (matchHere regex 0 '\n' stringIn) where- regex = setExecOpts (ExecOption {captureGroups = False,testMatch = False}) regexIn--{--There are four possible routines use by matchHere, depending on-whether it needs to collect submatch data and whether the pattern is-only permitted to start matching at offsetIn==0.--}-matchHere :: Regex -> Position -> Char -> String -> [MatchArray]-matchHere regexIn offsetIn prevIn inputIn = ans where- ans = if subCapture then runHerePure else noCap- where subCapture = captureGroups (regex_execOptions regexIn)- && (1<=rangeSize (bounds (regex_groups regexIn)))-- frontAnchored = (not (multiline (regex_compOptions regexIn)))- && isDFAFrontAnchored (regex_dfa regexIn)-- -- Select which style of ^ $ tests are performed.- test | multiline (regex_compOptions regexIn) = test_multiline- | otherwise = test_singleline- where test_multiline Test_BOL _off prev _input = prev == '\n'- test_multiline Test_EOL _off _prev input = case input of- [] -> True- (next:_) -> next == '\n'- test_singleline Test_BOL off _prev _input = off == 0- test_singleline Test_EOL _off _prev input = null input- - runHerePure :: [MatchArray]- runHerePure = Lazy.runST (do- TagEngine findTrans updateWinner performTrans <- lazy (newTagEngine regexIn)- let -- runHere :: Maybe (WScratch s,(Position,Char,String)) -> DT- -- -> MScratch s -> MScratch s- -- -> Position -> Char -> String- -- -> ST s (Maybe (WScratch s,(Position,Char,String)))- runHere winning dt s1 s2 off prev input = {-# SCC "runHere" #-}- s1 `seq` s2 `seq` off `seq` prev `seq` input `seq`- case dt of- Testing' {dt_test=wt,dt_a=a,dt_b=b} ->- if test wt off prev input- then runHere winning a s1 s2 off prev input- else runHere winning b s1 s2 off prev input- Simple' {dt_win=w, dt_trans=t, dt_other=o} -> do- case input of- [] -> updateWinner s1 (off,prev,input) winning w- (c:input') ->- case Map.lookup c t `mplus` o of- Nothing -> updateWinner s1 (off,prev,input) winning w- Just (dfa,trans) -> do- findTrans s1 off trans- winning' <- updateWinner s1 (off,prev,input) winning w- performTrans s1 s2 off trans- runHere winning' (d_dt dfa) s2 s1 (succ off) c input'- -- end of runHere- -- body of runHerePure continues- (SScratch s1 s2 w0) <- lazy (newScratch regexIn offsetIn)- let go off prev input = {-# SCC "runHerePure.go" #-}- off `seq` prev `seq` input `seq` do- answer <- lazy (runHere Nothing (d_dt (regex_dfa regexIn)) s1 s2 off prev input)- case answer of- Nothing -> case input of- [] -> return []- (prev':input') -> let off' = succ off- in do () <- lazy (resetScratch regexIn off' s1 w0)- go off' prev' input'- Just (w,(off',prev',input')) -> do- ma <- lazy (tagsToGroupsST (regex_groups regexIn) w)- let len = snd (ma!0)- rest <- if len==0- then case input' of- [] -> return []- (prev'':input'') -> do- let off'' = succ off'- () <- lazy (resetScratch regexIn off'' s1 w0)- go off'' prev'' input''- else do- () <- lazy (resetScratch regexIn off' s1 w0)- go off' prev' input'- return (ma:rest)- if frontAnchored- then if offsetIn/=0 then return [] - else do- answer <- lazy (runHere Nothing (d_dt (regex_dfa regexIn)) s1 s2 offsetIn prevIn inputIn)- case answer of- Nothing -> return []- Just (w,_) -> do- ma <- lazy (tagsToGroupsST (regex_groups regexIn) w)- return (ma:[])- else go offsetIn prevIn inputIn ) -- end Lazy.runST- -- end of runHerePure-- noCap = {-# SCC "noCap" #-}- let dtIn = (d_dt (regex_dfa regexIn))- go off prev input = off `seq` prev `seq` input `seq`- case runHereNoCap Nothing dtIn off prev input of- Nothing -> case input of- [] -> []- (prev':input') -> let off' = succ off- in go off' prev' input'- Just (off',prev',input') ->- let len = off'-off- ma = array (0,0) [(0,(off,len))]- rest = if len == 0- then case input' of- [] -> []- (prev'':input'') ->- let off'' = succ off'- in go off'' prev'' input''- else go off' prev' input'-{-- rest = if len == 0 || null input then []- else go off' prev' input'--}- in (ma:rest)- in if frontAnchored- then if offsetIn /= 0 then []- else case runHereNoCap Nothing dtIn offsetIn prevIn inputIn of- Nothing -> []- Just (off',_prev',_input') ->- let len = off'-offsetIn- ma = array (0,0) [(0,(offsetIn,len))]- in (ma:[])- else go offsetIn prevIn inputIn-- runHereNoCap winning dt off prev input = {-# SCC "runHereNoCap" #-}- off `seq` prev `seq` input `seq`- case dt of- Simple' {dt_win=w, dt_trans=t, dt_other=o} ->- let winning' = if IMap.null w then winning else Just (off,prev,input)- in seq winning' $- if Map.null t && isNothing o then winning' else- case input of- [] -> winning'- (c:input') ->- case Map.lookup c t `mplus` o of- Nothing -> winning'- Just (dfa,_) -> let dt' = d_dt dfa- off' = succ off- prev' = c- in seq off' $- runHereNoCap winning' dt' off' prev' input'- Testing' {dt_test=wt,dt_a=a,dt_b=b} ->- if test wt off prev input- then runHereNoCap winning a off prev input- else runHereNoCap winning b off prev input
− Text/Regex/TDFA/MutRunBS.hs
@@ -1,169 +0,0 @@--- | "Text.Regex.TDFA.Run" is the main module for matching a DFA--- against a String. Many of the associated functions are exported to--- other modules to help match against other types.-module Text.Regex.TDFA.MutRunBS (findMatch,findMatchAll,countMatchAll) where--import Control.Monad(MonadPlus(..))-import Control.Monad.ST(ST)-import qualified Control.Monad.ST.Lazy as Lazy(ST,runST,strictToLazyST)-import Data.Array.IArray((!),array,bounds)-import Data.Array.MArray(rangeSize)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Unsafe as B(unsafeIndex)-import Data.IntMap.CharMap(CharMap(..))-import qualified Data.IntMap as IMap(null,lookup)--import Text.Regex.Base(MatchArray,RegexOptions(..))-import Text.Regex.TDFA.Common-import Text.Regex.TDFA.TDFA(isDFAFrontAnchored)-import Text.Regex.TDFA.RunMutState(TagEngine(..),newTagEngine2,tagsToGroupsST,newScratch,resetScratch,SScratch(..))-import Text.Regex.TDFA.Wrap()--- import Debug.Trace--{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}--{-# INLINE lazy #-}-lazy :: ST s a -> Lazy.ST s a-lazy = Lazy.strictToLazyST--{-# INLINE index #-}-index :: B.ByteString -> Int -> Int-index input off = fromEnum (B.unsafeIndex input off)---- err :: String -> a--- err = common_error "Text.Regex.TDFA.MutRunBS"--{-# INLINE findMatch #-}-findMatch :: Regex -> B.ByteString -> Maybe MatchArray-findMatch regexIn inputIn = case matchHere regexIn 0 inputIn of- [] -> Nothing- (ma:_) -> Just ma--{-# INLINE findMatchAll #-}-findMatchAll :: Regex -> B.ByteString -> [MatchArray]-findMatchAll regexIn inputIn = matchHere regexIn 0 inputIn--{-# INLINE countMatchAll #-}-countMatchAll :: Regex -> B.ByteString -> Int-countMatchAll regexIn inputIn = length (matchHere regex 0 inputIn) where- regex = setExecOpts (ExecOption {captureGroups = False,testMatch = False}) regexIn--{--There are four possible routines use by matchHere, depending on-whether it needs to collect submatch data and whether the pattern is-only permitted to start matching at offsetIn==0.--}-matchHere :: Regex -> Position -> B.ByteString -> [MatchArray]-matchHere regexIn offsetIn inputIn = ans where- ans = if subCapture then runHerePure else noCap- where subCapture = captureGroups (regex_execOptions regexIn)- && (1<=rangeSize (bounds (regex_groups regexIn)))-- frontAnchored = (not (multiline (regex_compOptions regexIn)))- && isDFAFrontAnchored (regex_dfa regexIn)-- final = B.length inputIn-- test | multiline (regex_compOptions regexIn) = test_multiline- | otherwise = test_singleline- where test_multiline Test_BOL off = off == 0 || newline == index inputIn (pred off)- test_multiline Test_EOL off = off == final || newline == index inputIn off- test_singleline Test_BOL off = off == 0- test_singleline Test_EOL off = off == final- newline = fromEnum '\n'-- runHerePure :: [MatchArray]- runHerePure = Lazy.runST (do- TagEngine findTrans updateWinner performTrans <- lazy (newTagEngine2 regexIn)- let -- runHere :: Maybe (WScratch s,(Position,Char,String)) -> DT- -- -> MScratch s -> MScratch s- -- -> Position- -- -> ST s (Maybe (WScratch s,(Position,Char,String)))- runHere winning dt s1 s2 off = {-# SCC "runHere" #-}- s1 `seq` s2 `seq` off `seq`- case dt of- Testing' {dt_test=wt,dt_a=a,dt_b=b} ->- if test wt off- then runHere winning a s1 s2 off- else runHere winning b s1 s2 off- Simple' {dt_win=w, dt_trans=(CharMap t), dt_other=o} -> do- if off==final then updateWinner s1 off winning w else do- case IMap.lookup (index inputIn off) t `mplus` o of- Nothing -> updateWinner s1 off winning w- Just (dfa,trans) -> do- findTrans s1 off trans- winning' <- updateWinner s1 off winning w- performTrans s1 s2 off trans- runHere winning' (d_dt dfa) s2 s1 (succ off)- -- end of runHere- -- body of runHerePure continues- (SScratch s1 s2 w0) <- lazy (newScratch regexIn offsetIn)- let go off = {-# SCC "runHerePure.go" #-} off `seq` do- answer <- lazy (runHere Nothing (d_dt (regex_dfa regexIn)) s1 s2 off)- case answer of- Nothing -> if off==final -- no match starting past the last character- then return []- else do let off' = succ off- () <- lazy (resetScratch regexIn off' s1 w0)- go off'- Just (w,off') -> do- ma <- lazy (tagsToGroupsST (regex_groups regexIn) w)- let len = snd (ma!0)- rest <- if len==0- then if off'==final then return []- else do let off'' = succ off'- () <- lazy (resetScratch regexIn off'' s1 w0)- go off''- else do () <- lazy (resetScratch regexIn off' s1 w0)- go off'- return (ma:rest)- if frontAnchored- then if offsetIn/=0 then return [] - else do- answer <- lazy (runHere Nothing (d_dt (regex_dfa regexIn)) s1 s2 offsetIn)- case answer of- Nothing -> return []- Just (w,_) -> do- ma <- lazy (tagsToGroupsST (regex_groups regexIn) w)- return (ma:[])- else go offsetIn ) -- end Lazy.runST- -- end of runHerePure-- noCap = {-# SCC "noCap" #-}- let dtIn = (d_dt (regex_dfa regexIn))- go off =- case runHereNoCap Nothing dtIn off of- Nothing -> if off==final then [] else go (succ off)- Just off' ->- let len = off'-off- ma = array (0,0) [(0,(off,len))]- rest = if len==0- then if off'==final then []- else go (succ off')- else go off'- in (ma:rest)- in if frontAnchored- then if offsetIn /= 0 then []- else case runHereNoCap Nothing dtIn offsetIn of- Nothing -> []- Just off' ->- let len = off'-offsetIn- ma = array (0,0) [(0,(offsetIn,len))]- in (ma:[])- else go offsetIn-- runHereNoCap winning dt off = {-# SCC "runHereNoCap" #-}- off `seq`- case dt of- Simple' {dt_win=w, dt_trans=(CharMap t), dt_other=o} ->- let winning' = if IMap.null w then winning else Just off- in seq winning' $- if off==final then winning'- else case IMap.lookup (index inputIn off) t `mplus` o of- Nothing -> winning'- Just (DFA {d_dt=dt'},_) ->- runHereNoCap winning' dt' (succ off)- Testing' {dt_test=wt,dt_a=a,dt_b=b} ->- if test wt off- then runHereNoCap winning a off- else runHereNoCap winning b off
− Text/Regex/TDFA/MutRunLBS.hs
@@ -1,168 +0,0 @@--- | "Text.Regex.TDFA.Run" is the main module for matching a DFA--- against a String. Many of the associated functions are exported to--- other modules to help match against other types.-module Text.Regex.TDFA.MutRunLBS (findMatch,findMatchAll,countMatchAll) where--import Control.Monad(MonadPlus(..))-import Control.Monad.ST(ST)-import qualified Control.Monad.ST.Lazy as Lazy(ST,runST,strictToLazyST)-import Data.Array.IArray((!),array,bounds)-import Data.Array.MArray(rangeSize)-import qualified Data.ByteString.Lazy.Char8 as B-import Data.IntMap.CharMap(CharMap(..))-import qualified Data.IntMap as IMap(null,lookup)--import Text.Regex.Base(MatchArray,RegexOptions(..))-import Text.Regex.TDFA.Common-import Text.Regex.TDFA.TDFA(isDFAFrontAnchored)-import Text.Regex.TDFA.RunMutState(TagEngine(..),newTagEngine2,tagsToGroupsST,newScratch,resetScratch,SScratch(..))-import Text.Regex.TDFA.Wrap()--- import Debug.Trace--{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}--{-# INLINE lazy #-}-lazy :: ST s a -> Lazy.ST s a-lazy = Lazy.strictToLazyST--{-# INLINE index #-}-index :: B.ByteString -> Int -> Int-index input off = fromEnum (B.index input (toEnum off))---- err :: String -> a--- err = common_error "Text.Regex.TDFA.MutRunLBS"--{-# INLINE findMatch #-}-findMatch :: Regex -> B.ByteString -> Maybe MatchArray-findMatch regexIn inputIn = case matchHere regexIn 0 inputIn of- [] -> Nothing- (ma:_) -> Just ma--{-# INLINE findMatchAll #-}-findMatchAll :: Regex -> B.ByteString -> [MatchArray]-findMatchAll regexIn inputIn = matchHere regexIn 0 inputIn--{-# INLINE countMatchAll #-}-countMatchAll :: Regex -> B.ByteString -> Int-countMatchAll regexIn inputIn = length (matchHere regex 0 inputIn) where- regex = setExecOpts (ExecOption {captureGroups = False,testMatch = False}) regexIn--{--There are four possible routines use by matchHere, depending on-whether it needs to collect submatch data and whether the pattern is-only permitted to start matching at offsetIn==0.--}-matchHere :: Regex -> Position -> B.ByteString -> [MatchArray]-matchHere regexIn offsetIn inputIn = ans where- ans = if subCapture then runHerePure else noCap- where subCapture = captureGroups (regex_execOptions regexIn)- && (1<=rangeSize (bounds (regex_groups regexIn)))-- frontAnchored = (not (multiline (regex_compOptions regexIn)))- && isDFAFrontAnchored (regex_dfa regexIn)-- final = fromEnum (B.length inputIn)-- test | multiline (regex_compOptions regexIn) = test_multiline- | otherwise = test_singleline- where test_multiline Test_BOL off = off == 0 || newline == index inputIn (pred off)- test_multiline Test_EOL off = off == final || newline == index inputIn off- test_singleline Test_BOL off = off == 0- test_singleline Test_EOL off = off == final- newline = fromEnum '\n'-- runHerePure :: [MatchArray]- runHerePure = Lazy.runST (do- TagEngine findTrans updateWinner performTrans <- lazy (newTagEngine2 regexIn)- let -- runHere :: Maybe (WScratch s,(Position,Char,String)) -> DT- -- -> MScratch s -> MScratch s- -- -> Position- -- -> ST s (Maybe (WScratch s,(Position,Char,String)))- runHere winning dt s1 s2 off = {-# SCC "runHere" #-}- s1 `seq` s2 `seq` off `seq`- case dt of- Testing' {dt_test=wt,dt_a=a,dt_b=b} ->- if test wt off- then runHere winning a s1 s2 off- else runHere winning b s1 s2 off- Simple' {dt_win=w, dt_trans=(CharMap t), dt_other=o} -> do- if off==final then updateWinner s1 off winning w else do- case IMap.lookup (index inputIn off) t `mplus` o of- Nothing -> updateWinner s1 off winning w- Just (dfa,trans) -> do- findTrans s1 off trans- winning' <- updateWinner s1 off winning w- performTrans s1 s2 off trans- runHere winning' (d_dt dfa) s2 s1 (succ off)- -- end of runHere- -- body of runHerePure continues- (SScratch s1 s2 w0) <- lazy (newScratch regexIn offsetIn)- let go off = {-# SCC "runHerePure.go" #-} off `seq` do- answer <- lazy (runHere Nothing (d_dt (regex_dfa regexIn)) s1 s2 off)- case answer of- Nothing -> if off==final- then return []- else do let off' = succ off- () <- lazy (resetScratch regexIn off' s1 w0)- go off'- Just (w,off') -> do- ma <- lazy (tagsToGroupsST (regex_groups regexIn) w)- let len = snd (ma!0)- rest <- if len==0- then if off'==final then return []- else do let off'' = succ off'- () <- lazy (resetScratch regexIn off'' s1 w0)- go off''- else do () <- lazy (resetScratch regexIn off' s1 w0)- go off'- return (ma:rest)- if frontAnchored- then if offsetIn/=0 then return [] - else do- answer <- lazy (runHere Nothing (d_dt (regex_dfa regexIn)) s1 s2 offsetIn)- case answer of- Nothing -> return []- Just (w,_) -> do- ma <- lazy (tagsToGroupsST (regex_groups regexIn) w)- return (ma:[])- else go offsetIn ) -- end Lazy.runST- -- end of runHerePure-- noCap = {-# SCC "noCap" #-}- let dtIn = (d_dt (regex_dfa regexIn))- go off =- case runHereNoCap Nothing dtIn off of- Nothing -> if off==final then [] else go (succ off)- Just off' ->- let len = off'-off- ma = array (0,0) [(0,(off,len))]- rest = if len==0- then if off'==final then []- else go (succ off')- else go off'- in (ma:rest)- in if frontAnchored- then if offsetIn /= 0 then []- else case runHereNoCap Nothing dtIn offsetIn of- Nothing -> []- Just off' ->- let len = off'-offsetIn- ma = array (0,0) [(0,(offsetIn,len))]- in (ma:[])- else go offsetIn-- runHereNoCap winning dt off = {-# SCC "runHereNoCap" #-}- off `seq`- case dt of- Simple' {dt_win=w, dt_trans=(CharMap t), dt_other=o} ->- let winning' = if IMap.null w then winning else Just off- in seq winning' $- if off==final then winning'- else case IMap.lookup (index inputIn off) t `mplus` o of- Nothing -> winning'- Just (DFA {d_dt=dt'},_) ->- runHereNoCap winning' dt' (succ off)- Testing' {dt_test=wt,dt_a=a,dt_b=b} ->- if test wt off- then runHereNoCap winning a off- else runHereNoCap winning b off
− Text/Regex/TDFA/MutRunSeq.hs
@@ -1,184 +0,0 @@--- | "Text.Regex.TDFA.Run" is the main module for matching a DFA--- against a String. Many of the associated functions are exported to--- other modules to help match against other types.-module Text.Regex.TDFA.MutRunSeq (findMatch,findMatchAll,countMatchAll) where--import Control.Monad(MonadPlus(..))-import Control.Monad.ST(ST)-import qualified Control.Monad.ST.Lazy as Lazy(ST,runST,strictToLazyST)-import Data.Array.IArray((!),array,bounds)-import Data.Array.MArray(rangeSize)-import qualified Data.IntMap.CharMap as Map(lookup,null)-import qualified Data.IntMap as IMap(null)-import Data.Maybe(isNothing)-import Data.Sequence as S(Seq,ViewL(..))-import qualified Data.Sequence as S(viewl,null)--import Text.Regex.Base(MatchArray,RegexOptions(..))-import Text.Regex.TDFA.Common-import Text.Regex.TDFA.TDFA(isDFAFrontAnchored)-import Text.Regex.TDFA.RunMutState(TagEngine(..),newTagEngine,tagsToGroupsST,newScratch,resetScratch,SScratch(..))-import Text.Regex.TDFA.Wrap()--- import Debug.Trace--{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}--{-# INLINE lazy #-}-lazy :: ST s a -> Lazy.ST s a-lazy = Lazy.strictToLazyST---- err :: String -> a--- err = common_error "Text.Regex.TDFA.MutRunSeq"--{-# INLINE findMatch #-}-findMatch :: Regex -> Seq Char -> Maybe MatchArray-findMatch regexIn stringIn = case matchHere regexIn 0 '\n' stringIn of- [] -> Nothing- (ma:_) -> Just ma--{-# INLINE findMatchAll #-}-findMatchAll :: Regex -> Seq Char -> [MatchArray]-findMatchAll regexIn stringIn = matchHere regexIn 0 '\n' stringIn--{-# INLINE countMatchAll #-}-countMatchAll :: Regex -> Seq Char -> Int-countMatchAll regexIn stringIn = length (matchHere regex 0 '\n' stringIn) where- regex = setExecOpts (ExecOption {captureGroups = False,testMatch = False}) regexIn--{--There are four possible routines use by matchHere, depending on-whether it needs to collect submatch data and whether the pattern is-only permitted to start matching at offsetIn==0.--}-matchHere :: Regex -> Position -> Char -> Seq Char -> [MatchArray]-matchHere regexIn offsetIn prevIn inputIn = ans where- ans = if subCapture then runHerePure else noCap- where subCapture = captureGroups (regex_execOptions regexIn)- && (1<=rangeSize (bounds (regex_groups regexIn)))-- frontAnchored = (not (multiline (regex_compOptions regexIn)))- && isDFAFrontAnchored (regex_dfa regexIn)-- -- Select which style of ^ $ tests are performed.- test | multiline (regex_compOptions regexIn) = test_multiline- | otherwise = test_singleline- where test_multiline Test_BOL _off prev _input = prev == '\n'- test_multiline Test_EOL _off _prev input = case S.viewl input of- EmptyL -> True- (next :< _) -> next == '\n'- test_singleline Test_BOL off _prev _input = off == 0- test_singleline Test_EOL _off _prev input = S.null input- - runHerePure :: [MatchArray]- runHerePure = Lazy.runST (do- TagEngine findTrans updateWinner performTrans <- lazy (newTagEngine regexIn)- let -- runHere :: Maybe (WScratch s,(Position,Char,Seq Char)) -> DT- -- -> MScratch s -> MScratch s- -- -> Position -> Char -> Seq Char- -- -> ST s (Maybe (WScratch s,(Position,Char,Seq Char)))- runHere winning dt s1 s2 off prev input = {-# SCC "runHere" #-}- s1 `seq` s2 `seq` off `seq` prev `seq` input `seq`- case dt of- Testing' {dt_test=wt,dt_a=a,dt_b=b} ->- if test wt off prev input- then runHere winning a s1 s2 off prev input- else runHere winning b s1 s2 off prev input- Simple' {dt_win=w, dt_trans=t, dt_other=o} -> do- case S.viewl input of- EmptyL -> updateWinner s1 (off,prev,input) winning w- (c :< input') ->- case Map.lookup c t `mplus` o of- Nothing -> updateWinner s1 (off,prev,input) winning w- Just (dfa,trans) -> do- findTrans s1 off trans- winning' <- updateWinner s1 (off,prev,input) winning w- performTrans s1 s2 off trans- runHere winning' (d_dt dfa) s2 s1 (succ off) c input'- -- end of runHere- -- body of runHerePure continues- (SScratch s1 s2 w0) <- lazy (newScratch regexIn offsetIn)- let go off prev input = {-# SCC "runHerePure.go" #-}- off `seq` prev `seq` input `seq` do- answer <- lazy (runHere Nothing (d_dt (regex_dfa regexIn)) s1 s2 off prev input)- case answer of- Nothing -> case S.viewl input of- EmptyL -> return []- (prev' :< input') ->- let off' = succ off- in do () <- lazy (resetScratch regexIn off' s1 w0)- go off' prev' input'- Just (w,(off',prev',input')) -> do- ma <- lazy (tagsToGroupsST (regex_groups regexIn) w)- let len = snd (ma!0)- rest <- if len==0- then case S.viewl input of- EmptyL -> return []- (prev'' :< input'') -> do- let off'' = succ off'- () <- lazy (resetScratch regexIn off'' s1 w0)- go off'' prev'' input''- else do () <- lazy (resetScratch regexIn off' s1 w0)- go off' prev' input'- return (ma:rest)- if frontAnchored- then if offsetIn/=0 then return [] - else do- answer <- lazy (runHere Nothing (d_dt (regex_dfa regexIn)) s1 s2 offsetIn prevIn inputIn)- case answer of- Nothing -> return []- Just (w,_) -> do- ma <- lazy (tagsToGroupsST (regex_groups regexIn) w)- return (ma:[])- else go offsetIn prevIn inputIn ) -- end Lazy.runST- -- end of runHerePure-- noCap = {-# SCC "noCap" #-}- let dtIn = (d_dt (regex_dfa regexIn))- go off prev input = - case runHereNoCap Nothing dtIn off prev input of- Nothing -> case S.viewl input of- EmptyL -> []- (prev' :< input') -> let off' = succ off- in go off' prev' input'- Just (off',prev',input') ->- let len = off'-off- ma = array (0,0) [(0,(off,len))]- rest = if len==0- then case S.viewl input' of- EmptyL -> []- (prev'' :< input'') ->- let off'' = succ off'- in go off'' prev'' input''- else go off' prev' input'- in (ma:rest)- in if frontAnchored- then if offsetIn /= 0 then []- else case runHereNoCap Nothing dtIn offsetIn prevIn inputIn of- Nothing -> []- Just (off',_prev',_input') ->- let len = off'-offsetIn- ma = array (0,0) [(0,(offsetIn,len))]- in (ma:[])- else go offsetIn prevIn inputIn-- runHereNoCap winning dt off prev input = {-# SCC "runHereNoCap" #-}- off `seq` prev `seq` input `seq`- case dt of- Simple' {dt_win=w, dt_trans=t, dt_other=o} ->- let winning' = if IMap.null w then winning else Just (off,prev,input)- in seq winning' $- if Map.null t && isNothing o then winning' else- case S.viewl input of- EmptyL -> winning'- (c :< input') ->- case Map.lookup c t `mplus` o of- Nothing -> winning'- Just (dfa,_) -> let dt' = d_dt dfa- off' = succ off- prev' = c- in seq off' $- runHereNoCap winning' dt' off' prev' input'- Testing' {dt_test=wt,dt_a=a,dt_b=b} ->- if test wt off prev input- then runHereNoCap winning a off prev input- else runHereNoCap winning b off prev input
+ Text/Regex/TDFA/NewDFA.hs view
@@ -0,0 +1,884 @@+-- | This is the "rewrite" of RunMutState ++ MutRun. It is supposed+-- to never backtrack in the consumption of the input. This is more+-- complicated then RunMutState which only considered a single+-- starting offset, and MutRun which incremented the starting offset+-- by one with each failed match.+--+-- This is not optimized for speed.+module Text.Regex.TDFA.NewDFA(matchAll,matchOnce,matchCount,matchTest) where++import Control.Monad(when,forM,forM_,liftM2,foldM,join,MonadPlus(..),filterM)+import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..))+-- #ifdef __GLASGOW_HASKELL__+import GHC.Arr(STArray(..))+import GHC.ST(ST(..))+import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#)+{-+-- #else+import Control.Monad.ST(ST)+import Data.Array.ST(STArray)+-- #endif+-}+import Prelude hiding ((!!))++import Data.Array.MArray(MArray(..),unsafeFreeze,getAssocs)+import Data.Array.IArray(Array,bounds,assocs)+--import qualified Data.Foldable as F+import qualified Data.IntMap.CharMap2 as CMap(lookup)+import Data.IntMap(IntMap)+import qualified Data.IntMap as IMap(null,toList,lookup,insert)+import Data.Ix(Ix,rangeSize,range)+import Data.Maybe(catMaybes,listToMaybe)+import Data.Monoid(Monoid(..))+--import Data.IntSet(IntSet)+import qualified Data.IntSet as ISet(toAscList)+import qualified Data.Array.ST+import Data.Array.IArray((!))+import qualified Data.Array.MArray+import Data.List(partition,sort,foldl',sortBy,groupBy)+import Data.STRef+import qualified Control.Monad.ST.Lazy as L+import qualified Control.Monad.ST.Strict as S+import Data.Sequence(ViewL(..),viewl)+import qualified Data.Sequence as Seq++import Text.Regex.Base(MatchArray,MatchOffset,MatchLength)+import qualified Text.Regex.TDFA.IntArrTrieSet as Trie+import Text.Regex.TDFA.Common hiding (indent)+import Text.Regex.TDFA.TDFA(isDFAFrontAnchored)++--import Debug.Trace++-- trace :: String -> a -> a+-- trace _ a = a++err :: String -> a+err s = common_error "Text.Regex.TDFA.NewDFA" s++{-# INLINE (!!) #-}+(!!) :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> S.ST s e+(!!) = unsafeRead+{-# INLINE set #-}+set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s ()+set = unsafeWrite+ +matchAll :: Regex -> String -> [MatchArray]+matchAll r s = execMatch r 0 '\n' s++matchOnce :: Regex -> String -> Maybe MatchArray+matchOnce r s = listToMaybe (matchAll r s)++matchCount :: Regex -> String -> Int+matchCount regexIn stringIn = length (matchAll regexNC stringIn)+ where regexNC = regexIn { regex_execOptions = (regex_execOptions regexIn) {captureGroups = False} }++matchTest :: Regex -> String -> Bool+matchTest regexIn stringIn = not (null (matchAll regexNC stringIn))+ where regexNC = regexIn { regex_execOptions = (regex_execOptions regexIn) {captureGroups = False,testMatch = True} }++execMatch :: Regex -> Position -> Char -> String -> [MatchArray]+execMatch (Regex { regex_dfa = dfaIn+ , regex_init = startState+ , regex_b_index = b_index+ , regex_b_tags = b_tags_all+ , regex_trie = trie+ , regex_tags = aTags+ , regex_groups = aGroups+ , regex_compOptions = CompOption { multiline = newline }+ , regex_execOptions = ExecOption { captureGroups = capture+ , testMatch = _checkMatch }})+ offsetIn prevIn inputIn = L.runST runCaptureGroup where++{-+ msg = "subCapture "++show subCapture+ ++ ", frontAnchored "++show (frontAnchored,(not newline,isDFAFrontAnchored dfaIn))+ ++ ", b_index "++show b_index+ ++ ", b_tags "++show b_tags+ ++ ", orbitTags "++show orbitTags+-}++ subCapture,frontAnchored :: Bool+ !subCapture = capture && (1<=rangeSize (bounds aGroups))+ !frontAnchored = (not newline) && isDFAFrontAnchored dfaIn++ b_tags :: (Tag,Tag)+ !b_tags | subCapture = b_tags_all+ | otherwise = (0,1)++ orbitTags :: [Tag]+ !orbitTags = map fst . filter ((Orbit==).snd) . assocs $ aTags++ test :: WhichTest -> Index -> Char -> String -> Bool+ !test = mkTest newline ++ spawnStart :: (Tag,Tag) -> BlankScratch s -> Index -> MScratch s -> Position -> S.ST s Position+ spawnStart | frontAnchored = \ _ _ _ _ _ -> return maxBound+ | otherwise = spawnAt -- regardless of subCapture++ doActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s ()+ doActions | subCapture = doAllActions+ | otherwise = \ _ _ _ -> return ()++ doFinalActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s ()+ doFinalActions | subCapture = doAllActions+ | otherwise = do01Actions++ comp :: C s+ comp | subCapture = {-# SCC "matchHere.comp" #-} ditzyComp'3 aTags+ | otherwise = comp01++ tagsToGroupsST | subCapture = tagsToAllGroupsST+ | otherwise = tagsToGroup0ST++ runCaptureGroup :: L.ST s [MatchArray]+ runCaptureGroup = {-# SCC "runCaptureGroup" #-} do+ obtainNext <- L.strictToLazyST constructNewEngine+ let loop = do vals <- L.strictToLazyST obtainNext+ if null vals -- force vals before defining valsRest+ then return []+ else do valsRest <- loop+ return (vals ++ valsRest)+ loop++-- constructNewEngine :: forall s. S.ST s (S.ST s [MatchArray])+ constructNewEngine = {-# SCC "constructNewEngine" #-} do+ (SScratch s1In s2In restScratch@(_winQ,blank,_which)) <- newScratch b_index b_tags+ spawnAt b_tags blank startState s1In offsetIn+ storeNext <- newSTRef undefined+ writeSTRef storeNext (goNext storeNext restScratch s1In s2In dfaIn offsetIn prevIn inputIn)+ let obtainNext = join (readSTRef storeNext)+ return obtainNext++ goNext storeNext (winQ,blank,which) s1In' s2In' dfaIn' offsetIn' prevIn' inputIn' = {-# SCC "goNext" #-} do+ writeSTRef storeNext (err "obtainNext called while goNext is running!")+ eliminatedStateFlag <- newSTRef False+ eliminatedRespawnFlag <- newSTRef False+ let next s1 s2 did dt offset prev input = {-# SCC "goNext.next" #-}+ case dt of+ Testing' {dt_test=wt,dt_a=a,dt_b=b} ->+ if test wt offset prev input+ then next s1 s2 did a offset prev input+ else next s1 s2 did b offset prev input+ Simple' {dt_win=w} -> do+ if IMap.null w then proceedNow s1 s2 did dt offset prev input+ else newWinnerThenProceed s1 s2 did dt offset prev input++ proceedNow | frontAnchored = proceedNowSingle+ | otherwise = proceedNowMany++ proceedNowSingle s1 s2 did dt offset prev input = {-# SCC "goNext.proceedNowSingle" #-}+ case dt of+ Testing' {dt_test=wt,dt_a=a,dt_b=b} ->+ if test wt offset prev input+ then proceedNow s1 s2 did a offset prev input+ else proceedNow s1 s2 did b offset prev input+ Simple' {dt_trans=t, dt_other=o} ->+ case input of+ [] -> finalizeWinners+ (c:input') -> do+ case (CMap.lookup c t) `mplus` o of+ Nothing -> return []+ Just (Transition {trans_single=dfa',trans_how=dtrans}) ->+ findTrans s1 s2 (d_id dfa') (d_dt dfa') dtrans offset c input'++ proceedNowMany s1 s2 did dt offset prev input = {-# SCC "goNext.proceedNowMany" #-}+ case dt of+ Testing' {dt_test=wt,dt_a=a,dt_b=b} ->+ if test wt offset prev input+ then proceedNow s1 s2 did a offset prev input+ else proceedNow s1 s2 did b offset prev input+ Simple' {dt_trans=t, dt_other=o} ->+ case input of+ [] -> finalizeWinners+ (c:input') -> do+ case (CMap.lookup c t) `mplus` o of+ Nothing -> error "proceedNowMany found no destination (should always include startstate)"+ Just (Transition {trans_many=dfa',trans_how=dtrans}) ->+ findTrans s1 s2 (d_id dfa') (d_dt dfa') dtrans offset c input'++-- compressOrbits gets all the current Tag-0 start information from+-- the NFA states; then it loops through all the Orbit tags with+-- compressOrbit.+--+-- compressOrbit on such a Tag loops through all the NFS states'+-- m_orbit record, discardind ones that are Nothing and discarding+-- ones that are too new to care about (after the cutoff value).+--+-- compressOrbit then groups the Orbits records by the Tag-0 start+-- position and the basePos position. Entried in different groups+-- will never be comparable in the future so they can be processed+-- separately. Groups could probably be even more finely+-- distinguished, as a futher optimization, but the justification will+-- be tricky.+--+-- Current Tag-0 values are at most offset and all newly spawned+-- groups will have Tag-0 of at least (succ offset) so the current+-- groups are closed to those spawned in the future. The basePos may+-- be as large as offset and may be overwritten later with values of+-- offset or larger (and this will also involve deleting the Orbits+-- record). Thus there could be a future collision between a current+-- group with basePos==offset and an updated record that acquires+-- basePos==offset. By excluding groups with basePos before the+-- current offset the collision between existing and future records+-- is avoided.+--+-- An entry in a group can only collide with that group's+-- descendents. compressOrbit sends each group to the compressGroup+-- command.+--+-- compressGroup on a single record checks whether it's Seq can be+-- cleared and if so it will clear it (and set ordinal to Nothing but+-- this this not particularly important).+--+-- compressGroup on many records sorts and groups the members and zips+-- the groups with their new ordinal value. The comparision is based+-- on the old ordinal value, then the inOrbit value, and then the (Seq+-- Position) data.+--+-- The old ordinals of the group will all be Nothing or all be Just,+-- but this condition is neither checked nor violations detected.+-- This comparision is justified because once records get different+-- ordinals assigned they will never change places.+--+-- The inOrbit Bool is only different if one of them has set the stop+-- position to at most (succ offset). They will obly be compared if+-- the other one leaves, an its stop position will be at least offset.+-- The previous sentence is justified by inspectin of the "assemble"+-- function in the TDFA module: there is no (PostUpdate+-- LeaveOrbitTask) so the largest possible value for the stop Tag is+-- (pred offset). Thus the record with inOrbit==False would beat (be+-- GT than) the record with inOrbit==True.+--+-- The Seq comparison is safe because the largest existing Position+-- value is (pred offset) and the smallest future Position value is+-- offset. The previous sentence is justified by inspectin of the+-- "assemble" function in the TDFA module: there is no (PostUpdate+-- EnterOrbitTags) so the largest possible value in the Seq is (pred+-- offset).+--+-- The updated Orbits get the new ordinal value and an empty (Seq+-- Position).++ compressOrbits s1 did offset = do+ let getStart state = do start <- maybe (err "compressOrbit,1") (!! 0) =<< m_pos s1 !! state+ return (state,start)+ cutoff = offset - 50 -- Require: cutoff <= offset, MAGIC TUNABLE CONSTANT 50+ ss <- mapM getStart (ISet.toAscList did)+ let compressOrbit tag = do+ mos <- forM ss ( \ p@(state,_start) -> do+ mo <- fmap (IMap.lookup tag) (m_orbit s1 !! state)+ case mo of+ Just orbits | basePos orbits < cutoff -> return (Just (p,orbits))+ | otherwise -> return Nothing+ _ -> return Nothing )+ let compressGroup [((state,_),orbit)] | Seq.null (getOrbits orbit) = return ()+ | otherwise =+ set (m_orbit s1) state + . (IMap.insert tag $! (orbit { ordinal = Nothing, getOrbits = mempty}))+ =<< m_orbit s1 !! state++ compressGroup gs = do+ let sortPos (_,b1) (_,b2) = compare (ordinal b1) (ordinal b2) `mappend`+ compare (inOrbit b2) (inOrbit b1) `mappend`+ comparePos (viewl (getOrbits b1)) (viewl (getOrbits b2))+ groupPos (_,b1) (_,b2) = ordinal b1 == ordinal b2 && getOrbits b1 == getOrbits b2+ gs' = zip [(1::Int)..] (groupBy groupPos . sortBy sortPos $ gs)+ forM_ gs' $ \ (!n,eqs) -> do+ forM_ eqs $ \ ((state,_),orbit) ->+ set (m_orbit s1) state+ . (IMap.insert tag $! (orbit { ordinal = Just n, getOrbits = mempty }))+ =<< m_orbit s1 !! state+ let sorter ((_,a1),b1) ((_,a2),b2) = compare a1 a2 `mappend` compare (basePos b1) (basePos b2)+ grouper ((_,a1),b1) ((_,a2),b2) = a1==a2 && basePos b1 == basePos b2+ orbitGroups = groupBy grouper . sortBy sorter . catMaybes $ mos+ mapM_ compressGroup orbitGroups+ mapM_ compressOrbit orbitTags++-- findTrans has to (part 1) decide, for each destination, "which" of+-- zero or more source NFA states will be the chosen source. Then it+-- has to (part 2) perform the transition or spawn. It keeps track of+-- the starting index while doing so, and compares the earliest start+-- with the stored winners. (part 3) If some winners are ready to be+-- released then the future continuation of the search is placed in+-- "storeNext". If no winners are ready to be released then the+-- computation continues immediately.++ findTrans s1 s2 did' dt' dtrans offset prev' input' = {-# SCC "goNext.findTrans" #-} do+ -- findTrans part 0+ -- MAGIC TUNABLE CONSTANT 100 (and 100-1). TODO: (offset .&. 127 == 127) instead?+ when (not (null orbitTags) && (offset `rem` 100 == 99)) (compressOrbits s1 did' offset)+ -- findTrans part 1+ let findTransTo (destIndex,sources) | IMap.null sources =+ set which destIndex ((-1,Instructions { newPos = [(0,SetPost)], newOrbits = Nothing })+ ,blank_pos blank,mempty)+ | otherwise = do+ let prep (sourceIndex,(_dopa,instructions)) = {-# SCC "goNext.findTrans.prep" #-} do+{-+ ms1 <- showMS s1 sourceIndex+ let msg = unlines $ [ "findTrans prep: "++show (sourceIndex,destIndex) ++ " at offset "++show offset ++ "for d_id of "++show did'+ , ms1+ , show instructions+ ]+ trace msg $ do+-}+ pos <- maybe (err $ "findTrans,1 : "++show (sourceIndex,destIndex,did')) return+ =<< m_pos s1 !! sourceIndex+ orbit <- m_orbit s1 !! sourceIndex+ let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions)+ return ((sourceIndex,instructions),pos,orbit')+ challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.findTrans.challenge" #-} do+ check <- comp offset x1 (newPos ins1) x2 (newPos ins2)+{-+ ms1 <- showMS s1 _si1+ ms2 <- showMS s1 _si2+ let msg = unlines $ [ "findTrans challenge: "++show ((_si1,_si2),destIndex) ++ " at offset "++show offset ++ "for d_id of "++show did'+ , ms1+ , show ins1+ , show _o1+ , ms2+ , show ins2+ , show _o2+ , "Result "++show check+ ]+ trace msg $ do+-}+ if check==LT then return x2 else return x1+ (first:rest) <- mapM prep (IMap.toList sources)+ set which destIndex =<< foldM challenge first rest+ let dl = IMap.toList dtrans+ mapM_ findTransTo dl+ -- findTrans part 2+ let performTransTo (destIndex,_) = {-# SCC "goNext.findTrans.performTransTo" #-} do+ x@((sourceIndex,_instructions),_pos,_orbit') <- which !! destIndex+ if sourceIndex == (-1)+ then spawnStart b_tags blank destIndex s2 (succ offset)+ else updateCopy doActions x offset s2 destIndex+ earlyStart <- fmap minimum $ mapM performTransTo dl+ -- findTrans part 3+ earlyWin <- readSTRef (mq_earliest winQ)+ if earlyWin < earlyStart + then do+ winners <- fmap (foldl' (\ rest ws -> ws : rest) []) $+ getMQ earlyStart winQ+ writeSTRef storeNext (next s2 s1 did' dt' (succ offset) prev' input')+ mapM (tagsToGroupsST aGroups) winners+ else do+ let offset' = succ offset in seq offset' $ next s2 s1 did' dt' offset' prev' input'++-- The "newWinnerThenProceed" can find both a new non-empty winner and+-- a new empty winner. A new non-empty winner can cause some of the+-- NFA states that comprise the DFA state to be eliminated, and if the+-- startState is eliminated then it must then be respawned. And+-- imperative flag setting and resetting style is used.+--+-- A non-empty winner from the startState might obscure a potential+-- empty winner (form the startState at the current offset). This+-- winEmpty possibility is also checked for. (unit test pattern ".*")+-- (futher test "(.+|.+.)*" on "aa\n")++ newWinnerThenProceed s1 s2 did dt offset prev input = {-# SCC "goNext.newWinnerThenProceed" #-}+ case dt of+ Testing' {dt_test=wt,dt_a=a,dt_b=b} ->+ if test wt offset prev input+ then newWinnerThenProceed s1 s2 did a offset prev input+ else newWinnerThenProceed s1 s2 did b offset prev input+ Simple' {dt_win=w} -> do+ let prep x@(sourceIndex,instructions) = {-# SCC "goNext.newWinnerThenProceed.prep" #-} do+ pos <- maybe (err "newWinnerThenProceed,1") return =<< m_pos s1 !! sourceIndex+ startPos <- pos !! 0+ orbit <- m_orbit s1 !! sourceIndex+ let orbit' = maybe orbit (\ f -> f offset orbit) (newOrbits instructions)+ return (startPos,(x,pos,orbit'))+ challenge x1@((_si1,ins1),_p1,_o1) x2@((_si2,ins2),_p2,_o2) = {-# SCC "goNext.newWinnerThenProceed.challenge" #-} do+ check <- comp offset x1 (newPos ins1) x2 (newPos ins2)+{-+ ms1 <- showMS s1 _si1+ ms2 <- showMS s1 _si2+ let msg = unlines $ [ "newWinnerThenProceed challenge: "++show (_si1,_si2) ++ " at offset "++show offset+ , ms1+ , show ins1+ , show _o1+ , ms2+ , show ins2+ , show _o2+ , "Result "++show check+ ]+ trace msg $ do+-}+ if check==LT then return x2 else return x1+ prep'd <- mapM prep (IMap.toList w)+ let (emptyFalse,emptyTrue) = partition ((offset >) . fst) prep'd+ mayID <- {-# SCC "goNext.newWinnerThenProceed.mayID" #-}+ case map snd emptyFalse of+ [] -> return Nothing+ (first:rest) -> do+ best@((_sourceIndex,_instructions),bp,_orbit') <- foldM challenge first rest+ newWinner offset best+ startWin <- bp !! 0+ let states = ISet.toAscList did+ keepState i1 = do+ pos <- maybe (err "newWinnerThenProceed,2") return =<< m_pos s1 !! i1+ startsAt <- pos !! 0+ let keep = (startsAt <= startWin) || (offset <= startsAt)+ when (not keep) $ do+ writeSTRef eliminatedStateFlag True+ when (i1 == startState) (writeSTRef eliminatedRespawnFlag True)+ return keep+ states' <- filterM keepState states+ changed <- readSTRef eliminatedStateFlag+ if changed then return (Just states') else return Nothing+ case emptyTrue of+ [] -> case IMap.lookup startState w of+ Nothing -> return ()+ Just ins -> winEmpty offset ins+ [first] -> newWinner offset (snd first)+ _ -> err "newWinnerThenProceed,3 : too many emptyTrue values"+ case mayID of+ Nothing -> proceedNow s1 s2 did dt offset prev input+ Just states' -> do+ writeSTRef eliminatedStateFlag False+ respawn <- readSTRef eliminatedRespawnFlag+ if respawn+ then do+ writeSTRef eliminatedRespawnFlag False+ spawnStart b_tags blank startState s1 (succ offset)+ let dfa' = Trie.lookupAsc trie (sort (states'++[startState]))+ proceedNow s1 s2 (d_id dfa') (d_dt dfa') offset prev input+ else do+ let dfa' = Trie.lookupAsc trie states'+ proceedNow s1 s2 (d_id dfa') (d_dt dfa') offset prev input++ winEmpty preTag winInstructions = {-# SCC "goNext.winEmpty" #-} do+ newerPos <- newA_ b_tags+ copySTU (blank_pos blank) newerPos+ set newerPos 0 preTag+ doFinalActions preTag newerPos (newPos winInstructions)+ putMQ (WScratch newerPos) winQ+ + newWinner preTag ((_sourceIndex,winInstructions),oldPos,_newOrbit) = {-# SCC "goNext.newWinner" #-} do+ newerPos <- newA_ b_tags+ copySTU oldPos newerPos+ doFinalActions preTag newerPos (newPos winInstructions)+ putMQ (WScratch newerPos) winQ++ finalizeWinners = do+ winners <- fmap (foldl' (\ rest mqa -> mqa_ws mqa : rest) []) $+ readSTRef (mq_list winQ) -- reverses the winner list+ resetMQ winQ+ writeSTRef storeNext (return [])+ mapM (tagsToGroupsST aGroups) winners++ -- goNext then ends with the next statement+ next s1In' s2In' (d_id dfaIn') (d_dt dfaIn') offsetIn' prevIn' inputIn'++{-# INLINE do01Actions #-}+do01Actions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s ()+do01Actions preTag pos ins = doAllActions preTag pos (filter ((1>=) . fst) ins)++{-# INLINE doAllActions #-}+doAllActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s ()+doAllActions preTag pos ins = mapM_ doAction ins where+ postTag = succ preTag+ doAction (tag,SetPre) = set pos tag preTag+ doAction (tag,SetPost) = set pos tag postTag+ doAction (tag,SetVal v) = set pos tag v+++{-++Lets say that NFA states start at positions 0,1,2,3,4,5 and offset is 5.+Thus none are in the startState.+We are about to process the 6th character.+The first winner is now found, and it starts with the index 2 and ends at index 5 (always the offset).+In addition a null winner starting and ending at 5 is found (between 5th and 6th characters).+Lets also say that the 0,2,4 NFA states _may_ transition next to include the startState+position 0 -> keep (might win startState, which is okay)+position 1 -> keep (normal keep case)+position 2 -> keep (just created winner, may be extended)+position 3 -> drop (normal drop case)+position 4 -> drop (must not win startState)+position 5 -> keep (just created empty winner)++if "position 0" does feed a start state then a new one will be respawn, starting with "position 6".++-}++----++{-# INLINE mkTest #-}+mkTest :: Bool -> WhichTest -> Index -> Char -> String -> Bool+mkTest isMultiline = if isMultiline then test_multiline else test_singleline+ where test_multiline Test_BOL _off prev _input = prev == '\n'+ test_multiline Test_EOL _off _prev input = case input of+ [] -> True+ (next:_) -> next == '\n'+ test_singleline Test_BOL off _prev _input = off == 0+ test_singleline Test_EOL _off _prev input = null input++----++{- MUTABLE WINNER QUEUE -}++data MQA s = MQA {mqa_start :: !Position, mqa_ws :: !(WScratch s)}++data MQ s = MQ { mq_earliest :: !(STRef s Position)+ , mq_list :: !(STRef s [MQA s])+ }++newMQ :: S.ST s (MQ s)+newMQ = do+ earliest <- newSTRef maxBound+ list <- newSTRef []+ return (MQ earliest list)++resetMQ :: MQ s -> S.ST s ()+resetMQ (MQ {mq_earliest=earliest,mq_list=list}) = do+ writeSTRef earliest maxBound+ writeSTRef list []++putMQ :: WScratch s -> MQ s -> S.ST s ()+putMQ ws (MQ {mq_earliest=earliest,mq_list=list}) = do+{-+ sws <-s howWS ws+ let msg = "putMQ\n"++sws+ trace msg $ do+-}+ start <- w_pos ws !! 0+ let mqa = MQA start ws+ startE <- readSTRef earliest+ if start <= startE+ then writeSTRef earliest start >> writeSTRef list [mqa]+ else do+ old <- readSTRef list+ let !rest = dropWhile (\ m -> start <= mqa_start m) old + !new = mqa : rest+ writeSTRef list new++getMQ :: Position -> MQ s -> ST s [WScratch s]+getMQ pos (MQ {mq_earliest=earliest,mq_list=list}) = do+ old <- readSTRef list+ case span (\m -> pos <= mqa_start m) old of+ ([],ans) -> do+ writeSTRef earliest maxBound+ writeSTRef list []+ return (map mqa_ws ans)+ (new,ans) -> do+ writeSTRef earliest (mqa_start (last new))+ writeSTRef list new+ return (map mqa_ws ans)++{- MUTABLE SCRATCH DATA STRUCTURES -}++data SScratch s = SScratch { _s_1 :: !(MScratch s)+ , _s_2 :: !(MScratch s)+ , _s_rest :: !( MQ s+ , BlankScratch s+ , STArray s Index ((Index,Instructions),STUArray s Tag Position,OrbitLog)+ )+ }+data MScratch s = MScratch { m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position)))+ , m_orbit :: !(STArray s Index OrbitLog)+ }+newtype BlankScratch s = BlankScratch { blank_pos :: (STUArray s Tag Position)+ }+newtype WScratch s = WScratch { w_pos :: (STUArray s Tag Position)+ }++{- DEBUGGING HELPERS -}++{-+indent :: String -> String+indent xs = ' ':' ':xs++showMS :: MScratch s -> Index -> ST s String+showMS s i = do+ ma <- m_pos s !! i+ mc <- m_orbit s !! i+ a <- case ma of+ Nothing -> return "No pos"+ Just pos -> fmap show (getAssocs pos)+ let c = show mc+ return $ unlines [ "MScratch, index = "++show i+ , indent a+ , indent c]++showWS :: WScratch s -> ST s String+showWS (WScratch pos) = do+ a <- getAssocs pos+ return $ unlines [ "WScratch" + , indent (show a)]+-}+{- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -}++{-# INLINE newA #-}+newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> S.ST s (STUArray s Tag e)+newA b_tags initial = newArray b_tags initial++{-# INLINE newA_ #-}+newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> S.ST s (STUArray s Tag e)+newA_ b_tags = newArray_ b_tags++newScratch :: (Index,Index) -> (Tag,Tag) -> S.ST s (SScratch s)+newScratch b_index b_tags = do+ s1 <- newMScratch b_index+ s2 <- newMScratch b_index+ winQ <- newMQ+ blank <- fmap BlankScratch (newA b_tags (-1))+ which <- (newArray b_index ((-1,err "newScratch which 1"),err "newScratch which 2",err "newScratch which 3"))+ return (SScratch s1 s2 (winQ,blank,which))++newMScratch :: (Index,Index) -> S.ST s (MScratch s)+newMScratch b_index = do+ pos's <- newArray b_index Nothing+ orbit's <- newArray b_index mempty+ return (MScratch pos's orbit's)++{- COMPOSE A FUNCTION CLOSURE TO COMPARE TAG VALUES -}++newtype F s = F ([F s] -> C s)+type C s = Position+ -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)+ -> [(Int, Action)]+ -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)+ -> [(Int, Action)]+ -> ST s Ordering++{-# INLINE orderOf #-}+orderOf :: Action -> Action -> Ordering+orderOf post1 post2 =+ case (post1,post2) of+ (SetPre,SetPre) -> EQ+ (SetPost,SetPost) -> EQ+ (SetPre,SetPost) -> LT+ (SetPost,SetPre) -> GT+ (SetVal v1,SetVal v2) -> compare v1 v2+ _ -> err $ "bestTrans.compareWith.choose sees incomparable "++show (post1,post2)++comp01 :: C s+comp01 preTag (_state1,pos1,_orbit1') np1 (_state2,pos2,_orbit2') np2 = do+ c <- liftM2 compare (pos2!!0) (pos1!!0) -- reversed since Minimize+ case c of+ EQ -> challenge1+ answer -> return answer+ where+ challenge1 = do+ case np1 of+ ((t1,b1):_rest1) | t1==1 -> do+ let p1 = case b1 of SetPre -> preTag+ SetPost -> succ preTag+ SetVal v -> v+ case np2 of+ ((t2,b2):_rest2) | t2==1 -> do+ let p2 = case b2 of SetPre -> preTag+ SetPost -> succ preTag+ SetVal v -> v+ return (compare p1 p2)+ _ -> do+ p2 <- pos2 !! 1+ return (compare p1 p2)+ _ -> do+ p1 <- pos1 !! 1+ case np2 of+ ((t2,b2):_rest2) | t2==1 -> do+ let p2 = case b2 of SetPre -> preTag+ SetPost -> succ preTag+ SetVal v -> v+ return (compare p1 p2)+ _ -> do+ p2 <- pos2 !! 1+ return (compare p1 p2)++ditzyComp'3 :: forall s. Array Tag OP -> C s+ditzyComp'3 aTagOP = comp0 where+ (F comp1:compsRest) = allcomps 1++ comp0 :: C s+ comp0 preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 = do+ c <- liftM2 compare (pos2!!0) (pos1!!0) -- reversed since Minimize+ case c of+ EQ -> comp1 compsRest preTag x1 np1 x2 np2+ answer -> return answer++ allcomps :: Tag -> [F s]+ allcomps tag | tag > top = [F (\ _ _ _ _ _ _ -> return EQ)]+ | otherwise = + case aTagOP ! tag of+ Orbit -> F (challenge_Orb tag) : allcomps (succ tag)+ Maximize -> F (challenge_Max tag) : allcomps (succ tag)+ Ignore -> F (challenge_Ignore tag) : allcomps (succ tag)+ Minimize -> err "allcomps Minimize"+ where top = snd (bounds aTagOP)++ challenge_Ignore !tag (F next:comps) preTag x1 np1 x2 np2 =+ case np1 of+ ((t1,_):rest1) | t1==tag ->+ case np2 of+ ((t2,_):rest2) | t2==tag -> next comps preTag x1 rest1 x2 rest2+ _ -> next comps preTag x1 rest1 x2 np2+ _ -> do+ case np2 of+ ((t2,_):rest2) | t2==tag -> next comps preTag x1 np1 x2 rest2+ _ -> next comps preTag x1 np1 x2 np2+ challenge_Ignore _ [] _ _ _ _ _ = err "impossible 2347867"++ challenge_Max !tag (F next:comps) preTag x1@(_state1,pos1,_orbit1') np1 x2@(_state2,pos2,_orbit2') np2 =+ case np1 of+ ((t1,b1):rest1) | t1==tag ->+ case np2 of+ ((t2,b2):rest2) | t2==tag ->+ if b1==b2 then next comps preTag x1 rest1 x2 rest2+ else return (orderOf b1 b2)+ _ -> do+ p2 <- pos2 !! tag+ let p1 = case b1 of SetPre -> preTag+ SetPost -> succ preTag+ SetVal v -> v+ if p1==p2 then next comps preTag x1 rest1 x2 np2+ else return (compare p1 p2)+ _ -> do+ p1 <- pos1 !! tag+ case np2 of+ ((t2,b2):rest2) | t2==tag -> do+ let p2 = case b2 of SetPre -> preTag+ SetPost -> succ preTag+ SetVal v -> v+ if p1==p2 then next comps preTag x1 np1 x2 rest2+ else return (compare p1 p2)+ _ -> do+ p2 <- pos2 !! tag+ if p1==p2 then next comps preTag x1 np1 x2 np2+ else return (compare p1 p2)+ challenge_Max _ [] _ _ _ _ _ = err "impossible 9384324"++ challenge_Orb !tag (F next:comps) preTag x1@(_state1,_pos1,orbit1') np1 x2@(_state2,_pos2,orbit2') np2 = + let s1 = IMap.lookup tag orbit1'+ s2 = IMap.lookup tag orbit2'+ in case (s1,s2) of+ (Nothing,Nothing) -> next comps preTag x1 np1 x2 np2+ (Just o1,Just o2) | inOrbit o1 == inOrbit o2 ->+ case compare (ordinal o1) (ordinal o2) `mappend`+ comparePos (viewl (getOrbits o1)) (viewl (getOrbits o2)) of+ EQ -> next comps preTag x1 np1 x2 np2+ answer -> return answer+ _ -> err $ unlines [ "challenge_Orb is too stupid to handle mismatched orbit data :"+ , show(tag,preTag,np1,np2)+ , show s1+ , show s2+ ]+ challenge_Orb _ [] _ _ _ _ _ = err "impossible 0298347"++comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering+comparePos EmptyL EmptyL = EQ+comparePos EmptyL _ = GT+comparePos _ EmptyL = LT+comparePos (p1 :< ps1) (p2 :< ps2) = + compare p1 p2 `mappend` comparePos (viewl ps1) (viewl ps2)++{- CONVERT WINNERS TO MATCHARRAY -}++tagsToGroup0ST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray+tagsToGroup0ST _aGroups (WScratch {w_pos=pos})= do+ ma <- newArray (0,0) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength))+ startPos0 <- pos !! 0+ stopPos0 <- pos !! 1+ set ma 0 (startPos0,stopPos0-startPos0)+ unsafeFreeze ma++tagsToAllGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray+tagsToAllGroupsST aGroups (WScratch {w_pos=pos})= do+ let b_max = snd (bounds (aGroups))+ ma <- newArray (0,b_max) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength))+ startPos0 <- pos !! 0+ stopPos0 <- pos !! 1+ set ma 0 (startPos0,stopPos0-startPos0)+ let act _this_index [] = return ()+ act this_index ((GroupInfo _ parent start stop flagtag):gs) = do+ flagVal <- pos !! flagtag+ if (-1) == flagVal then act this_index gs+ else do+ startPos <- pos !! start+ stopPos <- pos !! stop+ (startParent,lengthParent) <- ma !! parent+ let ok = (0 <= startParent &&+ 0 <= lengthParent &&+ startParent <= startPos &&+ stopPos <= startPos + lengthParent)+ if not ok then act this_index gs+ else set ma this_index (startPos,stopPos-startPos)+ forM_ (range (1,b_max)) $ (\i -> act i (aGroups!i))+ unsafeFreeze ma++{- MUTABLE TAGGED TRANSITION (returning Tag-0 value) -}++{-# INLINE spawnAt #-}+-- Reset the entry at "Index", or allocate such an entry.+-- set tag 0 to the "Position"+spawnAt :: (Tag,Tag) -> BlankScratch s -> Index -> MScratch s -> Position -> S.ST s Position+spawnAt b_tags (BlankScratch blankPos) i s1 thisPos = do+ oldPos <- m_pos s1 !! i+ pos <- case oldPos of+ Nothing -> do+ pos' <- newA_ b_tags+ set (m_pos s1) i (Just pos')+ return pos'+ Just pos -> return pos+ copySTU blankPos pos+ set (m_orbit s1) i $! mempty+ set pos 0 thisPos+ return thisPos++{-# INLINE updateCopy #-}+updateCopy :: (Index -> STUArray s Tag Position -> [(Tag, Action)] -> ST s a)+ -> ((Index, Instructions), STUArray s Tag Position, OrbitLog)+ -> Index+ -> MScratch s+ -> Int+ -> ST s Position+updateCopy doActions ((_i1,instructions),oldPos,newOrbit) preTag s2 i2 = do+ b_tags <- getBounds oldPos+ newerPos <- maybe (do+ a <- newA_ b_tags+ set (m_pos s2) i2 (Just a)+ return a) return =<< m_pos s2 !! i2+ copySTU oldPos newerPos+ doActions preTag newerPos (newPos instructions)+ set (m_orbit s2) i2 $! newOrbit+ newerPos !! 0++{- USING memcpy TO COPY STUARRAY DATA -}++-- #ifdef __GLASGOW_HASKELL__+foreign import ccall unsafe "memcpy"+ memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO ()++{-+Prelude Data.Array.Base> :i STUArray+data STUArray s i e+ = STUArray !i !i !Int (GHC.Prim.MutableByteArray# s)+ -- Defined in Data.Array.Base+-}+-- This has been updated for ghc 6.8.3 and still works with ghc 6.10.1+{-# INLINE copySTU #-}+copySTU :: (Show i,Ix i,MArray (STUArray s) e (S.ST s)) => STUArray s i e -> STUArray s i e -> S.ST s (STUArray s i e)+copySTU _souce@(STUArray _ _ _ msource) destination@(STUArray _ _ _ mdest) =+-- do b1 <- getBounds s1+-- b2 <- getBounds s2+-- when (b1/=b2) (error ("\n\nWTF copySTU: "++show (b1,b2)))+ ST $ \s1# ->+ case sizeofMutableByteArray# msource of { n# ->+ case unsafeCoerce# memcpy mdest msource n# s1# of { (# s2#, () #) ->+ (# s2#, destination #) }}+{-+#else /* !__GLASGOW_HASKELL__ */++copySTU :: (MArray (STUArray s) e (S.ST s))=> STUArray s Tag e -> STUArray s Tag e -> S.ST s (STUArray s i e)+copySTU source destination = do+ b@(start,stop) <- getBounds source+ b' <- getBounds destination+ -- traceCopy ("> copySTArray "++show b) $ do+ when (b/=b') (fail $ "Text.Regex.TDFA.RunMutState copySTUArray bounds mismatch"++show (b,b'))+ forM_ (range b) $ \index ->+ set destination index =<< source !! index+ return destination+#endif /* !__GLASGOW_HASKELL__ */+-}
Text/Regex/TDFA/Pattern.hs view
@@ -30,13 +30,13 @@ -- This is consumed by the CorePattern module and the tender leaves -- are nibbled by the TNFA module. data Pattern = PEmpty- | PGroup (Maybe GroupIndex) Pattern -- Nothing to indicate non-matching PGroup- | POr [Pattern]- | PConcat [Pattern]- | PQuest Pattern- | PPlus Pattern+ | PGroup (Maybe GroupIndex) Pattern -- Nothing to indicate non-matching PGroup (Nothing never used!)+ | POr [Pattern] -- flattened by starTrans+ | PConcat [Pattern] -- flattened by starTrans+ | PQuest Pattern -- eliminated by starTrans+ | PPlus Pattern -- eliminated by starTrans | PStar Bool Pattern -- True means mayFirstBeNull is True- | PBound Int (Maybe Int) Pattern+ | PBound Int (Maybe Int) Pattern -- eliminated by starTrans -- The rest of these need an index of where in the regex string it is from | PCarat {getDoPa::DoPa} | PDollar {getDoPa::DoPa}@@ -44,11 +44,11 @@ | PDot {getDoPa::DoPa} -- Any character (newline?) at all | PAny {getDoPa::DoPa,getPatternSet::PatternSet} -- Square bracketed things | PAnyNot {getDoPa::DoPa,getPatternSet::PatternSet} -- Inverted square bracketed things- | PEscape {getDoPa::DoPa,getPatternChar::Char} -- Backslashed Character- | PChar {getDoPa::DoPa,getPatternChar::Char} -- Specific Character+ | PEscape {getDoPa::DoPa,getPatternChar::Char} -- Backslashed Character+ | PChar {getDoPa::DoPa,getPatternChar::Char} -- Specific Character -- The following are semantic tags created in starTrans, not the parser- | PNonCapture Pattern- | PNonEmpty Pattern+ | PNonCapture Pattern -- introduced by starTrans+ | PNonEmpty Pattern -- introduced by starTrans deriving (Eq,Show) -- | I have not been checking, but this should have the property that@@ -80,11 +80,13 @@ -- The following were not directly from the parser, and will not be parsed in properly PNonCapture p -> showPattern p PNonEmpty p -> showPattern p- where groupRange x n (y:ys) = if (fromEnum y)-(fromEnum x) == n then groupRange x (succ n) ys+ where {-+ groupRange x n (y:ys) = if (fromEnum y)-(fromEnum x) == n then groupRange x (succ n) ys else (if n <=3 then take n [x..] else x:'-':(toEnum (pred n+fromEnum x)):[]) ++ groupRange y 1 ys groupRange x n [] = if n <=3 then take n [x..] else x:'-':(toEnum (pred n+fromEnum x)):[]+-} paren s = ('(':s)++")" data PatternSet = PatternSet (Maybe (Set Char))@@ -129,10 +131,11 @@ -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- | Do the transformation and simplification in a single traversal.--- This removes the PPlus PQuest and PBound values for POr and PEmpty--- and PStar True/False. For some PBound values it creates PNonEmpty--- and PNonCapture. It also simplifies to flatten out nested POr and--- PConcat instances and elimiate some uneeded PEmpty values.+-- This removes the PPlus, PQuest, and PBound values, changing to POr+-- and PEmpty and PStar True/False. For some PBound values it adds+-- PNonEmpty and PNonCapture semantic marker. It also simplifies to+-- flatten out nested POr and PConcat instances and eliminate some+-- uneeded PEmpty values. starTrans :: Pattern -> Pattern starTrans = dfsPattern (simplify' . starTrans') @@ -166,7 +169,8 @@ {- The PStar should not capture 0 characters on its first iteration, so set its mayFirstBeNull flag to False -}- PPlus p -> asGroup $ PConcat [p,simplify' $ PStar False p]+ PPlus p | canOnlyMatchNull p -> p+ | otherwise -> asGroup $ PConcat [p,PStar False p] {- "An ERE matching a single character repeated by an '*' , '?' , or an interval expression shall not match a null expression unless@@ -174,22 +178,12 @@ satisfy the exact or minimum number of occurrences for the interval expression." -}--- Easy cases- PBound i _ _ | i<0 -> PEmpty -- malformed- PBound i (Just j) _ | i>j -> PEmpty -- malformed- PBound _ (Just 0) _ -> PEmpty- PBound 0 Nothing p -> PStar True p- PBound 0 (Just 1) p -> POr [p,PEmpty]--{- The iterations before the last required one cannot determine the- group capture so change the PGroups to False or wrap in PNonCapture.--}- PBound i Nothing p -> asGroup . PConcat $ apply (p':) (pred i) [p,simplify' $ PStar False p]- where p' = nonCapture' p -- XXX cleanup--{- p{0,2} is (pp?)? is p?p? and p{0,3} is (p(pp?)?)? is p?p?p?- p{1,2} is pp{0,1} is pp?- p{2,5} is ppp{0,3} is pp(p(pp?)?)? is ppp?p?p?+{- p? is p|PEmpty which prefers even a 0-character match for p+ p{0,1} is p? is POr [p,PEmpty]+ p{0,2} is (pp?)? NOT p?p?+ p{0,3} is (p(pp?)?)?+ p{1,2} is like pp{0,1} is like pp? but see below+ p{2,5} is ppp{0,3} is pp(p(pp?)?)? But this is not always right. Because if the second use of p in p?p? matches 0 characters then the perhaps non 0 character match of@@ -202,9 +196,13 @@ simplicity, only use ! when p can match 0 characters but not only 0 characters. - Call this (PNonEmpty p) in the Pattern type. Note that if p cannot- match 0 characters then p! is equivalent to p?- The p{0,1} is still always p?+ Call this (PNonEmpty p) in the Pattern type. + p! is PNonEmpty p is POr [PEmpty,p]+ IS THIS TRUE? Use QuickCheck?++ Note that if p cannot match 0 characters then p! is p? and vice versa++ The p{0,1} is still always p? and POr [p,PEmpty] Now p{0,2} means p?p! or (pp!)? and p{0,3} means (p(pp!)!)? or p?p!p! Equivalently p?p! and p?p!p! And p{2,2} is p'p and p{3,3} is p'p'p and p{4} is p'p'p'p@@ -223,71 +221,79 @@ if p can match 0 or non-zero characters then cases are p{0,0} is (), p{0,1} is (p)?, p{0,2} is (pp!)?, p{0,3} is (pp!p!)? p{1,1} is p, p{1,2} is pp!, p{1,3} is pp!p!, p{1,4} is pp!p!p!- p{2,2} is p'p, p{2,3} is p'pp!, p{2,4} is p'pp!p!, p{2,5} is p'pp!p!p!- p{3,3} is p'p'p, p{3,4} is p'p'pp!, p{3,5} is p'p'pp!p!+ p{2,2} is p'p, + p{2,3} is p'pp!, + p{2,4} is p'pp!p! or p'p(pp!)!+ p{2,5} is p'pp!p!p! or p'p(p(pp!)!)!+ p{3,3} is p'p'p, p{3,4} is p'p'pp!, p{3,5} is p'p'pp!p!, p{3,6} is p'p'pp!p!p! + if p can only match 1 or more characters then cases are+ p{0,0} is ()+ p{0,1} is p?, p{0,2} is (pp?)?, p{0,3} is (p(pp?)?)?, p{0,4} is (pp{0,3})?+ p{1,1} is p, p{1,j} is pp{0,pred j}+ p{2,2} is p'p, p{2,3} is p'pp?, p{2,4} is p'p(pp?)?, p{2,5} = p'p{1,4} = p'(pp{0,3})+ p{3,3} is p'p'p, p{3,4} is p'p'pp?, p{3,5} is p'p'p(pp?)?, p{3,6} is + And by this logic, the PStar False is really p*! So p{0,} is p* and p{1,} is pp*! and p{2,} is p'pp*! and p{3,} is p'p'pp*! -WTF BUG: but which is right? The last capture is "" if the (){,} is-itself put in parenthesis. So the simple solution is to wrap the-expanded PBound in a (PGroup Nothing).--/Test-str "ababcd" "(a|ab|c|bcd){0,10}(d*)"-TDFA ("","ababcd","",["bcd",""])-/Test-str "ababcd" "(a|ab|c|bcd){1,10}(d*)"-TDFA ("","ababcd","",["bcd",""])-/Test-str "ababcd" "(a|ab|c|bcd){2,10}(d*)"-TDFA ("","ababcd","",["c","d"])-/Test-str "ababcd" "(a|ab|c|bcd){3,10}(d*)"-TDFA ("","ababcd","",["c","d"])-./Test-str "ababcd" "(a|ab|c|bcd){4,10}(d*)"-TDFA ("ababcd","","",[])--./Test-str "ababcd" "(a|ab|c|bcd){0,}(d*)"-TDFA ("","ababcd","",["bcd",""])-./Test-str "ababcd" "(a|ab|c|bcd){1,}(d*)"-TDFA ("","ababcd","",["bcd",""])-./Test-str "ababcd" "(a|ab|c|bcd){2,}(d*)"-TDFA ("","ababcd","",["c","d"])-./Test-str "ababcd" "(a|ab|c|bcd){3,}(d*)"-TDFA ("","ababcd","",["c","d"])-./Test-str "ababcd" "(a|ab|c|bcd){4,}(d*)"-TDFA ("ababcd","","",[])--The two parsing are, explicity in my notation:--./Test-str "ababcd" "(a|ab|c|bcd)?(a|ab|c|bcd)?(a|ab|c|bcd)?(a|ab|c|bcd)?(d*)"-TDFA ("","ababcd","",["ab","ab","c","","d"])--In the next series is the issue with + The (nonEmpty' p) below is the only way PNonEmpty is introduced+ into the Pattern. It is always preceded by p inside a PConcat+ list. The p involved never simplifies to PEmpty. Thus it is+ impossible to have PNonEmpty directly nested, i.e. (PNonEmpty+ (PNonEmpty _)) never occurs even after simplifications. -./Test-str "ababcd" "((a|ab|c|bcd)((a|ab|c|bcd)((a|ab|c|bcd)(a|ab|c|bcd)?)?)?)?(d*)"-TDFA ("","ababcd","",["ababcd","ab","abcd","a","bcd","bcd","",""])-./Test-str "ababcd" "<(a|ab|c|bcd)<(a|ab|c|bcd)<(a|ab|c|bcd)(a|ab|c|bcd)?>?>?>?(d*)" -TDFA ("","ababcd","",["ab","a","bcd","",""])-./Test-str "ababcd" "(a|ab|c|bcd)((a|ab|c|bcd)((a|ab|c|bcd)((a|ab|c|bcd)(a|ab|c|bcd)?)?)?)?(d*)" -TDFA ("","ababcd","",["ab","abcd","a","bcd","bcd","","","",""])-./Test-str "ababcd" "(a|ab|c|bcd)(a|ab|c|bcd)((a|ab|c|bcd)((a|ab|c|bcd)((a|ab|c|bcd)(a|ab|c|bcd)?)?)?)?(d*)" -TDFA ("","ababcd","",["ab","ab","c","c","","","","","","d"])-./Test-str "ababcd" "(a|ab|c|bcd)(a|ab|c|bcd)(a|ab|c|bcd)((a|ab|c|bcd)((a|ab|c|bcd)((a|ab|c|bcd)(a|ab|c|bcd)?)?)?)?(d*)" -TDFA ("","ababcd","",["ab","ab","c","","","","","","","","d"])+ The (nonCapture' p) below is the only way PNonCapture is+ introduced into the Pattern. It is always followed by p inside a+ PConcat list. -}- PBound 0 (Just j) p | cannotMatchNull p -> apply (quest' . (concat' p)) (pred j) (quest' p)- | canOnlyMatchNull p -> quest' p- | otherwise -> POr [ simplify' (PConcat (p : replicate (pred j) (nonEmpty' p))) , PEmpty ]---- PBound i (Just j) p | i == j -> asGroup . PConcat $ apply (p':) (pred i) [p]- | cannotMatchNull p -> asGroup . PConcat $ apply (p':) (pred i) $ (p:) $ - [apply (quest' . (concat' p)) (pred (j-i)) (quest' p)]- | canOnlyMatchNull p -> p- | otherwise -> asGroup . PConcat $ (replicate (pred i) p') ++ p : (replicate (j-i) (nonEmpty' p))- where p' = nonCapture' p -- XXX cleanup+-- Easy cases+ PBound i _ _ | i<0 -> PEmpty -- impossibly malformed+ PBound i (Just j) _ | i>j -> PEmpty -- impossibly malformed+ PBound _ (Just 0) _ -> PEmpty+-- Medium cases+ PBound 0 Nothing p | canOnlyMatchNull p -> quest p+ | otherwise -> PStar True p+ PBound 0 (Just 1) p -> quest p+-- Hard cases+ PBound i Nothing p | canOnlyMatchNull p -> p+ | otherwise -> asGroup . PConcat $ apply (nc'p:) (pred i) [p,PStar False p]+ where nc'p = nonCapture' p+ PBound 0 (Just j) p | canOnlyMatchNull p -> quest p+ -- The first operation is quest NOT nonEmpty. This can be tested with+ -- "a\nb" "((^)?|b){0,3}" and "a\nb" "((^)|b){0,3}"+ | otherwise -> quest . (concat' p) $+ apply (nonEmpty' . (concat' p)) (j-2) (nonEmpty' p)+{- 0.99.6 remove+| cannotMatchNull p -> apply (quest' . (concat' p)) (pred j) (quest' p)+| otherwise -> POr [ simplify' (PConcat (p : replicate (pred j) (nonEmpty' p))) , PEmpty ]+-}+{- 0.99.6 add, 0.99.7 remove+ PBound i (Just j) p | canOnlyMatchNull p -> p+ | i == j -> PConcat $ apply (p':) (pred i) [p]+ | otherwise -> PConcat $ apply (p':) (pred i)+ [p,apply (nonEmpty' . (concat' p)) (j-i-1) (nonEmpty' p) ]+ where p' = nonCapture' p+-}+{- 0.99.7 add -}+ PBound i (Just j) p | canOnlyMatchNull p -> p+ | i == j -> asGroup . PConcat $ apply (nc'p:) (pred i) [p]+ | otherwise -> asGroup . PConcat $ apply (nc'p:) (pred i)+ [p,apply (nonEmpty' . (concat' p)) (j-i-1) (ne'p) ]+ where nc'p = nonCapture' p+ ne'p = nonEmpty' p+{- 0.99.6+| cannotMatchNull p -> PConcat $ apply (p':) (pred i) $ (p:) $+ [apply (quest' . (concat' p)) (pred (j-i)) (quest' p)]+| otherwise -> PConcat $ (replicate (pred i) p') ++ p : (replicate (j-i) (nonEmpty' p))+-}+ PStar mayFirstBeNull p | canOnlyMatchNull p -> if mayFirstBeNull then quest p+ else PEmpty+ | otherwise -> pass -- Left intact PEmpty -> pass PGroup {} -> pass- PStar {} -> pass POr {} -> pass PConcat {} -> pass PCarat {} -> pass@@ -298,18 +304,20 @@ PEscape {} -> pass PChar {} -> pass PNonCapture {} -> pass- PNonEmpty {} -> pass+ PNonEmpty {} -> pass -- TODO : remove PNonEmpty from program where- quest' = (\p -> simplify' $ POr [p,PEmpty]) -- require p to have been simplified+ quest = (\ p -> POr [p,PEmpty]) -- require p to have been simplified+-- quest' = (\ p -> simplify' $ POr [p,PEmpty]) -- require p to have been simplified concat' a b = simplify' $ PConcat [a,b] -- require a and b to have been simplified- nonEmpty' = PNonEmpty+ nonEmpty' = (\ p -> simplify' $ POr [PEmpty,p]) -- 2009-01-19 : this was PNonEmpty nonCapture' = PNonCapture- apply f n x = foldr ($) x (replicate n f)+ apply f n x = foldr ($) x (replicate n f) -- function f applied n times to x : f^n(x) asGroup p = PGroup Nothing (simplify' p) pass = pIn -- | Function to transform a pattern into an equivalent, but less--- redundant form. Nested 'POr' and 'PConcat' are flattened.+-- redundant form. Nested 'POr' and 'PConcat' are flattened. PEmpty+-- is propagated. simplify' :: Pattern -> Pattern simplify' x@(POr _) = let ps' = case span notPEmpty (flatten x) of@@ -326,6 +334,8 @@ [p] -> p _ -> PConcat ps' -- PConcat ps' simplify' (PStar _ PEmpty) = PEmpty+simplify' (PNonCapture PEmpty) = PEmpty -- 2009, perhaps useful+--simplify' (PNonEmpty PEmpty) = err "simplify' (PNonEmpty PEmpty) = should be Impossible!" -- 2009 simplify' other = other -- | Function to flatten nested POr or nested PConcat applicataions.@@ -342,6 +352,28 @@ notPEmpty PEmpty = False notPEmpty _ = True +-- | Determines if pIn will fail or accept [] and never accept any+-- characters. Treat PCarat and PDollar as True.+canOnlyMatchNull :: Pattern -> Bool+canOnlyMatchNull pIn =+ case pIn of+ PEmpty -> True+ PGroup _ p -> canOnlyMatchNull p+ POr ps -> all canOnlyMatchNull ps+ PConcat ps -> all canOnlyMatchNull ps+ PQuest p -> canOnlyMatchNull p+ PPlus p -> canOnlyMatchNull p+ PStar _ p -> canOnlyMatchNull p+ PBound _ (Just 0) _ -> True+ PBound _ _ p -> canOnlyMatchNull p+ PCarat _ -> True+ PDollar _ -> True+ PNonCapture p -> canOnlyMatchNull p+-- PNonEmpty p -> canOnlyMatchNull p -- like PQuest+ _ ->False++{-+ -- | If 'cannotMatchNull' returns 'True' then it is known that the -- 'Pattern' will never accept an empty string. If 'cannotMatchNull' -- returns 'False' then it is possible but not definite that the@@ -363,27 +395,6 @@ PCarat _ -> False PDollar _ -> False PNonCapture p -> cannotMatchNull p- PNonEmpty _ -> False -- like PQuest+-- PNonEmpty _ -> False -- like PQuest _ -> True---- | Determines if pIn will fail or accept [] and never accept any--- characters. Treat PCarat and PDollar as True.-canOnlyMatchNull :: Pattern -> Bool-canOnlyMatchNull pIn =- case pIn of- PEmpty -> True- PGroup _ p -> canOnlyMatchNull p- POr [] -> True- POr ps -> all canOnlyMatchNull ps- PConcat [] -> True- PConcat ps -> all canOnlyMatchNull ps- PQuest p -> canOnlyMatchNull p- PPlus p -> canOnlyMatchNull p- PStar _ p -> canOnlyMatchNull p- PBound _ (Just 0) _ -> True- PBound _ _ p -> canOnlyMatchNull p- PCarat _ -> True- PDollar _ -> True- PNonCapture p -> canOnlyMatchNull p- PNonEmpty p -> canOnlyMatchNull p -- like PQuest- _ ->False+-}
Text/Regex/TDFA/ReadRegex.hs view
@@ -1,7 +1,10 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -- | This is a POSIX version of parseRegex that allows NUL characters. -- Lazy/Possessive/Backrefs are not recognized. Anchors ^ and $ are--- not recognized.+-- recognized.+--+-- The PGroup returned always have (Maybe GroupIndex) set to (Just _)+-- and never to Nothing. module Text.Regex.TDFA.ReadRegex (parseRegex ,decodePatternSet ,legalCharacterClasses) where@@ -64,6 +67,9 @@ let lowI = read lowS highMI <- option (Just lowI) $ try $ do char ','+ -- parsec note: if 'many digits' fails below then the 'try' ensures+ -- that the ',' will not match the closing '}' in p_bound, same goes+ -- for any non '}' garbage after the 'many digits'. highS <- many digit if null highS then return Nothing -- no upper bound else do let highI = read highS@@ -89,12 +95,11 @@ p_left_brace = try $ (char '{' >> notFollowedBy digit >> char_index >>= return . (`PChar` '{')) p_escaped = char '\\' >> anyChar >>= \c -> char_index >>= return . (`PEscape` c) p_other_char = noneOf specials >>= \c -> char_index >>= return . (`PChar` c) - specials = "^.[$()|*+?{\\"+ where specials = "^.[$()|*+?{\\" -- parse [bar] and [^bar] sets of characters p_bracket = (char '[') >> ( (char '^' >> p_set True) <|> (p_set False) ) --- p_set does not support [.ch.] or [=y=] or [:foo:] -- p_set :: Bool -> GenParser Char st Pattern p_set invert = do initial <- (option "" ((char ']' >> return "]") <|> (char '-' >> return "-"))) values <- many1 p_set_elem
− Text/Regex/TDFA/RunMutState.hs
@@ -1,632 +0,0 @@-{-# LANGUAGE CPP #-}-module Text.Regex.TDFA.RunMutState(TagEngine(..),newTagEngine,newTagEngine2- ,newScratch,tagsToGroupsST- ,toInstructions,compareWith,resetScratch- ,SScratch(..),MScratch,WScratch) where--import Control.Monad(forM_,liftM,liftM2,liftM3,foldM)---import Control.Monad.ST.Strict as S (ST)---import qualified Control.Monad.ST.Lazy as L (ST)-import Control.Monad.State(MonadState(..),execState)--import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..))-#ifdef __GLASGOW_HASKELL__-import GHC.Arr(STArray(..))-import GHC.ST(ST(..))-import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#)-#else-import Control.Monad(when)-import Control.Monad.ST(ST)-import Data.Array.ST(STArray)-#endif--import Data.Array.MArray(MArray(..),newListArray,unsafeFreeze)-import Data.Array.IArray(Array,(!),bounds,assocs)--import Data.IntMap(IntMap)-import qualified Data.IntMap as IMap(null,toList,insert,insertWith,insertWithKey,delete,lookup,keys)-import Data.Ix(Ix(..))-import Data.Monoid(Monoid(..))-import Data.Sequence as S((|>),viewl,ViewL(..))-import Data.STRef(newSTRef,readSTRef,writeSTRef,STRef)--import Text.Regex.Base(MatchArray,MatchOffset,MatchLength)-import Text.Regex.TDFA.Common---- import Debug.Trace--{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}--err :: String -> a-err s = common_error "Text.Regex.TDFA.RunMutState" s--data TagEngine s t p = TagEngine- !(MScratch s -> Position -> IntMap (IntMap (t,Instructions)) -> ST s ())- !(MScratch s -> p -> Maybe (WScratch s,p) -> IntMap Instructions -> ST s (Maybe (WScratch s,p)))- !(MScratch s -> MScratch s -> Position -> IntMap (IntMap (DoPa,Instructions)) -> ST s ())--{-# INLINE newTagEngine #-}-newTagEngine :: Regex -> ST s (TagEngine s t (Position,Char,xxx))-newTagEngine regexIn = do- (which,count) <- newBoard regexIn- let comp = makeTagComparer (regex_tags regexIn)- let findTrans s1 off trans = {-# SCC "findTrans" #-} (mapM_ findTrans' (IMap.toList trans)) where- findTrans' (destIndex,sources) | IMap.null sources =- unsafeWrite which destIndex ((-1,undefined),undefined,undefined)- | otherwise = {-# SCC "findTrans'" #-} do- let (first:rest) = IMap.toList sources- {-# INLINE prep #-}- prep (sourceIndex,(_,instructions)) = {-# SCC "prep" #-} do- p <- maybe (error "findtrans") return =<< unsafeRead (m_pos s1) sourceIndex- o <- unsafeRead (m_orbit s1) sourceIndex- let o' = maybe o (\x -> x off o) (newOrbits instructions)- return ((sourceIndex,instructions),p,o')- challenge x1 y1 = {-# SCC "challenge" #-} do- x2 <- prep y1- check <- comp off x1 (newPos . snd . fst3 $ x1) x2 (newPos . snd . fst3 $ x2)- {-- debug1 <- getAssocs (snd3 x1)- debug2 <- getAssocs (snd3 x2)- () <- trace ("findTrans comp, pos="++show off'++", check="++show check- ++"\n"++show (debug1,fst3 x1,o1)- ++ "\n"++show (debug2,fst3 x2,o2)) (return ())- -}- if check==LT then return x2 else return x1- x1 <- prep first- x@((sourceIndex',_instructions'),_,_orbit') <- foldM challenge x1 rest- unsafeWrite which destIndex x -- (sourceIndex',instructions',orbit')- unsafeRead count sourceIndex' >>= (unsafeWrite count sourceIndex') . succ-- let {-# INLINE updateWinner #-}- updateWinner s1 (off,prev,input) winning sources | IMap.null sources = return winning- | otherwise = {-# SCC "updateWinner" #-} do- let (first:rest) = IMap.toList sources- {-# INLINE prep #-}- prep x@(sourceIndex,instructions) = do- p <- maybe (error "updateWinner") return =<< unsafeRead (m_pos s1) sourceIndex- o <- unsafeRead (m_orbit s1) sourceIndex- let o' = maybe o (\f -> f off o) (newOrbits instructions)- return (x,p,o')- challenge x1 y1 = do- x2 <- prep y1- check <- comp off x1 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x1)- x2 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x2)- {-- debug1 <- getAssocs (snd3 x1)- debug2 <- getAssocs (snd3 x2)- () <- trace ("updateWinner comp, pos="++show off++", check="++show check- ++"\n"++show (debug1,fst3 x1,thd3 x1)- ++ "\n"++show (debug2,fst3 x2,thd3 x2)) (return ())- -}- if check==LT then return x2 else return x1- x1 <- prep first- ((sourceIndex',instructions'),_,o') <- foldM challenge x1 rest- n <- unsafeRead count sourceIndex'- w <- updateWinning s1 (sourceIndex',instructions',o') off n (fmap fst winning)- return (Just (w,(off,prev,input)))-- let performTrans s1 s2 off dtrans | IMap.null dtrans = return ()- | otherwise = {-# SCC "performTrans" #-} do- mapM_ performTrans' (IMap.keys dtrans)- where performTrans' destIndex = {-# SCC "performTrans'" #-} do- i1@((sourceIndex,_instructions),_,_orbit) <- unsafeRead which destIndex- if sourceIndex == (-1) then return () else do- n <- unsafeRead count sourceIndex- unsafeWrite count sourceIndex (pred n)- if n==1 then updateSwap s1 i1 off s2 destIndex- else updateCopy s1 i1 off s2 destIndex--- findTrans :: forall s. ({-Dest-}Index,IntMap {-Source-} (DoPa,Instructions)) -> ST s ()--- updateWinner :: IntMap {- Source -} Instructions -> ST s (Maybe (WScratch s,(Position,Char,String)))--- performTrans :: IntMap {-Dest-} (IntMap {-Source-} (DoPa,Instructions)) -> ST s ()- return (TagEngine findTrans updateWinner performTrans)--{-# INLINE newTagEngine2 #-}-newTagEngine2 :: Regex -> ST s (TagEngine s t Position)-newTagEngine2 regexIn = do- (which,count) <- newBoard regexIn- let comp = makeTagComparer (regex_tags regexIn)- let findTrans s1 off trans = {-# SCC "findTrans" #-} (mapM_ findTrans' (IMap.toList trans)) where- findTrans' (destIndex,sources) | IMap.null sources =- unsafeWrite which destIndex ((-1,undefined),undefined,undefined)- | otherwise = {-# SCC "findTrans'" #-} do- let (first:rest) = IMap.toList sources- {-# INLINE prep #-}- prep (sourceIndex,(_,instructions)) = {-# SCC "prep" #-} do- p <- maybe (error "findtrans") return =<< unsafeRead (m_pos s1) sourceIndex- o <- unsafeRead (m_orbit s1) sourceIndex- let o' = maybe o (\x -> x off o) (newOrbits instructions)- return ((sourceIndex,instructions),p,o')- challenge x1 y1 = {-# SCC "challenge" #-} do- x2 <- prep y1- check <- comp off x1 (newPos . snd . fst3 $ x1) x2 (newPos . snd . fst3 $ x2)- {-- debug1 <- getAssocs (snd3 x1)- debug2 <- getAssocs (snd3 x2)- () <- trace ("findTrans comp, pos="++show off'++", check="++show check- ++"\n"++show (debug1,fst3 x1,o1)- ++ "\n"++show (debug2,fst3 x2,o2)) (return ())- -}- if check==LT then return x2 else return x1- x1 <- prep first- x@((sourceIndex',_instructions'),_,_orbit') <- foldM challenge x1 rest- unsafeWrite which destIndex x -- (sourceIndex',instructions',orbit')- unsafeRead count sourceIndex' >>= (unsafeWrite count sourceIndex') . succ-- let {-# INLINE updateWinner #-}- updateWinner s1 off winning sources | IMap.null sources = return winning- | otherwise = {-# SCC "updateWinner" #-} do- let (first:rest) = IMap.toList sources- {-# INLINE prep #-}- prep x@(sourceIndex,instructions) = do- p <- maybe (error "updateWinner") return =<< unsafeRead (m_pos s1) sourceIndex- o <- unsafeRead (m_orbit s1) sourceIndex- let o' = maybe o (\f -> f off o) (newOrbits instructions)- return (x,p,o')- challenge x1 y1 = do- x2 <- prep y1- check <- comp off x1 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x1)- x2 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x2)- {-- debug1 <- getAssocs (snd3 x1)- debug2 <- getAssocs (snd3 x2)- () <- trace ("updateWinner comp, pos="++show off++", check="++show check- ++"\n"++show (debug1,fst3 x1,thd3 x1)- ++ "\n"++show (debug2,fst3 x2,thd3 x2)) (return ())- -}- if check==LT then return x2 else return x1- x1 <- prep first- ((sourceIndex',instructions'),_,o') <- foldM challenge x1 rest- n <- unsafeRead count sourceIndex'- w <- updateWinning s1 (sourceIndex',instructions',o') off n (fmap fst winning)- return (Just (w,off))-- let performTrans s1 s2 off dtrans | IMap.null dtrans = return ()- | otherwise = {-# SCC "performTrans" #-} do- mapM_ performTrans' (IMap.keys dtrans)- where performTrans' destIndex = {-# SCC "performTrans'" #-} do- i1@((sourceIndex,_instructions),_,_orbit) <- unsafeRead which destIndex- if sourceIndex == (-1) then return () else do- n <- unsafeRead count sourceIndex- unsafeWrite count sourceIndex (pred n)- if n==1 then updateSwap s1 i1 off s2 destIndex- else updateCopy s1 i1 off s2 destIndex--- findTrans :: forall s. ({-Dest-}Index,IntMap {-Source-} (DoPa,Instructions)) -> ST s ()--- updateWinner :: IntMap {- Source -} Instructions -> ST s (Maybe (WScratch s,(Position,Char,String)))--- performTrans :: IntMap {-Dest-} (IntMap {-Source-} (DoPa,Instructions)) -> ST s ()- return (TagEngine findTrans updateWinner performTrans)---- XXX change first element type to store winning orbit' and such?-newBoard :: Regex -> ST s (STArray s Index ((Index,Instructions),a,OrbitLog)- ,STUArray s Index Int)-newBoard regexIn = do- let bWhich = (0,regex_init regexIn) -- (-1) index is winning state- bCount = (0,regex_init regexIn)- liftM2 (,) (newListArray bWhich (replicate (rangeSize bWhich) ((-1,undefined),undefined,undefined)))- (newArray bCount 0)--{--newA' :: (MArray (STArray s) e (ST s)) => (Tag,Tag) -> e -> ST s (STArray s Tag e)-newA' b_tags initial = -- traceNew ("> newA' "++show b_tags) $- newArray b_tags initial--newA'_ :: (MArray (STArray s) e (ST s)) => (Tag,Tag) -> ST s (STArray s Tag e)-newA'_ b_tags = -- traceNew ("> newA'_ "++show b_tags) $- newArray_ b_tags--}--newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> ST s (STUArray s Tag e)-newA b_tags initial = -- traceNew ("> newA "++show b_tags) $- newArray b_tags initial--newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> ST s (STUArray s Tag e)-newA_ b_tags = -- traceNew ("> newA_ "++show b_tags) $- newArray_ b_tags--data MScratch s = MScratch { m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position)))- , m_flag :: !(STArray s Index (Maybe (STUArray s Tag Bool)))- , m_orbit :: !(STArray s Index OrbitLog) -- Fixed!- }-data SScratch s= SScratch { s_1 :: !(MScratch s)- , s_2 :: !(MScratch s) -- XXX- , w_blank :: !(WScratch s)- }-data WScratch s = WScratch { w_pos :: !(STRef s (STUArray s Tag Position))- , w_flag :: !(STRef s (STUArray s Tag Bool))- , w_orbit :: !(STRef s OrbitLog)- }--newWScratch :: (Tag,Tag) -> ST s (WScratch s)-newWScratch b_tags = liftM3 WScratch (newSTRef =<< newA b_tags (-1))- (newSTRef =<< newA b_tags False)- (newSTRef mempty)--newWScratch_ :: (Tag,Tag) -> ST s (WScratch s)-newWScratch_ b_tags = liftM3 WScratch (newSTRef =<< newA_ b_tags)- (newSTRef =<< newA_ b_tags)- (newSTRef mempty)--resetScratch :: Regex -> Position -> MScratch s -> WScratch s -> ST s ()-resetScratch regexIn startPos s1 w0 = do- let i = regex_init regexIn- b_tags = bounds (regex_tags regexIn)-- oldPos <- unsafeRead (m_pos s1) i- initialPos <- case oldPos of- Nothing -> newA b_tags (-1)- Just pos -> do blank <- readSTRef (w_pos w0)- copySTU blank pos- return pos- unsafeWrite initialPos 0 startPos- unsafeWrite (m_pos s1) i (Just initialPos)-- oldFlags <- unsafeRead (m_flag s1) i- initFlags <- case oldFlags of- Nothing -> newA b_tags False- Just flags -> do- blank <- readSTRef (w_flag w0)- copySTU blank flags- return flags- unsafeWrite initFlags 0 True- unsafeWrite (m_flag s1) i (Just initFlags)-- unsafeWrite (m_orbit s1) i mempty--newScratch :: Regex -> Position -> ST s (SScratch s)-newScratch regexIn startPos = do- let i = regex_init regexIn- b_index = (0,i)- b_tags = bounds (regex_tags regexIn)--- trace ("\n> newScratch: "++show (b_index,b_tags,i,startPos)) $ do- s@(SScratch {s_1=s1,w_blank=w0}) <- newSScratch b_index b_tags- resetScratch regexIn startPos s1 w0- return s--newSScratch :: (Index, Index) -> (Tag, Tag) -> ST s (SScratch s)-newSScratch b_index b_tags = do- s1 <- newMScratch b_index- s2 <- newMScratch b_index- w0 <- newWScratch b_tags- return (SScratch s1 s2 w0)--newMScratch :: (Index,Index) -> ST s (MScratch s)-newMScratch b_index = do- let n = rangeSize b_index- pos <- newListArray b_index (replicate n Nothing)- flag <- newListArray b_index (replicate n Nothing)- orbit <- newListArray b_index (replicate n mempty)- return (MScratch pos flag orbit)--{-# INLINE copyUpdateTags #-}-copyUpdateTags :: (MArray (STUArray s) Position (ST s))- => STUArray s Tag Position -- source- -> [(Tag,Bool)] -- updates- -> Position -> Position- -> STUArray s Tag Position -- destination- -> (ST s) ()-copyUpdateTags a1 changes pFalse pTrue a2 = do- copySTU a1 a2- mapM_ (\(tag,v) -> if v then unsafeWrite a2 tag pTrue- else unsafeWrite a2 tag pFalse) changes--{-# INLINE copyUpdateFlags #-}-copyUpdateFlags :: (MArray (STUArray s) Bool (ST s))- => STUArray s Tag Bool -- source- -> [(Tag,Bool)] -- updates- -> STUArray s Tag Bool -- destination- -> (ST s) ()-copyUpdateFlags a1 changes a2 = do- copySTU a1 a2- mapM_ (\(tag,v) -> unsafeWrite a2 tag v) changes--{-# INLINE updateWinning #-}-updateWinning :: MScratch s -- source - -> ({-Source -} Index,Instructions,OrbitLog)- -> Position- -> Int- -> Maybe (WScratch s) -- destination- -> ST s (WScratch s)-updateWinning s1 (i1,ins,o) preTag n mw = do- (Just pos1) <- unsafeRead (m_pos s1) i1- (Just flag1) <- unsafeRead (m_flag s1) i1- let val x = if x then postTag else preTag- postTag = succ preTag- if n==0- then do- -- new change with 0.97.3: clear these 3 fields as we are stealing the allocated data!- unsafeWrite (m_pos s1) i1 Nothing- unsafeWrite (m_flag s1) i1 Nothing- unsafeWrite (m_orbit s1) i1 mempty- mapM_ (\(tag,v) -> unsafeWrite pos1 tag (val v)) (newPos ins)- mapM_ (\(tag,f) -> unsafeWrite flag1 tag (f)) (newFlags ins)- case mw of- Nothing -> liftM3 WScratch (newSTRef pos1) (newSTRef flag1) (newSTRef o)- Just w -> do writeSTRef (w_pos w) pos1- writeSTRef (w_flag w) flag1- writeSTRef (w_orbit w) o- return w- else do- w <- case mw of- Nothing -> getBounds pos1 >>= newWScratch_- Just w -> return w- pos2 <- readSTRef (w_pos w)- flag2 <- readSTRef (w_flag w)- copyUpdateTags pos1 (newPos ins) preTag postTag pos2- copyUpdateFlags flag1 (newFlags ins) flag2- writeSTRef (w_orbit w) o- return w--{-# INLINE updateSwap #-}-updateSwap :: MScratch s -- source - -> (({-Source -} Index,Instructions),STUArray s Tag Position,OrbitLog)- -> Position- -> MScratch s -> Index -- destination- -> ST s ()-updateSwap s1 ((i1,ins),_,o) preTag s2 i2 = do- -- obtain source- pos1'@(Just pos1) <- unsafeRead (m_pos s1) i1- flag1'@(Just flag1) <- unsafeRead (m_flag s1) i1- -- preserve allocated storage in detination rather than cycle through GC- unsafeWrite (m_pos s1) i1 =<< unsafeRead (m_pos s2) i2- unsafeWrite (m_flag s1) i1 =<< unsafeRead (m_flag s2) i2- -- put source in destination- unsafeWrite (m_pos s2) i2 pos1'- unsafeWrite (m_flag s2) i2 flag1'- unsafeWrite (m_orbit s2) i2 o --- XXX ???- let val x = if x then postTag else preTag where postTag = succ preTag- mapM_ (\(tag,v) -> unsafeWrite pos1 tag (val v)) (newPos ins)- mapM_ (\(tag,f) -> unsafeWrite flag1 tag (f)) (newFlags ins)--{-# INLINE updateCopy #-}-updateCopy :: MScratch s -- source - -> (({-Source -} Index,Instructions),STUArray s Tag Position,OrbitLog)- -> Position- -> MScratch s -> Index -- destination- -> ST s ()-updateCopy s1 ((i1,ins),_,o) preTag s2 i2 = do- pos1 <- maybe (err $ "forceUpdate : m_pos s1 is Nothing" ++ show (i1,ins,preTag)) return =<< unsafeRead (m_pos s1) i1- flag1 <- maybe (err $ "forceUpdate : m_flag s1 is Nothing" ++ show (i1,ins,preTag)) return =<< unsafeRead (m_flag s1) i1- b_tags <- getBounds pos1- pos2 <- maybe (do a <- newA_ b_tags- unsafeWrite (m_pos s2) i2 (Just a)- return a) return =<< unsafeRead (m_pos s2) i2- flag2 <- maybe (do a <- newA_ b_tags- unsafeWrite (m_flag s2) i2 (Just a)- return a) return =<< unsafeRead (m_flag s2) i2- copyUpdateTags pos1 (newPos ins) preTag (succ preTag) pos2- copyUpdateFlags flag1 (newFlags ins) flag2- unsafeWrite (m_orbit s2) i2 o--makeTagComparer :: Array Tag OP- -> Position- -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)- -> [(Int, Bool)]- -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)- -> [(Int, Bool)]- -> ST s Ordering-makeTagComparer aTagOP = foldr ($) end (map chooseBranch- (dropWhile ((1>=).fst)- (assocs aTagOP)))- where chooseBranch (tag,Maximize) = challenge_Max tag- chooseBranch (tag,Minimize) = challenge_Min tag- chooseBranch (tag,Orbit) = challenge_Orb tag- end _ _ _ _ _ = return EQ-- challenge_Orb tag next preTag x1@(_state1,_,orbit1') np1 x2@(_state2,_,orbit2') np2 = - let s1 = IMap.lookup tag orbit1'- s2 = IMap.lookup tag orbit2'- in case (s1,s2) of- (Nothing,Nothing) -> next preTag x1 np1 x2 np2- (Just o1,Just o2) | inOrbit o1 == inOrbit o2 ->- case comparePos (viewl (getOrbits o1)) (viewl (getOrbits o2)) of- EQ -> next preTag x1 np1 x2 np2- answer -> return answer- _ -> err $ "challenge_Orb is too stupid to handle mismatched orbit data :"- ++ show(tag,preTag,np1,np2)- where comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering- comparePos EmptyL EmptyL = EQ- comparePos EmptyL _ = GT- comparePos _ EmptyL = LT- comparePos (p1 :< ps1) (p2 :< ps2) = - compare p1 p2 `mappend` comparePos (viewl ps1) (viewl ps2)- -- -- challenge_pos takes the current winner and a challenger, each with instructions.- -- But the orbits are already modified.- challenge_Max tag next preTag x1@(_state1,pos1,_) np1 x2@(_state2,pos2,_) np2 = do- (np1',p1) <- case np1 of- ((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)- _ -> liftM ((,) np1) (unsafeRead pos1 tag)- (np2',p2) <- case np2 of- ((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)- _ -> liftM ((,) np2) (unsafeRead pos2 tag)- case (p1,p2) of- (-1,-1) -> next preTag x1 np1' x2 np2'- (_ ,-1) -> return GT- (-1, _) -> return LT- _ -> let answer = compare p1 p2- in if answer == EQ then next preTag x1 np1' x2 np2'- else return answer-- -- challenge_pos takes the current winner and a challenger, each with instructions.- -- But the orbits are already modified.- challenge_Min tag next preTag x1@(_state1,pos1,_) np1 x2@(_state2,pos2,_) np2 = do- (np1',p1) <- case np1 of- ((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)- _ -> liftM ((,) np1) (unsafeRead pos1 tag)- (np2',p2) <- case np2 of- ((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)- _ -> liftM ((,) np2) (unsafeRead pos2 tag)- case (p1,p2) of- (-1,-1) -> next preTag x1 np1' x2 np2'- (_ ,-1) -> return LT- (-1, _) -> return GT- _ -> let answer = compare p2 p1- in if answer == EQ then next preTag x1 np1' x2 np2'- else return answer--compareWith :: (Ord x,Monoid a) => (Maybe (x,b) -> Maybe (x,c) -> a) -> [(x,b)] -> [(x,c)] -> a-compareWith comp = cw where- cw [] [] = comp Nothing Nothing- cw xx@(x:xs) yy@(y:ys) =- case compare (fst x) (fst y) of- GT -> comp Nothing (Just y) `mappend` cw xx ys- EQ -> comp (Just x) (Just y) `mappend` cw xs ys- LT -> comp (Just x) Nothing `mappend` cw xs yy- cw xx [] = foldr (\x rest -> comp (Just x) Nothing `mappend` rest) mempty xx- cw [] yy = foldr (\y rest -> comp Nothing (Just y) `mappend` rest) mempty yy--------------------------modifyPos :: Bool -> Tag -> CompileInstructions ()-modifyPos todo tag = do- (a,b,c) <- get- let a' = IMap.insert tag todo a- b' = IMap.insert tag True b- put (a',b',c)--setPreTag :: Tag -> CompileInstructions ()-setPreTag = modifyPos False--setPostTag :: Tag -> CompileInstructions ()-setPostTag = modifyPos True--resetTag :: Tag -> CompileInstructions ()-resetTag tag = do- (a,b,c) <- get- let b' = IMap.insert tag False b- put (a,b',c)--modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()-modifyOrbit f = do- (a,b,c) <- get- let c' = f c- put (a,b,c')--modifyFlagOrbit :: Tag -> Bool -> (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()-modifyFlagOrbit tag flag f = do- (a,b,c) <- get- let b' = IMap.insert tag flag b- c' = f c- put (a,b',c')--resetOrbit :: Tag -> CompileInstructions ()-resetOrbit tag = modifyFlagOrbit tag False (IMap.insert tag AlterReset)--leaveOrbit :: Tag -> CompileInstructions ()-leaveOrbit tag = modifyOrbit escapeOrbit where- escapeOrbit = IMap.insertWith setInOrbitFalse tag AlterLeave where- setInOrbitFalse _ x@(AlterModify {}) = x {newInOrbit = False}- setInOrbitFalse _ x = x--enterOrbit :: Tag -> CompileInstructions ()-enterOrbit tag = modifyFlagOrbit tag True changeOrbit where- changeOrbit = IMap.insertWith overwriteOrbit tag appendNewOrbit-- appendNewOrbit = AlterModify {newInOrbit = True, freshOrbit = False} -- try to append- startNewOrbit = AlterModify {newInOrbit = True, freshOrbit = True} -- will start a new series-- overwriteOrbit _ AlterReset = startNewOrbit- overwriteOrbit _ AlterLeave = startNewOrbit- overwriteOrbit _ (AlterModify {newInOrbit = False}) = startNewOrbit- overwriteOrbit _ (AlterModify {newInOrbit = True}) =- err $ "enterOrbit: Cannot enterOrbit twice in a row: " ++ show tag--alterOrbits :: [(Tag,AlterOrbit)] -> (Position -> OrbitTransformer)-alterOrbits x = let items = map alterOrbit x- in (\pos m -> foldl (flip ($)) m (map ($ pos) items))--alterOrbit :: (Tag,AlterOrbit) -> (Position -> OrbitTransformer)-alterOrbit (tag,AlterModify {newInOrbit = inOrbit',freshOrbit = True}) =- (\_ m -> IMap.insert tag (Orbits {inOrbit = inOrbit', getOrbits = mempty}) m)-alterOrbit (tag,AlterModify {newInOrbit = inOrbit',freshOrbit = False}) =- (\pos m -> IMap.insertWithKey (updateOrbit pos) tag newOrbit m) where- newOrbit = Orbits {inOrbit = inOrbit', getOrbits = mempty}- updateOrbit pos _tag new old =- let answer = case old of- Orbits True prev -> Orbits {inOrbit = inOrbit', getOrbits = prev |> pos }- Orbits False _ -> new- in answer-alterOrbit (tag,AlterReset) = (\_ m -> IMap.delete tag m)-alterOrbit (tag,AlterLeave) = (\_ m -> - let old = IMap.lookup tag m- answer = case old of- Nothing -> m- Just x -> IMap.insert tag (escapeOrbit x) m- in answer)- where escapeOrbit x = x {inOrbit = False}--assemble :: TagList -> CompileInstructions ()-assemble spec = sequence_ . map helper $ spec where- helper (tag,command) =- case command of- PreUpdate TagTask -> setPreTag tag- PreUpdate ResetGroupStopTask -> resetTag tag- PreUpdate ResetOrbitTask -> resetOrbit tag- PreUpdate EnterOrbitTask -> enterOrbit tag- PreUpdate LeaveOrbitTask -> leaveOrbit tag- PostUpdate TagTask -> setPostTag tag- PostUpdate ResetGroupStopTask -> resetTag tag- _ -> err ("assemble : Weird orbit command: "++show (tag,spec))--toInstructions :: TagList -> Instructions-toInstructions spec =- let todo = assemble spec- initalState = (mempty,mempty,mempty)- (a,b,c) = execState todo initalState- in Instructions {newPos = IMap.toList a- ,newFlags = IMap.toList b- ,newOrbits = if IMap.null c then Nothing else Just $ alterOrbits (IMap.toList c)}--tagsToGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> ST s MatchArray-tagsToGroupsST aGroups (WScratch {w_pos=pRef,w_flag=fRef})= do- let b_max = snd (bounds (aGroups))- ma <- newArray (0,b_max) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength))- p <- readSTRef pRef- f <- readSTRef fRef- startPos0 <- unsafeRead p 0- stopPos0 <- unsafeRead p 1- unsafeWrite ma 0 (startPos0,stopPos0-startPos0)- let act _this_index [] = return ()- act this_index ((GroupInfo _ parent start stop):gs) = do- flagVal <- unsafeRead f stop- if not flagVal then act this_index gs- else do- startPos <- unsafeRead p start- stopPos <- unsafeRead p stop- (startParent,lengthParent) <- unsafeRead ma parent- let ok = (0 <= startParent &&- 0 <= lengthParent &&- startParent <= startPos &&- stopPos <= startPos + lengthParent)- if not ok then act this_index gs- else unsafeWrite ma this_index (startPos,stopPos-startPos)- forM_ (range (1,b_max)) $ (\i -> act i (aGroups!i))- unsafeFreeze ma--#ifdef __GLASGOW_HASKELL__-foreign import ccall unsafe "memcpy"- memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO ()---- This has been updated for ghc 6.8.3-{-# INLINE copySTU #-}-copySTU :: (Show i,Ix i,MArray (STUArray s) e (ST s)) => STUArray s i e -> STUArray s i e -> ST s ()-copySTU (STUArray _ _ _ msource) (STUArray _ _ _ mdest) =--- do b1 <- getBounds s1--- b2 <- getBounds s2--- when (b1/=b2) (error ("\n\nWTF copySTU: "++show (b1,b2)))- ST $ \s1# ->- case sizeofMutableByteArray# msource of { n# ->- case unsafeCoerce# memcpy mdest msource n# s1# of { (# s2#, () #) ->- (# s2#, () #) }}--#else /* !__GLASGOW_HASKELL__ */--copySTU :: (MArray (STUArray s) e (ST s))=> STUArray s Tag e -> STUArray s Tag e -> ST s ()-copySTU source destination = do- b@(start,stop) <- getBounds source- b' <- getBounds destination- -- traceCopy ("> copySTArray "++show b) $ do- when (b/=b') (fail $ "Text.Regex.TDFA.RunMutState copySTUArray bounds mismatch"++show (b,b'))- forM_ (range b) $ \index ->- unsafeRead source index >>= unsafeWrite destination index-#endif /* !__GLASGOW_HASKELL__ */
Text/Regex/TDFA/Sequence.hs view
@@ -23,10 +23,10 @@ import Text.Regex.Base(MatchArray,RegexContext(..),RegexMaker(..),RegexLike(..)) import Text.Regex.Base.Impl(polymatch,polymatchM) import Text.Regex.TDFA.String() -- piggyback on RegexMaker for String-import Text.Regex.TDFA.TDFA(patternToDFA)-import Text.Regex.TDFA.MutRunSeq(findMatch,findMatchAll,countMatchAll)+import Text.Regex.TDFA.TDFA(patternToRegex) import Text.Regex.TDFA.Wrap(Regex(..),CompOption,ExecOption) import Text.Regex.TDFA.ReadRegex(parseRegex)+import qualified Data.Foldable as F(toList) {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} @@ -38,12 +38,19 @@ makeRegexOptsM c e source = either fail return $ compile c e source instance RegexLike Regex (S.Seq Char) where- matchOnce = findMatch- matchAll = findMatchAll- matchCount = countMatchAll--- matchTest--- matchOnceText--- matchTextAll+ matchOnce r = matchOnce r . F.toList+ matchAll r = matchAll r . F.toList+ matchCount r = matchCount r . F.toList+ matchTest r = matchTest r . F.toList+ matchOnceText regex source = + fmap (\ma -> let (o,l) = ma!0+ in (S.take o source+ ,fmap (\ol@(off,len) -> (S.take len (S.drop off source),ol)) ma+ ,S.drop (o+l) source))+ (matchOnce regex source)+ matchAllText regex source =+ map (fmap (\ol@(off,len) -> (S.take len (S.drop off source),ol)))+ (matchAll regex source) {-# INLINE toList #-} toList :: S.Seq Char -> [Char]@@ -58,9 +65,7 @@ compile compOpt execOpt bs = case parseRegex (toList bs) of Left err -> Left ("parseRegex for Text.Regex.TDFA.ByteString failed:"++show err)- Right pattern ->- let (dfa,i,tags,groups) = patternToDFA compOpt pattern- in Right (Regex dfa i tags groups compOpt execOpt)+ Right pattern -> Right (patternToRegex pattern compOpt execOpt) execute :: Regex -- ^ Compiled regular expression -> (S.Seq Char) -- ^ ByteString to match against
Text/Regex/TDFA/String.hs view
@@ -24,9 +24,9 @@ import Text.Regex.Base.Impl(polymatch,polymatchM) import Text.Regex.Base.RegexLike(RegexMaker(..),RegexLike(..),RegexContext(..),MatchOffset,MatchLength,MatchArray) import Text.Regex.TDFA.Common(common_error)+import qualified Text.Regex.TDFA.NewDFA as N(matchAll,matchOnce,matchCount,matchTest) import Text.Regex.TDFA.ReadRegex(parseRegex)-import Text.Regex.TDFA.MutRun(findMatch,findMatchAll,countMatchAll)-import Text.Regex.TDFA.TDFA(patternToDFA)+import Text.Regex.TDFA.TDFA(patternToRegex) import Text.Regex.TDFA.Wrap(Regex(..),CompOption,ExecOption) {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}@@ -45,9 +45,7 @@ compile compOpt execOpt source = case parseRegex source of Left msg -> Left ("parseRegex for Text.Regex.TDFA.String failed:"++show msg)- Right pattern ->- let (dfa,i,tags,groups) = patternToDFA compOpt pattern- in Right (Regex dfa i tags groups compOpt execOpt)+ Right pattern -> Right (patternToRegex pattern compOpt execOpt) instance RegexMaker Regex CompOption ExecOption String where makeRegexOpts c e source = unwrap (compile c e source)@@ -56,7 +54,7 @@ execute :: Regex -- ^ Compiled regular expression -> String -- ^ String to match against -> Either String (Maybe MatchArray)-execute r s = Right (matchOnce r s)+execute r s = Right (N.matchOnce r s) regexec :: Regex -- ^ Compiled regular expression -> String -- ^ String to match against@@ -71,10 +69,10 @@ -- Minimal defintion for now instance RegexLike Regex String where- matchOnce = findMatch- matchAll = findMatchAll- matchCount = countMatchAll--- matchTest+ matchOnce = N.matchOnce+ matchAll = N.matchAll+ matchCount = N.matchCount+ matchTest = N.matchTest -- matchOnceText -- matchTextAll
Text/Regex/TDFA/TDFA.hs view
@@ -2,31 +2,33 @@ -- A DFA state corresponds to a Set of QNFA states, repesented as list -- of Index which are used to lookup the DFA state in a lazy Trie -- which holds all possible subsets of QNFA states.-module Text.Regex.TDFA.TDFA(patternToDFA,DFA(..),DT(..)- ,examineDFA,isDFAFrontAnchored- ,nfaToDFA,dfaMap) where+module Text.Regex.TDFA.TDFA(patternToRegex,DFA(..),DT(..)+ ,examineDFA,isDFAFrontAnchored+ ,nfaToDFA,dfaMap) where --import Control.Arrow((***)) import Control.Monad.Instances() import Control.Monad.RWS-import Data.Array.IArray(Array,(!),bounds)+import Control.Monad.State(State,MonadState(..),execState)+import Data.Array.IArray(Array,(!),bounds,{-assocs-}) import Data.IntMap(IntMap)-import qualified Data.IntSet as ISet(empty,singleton,null)+import qualified Data.IntMap as IMap+import Data.IntMap.CharMap2(CharMap(..))+import qualified Data.IntMap.CharMap2 as Map(empty)+--import Data.IntSet(IntSet)+import qualified Data.IntSet as ISet import Data.List(foldl')-import Data.IntMap.CharMap(CharMap(..))-import qualified Data.IntMap.CharMap as Map(empty)-import qualified Data.IntMap as IMap(empty,null,singleton,keys,union- ,unionWith,elems,toList,toAscList,fromDistinctAscList) import qualified Data.Map (Map,empty,member,insert,elems) import Data.Maybe(isJust)+import Data.Sequence as S((|>),{-viewl,ViewL(..)-}) import Text.Regex.TDFA.Common import Text.Regex.TDFA.IntArrTrieSet(TrieSet) import qualified Text.Regex.TDFA.IntArrTrieSet as Trie(lookupAsc,fromSinglesMerge) import Text.Regex.TDFA.Pattern(Pattern)-import Text.Regex.TDFA.RunMutState(compareWith,toInstructions)+--import Text.Regex.TDFA.RunMutState(toInstructions) import Text.Regex.TDFA.TNFA(patternToNFA)--- import Debug.Trace+--import Debug.Trace {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} @@ -51,16 +53,39 @@ makeDFA :: SetIndex -> DT -> DFA makeDFA i dt = DFA i dt --- Note that no CompOption parameter is needed.+-- Note that no CompOption or ExecOption parameter is needed. nfaToDFA :: ((Index,Array Index QNFA),Array Tag OP,Array GroupIndex [GroupInfo])- -> (DFA,Index,Array Tag OP,Array GroupIndex [GroupInfo])-nfaToDFA ((startIndex,aQNFA),aTagOp,aGroupInfo) = (dfa,startIndex,aTagOp,aGroupInfo) where+ -> (CompOption -> ExecOption -> Regex)+nfaToDFA ((startIndex,aQNFA),aTagOp,aGroupInfo) = Regex dfa startIndex indexBounds tagBounds trie aTagOp aGroupInfo where dfa = indexesToDFA [startIndex]+ indexBounds = bounds aQNFA+ tagBounds = bounds aTagOp indexesToDFA = {-# SCC "nfaToDFA.indexesToDFA" #-} Trie.lookupAsc trie -- Lookup in cache- where trie :: TrieSet DFA- trie = Trie.fromSinglesMerge dlose mergeDFA (bounds aQNFA) indexToDFA + trie :: TrieSet DFA+ trie = Trie.fromSinglesMerge dlose mergeDFA (bounds aQNFA) indexToDFA++ newTransition :: DTrans -> Transition+ newTransition dtrans = Transition { trans_many = indexesToDFA (IMap.keys dtransWithSpawn)+ , trans_single = indexesToDFA (IMap.keys dtrans)+ , trans_how = dtransWithSpawn }+ where dtransWithSpawn = addSpawn dtrans++ makeTransition :: DTrans -> Transition+ makeTransition dtrans | hasSpawn = Transition { trans_many = indexesToDFA (IMap.keys dtrans)+ , trans_single = indexesToDFA (IMap.keys (IMap.delete startIndex dtrans))+ , trans_how = dtrans }+ | otherwise = Transition { trans_many = indexesToDFA (IMap.keys dtrans)+ , trans_single = indexesToDFA (IMap.keys dtrans)+ , trans_how = dtrans }+ where hasSpawn = maybe False IMap.null (IMap.lookup startIndex dtrans)++ -- coming from (-1) means spawn a new starting item+ addSpawn :: DTrans -> DTrans+ addSpawn dtrans | IMap.member startIndex dtrans = dtrans+ | otherwise = IMap.insert startIndex mempty dtrans+ indexToDFA :: Index -> DFA -- used to seed the Trie from the NFA indexToDFA i = {-# SCC "nfaToDFA.indexToDFA" #-} makeDFA (ISet.singleton source) (qtToDT qtIn) where@@ -74,24 +99,24 @@ qtToDT (Simple {qt_win=w, qt_trans=t, qt_other=o}) = Simple' { dt_win = makeWinner , dt_trans = fmap qtransToDFA t- , dt_other = if IMap.null o then Nothing else Just (qtransToDFA o)}+-- , dt_other = if IMap.null o then Just (newTransition $ IMap.singleton startIndex mempty) else Just (qtransToDFA o)}+ , dt_other = Just (qtransToDFA o)} where makeWinner :: IntMap {- Index -} Instructions -- (RunState ()) makeWinner | noWin w = IMap.empty | otherwise = IMap.singleton source (cleanWin w) - qtransToDFA :: QTrans -> (DFA,DTrans)+ qtransToDFA :: QTrans -> Transition qtransToDFA qtrans = {-# SCC "nfaToDFA.indexToDFA.qtransToDFA" #-}- (indexesToDFA destinations,dtrans)+ newTransition dtrans where dtrans :: DTrans- dtrans = IMap.fromDistinctAscList . mapSnd (IMap.singleton source) $ best- destinations :: [Index]- destinations = map fst best- best :: [(Index,(DoPa,Instructions))]+ dtrans =IMap.fromDistinctAscList . mapSnd (IMap.singleton source) $ best+ best :: [(Index {- Destination -} ,(DoPa,Instructions))] best = pickQTrans aTagOp $ qtrans - -- The DFA states are built up by merging the singleton ones converted from the NFA+ -- The DFA states are built up by merging the singleton ones converted from the NFA.+ -- Thus the "source" indices in the DTrans should not collide. mergeDFA :: DFA -> DFA -> DFA mergeDFA d1 d2 = {-# SCC "nfaToDFA.mergeDFA" #-} makeDFA i dt where@@ -106,11 +131,11 @@ (Just o1', Just o2') -> Just (mergeDTrans o1' o2') _ -> o1 `mplus` o2 -- This is very much like mergeQTrans- mergeDTrans :: (DFA,DTrans) -> (DFA,DTrans) -> (DFA,DTrans)- mergeDTrans (_,dt1) (_,dt2) = (indexesToDFA (IMap.keys dtrans),dtrans)+ mergeDTrans :: Transition -> Transition -> Transition+ mergeDTrans (Transition {trans_how=dt1}) (Transition {trans_how=dt2}) = makeTransition dtrans where dtrans = IMap.unionWith IMap.union dt1 dt2 -- This is very much like fuseQTrans- fuseDTrans :: CharMap (DFA,DTrans)+ fuseDTrans :: CharMap Transition fuseDTrans = CharMap (IMap.fromDistinctAscList (fuse l1 l2)) where l1 = IMap.toAscList (unCharMap t1)@@ -139,8 +164,8 @@ nestDT dt1@(Testing' {dt_a=a,dt_b=b}) dt2 = dt1 { dt_a = mergeDT a dt2, dt_b = mergeDT b dt2 } nestDT _ _ = err "nestDT called on Simple -- cannot happen" -patternToDFA :: CompOption -> (Pattern,(GroupIndex, DoPa)) -> (DFA,Index,Array Tag OP,Array GroupIndex [GroupInfo])-patternToDFA compOpt pattern = nfaToDFA (patternToNFA compOpt pattern)+patternToRegex :: (Pattern,(GroupIndex, DoPa)) -> CompOption -> ExecOption -> Regex+patternToRegex pattern compOpt execOpt = nfaToDFA (patternToNFA compOpt pattern) compOpt execOpt dfaMap :: DFA -> Data.Map.Map SetIndex DFA dfaMap = seen (Data.Map.empty) where@@ -150,12 +175,14 @@ else let new = Data.Map.insert i d old in foldl' seen new (flattenDT dt) +-- Get all trans_many states flattenDT :: DT -> [DFA]-flattenDT (Simple' {dt_trans=(CharMap mt),dt_other=mo}) = map fst . maybe id (:) mo . IMap.elems $ mt+flattenDT (Simple' {dt_trans=(CharMap mt),dt_other=mo}) = concatMap (\d -> [trans_many d,trans_single d]) . maybe id (:) mo . IMap.elems $ mt flattenDT (Testing' {dt_a=a,dt_b=b}) = flattenDT a ++ flattenDT b -examineDFA :: (DFA,Index,Array Tag OP,Array GroupIndex [GroupInfo]) -> String-examineDFA (dfa,_,_,_) = unlines $ map show $ Data.Map.elems $ dfaMap dfa+examineDFA :: Regex -> String+examineDFA (Regex {regex_dfa=dfa}) = unlines . (:) ("Number of reachable DFA states: "++show (length dfas)) . map show $ dfas+ where dfas = Data.Map.elems $ dfaMap dfa {- @@ -202,40 +229,95 @@ bestTrans :: Array Tag OP -> [TagCommand] -> (DoPa,Instructions) bestTrans _ [] = err "bestTrans : There were no transition choose from!" bestTrans aTagOP (f:fs) | null fs = canonical f- | otherwise = foldl' pick (canonical f) fs where+ | otherwise = answer -- if null toDisplay then answer else trace toDisplay answer+ where+ answer = foldl' pick (canonical f) fs+ {- toDisplay | null fs = ""+ | otherwise = unlines $ "bestTrans" : show (answer) : "from among" : concatMap (\x -> [show x, show (toInstructions (snd x))]) (f:fs) -} canonical :: TagCommand -> (DoPa,Instructions) canonical (dopa,spec) = (dopa, toInstructions spec) pick :: (DoPa,Instructions) -> TagCommand -> (DoPa,Instructions)- pick win@(dopa1,Instructions {newPos = winPos}) (dopa2,spec) =- let next@(Instructions {newPos = nextPos}) = toInstructions spec- in case compareWith choose winPos nextPos of+ pick win@(dopa1,winI) (dopa2,spec) =+ let nextI = toInstructions spec+-- in case compareWith choose winPos nextPos of -- XXX 2009: add in enterOrbit information+ in case compareWith choose (toListing winI) (toListing nextI) of GT -> win- LT -> (dopa2,next)- EQ -> if dopa1 >= dopa2 then win else (dopa2,next) -- no deep reason not to just pick win+ LT -> (dopa2,nextI)+ EQ -> if dopa1 >= dopa2 then win else (dopa2,nextI) -- no deep reason not to just pick win++ toListing :: Instructions -> [(Tag,Action)]+ toListing (Instructions {newPos = nextPos}) = filter notReset nextPos+ where notReset (_,SetVal (-1)) = False+ notReset _ = True+{-+ toListing (Instructions {newPos = nextPos}) = mergeTagOrbit nextPos (filter snd nextFlags)++ mergeTagOrbit xx [] = xx+ mergeTagOrbit [] yy = yy+ mergeTagOrbit xx@(x:xs) yy@(y:ys) = + case compare (fst x) (fst y) of+ GT -> y : mergeTagOrbit xx ys+ LT -> x : mergeTagOrbit xs yy+ EQ -> x : mergeTagOrbit xs ys -- keep tag setting over orbit setting.+-}++ {-# INLINE choose #-}+ choose :: Maybe (Tag,Action) -> Maybe (Tag,Action) -> Ordering choose Nothing Nothing = EQ choose Nothing x = flipOrder (choose x Nothing)- choose (Just (tag,post)) Nothing =+ choose (Just (tag,_post)) Nothing = case aTagOP!tag of Maximize -> GT- Minimize -> LT- Orbit -> err $ "bestTrans.choose : Very Unexpeted Orbit in Just Nothing: "++show (tag,post,aTagOP,f:fs)+ Minimize -> LT -- needed to choose best path inside nested * operators,+ -- this needs a leading Minimize tag inside at least the parent * operator+ Ignore -> GT -- XXX this is a guess in analogy with Maximize for the end bit of a group+ Orbit -> LT -- trace ("choose LT! Just "++show tag++" < Nothing") LT -- 2009 XXX : comment out next line and use the Orbit instead+-- Orbit -> err $ "bestTrans.choose : Very Unexpeted Orbit in Just Nothing: "++show (tag,post,aTagOP,f:fs) choose (Just (tag,post1)) (Just (_,post2)) = case aTagOP!tag of- Maximize -> compare post1 post2- Minimize -> (flip compare) post1 post2- Orbit -> err $ "bestTrans.choose : Very Unexpeted Orbit in Just Just: "++show (tag,(post1,post2),aTagOP,f:fs)+ Maximize -> order+ Minimize -> flipOrder order+ Ignore -> EQ+ Orbit -> EQ+-- Orbit -> err $ "bestTrans.choose : Very Unexpeted Orbit in Just Just: "++show (tag,(post1,post2),aTagOP,f:fs)+ where order = case (post1,post2) of+ (SetPre,SetPre) -> EQ+ (SetPost,SetPost) -> EQ+ (SetPre,SetPost) -> LT+ (SetPost,SetPre) -> GT+ (SetVal v1,SetVal v2) -> compare v1 v2+ _ -> err $ "bestTrans.compareWith.choose sees incomparable "++show (tag,post1,post2) + {-# INLINE compareWith #-}+ compareWith :: (Ord x,Monoid a) => (Maybe (x,b) -> Maybe (x,c) -> a) -> [(x,b)] -> [(x,c)] -> a+ compareWith comp = cw where+ cw [] [] = comp Nothing Nothing+ cw xx@(x:xs) yy@(y:ys) =+ case compare (fst x) (fst y) of+ GT -> comp Nothing (Just y) `mappend` cw xx ys+ EQ -> comp (Just x) (Just y) `mappend` cw xs ys+ LT -> comp (Just x) Nothing `mappend` cw xs yy+ cw xx [] = foldr (\x rest -> comp (Just x) Nothing `mappend` rest) mempty xx+ cw [] yy = foldr (\y rest -> comp Nothing (Just y) `mappend` rest) mempty yy++-- can DT never win or accept a character? isDTLosing :: DT -> Bool isDTLosing (Testing' {dt_a=a,dt_b=b}) = isDTLosing a && isDTLosing b-isDTLosing (Simple' {dt_win=w})- | not (IMap.null w) = False-isDTLosing (Simple' {dt_other=Just (dfa,_)})- | not (ISet.null (d_id dfa)) = False-isDTLosing (Simple' {dt_trans=CharMap t}) =- let destinations = map (d_id . fst) . IMap.elems $ t- in all ISet.null destinations -- True for empty list of destinations+isDTLosing (Simple' {dt_win=w}) | not (IMap.null w) = False -- can win+isDTLosing (Simple' {dt_trans=CharMap mt,dt_other=mo}) =+ let ts = (maybe id (:) mo) (IMap.elems mt)+ in all transLoses ts +transLoses :: Transition -> Bool+transLoses t@(Transition {trans_single=dfa}) = isSpawning t || ISet.null (d_id dfa)+isSpawning :: Transition -> Bool+isSpawning t = case IMap.elems (trans_how t) of+ [m] -> case IMap.keys m of+ [] -> True+ _ -> False+ _ -> False+ -- Assumes that Test_BOL is the smallest (and therefore always first) test isDTFrontAnchored :: DT -> Bool isDTFrontAnchored (Testing' {dt_test=wt,dt_b=b}) | wt == Test_BOL = isDTLosing b@@ -243,3 +325,115 @@ isDFAFrontAnchored :: DFA -> Bool isDFAFrontAnchored = isDTFrontAnchored . d_dt++{- toInstructions -}++toInstructions :: TagList -> Instructions+toInstructions spec =+ let (p,o) = execState (assemble spec) (mempty,mempty)+ in Instructions { newPos = IMap.toList p+ , newOrbits = if IMap.null o then Nothing+ else Just $ alterOrbits (IMap.toList o)+ }++type CompileInstructions a = State+ ( IntMap Action -- 2009: change to SetPre | SetPost enum+ , IntMap AlterOrbit+ ) a++data AlterOrbit = AlterReset -- removing the Orbits record from the OrbitLog+ | AlterLeave -- set inOrbit to False+ | AlterModify { newInOrbit :: Bool -- set inOrbit to the newInOrbit value+ , freshOrbit :: Bool} -- freshOrbit of True means to set getOrbits to mempty+ deriving (Show) -- freshOrbit of False means try appending position or else Seq.empty++assemble :: TagList -> CompileInstructions ()+assemble = mapM_ oneInstruction where+ oneInstruction (tag,command) =+ case command of+ PreUpdate TagTask -> setPreTag tag+ PreUpdate ResetGroupStopTask -> resetGroupTag tag+ PreUpdate SetGroupStopTask -> setGroupTag tag+ PreUpdate ResetOrbitTask -> resetOrbit tag+ PreUpdate EnterOrbitTask -> enterOrbit tag+ PreUpdate LeaveOrbitTask -> leaveOrbit tag+ PostUpdate TagTask -> setPostTag tag+ PostUpdate ResetGroupStopTask -> resetGroupTag tag+ PostUpdate SetGroupStopTask -> setGroupTag tag+ _ -> err ("assemble : Weird orbit command: "++show (tag,command))++setPreTag :: Tag -> CompileInstructions ()+setPreTag = modifyPos SetPre++setPostTag :: Tag -> CompileInstructions ()+setPostTag = modifyPos SetPost++resetGroupTag :: Tag -> CompileInstructions ()+resetGroupTag = modifyPos (SetVal (-1))++setGroupTag :: Tag -> CompileInstructions ()+setGroupTag = modifyPos (SetVal 0)++resetOrbit :: Tag -> CompileInstructions ()+resetOrbit tag = modifyPos (SetVal (-1)) tag >> modifyOrbit (IMap.insert tag AlterReset)++enterOrbit :: Tag -> CompileInstructions ()+enterOrbit tag = modifyPos (SetVal 0) tag >> modifyOrbit changeOrbit where+ changeOrbit = IMap.insertWith overwriteOrbit tag appendNewOrbit++ appendNewOrbit = AlterModify {newInOrbit = True, freshOrbit = False} -- try to append+ startNewOrbit = AlterModify {newInOrbit = True, freshOrbit = True} -- will start a new series++ overwriteOrbit _ AlterReset = startNewOrbit+ overwriteOrbit _ AlterLeave = startNewOrbit+ overwriteOrbit _ (AlterModify {newInOrbit = False}) = startNewOrbit+ overwriteOrbit _ (AlterModify {newInOrbit = True}) =+ err $ "enterOrbit: Cannot enterOrbit twice in a row: " ++ show tag++leaveOrbit :: Tag -> CompileInstructions ()+leaveOrbit tag = modifyOrbit escapeOrbit where+ escapeOrbit = IMap.insertWith setInOrbitFalse tag AlterLeave where+ setInOrbitFalse _ x@(AlterModify {}) = x {newInOrbit = False}+ setInOrbitFalse _ x = x++modifyPos :: Action -> Tag -> CompileInstructions ()+modifyPos todo tag = do+ (a,c) <- get+ let a' = IMap.insert tag todo a+ seq a' $ put (a',c)++modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()+modifyOrbit f = do+ (a,c) <- get+ let c' = f c+ seq c' $ put (a,c')++----++alterOrbits :: [(Tag,AlterOrbit)] -> (Position -> OrbitTransformer)+alterOrbits x = let items = map alterOrbit x+ in (\ pos m -> foldl (flip ($)) m (map ($ pos) items))++alterOrbit :: (Tag,AlterOrbit) -> (Position -> OrbitTransformer)++alterOrbit (tag,AlterModify {newInOrbit = inOrbit',freshOrbit = True}) =+ (\ pos m -> IMap.insert tag (Orbits { inOrbit = inOrbit'+ , basePos = pos+ , ordinal = Nothing+ , getOrbits = mempty}) m)++alterOrbit (tag,AlterModify {newInOrbit = inOrbit',freshOrbit = False}) =+ (\ pos m -> IMap.insertWithKey (updateOrbit pos) tag (newOrbit pos) m) where+ newOrbit pos = Orbits { inOrbit = inOrbit'+ , basePos = pos+ , ordinal = Nothing+ , getOrbits = mempty}+ updateOrbit pos _tag new old | inOrbit old = old { inOrbit = inOrbit'+ , getOrbits = getOrbits old |> pos }+ | otherwise = new++alterOrbit (tag,AlterReset) = (\ _ m -> IMap.delete tag m)++alterOrbit (tag,AlterLeave) = (\ _ m -> case IMap.lookup tag m of+ Nothing -> m+ Just x -> IMap.insert tag (x {inOrbit=False}) m)
Text/Regex/TDFA/TNFA.hs view
@@ -31,7 +31,7 @@ -- Uses recursive do notation. module Text.Regex.TDFA.TNFA(patternToNFA- ,QNFA(..),QT(..),QTrans,TagUpdate(..)) where+ ,QNFA(..),QT(..),QTrans,TagUpdate(..)) where {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -} @@ -39,15 +39,15 @@ import Data.Array.IArray(Array,array) import Data.Char(toLower,toUpper,isAlpha,ord) import Data.List(foldl')-import Data.IntMap.CharMap(CharMap(..))-import qualified Data.IntMap.CharMap as Map(null,toAscList,singleton,map) import Data.IntMap (IntMap)-import qualified Data.IntMap as IMap(size,toList,toAscList,null,unionWith,singleton,fromList,fromDistinctAscList)+import qualified Data.IntMap as IMap(size,toAscList,null,unionWith,singleton,fromList,fromDistinctAscList)+import Data.IntMap.CharMap2(CharMap(..))+import qualified Data.IntMap.CharMap2 as Map(null,singleton,map)+import qualified Data.IntMap.EnumMap2 as EMap(null,keysSet,assocs)+import Data.IntSet.EnumSet2(EnumSet)+import qualified Data.IntSet.EnumSet2 as Set(singleton,toList,insert) import Data.Maybe(catMaybes,isNothing) import Data.Monoid(mempty,mappend)-import Data.IntSet.EnumSet(EnumSet)-import qualified Data.IntSet.EnumSet as Set(singleton,toList,insert)-import qualified Data.IntMap.EnumMap as EMap(null,keysSet,assocs) import qualified Data.Set(insert,toAscList) import Text.Regex.TDFA.Common@@ -56,7 +56,7 @@ ,mustAccept,cannotAccept,patternToQ) import Text.Regex.TDFA.Pattern(Pattern(..)) import Text.Regex.TDFA.ReadRegex(decodePatternSet)-import Debug.Trace+--import Debug.Trace ecart :: String -> a -> a ecart _ = id@@ -67,30 +67,6 @@ debug :: (Show a) => a -> s -> s debug _ s = s -instance Show QNFA where- show (QNFA {q_id = i, q_qt = qt}) = "QNFA {q_id = "++show i- ++"\n ,q_qt = "++ show qt- ++"\n}"--instance Show QT where- show = showQT--showQT :: QT -> String-showQT (Simple win trans other) = "{qt_win=" ++ show win- ++ "\n, qt_trans=" ++ show (foo trans)- ++ "\n, qt_other=" ++ show (foo' other) ++ "}"-showQT (Testing test dopas a b) = "{Testing "++show test++" "++show (Set.toList dopas)- ++"\n"++indent a- ++"\n"++indent b++"}"- where indent = init . unlines . map (spaces++) . lines . showQT- spaces = replicate 9 ' '--foo :: CharMap QTrans -> [(Char,[(Index,[TagCommand])])]-foo = mapSnd foo' . Map.toAscList--foo' :: QTrans -> [(Index,[TagCommand])]-foo' = IMap.toList - instance Eq QT where t1@(Testing {}) == t2@(Testing {}) = (qt_test t1) == (qt_test t2) && (qt_a t1) == (qt_a t2) && (qt_b t1) == (qt_b t2)@@ -104,18 +80,15 @@ eqQTrans = (==) _ == _ = False --- This uses the Eq QT instace above--- ZZZ-mkTesting :: QT -> QT-mkTesting t@(Testing {qt_a=a,qt_b=b}) = if a==b then a else t -- Move to nfsToDFA XXX-mkTesting t = t- qtwin,qtlose :: QT+-- qtwin is the continuation after matching the whole pattern. It has+-- no futher transitions and sets tag #1 to the current position. qtwin = Simple {qt_win=[(1,PreUpdate TagTask)],qt_trans=mempty,qt_other=mempty}+-- qtlose is the continuation to nothing, used when ^ or $ tests fail. qtlose = Simple {qt_win=mempty,qt_trans=mempty,qt_other=mempty} patternToNFA :: CompOption- -> (Text.Regex.TDFA.Pattern.Pattern,(GroupIndex, DoPa))+ -> (Pattern,(GroupIndex, DoPa)) -> ((Index,Array Index QNFA) ,Array Tag OP ,Array GroupIndex [GroupInfo])@@ -125,16 +98,7 @@ in debug msg (qToNFA compOpt q,tags,groups) -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == ---- dumb smart constructor used by qToQNFA--- could replace with something that is--- (*) Monadic, using uniq to auto generate the new i--- (*) Puts the new QNFA into the State's (list->list) (so it is ascending in order)--- (*) Actually creates a simple DFA instead?-mkQNFA :: Int -> QT -> QNFA-mkQNFA i qt = debug ("\n>QNFA id="++show i) $- -- XXX Go through the qt and keep only the best tagged transition(s) to each state.- QNFA i (debug ("\ngetting QT for "++show i) qt)+-- Query function on Q nullable :: Q -> Bool nullable = not . null . nullQ@@ -152,10 +116,27 @@ usesQNFA (Q {wants=WantsQNFA}) = True usesQNFA _ = False +-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- Functions related to QT++-- dumb smart constructor used by qToQNFA+-- Possible: Go through the qt and keep only the best tagged transition(s) to each state to make simple NFA?+mkQNFA :: Index -> QT -> QNFA+mkQNFA i qt = debug ("\n>QNFA id="++show i) $+ QNFA i (debug ("\ngetting QT for "++show i) qt)++-- This uses the Eq QT instance above+-- ZZZ+mkTesting :: QT -> QT+mkTesting t@(Testing {qt_a=a,qt_b=b}) = if a==b then a else t -- Move to nfsToDFA XXX+mkTesting t = t+ nullQT :: QT -> Bool nullQT (Simple {qt_win=w,qt_trans=t,qt_other=o}) = noWin w && Map.null t && IMap.null o nullQT _ = False +-- This reconstructs the set of tests checked in processing QT, adding+-- them to the passed set. listTestInfo :: QT -> EnumSet WhichTest -> EnumSet WhichTest listTestInfo qt s = execState (helper qt) s where helper (Simple {}) = return ()@@ -163,11 +144,12 @@ modify (Set.insert wt) helper a helper b--- This is used to view "win" only through NullView++-- This is used to view "win" only through NullView, and is used in+-- processing Or. applyNullViews :: NullView -> QT -> QT applyNullViews [] win = win-applyNullViews nvs win = foldl' (dominate win winTests) qtlose (reverse $ cleanNullView nvs) where- winTests = listTestInfo win $ mempty+applyNullViews nvs win = foldl' (dominate win) qtlose (reverse $ cleanNullView nvs) where -- This is used to prefer to view "win" through NullView. Losing is -- replaced by the plain win. This is employed by Star patterns to@@ -175,15 +157,36 @@ -- skipping the NullView occurs if the match fails. preferNullViews :: NullView -> QT -> QT preferNullViews [] win = win-preferNullViews nvs win = foldl' (dominate win winTests) win (reverse $ cleanNullView nvs) where- winTests = listTestInfo win $ mempty+preferNullViews nvs win = foldl' (dominate win) win (reverse $ cleanNullView nvs) where -dominate :: QT -> EnumSet WhichTest -> QT -> (SetTestInfo,WinTags) -> QT-dominate win winTests lose x@(SetTestInfo sti,tags) = debug ("dominate "++show x) $+{- +dominate is common to applyNullViews and preferNullViews above.++Even I no longer understand it without study.++Oversimplified: The last argument has a new set of tests "sti" that+must be satisfied to then apply the new "tags" and reach the "win" QT.+Failing any of this set of tests leads to the "lose" QT.++Closer: The "win" may already have some other set of tests leading to+various branches, this set is cached in winTests. And the "lose" may+already have some other set of tests leading to various branches. The+combination of "win" and "lose" and "sti" must check the union of+these tests, which is "allTests".++Detail: The merging is done by useTest, where the tests in sti divert+losing to a branch of "lose" and winning to a branch of "win". Tests+not in sti are unchanged (but the losing DoPa index might be added).+-}+dominate :: QT -> QT -> (SetTestInfo,WinTags) -> QT+dominate win lose x@(SetTestInfo sti,tags) = debug ("dominate "++show x) $ let -- The winning states are reached through the SetTag win' = prependTags' tags win -- get the SetTestInfo - allTests = (listTestInfo lose $ EMap.keysSet sti) `mappend` winTests+ winTests = listTestInfo win $ mempty+ allTests = (listTestInfo lose $ winTests) `mappend` (EMap.keysSet sti)+ -- The first and second arguments of useTest are sorted+ -- At all times the second argument of useTest is a subset of the first useTest _ [] w _ = w -- no more dominating tests to fail to choose lose, so just choose win useTest (aTest:tests) allD@((dTest,dopas):ds) w l = let (wA,wB,wD) = branches w@@ -199,9 +202,12 @@ ,qt_dopas = wD `mappend` lD ,qt_a = useTest tests allD wA lA ,qt_b = useTest tests allD wB lB}- useTest [] _ _ _ = err "This case in applyNullViews.useText cannot happen"+ useTest [] _ _ _ = err "This case in dominate.useText cannot happen: second argument would have to have been null and that is checked before this case" in useTest (Set.toList allTests) (EMap.assocs sti) win' lose +-- 'applyTest' is only used by addTest+-- 2009: maybe need to keep track of whether a change is actually made+-- (beyond DoPa tracking) to the QT. applyTest :: TestInfo -> QT -> QT applyTest (wt,dopa) qt | nullQT qt = qt | otherwise = applyTest' qt where@@ -225,13 +231,16 @@ -- Three ways to merge a pair of QT's varying how winning transitions -- are handled. ----- mergeQT_2nd is used by the NonEmpty case+-- mergeQT_2nd is used by the NonEmpty case and always discards the+-- first argument's win and uses the second argment's win. ----- mergeAltQT is used by the Or cases+-- mergeAltQT is used by the Or cases and is biased to the first+-- argument's winning transition, if present. ----- +-- mergeQT is used by Star and mergeE and combines the winning+-- transitions (concatenating the instructions). mergeQT_2nd,mergeAltQT,mergeQT :: QT -> QT -> QT-mergeQT_2nd q1 q2 | nullQT q1 = q2 -- prefer winning with w1 then with w2+mergeQT_2nd q1 q2 | nullQT q1 = q2 | otherwise = mergeQTWith (\_ w2 -> w2) q1 q2 mergeAltQT q1 q2 | nullQT q1 = q2 -- prefer winning with w1 then with w2@@ -251,10 +260,10 @@ t' = fuseQTrans t1 o1 t2 o2 o' = mergeQTrans o1 o2 in Simple w' t' o'- merge s@(Simple {}) t@(Testing _ _ a b) = mkTesting $- t {qt_a=(merge s a), qt_b=(merge s b)}- merge t@(Testing _ _ a b) s@(Simple {}) = mkTesting $- t {qt_a=(merge a s), qt_b=(merge b s)}+ merge t1@(Testing _ _ a1 b1) s2@(Simple {}) = mkTesting $+ t1 {qt_a=(merge a1 s2), qt_b=(merge b1 s2)}+ merge s1@(Simple {}) t2@(Testing _ _ a2 b2) = mkTesting $+ t2 {qt_a=(merge s1 a2), qt_b=(merge s1 b2)} merge t1@(Testing wt1 ds1 a1 b1) t2@(Testing wt2 ds2 a2 b2) = mkTesting $ case compare wt1 wt2 of LT -> t1 {qt_a=(merge a1 t2), qt_b=(merge b1 t2)}@@ -281,25 +290,59 @@ mergeQTrans :: QTrans -> QTrans -> QTrans mergeQTrans = IMap.unionWith mappend +-- Note: There are no append* operations. There are only these+-- prepend* operations because things are only prepended to the future+-- continuation. And the ordering is significant.++-- This is only used in inStar/nullable+prependPreTag :: Maybe Tag -> QT -> QT+prependPreTag Nothing qt = qt+prependPreTag (Just tag) qt = prependTags' [(tag,PreUpdate TagTask)] qt++prependGroupResets :: [Tag] -> QT -> QT+prependGroupResets [] qt = qt+prependGroupResets tags qt = prependTags' [(tag,PreUpdate ResetGroupStopTask)|tag<-tags] qt++prependTags' :: TagList -> QT -> QT+prependTags' [] qt = qt+prependTags' tcs' qt@(Testing {}) = qt { qt_a = prependTags' tcs' (qt_a qt)+ , qt_b = prependTags' tcs' (qt_b qt) }+prependTags' tcs' (Simple {qt_win=w,qt_trans=t,qt_other=o}) =+ Simple { qt_win = if noWin w then w else tcs' `mappend` w+ , qt_trans = Map.map prependQTrans t+ , qt_other = prependQTrans o }+ where prependQTrans = fmap (map (\(d,tcs) -> (d,tcs' `mappend` tcs)))++-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- define type S which is a State monad, this allows the creation of the uniq QNFA ids and storing the QNFA+-- in an ascending order difference list for later placement in an array.+ -- Type of State monad used inside qToNFA-type S = State (Index -- Next available QNFA index+type S = State (Index -- Next available QNFA index ,[(Index,QNFA)]->[(Index,QNFA)]) -- DList of previous QNFAs -- Type of continuation of the NFA, not much more complicated-type E = (TagTasks -- Things to de before the Either QNFA QT- ,Either QNFA QT) -- The future, packged in the best way+type E = (TagTasks -- Things to do before the Either QNFA QT+ -- with OneChar these become PostUpdate otherwise they become PreUpdate+ ,Either QNFA QT) -- The future, packaged in the best way -type ActCont = (E, Maybe E, Maybe (TagTasks,QNFA))+-- See documentation below before the 'act' function. This is for use inside a Star pattern.+type ActCont = ( E -- The eLoop is the dangerous recursive reference to continuation+ -- future that loops while accepting zero more characters+ , Maybe E -- This holds the safe non-zero-character accepting continuation+ , Maybe (TagTasks,QNFA)) -- optimized merger of the above, used only inside act, to avoid orphan QNFA id values +-- newQNFA is the only operation that actually uses the monad get and put operations newQNFA :: String -> QT -> S QNFA newQNFA s qt = do (thisI,oldQs) <- get let futureI = succ thisI in seq futureI $ debug (">newQNFA< "++s++" : "++show thisI) $ do- let qnfa = mkQNFA thisI qt -- (strictQT qt) -- making strictQNFA kills test (1,11) ZZZ- put (futureI, oldQs . ((thisI,qnfa):))+ let qnfa = mkQNFA thisI qt -- (strictQT qt) -- making strictQNFA kills test (1,11) ZZZ+ put $! (futureI, oldQs . ((thisI,qnfa):)) return qnfa -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == +-- E related functions fromQNFA :: QNFA -> E fromQNFA qnfa = (mempty,Left qnfa)@@ -307,60 +350,84 @@ fromQT :: QT -> E fromQT qt = (mempty,Right qt) --- Promises (Left qnfa)+-- Promises the output will match (_,Left _), used by Or cases when any branch wants a QNFA continuation asQNFA :: String -> E -> S E asQNFA _ x@(_,Left _) = return x asQNFA s (tags,Right qt) = do qnfa <- newQNFA s qt -- YYY Policy choice: leave the tags return (tags, Left qnfa) +-- Convert continuation E into a QNFA, only done at "top level" by qToNFA to get unique start state getQNFA :: String -> E -> S QNFA getQNFA _ ([],Left qnfa) = return qnfa getQNFA s (tags,Left qnfa) = newQNFA s (prependTags' (promoteTasks PreUpdate tags) (q_qt qnfa)) getQNFA s (tags,Right qt) = newQNFA s (prependTags' (promoteTasks PreUpdate tags) qt) +-- Extract the QT from the E getQT :: E -> QT getQT (tags,cont) = prependTags' (promoteTasks PreUpdate tags) (either q_qt id cont) +-- 2009: This looks realllly dodgy, since it can convert a QNFA/Testing to a QT/Testing+-- without actually achieving anything except adding a DoPa to the Testing. A diagnostic+-- series of runs might be needed to decide if this ever creates orphan id numbers.+-- Then applyTest might need to keep track of whether it actually changes anything. addTest :: TestInfo -> E -> E-addTest ti (tags,Left qnfa) = (tags, Right $ applyTest ti (q_qt qnfa))-addTest ti (tags,Right qt) = (tags, Right $ applyTest ti qt)+addTest ti (tags,cont) = (tags, Right . applyTest ti . either q_qt id $ cont) +-- This is used only with PreUpdate and PostUpdate as the first argument. promoteTasks :: (TagTask->TagUpdate) -> TagTasks -> TagList promoteTasks promote tags = map (\(tag,task) -> (tag,promote task)) tags +-- only used in addWinTags demoteTags :: TagList -> TagTasks demoteTags = map helper where helper (tag,PreUpdate tt) = (tag,tt) helper (tag,PostUpdate tt) = (tag,tt) +-- This is polymorphic so addWinTags can be cute below {-# INLINE addWinTags #-} addWinTags :: WinTags -> (TagTasks,a) -> (TagTasks,a)-addWinTags wtags (tags,cont) = (demoteTags wtags `mappend` tags,cont)+addWinTags wtags (tags,cont) = (demoteTags wtags `mappend` tags+ ,cont) {-# INLINE addTag' #-}+-- This is polymorphic so addTagAC can be cute below addTag' :: Tag -> (TagTasks,a) -> (TagTasks,a)-addTag' tag (tags,cont) = ((tag,TagTask):tags,cont)+addTag' tag (tags,cont) = ((tag,TagTask):tags+ ,cont) +-- a Maybe version of addTag' above, specializing 'a' to Either QNFA QT+addTag :: Maybe Tag -> E -> E+addTag Nothing e = e+addTag (Just tag) e = addTag' tag e+ {-# INLINE addGroupResets #-}+-- This is polymorphic so addGroupResetsAC can be cute below addGroupResets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a) addGroupResets [] x = x-addGroupResets tags (tags',cont) = (foldr (:) tags' . map (\tag -> (tag,ResetGroupStopTask)) $ tags,cont)+addGroupResets tags (tags',cont) = (foldr (:) tags' . map (\tag -> (tag,ResetGroupStopTask)) $ tags+ ,cont) -addTag :: Maybe Tag -> E -> E-addTag Nothing e = e-addTag (Just tag) e = addTag' tag e+addGroupSets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a)+addGroupSets [] x = x+addGroupSets tags (tags',cont) = (foldr (:) tags' . map (\tag -> (tag,SetGroupStopTask)) $ tags+ ,cont) -{- XXX use QT form instead-enterOrbit :: Maybe Tag -> E -> E-enterOrbit Nothing e = e-enterOrbit (Just tag) (tags,cont) = ((tag,EnterOrbitTask):tags,cont)--}+-- Consume an ActCont. Uses the mergeQT form to combine non-accepting+-- and accepting view of the continuation.+getE :: ActCont -> E+getE (_,_,Just (tags,qnfa)) = (tags, Left qnfa) -- consume optimized mQNFA value returned by Star+getE (eLoop,Just accepting,_) = fromQT (mergeQT (getQT eLoop) (getQT accepting))+getE (eLoop,Nothing,_) = eLoop +-- 2009: See coment for addTest. Here is a case where the third component might be a (Just qnfa) and it+-- is being lost even though the added test might be redundant. addTestAC :: TestInfo -> ActCont -> ActCont addTestAC ti (e,mE,_) = (addTest ti e ,fmap (addTest ti) mE ,Nothing) +-- These are AC versions of the add functions on E+ addTagAC :: Maybe Tag -> ActCont -> ActCont addTagAC Nothing ac = ac addTagAC (Just tag) (e,mE,mQNFA) = (addTag' tag e@@ -373,66 +440,43 @@ ,fmap (addGroupResets tags) mE ,fmap (addGroupResets tags) mQNFA) +addGroupSetsAC :: [Tag] -> ActCont -> ActCont+addGroupSetsAC [] ac = ac+addGroupSetsAC tags (e,mE,mQNFA) = (addGroupSets tags e+ ,fmap (addGroupSets tags) mE+ ,fmap (addGroupSets tags) mQNFA)+ addWinTagsAC :: WinTags -> ActCont -> ActCont addWinTagsAC wtags (e,mE,mQNFA) = (addWinTags wtags e ,fmap (addWinTags wtags) mE ,fmap (addWinTags wtags) mQNFA)--getE :: ActCont -> E-getE (_,_,Just (tags,qnfa)) = (tags, Left qnfa) -- consume optimized mQNFA value returned by Star-getE (eLoop,Just accepting,_) = mergeE eLoop accepting-getE (eLoop,Nothing,_) = eLoop--mergeE :: E -> E -> E-mergeE e1 e2 = fromQT (mergeQT (getQT e1) (getQT e2))--prependTag :: Maybe Tag -> QT -> QT-prependTag Nothing qt = qt-prependTag (Just tag) qt = prependTags' [(tag,PreUpdate TagTask)] qt--prependGroupResets :: [Tag] -> QT -> QT-prependGroupResets [] qt = qt-prependGroupResets tags qt = prependTags' [(tag,PreUpdate ResetGroupStopTask)|tag<-tags] qt--prependTags' :: TagList -> QT -> QT-prependTags' tcs' qt@(Testing {}) = qt { qt_a = prependTags' tcs' (qt_a qt)- , qt_b = prependTags' tcs' (qt_b qt) }-prependTags' tcs' (Simple {qt_win=w,qt_trans=t,qt_other=o}) =- Simple { qt_win = if noWin w then w else tcs' `mappend` w- , qt_trans = Map.map prependQTrans t- , qt_other = prependQTrans o }- where prependQTrans = fmap (map (\(d,tcs) -> (d,tcs' `mappend` tcs)))- -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == --- Initial preTag of 0th tag is implied--- No other general pre-tags would be expected+-- Initial preTag of 0th tag is implied. No other general pre-tags would be expected.+-- The qtwin contains the preTag of the 1st tag and is only set when a match is completed.+-- The fst Index is the index of the unique starting QNFA state.+-- The snd (Array Index QNFA) is all the QNFA states.+--+-- In the cases below, Empty is handled much like a Test with no TestInfo. qToNFA :: CompOption -> Q -> (Index,Array Index QNFA) qToNFA compOpt qTop = (q_id startingQNFA ,array (0,pred lastIndex) (table [])) where+ -- Result startingQNFA is the top level's index+ -- State pair: fst 0 is the next state number (not yet used) going in, and lastIndex coming out (succ of last used)+ -- snd id is the difference list of states going in, and the finished list coming out (startingQNFA,(lastIndex,table)) = runState (getTrans qTop (fromQT $ qtwin) >>= getQNFA "top level") startState startState = (0,id) - -- This is the only place where PostUpdate is used- newTrans :: String -> [Tag] -> Maybe Tag -> Pattern -> E -> S E- newTrans s resets mPre pat (tags,cont) = do- i <- case cont of- Left qnfa -> return (q_id qnfa) -- strictQNFA ZZZ no help- Right qt -> do qnfa <- newQNFA s qt -- strictQT ZZZ no help- return (q_id qnfa)- let post = promoteTasks PostUpdate tags- pre = promoteTasks PreUpdate ([(tag,ResetGroupStopTask) | tag<-resets] ++ maybe [] (\tag -> [(tag,TagTask)]) mPre)- return . fromQT $ acceptTrans pre pat post i -- fromQT $ strictQT no help- getTrans,getTransTagless :: Q -> E -> S E- getTrans qIn@(Q {preReset=resets,preTag=pre,postTag=post,unQ=pIn}) e = debug (">< getTrans "++show qIn++" <>") $--- liftM strictE $ -- ZZZ causes stack overflow in test (1,36)+ getTrans qIn@(Q {preReset=resets,postSet=sets,preTag=pre,postTag=post,unQ=pIn}) e = debug (">< getTrans "++show qIn++" <>") $ case pIn of- OneChar pat -> newTrans "getTrans/OneChar" resets pre pat . addTag post $ e- Empty -> return . addGroupResets resets . addTag pre . addTag post $ e- Test ti -> return . addGroupResets resets . addTag pre . addTest ti . addTag post $ e- _ -> return . addGroupResets resets . addTag pre =<< getTransTagless qIn (addTag post $ e)+ -- The case below is the ultimate consumer of every single OneChar in the input and the only caller of+ -- newTrans/acceptTrans which is the sole source of QT/Simple nodes.+ OneChar pat -> newTrans "getTrans/OneChar" resets pre pat . addTag post . addGroupSets sets $ e+ Empty -> return . addGroupResets resets . addTag pre . addTag post . addGroupSets sets $ e+ Test ti -> return . addGroupResets resets . addTag pre . addTest ti . addTag post . addGroupSets sets $ e+ _ -> return . addGroupResets resets . addTag pre =<< getTransTagless qIn (addTag post . addGroupSets sets $ e) getTransTagless qIn e = debug (">< getTransTagless "++show qIn++" <>") $ case unQ qIn of@@ -441,13 +485,15 @@ Or [q] -> getTrans q e Or qs -> do eqts <- if usesQNFA qIn- then do eQNFA <- asQNFA "getTransTagless/Or/usesQNFA" e- sequence [ getTrans q eQNFA | q <- qs ]+ then do+ eQNFA <- asQNFA "getTransTagless/Or/usesQNFA" e+ sequence [ getTrans q eQNFA | q <- qs ] else sequence [ getTrans q e | q <- qs ] let qts = map getQT eqts return (fromQT (foldr1 mergeAltQT qts)) Star mOrbit resetTheseOrbits mayFirstBeNull q ->+ -- mOrbit of Just implies varies q and childGroups q let (e',clear) = -- debug ("\n>"++show e++"\n"++show q++"\n<") $ if notNullable q then (e,True) -- subpattern cannot be null else if null resetTheseOrbits && isNothing mOrbit@@ -455,14 +501,14 @@ Just [] -> (e,True) -- True because null of subpattern is same as skipping subpattern Just tagList -> (addWinTags tagList e,False) -- null of subpattern NOT same as skipping _ -> (fromQT . preferNullViews (nullQ q) . getQT $ e,False) -- is NOT same as skipping- else (fromQT . resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit+ else (fromQT . resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit -- resetOrbitsQT and enterOrbitQT commute . preferNullViews (nullQ q) . getQT . leaveOrbit mOrbit $ e,False) -- perform resets when accepting 0 characters in if cannotAccept q then return e' else mdo mqt <- inStar q this (this,ans) <- case mqt of Nothing -> err ("Weird pattern in getTransTagless/Star: " ++ show (qTop,qIn)) Just qt -> do- let qt' = resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit $ qt+ let qt' = resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit $ qt -- resetOrbitsQT and enterOrbitQT commute thisQT = mergeQT qt' . getQT . leaveOrbit mOrbit $ e -- capture of subpattern or leave via next pattern (avoid null of subpattern on way out) ansE = fromQT . mergeQT qt' . getQT $ e' -- capture of subpattern or leave via null of subpattern thisE <- if usesQNFA q@@ -472,6 +518,7 @@ return (if mayFirstBeNull then (if clear then this -- optimization to possibly preserve QNFA else ans) else this)+ {- NonEmpty is like actNullable (Or [Empty,q]) without the extra tag to prefer the first Empty branch -} NonEmpty q -> ecart ("\n> getTransTagless/NonEmpty"++show qIn) $ do -- Assertion to check than Pattern.starTrans did its job right:@@ -488,12 +535,12 @@ _ -> err ("This case in Text.Regex.TNFA.TNFA.getTransTagless cannot happen" ++ show (qTop,qIn)) inStar,inStarNullableTagless :: Q -> E -> S (Maybe QT)- inStar qIn@(Q {preReset=resets,preTag=pre,postTag=post}) eLoop | notNullable qIn =+ inStar qIn@(Q {preReset=resets,postSet=sets,preTag=pre,postTag=post}) eLoop | notNullable qIn = debug (">< inStar/1 "++show qIn++" <>") $ return . Just . getQT =<< getTrans qIn eLoop- | otherwise =+ | otherwise = debug (">< inStar/2 "++show qIn++" <>") $- return . fmap (prependGroupResets resets . prependTag pre) =<< inStarNullableTagless qIn (addTag post $ eLoop)+ return . fmap (prependGroupResets resets . prependPreTag pre) =<< inStarNullableTagless qIn (addTag post . addGroupSets sets $ eLoop) inStarNullableTagless qIn eLoop = debug (">< inStarNullableTagless "++show qIn++" <>") $ do case unQ qIn of@@ -508,8 +555,13 @@ let qts = catMaybes mqts mqt = if null qts then Nothing else Just (foldr1 mergeAltQT qts) return mqt+ -- Calls to act are inlined by hand to actNullable. This returns only cases where q1 or q2 or both+ -- accepted characters. The zero-character case is handled by the tag wrapping by inStar.+ -- 2009: Does this look dodgy and repetitios of tags? Seq by policy has no preTag or postTag.+ -- though it can have prependGroupResets, but those are not repeated in children so it is okay. Seq q1 q2 -> do (_,meAcceptingOut,_) <- actNullable q1 =<< actNullable q2 (eLoop,Nothing,Nothing) return (fmap getQT meAcceptingOut)+ -- Calls to act are inlined by hand and are we losing the tags? Star {} -> do (_,meAcceptingOut,_) <- actNullableTagless qIn (eLoop,Nothing,Nothing) return (fmap getQT meAcceptingOut) NonEmpty {} -> ecart ("\n> inStarNullableTagless/NonEmpty"++show qIn) $@@ -567,13 +619,13 @@ return mqt -- or "return (fromQT qtlose,mqt,Nothing)" actNullable,actNullableTagless :: Q -> ActCont -> S ActCont- actNullable qIn@(Q {preReset=resets,preTag=pre,postTag=post,unQ=pIn}) ac =+ actNullable qIn@(Q {preReset=resets,postSet=sets,preTag=pre,postTag=post,unQ=pIn}) ac = debug (">< actNullable "++show qIn++" <>") $ do case pIn of- Empty -> return . addGroupResetsAC resets . addTagAC pre . addTagAC post $ ac- Test ti -> return . addGroupResetsAC resets . addTagAC pre . addTestAC ti . addTagAC post $ ac+ Empty -> return . addGroupResetsAC resets . addTagAC pre . addTagAC post . addGroupSetsAC sets $ ac+ Test ti -> return . addGroupResetsAC resets . addTagAC pre . addTestAC ti . addTagAC post . addGroupSetsAC sets $ ac OneChar {} -> err ("OneChar cannot have nullable True ")- _ -> return . addGroupResetsAC resets . addTagAC pre =<< actNullableTagless qIn ( addTagAC post $ ac )+ _ -> return . addGroupResetsAC resets . addTagAC pre =<< actNullableTagless qIn ( addTagAC post . addGroupSetsAC sets $ ac ) actNullableTagless qIn ac@(eLoop,mAccepting,mQNFA) = debug (">< actNullableTagless "++show (qIn)++" <>") $ do case unQ qIn of@@ -678,6 +730,25 @@ leaveOrbit | lastStarGreedy compOpt = const id | otherwise = maybe id (\tag->(\(tags,cont)->((tag,LeaveOrbitTask):tags,cont))) + -- 'newTrans' is the only place where PostUpdate is used and is only called from getTrans/OneChar+ -- and is the only caller of 'acceptTrans' to make QT/Simple nodes.+ newTrans :: String -- debugging string for when a newQNFA is allocated+ -> [Tag] -- which tags get ResetGroupStopTask in this transition (PreUpdate)+ -> Maybe Tag -- maybe one TagTask to update before incrementing the offset (PreUpdate)+ -> Pattern -- the one character accepting Pattern of this transition+ -> E -- the continuation state, reified to a QNFA, of after this Pattern+ -- The fst part of the E is consumed here as a TagTask (PostUpdate)+ -> S E -- the continuation state, as a QT, of before this Pattern+ newTrans s resets mPre pat (tags,cont) = do+ i <- case cont of+ Left qnfa -> return (q_id qnfa) -- strictQNFA ZZZ no help+ Right qt -> do qnfa <- newQNFA s qt -- strictQT ZZZ no help+ return (q_id qnfa)+ let post = promoteTasks PostUpdate tags+ pre = promoteTasks PreUpdate ([(tag,ResetGroupStopTask) | tag<-resets] ++ maybe [] (\tag -> [(tag,TagTask)]) mPre)+ return . fromQT $ acceptTrans pre pat post i -- fromQT $ strictQT no help++ -- 'acceptTrans' is the sole creator of QT/Simple and is only called by getTrans/OneChar/newTrans acceptTrans :: TagList -> Pattern -> TagList -> Index -> QT acceptTrans pre pIn post i = let target = IMap.singleton i [(getDoPa pIn,pre++post)]@@ -713,3 +784,15 @@ dotTrans | multiline compOpt = Map.singleton '\n' mempty | otherwise = mempty +{-++prepend architecture becomes+prependTags :: TagTask -> [Tag] -> QT -> QT+which always uses PreUpdate and the same task for all the tags++qt_win seems to only allow PreUpdate so why keep the same type?+++ADD ORPHAN ID check and make this a fatal error while testing++-}
regex-tdfa.cabal view
@@ -1,57 +1,66 @@ Name: regex-tdfa-Version: 0.97.4--- 0.97.1: Bug Fix: Use PGroup Nothing when expanding PBound--- 0.97.2: Bug Fix: Use more complex null view in PStar when mayFirstBeNull, fix (()*)* and ((.?)*)*--- 0.97.3: Bug Fix: RunMutState.updateWinning was borking the input state (.*)*...?()|. on 123456--- 0.97.4: Bug Fix: PPLus needs asGroup as well, "(BB(B?))+(B?)" on "BBBB"-Cabal-Version: >=1.2.3+Version: 1.0.0+-- 0.99.4 tests pnonempty' = \ p -> POr [ PEmpty, p ] instead of PNonEmpty+-- 0.99.5 remove PNonEmpty constructor+-- 0.99.6 change to nested nonEmpty calls for PBound+-- 0.99.7 Use (PGroup Nothing) in Pattern to decompose PBound+-- 0.99.8 testing chaning Maximize to Minimize for Tags, decide (a*)* is canonical problem+-- 0.99.9 testing changing bestTrans/chooseWith/choose to include enterOrbit/newFlags/(_,True) info+-- 0.99.10 fixed ((.?)*)* patterns by changing PStar nullView when mayFirstBeNull+-- 0.99.11 improve above fix and make stuff work better -- HAS BUG, along with old TDFA!+-- 0.99.12 try to debug 0.99.11 : fixed updateWinner+-- 0.99.13 more cleanup+-- 0.99.14 start changing to the new real DFA+-- 0.99.15 get string with NewDFA testing, unit tests and 1000 random regex pass+-- 0.99.16 performance? up to v15+-- 0.99.17 radical removal of flag array and adding of SetVal to handle groups+-- 0.99.18 try alternate lazy/strict strategy in NewDFA. Fix offset laziness.+-- 0.99.19 try for pre-comparison of orbit-logs!+-- 0.99.20 go to many vs single?+-- 1.0.0 License: BSD3 License-File: LICENSE-Copyright: Copyright (c) 2007-2009, Christopher Kuklewicz+Copyright: Copyright (c) 2007, Christopher Kuklewicz Author: Christopher Kuklewicz Maintainer: TextRegexLazy@personal.mightyreason.com Stability: Seems to work, but not POSIX yet Homepage: http://sourceforge.net/projects/lazy-regex Package-URL: http://darcs.haskell.org/packages/regex-unstable/regex-tdfa/-Synopsis: Accurate POSIX extended regular expression library+Synopsis: Replaces/Enhances Text.Regex Description: A new all Haskell "tagged" DFA regex engine, inspired by libtre Category: Text Tested-With: GHC Build-Type: Simple+Cabal-Version: >= 1.2.3 flag base4 library - Build-Depends: regex-base >= 0.80, parsec, mtl, containers, array, bytestring+ Build-Depends: regex-base >= 0.93.1, parsec, mtl, containers, array, bytestring if flag(base4) Build-Depends: base >= 4.0, ghc-prim else Build-Depends: base < 4.0- other-modules: Paths_regex_tdfa- Exposed-Modules: Text.Regex.TDFA.Common- Text.Regex.TDFA.IntArrTrieSet- Text.Regex.TDFA.TNFA- Text.Regex.TDFA.TDFA- Text.Regex.TDFA.Pattern- Text.Regex.TDFA.ReadRegex- Text.Regex.TDFA.CorePattern- Text.Regex.TDFA.RunMutState- Text.Regex.TDFA.String- Text.Regex.TDFA.MutRun- Text.Regex.TDFA.ByteString- Text.Regex.TDFA.MutRunBS- Text.Regex.TDFA.ByteString.Lazy- Text.Regex.TDFA.MutRunLBS- Text.Regex.TDFA.Sequence- Text.Regex.TDFA.MutRunSeq- Text.Regex.TDFA.Wrap- Text.Regex.TDFA- Data.IntSet.EnumSet- Data.IntMap.EnumMap- Data.IntMap.CharMap- Buildable: True- Extensions: MultiParamTypeClasses, FunctionalDependencies, BangPatterns, MagicHash, RecursiveDo, NoMonoPatBinds, ForeignFunctionInterface, UnboxedTuples, TypeOperators, FlexibleContexts, ExistentialQuantification, UnliftedFFITypes, TypeSynonymInstances- GHC-Options: -Wall -O2 -funbox-strict-fields- -- GHC-Options: -Wall -O2- -- GHC-Options: -Wall -ddump-minimal-imports- -- GHC-Prof-Options: -auto-all++ other-modules: Paths_regex_tdfa+ Exposed-Modules: Text.Regex.TDFA.Common+ Text.Regex.TDFA.IntArrTrieSet+ Text.Regex.TDFA.TNFA+ Text.Regex.TDFA.TDFA+ Text.Regex.TDFA.Pattern+ Text.Regex.TDFA.ReadRegex+ Text.Regex.TDFA.CorePattern+ Text.Regex.TDFA.NewDFA+ Text.Regex.TDFA.String+ Text.Regex.TDFA.ByteString+ Text.Regex.TDFA.ByteString.Lazy+ Text.Regex.TDFA.Sequence+ Text.Regex.TDFA.Wrap+ Text.Regex.TDFA+ Data.IntSet.EnumSet2+ Data.IntMap.EnumMap2+ Data.IntMap.CharMap2+ Buildable: True+ Extensions: MultiParamTypeClasses, FunctionalDependencies, BangPatterns, MagicHash, RecursiveDo, NoMonoPatBinds, ForeignFunctionInterface, UnboxedTuples, TypeOperators, FlexibleContexts, ExistentialQuantification, UnliftedFFITypes, TypeSynonymInstances+ GHC-Options: -Wall -O2 -funbox-strict-fields+ GHC-Prof-Options: -auto-all