packages feed

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 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