diff --git a/Data/Monoid/Cancellative.hs b/Data/Monoid/Cancellative.hs
--- a/Data/Monoid/Cancellative.hs
+++ b/Data/Monoid/Cancellative.hs
@@ -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
diff --git a/Data/Monoid/Factorial.hs b/Data/Monoid/Factorial.hs
--- a/Data/Monoid/Factorial.hs
+++ b/Data/Monoid/Factorial.hs
@@ -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 [] = []
diff --git a/Data/Monoid/Instances/Concat.hs b/Data/Monoid/Instances/Concat.hs
--- a/Data/Monoid/Instances/Concat.hs
+++ b/Data/Monoid/Instances/Concat.hs
@@ -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)
diff --git a/Data/Monoid/Instances/Positioned.hs b/Data/Monoid/Instances/Positioned.hs
--- a/Data/Monoid/Instances/Positioned.hs
+++ b/Data/Monoid/Instances/Positioned.hs
@@ -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
diff --git a/Data/Monoid/Null.hs b/Data/Monoid/Null.hs
--- a/Data/Monoid/Null.hs
+++ b/Data/Monoid/Null.hs
@@ -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)
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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)
+
diff --git a/Test/TestMonoidSubclasses.hs b/Test/TestMonoidSubclasses.hs
--- a/Test/TestMonoidSubclasses.hs
+++ b/Test/TestMonoidSubclasses.hs
@@ -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
diff --git a/monoid-subclasses.cabal b/monoid-subclasses.cabal
--- a/monoid-subclasses.cabal
+++ b/monoid-subclasses.cabal
@@ -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