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