monoid-subclasses 0.4.2.1 → 0.4.3

raw patch · 8 files changed

+527/−265 lines, 8 filesdep ~QuickCheckdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: QuickCheck, base

API changes (from Hackage documentation)

Files

• Data/Monoid/Cancellative.hs +76/−0
• Data/Monoid/Factorial.hs +183/−0
• Data/Monoid/Instances/Concat.hs +216/−214
• Data/Monoid/Instances/Positioned.hs +2/−2
• Data/Monoid/Null.hs +7/−1
• README.md +28/−0
• Test/TestMonoidSubclasses.hs +10/−45
• monoid-subclasses.cabal +5/−3

@@ -333,6 +333,82 @@ instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (a, b) where    commonSuffix (a, b) (c, d) = (commonSuffix a c, commonSuffix b d) +-- Triple instances++instance (CommutativeMonoid a, CommutativeMonoid b, CommutativeMonoid c) => CommutativeMonoid (a, b, c)++instance (ReductiveMonoid a, ReductiveMonoid b, ReductiveMonoid c) => ReductiveMonoid (a, b, c) where+   (a1, b1, c1) </> (a2, b2, c2) = (,,) <$> (a1 </> a2) <*> (b1 </> b2) <*> (c1 </> c2)++instance (CancellativeMonoid a, CancellativeMonoid b, CancellativeMonoid c) => CancellativeMonoid (a, b, c)++instance (GCDMonoid a, GCDMonoid b, GCDMonoid c) => GCDMonoid (a, b, c) where+   gcd (a1, b1, c1) (a2, b2, c2) = (gcd a1 a2, gcd b1 b2, gcd c1 c2)++instance (LeftReductiveMonoid a, LeftReductiveMonoid b, LeftReductiveMonoid c) => LeftReductiveMonoid (a, b, c) where+   stripPrefix (a1, b1, c1) (a2, b2, c2) = (,,) <$> stripPrefix a1 a2 <*> stripPrefix b1 b2 <*> stripPrefix c1 c2+   isPrefixOf (a1, b1, c1) (a2, b2, c2) = isPrefixOf a1 a2 && isPrefixOf b1 b2 && isPrefixOf c1 c2++instance (RightReductiveMonoid a, RightReductiveMonoid b, RightReductiveMonoid c) =>+         RightReductiveMonoid (a, b, c) where+   stripSuffix (a1, b1, c1) (a2, b2, c2) = (,,) <$> stripSuffix a1 a2 <*> stripSuffix b1 b2 <*> stripSuffix c1 c2+   isSuffixOf (a1, b1, c1) (a2, b2, c2) = isSuffixOf a1 a2 && isSuffixOf b1 b2 && isSuffixOf c1 c2++instance (LeftCancellativeMonoid a, LeftCancellativeMonoid b, LeftCancellativeMonoid c) =>+         LeftCancellativeMonoid (a, b, c)++instance (RightCancellativeMonoid a, RightCancellativeMonoid b, RightCancellativeMonoid c) =>+         RightCancellativeMonoid (a, b, c)++instance (LeftGCDMonoid a, LeftGCDMonoid b, LeftGCDMonoid c) => LeftGCDMonoid (a, b, c) where+   commonPrefix (a1, b1, c1) (a2, b2, c2) = (commonPrefix a1 a2, commonPrefix b1 b2, commonPrefix c1 c2)++instance (RightGCDMonoid a, RightGCDMonoid b, RightGCDMonoid c) => RightGCDMonoid (a, b, c) where+   commonSuffix (a1, b1, c1) (a2, b2, c2) = (commonSuffix a1 a2, commonSuffix b1 b2, commonSuffix c1 c2)++-- Quadruple instances++instance (CommutativeMonoid a, CommutativeMonoid b, CommutativeMonoid c, CommutativeMonoid d) =>+         CommutativeMonoid (a, b, c, d)++instance (ReductiveMonoid a, ReductiveMonoid b, ReductiveMonoid c, ReductiveMonoid d) =>+         ReductiveMonoid (a, b, c, d) where+   (a1, b1, c1, d1) </> (a2, b2, c2, d2) = (,,,) <$> (a1 </> a2) <*> (b1 </> b2) <*> (c1 </> c2) <*> (d1 </> d2)++instance (CancellativeMonoid a, CancellativeMonoid b, CancellativeMonoid c, CancellativeMonoid d) =>+         CancellativeMonoid (a, b, c, d)++instance (GCDMonoid a, GCDMonoid b, GCDMonoid c, GCDMonoid d) => GCDMonoid (a, b, c, d) where+   gcd (a1, b1, c1, d1) (a2, b2, c2, d2) = (gcd a1 a2, gcd b1 b2, gcd c1 c2, gcd d1 d2)++instance (LeftReductiveMonoid a, LeftReductiveMonoid b, LeftReductiveMonoid c, LeftReductiveMonoid d) =>+         LeftReductiveMonoid (a, b, c, d) where+   stripPrefix (a1, b1, c1, d1) (a2, b2, c2, d2) =+      (,,,) <$> stripPrefix a1 a2 <*> stripPrefix b1 b2 <*> stripPrefix c1 c2 <*> stripPrefix d1 d2+   isPrefixOf (a1, b1, c1, d1) (a2, b2, c2, d2) =+      isPrefixOf a1 a2 && isPrefixOf b1 b2 && isPrefixOf c1 c2 && isPrefixOf d1 d2++instance (RightReductiveMonoid a, RightReductiveMonoid b, RightReductiveMonoid c, RightReductiveMonoid d) =>+         RightReductiveMonoid (a, b, c, d) where+   stripSuffix (a1, b1, c1, d1) (a2, b2, c2, d2) =+      (,,,) <$> stripSuffix a1 a2 <*> stripSuffix b1 b2 <*> stripSuffix c1 c2 <*> stripSuffix d1 d2+   isSuffixOf (a1, b1, c1, d1) (a2, b2, c2, d2) =+      isSuffixOf a1 a2 && isSuffixOf b1 b2 && isSuffixOf c1 c2 && isSuffixOf d1 d2++instance (LeftCancellativeMonoid a, LeftCancellativeMonoid b, LeftCancellativeMonoid c, LeftCancellativeMonoid d) =>+         LeftCancellativeMonoid (a, b, c, d)++instance (RightCancellativeMonoid a, RightCancellativeMonoid b, RightCancellativeMonoid c, RightCancellativeMonoid d) =>+         RightCancellativeMonoid (a, b, c, d)++instance (LeftGCDMonoid a, LeftGCDMonoid b, LeftGCDMonoid c, LeftGCDMonoid d) => LeftGCDMonoid (a, b, c, d) where+   commonPrefix (a1, b1, c1, d1) (a2, b2, c2, d2) =+      (commonPrefix a1 a2, commonPrefix b1 b2, commonPrefix c1 c2, commonPrefix d1 d2)++instance (RightGCDMonoid a, RightGCDMonoid b, RightGCDMonoid c, RightGCDMonoid d) => RightGCDMonoid (a, b, c, d) where+   commonSuffix (a1, b1, c1, d1) (a2, b2, c2, d2) =+      (commonSuffix a1 a2, commonSuffix b1 b2, commonSuffix c1 c2, commonSuffix d1 d2)+ -- Maybe instances  instance LeftReductiveMonoid x => LeftReductiveMonoid (Maybe x) where

@@ -289,6 +289,189 @@ fromSnd :: Monoid a => b -> (a, b) fromSnd b = (mempty, b) +instance (FactorialMonoid a, FactorialMonoid b, FactorialMonoid c) => FactorialMonoid (a, b, c) where+   factors (a, b, c) = List.map (\a1-> (a1, mempty, mempty)) (factors a)+                       ++ List.map (\b1-> (mempty, b1, mempty)) (factors b)+                       ++ List.map (\c1-> (mempty, mempty, c1)) (factors c)+   primePrefix (a, b, c) | not (null a) = (primePrefix a, mempty, mempty)+                         | not (null b) = (mempty, primePrefix b, mempty)+                         | otherwise = (mempty, mempty, primePrefix c)+   primeSuffix (a, b, c) | not (null c) = (mempty, mempty, primeSuffix c)+                         | not (null b) = (mempty, primeSuffix b, mempty)+                         | otherwise = (primeSuffix a, mempty, mempty)+   splitPrimePrefix (a, b, c) = case (splitPrimePrefix a, splitPrimePrefix b, splitPrimePrefix c)+                                of (Just (ap, as), _, _) -> Just ((ap, mempty, mempty), (as, b, c))+                                   (Nothing, Just (bp, bs), _) -> Just ((a, bp, mempty), (a, bs, c))+                                   (Nothing, Nothing, Just (cp, cs)) -> Just ((a, b, cp), (a, b, cs))+                                   (Nothing, Nothing, Nothing) -> Nothing+   splitPrimeSuffix (a, b, c) = case (splitPrimeSuffix a, splitPrimeSuffix b, splitPrimeSuffix c)+                                of (_, _, Just (cp, cs)) -> Just ((a, b, cp), (mempty, mempty, cs))+                                   (_, Just (bp, bs), Nothing) -> Just ((a, bp, c), (mempty, bs, c))+                                   (Just (ap, as), Nothing, Nothing) -> Just ((ap, b, c), (as, b, c))+                                   (Nothing, Nothing, Nothing) -> Nothing+   inits (a, b, c) = List.map (\a1-> (a1, mempty, mempty)) (inits a)+                     ++ List.map (\b1-> (a, b1, mempty)) (List.tail $ inits b)+                     ++ List.map (\c1-> (a, b, c1)) (List.tail $ inits c)+   tails (a, b, c) = List.map (\a1-> (a1, b, c)) (tails a)+                     ++ List.map (\b1-> (mempty, b1, c)) (List.tail $ tails b)+                     ++ List.map (\c1-> (mempty, mempty, c1)) (List.tail $ tails c)+   foldl f s0 (a, b, c) = foldl f3 (foldl f2 (foldl f1 s0 a) b) c+      where f1 x = f x . fromFstOf3+            f2 x = f x . fromSndOf3+            f3 x = f x . fromThdOf3+   foldl' f s0 (a, b, c) = a' `seq` b' `seq` foldl' f3 b' c+      where f1 x = f x . fromFstOf3+            f2 x = f x . fromSndOf3+            f3 x = f x . fromThdOf3+            a' = foldl' f1 s0 a+            b' = foldl' f2 a' b+   foldr f s (a, b, c) = foldr (f . fromFstOf3) (foldr (f . fromSndOf3) (foldr (f . fromThdOf3) s c) b) a+   foldMap f (a, b, c) = Data.Monoid.Factorial.foldMap (f . fromFstOf3) a+                         `mappend` Data.Monoid.Factorial.foldMap (f . fromSndOf3) b+                         `mappend` Data.Monoid.Factorial.foldMap (f . fromThdOf3) c+   length (a, b, c) = length a + length b + length c+   span p (a, b, c) = ((ap, bp, cp), (as, bs, cs))+      where (ap, as) = span (p . fromFstOf3) a+            (bp, bs) | null as = span (p . fromSndOf3) b+                     | otherwise = (mempty, b)+            (cp, cs) | null as && null bs = span (p . fromThdOf3) c+                     | otherwise = (mempty, c)+   spanMaybe s0 f (a, b, c) | not (null as) = ((ap, mempty, mempty), (as, b, c), s1)+                            | not (null bs) = ((ap, bp, mempty), (as, bs, c), s2)+                            | otherwise = ((ap, bp, cp), (as, bs, cs), s3)+     where (ap, as, s1) = spanMaybe s0 (\s-> f s . fromFstOf3) a+           (bp, bs, s2) = spanMaybe s1 (\s-> f s . fromSndOf3) b+           (cp, cs, s3) = spanMaybe s2 (\s-> f s . fromThdOf3) c+   spanMaybe' s0 f (a, b, c) | not (null as) = ((ap, mempty, mempty), (as, b, c), s1)+                             | not (null bs) = ((ap, bp, mempty), (as, bs, c), s2)+                             | otherwise = ((ap, bp, cp), (as, bs, cs), s3)+     where (ap, as, s1) = spanMaybe' s0 (\s-> f s . fromFstOf3) a+           (bp, bs, s2) = spanMaybe' s1 (\s-> f s . fromSndOf3) b+           (cp, cs, s3) = spanMaybe' s2 (\s-> f s . fromThdOf3) c+   splitAt n (a, b, c) = ((ap, bp, cp), (as, bs, cs))+      where (ap, as) = splitAt n a+            (bp, bs) | null as = splitAt (n - length a) b+                     | otherwise = (mempty, b)+            (cp, cs) | null as && null bs = splitAt (n - length a - length b) c+                     | otherwise = (mempty, c)+   reverse (a, b, c) = (reverse a, reverse b, reverse c)++{-# INLINE fromFstOf3 #-}+fromFstOf3 :: (Monoid b, Monoid c) => a -> (a, b, c)+fromFstOf3 a = (a, mempty, mempty)++{-# INLINE fromSndOf3 #-}+fromSndOf3 :: (Monoid a, Monoid c) => b -> (a, b, c)+fromSndOf3 b = (mempty, b, mempty)++{-# INLINE fromThdOf3 #-}+fromThdOf3 :: (Monoid a, Monoid b) => c -> (a, b, c)+fromThdOf3 c = (mempty, mempty, c)++instance (FactorialMonoid a, FactorialMonoid b, FactorialMonoid c, FactorialMonoid d) =>+         FactorialMonoid (a, b, c, d) where+   factors (a, b, c, d) = List.map (\a1-> (a1, mempty, mempty, mempty)) (factors a)+                          ++ List.map (\b1-> (mempty, b1, mempty, mempty)) (factors b)+                          ++ List.map (\c1-> (mempty, mempty, c1, mempty)) (factors c)+                          ++ List.map (\d1-> (mempty, mempty, mempty, d1)) (factors d)+   primePrefix (a, b, c, d) | not (null a) = (primePrefix a, mempty, mempty, mempty)+                            | not (null b) = (mempty, primePrefix b, mempty, mempty)+                            | not (null c) = (mempty, mempty, primePrefix c, mempty)+                            | otherwise    = (mempty, mempty, mempty, primePrefix d)+   primeSuffix (a, b, c, d) | not (null d) = (mempty, mempty, mempty, primeSuffix d)+                            | not (null c) = (mempty, mempty, primeSuffix c, mempty)+                            | not (null b) = (mempty, primeSuffix b, mempty, mempty)+                            | otherwise    = (primeSuffix a, mempty, mempty, mempty)+   splitPrimePrefix (a, b, c, d) = case (splitPrimePrefix a, splitPrimePrefix b, splitPrimePrefix c, splitPrimePrefix d)+                                   of (Just (ap, as), _, _, _) -> Just ((ap, mempty, mempty, mempty), (as, b, c, d))+                                      (Nothing, Just (bp, bs), _, _) -> Just ((a, bp, mempty, mempty), (a, bs, c, d))+                                      (Nothing, Nothing, Just (cp, cs), _) -> Just ((a, b, cp, mempty), (a, b, cs, d))+                                      (Nothing, Nothing, Nothing, Just (dp, ds)) -> Just ((a, b, c, dp), (a, b, c, ds))+                                      (Nothing, Nothing, Nothing, Nothing) -> Nothing+   splitPrimeSuffix (a, b, c, d) = case (splitPrimeSuffix a, splitPrimeSuffix b, splitPrimeSuffix c, splitPrimeSuffix d)+                                   of (_, _, _, Just (dp, ds)) -> Just ((a, b, c, dp), (mempty, mempty, mempty, ds))+                                      (_, _, Just (cp, cs), Nothing) -> Just ((a, b, cp, d), (mempty, mempty, cs, d))+                                      (_, Just (bp, bs), Nothing, Nothing) -> Just ((a, bp, c, d), (mempty, bs, c, d))+                                      (Just (ap, as), Nothing, Nothing, Nothing) -> Just ((ap, b, c, d), (as, b, c, d))+                                      (Nothing, Nothing, Nothing, Nothing) -> Nothing+   inits (a, b, c, d) = List.map (\a1-> (a1, mempty, mempty, mempty)) (inits a)+                        ++ List.map (\b1-> (a, b1, mempty, mempty)) (List.tail $ inits b)+                        ++ List.map (\c1-> (a, b, c1, mempty)) (List.tail $ inits c)+                        ++ List.map (\d1-> (a, b, c, d1)) (List.tail $ inits d)+   tails (a, b, c, d) = List.map (\a1-> (a1, b, c, d)) (tails a)+                        ++ List.map (\b1-> (mempty, b1, c, d)) (List.tail $ tails b)+                        ++ List.map (\c1-> (mempty, mempty, c1, d)) (List.tail $ tails c)+                        ++ List.map (\d1-> (mempty, mempty, mempty, d1)) (List.tail $ tails d)+   foldl f s0 (a, b, c, d) = foldl f4 (foldl f3 (foldl f2 (foldl f1 s0 a) b) c) d+      where f1 x = f x . fromFstOf4+            f2 x = f x . fromSndOf4+            f3 x = f x . fromThdOf4+            f4 x = f x . fromFthOf4+   foldl' f s0 (a, b, c, d) = a' `seq` b' `seq` c' `seq` foldl' f4 c' d+      where f1 x = f x . fromFstOf4+            f2 x = f x . fromSndOf4+            f3 x = f x . fromThdOf4+            f4 x = f x . fromFthOf4+            a' = foldl' f1 s0 a+            b' = foldl' f2 a' b+            c' = foldl' f3 b' c+   foldr f s (a, b, c, d) =+      foldr (f . fromFstOf4) (foldr (f . fromSndOf4) (foldr (f . fromThdOf4) (foldr (f . fromFthOf4) s d) c) b) a+   foldMap f (a, b, c, d) = Data.Monoid.Factorial.foldMap (f . fromFstOf4) a+                            `mappend` Data.Monoid.Factorial.foldMap (f . fromSndOf4) b+                            `mappend` Data.Monoid.Factorial.foldMap (f . fromThdOf4) c+                            `mappend` Data.Monoid.Factorial.foldMap (f . fromFthOf4) d+   length (a, b, c, d) = length a + length b + length c + length d+   span p (a, b, c, d) = ((ap, bp, cp, dp), (as, bs, cs, ds))+      where (ap, as) = span (p . fromFstOf4) a+            (bp, bs) | null as = span (p . fromSndOf4) b+                     | otherwise = (mempty, b)+            (cp, cs) | null as && null bs = span (p . fromThdOf4) c+                     | otherwise = (mempty, c)+            (dp, ds) | null as && null bs && null cs = span (p . fromFthOf4) d+                     | otherwise = (mempty, d)+   spanMaybe s0 f (a, b, c, d) | not (null as) = ((ap, mempty, mempty, mempty), (as, b, c, d), s1)+                               | not (null bs) = ((ap, bp, mempty, mempty), (as, bs, c, d), s2)+                               | not (null cs) = ((ap, bp, cp, mempty), (as, bs, cs, d), s3)+                               | otherwise = ((ap, bp, cp, dp), (as, bs, cs, ds), s4)+     where (ap, as, s1) = spanMaybe s0 (\s-> f s . fromFstOf4) a+           (bp, bs, s2) = spanMaybe s1 (\s-> f s . fromSndOf4) b+           (cp, cs, s3) = spanMaybe s2 (\s-> f s . fromThdOf4) c+           (dp, ds, s4) = spanMaybe s3 (\s-> f s . fromFthOf4) d+   spanMaybe' s0 f (a, b, c, d) | not (null as) = ((ap, mempty, mempty, mempty), (as, b, c, d), s1)+                               | not (null bs) = ((ap, bp, mempty, mempty), (as, bs, c, d), s2)+                               | not (null cs) = ((ap, bp, cp, mempty), (as, bs, cs, d), s3)+                               | otherwise = ((ap, bp, cp, dp), (as, bs, cs, ds), s4)+     where (ap, as, s1) = spanMaybe' s0 (\s-> f s . fromFstOf4) a+           (bp, bs, s2) = spanMaybe' s1 (\s-> f s . fromSndOf4) b+           (cp, cs, s3) = spanMaybe' s2 (\s-> f s . fromThdOf4) c+           (dp, ds, s4) = spanMaybe' s3 (\s-> f s . fromFthOf4) d+   splitAt n (a, b, c, d) = ((ap, bp, cp, dp), (as, bs, cs, ds))+      where (ap, as) = splitAt n a+            (bp, bs) | null as = splitAt (n - length a) b+                     | otherwise = (mempty, b)+            (cp, cs) | null as && null bs = splitAt (n - length a - length b) c+                     | otherwise = (mempty, c)+            (dp, ds) | null as && null bs && null cs = splitAt (n - length a - length b - length c) d+                     | otherwise = (mempty, d)+   reverse (a, b, c, d) = (reverse a, reverse b, reverse c, reverse d)++{-# INLINE fromFstOf4 #-}+fromFstOf4 :: (Monoid b, Monoid c, Monoid d) => a -> (a, b, c, d)+fromFstOf4 a = (a, mempty, mempty, mempty)++{-# INLINE fromSndOf4 #-}+fromSndOf4 :: (Monoid a, Monoid c, Monoid d) => b -> (a, b, c, d)+fromSndOf4 b = (mempty, b, mempty, mempty)++{-# INLINE fromThdOf4 #-}+fromThdOf4 :: (Monoid a, Monoid b, Monoid d) => c -> (a, b, c, d)+fromThdOf4 c = (mempty, mempty, c, mempty)++{-# INLINE fromFthOf4 #-}+fromFthOf4 :: (Monoid a, Monoid b, Monoid c) => d -> (a, b, c, d)+fromFthOf4 d = (mempty, mempty, mempty, d)+ instance FactorialMonoid [x] where    factors xs = List.map (:[]) xs    primePrefix [] = []

@@ -1,5 +1,5 @@ {- -    Copyright 2013-2015 Mario Blazevic+    Copyright 2013-2016 Mario Blazevic      License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -10,11 +10,12 @@ {-# LANGUAGE Haskell2010 #-}  module Data.Monoid.Instances.Concat (-   Concat, concatenate, extract+   Concat, concatenate, extract, force    ) where  import Control.Applicative -- (Applicative(..))+import Control.Arrow (first) import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.String (IsString(..))@@ -26,262 +27,263 @@ import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual-import Data.Sequence (Seq, filter, (<|), (|>), ViewL((:<)), ViewR((:>)))+import Data.Sequence (Seq) 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)+                       length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, pi) --- | @'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.+-- | @'Concat'@ is a transparent monoid transformer. 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 logarithmic-time operation.+-- importantly, injecting a monoid into 'Concat' has the effect of making 'mappend' a constant-time operation. The+-- `splitPrimePrefix` and `splitPrimeSuffix` operations are amortized to constant time, provided that only one or the+-- other is used. Using both operations alternately will trigger the worst-case behaviour of O(n). ---newtype Concat a = Concat {extract :: Seq a} deriving Show+data Concat a = Leaf a+              | Concat a :<> Concat a+              deriving Show +{-# DEPRECATED concatenate, extract "Concat is not wrapping Seq any more, don't use concatenate nor extract." #-} concatenate :: PositiveMonoid a => Seq a -> Concat a-concatenate = Concat . filter (not . null)+concatenate q+   | Foldable.all null q = mempty+   | otherwise = Foldable.foldr (\a c-> if null a then c else Leaf a <> c) mempty q +extract :: Concat a -> Seq a+extract = Seq.fromList . Foldable.toList++force :: Monoid a => Concat a -> a+force (Leaf x) = x+force (x :<> y) = force x <> force y+ instance (Eq a, Monoid a) => Eq (Concat a) where-   Concat x == Concat y = Foldable.foldMap id x == Foldable.foldMap id y+   x == y = force x == force y  instance (Ord a, Monoid a) => Ord (Concat a) where-   compare (Concat x) (Concat y) = compare (Foldable.foldMap id x) (Foldable.foldMap id y)+   compare x y = compare (force x) (force y)  instance Functor Concat where-   fmap f (Concat x) = Concat (fmap f x)+   fmap f (Leaf x) = Leaf (f x)+   fmap f (l :<> r) = fmap f l :<> fmap f r  instance Applicative Concat where-   pure a = Concat (Seq.singleton a)-   Concat x <*> Concat y = Concat (x <*> y)-   Concat x *> Concat y = Concat (x *> y)+   pure = Leaf+   Leaf f <*> x = f <$> x+   (f1 :<> f2) <*> x = (f1 <*> x) :<> (f2 <*> x) -instance Monoid (Concat a) where-   mempty = Concat Seq.empty-   mappend (Concat a) (Concat b) = Concat (mappend a b)+instance Foldable.Foldable Concat where+   fold (Leaf x) = x+   fold (x :<> y) = Foldable.fold x <> Foldable.fold y+   foldMap f (Leaf x) = f x+   foldMap f (x :<> y) = Foldable.foldMap f x <> Foldable.foldMap f y+   foldl f a (Leaf x) = f a x+   foldl f a (x :<> y) = Foldable.foldl f (Foldable.foldl f a x) y+   foldl' f a (Leaf x) = f a x+   foldl' f a (x :<> y) = let a' = Foldable.foldl' f a x in a' `seq` Foldable.foldl' f a' y+   foldr f a (Leaf x) = f x a+   foldr f a (x :<> y) = Foldable.foldr f (Foldable.foldr f a y) x+   foldr' f a (Leaf x) = f x a+   foldr' f a (x :<> y) = let a' = Foldable.foldr' f a y in Foldable.foldr' f a' x -instance MonoidNull (Concat a) where-   null (Concat x) = Seq.null x+instance PositiveMonoid a => Monoid (Concat a) where+   mempty = Leaf mempty+   mappend x y +      | null x = y+      | null y = x+      | otherwise = x :<> y -instance PositiveMonoid (Concat a)+instance PositiveMonoid a => MonoidNull (Concat a) where+   null (Leaf x) = null x+   null _ = False -instance (LeftReductiveMonoid a, MonoidNull a, StableFactorialMonoid a) => LeftReductiveMonoid (Concat a) where-   stripPrefix c1 c2 = fmap Concat $ strip1 (extract c1) (extract c2)-      where strip1 x y = strip2 (Seq.viewl x) y-            strip2 Seq.EmptyL y = Just y-            strip2 (xp :< xs) y = strip3 xp xs (Seq.viewl y)-            strip3 _ _ Seq.EmptyL = Nothing-            strip3 xp xs (yp :< ys) =-               case (stripPrefix xp yp, stripPrefix yp xp)-               of (Just yps, _) -> strip1 xs (if null yps then ys else yps <| ys)-                  (Nothing, Nothing) -> Nothing-                  (Nothing, Just xps) -> strip3 xps xs (Seq.viewl ys)+instance PositiveMonoid a => PositiveMonoid (Concat a) -instance (MonoidNull a, RightReductiveMonoid a, StableFactorialMonoid a) => RightReductiveMonoid (Concat a) where-   stripSuffix c1 c2 = fmap Concat $ strip1 (extract c1) (extract c2)-      where strip1 x y = strip2 (Seq.viewr x) y-            strip2 Seq.EmptyR y = Just y-            strip2 (xp :> xs) y = strip3 xp xs (Seq.viewr y)-            strip3 _ _ Seq.EmptyR = Nothing-            strip3 xp xs (yp :> ys) =-               case (stripSuffix xs ys, stripSuffix ys xs)-               of (Just ysp, _) -> strip1 xp (if null ysp then yp else yp |> ysp)-                  (Nothing, Nothing) -> Nothing-                  (Nothing, Just xsp) -> strip3 xp xsp (Seq.viewr yp)+instance (LeftReductiveMonoid a, StableFactorialMonoid a) => LeftReductiveMonoid (Concat a) where+   stripPrefix (Leaf x) (Leaf y) = Leaf <$> stripPrefix x y+   stripPrefix (xp :<> xs) y = stripPrefix xp y >>= stripPrefix xs+   stripPrefix x (yp :<> ys) = case (stripPrefix x yp, stripPrefix yp x)+                               of (Just yps, _) -> Just (yps <> ys)+                                  (Nothing, Nothing) -> Nothing+                                  (Nothing, Just xs) -> stripPrefix xs ys -instance (Eq a, LeftGCDMonoid a, MonoidNull a, StableFactorialMonoid a) => LeftGCDMonoid (Concat a) where-   stripCommonPrefix (Concat x) (Concat y) = strip cp1 xs1 ys1-      where (cp1, xs1, ys1) = stripCommonPrefix x y-            strip cp xs ys =-               case (Seq.viewl xs, Seq.viewl ys)-               of (Seq.EmptyL, _) -> (Concat cp, mempty, Concat ys)-                  (_, Seq.EmptyL) -> (Concat cp, Concat xs, mempty)-                  (xsp :< xss, ysp :< yss) ->-                     let (cs, xsps, ysps) = stripCommonPrefix xsp ysp-                         cp' = cp |> cs-                         prepend p s = if null p then s else p <| s-                     in if null cs-                        then (Concat cp, Concat xs, Concat ys)-                        else if null xsps && null ysps-                             then strip cp' xss yss-                             else (Concat cp', Concat $ prepend xsps xss, Concat $ prepend ysps yss)+instance (RightReductiveMonoid a, StableFactorialMonoid a) => RightReductiveMonoid (Concat a) where+   stripSuffix (Leaf x) (Leaf y) = Leaf <$> stripSuffix x y+   stripSuffix (xp :<> xs) y = stripSuffix xs y >>= stripSuffix xp+   stripSuffix x (yp :<> ys) = case (stripSuffix x ys, stripSuffix ys x)+                               of (Just ysp, _) -> Just (yp <> ysp)+                                  (Nothing, Nothing) -> Nothing+                                  (Nothing, Just xp) -> stripSuffix xp yp -instance (Eq a, RightGCDMonoid a, MonoidNull a, StableFactorialMonoid a) => RightGCDMonoid (Concat a) where-   stripCommonSuffix (Concat x) (Concat y) = strip xp1 yp1 cs1-      where (xp1, yp1, cs1) = stripCommonSuffix x y-            strip xp yp cs =-               case (Seq.viewr xp, Seq.viewr yp)-               of (Seq.EmptyR, _) -> (mempty, Concat yp, Concat cs)-                  (_, Seq.EmptyR) -> (Concat xp, mempty, Concat cs)-                  (xpp :> xps, ypp :> yps) ->-                     let (xpsp, ypsp, cp) = stripCommonSuffix xps yps-                         cs' = cp <| cs-                         append p s = if null s then p else p |> s-                     in if null cp-                        then (Concat xp, Concat yp, Concat cs)-                        else if null xpsp && null ypsp-                             then strip xpp ypp cs'-                             else (Concat $ append xpp xpsp, Concat $ append ypp ypsp, Concat cs')+instance (LeftGCDMonoid a, StableFactorialMonoid a) => LeftGCDMonoid (Concat a) where+   stripCommonPrefix (Leaf x) (Leaf y) = map3 Leaf (stripCommonPrefix x y)+   stripCommonPrefix (xp :<> xs) y+      | null xps = (xp <> xsp, xss, yss)+      | otherwise = (xpp, xps <> xs, ys)+      where (xpp, xps, ys) = stripCommonPrefix xp y+            (xsp, xss, yss) = stripCommonPrefix xs ys+   stripCommonPrefix x (yp :<> ys)+      | null yps = (yp <> ysp, xss, yss)+      | otherwise = (ypp, xs, yps <> ys)+      where (ypp, xs, yps) = stripCommonPrefix x yp+            (ysp, xss, yss) = stripCommonPrefix xs ys -instance FactorialMonoid a => FactorialMonoid (Concat a) where-   factors (Concat x) = Foldable.foldMap (fmap (Concat . Seq.singleton) . factors) x-   primePrefix (Concat x) = Concat (fmap primePrefix $ primePrefix x)-   primeSuffix (Concat x) = Concat (fmap primeSuffix $ primeSuffix x)-   splitPrimePrefix (Concat x) =-      case Seq.viewl x-           of Seq.EmptyL -> Nothing-              xp :< xs -> Just (Concat $ Seq.singleton xpp, Concat xs')-                 where Just (xpp, xps) = splitPrimePrefix xp-                       xs' = if null xps then xs else xps <| xs-   splitPrimeSuffix (Concat x) =-      case Seq.viewr x-           of Seq.EmptyR -> Nothing-              xp :> xs -> Just (Concat xp', Concat $ Seq.singleton xss)-                 where Just (xsp, xss) = splitPrimeSuffix xs-                       xp' = if null xsp then xp else xp |> xsp-   foldl f a0 (Concat x) = Foldable.foldl g a0 x-      where g = Factorial.foldl (\a-> f a . Concat . Seq.singleton)-   foldl' f a0 (Concat x) = Foldable.foldl' g a0 x-      where g = Factorial.foldl' (\a-> f a . Concat . Seq.singleton)-   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 (Factorial.foldMap (f . Concat . Seq.singleton)) x-   span p (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) = 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+instance (RightGCDMonoid a, StableFactorialMonoid a) => RightGCDMonoid (Concat a) where+   stripCommonSuffix (Leaf x) (Leaf y) = map3 Leaf (stripCommonSuffix x y)+   stripCommonSuffix (xp :<> xs) y+      | null xsp = (xpp, ypp, xps <> xs)+      | otherwise = (xp <> xsp, yp, xss)+      where (xsp, yp, xss) = stripCommonSuffix xs y+            (xpp, ypp, xps) = stripCommonSuffix xp yp+   stripCommonSuffix x (yp :<> ys)+      | null ysp = (xpp, ypp, yps <> ys)+      | otherwise = (xp, yp <> ysp, yss)+      where (xp, ysp, yss) = stripCommonSuffix x ys+            (xpp, ypp, yps) = stripCommonSuffix xp yp++instance (FactorialMonoid a, PositiveMonoid a) => FactorialMonoid (Concat a) where+   factors c = toList c []+      where toList (Leaf x) rest+               | null x = rest+               | otherwise = (Leaf <$> factors x) ++ rest+            toList (x :<> y) rest = toList x (toList y rest)+   primePrefix (Leaf x) = Leaf (primePrefix x)+   primePrefix (x :<> _) = primePrefix x+   primeSuffix (Leaf x) = Leaf (primeSuffix x)+   primeSuffix (_ :<> y) = primeSuffix y+   splitPrimePrefix (Leaf x) = map2 Leaf <$> splitPrimePrefix x+   splitPrimePrefix (x :<> y) = ((<> y) <$>) <$> splitPrimePrefix x+   splitPrimeSuffix (Leaf x) = map2 Leaf <$> splitPrimeSuffix x+   splitPrimeSuffix (x :<> y) = first (x <>) <$> splitPrimeSuffix y++   foldl f = Foldable.foldl g+      where g = Factorial.foldl (\a-> f a . Leaf)+   foldl' f = Foldable.foldl' g+      where g = Factorial.foldl' (\a-> f a . Leaf)+   foldr f = Foldable.foldr g+      where g a b = Factorial.foldr (f . Leaf) b a+   length x = getSum $ Foldable.foldMap (Sum . length) x+   foldMap f = Foldable.foldMap (Factorial.foldMap (f . Leaf))+   span p (Leaf x) = map2 Leaf (Factorial.span (p . Leaf) x)+   span p (x :<> y)+      | null xs = (x <> yp, ys)+      | otherwise = (xp, xs :<> y)+      where (xp, xs) = Factorial.span p x+            (yp, ys) = Factorial.span p y+   spanMaybe s0 f (Leaf x) = first2 Leaf (Factorial.spanMaybe s0 (\s-> f s . Leaf) x)+   spanMaybe s0 f (x :<> y)+      | null xs = (x :<> yp, ys, s2)+      | otherwise = (xp, xs :<> y, s1)+      where (xp, xs, s1) = Factorial.spanMaybe s0 f x+            (yp, ys, s2) = Factorial.spanMaybe s1 f y+   spanMaybe' s0 f c = seq s0 $+      case c+      of Leaf x -> first2 Leaf (Factorial.spanMaybe' s0 (\s-> f s . Leaf) x)+         x :<> y -> let (xp, xs, s1) = Factorial.spanMaybe' s0 f x+                        (yp, ys, s2) = Factorial.spanMaybe' s1 f y+                    in if null xs then (x :<> yp, ys, s2) else (xp, xs :<> y, s1)++   split p = Foldable.foldr splitNext [mempty]       where splitNext a ~(xp:xs) =-               let as = fmap (Concat . Seq.singleton) (Factorial.split (p . Concat . Seq.singleton) a)+               let as = Leaf <$> Factorial.split (p . Leaf) a                in if null xp                   then as ++ xs                   else init as ++ (last as <> xp):xs    splitAt 0 c = (mempty, c)-   splitAt n (Concat x) =-      case Seq.viewl x-      of Seq.EmptyL -> (mempty, mempty)-         xp :< xs | k < n -> (Concat (xp <| xsp), xss)-                  | otherwise -> (Concat $ Seq.singleton xpp, Concat (if null xps then xs else xps <| xs))-            where k = length xp-                  (Concat xsp, xss) = splitAt (n - k) (Concat xs)-                  (xpp, xps) = splitAt n xp-   reverse (Concat x) = Concat (reverse <$> reverse x)+   splitAt n (Leaf x) = map2 Leaf (Factorial.splitAt n x)+   splitAt n (x :<> y)+      | k < n = (x :<> yp, ys)+      | k > n = (xp, xs :<> y)+      | otherwise = (x, y)+      where k = length x+            (yp, ys) = splitAt (n - k) y+            (xp, xs) = splitAt n x+   reverse (Leaf x) = Leaf (reverse x)+   reverse (x :<> y) = reverse y :<> reverse x +instance (FactorialMonoid a, PositiveMonoid a) => StableFactorialMonoid (Concat a)  instance (IsString a) => IsString (Concat a) where-   fromString "" = Concat Seq.empty-   fromString s = Concat (Seq.singleton $ fromString s)+   fromString s = Leaf (fromString s)  instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Concat a) where-   fromText t | null t = Concat Seq.empty-              | otherwise = Concat (Seq.singleton $ fromText t)-   singleton = Concat . Seq.singleton . singleton-   splitCharacterPrefix (Concat x) =-      case Seq.viewl x-      of Seq.EmptyL -> Nothing-         xp :< xs -> case splitCharacterPrefix xp-                     of Just (c, xps) -> Just (c, Concat $ if null xps then xs else xps <| xs)-                        Nothing -> Nothing-   characterPrefix (Concat x) =-      case Seq.viewl x-      of Seq.EmptyL -> Nothing-         xp :< _ -> characterPrefix xp-   map f (Concat x) = Concat (fmap (map f) x)-   any p (Concat x) = Foldable.any (any p) x-   all p (Concat x) = Foldable.all (all p) x+   fromText t = Leaf (fromText t)+   singleton = Leaf . singleton+   splitCharacterPrefix (Leaf x) = (Leaf <$>) <$> splitCharacterPrefix x+   splitCharacterPrefix (x :<> y) = ((<> y) <$>) <$> splitCharacterPrefix x+   characterPrefix (Leaf x) = characterPrefix x+   characterPrefix (x :<> _) = characterPrefix x+   map f x = map f <$> x+   toString ft x = List.concatMap (toString $ ft . Leaf) (Foldable.toList x) -   foldl ft fc a0 (Concat x) = Foldable.foldl g a0 x-      where g = Textual.foldl (\a-> ft a . Concat . Seq.singleton) fc-   foldl' ft fc a0 (Concat x) = Foldable.foldl' g a0 x-      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)+   foldl ft fc = Foldable.foldl g+      where g = Textual.foldl (\a-> ft a . Leaf) fc+   foldl' ft fc = Foldable.foldl' g+      where g = Textual.foldl' (\a-> ft a . Leaf) fc+   foldr ft fc = Foldable.foldr g+      where g a b = Textual.foldr (ft . Leaf) fc b a+   any p = Foldable.any (any p)+   all p = Foldable.all (all p) -   span pt 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 (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)+   span pt pc (Leaf x) = map2 Leaf (Textual.span (pt . Leaf) pc x)+   span pt pc (x :<> y)+      | null xs = (x <> yp, ys)+      | otherwise = (xp, xs :<> y)+      where (xp, xs) = Textual.span pt pc x+            (yp, ys) = Textual.span pt pc y+   span_ bt pc (Leaf x) = map2 Leaf (Textual.span_ bt pc x)+   span_ bt pc (x :<> y)+      | null xs = (x <> yp, ys)+      | otherwise = (xp, xs :<> y)+      where (xp, xs) = Textual.span_ bt pc x+            (yp, ys) = Textual.span_ bt pc y    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)+   spanMaybe s0 ft fc (Leaf x) = first2 Leaf (Textual.spanMaybe s0 (\s-> ft s . Leaf) fc x)+   spanMaybe s0 ft fc (x :<> y)+      | null xs = (x :<> yp, ys, s2)+      | otherwise = (xp, xs :<> y, s1)+      where (xp, xs, s1) = Textual.spanMaybe s0 ft fc x+            (yp, ys, s2) = Textual.spanMaybe s1 ft fc y+   spanMaybe' s0 ft fc c = seq s0 $+      case c+      of Leaf x -> first2 Leaf (Textual.spanMaybe' s0 (\s-> ft s . Leaf) fc x)+         x :<> y -> let (xp, xs, s1) = Textual.spanMaybe' s0 ft fc x+                        (yp, ys, s2) = Textual.spanMaybe' s1 ft fc y+                    in if null xs then (x :<> yp, ys, s2) else (xp, xs :<> y, s1)+   spanMaybe_ s0 fc (Leaf x) = first2 Leaf (Textual.spanMaybe_ s0 fc x)+   spanMaybe_ s0 fc (x :<> y)+      | null xs = (x :<> yp, ys, s2)+      | otherwise = (xp, xs :<> y, s1)+      where (xp, xs, s1) = Textual.spanMaybe_ s0 fc x+            (yp, ys, s2) = Textual.spanMaybe_ s1 fc y+   spanMaybe_' s0 fc c = seq s0 $+      case c+      of Leaf x -> first2 Leaf (Textual.spanMaybe_' s0 fc x)+         x :<> y -> let (xp, xs, s1) = Textual.spanMaybe_' s0 fc x+                        (yp, ys, s2) = Textual.spanMaybe_' s1 fc y+                    in if null xs then (x :<> yp, ys, s2) else (xp, xs :<> y, s1) -   split p (Concat x) = Foldable.foldr splitNext [mempty] x+   split p = Foldable.foldr splitNext [mempty]       where splitNext a ~(xp:xs) =-               let as = fmap (Concat . Seq.singleton) (Textual.split p a)+               let as = Leaf <$> 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+   find p x = getFirst $ Foldable.foldMap (First . find p) x+   elem i = Foldable.any (Textual.elem i)++-- Utility functions++map2 :: (a -> b) -> (a, a) -> (b, b)+map2 f (x, y) = (f x, f y)++map3 :: (a -> b) -> (a, a, a) -> (b, b, b)+map3 f (x, y, z) = (f x, f y, f z)++first2 :: (a -> b) -> (a, a, c) -> (b, b, c)+first2 f (x, y, z) = (f x, f y, z)

@@ -129,9 +129,9 @@    null = null . extractLines    {-# INLINE null #-} -instance (StableFactorialMonoid m, PositiveMonoid m) => PositiveMonoid (OffsetPositioned m)+instance StableFactorialMonoid m => PositiveMonoid (OffsetPositioned m) -instance (StableFactorialMonoid m, TextualMonoid m, PositiveMonoid m) => PositiveMonoid (LinePositioned m)+instance (StableFactorialMonoid m, TextualMonoid m) => PositiveMonoid (LinePositioned m)  instance (StableFactorialMonoid m, LeftReductiveMonoid m) => LeftReductiveMonoid (OffsetPositioned m) where    isPrefixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isPrefixOf c1 c2

@@ -79,6 +79,12 @@ instance (MonoidNull a, MonoidNull b) => MonoidNull (a, b) where    null (a, b) = null a && null b +instance (MonoidNull a, MonoidNull b, MonoidNull c) => MonoidNull (a, b, c) where+   null (a, b, c) = null a && null b && null c++instance (MonoidNull a, MonoidNull b, MonoidNull c, MonoidNull d) => MonoidNull (a, b, c, d) where+   null (a, b, c, d) = null a && null b && null c && null d+ instance MonoidNull [x] where    null = List.null @@ -136,7 +142,7 @@ instance Ord a => PositiveMonoid (Set.Set a) instance PositiveMonoid (Vector.Vector a) --- Both instances are not allowed, so we leave the choice to the user.+-- The possible tuple instances would be overlapping, so we leave the choice to the user. -- -- instance (PositiveMonoid a, Monoid b) => PositiveMonoid (a, b) -- instance (Monoid a, PositiveMonoid b) => PositiveMonoid (a, b)

@@ -0,0 +1,28 @@+monoid-subclasses+=================++### Subclasses of Monoid with a solid theoretical foundation and practical purposes ###++The monoid-subclasses package has been released [on Hackage](http://hackage.haskell.org/package/monoid-subclasses). The package defines several classes that are richer than [monoids](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t:Monoid) but less demanding than [groups](http://hackage.haskell.org/packages/archive/groups/0.1.0.1/doc/html/Data-Group.html):+  * [ReductiveMonoid](http://hackage.haskell.org/packages/archive/monoid-subclasses/0.1/doc/html/Data-Monoid-Cancellative.html#t:ReductiveMonoid) provides the operator `</>` which acts as a partial inverse of the `<>` operator, _i.e._, `Monoid.mappend`.+  * [CancellativeMonoid](http://hackage.haskell.org/packages/archive/monoid-subclasses/0.1/doc/html/Data-Monoid-Cancellative.html#t:CancellativeMonoid) is a subclass of `ReductiveMonoid` that provides additional guarantees about the `</>` operation result:++        (a <> b) </> a == Just b+        (a <> b) </> b == Just a++    Every group (<em>i.e.</em>, every `Monoid a` with the operation `inverse :: a -> a`) is a `CancellativeMonoid` where `a </> b = Just (a <> inverse b)` but not every `CancellativeMonoid` is a group.+  * [GCDMonoid](http://hackage.haskell.org/packages/archive/monoid-subclasses/0.1/doc/html/Data-Monoid-Cancellative.html#t:GCDMonoid) is a subclass of `ReductiveMonoid` that provides the `gcd` operation for getting the greatest common denominator for two given monoid values.+  * [MonoidNull](http://hackage.haskell.org/packages/archive/monoid-subclasses/0.1/doc/html/Data-Monoid-Null.html) class provides the Boolean `null` operation that checks if the argument monoid is `mempty`.+  * [FactorialMonoid](http://hackage.haskell.org/packages/archive/monoid-subclasses/0.1/doc/html/Data-Monoid-Factorial.html) class represents monoids that can be split up into irreducible factors.++That's the theoretical point of view. From the practical point of view, the main purpose of the _monoid-subclasses_ package is similar to that of [ListLike](http://hackage.haskell.org/packages/archive/ListLike/latest/doc/html/Data-ListLike.html) - to provide unifying abstractions for various monoidal data types in Haskell, primarily [String](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-String.html#t:String), [ByteString](http://hackage.haskell.org/packages/archive/bytestring/latest/doc/html/Data-ByteString.html#t:ByteString), and [Text](http://hackage.haskell.org/package/text). All three types are already instances of the [Monoid](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t:Monoid) class. While that abstraction is useful for building sequences of data, it doesn't help with deconstructing them.++That being said, there are two major differences in the goals of _ListLike_ and _monoid-subclasses_:+  * _ListLike_ strives to reproduce the standard [Data.List](http://hackage.haskell.org/packages/archive/base/4.6.0.0/doc/html/Data-List.html) interface, whereas _monoid-subclasses_ builds from deeper theoretical foundations; and+  * The _monoid-subclasses_ implementation uses standard Haskell 2010, with the exception of two minor extensions which can be worked around if necessary.++The [incremental-parser](http://hackage.haskell.org/package/incremental-parser) package provides one example of use of _monoid-subclasses_. Another example is [picoparsec](https://bitbucket.org/blamario/picoparsec), a fork of [attoparsec](http://hackage.haskell.org/package/attoparsec).++A more thorough description of the library can be found in the Haskell Symposium 2013 paper [Adding Structure to Monoids+](https://github.com/blamario/monoid-subclasses/wiki/Files/HaskellSymposium2013.pdf)+

@@ -148,7 +148,7 @@                          PositiveMonoidInstance (mempty :: Ordering),                          PositiveMonoidInstance (mempty :: All),                          PositiveMonoidInstance (mempty :: Any),-                         PositiveMonoidInstance (mempty :: (Maybe (Sum Int))),+                         PositiveMonoidInstance (mempty :: (Maybe (Sum Integer))),                          PositiveMonoidInstance (mempty :: (First Char)),                          PositiveMonoidInstance (mempty :: (Last Int)),                          PositiveMonoidInstance (mempty :: String),@@ -161,10 +161,12 @@  factorialInstances :: [FactorialMonoidInstance] factorialInstances = map upcast stableFactorialInstances-                     ++ [FactorialMonoidInstance (mempty :: Sum Int8),+                     ++ [FactorialMonoidInstance (mempty :: Sum Integer),                          FactorialMonoidInstance (mempty :: Product Int32),                          FactorialMonoidInstance (mempty :: Maybe String),                          FactorialMonoidInstance (mempty :: (Text, String)),+                         FactorialMonoidInstance (mempty :: (Product Int32, ByteString, Sum Integer)),+                         FactorialMonoidInstance (mempty :: (IntSet, Text, Sum Integer, String)),                          FactorialMonoidInstance (mempty :: IntMap Int),                          FactorialMonoidInstance (mempty :: IntSet),                          FactorialMonoidInstance (mempty :: Map String Int),@@ -276,6 +278,8 @@                        LeftGCDMonoidInstance (mempty :: Lazy.Text),                        LeftGCDMonoidInstance (mempty :: Dual ByteString),                        LeftGCDMonoidInstance (mempty :: (Text, String)),+                       LeftGCDMonoidInstance (mempty :: (ByteString, Text, String)),+                       LeftGCDMonoidInstance (mempty :: ([Word8], ByteString, String, Text)),                        LeftGCDMonoidInstance (mempty :: IntMap Int),                        LeftGCDMonoidInstance (mempty :: Map String Int),                        LeftGCDMonoidInstance (mempty :: Seq Int),@@ -310,7 +314,10 @@ cancellativeGCDInstances = [CancellativeGCDMonoidInstance (),                             CancellativeGCDMonoidInstance (mempty :: Sum Integer),                             CancellativeGCDMonoidInstance (mempty :: Dual (Sum Integer)),-                            CancellativeGCDMonoidInstance (mempty :: (Sum Integer, Sum Int))]+                            CancellativeGCDMonoidInstance (mempty :: (Sum Integer, Dual (Sum Integer))),+                            CancellativeGCDMonoidInstance (mempty :: (Sum Integer, (), Dual (Sum Integer))),+                            CancellativeGCDMonoidInstance (mempty :: ((Sum Integer, ()), Sum Integer, (),+                                                                      Dual (Sum Integer)))]  main = defaultMain (testGroup "MonoidSubclasses" $ map expand tests)   where expand (name, test) = testProperty name (foldr1 (.&&.) $ checkInstances test)@@ -762,27 +769,6 @@    splitCharacterPrefix (TestString []) = Nothing    splitCharacterPrefix (TestString (x:xs)) = Just (x, TestString xs) -instance Arbitrary All where-   arbitrary = fmap All arbitrary--instance Arbitrary Any where-   arbitrary = fmap Any arbitrary--instance Arbitrary a => Arbitrary (Dual a) where-   arbitrary = fmap Dual arbitrary--instance Arbitrary a => Arbitrary (First a) where-   arbitrary = fmap First arbitrary--instance Arbitrary a => Arbitrary (Last a) where-   arbitrary = fmap Last arbitrary--instance Arbitrary a => Arbitrary (Product a) where-   arbitrary = fmap Product arbitrary--instance Arbitrary a => Arbitrary (Sum a) where-   arbitrary = fmap Sum arbitrary- instance Arbitrary ByteStringUTF8 where    arbitrary = fmap ByteStringUTF8 arbitrary @@ -800,27 +786,6 @@  instance (Arbitrary a, Arbitrary b) => Arbitrary (Stateful a b) where    arbitrary = Stateful.Stateful <$> liftA2 (,) arbitrary arbitrary--instance CoArbitrary All where-   coarbitrary (All p) = coarbitrary p--instance CoArbitrary Any where-   coarbitrary (Any p) = coarbitrary p--instance CoArbitrary a => CoArbitrary (Dual a) where-   coarbitrary (Dual a) = coarbitrary a--instance CoArbitrary a => CoArbitrary (First a) where-   coarbitrary (First a) = coarbitrary a--instance CoArbitrary a => CoArbitrary (Last a) where-   coarbitrary (Last a) = coarbitrary a--instance CoArbitrary a => CoArbitrary (Product a) where-   coarbitrary (Product a) = coarbitrary a--instance CoArbitrary a => CoArbitrary (Sum a) where-   coarbitrary (Sum a) = coarbitrary a  instance CoArbitrary ByteStringUTF8 where    coarbitrary (ByteStringUTF8 bs) = coarbitrary bs

@@ -1,5 +1,5 @@ Name:                monoid-subclasses-Version:             0.4.2.1+Version:             0.4.3 Cabal-Version:       >= 1.10 Build-Type:          Simple Synopsis:            Subclasses of Monoid@@ -11,11 +11,12 @@    License:             BSD3 License-file:        BSD3-LICENSE.txt-Copyright:           (c) 2013-2015 Mario Blazevic+Copyright:           (c) 2013-2016 Mario Blazevic Author:              Mario Blazevic Maintainer:          Mario Blazevic <blamario@yahoo.com> Homepage:            https://github.com/blamario/monoid-subclasses/ Bug-reports:         https://github.com/blamario/monoid-subclasses/issues+Extra-Source-Files:  README.md Source-repository head   type:              git   location:          https://github.com/blamario/monoid-subclasses@@ -35,7 +36,8 @@   Build-Depends:     base >= 4.5 && < 5,                      bytestring >= 0.9 && < 1.0, containers >= 0.5.7.0 && < 0.6, text >= 0.11 && < 1.3,                      vector >= 0.9 && < 0.12, primes == 0.2.*,-                     QuickCheck == 2.*, quickcheck-instances >= 0.3.12 && <0.4, tasty >= 0.7, tasty-quickcheck >= 0.7,+                     QuickCheck >= 2.9 && < 3, quickcheck-instances >= 0.3.12 && <0.4,+                     tasty >= 0.7, tasty-quickcheck >= 0.7,                      monoid-subclasses   Main-is:           Test/TestMonoidSubclasses.hs   default-language:  Haskell2010