packages feed

regex-tdfa (empty) → 0.92

raw patch · 24 files changed

+4612/−0 lines, 24 filesdep +basedep +mtldep +parsecbuild-type:Customsetup-changed

Dependencies added: base, mtl, parsec, regex-base

Files

+ Data/IntMap/CharMap.hs view
@@ -0,0 +1,303 @@+module Data.IntMap.CharMap where++import GHC.Base(unsafeChr)+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)++newtype CharMap a = CharMap {unCharMap :: M.IntMap a} deriving (Monoid,Eq,Read,Show,Ord,Functor)++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 :: Monad m => Key -> CharMap a -> m 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 view
@@ -0,0 +1,238 @@+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,Read,Show,Ord,Monoid,Foldable,Functor)++(!) :: (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) = 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 view
@@ -0,0 +1,102 @@+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 (Monoid,Eq,Read,Show,Ord)++(\\) :: (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
@@ -0,0 +1,12 @@+This modile is under this "3 clause" BSD license:++Copyright (c) 2007, 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:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,6 @@+#!/usr/bin/env runhaskell++-- I usually compile this with "ghc --make -o setup Setup.hs"++import Distribution.Simple(defaultMain)+main = defaultMain
+ Text/Regex/TDFA.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++{- Wrong answer++"A\n_"+"(^|()|.|()){0,3}()"++("TDFA   ",("",array (0,4) [(0,("",(0,0))),(1,("",(-1,0))),(2,("",(-1,0))),(3,("",(-1,0))),(4,("",(0,0)))],"A\n_"))++-}+++{-| +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.++Todo:+  compNoCapture to avoid creating any tags and optimize inStar stuff...+  runBool case for aborting on shortest match+  frontAnchored+  Cleanup locations of helper functions+  Decide whether to nix DoPa or just replace with Int+  Make untagged TDFA for non-capturing cases+  Pull starTrans into ReadRegex+  Consider replacing Pattern with CorePattern entirely+  Remove parent info from GroupInfo and/or reduce tag resetting workload+    (try to shift work from doing resets to post-processing)++Beyond posix:+  non-capturing groups+  Inverted tests and additional tests+  lazy instead of greedy+  possessive instead of greedy+  leftmost branch instead of leftmost/longest (open/close group instead of tagging)+-}++module Text.Regex.TDFA(getVersion_Text_Regex_TDFA+                      ,module Text.Regex.TDFA.Wrap+                      ,module Text.Regex.TDFA.String+                      ,module Text.Regex.TDFA.ByteString+                      ,module Text.Regex.TDFA.ByteString.Lazy+                      ,module Text.Regex.TDFA.Sequence+                      ,module Text.Regex.Base) where++import Data.Version(Version(..))+import Text.Regex.Base+import Text.Regex.TDFA.String()+import Text.Regex.TDFA.ByteString()+import Text.Regex.TDFA.ByteString.Lazy()+import Text.Regex.TDFA.Sequence()+import Text.Regex.TDFA.Wrap(Regex,CompOption(..),ExecOption(..),(=~),(=~~))++getVersion_Text_Regex_TDFA :: Version+getVersion_Text_Regex_TDFA =+  Version { versionBranch = [0,92]+          , versionTags = ["tdfa","unstable"]+          }
+ Text/Regex/TDFA/ByteString.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+{-| +This modules provides 'RegexMaker' and 'RegexLike' instances for using+'ByteString' with the DFA backend ("Text.Regex.Lib.WrapDFAEngine" and+"Text.Regex.Lazy.DFAEngineFPS").  This module is usually used via+import "Text.Regex.TDFA".++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.+-}+module Text.Regex.TDFA.ByteString(+  Regex+ ,CompOption+ ,ExecOption+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array((!),elems)+import qualified Data.ByteString.Char8 as B++import Text.Regex.Base(MatchArray,RegexContext(..),RegexMaker(..),RegexLike(..))+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.Wrap(Regex(..),CompOption,ExecOption)++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++instance RegexContext Regex B.ByteString B.ByteString where+  match = polymatch+  matchM = polymatchM++instance RegexMaker Regex CompOption ExecOption B.ByteString where+  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++compile :: CompOption -- ^ Flags (summed together)+        -> ExecOption -- ^ Flags (summed together)+        -> B.ByteString -- ^ The regular expression to compile+        -> Either String Regex -- ^ Returns: the compiled regular expression+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)++execute :: Regex      -- ^ Compiled regular expression+        -> B.ByteString -- ^ ByteString to match against+        -> Either String (Maybe MatchArray)+execute r bs = Right (matchOnce r bs)++regexec :: Regex      -- ^ Compiled regular expression+        -> B.ByteString -- ^ ByteString to match against+        -> Either String (Maybe (B.ByteString, B.ByteString, B.ByteString, [B.ByteString]))+regexec r bs =+  case matchOnceText r bs of+    Nothing -> Right (Nothing)+    Just (pre,mt,post) ->+      let main = fst (mt!0)+          rest = map fst (tail (elems mt)) -- will be []+      in Right (Just (pre,main,post,rest))
+ Text/Regex/TDFA/ByteString/Lazy.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-| +This modules provides 'RegexMaker' and 'RegexLike' instances for using+'ByteString' with the DFA backend ("Text.Regex.Lib.WrapDFAEngine" and+"Text.Regex.Lazy.DFAEngineFPS").  This module is usually used via+import "Text.Regex.TDFA".++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.+-}+module Text.Regex.TDFA.ByteString.Lazy(+  Regex+ ,CompOption+ ,ExecOption+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array((!),elems)+import qualified Data.ByteString.Lazy.Char8 as L++import Text.Regex.Base(MatchArray,RegexContext(..),RegexMaker(..),RegexLike(..))+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.Wrap(Regex(..),CompOption,ExecOption)++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++instance RegexContext Regex L.ByteString L.ByteString where+  match = polymatch+  matchM = polymatchM++instance RegexMaker Regex CompOption ExecOption L.ByteString where+  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++compile :: CompOption -- ^ Flags (summed together)+        -> ExecOption -- ^ Flags (summed together)+        -> L.ByteString -- ^ The regular expression to compile+        -> Either String Regex -- ^ Returns: the compiled regular expression+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)++execute :: Regex      -- ^ Compiled regular expression+        -> L.ByteString -- ^ ByteString to match against+        -> Either String (Maybe MatchArray)+execute r bs = Right (matchOnce r bs)++regexec :: Regex      -- ^ Compiled regular expression+        -> L.ByteString -- ^ ByteString to match against+        -> Either String (Maybe (L.ByteString, L.ByteString, L.ByteString, [L.ByteString]))+regexec r bs =+  case matchOnceText r bs of+    Nothing -> Right (Nothing)+    Just (pre,mt,post) ->+      let main = fst (mt!0)+          rest = map fst (tail (elems mt)) -- will be []+      in Right (Just (pre,main,post,rest))
+ Text/Regex/TDFA/Common.hs view
@@ -0,0 +1,223 @@+{-# OPTIONS -funbox-strict-fields #-}+-- | Common provides simple functions to the backend.  It defines most+-- of the data types.  All modules should call error via the+-- common_error function below.+module Text.Regex.TDFA.Common {- export everything -} where++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++import Text.Show.Functions()+import Control.Monad.State(State)+import Data.Array.IArray(Array)+import Data.IntSet.EnumSet(EnumSet)+import Data.IntMap as IMap (IntMap,findWithDefault,assocs)+import Data.IntSet(IntSet)+import Data.IntMap.CharMap as Map (CharMap,assocs)+import Data.Sequence(Seq)+--import Debug.Trace++{-# 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++common_error :: String -> String -> a+common_error moduleName message =+  error ("Explict error in module "++moduleName++" : "++message)++on :: (t1 -> t1 -> t2) -> (t -> t1) -> t -> t -> t2+f `on` g = (\x y -> (g x) `f` (g y))++-- | after sort or sortBy the use of nub/nubBy can be replaced by norep/norepBy+norep :: (Eq a) => [a]->[a]+norep [] = []+norep x@[_] = x+norep (a:bs@(c:cs)) | a==c = norep (a:cs)+                    | otherwise = a:norep bs++-- | after sort or sortBy the use of nub/nubBy can be replaced by norep/norepBy+norepBy :: (a -> a -> Bool) -> [a] -> [a]+norepBy _ [] = []+norepBy _ x@[_] = x+norepBy eqF (a:bs@(c:cs)) | a `eqF` c = norepBy eqF (a:cs)+                          | otherwise = a:norepBy eqF bs++mapFst :: (Functor f) => (t -> t2) -> f (t, t1) -> f (t2, t1)+mapFst f = fmap (\ (a,b) -> (f a,b))++mapSnd :: (Functor f) => (t1 -> t2) -> f (t, t1) -> f (t, t2)+mapSnd f = fmap (\ (a,b) -> (a,f b))++fst3 :: (a,b,c) -> a+fst3 (x,_,_) = x++snd3 :: (a,b,c) -> b+snd3 (_,x,_) = x++thd3 :: (a,b,c) -> c+thd3 (_,_,x) = x++flipOrder :: Ordering -> Ordering+flipOrder GT = LT+flipOrder LT = GT+flipOrder EQ = EQ++noWin :: WinTags -> Bool+noWin = null++-- | Used to track elements of the pattern that accept characters or +-- are anchors+newtype DoPa = DoPa {dopaIndex :: Int} deriving (Eq,Ord,Enum)++instance Show DoPa where+  showsPrec p (DoPa {dopaIndex=i}) = ('#':) . showsPrec p i++-- | Control whether the pattern is multiline or+-- case-sensitive like Text.Regex and whether to capture the subgroups+-- (\1, \2, etc).+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.+                                                        -- Setting this to true will improve performance, and should be done+                                                        -- if you plan to set the captureGroups execoption to False.+                             } deriving (Read,Show)+data ExecOption = ExecOption { captureGroups :: Bool    -- ^ True by default.  Set to False to improve speed (and space).+                             , testMatch :: Bool        -- ^ False by default. Set to True to quickly return shortest match (w/o groups).+                             } deriving (Read,Show)++-- | 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)+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)+type GroupIndex = Int+-- | GroupInfo collects the parent and tag information for an instance +-- of a group+data GroupInfo = GroupInfo {thisIndex,parentIndex::GroupIndex+                           ,startTag,stopTag::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}++-- | Internal NFA node type+data QNFA = QNFA {q_id :: Index+                 ,q_qt :: QT}+-- | Internal to QNFA type.+data QT = Simple {qt_win :: WinTags -- ^ empty transitions to the virtual winning state+                 ,qt_trans :: CharMap QTrans -- ^ all ways to leave this QNFA to other or the same QNFA+                 ,qt_other :: QTrans -- ^ default ways to leave this QNFA to other or the same QNFA+                 }+        | Testing {qt_test :: WhichTest -- ^ The test to perform+                  ,qt_dopas :: EnumSet DoPa  -- ^ location(s) of the anchor(s) in the original regexp+                  ,qt_a,qt_b :: QT -- ^ use qt_a if test is True, else use qt_b+                  }++-- | Internal type to represent the tagged transition from one QNFA to+-- another (or itself).  The key is the Index of the destination QNFA.+type QTrans = IntMap {- Destination Index -} [TagCommand]++-- | Known predicates, just Beginning of Line (^) and End of Line ($).+data WhichTest = Test_BOL | Test_EOL deriving (Show,Eq,Ord,Enum)++-- | The things that can be done with a Tag.  TagTask and+-- 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+             | ResetOrbitTask | EnterOrbitTask | LeaveOrbitTask deriving (Show,Eq)+-- | Ordered list of tags and their associated Task+type TagTasks = [(Tag,TagTask)]+-- | When attached to a QTrans the TagTask can be done before or after+-- accepting the character.+data TagUpdate = PreUpdate TagTask | PostUpdate TagTask deriving (Show,Eq)+-- | Ordered list of tags and their associated update operation.+type TagList = [(Tag,TagUpdate)]+-- | A TagList and the location of the item in the original pattern+-- that is being accepted.+type TagCommand = (DoPa,TagList)+-- | Ordered list of tags and their associated update operation to+-- perform on an empty transition to the virtual winning state.+type WinTags = TagList++-- | 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)+-- | 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+                  }+        | 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.+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.+data Orbits = Orbits+  { inOrbit :: !Bool        -- True if enterOrbit, False if LeaveOrbit+  , getOrbits :: !(Seq Position)+  } deriving (Show)++data Instructions = Instructions+  { newPos :: ![(Tag,Bool)] -- False is preUpdate, True is postUpdate+  , newFlags :: ![(Tag,Bool)]   -- apply to scratchFlags+  , newOrbits :: !(Maybe (Position -> OrbitTransformer))+  } deriving (Show)++type OrbitLog = IntMap Orbits+type OrbitTransformer = OrbitLog -> OrbitLog++type CompileInstructions a = State+  ( IntMap Bool+  , IntMap Bool+  , IntMap AlterOrbit+  ) a++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
+ Text/Regex/TDFA/CorePattern.hs view
@@ -0,0 +1,449 @@+-- | The CorePattern module deconstructs the Pattern tree created by+-- ReadRegex.parseRegex and returns a simpler Q/P tree with+-- annotations at each Q node.  This will be converted by the TNFA+-- module into a QNFA finite automata.+--+-- Of particular note, this Pattern to Q/P conversion creates and+-- assigns all the internal Tags that will be used during the matching+-- process, and associates the captures groups with the tags that+-- represent their starting and ending locations and with their+-- immediate parent group.+--+-- Each Maximize and Minimize tag is held as either a preTag or a+-- postTag by one and only one location in the Q/P tree.  The Orbit+-- tags are each held by one and only one Star node.  Tags that stop a+-- Group are also held in perhaps numerous preReset lists.+--+-- The additional nullQ::nullView field of Q records the potentially+-- complex information about what tests and tags must be used if the+-- pattern unQ::P matches 0 zero characters.  There can be redundancy+-- in nullView, which is eliminated by cleanNullView.+--+-- Uses recursive do notation.+module Text.Regex.TDFA.CorePattern(Q(..),P(..),WhichTest(..),Wanted(..)+                                  ,TestInfo,OP(..),SetTestInfo(..),NullView+                                  ,patternToQ,cleanNullView,cannotAccept,mustAccept) where++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 Text.Regex.TDFA.Common {- all -}+import Text.Regex.TDFA.Pattern(Pattern(..),starTrans)+-- import Debug.Trace++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++err :: String -> a+err = common_error "Text.Regex.TDFA.CorePattern"++debug :: (Show a) => a -> b -> b+debug _ = id++-- Core Pattern Language+data P = Empty+       | 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+              , 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+         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+           ,unQ :: P} deriving (Eq)++type TestInfo = (WhichTest,DoPa)++-- This is newtype'd to allow control over class instances+-- This is a set of WhichTest where each test has associated pattern location information+newtype SetTestInfo = SetTestInfo {getTests :: EnumMap WhichTest (EnumSet DoPa)} deriving (Eq,Monoid)++instance Show SetTestInfo where+  show (SetTestInfo sti) = "SetTestInfo "++show (mapSnd (Set.toList) $ Map.assocs sti)++-- There may be several distinct ways for a subtree to conditionally+-- (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++-- During the depth first traversal, children are told about tags by the parent+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+                 deriving (Show)++-- Nodes in the tree are labeled by the type kind of continuation they+-- 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.+data Wanted = WantsQNFA | WantsQT | WantsBoth | WantsEither deriving (Eq,Show)++instance Show Q where+  show = showQ++showQ :: Q -> String+showQ q = "Q { nullQ = "++show (nullQ q)+++        "\n  , takes = "++show (takes q)+++        "\n  , preReset = "++show (preReset 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+         spaces = replicate 10 ' '++-- Smart constructors for NullView+notNull :: NullView+notNull = []++emptyNull :: WinTags -> NullView+emptyNull tags = (mempty, tags) : []++testNull :: TestInfo -> WinTags -> NullView+testNull (w,d) tags = (SetTestInfo (Map.singleton w (Set.singleton d)), tags) : []++-- 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+-- the first unconditional entry in the list will be the last entry of+-- the returned list since the empty set is a subset of any other set.+cleanNullView :: NullView -> NullView+cleanNullView [] = []+cleanNullView (first@(SetTestInfo sti,_):rest) | Map.null sti = first : []  -- optimization+                                               | otherwise =+  first : cleanNullView (filter (not . (setTI `Set.isSubsetOf`) . Map.keysSet . getTests . fst) rest)+  where setTI = Map.keysSet sti++-- Ordered Sequence of two NullViews: all ordered combinations of tests and tags.+-- Order of <- s1 and <- s2 is deliberately chosen to maintain preference priority+mergeNullViews :: NullView -> NullView -> NullView+mergeNullViews s1 s2 = cleanNullView $ do+  (test1,tag1) <- s1+  (test2,tag2) <- s2+  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 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)++-- Parallel combination of list of ranges of number of accepted characters+orTakes :: [(Int, Maybe Int)] -> (Int,Maybe Int)+orTakes [] = (0,Just 0)+orTakes ts = let (xs,ys) = unzip ts+             in (minimum xs, foldl1 (liftM2 max) ys)++-- Invariant: apply (toAdvice _ ) == mempty+apply :: HandleTag -> Maybe Tag+apply (Apply tag) = Just tag+apply _ = Nothing+toAdvice :: HandleTag -> HandleTag+toAdvice (Apply tag) = Advice tag+toAdvice s = s+noTag :: HandleTag -> Bool+noTag NoTag = True+noTag _ = False+fromHandleTag :: HandleTag -> Tag+fromHandleTag (Apply tag) = tag+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+varies Q {takes = (x,Just y)} = x/=y++mustAccept :: Q -> Bool+mustAccept q = (0/=) . fst . takes $ q++canAccept :: Q -> Bool+canAccept q = maybe True (0/=) $ snd . takes $ q++cannotAccept :: Q -> Bool+cannotAccept q = maybe False (0==) $ snd . takes $ q++-- This converts then input Pattern to an analyzed Q structure with+-- the tags assigned.+--+-- The analysis is filled in by a depth first search and the tags are+-- 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.+-- +-- 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.+--+-- 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.+--+-- There is a final "qwin of Q {postTag=ISet.singleton 1}" and an+-- implied initial index tag of 0.+-- +-- favoring pushing Apply into the child postTag makes PGroup happier++type PM = RWS (Maybe GroupIndex) [Either Tag GroupInfo] ([OP]->[OP],Tag) +type HHQ = HandleTag  -- m1 : info about left boundaary / preTag+        -> HandleTag  -- m2 : info about right boundary / postTag+        -> PM Q++-- There is no group 0 here, since it is always the whole match and has no parent of its own+makeGroupArray :: GroupIndex -> [GroupInfo] -> Array GroupIndex [GroupInfo]+makeGroupArray maxGroupIndex groups = accumArray (\earlier later -> later:earlier) [] (1,maxGroupIndex) filler+    where filler = map (\gi -> (thisIndex gi,gi)) groups++fromRight :: [Either Tag GroupInfo] -> [GroupInfo]+fromRight [] = []+fromRight ((Right x):xs) = x:fromRight xs+fromRight ((Left _):xs) = fromRight xs++partitionEither :: [Either Tag GroupInfo] -> ([Tag],[GroupInfo])+partitionEither = helper id id where+  helper :: ([Tag]->[Tag]) -> ([GroupInfo]->[GroupInfo]) -> [Either Tag GroupInfo] -> ([Tag],[GroupInfo])+  helper ls rs [] = (ls [],rs [])+  helper ls rs ((Right x):xs) = helper  ls      (rs.(x:)) xs+  helper ls rs ((Left  x):xs) = helper (ls.(x:)) rs       xs++-- Partial function: assumes starTrans has been run on the Pattern+patternToQ :: CompOption -> (Pattern,(GroupIndex,DoPa)) -> (Q,Array Tag OP,Array GroupIndex [GroupInfo])+patternToQ compOpt (pOrig,(maxGroupIndex,_)) = (tnfa,aTags,aGroups) where+  (tnfa,(tag_dlist,nextTag),groups) = runRWS monad startReader startState+  aTags = listArray (0,pred nextTag) (tag_dlist [])+  aGroups = makeGroupArray maxGroupIndex (fromRight groups)++  -- implicitly inside a PGroup 0 converted into a GroupInfo 0 undefined 0 1+  monad = go (starTrans pOrig) (Advice 0) (Advice 1)+  startReader :: Maybe GroupIndex+  startReader = Just 0                           -- start inside group 0, capturing enabled+  startState :: ([OP]->[OP],Tag)+  startState = ( (Minimize:) . (Maximize:) , 2)  -- Tag 0 is Minimized and Tag 1 is maximized.++  -- Specialize the monad operations and give more meaningful names+  makeOrbit :: PM (Maybe Tag)+  makeOrbit = do Apply x <- uniq Orbit+                 tell [Left x]+                 return (Just x)++  withOrbit :: PM a -> PM (a,[Tag])+  withOrbit = listens childStars+    where childStars x = let (ts,_) = partitionEither x in ts++  getParentIndex :: PM (Maybe GroupIndex)+  getParentIndex = ask++  makeGroup :: GroupInfo -> PM ()+  makeGroup = tell . (:[]) . Right++  nonCapture :: PM  a -> PM a+  nonCapture = local (const Nothing)++  withParent :: GroupIndex -> PM a -> PM (a,[Tag])+  withParent this = local (const (Just this)) . listens childGroupInfo+    where childGroupInfo x =+            let (_,gs) = partitionEither x+                children :: [GroupIndex]+                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++  -- 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+  --  * 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+          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+            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+            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)+                                   )+  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))+                         ,takes=(0,Just 0)+                         ,preReset=[],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+                         ,tagged=False,childGroups=False,wants=WantsQNFA+                         ,unQ = OneChar pIn}+        test myTest = return $ Q {nullQ=testNull myTest (winTags (apply m1) (apply m2))+                                 ,takes=(0,Just 0)+                                 ,preReset=[],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+           -- 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)+           let wqs = map wants qs+               wanted = if any (WantsBoth==) wqs then WantsBoth+                          else case (any (WantsQNFA==) wqs,any (WantsQT==) wqs) of+                                 (True,True) -> WantsBoth+                                 (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)+           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)+           let nullView = emptyNull (winTags (apply a) (apply b)) -- chosen to represent skipping sub-pattern+           return $ Q nullView+                      (0,if accepts then Nothing else (Just 0))+                      [] (apply a) (apply b)+                      needsTags (childGroups q) WantsQT+                      (Star c resetTags mayFirstBeNull q)+         PCarat dopa -> test (Test_BOL,dopa)+         PDollar dopa -> test (Test_EOL,dopa)+         PChar {} -> one+         PDot {} -> one+         PAny {} -> one+         PAnyNot {} -> one+         PEscape {} -> one++         -- A PGroup node in the Pattern tree does not become a node+         -- in the Q/P tree. A PGroup can share and pass along a+         -- preTag (with Advice) with other branches, but will pass+         -- down an Apply postTag.+         --+         -- If the parent index is Nothing then this is part of a+         -- non-capturing subtree and ignored.+         PGroup Nothing p -> go p m1 m2+         PGroup (Just this) p -> do+           mParent <- getParentIndex+           case mParent of+             Nothing -> go p m1 m2+             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)+                          , tagged = True+                          , childGroups = True+                          , preReset = resetTags `mappend` (preReset q) }++         -- 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)++         -- 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".+         PNonEmpty p -> mdo+           let needsTags = canAccept q+           a <- if noTag m1 && needsTags then uniq Minimize else return m1+           b <- if noTag m2 && needsTags then uniq Maximize else return m2+           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)++         -- these are here for completeness of the case branches, currently starTrans replaces them all+         PPlus {} -> die+         PQuest {} -> die+         PBound {} -> die
+ Text/Regex/TDFA/IntArrTrieSet.hs view
@@ -0,0 +1,63 @@+{- |+This creates a lazy Trie based on a finite range of Ints and is used to+memorize a function over the subsets of this range.++To create a Trie you need two supply 2 things+  * Range of keys to bound+  * A function or functions used to construct the value for a subset of keys++The Trie uses the Array type internally.+-}+module Text.Regex.TDFA.IntArrTrieSet where++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++import Data.Array.IArray(Array,(!),listArray)++data TrieSet v = TrieSet { value :: v+                         , next :: Array Int (TrieSet v) }++-- | This is the accessor for the Trie. The list of keys should be+-- sorted.+lookupAsc :: TrieSet v -> [Int] -> v+lookupAsc (TrieSet {value=v,next=n}) =+  (\keys -> case keys of [] -> v+                         (key:keys') -> lookupAsc (n!key) keys')++-- | This is a Trie constructor for a complete range of keys.+fromBounds :: (Int,Int)     -- ^ (lower,upper) range of keys, lower<=upper+           -> ([Int] -> v)  -- ^ Function from list of keys to its value.+                            --   It must work for distinct ascending lists.+           -> TrieSet v     -- ^ The constructed Trie+fromBounds (start,stop) keysToValue = build id start where+  build keys low = TrieSet { value = keysToValue (keys [])+                           , next = listArray (low,stop)+                                    [build (keys.(x:)) (succ x) | x <- [low..stop] ] }++-- | This is a Trie constructor for a complete range of keys that uses+-- a function from single values and a merge operation on values to+-- fill the Trie.+fromSinglesMerge :: v          -- ^ value for (lookupAsc trie [])+                 -> (v->v->v)  -- ^ merge operation on values+                 -> (Int,Int)  -- ^ (lower,upper) range of keys, lower<=upper+                 -> (Int->v)   -- ^ Function from a single key to its value+                 -> TrieSet v  -- ^ The constructed Trie+fromSinglesMerge emptyValue mergeValues bound keyToValue = trieSet where+  trieSet = fromBounds bound keysToValue'+  keysToValue' keys =+    case keys of+      [] -> emptyValue+      [key] -> keyToValue key+      _ -> mergeValues (keysToValue (init keys)) (keysToValue [last keys])+  keysToValue = lookupAsc trieSet++-- | This is a Trie constructor for a complete range of keys that uses+-- a function from single values and a sum operation of values to fill+-- the Trie.+fromSinglesSum :: ([v]->v)   -- ^ summation operation for values+               -> (Int,Int)  -- ^ (lower,upper) range of keys, lower <= upper+               -> (Int->v)   -- ^ Function from a single key to its value+               -> TrieSet v  -- ^ The constructed Trie+fromSinglesSum mergeValues bound keyToValue = trieSet where+  trieSet = fromBounds bound keysToValue'+  keysToValue' = mergeValues . map keyToValue
+ Text/Regex/TDFA/MutRun.hs view
@@ -0,0 +1,167 @@+-- | "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.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(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+    (!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" #-}+          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" #-} 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 || null input' then return []+                        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 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 || 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" #-}+    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 view
@@ -0,0 +1,161 @@+-- | "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.Base 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(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+    (!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" #-}+          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" #-} 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 || off'==final then return []+                        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 || off'==final then []+                           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" #-}+    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 view
@@ -0,0 +1,160 @@+-- | "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(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+    (!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" #-}+          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" #-} 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 || off'==final then return []+                        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 || off'==final then []+                           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" #-}+    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 view
@@ -0,0 +1,170 @@+-- | "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(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+    (!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" #-}+          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" #-} 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 || S.null input' then return []+                        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 || S.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" #-}+    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/Pattern.hs view
@@ -0,0 +1,343 @@+-- | This "Text.Regex.TDFA.Pattern" module provides the 'Pattern' data+-- type and its subtypes.  This 'Pattern' type is used to represent+-- the parsed form of a Regular Expression.  +module Text.Regex.TDFA.Pattern+    (Pattern(..)+    ,PatternSet(..)+    ,PatternSetCharacterClass(..)+    ,PatternSetCollatingElement(..)+    ,PatternSetEquivalenceClass(..)+    ,GroupIndex+    ,DoPa(..)+    ,showPattern+-- ** Internal use+    ,starTrans+-- ** Internal use, Operations to support debugging under ghci+    ,starTrans',simplify',dfsPattern+    ) where++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++import Data.List(intersperse,partition)+import qualified Data.Set as Set(toAscList,toList)+import Data.Set(Set) -- XXX EnumSet+import Text.Regex.TDFA.Common(DoPa(..),GroupIndex,common_error)++err :: String -> a+err = common_error "Text.Regex.TDFA.Pattern"++-- | Pattern is the type returned by the regular expression parser.+-- 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+             | PStar   Bool Pattern               -- True means mayFirstBeNull is True+             | PBound  Int (Maybe Int) Pattern+             -- The rest of these need an index of where in the regex string it is from+             | PCarat  {getDoPa::DoPa}+             | PDollar {getDoPa::DoPa}+             -- The following test and accept a single character+             | 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+             -- The following are semantic tags created in starTrans, not the parser+             | PNonCapture Pattern+             | PNonEmpty Pattern+               deriving (Eq,Show)++-- | I have not been checking, but this should have the property that+-- parsing the resulting string should result in an identical Pattern.+-- This is not true if starTrans has created PNonCapture and PNonEmpty+-- values or a (PStar False).  The contents of a "[ ]" grouping are+-- always shown in a sorted canonical order.+showPattern :: Pattern -> String+showPattern pIn =+  case pIn of+    PEmpty -> "()"+    PGroup _ p -> paren (showPattern p)+    POr ps -> concat $ intersperse "|" (map showPattern ps)+    PConcat ps -> concatMap showPattern ps+    PQuest p -> (showPattern p)++"?"+    PPlus p -> (showPattern p)++"+"+    -- If PStar has mayFirstBeNull False then reparsing will forget this flag+    PStar _ p -> (showPattern p)++"*"+    PBound i (Just j) p | i==j -> showPattern p ++ ('{':show i)++"}"+    PBound i mj p -> showPattern p ++ ('{':show i) ++ maybe ",}" (\j -> ',':show j++"}") mj+    --+    PCarat _ -> "^"+    PDollar _ -> "$"+    PDot _ -> "."+    PAny _ ps -> ('[':show ps)++"]"+    PAnyNot _ ps ->  ('[':'^':show ps)++"]"+    PEscape _ c -> '\\':c:[]+    PChar _ c -> [c]+    -- 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+                                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))+                             (Maybe (Set PatternSetCharacterClass))+                             (Maybe (Set PatternSetCollatingElement))+                             (Maybe (Set PatternSetEquivalenceClass))+                             deriving (Eq)++instance Show PatternSet where+  showsPrec i (PatternSet s scc sce sec) =+    let (special,normal) = maybe ("","") ((partition (`elem` "]-")) . Set.toAscList) s+        charSpec = (if ']' `elem` special then (']':) else id) (byRange normal)+        scc' = maybe "" ((concatMap show) . Set.toList) scc+        sce' = maybe "" ((concatMap show) . Set.toList) sce+        sec' = maybe "" ((concatMap show) . Set.toList) sec+    in shows charSpec+       . showsPrec i scc' . showsPrec i sce' . showsPrec i sec'+       . if '-' `elem` special then showChar '-' else id+    where byRange xAll@(x:xs) | length xAll <=3 = xAll+                              | otherwise = groupRange x 1 xs+          byRange _ = undefined+          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)):[]++newtype PatternSetCharacterClass   = PatternSetCharacterClass   {unSCC::String}+  deriving (Eq,Ord)+newtype PatternSetCollatingElement = PatternSetCollatingElement {unSCE::String}+  deriving (Eq,Ord)+newtype PatternSetEquivalenceClass = PatternSetEquivalenceClass {unSEC::String}+  deriving (Eq,Ord)++instance Show PatternSetCharacterClass where+  showsPrec _ p = showChar '[' . showChar ':' . shows (unSCC p) . showChar ':' . showChar ']'+instance Show PatternSetCollatingElement where+  showsPrec _ p = showChar '[' . showChar '.' . shows (unSCE p) . showChar '.' . showChar ']'+instance Show PatternSetEquivalenceClass where+  showsPrec _ p = showChar '[' . showChar '=' . shows (unSEC p) . showChar '=' . showChar ']'++-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == ++-- | 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.+starTrans :: Pattern -> Pattern+starTrans = dfsPattern (simplify' . starTrans')++-- | Apply a Pattern transfomation function depth first+dfsPattern :: (Pattern -> Pattern)  -- ^ The transformation function+           -> Pattern               -- ^ The Pattern to transform+           -> Pattern               -- ^ The transformed Pattern+dfsPattern f = dfs+ where unary c = f . c . dfs+       dfs pattern = case pattern of+                       POr ps -> f (POr (map dfs ps))+                       PConcat ps -> f (PConcat (map dfs ps))+                       PGroup i p -> unary (PGroup i) p+                       PQuest p -> unary PQuest p+                       PPlus p -> unary PPlus p+                       PStar i p -> unary (PStar i) p+                       PBound i mi p -> unary (PBound i mi) p+                       _ -> f pattern++{- Replace by PNonCapture+unCapture = dfsPattern unCapture' where+  unCapture' (PGroup (Just _) p) = PGroup Nothing p+  unCapture' x = x+-}++starTrans' :: Pattern -> Pattern+starTrans' pIn =+  case pIn of -- We know that "p" has been simplified in each of these cases:+    PQuest p -> POr [p,PEmpty]++{- The PStar should not capture 0 characters on its first iteration,+   so set its mayFirstBeNull flag to False+ -}+    PPlus  p -> PConcat [p,simplify' $ PStar False p]++{- "An ERE matching a single character repeated by an '*' , '?' , or+   an interval expression shall not match a null expression unless+   this is the only match for the repetition or it is necessary to+   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 -> 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?++   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+   the first p is overwritten.++   We need a new operation "p!" that means "p?" unless "p" match 0+   characters, in which case skip p as if it failed in "p?".  Thus+   when p cannot accept 0 characters p! and p? are equivalent.  And+   when p can only match 0 characters p! is PEmpty.  So for+   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?+   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+   The p{1,2} is pp! and p{1,3} is pp!p! or p(pp!)!+   And p{2,4} means p'pp!p! and p{3,6} is p'p'pp!p!p! or p'p'p(p(pp!)!)!++   But this second form still has a problem: the (pp!)! can have the first+   p match 0 and the second p match non-zero. This showed up for (.|$){1,3}+   since ($.!)! should not be a valid path but altered the qt_win commands.++   Thus only p'p'pp!p!p! has the right semantics.  For completeness:++   if p can only match only 0 characters then the cases are+   p{0,0} is (), p{0,_} = p?, p{_,_} is p++   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!++   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*!+-}+    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    -> PConcat $ apply (p':) (pred i) [p]+                        | cannotMatchNull p -> PConcat $ apply (p':) (pred i) $ (p:) $ +                                                 [apply (quest' . (concat' p)) (pred (j-i)) (quest' p)]+                        | canOnlyMatchNull p -> p+                        | otherwise -> PConcat $ (replicate (pred i) p') ++ p : (replicate (j-i) (nonEmpty' p))+      where p' = nonCapture' p -- XXX cleanup+    -- Left intact+    PEmpty -> pass+    PGroup {} -> pass+    PStar {} -> pass+    POr {} -> pass+    PConcat {} -> pass+    PCarat {} -> pass+    PDollar {} -> pass+    PDot {} -> pass+    PAny {} -> pass+    PAnyNot {} -> pass+    PEscape {} -> pass+    PChar {} -> pass+    PNonCapture {} -> pass+    PNonEmpty {} -> pass+  where+    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+    nonCapture' = PNonCapture+    apply f n x = foldr ($) x (replicate n f)+    pass = pIn++-- | Function to transform a pattern into an equivalent, but less+-- redundant form.  Nested 'POr' and 'PConcat' are flattened.+simplify' :: Pattern -> Pattern+simplify' x@(POr _) = +  let ps' = case span notPEmpty (flatten x) of+              (notEmpty,[]) -> notEmpty+              (notEmpty,_:rest) -> notEmpty ++ (PEmpty:filter notPEmpty rest) -- keep 1st PEmpty only+  in case ps' of+       [] -> PEmpty+       [p] -> p+       _ -> POr ps'+simplify' x@(PConcat _) =+  let ps' = filter notPEmpty (flatten x)+  in case ps' of+       [] -> PEmpty+       [p] -> p+       _ -> PConcat ps' -- PConcat ps'+simplify' (PStar _ PEmpty) = PEmpty+simplify' other = other++-- | Function to flatten nested POr or nested PConcat applicataions.+flatten :: Pattern -> [Pattern]+flatten (POr ps) = (concatMap (\x -> case x of+                                       POr ps' -> ps'+                                       p -> [p]) ps)+flatten (PConcat ps) = (concatMap (\x -> case x of+                                           PConcat ps' -> ps'+                                           p -> [p]) ps)+flatten _ = err "flatten can only be applied to POr or PConcat"++notPEmpty :: Pattern -> Bool+notPEmpty PEmpty = False+notPEmpty _      = True++-- | 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+-- 'Pattern' could accept an empty string.+cannotMatchNull :: Pattern -> Bool+cannotMatchNull pIn =+  case pIn of+    PEmpty -> False+    PGroup _ p -> cannotMatchNull p+    POr [] -> False+    POr ps -> all cannotMatchNull ps+    PConcat [] -> False+    PConcat ps -> any cannotMatchNull ps+    PQuest _ -> False+    PPlus p -> cannotMatchNull p+    PStar {} -> False+    PBound 0 _ _ -> False+    PBound _ _ p -> cannotMatchNull p+    PCarat _ -> False+    PDollar _ -> False+    PNonCapture p -> cannotMatchNull p+    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
@@ -0,0 +1,174 @@+{-# 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.+module Text.Regex.TDFA.ReadRegex (parseRegex+                                 ,decodePatternSet+                                 ,legalCharacterClasses) where++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++import Text.Regex.TDFA.Pattern {- all -}+import Text.ParserCombinators.Parsec((<|>), (<?>),+  unexpected, try, runParser, many, getState, setState, CharParser, ParseError,+  sepBy1, option, notFollowedBy, many1, lookAhead, eof, between,+  string, noneOf, digit, char, anyChar)+import Control.Monad(liftM, when, guard)+import qualified Data.Set as Set(Set,fromList, toList, insert,empty)++-- | BracketElement is internal to this module+data BracketElement = BEChar Char | BEChars String | BEColl String | BEEquiv String | BEClass String++-- | Return either an error message or a tuple of the Pattern and the+-- largest group index and the largest DoPa index (both have smallest+-- index of 1).  Since the regular expression is supplied as [Char] it+-- automatically supports unicode and '\NUL' characters.+parseRegex :: String -> Either ParseError (Pattern,(GroupIndex,DoPa))+parseRegex x = runParser (do pat <- p_regex+                             eof+                             (lastGroupIndex,lastDopa) <- getState+                             return (pat,(lastGroupIndex,DoPa lastDopa))) (0,0) x x++p_regex :: CharParser (GroupIndex,Int) Pattern+p_regex = liftM POr $ sepBy1 p_branch (char '|')++-- man re_format helps alot, it says one-or-more pieces so this is+-- many1 not many.  Use "()" to indicate an empty piece.+p_branch = liftM PConcat $ many1 p_piece++p_piece = (p_anchor <|> p_atom) >>= p_post_atom -- correct specification++p_atom =  p_group <|> p_bracket <|> p_char <?> "an atom"++group_index = do+  (gi,ci) <- getState+  let index = succ gi+  setState (index,ci)+  return (Just index)++p_group = lookAhead (char '(') >> do+  index <- group_index+  liftM (PGroup index) $ between (char '(') (char ')') p_regex++-- p_post_atom takes the previous atom as a parameter+p_post_atom atom = (char '?' >> return (PQuest atom))+               <|> (char '+' >> return (PPlus atom))+               <|> (char '*' >> return (PStar True atom))+               <|> p_bound atom +               <|> return atom++p_bound atom = try $ between (char '{') (char '}') (p_bound_spec atom)++p_bound_spec atom = do lowS <- many1 digit+                       let lowI = read lowS+                       highMI <- option (Just lowI) $ try $ do +                                   char ','+                                   highS <- many digit+                                   if null highS then return Nothing -- no upper bound+                                     else do let highI = read highS+                                             guard (lowI <= highI)+                                             return (Just (read highS))+                       return (PBound lowI highMI atom)++-- An anchor cannot be modified by a repetition specifier+p_anchor = (char '^' >> liftM PCarat char_index)+       <|> (char '$' >> liftM PDollar char_index)+       <|> try (do string "()" +                   index <- group_index+                   return $ PGroup index PEmpty) +       <?> "empty () or anchor ^ or $"++char_index = do (gi,ci) <- getState+                let ci' = succ ci+                setState (gi,ci')+                return (DoPa ci')++p_char = p_dot <|> p_left_brace <|> p_escaped <|> p_other_char where+  p_dot = char '.' >> char_index >>= return . PDot+  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  = "^.[$()|*+?{\\"++-- 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+                  char ']'+                  ci <- char_index+                  let chars = maybe'set $ initial+                                          ++ [c | BEChar c <- values ]+                                          ++ concat [s | BEChars s <- values ]+                      colls = maybe'set [PatternSetCollatingElement coll | BEColl coll <- values ]+                      equivs = maybe'set [PatternSetEquivalenceClass equiv | BEEquiv equiv <- values]+                      class's = maybe'set [PatternSetCharacterClass a'class | BEClass a'class <- values]+                      maybe'set x = if null x then Nothing else Just (Set.fromList x)+                      sets = PatternSet chars class's colls equivs+                  sets `seq` return $ if invert then PAnyNot ci sets else PAny ci sets++-- From here down the code is the parser and functions for pattern [ ] set things++p_set_elem = p_set_elem_class <|> p_set_elem_equiv <|> p_set_elem_coll+         <|> p_set_elem_range <|> p_set_elem_char <?> "Failed to parse bracketed string"++p_set_elem_class = liftM BEClass $+  try (between (string "[:") (string ":]") (many1 $ noneOf ":]"))++p_set_elem_equiv = liftM BEEquiv $+  try (between (string "[=") (string "=]") (many1 $ noneOf "=]"))++p_set_elem_coll =  liftM BEColl $+  try (between (string "[.") (string ".]") (many1 $ noneOf ".]"))++p_set_elem_range = try $ do +  start <- noneOf "]-"+  char '-'+  end <- noneOf "]"+  return (BEChars [start..end])++p_set_elem_char = do +  c <- noneOf "]"+  when (c == '-') $ do+    atEnd <- (lookAhead (char ']') >> return True) <|> (return False)+    when (not atEnd) (unexpected "A dash is in the wrong place in a bracket")+  return (BEChar c)++-- | decodePatternSet cannot handle collating element and treats+-- equivalence classes as just their definition and nothing more.+decodePatternSet :: PatternSet -> Set.Set Char+decodePatternSet (PatternSet msc mscc _ msec) =+  let baseMSC = maybe Set.empty id msc+      withMSCC = foldl (flip Set.insert) baseMSC  (maybe [] (concatMap decodeCharacterClass . Set.toList) mscc)+      withMSEC = foldl (flip Set.insert) withMSCC (maybe [] (concatMap unSEC . Set.toList) msec)+  in withMSEC++-- | This is the list of recognized [: :] character classes, others+-- are decoded as empty.+legalCharacterClasses :: [String]+legalCharacterClasses = ["alnum","digit","punct","alpha","graph"+  ,"space","blank","lower","upper","cntrl","print","xdigit","word"]++-- | This returns the disctince ascending list of characters+-- represented by [: :] values in legalCharacterClasses; unrecognized+-- class names return an empty string+decodeCharacterClass :: PatternSetCharacterClass -> String+decodeCharacterClass (PatternSetCharacterClass s) =+  case s of+    "alnum" -> ['0'..'9']++['a'..'z']++['A'..'Z']+    "digit" -> ['0'..'9']+    "punct" -> ['\33'..'\47']++['\58'..'\64']++['\91'..'\95']++"\96"++['\123'..'\126']+    "alpha" -> ['a'..'z']++['A'..'Z']+    "graph" -> ['\41'..'\126']+    "space" -> "\t\n\v\f\r "+    "blank" -> "\t "+    "lower" -> ['a'..'z']+    "upper" -> ['A'..'Z']+    "cntrl" -> ['\0'..'\31']++"\127" -- with NUL+    "print" -> ['\32'..'\126']+    "xdigit" -> ['0'..'9']++['a'..'f']++['A'..'F']+    "word" -> ['0'..'9']++['a'..'z']++['A'..'Z']++"_"+    _ -> []+
+ Text/Regex/TDFA/RunMutState.hs view
@@ -0,0 +1,619 @@+module Text.Regex.TDFA.RunMutState(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(..))+import GHC.Arr(STArray(..))+import GHC.ST(ST(..))+import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#)++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++{-# INLINE newTagEngine #-}+newTagEngine :: Regex -> ST s (MScratch s -> Position -> IntMap (IntMap (t,Instructions)) -> ST s ()+                              ,MScratch s -> (Position,Char,xxx) -> Maybe (WScratch s,(Position,Char,xxx)) -> IntMap Instructions -> ST s (Maybe (WScratch s,(Position,Char,xxx)))+                              ,MScratch s -> MScratch s -> Position -> IntMap (IntMap (DoPa,Instructions)) -> ST s ()+                              )+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 (findTrans,updateWinner,performTrans)++{-# INLINE newTagEngine2 #-}+newTagEngine2 :: Regex -> ST s (MScratch s -> Position -> IntMap (IntMap (t,Instructions)) -> ST s ()+                               ,MScratch s -> Position -> Maybe (WScratch s,Position) -> IntMap Instructions -> ST s (Maybe (WScratch s,Position))+                               ,MScratch s -> MScratch s -> Position -> IntMap (IntMap (DoPa,Instructions)) -> ST s ()+                               )+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 (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+      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++foreign import ccall unsafe "memcpy"+    memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO ()++{-# 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#, () #) }}++{-  Commented out -- more useful to non-GHC compilers++copySTArray :: (MArray (STUArray s) e (ST s))=> STUArray s Tag e -> STUArray s Tag e -> ST s ()+copySTArray 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+-}
+ Text/Regex/TDFA/Sequence.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+{-| +This modules provides 'RegexMaker' and 'RegexLike' instances for using+'ByteString' with the DFA backend ("Text.Regex.Lib.WrapDFAEngine" and+"Text.Regex.Lazy.DFAEngineFPS").  This module is usually used via+import "Text.Regex.TDFA".++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.+-}+module Text.Regex.TDFA.Sequence(+  Regex+ ,CompOption+ ,ExecOption+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array((!),elems)+import Data.Sequence as S++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.Wrap(Regex(..),CompOption,ExecOption)+import Text.Regex.TDFA.ReadRegex(parseRegex)++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++instance RegexContext Regex (S.Seq Char) (S.Seq Char) where+  match = polymatch+  matchM = polymatchM++instance RegexMaker Regex CompOption ExecOption (S.Seq Char) where+  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++{-# INLINE toList #-}+toList :: S.Seq Char -> [Char]+toList s = expand (S.viewl s) where+  expand EmptyL = []+  expand (c :< cs) = c : expand (S.viewl cs)++compile :: CompOption -- ^ Flags (summed together)+        -> ExecOption -- ^ Flags (summed together)+        -> (S.Seq Char) -- ^ The regular expression to compile+        -> Either String Regex -- ^ Returns: the compiled regular expression+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)++execute :: Regex      -- ^ Compiled regular expression+        -> (S.Seq Char) -- ^ ByteString to match against+        -> Either String (Maybe MatchArray)+execute r bs = Right (matchOnce r bs)++regexec :: Regex      -- ^ Compiled regular expression+        -> (S.Seq Char) -- ^ ByteString to match against+        -> Either String (Maybe ((S.Seq Char), (S.Seq Char), (S.Seq Char), [(S.Seq Char)]))+regexec r bs =+  case matchOnceText r bs of+    Nothing -> Right (Nothing)+    Just (pre,mt,post) ->+      let main = fst (mt!0)+          rest = map fst (tail (elems mt)) -- will be []+      in Right (Just (pre,main,post,rest))
+ Text/Regex/TDFA/String.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{- | +This modules provides 'RegexMaker' and 'RegexLike' instances for using+'String' with the TDFA backend.++This exports instances of the high level API and the medium level+API of 'compile','execute', and 'regexec'.+-}+module Text.Regex.TDFA.String(+  -- ** Types+  Regex+ ,MatchOffset+ ,MatchLength+ ,CompOption+ ,ExecOption+  -- ** Medium level API functions+ ,compile+ ,execute+ ,regexec+ ) where++import Data.Array((!),elems)++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 Text.Regex.TDFA.ReadRegex(parseRegex)+import Text.Regex.TDFA.MutRun(findMatch,findMatchAll,countMatchAll)+import Text.Regex.TDFA.TDFA(patternToDFA)+import Text.Regex.TDFA.Wrap(Regex(..),CompOption,ExecOption)++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++err :: String -> a+err = common_error "Text.Regex.TDFA.String"++unwrap :: Either String v -> v+unwrap x = case x of Left msg -> err ("Text.Regex.TDFA.String died: "++msg)+                     Right v -> v++compile  :: CompOption -- ^ Flags (summed together)+         -> ExecOption -- ^ Flags (summed together)+         -> String     -- ^ The regular expression to compile (ASCII only, no null bytes)+         -> Either String Regex -- ^ Returns: the compiled regular expression+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)++instance RegexMaker Regex CompOption ExecOption String where+  makeRegexOpts c e source = unwrap (compile c e source)+  makeRegexOptsM c e source = either fail return $ compile c e source++execute :: Regex      -- ^ Compiled regular expression+        -> String     -- ^ String to match against+        -> Either String (Maybe MatchArray)+execute r s = Right (matchOnce r s)++regexec :: Regex      -- ^ Compiled regular expression+        -> String     -- ^ String to match against+        -> Either String (Maybe (String, String, String, [String]))+regexec r s =+  case matchOnceText r s of+    Nothing -> Right Nothing+    Just (pre,mt,post) ->+      let main = fst (mt!0)+          rest = map fst (tail (elems mt)) -- will be []+      in Right (Just (pre,main,post,rest))++-- Minimal defintion for now+instance RegexLike Regex String where+  matchOnce = findMatch+  matchAll = findMatchAll+  matchCount = countMatchAll+-- matchTest+-- matchOnceText+-- matchTextAll++instance RegexContext Regex String String where+  match = polymatch+  matchM = polymatchM
+ Text/Regex/TDFA/TDFA.hs view
@@ -0,0 +1,243 @@+-- | "Text.Regex.TDFA.TDFA" converts the QNFA from TNFA into the DFA.+-- 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++--import Control.Arrow((***))+import Control.Monad.Instances()+import Control.Monad.RWS+import Data.Array.IArray(Array,(!),bounds)+import Data.IntMap(IntMap)+import qualified Data.IntSet as ISet(empty,singleton,null)+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 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.TNFA(patternToNFA)+-- import Debug.Trace++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++err :: String -> a+err s = common_error "Text.Regex.TDFA.TDFA"  s++dlose :: DFA+dlose = DFA { d_id = ISet.empty+            , d_dt = Simple' { dt_win = IMap.empty+                             , dt_trans = Map.empty+                             , dt_other = Nothing } }++{-+-- Specilized utility+ungroupBy :: (a->x) -> ([a]->y) -> [[a]] -> [(x,y)]+ungroupBy f g = map helper where+  helper [] = (err "empty group passed to ungroupBy",g [])+  helper x@(x1:_) = (f x1,g x)+-}+-- dumb smart constructor for tracing construction (I wanted to monitor laziness)+{-# INLINE makeDFA #-}+makeDFA :: SetIndex -> DT -> DFA+makeDFA i dt = DFA i dt++-- Note that no CompOption 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+  dfa = indexesToDFA [startIndex]++  indexesToDFA = {-# SCC "nfaToDFA.indexesToDFA" #-} Trie.lookupAsc trie  -- Lookup in cache+    where trie :: TrieSet DFA+          trie = Trie.fromSinglesMerge dlose mergeDFA (bounds aQNFA) indexToDFA++  indexToDFA :: Index -> DFA  -- used to seed the Trie from the NFA+  indexToDFA i = {-# SCC "nfaToDFA.indexToDFA" #-} makeDFA (ISet.singleton source) (qtToDT qtIn)+    where+      (QNFA {q_id = source,q_qt = qtIn}) = aQNFA!i+      qtToDT :: QT -> DT+      qtToDT (Testing {qt_test=wt, qt_dopas=dopas, qt_a=a, qt_b=b}) =+          Testing' { dt_test = wt+                   , dt_dopas = dopas+                   , dt_a = qtToDT a+                   , dt_b = qtToDT b }+      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)}+        where+          makeWinner :: IntMap {- Index -} Instructions --  (RunState ())+          makeWinner | noWin w = IMap.empty+                     | otherwise = IMap.singleton source (cleanWin w)++          qtransToDFA :: QTrans -> (DFA,DTrans)+          qtransToDFA qtrans = {-# SCC "nfaToDFA.indexToDFA.qtransToDFA" #-}+                               (indexesToDFA destinations,dtrans)+            where+              dtrans :: DTrans+              dtrans = IMap.fromDistinctAscList . mapSnd (IMap.singleton source) $ best+              destinations :: [Index]+              destinations = map fst best+              best :: [(Index,(DoPa,Instructions))]+              best = pickQTrans aTagOp $ qtrans++  -- The DFA states are built up by merging the singleton ones converted from the NFA+  mergeDFA :: DFA -> DFA -> DFA+  mergeDFA d1 d2 = {-# SCC "nfaToDFA.mergeDFA" #-} makeDFA i dt+    where+      i = d_id d1 `mappend` d_id d2+      dt = d_dt d1 `mergeDT` d_dt d2+      mergeDT,nestDT :: DT -> DT -> DT+      mergeDT (Simple' w1 t1 o1) (Simple' w2 t2 o2) = Simple' w t o+        where+          w = w1 `mappend` w2+          t = fuseDTrans -- t1 o1 t2 o2+          o = case (o1,o2) of+                (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)+            where dtrans = IMap.unionWith IMap.union dt1 dt2+          -- This is very much like fuseQTrans+          fuseDTrans :: CharMap (DFA,DTrans)+          fuseDTrans = CharMap (IMap.fromDistinctAscList (fuse l1 l2))+            where+              l1 = IMap.toAscList (unCharMap t1)+              l2 = IMap.toAscList (unCharMap t2)+              merge_o1 = case o1 of Nothing -> id+                                    Just o1' -> mergeDTrans o1'+              merge_o2 = case o2 of Nothing -> id+                                    Just o2' -> mergeDTrans o2'+              fuse [] y = if isJust o1 then mapSnd merge_o1 y else y+              fuse x [] = if isJust o2 then mapSnd merge_o2 x else x+              fuse x@((xc,xa):xs) y@((yc,ya):ys) = +                case compare xc yc of+                  LT -> (xc,merge_o2 xa) : fuse xs y+                  EQ -> (xc,mergeDTrans xa ya) : fuse xs ys+                  GT -> (yc,merge_o1 ya) : fuse x ys+      mergeDT dt1@(Testing' wt1 dopas1 a1 b1) dt2@(Testing' wt2 dopas2 a2 b2) =+        case compare wt1 wt2 of+          LT -> nestDT dt1 dt2+          EQ -> Testing' { dt_test = wt1+                         , dt_dopas = dopas1 `mappend` dopas2+                         , dt_a = mergeDT a1 a2+                         , dt_b = mergeDT b1 b2 }+          GT -> nestDT dt2 dt1+      mergeDT dt1@(Testing' {}) dt2 = nestDT dt1 dt2+      mergeDT dt1 dt2@(Testing' {}) = nestDT dt2 dt1+      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)++dfaMap :: DFA -> Data.Map.Map SetIndex DFA+dfaMap = seen (Data.Map.empty) where+  seen old d@(DFA {d_id=i,d_dt=dt}) =+    if i `Data.Map.member` old+      then old+      else let new = Data.Map.insert i d old+           in foldl' seen new (flattenDT dt)++flattenDT :: DT -> [DFA]+flattenDT (Simple' {dt_trans=(CharMap mt),dt_other=mo}) = map fst . 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++{-++fillMap :: Tag -> IntMap (Position,Bool)+fillMap tag = IMap.fromDistinctAscList [(t,(-1,True)) | t <- [0..tag] ]++diffMap :: IntMap (Position,Bool) -> IntMap (Position,Bool) -> [(Index,(Position,Bool))]+diffMap old new = IMap.toList (IMap.differenceWith (\a b -> if a==b then Nothing else Just b) old new)++examineDFA :: (DFA,Index,Array Tag OP,Array GroupIndex [GroupInfo]) -> String+examineDFA (dfa,_,aTags,_) = unlines $ map (examineDFA' (snd . bounds $ aTags)) (Map.elems $ dfaMap dfa)++examineDFA' :: Tag -> DFA -> String+examineDFA' maxTag = showDFA (fillMap maxTag)++{-+instance Show DFA where+  show (DFA {d_id=i,d_dt=dt}) = "DFA {d_id = "++show (ISet.toList i)+                            ++"\n    ,d_dt = "++ show dt+                            ++"\n}"+-}+-- instance Show DT where show = showDT++showDFA :: IntMap (Position,Bool) -> DFA -> String+showDFA m (DFA {d_id=i,d_dt=dt}) = "DFA {d_id = "++show (ISet.toList i)+                               ++"\n    ,d_dt = "++ showDT m dt+                               ++"\n}"+-}++++-- pick QTrans can be told the unique source and knows all the+-- destinations (hmm...along with qt_win)!  So if in ascending destination order the last source+-- is free to mutatate the old state.  If the QTrans has only one+-- entry then all we need to do is mutate that entry when making a+-- transition.+-- +pickQTrans :: Array Tag OP -> QTrans -> [({-Destination-}Index,(DoPa,Instructions))]+pickQTrans op tr = mapSnd (bestTrans op) . IMap.toList $ tr++cleanWin :: WinTags -> Instructions+cleanWin = toInstructions++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+  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+         GT -> win+         LT -> (dopa2,next)+         EQ -> if dopa1 >= dopa2 then win else (dopa2,next) -- no deep reason not to just pick win+  choose Nothing Nothing = EQ+  choose Nothing x = flipOrder (choose x 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)+  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)+++isDTLosing :: DT -> Bool+isDTLosing (Testing' {dt_a=a,dt_b=b}) = isDTLosing a && isDTLosing b+isDTLosing (Simple' {dt_win=w,dt_trans=(CharMap t),dt_other=o}) | not (IMap.null w) = False+    | Just (dfa,_) <- o, not (ISet.null (d_id dfa)) = False+    | otherwise =+  let destinations = map (d_id . fst) . IMap.elems $ t+  in all ISet.null destinations -- True for empty list of destinations++-- 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+isDTFrontAnchored _ = False++isDFAFrontAnchored :: DFA -> Bool+isDFAFrontAnchored = isDTFrontAnchored . d_dt
+ Text/Regex/TDFA/TNFA.hs view
@@ -0,0 +1,712 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- XXX design uncertainty:  should preResets be inserted into nullView?+-- if not, why not? ADDED++-- XXX design uncertainty: what does act -> actNullable ->+-- actNullableTagless not use nullQ and same for inStar, etc?+-- TODO : try rewriting whole qToNFA in terms of "act"+-- (That will require re-organizing the continuation data a bit)++-- | "Text.Regex.TDFA.TNFA" converts the CorePattern Q/P data (and its+-- Pattern leafs) to a QNFA tagged non-deterministic finite automata.+-- +-- This holds every possible way to follow one state by another, while+-- in the DFA these will be reduced by picking a single best+-- transition for each (soure,destination) pair.  The transitions are+-- heavily and often redundantly annotated with tasks to perform, and+-- this redundancy is reduced when picking the best transition.  So+-- far, keeping all this information has helped fix bugs in both the+-- design and implementation.+--+-- The QNFA for a Pattern with a starTraned Q/P form with N one+-- character accepting leaves has at most N+1 nodes.  These nodes+-- repesent the future choices after accepting a leaf.  The processing+-- of Or nodes often reduces this number by sharing at the end of the+-- different paths.  Turning off capturing while compiling the pattern+-- may (future extension) reduce this further for some patterns by+-- processing Star with optimizations.  This compact design also means+-- that tags are assigned not just to be updated before taking a+-- transition (PreUpdate) but also after the transition (PostUpdate).+-- +-- Uses recursive do notation.++module Text.Regex.TDFA.TNFA(patternToNFA+                           ,QNFA(..),QT(..),QTrans,TagUpdate(..)) where++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++import Control.Monad.State+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 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+import Text.Regex.TDFA.CorePattern(Q(..),P(..),OP(..),WhichTest,cleanNullView,NullView+                                  ,SetTestInfo(..),Wanted(..),TestInfo+                                  ,mustAccept,cannotAccept,patternToQ)+import Text.Regex.TDFA.Pattern(Pattern(..))+import Text.Regex.TDFA.ReadRegex(decodePatternSet)+import Debug.Trace++err :: String -> a+err t = common_error "Text.Regex.TDFA.TNFA" t++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)+  (Simple w1 (CharMap t1) o1) == (Simple w2 (CharMap t2) o2) =+    w1 == w2 && eqTrans && eqQTrans o1 o2+    where eqTrans :: Bool+          eqTrans = (IMap.size t1 == IMap.size t2)+                    && and (zipWith together (IMap.toAscList t1) (IMap.toAscList t2))+            where together (c1,qtrans1) (c2,qtrans2) = (c1 == c2) && eqQTrans qtrans1 qtrans2+          eqQTrans :: QTrans -> QTrans -> Bool+          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 = Simple {qt_win=[(1,PreUpdate TagTask)],qt_trans=mempty,qt_other=mempty}+qtlose = Simple {qt_win=mempty,qt_trans=mempty,qt_other=mempty}++patternToNFA :: CompOption+             -> (Text.Regex.TDFA.Pattern.Pattern,(GroupIndex, DoPa))+             -> ((Index,Array Index QNFA)+                ,Array Tag OP+                ,Array GroupIndex [GroupInfo])+patternToNFA compOpt pattern =+  let (q,tags,groups) = patternToQ compOpt pattern+      msg = unlines [ show q ]+  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)++nullable :: Q -> Bool+nullable = not . null . nullQ++notNullable :: Q -> Bool+notNullable = null . nullQ++-- This asks if the preferred (i.e. first) NullView has no tests.+maybeOnlyEmpty :: Q -> Maybe WinTags+maybeOnlyEmpty (Q {nullQ = ((SetTestInfo sti,tags):_)}) = if EMap.null sti then Just tags else Nothing+maybeOnlyEmpty _ = Nothing++usesQNFA :: Q -> Bool+usesQNFA (Q {wants=WantsBoth}) = True+usesQNFA (Q {wants=WantsQNFA}) = True+usesQNFA _ = False++nullQT :: QT -> Bool+nullQT (Simple {qt_win=w,qt_trans=t,qt_other=o}) = noWin w && Map.null t && IMap.null o+nullQT _ = False++listTestInfo :: QT -> EnumSet WhichTest -> EnumSet WhichTest+listTestInfo qt s = execState (helper qt) s+  where helper (Simple {}) = return ()+        helper (Testing {qt_test = wt, qt_a = a, qt_b = b}) = do+          modify (Set.insert wt)+          helper a+          helper b+-- This is used to view "win" only through NullView+applyNullViews :: NullView -> QT -> QT+applyNullViews [] win = win+applyNullViews nvs win = foldl' (dominate win winTests) qtlose (reverse $ cleanNullView nvs) where+  winTests = listTestInfo win $ mempty++-- This is used to prefer to view "win" through NullView.  Losing is+-- replaced by the plain win.  This is employed by Star patterns to+-- express that the first iteration is allowed to match null, but+-- 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++dominate :: QT -> EnumSet WhichTest -> QT -> (SetTestInfo,WinTags) -> QT+dominate win winTests 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+      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+            (lA,lB,lD) = branches l+            branches qt@(Testing {}) | aTest==qt_test qt = (qt_a qt,qt_b qt,qt_dopas qt)+            branches qt = (qt,qt,mempty)+        in if aTest == dTest+             then Testing {qt_test = aTest+                          ,qt_dopas = (dopas `mappend` wD) `mappend` lD+                          ,qt_a = useTest tests ds wA lA+                          ,qt_b = lB}+             else Testing {qt_test = aTest+                          ,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"+  in useTest (Set.toList allTests) (EMap.assocs sti) win' lose++applyTest :: TestInfo -> QT -> QT+applyTest (wt,dopa) qt | nullQT qt = qt+                       | otherwise = applyTest' qt where+  applyTest' :: QT -> QT+  applyTest' q@(Simple {}) =+    mkTesting $ Testing {qt_test = wt+                        ,qt_dopas = Set.singleton dopa+                        ,qt_a = q +                        ,qt_b = qtlose}+  applyTest' q@(Testing {qt_test=wt'}) =+    case compare wt wt' of+      LT -> Testing {qt_test = wt+                    ,qt_dopas = Set.singleton dopa+                    ,qt_a = q+                    ,qt_b = qtlose}+      EQ -> q {qt_dopas = Set.insert dopa (qt_dopas q)+              ,qt_b = qtlose}+      GT -> q {qt_a = applyTest' (qt_a q)+              ,qt_b = applyTest' (qt_b q)}++-- Three ways to merge a pair of QT's varying how winning transitions+-- are handled.+--+-- mergeQT_2nd is used by the NonEmpty case+--+-- mergeAltQT is used by the Or cases+--+-- +mergeQT_2nd,mergeAltQT,mergeQT :: QT -> QT -> QT+mergeQT_2nd q1 q2 | nullQT q1 = q2  -- prefer winning with w1 then with w2+                  | otherwise = mergeQTWith (\_ w2 -> w2) q1 q2++mergeAltQT q1 q2 | nullQT q1 = q2  -- prefer winning with w1 then with w2+                 | otherwise = mergeQTWith (\w1 w2 -> if noWin w1 then w2 else w1) q1 q2+mergeQT q1 q2 | nullQT q1 = q2  -- union wins+              | nullQT q2 = q1  -- union wins+              | otherwise = mergeQTWith mappend q1 q2 -- no preference, win with combined SetTag XXX is the wrong thing! "(.?)*"++-- This takes a function which implements a policy on mergining+-- winning transitions and then merges all the transitions.  It opens+-- the CharMap newtype for more efficient operation, then rewraps it.+mergeQTWith :: (WinTags -> WinTags -> WinTags) -> QT -> QT -> QT+mergeQTWith mergeWins = merge where+  merge :: QT -> QT -> QT+  merge (Simple w1 t1 o1) (Simple w2 t2 o2) =+    let w' = mergeWins w1 w2+        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 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)}+      EQ -> Testing {qt_test = wt1 -- same as wt2+                    ,qt_dopas = mappend ds1 ds2+                    ,qt_a = merge a1 a2+                    ,qt_b = merge b1 b2}+      GT -> t2 {qt_a=(merge t1 a2), qt_b=(merge t1 b2)}++  fuseQTrans :: (CharMap QTrans) -> QTrans+             -> (CharMap QTrans) -> QTrans+             -> CharMap QTrans+  fuseQTrans (CharMap t1) o1 (CharMap t2) o2 = CharMap (IMap.fromDistinctAscList (fuse l1 l2)) where+    l1 = IMap.toAscList t1+    l2 = IMap.toAscList t2+    fuse [] y  = mapSnd (mergeQTrans o1) y+    fuse x  [] = mapSnd (mergeQTrans o2) x+    fuse x@((xc,xa):xs) y@((yc,ya):ys) =+      case compare xc yc of+        LT -> (xc,mergeQTrans xa o2) : fuse xs y+        EQ -> (xc,mergeQTrans xa ya) : fuse xs ys+        GT -> (yc,mergeQTrans o1 ya) : fuse x  ys++  mergeQTrans :: QTrans -> QTrans -> QTrans+  mergeQTrans = IMap.unionWith mappend++-- Type of State monad used inside qToNFA+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 ActCont = (E, Maybe E, Maybe (TagTasks,QNFA))++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):))+  return qnfa++-- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == -- == ++fromQNFA :: QNFA -> E+fromQNFA qnfa = (mempty,Left qnfa)++fromQT :: QT -> E+fromQT qt = (mempty,Right qt)++-- Promises (Left qnfa)+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)++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)++getQT :: E -> QT+getQT (tags,cont) = prependTags' (promoteTasks PreUpdate tags) (either q_qt id cont)++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)++promoteTasks :: (TagTask->TagUpdate) -> TagTasks -> TagList+promoteTasks promote tags = map (\(tag,task) -> (tag,promote task)) tags++demoteTags :: TagList -> TagTasks+demoteTags = map helper+  where helper (tag,PreUpdate tt) = (tag,tt)+        helper (tag,PostUpdate tt) = (tag,tt)++{-# INLINE addWinTags #-}+addWinTags :: WinTags -> (TagTasks,a) -> (TagTasks,a)+addWinTags wtags (tags,cont) = (demoteTags wtags `mappend` tags,cont)++{-# INLINE addTag' #-}+addTag' :: Tag -> (TagTasks,a) -> (TagTasks,a)+addTag' tag (tags,cont) = ((tag,TagTask):tags,cont)++{-# INLINE addGroupResets #-}+addGroupResets :: (Show a) => [Tag] -> (TagTasks,a) -> (TagTasks,a)+addGroupResets [] x = x+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++{- XXX use QT form instead+enterOrbit :: Maybe Tag -> E -> E+enterOrbit Nothing e = e+enterOrbit (Just tag) (tags,cont) = ((tag,EnterOrbitTask):tags,cont)+-}++addTestAC :: TestInfo -> ActCont -> ActCont+addTestAC ti (e,mE,_) = (addTest ti e+                        ,fmap (addTest ti) mE+                        ,Nothing)++addTagAC :: Maybe Tag -> ActCont -> ActCont+addTagAC Nothing ac = ac+addTagAC (Just tag) (e,mE,mQNFA) = (addTag' tag e+                                   ,fmap (addTag' tag) mE+                                   ,fmap (addTag' tag) mQNFA)++addGroupResetsAC :: [Tag] -> ActCont -> ActCont+addGroupResetsAC [] ac = ac+addGroupResetsAC tags (e,mE,mQNFA) = (addGroupResets tags e+                                     ,fmap (addGroupResets tags) mE+                                     ,fmap (addGroupResets 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+qToNFA :: CompOption -> Q -> (Index,Array Index QNFA)+qToNFA compOpt qTop = (q_id startingQNFA+                      ,array (0,pred lastIndex) (table [])) where+  (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)+    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)++  getTransTagless qIn e = debug (">< getTransTagless "++show qIn++" <>") $+    case unQ qIn of+      Seq q1 q2 -> getTrans q1 =<< getTrans q2 e+      Or [] -> return e+      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 ]+                  else sequence [ getTrans q e | q <- qs ]+        let qts = map getQT eqts+        return (fromQT (foldr1 mergeAltQT qts))++      Star mOrbit resetTheseOrbits mayFirstBeNull 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+                       then case maybeOnlyEmpty q of+                              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+                             . 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+                              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+                                  then return . fromQNFA =<< newQNFA "getTransTagless/Star" thisQT+                                  else return . fromQT $ thisQT+                          return (thisE,ansE)+        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 -> trace ("\n> getTrans/NonEmpty"++show qIn)  $ do+        -- Assertion to check than Pattern.starTrans did its job right:+        when (cannotAccept q) (err $ "getTransTagless/NonEmpty : provided with a *cannotAccept* pattern: "++show (qTop,qIn))+        when (mustAccept q) (err $ "getTransTagless/NonEmpty : provided with a *mustAccept* pattern: "++show (qTop,qIn))+        let e' = case maybeOnlyEmpty qIn of+                   Just [] -> e+                   Just _wtags -> e -- addWinTags wtags e  XXX was duplicating tags+                   Nothing -> err $ "getTransTagless/NonEmpty is supposed to have an emptyNull nullView : "++show qIn+        mqt <- inStar q e+        return $ case mqt of+                   Nothing -> err ("Weird pattern in getTransTagless/NonEmpty: " ++ show (qTop,qIn))+                   Just qt -> fromQT . mergeQT_2nd qt . getQT $ e' -- ...and then this sets qt_win to exactly that of e'+      _ -> 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 =+    debug (">< inStar/1 "++show qIn++" <>") $+    return . Just . getQT =<< getTrans qIn eLoop+                                                 | otherwise =+    debug (">< inStar/2 "++show qIn++" <>") $+    return . fmap (prependGroupResets resets . prependTag pre) =<< inStarNullableTagless qIn (addTag post $ eLoop)+    +  inStarNullableTagless qIn eLoop = debug (">< inStarNullableTagless "++show qIn++" <>") $ do+    case unQ qIn of+      Empty -> return Nothing -- with Or this discards () branch in "(^|foo|())*"+      Or [] -> return Nothing+      Or [q] -> inStar q eLoop+      Or qs -> do+        mqts <- if usesQNFA qIn+                  then do eQNFA <- asQNFA "inStarNullableTagless/Or/usesQNFA" eLoop+                          sequence [ inStar q eQNFA | q <- qs ]+                  else sequence [inStar q eLoop | q <- qs ]+        let qts = catMaybes mqts+            mqt = if null qts then Nothing else Just (foldr1 mergeAltQT qts)+        return mqt+      Seq q1 q2 -> do (_,meAcceptingOut,_) <- actNullable q1 =<< actNullable q2 (eLoop,Nothing,Nothing)+                      return (fmap getQT meAcceptingOut)+      Star {} -> do (_,meAcceptingOut,_) <- actNullableTagless qIn (eLoop,Nothing,Nothing)+                    return (fmap getQT meAcceptingOut)+      NonEmpty {} -> trace ("\n> inStar/NonEmpty"++show qIn) $+                     do (_,meAcceptingOut,_) <- actNullableTagless qIn (eLoop,Nothing,Nothing)+                        return (fmap getQT meAcceptingOut)+      Test {} -> return Nothing -- with Or this discards ^ branch in "(^|foo|())*"+      OneChar {} -> err ("OneChar cannot have nullable True")++  {- act* functions++  These have a very complicated state that they receive and return as+  "the continuation".++   (E, Maybe E,Maybe (SetTag,QNFA))++  The first E is the source of the danger that must be avoided.  It+  starts out a reference to the QNFA/QT state that will be created by+  the most recent parent Star node.  Thus it is a recursive reference+  from the MonadFix machinery.  In particular, this value cannot be+  returned to the parent Star to be included in itself or we get a "let+  x = y; y=x" style infinite loop.++  As act* progresses the first E is actually modified to be the parent+  QNFA/QT as "seen" when all the elements to the right have accepted 0+  characters.  Thus it acquires tags and tests+tags (the NullView data+  is used for this purpose).++  The second item in the 3-tuple is a Maybe E.  This will be used as the+  source of the QT for this contents of the Star QNFA/QT.  It will be+  merged with the Star's own continuation data.  It starts out Nothing+  and stays that way as long as there are no accepting transitions in+  the Star's pattern.  This is value (via getQT) returned by inStar.++  The third item is a special optimization I added to remove a source+  of orphaned QNFAs.  A Star within Act will often have to create a+  QNFA node.  This cannot go into the second Maybe E item as Just+  (SetTag,Left QNFA) because this QNFA can have pulled values from the+  recursive parent Star's QNFA/QT in the first E value.  Thus pulling+  with getQT from the QNFA and using that as the Maybe E would likely+  cause an infinite loop.  This extra QNFA is stored in the thd3+  location for use by getE. To improve it further it can accumulate+  Tag information after being formed.++  When a non nullable Q is handled by act it checks to see if the+  third value is there, in which case it uses that QNFA as the total+  continuation (subsumed in getE).  Otherwise it merges the first E+  with any (Just E) in the second value to form the continuation.++  -}++  act :: Q -> ActCont -> S (Maybe E)+  act qIn c | nullable qIn = fmap snd3 $ actNullable qIn c+            | otherwise = debug (">< act "++show qIn++" <>") $ do+    mqt <- return . Just =<< getTrans qIn ( getE $ c )+    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 =+    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+      OneChar {} -> err ("OneChar cannot have nullable True ")+      _ -> return . addGroupResetsAC resets . addTagAC pre =<< actNullableTagless qIn ( addTagAC post $ ac )++  actNullableTagless qIn ac@(eLoop,mAccepting,mQNFA) = debug (">< actNullableTagless "++show (qIn)++" <>") $ do+    case unQ qIn of+      Seq q1 q2 -> actNullable q1 =<< actNullable q2 ac   -- We know q1 and q2 are nullable+                      +      Or [] -> return ac+      Or [q] -> actNullableTagless q ac+      Or qs -> do+        cqts <- do+          if all nullable qs+            then sequence [fmap snd3 $ actNullable q ac | q <- qs]+            else do+              e' <- asQNFA "qToNFA/actNullableTagless/Or" . getE $ ac+              let act' :: Q -> S (Maybe E)+                  act' q = return . Just =<< getTrans q e'+              sequence [ if nullable q then fmap snd3 $ actNullable q ac else act' q | q <- qs ]+        let qts = map getQT (catMaybes cqts)+            eLoop' = case maybeOnlyEmpty qIn of+                       Just wtags -> addWinTags wtags eLoop -- nullable without tests; avoid getQT+                       Nothing -> fromQT $ applyNullViews (nullQ qIn) (getQT eLoop) -- suspect this of duplicating some tags with nullQ qIn+            mAccepting' = if null qts+                            then fmap (fromQT . applyNullViews (nullQ qIn) . getQT) mAccepting -- suspect this of duplicating some tags with nullQ qIn+                            else Just (fromQT $ foldr1 mergeAltQT qts)+            mQNFA' = if null qts+                       then case maybeOnlyEmpty qIn of+                              Just wtags -> fmap (addWinTags wtags) mQNFA+                              Nothing -> Nothing+                       else Nothing+        return (eLoop',mAccepting',mQNFA')++      Star mOrbit resetTheseOrbits mayFirstBeNull q -> do+        let (ac0@(_,mAccepting0,_),clear) =+              if notNullable q+                then (ac,True)+                else if null resetTheseOrbits && isNothing mOrbit+                       then case maybeOnlyEmpty q of+                              Just [] -> (ac,True)+                              Just wtags -> (addWinTagsAC wtags ac,False)+                              _ -> let nQ = fromQT . preferNullViews (nullQ q) . getQT+                                   in ((nQ eLoop,fmap nQ mAccepting,Nothing),False)+                       else let nQ = fromQT . resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit+                                     . preferNullViews (nullQ q) . getQT . leaveOrbit mOrbit+                            in ((nQ eLoop,fmap nQ mAccepting,Nothing),False)+        if cannotAccept q then return ac0 else mdo+          mChildAccepting <- act q (this,Nothing,Nothing)+          (thisAC@(this,_,_),ansAC) <- +            case mChildAccepting of+              Nothing -> err $ "Weird pattern in getTransTagless/Star: " ++ show (qTop,qIn)+              Just childAccepting -> do+                let childQT = resetOrbitsQT resetTheseOrbits . enterOrbitQT mOrbit . getQT $ childAccepting+                    thisQT = mergeQT childQT . getQT . leaveOrbit mOrbit . getE $ ac+                    thisAccepting =+                      case mAccepting of+                        Just futureAccepting -> Just . fromQT . mergeQT childQT . getQT $ futureAccepting+                        Nothing -> Just . fromQT $ childQT+                thisAll <- if usesQNFA q+                             then do thisQNFA <- newQNFA "actNullableTagless/Star" thisQT+                                     return (fromQNFA thisQNFA, thisAccepting, Just (mempty,thisQNFA))+                             else return (fromQT thisQT, thisAccepting, Nothing)+                let skipQT = mergeQT childQT . getQT . getE $ ac0  -- for first iteration the continuation uses NullView+                    skipAccepting =+                      case mAccepting0 of+                        Just futureAccepting0 -> Just . fromQT . mergeQT childQT . getQT $ futureAccepting0+                        Nothing -> Just . fromQT $ childQT+                    ansAll = (fromQT skipQT, skipAccepting, Nothing)+                return (thisAll,ansAll)+          return (if mayFirstBeNull then (if clear then thisAC else ansAC)+                    else thisAC)+      NonEmpty q -> trace ("\n> actNullableTagless/NonEmpty"++show qIn) $ do+        -- We *know* that q is nullable from Pattern and CorePattern checks, but assert here anyway+        when (mustAccept q) (err $ "actNullableTagless/NonEmpty : provided with a *mustAccept* pattern: "++show (qTop,qIn))+        when (cannotAccept q) (err $ "actNullableTagless/NonEmpty : provided with a *cannotAccept* pattern: "++show (qTop,qIn))++        {- This is like actNullable (Or [Empty,q]) without the extra tag to prefer the first Empty branch -}+        let (clearE,_,_) = case maybeOnlyEmpty qIn of+                             Just [] -> ac+                             Just _wtags -> ac -- addWinTagsAC wtags ac XXX was duplicating tags+                             Nothing -> err $ "actNullableTagless/NonEmpty is supposed to have an emptyNull nullView : "++show (qTop,qIn)+        (_,mChildAccepting,_) <- actNullable q ac+        case mChildAccepting of+          Nothing -> err  $ "Weird pattern in actNullableTagless/NonEmpty: " ++ show (qTop,qIn)+            -- cannotAccept q checked for and excluded the above condition (and starTrans!)+          Just childAccepting -> do+            let childQT = getQT childAccepting+                thisAccepting = case mAccepting of+                                  Nothing -> Just . fromQT $ childQT+                                  Just futureAcceptingE -> Just . fromQT . mergeQT childQT . getQT $ futureAcceptingE+                                  -- I _think_ there is no need for mergeQT_2nd in the above.+            return (clearE,thisAccepting,Nothing)+      _ -> err $ "This case in Text.Regex.TNFA.TNFA.actNullableTagless cannot happen: "++show (qTop,qIn)++  -- This is applied directly to any qt immediately before passing to mergeQT+  resetOrbitsQT :: [Tag] -> QT -> QT+  resetOrbitsQT | lastStarGreedy compOpt = const id+                | otherwise = (\tags -> prependTags' [(tag,PreUpdate ResetOrbitTask)|tag<-tags])++  enterOrbitQT :: Maybe Tag -> QT -> QT+  enterOrbitQT | lastStarGreedy compOpt = const id+               | otherwise = maybe id (\tag->prependTags' [(tag,PreUpdate EnterOrbitTask)])++  leaveOrbit :: Maybe Tag -> E -> E+  leaveOrbit | lastStarGreedy compOpt = const id+             | otherwise = maybe id (\tag->(\(tags,cont)->((tag,LeaveOrbitTask):tags,cont)))++  acceptTrans :: TagList -> Pattern -> TagList -> Index -> QT+  acceptTrans pre pIn post i =+    let target = IMap.singleton i [(getDoPa pIn,pre++post)]+    in case pIn of+         PChar _ char ->+           let trans = toMap target [char]+           in Simple { qt_win = mempty, qt_trans = trans, qt_other = mempty }+         PEscape _ char ->+           let trans = toMap target [char]+           in Simple { qt_win = mempty, qt_trans = trans, qt_other = mempty }+         PDot _ -> Simple { qt_win = mempty, qt_trans = dotTrans, qt_other = target }+         PAny _ ps ->+           let trans = toMap target . Data.Set.toAscList . decodePatternSet $ ps+           in Simple { qt_win = mempty, qt_trans = trans, qt_other = mempty }+         PAnyNot _ ps ->+           let trans = toMap mempty . Data.Set.toAscList . addNewline . decodePatternSet $ ps+           in Simple { qt_win = mempty, qt_trans = trans, qt_other = target }+         _ -> err ("Cannot acceptTrans pattern "++show (qTop,pIn))+    where  -- Take a common destination and a sorted list of unique chraceters+           -- and create a map from those characters to the common destination+      toMap :: IntMap [(DoPa,[(Tag, TagUpdate)])] -> [Char]+            -> CharMap (IntMap [(DoPa,[(Tag, TagUpdate)])])+      toMap dest | caseSensitive compOpt = CharMap . IMap.fromDistinctAscList . map (\c -> (ord c,dest))+                 | otherwise = CharMap . IMap.fromList . ($ []) +                               . foldr (\c dl -> if isAlpha c+                                                   then (dl.((ord (toUpper c),dest):)+                                                           .((ord (toLower c),dest):)+                                                        )+                                                   else (dl.((ord c,dest):))+                                       ) id +      addNewline | multiline compOpt = Data.Set.insert '\n'+                 | otherwise = id+      dotTrans | multiline compOpt = Map.singleton '\n' mempty+               | otherwise = mempty+
+ Text/Regex/TDFA/Wrap.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS -fno-warn-orphans #-}+-- | "Text.Regex.TDFA.Wrap" provides the instance of RegexOptions and+-- the definition of (=~) and (=~~).  This is all re-exported by+-- "Text.Regex.TDFA".++module Text.Regex.TDFA.Wrap(Regex(..),CompOption(..),ExecOption(..),(=~),(=~~)) where++{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}++import Text.Regex.Base.RegexLike(RegexMaker(..),RegexOptions(..),RegexContext(..))+import Text.Regex.TDFA.Common(CompOption(..),ExecOption(..),Regex(..))++instance RegexOptions Regex CompOption ExecOption where+  blankCompOpt = defaultCompOpt+  blankExecOpt = defaultExecOpt+  defaultCompOpt = CompOption { caseSensitive = True+                              , multiline = True+                              , rightAssoc = True+                              , lastStarGreedy = False+                              }+  defaultExecOpt = ExecOption { captureGroups = True+                              , testMatch = False+                              }+  setExecOpts e r = r {regex_execOptions=e}+  getExecOpts r = regex_execOptions r++-- | This is the pure functional matching operator.  If the target+-- cannot be produced then some empty result will be returned.  If+-- there is an error in processing, then 'error' will be called.+(=~) :: (RegexMaker Regex CompOption ExecOption source,RegexContext Regex source1 target)+     => source1 -> source -> target+(=~) x r = let q :: Regex+               q = makeRegex r+           in match q x++-- | This is the monadic matching operator.  If a single match fails,+-- then 'fail' will be called.+(=~~) :: (RegexMaker Regex CompOption ExecOption source,RegexContext Regex source1 target,Monad m)+      => source1 -> source -> m target+(=~~) x r = do (q :: Regex) <- makeRegexM r+               matchM q x
+ regex-tdfa.cabal view
@@ -0,0 +1,58 @@+Name:                   regex-tdfa+Version:                0.92+-- Cabal-Version:       >=1.1.6+License:                BSD3+License-File:           LICENSE+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:               Replaces/Enhances Text.Regex+Description:            A new all Haskell "tagged" DFA regex engine, inspired by libtre+Category:               Text+Tested-With:            GHC+Build-Depends:          regex-base >= 0.80, base >= 2.0, parsec, mtl+-- Data-Files:+-- Extra-Source-Files:+-- Extra-Tmp-Files:+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+-- Other-Modules:+-- HS-Source-Dirs:         "."+Extensions:             MultiParamTypeClasses, FunctionalDependencies, BangPatterns+GHC-Options:            -Wall -Werror -O2 -funbox-strict-fields+-- GHC-Options:            -Wall -Werror -O2+-- GHC-Options:            -Wall -ddump-minimal-imports+-- GHC-Prof-Options:       -auto-all+-- Hugs-Options:+-- NHC-Options:+-- Includes:+-- Include-Dirs:+-- C-Sources:+-- Extra-Libraries:+-- Extra-Lib-Dirs:+-- CC-Options:+-- LD-Options:+-- Frameworks: