monoid-subclasses 0.4.0.4 → 0.4.1
raw patch · 12 files changed
+456/−57 lines, 12 filesdep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Data.Monoid.Instances.Markup: data TagSoup a b
+ Data.Monoid.Instances.Markup: instance (Eq a, Eq b) => Eq (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance (Eq a, Eq b, MonoidNull b, LeftCancellativeMonoid b) => LeftCancellativeMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance (Eq a, Eq b, MonoidNull b, LeftGCDMonoid b) => LeftGCDMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance (Eq a, Eq b, MonoidNull b, LeftReductiveMonoid b) => LeftReductiveMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance (Eq a, Eq b, MonoidNull b, RightCancellativeMonoid b) => RightCancellativeMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance (Eq a, Eq b, MonoidNull b, RightGCDMonoid b) => RightGCDMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance (Eq a, Eq b, MonoidNull b, RightReductiveMonoid b) => RightReductiveMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance (Eq a, Eq b, TextualMonoid b) => TextualMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance (IsString b, MonoidNull b) => IsString (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance FactorialMonoid b => FactorialMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance Monoid b => Monoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance Monoid b => MonoidNull (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance Monoid b => PositiveMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: instance StableFactorialMonoid b => StableFactorialMonoid (TagSoup a b)
+ Data.Monoid.Instances.Markup: soupLeaf :: MonoidNull b => b -> TagSoup a b
+ Data.Monoid.Instances.Markup: soupTag :: a -> TagSoup a b
+ Data.Monoid.Textual: toString :: TextualMonoid t => (t -> String) -> t -> String
- Data.Monoid.Textual: class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where fromText = fromString . unpack singleton = fromString . (: []) characterPrefix = fmap fst . splitCharacterPrefix map f = concatMap (singleton . f) concatMap f = foldr mappend (mappend . f) mempty all p = foldr (const id) ((&&) . p) True any p = foldr (const id) ((||) . p) False foldl ft fc = foldl (\ a prime -> maybe (ft a prime) (fc a) (characterPrefix prime)) foldr ft fc = foldr (\ prime -> maybe (ft prime) fc (characterPrefix prime)) foldl' ft fc = foldl' (\ a prime -> maybe (ft a prime) (fc a) (characterPrefix prime)) foldl_ = foldl const foldr_ = foldr (const id) foldl_' = foldl' const scanl f c = mappend (singleton c) . fst . foldl foldlOther (foldlChars f) (mempty, c) scanl1 f t = case (splitPrimePrefix t, splitCharacterPrefix t) of { (Nothing, _) -> t (Just (prefix, suffix), Nothing) -> mappend prefix (scanl1 f suffix) (Just _, Just (c, suffix)) -> scanl f c suffix } scanr f c = fst . foldr foldrOther (foldrChars f) (singleton c, c) scanr1 f = fst . foldr foldrOther fc (mempty, Nothing) where fc c (t, Nothing) = (mappend (singleton c) t, Just c) fc c1 (t, Just c2) = (mappend (singleton c') t, Just c') where c' = f c1 c2 mapAccumL f a0 = foldl ft fc (a0, mempty) where ft (a, t1) t2 = (a, mappend t1 t2) fc (a, t) c = (a', mappend t (singleton c')) where (a', c') = f a c mapAccumR f a0 = foldr ft fc (a0, mempty) where ft t1 (a, t2) = (a, mappend t1 t2) fc c (a, t) = (a', mappend (singleton c') t) where (a', c') = f a c takeWhile pt pc = fst . span pt pc dropWhile pt pc = snd . span pt pc span pt pc = span (\ prime -> maybe (pt prime) pc (characterPrefix prime)) break pt pc = break (\ prime -> maybe (pt prime) pc (characterPrefix prime)) spanMaybe s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = case splitPrimePrefix t of { Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, t, s) Nothing -> (t0, t, s) } spanMaybe' s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = seq s $ case splitPrimePrefix t of { Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, t, s) Nothing -> (t0, t, s) } takeWhile_ = takeWhile . const dropWhile_ = dropWhile . const break_ = break . const span_ = span . const spanMaybe_ s = spanMaybe s (const . Just) spanMaybe_' s = spanMaybe' s (const . Just) split p m = prefix : splitRest where (prefix, rest) = break (const False) p m splitRest = case splitCharacterPrefix rest of { Nothing -> [] Just (_, tl) -> split p tl } find p = foldr (const id) (\ c r -> if p c then Just c else r) Nothing elem c = any (== c)
+ Data.Monoid.Textual: class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where fromText = fromString . unpack singleton = fromString . (: []) characterPrefix = fmap fst . splitCharacterPrefix map f = concatMap (singleton . f) concatMap f = foldr mappend (mappend . f) mempty toString f = foldr (mappend . f) (:) [] all p = foldr (const id) ((&&) . p) True any p = foldr (const id) ((||) . p) False foldl ft fc = foldl (\ a prime -> maybe (ft a prime) (fc a) (characterPrefix prime)) foldr ft fc = foldr (\ prime -> maybe (ft prime) fc (characterPrefix prime)) foldl' ft fc = foldl' (\ a prime -> maybe (ft a prime) (fc a) (characterPrefix prime)) foldl_ = foldl const foldr_ = foldr (const id) foldl_' = foldl' const scanl f c = mappend (singleton c) . fst . foldl foldlOther (foldlChars f) (mempty, c) scanl1 f t = case (splitPrimePrefix t, splitCharacterPrefix t) of { (Nothing, _) -> t (Just (prefix, suffix), Nothing) -> mappend prefix (scanl1 f suffix) (Just _, Just (c, suffix)) -> scanl f c suffix } scanr f c = fst . foldr foldrOther (foldrChars f) (singleton c, c) scanr1 f = fst . foldr foldrOther fc (mempty, Nothing) where fc c (t, Nothing) = (mappend (singleton c) t, Just c) fc c1 (t, Just c2) = (mappend (singleton c') t, Just c') where c' = f c1 c2 mapAccumL f a0 = foldl ft fc (a0, mempty) where ft (a, t1) t2 = (a, mappend t1 t2) fc (a, t) c = (a', mappend t (singleton c')) where (a', c') = f a c mapAccumR f a0 = foldr ft fc (a0, mempty) where ft t1 (a, t2) = (a, mappend t1 t2) fc c (a, t) = (a', mappend (singleton c') t) where (a', c') = f a c takeWhile pt pc = fst . span pt pc dropWhile pt pc = snd . span pt pc span pt pc = span (\ prime -> maybe (pt prime) pc (characterPrefix prime)) break pt pc = break (\ prime -> maybe (pt prime) pc (characterPrefix prime)) spanMaybe s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = case splitPrimePrefix t of { Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, t, s) Nothing -> (t0, t, s) } spanMaybe' s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = seq s $ case splitPrimePrefix t of { Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, t, s) Nothing -> (t0, t, s) } takeWhile_ = takeWhile . const dropWhile_ = dropWhile . const break_ = break . const span_ = span . const spanMaybe_ s = spanMaybe s (const . Just) spanMaybe_' s = spanMaybe' s (const . Just) split p m = prefix : splitRest where (prefix, rest) = break (const False) p m splitRest = case splitCharacterPrefix rest of { Nothing -> [] Just (_, tl) -> split p tl } find p = foldr (const id) (\ c r -> if p c then Just c else r) Nothing elem c = any (== c)
Files
- Data/Monoid/Cancellative.hs +7/−2
- Data/Monoid/Factorial.hs +7/−6
- Data/Monoid/Instances/ByteString/UTF8.hs +4/−4
- Data/Monoid/Instances/Concat.hs +83/−10
- Data/Monoid/Instances/Markup.hs +302/−0
- Data/Monoid/Instances/Measured.hs +6/−4
- Data/Monoid/Instances/Positioned.hs +5/−4
- Data/Monoid/Instances/Stateful.hs +7/−5
- Data/Monoid/Null.hs +3/−3
- Data/Monoid/Textual.hs +16/−7
- Test/TestMonoidSubclasses.hs +9/−7
- monoid-subclasses.cabal +7/−5
Data/Monoid/Cancellative.hs view
@@ -44,10 +44,9 @@ ) where -import Prelude hiding (gcd) import qualified Prelude -import Data.Monoid (Monoid, Dual(..), Sum(..), Product(..))+import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..)) import qualified Data.List as List import Data.Maybe (isJust) import qualified Data.ByteString as ByteString@@ -63,6 +62,8 @@ import Data.Sequence (ViewL((:<)), ViewR((:>)), (<|), (|>)) import qualified Data.Vector as Vector +import Prelude hiding (gcd)+ -- | Class of all Abelian ({i.e.}, commutative) monoids that satisfy the commutativity property: -- -- > a <> b == b <> a@@ -112,6 +113,7 @@ stripPrefix :: m -> m -> Maybe m isPrefixOf a b = isJust (stripPrefix a b)+ {-# MINIMAL stripPrefix #-} -- | Class of monoids with a right inverse of 'Data.Monoid.mappend', satisfying the following law: -- @@ -126,6 +128,7 @@ stripSuffix :: m -> m -> Maybe m isSuffixOf a b = isJust (stripSuffix a b)+ {-# MINIMAL stripSuffix #-} -- | Subclass of 'LeftReductiveMonoid' where 'stripPrefix' is a complete inverse of '<>', satisfying the following -- additional law:@@ -159,6 +162,7 @@ where p = commonPrefix x y Just x' = stripPrefix p x Just y' = stripPrefix p y+ {-# MINIMAL commonPrefix | stripCommonPrefix #-} -- | Class of monoids capable of finding the equivalent of greatest common divisor on the right side of two monoidal -- values. The methods' complexity must be no worse than linear in the length of the common suffix. The following laws@@ -180,6 +184,7 @@ where s = commonSuffix x y Just x' = stripSuffix s x Just y' = stripSuffix s y+ {-# MINIMAL commonSuffix | stripCommonSuffix #-} -- Unit instances
Data/Monoid/Factorial.hs view
@@ -17,12 +17,9 @@ ) where -import Prelude hiding (break, drop, dropWhile, foldl, foldMap, foldr, last, length, map, mapM, mapM_, max, min,- null, reverse, span, splitAt, take, takeWhile)- import Control.Arrow (first) import qualified Control.Monad as Monad-import Data.Monoid (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo))+import Data.Monoid -- (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified Data.ByteString as ByteString@@ -40,6 +37,10 @@ import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) +import Prelude hiding (break, drop, dropWhile, foldl, foldr, last, length, map, mapM, mapM_, max, min,+ null, reverse, span, splitAt, take, takeWhile)++ -- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of -- a 'Product' are literally its prime factors: --@@ -255,7 +256,7 @@ f2 a = f a . fromSnd a' = foldl' f1 a0 x foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x- foldMap f (x, y) = foldMap (f . fromFst) x `mappend` foldMap (f . fromSnd) y+ foldMap f (x, y) = Data.Monoid.Factorial.foldMap (f . fromFst) x `mappend` Data.Monoid.Factorial.foldMap (f . fromSnd) y length (a, b) = length a + length b span p (x, y) = ((xp, yp), (xs, ys)) where (xp, xs) = span (p . fromFst) x@@ -636,7 +637,7 @@ -- | A 'Monad.mapM' equivalent. mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b-mapM f = ($ return mempty) . appEndo . foldMap (Endo . Monad.liftM2 mappend . f)+mapM f = ($ return mempty) . appEndo . Data.Monoid.Factorial.foldMap (Endo . Monad.liftM2 mappend . f) -- | A 'Monad.mapM_' equivalent. mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m ()
Data/Monoid/Instances/ByteString/UTF8.hs view
@@ -39,9 +39,6 @@ ) where -import Prelude hiding (any, drop, dropWhile, foldl, foldl1, foldMap, foldr, foldr1, scanl, scanr, scanl1, scanr1,- map, concatMap, break, span)- import Control.Exception (assert) import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Char (chr, ord, isDigit, isPrint)@@ -56,13 +53,16 @@ import Data.ByteString.Internal (w2c) import Data.ByteString.Unsafe (unsafeDrop, unsafeHead, unsafeTail, unsafeTake, unsafeIndex) -import Data.Monoid (Monoid(mempty, mappend))+import Data.Monoid -- (Monoid(mempty, mappend)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), LeftCancellativeMonoid, LeftGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(..), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..)) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial (FactorialMonoid(..)) import qualified Data.Monoid.Textual as Textual (TextualMonoid(..))++import Prelude hiding (any, drop, dropWhile, foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1,+ map, concatMap, break, span) newtype ByteStringUTF8 = ByteStringUTF8 ByteString deriving (Eq, Ord)
Data/Monoid/Instances/Concat.hs view
@@ -14,12 +14,11 @@ ) where -import Prelude hiding (all, any, break, filter, foldl, foldl1, foldMap, foldr, foldr1, map, concatMap,- length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)-import Control.Applicative (Applicative(..))+import Control.Applicative -- (Applicative(..)) import qualified Data.Foldable as Foldable+import qualified Data.List as List import Data.String (IsString(..))-import Data.Monoid (Monoid(..), (<>), First(..), Sum(..))+import Data.Monoid -- (Monoid(..), (<>), First(..), Sum(..)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)@@ -27,14 +26,17 @@ import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual-import Data.Sequence (Seq, empty, filter, (<|), (|>), ViewL((:<)), ViewR((:>)))+import Data.Sequence (Seq, filter, (<|), (|>), ViewL((:<)), ViewR((:>))) import qualified Data.Sequence as Seq +import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)+ -- | @'Concat' a@ is a @newtype@ wrapper around @'Seq' a@. The behaviour of the @'Concat' a@ instances of monoid -- subclasses is identical to the behaviour of their @a@ instances, up to the 'pure' isomorphism. -- -- The only purpose of 'Concat' then is to change the performance characteristics of various operations. Most--- importantly, injecting a monoid into a 'Concat' has the effect of making 'mappend' a constant-time operation.+-- importantly, injecting a monoid into a 'Concat' has the effect of making 'mappend' a logarithmic-time operation. -- newtype Concat a = Concat {extract :: Seq a} deriving Show @@ -145,7 +147,7 @@ foldr f a0 (Concat x) = Foldable.foldr g a0 x where g a b = Factorial.foldr (f . Concat . Seq.singleton) b a length (Concat x) = getSum $ Foldable.foldMap (Sum . length) x- foldMap f (Concat x) = Foldable.foldMap (foldMap (f . Concat . Seq.singleton)) x+ foldMap f (Concat x) = Foldable.foldMap (Factorial.foldMap (f . Concat . Seq.singleton)) x span p (Concat x) = case Seq.viewl x of Seq.EmptyL -> (mempty, mempty)@@ -154,6 +156,23 @@ | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs)) where (xpp, xps) = Factorial.span (p . Concat . Seq.singleton) xp (Concat xsp, xss) = Factorial.span p (Concat xs)+ spanMaybe s0 f (Concat x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'')+ | null xpp -> (mempty, Concat x, s')+ | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s')+ where (xpp, xps, s') = Factorial.spanMaybe s0 (\s-> f s . Concat . Seq.singleton) xp+ (Concat xsp, xss, s'') = Factorial.spanMaybe s' f (Concat xs)+ spanMaybe' s0 f (Concat x) =+ seq s0 $+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'')+ | null xpp -> (mempty, Concat x, s')+ | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s')+ where (xpp, xps, s') = Factorial.spanMaybe' s0 (\s-> f s . Concat . Seq.singleton) xp+ (Concat xsp, xss, s'') = Factorial.spanMaybe' s' f (Concat xs) split p (Concat x) = Foldable.foldr splitNext [mempty] x where splitNext a ~(xp:xs) = let as = fmap (Concat . Seq.singleton) (Factorial.split (p . Concat . Seq.singleton) a)@@ -169,15 +188,15 @@ where k = length xp (Concat xsp, xss) = splitAt (n - k) (Concat xs) (xpp, xps) = splitAt n xp- reverse (Concat x) = Concat (fmap reverse $ reverse x)+ reverse (Concat x) = Concat (reverse <$> reverse x) instance (IsString a) => IsString (Concat a) where- fromString "" = Concat empty+ fromString "" = Concat Seq.empty fromString s = Concat (Seq.singleton $ fromString s) instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Concat a) where- fromText t | null t = Concat empty+ fromText t | null t = Concat Seq.empty | otherwise = Concat (Seq.singleton $ fromText t) singleton = Concat . Seq.singleton . singleton splitCharacterPrefix (Concat x) =@@ -200,6 +219,7 @@ where g = Textual.foldl' (\a-> ft a . Concat . Seq.singleton) fc foldr ft fc a0 (Concat x) = Foldable.foldr g a0 x where g a b = Textual.foldr (ft . Concat . Seq.singleton) fc b a+ toString ft (Concat x) = List.concatMap (toString $ ft . Concat . Seq.singleton) (Foldable.toList x) span pt pc (Concat x) = case Seq.viewl x@@ -209,6 +229,59 @@ | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs)) where (xpp, xps) = Textual.span (pt . Concat . Seq.singleton) pc xp (Concat xsp, xss) = Textual.span pt pc (Concat xs)+ span_ bt pc (Concat x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty)+ xp :< xs | null xps -> (Concat (xp <| xsp), xss)+ | null xpp -> (mempty, Concat x)+ | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs))+ where (xpp, xps) = Textual.span_ bt pc xp+ (Concat xsp, xss) = Textual.span_ bt pc (Concat xs) break pt pc = Textual.span (not . pt) (not . pc)+ takeWhile_ bt pc = fst . span_ bt pc+ dropWhile_ bt pc = snd . span_ bt pc+ break_ bt pc = span_ (not bt) (not . pc) + spanMaybe s0 ft fc (Concat x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'')+ | null xpp -> (mempty, Concat x, s')+ | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s')+ where (xpp, xps, s') = Textual.spanMaybe s0 (\s-> ft s . Concat . Seq.singleton) fc xp+ (Concat xsp, xss, s'') = Textual.spanMaybe s' ft fc (Concat xs)+ spanMaybe' s0 ft fc (Concat x) =+ seq s0 $+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'')+ | null xpp -> (mempty, Concat x, s')+ | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s')+ where (xpp, xps, s') = Textual.spanMaybe' s0 (\s-> ft s . Concat . Seq.singleton) fc xp+ (Concat xsp, xss, s'') = Textual.spanMaybe' s' ft fc (Concat xs)+ spanMaybe_ s0 fc (Concat x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'')+ | null xpp -> (mempty, Concat x, s')+ | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s')+ where (xpp, xps, s') = Textual.spanMaybe_ s0 fc xp+ (Concat xsp, xss, s'') = Textual.spanMaybe_ s' fc (Concat xs)+ spanMaybe_' s0 fc (Concat x) =+ seq s0 $+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'')+ | null xpp -> (mempty, Concat x, s')+ | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s')+ where (xpp, xps, s') = Textual.spanMaybe_' s0 fc xp+ (Concat xsp, xss, s'') = Textual.spanMaybe_' s' fc (Concat xs)++ split p (Concat x) = Foldable.foldr splitNext [mempty] x+ where splitNext a ~(xp:xs) =+ let as = fmap (Concat . Seq.singleton) (Textual.split p a)+ in if null xp+ then as ++ xs+ else init as ++ (last as <> xp):xs find p (Concat x) = getFirst $ Foldable.foldMap (First . find p) x+ elem c (Concat x) = Foldable.any (Textual.elem c) x
+ Data/Monoid/Instances/Markup.hs view
@@ -0,0 +1,302 @@+{- + Copyright 2013-2015 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines monoid transformers that add support for markup over the base monoid type+-- ++{-# LANGUAGE Haskell2010 #-}++module Data.Monoid.Instances.Markup (+ TagSoup, soupLeaf, soupTag+ )+where++import Control.Applicative (Applicative(..))+import qualified Data.Foldable as Foldable+import Data.Functor -- ((<$>))+import qualified Data.List as List+import Data.Sequence (Seq, ViewL((:<)), ViewR((:>)), (<|), (|>))+import qualified Data.Sequence as Seq+import Data.Tree (Forest)+import qualified Data.Tree as Tree+import Data.String (IsString(..))+import Data.Monoid -- (Monoid(..))+import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..),+ LeftCancellativeMonoid, RightCancellativeMonoid,+ LeftGCDMonoid(..), RightGCDMonoid(..))+import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)+import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid)+import Data.Monoid.Textual (TextualMonoid(..))+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual++import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)++newtype TagSoup a b = TagSoup (Seq (Either a b)) deriving (Eq)++instance Monoid b => Monoid (TagSoup a b) where+ mempty = TagSoup mempty+ TagSoup s1 `mappend` TagSoup s2+ | s1' :> Right t1 <- Seq.viewr s1, Right t2 :< s2' <- Seq.viewl s2 = TagSoup ((s1' |> Right (t1 <> t2)) <> s2')+ | otherwise = TagSoup (s1 <> s2)++instance (Eq a, Eq b, MonoidNull b, LeftReductiveMonoid b) => LeftReductiveMonoid (TagSoup a b) where+ stripPrefix (TagSoup s1) (TagSoup s2)+ | s1' :> Right t1 <- Seq.viewr s1 =+ case stripPrefix s1' s2+ of Just s2' | Right t2 :< s2'' <- Seq.viewl s2', Just t2' <- stripPrefix t1 t2 -> Just (TagSoup $ consL Right t2' s2'')+ _ -> Nothing+ | otherwise = TagSoup <$> stripPrefix s1 s2++instance (Eq a, Eq b, MonoidNull b, RightReductiveMonoid b) => RightReductiveMonoid (TagSoup a b) where+ stripSuffix (TagSoup s1) (TagSoup s2)+ | Right t1 :< s1' <- Seq.viewl s1 =+ case stripSuffix s1' s2+ of Just s2' | s2'' :> Right t2 <- Seq.viewr s2', Just t2' <- stripSuffix t1 t2 -> Just (TagSoup $ consR Right s2'' t2')+ _ -> Nothing+ | otherwise = TagSoup <$> stripSuffix s1 s2++instance (Eq a, Eq b, MonoidNull b, LeftCancellativeMonoid b) => LeftCancellativeMonoid (TagSoup a b)+instance (Eq a, Eq b, MonoidNull b, RightCancellativeMonoid b) => RightCancellativeMonoid (TagSoup a b)++instance (Eq a, Eq b, MonoidNull b, LeftGCDMonoid b) => LeftGCDMonoid (TagSoup a b) where+ stripCommonPrefix (TagSoup s1) (TagSoup s2)+ | Right t1 :< s1'' <- Seq.viewl s1', Right t2 :< s2'' <- Seq.viewl s2', (tp, t1', t2') <- stripCommonPrefix t1 t2 =+ (TagSoup $ consR Right prefix tp, TagSoup $ consL Right t1' s1'', TagSoup $ consL Right t2' s2'')+ | otherwise = (TagSoup prefix, TagSoup s1', TagSoup s2')+ where (prefix, s1', s2') = stripCommonPrefix s1 s2++instance (Eq a, Eq b, MonoidNull b, RightGCDMonoid b) => RightGCDMonoid (TagSoup a b) where+ stripCommonSuffix (TagSoup s1) (TagSoup s2)+ | s1'' :> Right t1 <- Seq.viewr s1', s2'' :> Right t2 <- Seq.viewr s2', (t1', t2', ts) <- stripCommonSuffix t1 t2 =+ (TagSoup $ consR Right s1'' t1', TagSoup $ consR Right s2'' t2', TagSoup $ consR Right suffix ts)+ | otherwise = (TagSoup s1', TagSoup s2', TagSoup suffix)+ where (s1', s2', suffix) = stripCommonSuffix s1 s2++instance Monoid b => MonoidNull (TagSoup a b) where+ null (TagSoup s) = null s++instance Monoid b => PositiveMonoid (TagSoup a b)++instance FactorialMonoid b => FactorialMonoid (TagSoup a b) where+ factors (TagSoup s) = List.concatMap (either (\t-> [soupTag t]) (fmap nonNullSoupLeaf . factors)) (Foldable.toList s)+ splitPrimePrefix (TagSoup s) =+ case Seq.viewl s+ of Seq.EmptyL -> Nothing+ p@Left{} :< s' -> Just (TagSoup $ Seq.singleton p, TagSoup s')+ Right t :< s' | ~(Just (p, t')) <- splitPrimePrefix t -> Just (nonNullSoupLeaf p, TagSoup $ consL Right t' s')+ primePrefix ts@(TagSoup s) =+ case Seq.viewl s+ of Seq.EmptyL -> ts+ p@Left{} :< _ -> TagSoup (Seq.singleton p)+ Right t :< _ -> nonNullSoupLeaf (primePrefix t)+ splitPrimeSuffix (TagSoup s) =+ case Seq.viewr s+ of Seq.EmptyR -> Nothing+ s' :> p@Left{} -> Just (TagSoup s', TagSoup $ Seq.singleton p)+ s' :> Right t | ~(Just (t', p)) <- splitPrimeSuffix t -> Just (TagSoup $ consR Right s' t', nonNullSoupLeaf p)+ primeSuffix ts@(TagSoup s) =+ case Seq.viewr s+ of Seq.EmptyR -> ts+ _ :> p@Left{} -> TagSoup (Seq.singleton p)+ _ :> Right t -> nonNullSoupLeaf (primeSuffix t)+ foldl f a0 (TagSoup s) = Foldable.foldl g a0 s+ where g a p@Left{} = f a (TagSoup $ Seq.singleton p)+ g a (Right t) = Factorial.foldl (\a'-> f a' . nonNullSoupLeaf) a t+ foldl' f a0 (TagSoup s) = Foldable.foldl' g a0 s+ where g a p@Left{} = f a (TagSoup $ Seq.singleton p)+ g a (Right t) = Factorial.foldl' (\a'-> f a' . nonNullSoupLeaf) a t+ foldr f a0 (TagSoup s) = Foldable.foldr g a0 s+ where g p@Left{} a = f (TagSoup $ Seq.singleton p) a+ g (Right t) a = Factorial.foldr (f . nonNullSoupLeaf) a t+ length (TagSoup s) = getSum $ Foldable.foldMap (either (const $ Sum 1) (Sum . length)) s+ foldMap f (TagSoup s) = Foldable.foldMap (either (f . soupTag) (Factorial.foldMap $ f . nonNullSoupLeaf)) s+ span p (TagSoup x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty)+ xp@Left{} :< xs | p (TagSoup $ Seq.singleton xp) -> (TagSoup (xp <| xsp), xss)+ | otherwise -> (mempty, TagSoup x)+ where (TagSoup xsp, xss) = Factorial.span p (TagSoup xs)+ Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss)+ | null xpp -> (mempty, TagSoup x)+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs))+ where (xpp, xps) = Factorial.span (p . nonNullSoupLeaf) xp+ (TagSoup xsp, xss) = Factorial.span p (TagSoup xs)+ spanMaybe s0 f (TagSoup x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp@Left{} :< xs -> case f s0 (TagSoup $ Seq.singleton xp)+ of Just s' -> let (TagSoup xsp, xss, s'') = Factorial.spanMaybe s' f (TagSoup xs)+ in (TagSoup (xp <| xsp), xss, s'')+ Nothing -> (mempty, TagSoup x, s0)+ Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')+ | null xpp -> (mempty, TagSoup x, s')+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')+ where (xpp, xps, s') = Factorial.spanMaybe s0 (\s-> f s . nonNullSoupLeaf) xp+ (TagSoup xsp, xss, s'') = Factorial.spanMaybe s' f (TagSoup xs)+ spanMaybe' s0 f (TagSoup x) =+ seq s0 $+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp@Left{} :< xs -> case f s0 (TagSoup $ Seq.singleton xp)+ of Just s' -> let (TagSoup xsp, xss, s'') = Factorial.spanMaybe' s' f (TagSoup xs)+ in (TagSoup (xp <| xsp), xss, s'')+ Nothing -> (mempty, TagSoup x, s0)+ Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')+ | null xpp -> (mempty, TagSoup x, s')+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')+ where (xpp, xps, s') = Factorial.spanMaybe' s0 (\s-> f s . nonNullSoupLeaf) xp+ (TagSoup xsp, xss, s'') = Factorial.spanMaybe' s' f (TagSoup xs)+ split p (TagSoup x) = Foldable.foldr splitNext [mempty] x+ where splitNext t@Left{} ~l@(xp:xs)+ | p (TagSoup $ Seq.singleton t) = mempty:l+ | otherwise = (TagSoup (Seq.singleton t) <> xp):xs+ splitNext (Right t) ~(xp:xs) =+ let ts = soupLeaf <$> Factorial.split (p . nonNullSoupLeaf) t+ in if null xp+ then ts ++ xs+ else init ts ++ (last ts <> xp):xs+ splitAt 0 s = (mempty, s)+ splitAt n (TagSoup x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty)+ xp@Left{} :< xs -> (TagSoup (xp <| xsp), xss)+ where (TagSoup xsp, xss) = splitAt (n - 1) (TagSoup xs)+ Right xp :< xs | k < n -> (TagSoup (Right xp <| xsp), xss)+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup $ consL Right xps xs)+ where k = length xp+ (TagSoup xsp, xss) = splitAt (n - k) (TagSoup xs)+ (xpp, xps) = splitAt n xp+ reverse (TagSoup x) = TagSoup (either Left (Right . reverse) <$> reverse x)++instance StableFactorialMonoid b => StableFactorialMonoid (TagSoup a b)++instance (IsString b, MonoidNull b) => IsString (TagSoup a b) where+ fromString s = soupLeaf (fromString s)++instance (Eq a, Eq b, TextualMonoid b) => TextualMonoid (TagSoup a b) where+ splitCharacterPrefix (TagSoup s) =+ case Seq.viewl s+ of Right t :< s' | Just (c, t') <- splitCharacterPrefix t -> Just (c, TagSoup $ consL Right t' s')+ _ -> Nothing+ characterPrefix (TagSoup s) =+ case Seq.viewl s+ of Right t :< _ -> characterPrefix t+ _ -> Nothing+ fromText = soupLeaf . fromText+ singleton = nonNullSoupLeaf . singleton+ map f (TagSoup x) = TagSoup (fmap (either Left $ Right . map f) x)+ any p (TagSoup x) = Foldable.any (either (const False) $ any p) x+ all p (TagSoup x) = Foldable.all (either (const False) $ all p) x+ foldl ft fc a0 (TagSoup x) = Foldable.foldl g a0 x+ where g a (Right t) = Textual.foldl (\a1-> ft a1 . nonNullSoupLeaf) fc a t+ g a t@Left{} = ft a (TagSoup $ Seq.singleton t)+ foldl' ft fc a0 (TagSoup x) = Foldable.foldl' g a0 x+ where g a t@Left{} = a `seq` ft a (TagSoup $ Seq.singleton t)+ g a (Right t) = Textual.foldl' (\a1-> ft a1 . nonNullSoupLeaf) fc a t+ foldr ft fc a0 (TagSoup x) = Foldable.foldr g a0 x+ where g t@Left{} a = ft (TagSoup $ Seq.singleton t) a+ g (Right t) a = Textual.foldr (ft . nonNullSoupLeaf) fc a t+ toString ft (TagSoup x) = List.concatMap (either (ft . soupTag) (toString $ ft . nonNullSoupLeaf)) (Foldable.toList x)+ span pt pc (TagSoup x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty)+ xp@Left{} :< xs | pt (TagSoup $ Seq.singleton xp) -> (TagSoup (xp <| xsp), xss)+ | otherwise -> (mempty, TagSoup x)+ where (TagSoup xsp, xss) = Textual.span pt pc (TagSoup xs)+ Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss)+ | null xpp -> (mempty, TagSoup x)+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs))+ where (xpp, xps) = Textual.span (pt . nonNullSoupLeaf) pc xp+ (TagSoup xsp, xss) = Textual.span pt pc (TagSoup xs)+ span_ bt pc (TagSoup x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty)+ xp@Left{} :< xs -> if bt then (TagSoup (xp <| xsp), xss) else (mempty, TagSoup x)+ where (TagSoup xsp, xss) = Textual.span_ bt pc (TagSoup xs)+ Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss)+ | null xpp -> (mempty, TagSoup x)+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs))+ where (xpp, xps) = Textual.span_ bt pc xp+ (TagSoup xsp, xss) = Textual.span_ bt pc (TagSoup xs)+ break pt pc = Textual.span (not . pt) (not . pc)+ takeWhile_ bt pc = fst . span_ bt pc+ dropWhile_ bt pc = snd . span_ bt pc+ break_ bt pc = span_ (not bt) (not . pc)+ spanMaybe s0 ft fc (TagSoup x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp@Left{} :< xs | Just s' <- ft s0 (TagSoup $ Seq.singleton xp),+ (TagSoup xsp, xss, s'') <- Textual.spanMaybe s' ft fc (TagSoup xs) -> (TagSoup (xp <| xsp), xss, s'')+ | otherwise -> (mempty, TagSoup x, s0)+ Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')+ | null xpp -> (mempty, TagSoup x, s')+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')+ where (xpp, xps, s') = Textual.spanMaybe s0 (\s-> ft s . nonNullSoupLeaf) fc xp+ (TagSoup xsp, xss, s'') = Textual.spanMaybe s' ft fc (TagSoup xs)+ spanMaybe' s0 ft fc (TagSoup x) =+ seq s0 $+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp@Left{} :< xs | Just s' <- ft s0 (TagSoup $ Seq.singleton xp),+ (TagSoup xsp, xss, s'') <- Textual.spanMaybe' s' ft fc (TagSoup xs) -> (TagSoup (xp <| xsp), xss, s'')+ | otherwise -> (mempty, TagSoup x, s0)+ Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')+ | null xpp -> (mempty, TagSoup x, s')+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')+ where (xpp, xps, s') = Textual.spanMaybe' s0 (\s-> ft s . nonNullSoupLeaf) fc xp+ (TagSoup xsp, xss, s'') = Textual.spanMaybe' s' ft fc (TagSoup xs)+ spanMaybe_ s0 fc (TagSoup x) =+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp@Left{} :< xs | (TagSoup xsp, xss, s') <- Textual.spanMaybe_ s0 fc (TagSoup xs) -> (TagSoup (xp <| xsp), xss, s')+ | otherwise -> (mempty, TagSoup x, s0)+ Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')+ | null xpp -> (mempty, TagSoup x, s')+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')+ where (xpp, xps, s') = Textual.spanMaybe_ s0 fc xp+ (TagSoup xsp, xss, s'') = Textual.spanMaybe_ s' fc (TagSoup xs)+ spanMaybe_' s0 fc (TagSoup x) =+ seq s0 $+ case Seq.viewl x+ of Seq.EmptyL -> (mempty, mempty, s0)+ xp@Left{} :< xs | (TagSoup xsp, xss, s') <- Textual.spanMaybe_' s0 fc (TagSoup xs) -> (TagSoup (xp <| xsp), xss, s')+ | otherwise -> (mempty, TagSoup x, s0)+ Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')+ | null xpp -> (mempty, TagSoup x, s')+ | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')+ where (xpp, xps, s') = Textual.spanMaybe_' s0 fc xp+ (TagSoup xsp, xss, s'') = Textual.spanMaybe_' s' fc (TagSoup xs)+ split p (TagSoup x) = Foldable.foldr splitNext [mempty] x+ where splitNext tag@Left{} ~(xp:xs) = (TagSoup (Seq.singleton tag) <> xp):xs+ splitNext (Right t) ~(xp:xs) =+ let ts = soupLeaf <$> Textual.split p t+ in if null xp+ then ts ++ xs+ else init ts ++ (last ts <> xp):xs+ find p (TagSoup x) = getFirst $ Foldable.foldMap (First . either (const Nothing) (find p)) x+ elem c (TagSoup x) = Foldable.any (either (const False) $ Textual.elem c) x++soupLeaf :: MonoidNull b => b -> TagSoup a b+soupLeaf l | null l = TagSoup Seq.empty+ | otherwise = TagSoup (Seq.singleton $ Right l)++soupTag :: a -> TagSoup a b+soupTag = TagSoup . Seq.singleton . Left++-- Helper functions++nonNullSoupLeaf :: b -> TagSoup a b+nonNullSoupLeaf = TagSoup . Seq.singleton . Right++consL :: MonoidNull a => (a -> b) -> a -> Seq b -> Seq b+consL f t s | null t = s+ | otherwise = f t <| s++consR :: MonoidNull a => (a -> b) -> Seq b -> a -> Seq b+consR f s t | null t = s+ | otherwise = s |> f t
Data/Monoid/Instances/Measured.hs view
@@ -14,12 +14,10 @@ ) where -import Prelude hiding (all, any, break, filter, foldl, foldl1, foldMap, foldr, foldr1, map, concatMap,- length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)-import Data.Functor ((<$>))+import Data.Functor -- ((<$>)) import qualified Data.List as List import Data.String (IsString(..))-import Data.Monoid (Monoid(..))+import Data.Monoid -- (Monoid(..)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)@@ -28,6 +26,9 @@ import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual +import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)+ -- | @'Measured' a@ is a wrapper around the 'FactorialMonoid' @a@ that memoizes the monoid's 'length' so it becomes a -- constant-time operation. The parameter is restricted to the 'StableFactorialMonoid' class, which guarantees that -- @'length' (a <> b) == 'length' a + 'length' b@.@@ -108,6 +109,7 @@ foldl ft fc a0 (Measured _ x) = Textual.foldl (\a-> ft a . Measured 1) fc a0 x foldl' ft fc a0 (Measured _ x) = Textual.foldl' (\a-> ft a . Measured 1) fc a0 x foldr ft fc a0 (Measured _ x) = Textual.foldr (ft . Measured 1) fc a0 x+ toString ft (Measured _ x) = toString (ft . Measured 1) x span pt pc (Measured n x) = (xp', xs') where (xp, xs) = Textual.span (pt . Measured 1) pc x
Data/Monoid/Instances/Positioned.hs view
@@ -25,19 +25,20 @@ ) where -import Prelude hiding (all, any, break, filter, foldl, foldl1, foldMap, foldr, foldr1, lines, map, concatMap,- length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)-import Control.Applicative (Applicative(..))+import Control.Applicative -- (Applicative(..)) import qualified Data.List as List import Data.String (IsString(..)) -import Data.Monoid (Monoid(..), (<>), Endo(..))+import Data.Monoid -- (Monoid(..), (<>), Endo(..)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual++import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, lines, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) class Positioned p where extract :: p a -> a
Data/Monoid/Instances/Stateful.hs view
@@ -19,13 +19,11 @@ ) where -import Prelude hiding (all, any, break, elem, drop, filter, foldl, foldl1, foldMap, foldr, foldr1, gcd, map, concatMap,- length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, take)-import Control.Applicative (Applicative(..))-import Data.Functor ((<$>))+import Control.Applicative -- (Applicative(..))+import Data.Functor -- ((<$>)) import qualified Data.List as List import Data.String (IsString(..))-import Data.Monoid (Monoid(..), (<>))+import Data.Monoid -- (Monoid(..), (<>)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), LeftGCDMonoid(..), RightReductiveMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid)@@ -33,6 +31,9 @@ import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual +import Prelude hiding (all, any, break, elem, drop, filter, foldl, foldl1, foldr, foldr1, gcd, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, take)+ -- | @'Stateful' a b@ is a wrapper around the 'Monoid' @b@ that carries the state @a@ along. The state type @a@ must be -- a monoid as well if 'Stateful' is to be of any use. In the 'FactorialMonoid' and 'TextualMonoid' class instances, the -- monoid @b@ has the priority and the state @a@ is left for the end.@@ -160,6 +161,7 @@ f2 a = fx a . fromSnd foldl_' fc a (Stateful (t, _)) = foldl_' fc a t foldr_ fc a (Stateful (t, _)) = Textual.foldr_ fc a t+ toString fx (Stateful (t, x)) = toString (fx . fromFst) t ++ Factorial.foldMap (fx . fromSnd) x scanl f c (Stateful (t, x)) = Stateful (Textual.scanl f c t, x) scanl1 f (Stateful (t, x)) = Stateful (Textual.scanl1 f t, x)
Data/Monoid/Null.hs view
@@ -13,10 +13,8 @@ MonoidNull(..), PositiveMonoid ) where--import Prelude hiding (null) -import Data.Monoid (Monoid, First(..), Last(..), Dual(..), Sum(..), Product(..), All(getAll), Any(getAny))+import Data.Monoid -- (Monoid, First(..), Last(..), Dual(..), Sum(..), Product(..), All(getAll), Any(getAny)) import qualified Data.List as List import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LazyByteString@@ -28,6 +26,8 @@ import qualified Data.Sequence as Sequence import qualified Data.Set as Set import qualified Data.Vector as Vector++import Prelude hiding (null) -- | Extension of 'Monoid' that allows testing a value for equality with 'mempty'. The following law must hold: --
Data/Monoid/Textual.hs view
@@ -14,17 +14,14 @@ ) where -import Prelude hiding (all, any, break, concatMap, dropWhile, foldl, foldl1, foldr, foldr1, map, scanl, scanl1, scanr, scanr1,- span, takeWhile)- import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable-import Data.Functor ((<$>))+import Data.Functor -- ((<$>)) import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import Data.Text (Text)-import Data.Monoid (Monoid(mappend, mempty))+import Data.Monoid -- (Monoid(mappend, mempty)) import qualified Data.Sequence as Sequence import qualified Data.Vector as Vector import Data.String (IsString(fromString))@@ -34,6 +31,9 @@ import Data.Monoid.Factorial (FactorialMonoid) import qualified Data.Monoid.Factorial as Factorial +import Prelude hiding (all, any, break, concatMap, dropWhile, foldl, foldl1, foldr, foldr1, map, scanl, scanl1, scanr, scanr1,+ span, takeWhile)+ -- | The 'TextualMonoid' class is an extension of 'FactorialMonoid' specialized for monoids that can contain -- characters. Its methods are generally equivalent to their namesake functions from "Data.List" and "Data.Text", and -- they satisfy the following laws:@@ -79,8 +79,7 @@ -- > uncurry (mapAccumR (,)) -- > takeWhile (const True) (const True) -- > dropWhile (const False) (const False)------ A minimal instance definition must implement 'splitCharacterPrefix'.+-- > toString undefined . fromString class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where -- | Contructs a new data type instance Like 'fromString', but from a 'Text' input instead of 'String'.@@ -106,6 +105,9 @@ -- | Equivalent to 'List.concatMap' from "Data.List" with a @Char -> String@ function. Preserves all non-character -- data. concatMap :: (Char -> t) -> t -> t+ -- | Returns the list of characters the monoid contains, after having the argument function convert all its+ -- non-character factors into characters.+ toString :: (t -> String) -> t -> String -- | Equivalent to 'List.any' from "Data.List". Ignores all non-character data. any :: (Char -> Bool) -> t -> Bool -- | Equivalent to 'List.all' from "Data.List". Ignores all non-character data.@@ -187,6 +189,7 @@ map f = concatMap (singleton . f) concatMap f = foldr mappend (mappend . f) mempty+ toString f = foldr (mappend . f) (:) [] all p = foldr (const id) ((&&) . p) True any p = foldr (const id) ((||) . p) False @@ -273,6 +276,7 @@ {-# INLINE break_ #-} {-# INLINE takeWhile_ #-} {-# INLINE dropWhile_ #-}+ {-# MINIMAL splitCharacterPrefix #-} foldlChars :: TextualMonoid t => (Char -> Char -> Char) -> (t, Char) -> Char -> (t, Char) foldlOther :: Monoid t => (t, Char) -> t -> (t, Char)@@ -294,6 +298,7 @@ characterPrefix [] = Nothing map = List.map concatMap = List.concatMap+ toString = const id any = List.any all = List.all @@ -357,6 +362,7 @@ characterPrefix t = if Text.null t then Nothing else Just (Text.head t) map = Text.map concatMap = Text.concatMap+ toString = const Text.unpack any = Text.any all = Text.all @@ -419,6 +425,7 @@ characterPrefix t = if LazyText.null t then Nothing else Just (LazyText.head t) map = LazyText.map concatMap = LazyText.concatMap+ toString = const LazyText.unpack any = LazyText.any all = LazyText.all @@ -486,6 +493,7 @@ c Sequence.:< _ -> Just c map = Traversable.fmapDefault concatMap = Foldable.foldMap+ toString = const Foldable.toList any = Foldable.any all = Foldable.all @@ -551,6 +559,7 @@ characterPrefix = (Vector.!? 0) map = Vector.map concatMap = Vector.concatMap+ toString = const Vector.toList any = Vector.any all = Vector.all
Test/TestMonoidSubclasses.hs view
@@ -44,6 +44,7 @@ import Data.Sequence (Seq) import Data.Set (Set) import Data.Vector (Vector, fromList)+import Text.Show.Functions import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(ByteStringUTF8)) import Data.Monoid.Instances.Concat (Concat)@@ -372,6 +373,7 @@ ("Textual.scanr", TextualTest checkTextualScanr), ("Textual.scanl1", TextualTest checkTextualScanl1), ("Textual.scanr1", TextualTest checkTextualScanr1),+ ("Textual.toString", TextualTest checkToString), ("Textual.mapAccumL", TextualTest checkTextualMapAccumL), ("Textual.mapAccumR", TextualTest checkTextualMapAccumR), ("Textual.takeWhile", TextualTest checkTextualTakeWhile),@@ -574,11 +576,17 @@ check2 s = Textual.scanl1 f (fromString s :: a) == fromString (List.scanl1 f s) f c1 c2 = min c1 c2 -checkTextualScanr1 (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2+checkTextualScanr1 (TextualMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.scanr1 const a == a check2 s = Textual.scanr1 f (fromString s :: a) == fromString (List.scanr1 f s) f c1 c2 = min c1 c2 +checkToString (TextualMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2+ where check1 a = forAll arbitrary $ \f-> Textual.toString f a == Textual.foldr (\t s-> f t ++ s) (:) "" a+ check2 s = Textual.toString undefined (fromString s :: a) == s+ checkTextualMapAccumL (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumL (,)) ((), a) == ((), a)@@ -837,12 +845,6 @@ instance CoArbitrary b => CoArbitrary (Stateful a b) where coarbitrary = coarbitrary . Stateful.extract--instance Show a => Show (a -> Bool) where- show _ = "predicate"--instance Show a => Show (Bool -> a -> Maybe Bool) where- show _ = "stateful predicate" instance (PositiveMonoid a, MonoidNull b) => PositiveMonoid (a, b)
monoid-subclasses.cabal view
@@ -1,5 +1,5 @@ Name: monoid-subclasses-Version: 0.4.0.4+Version: 0.4.1 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid@@ -23,16 +23,18 @@ Library Exposed-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual, Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat,- Data.Monoid.Instances.Measured, Data.Monoid.Instances.Positioned, Data.Monoid.Instances.Stateful- Build-Depends: base >= 4 && < 5, bytestring >= 0.9 && < 1.0, containers >= 0.5.2.0 && < 0.6, text >= 0.11 && < 1.3,+ Data.Monoid.Instances.Markup, Data.Monoid.Instances.Measured,+ Data.Monoid.Instances.Positioned, Data.Monoid.Instances.Stateful+ Build-Depends: base >= 4.5 && < 5,+ bytestring >= 0.9 && < 1.0, containers >= 0.5.2.0 && < 0.6, text >= 0.11 && < 1.3, primes == 0.2.*, vector >= 0.9 && < 0.11 GHC-options: -Wall- GHC-prof-options: -auto-all default-language: Haskell2010 test-suite Main Type: exitcode-stdio-1.0- Build-Depends: base >= 4 && < 5, bytestring >= 0.9 && < 1.0, containers >= 0.5.2.0 && < 0.6, text >= 0.11 && < 1.3,+ Build-Depends: base >= 4.5 && < 5,+ bytestring >= 0.9 && < 1.0, containers >= 0.5.2.0 && < 0.6, text >= 0.11 && < 1.3, vector >= 0.9 && < 0.11, primes == 0.2.*, QuickCheck == 2.*, quickcheck-instances == 0.3.*, tasty >= 0.7, tasty-quickcheck >= 0.7, monoid-subclasses