1{-
2    Copyright 2013-2017 Mario Blazevic
3
4    License: BSD3 (see BSD3-LICENSE.txt file)
5-}
6
7-- | This module defines the 'FactorialMonoid' class and some of its instances.
8--
9
10{-# LANGUAGE Haskell2010, ConstraintKinds, FlexibleInstances, Trustworthy #-}
11
12module Data.Monoid.Factorial (
13   module Data.Semigroup.Factorial,
14   FactorialMonoid(..), StableFactorialMonoid,
15   )
16where
17
18import Control.Arrow (first)
19import Data.Monoid -- (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo))
20import qualified Data.Foldable as Foldable
21import qualified Data.List as List
22import qualified Data.ByteString as ByteString
23import qualified Data.ByteString.Lazy as LazyByteString
24import qualified Data.Text as Text
25import qualified Data.Text.Lazy as LazyText
26import qualified Data.IntMap as IntMap
27import qualified Data.IntSet as IntSet
28import qualified Data.Map as Map
29import qualified Data.Sequence as Sequence
30import qualified Data.Set as Set
31import qualified Data.Vector as Vector
32import Data.Int (Int64)
33
34import Data.Semigroup.Factorial
35import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)
36
37import Prelude hiding (break, drop, dropWhile, foldl, foldr, last, length, map, max, min,
38                       null, reverse, span, splitAt, take, takeWhile)
39
40
41-- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of
42-- a 'Product' are literally its prime factors:
43--
44-- prop> factors (Product 12) == [Product 2, Product 2, Product 3]
45--
46-- Factors of a list are /not/ its elements but all its single-item sublists:
47--
48-- prop> factors "abc" == ["a", "b", "c"]
49--
50-- The methods of this class satisfy the following laws in addition to those of 'Factorial':
51--
52-- > null == List.null . factors
53-- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix)
54-- > reverse == mconcat . List.reverse . factors
55-- > primePrefix == maybe mempty fst . splitPrimePrefix
56-- > primeSuffix == maybe mempty snd . splitPrimeSuffix
57-- > inits == List.map mconcat . List.inits . factors
58-- > tails == List.map mconcat . List.tails . factors
59-- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m)
60-- > List.all (List.all (not . pred) . factors) . split pred
61-- > mconcat . intersperse prime . split (== prime) == id
62-- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m)
63-- > spanMaybe () (const $ bool Nothing (Maybe ()) . p) m == (takeWhile p m, dropWhile p m, ())
64-- > spanMaybe s0 (\s m-> Just $ f s m) m0 == (m0, mempty, foldl f s0 m0)
65-- > let (prefix, suffix, s') = spanMaybe s f m
66-- >     foldMaybe = foldl g (Just s)
67-- >     g s m = s >>= flip f m
68-- > in all ((Nothing ==) . foldMaybe) (inits prefix)
69-- >    && prefix == last (filter (isJust . foldMaybe) $ inits m)
70-- >    && Just s' == foldMaybe prefix
71-- >    && m == prefix <> suffix
72--
73-- A minimal instance definition should implement 'splitPrimePrefix' for performance reasons, and other methods where
74-- beneficial.
75class (Factorial m, MonoidNull m) => FactorialMonoid m where
76   -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'.
77   splitPrimePrefix :: m -> Maybe (m, m)
78   -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'.
79   splitPrimeSuffix :: m -> Maybe (m, m)
80   -- | Returns the list of all prefixes of the argument, 'mempty' first.
81   inits :: m -> [m]
82   -- | Returns the list of all suffixes of the argument, 'mempty' last.
83   tails :: m -> [m]
84   -- | Like 'List.span' from "Data.List" on the list of prime 'factors'.
85   span :: (m -> Bool) -> m -> (m, m)
86   -- | Equivalent to 'List.break' from "Data.List".
87   break :: (m -> Bool) -> m -> (m, m)
88   -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes
89   -- satisfying the predicate are not a part of the result.
90   split :: (m -> Bool) -> m -> [m]
91   -- | Equivalent to 'List.takeWhile' from "Data.List".
92   takeWhile :: (m -> Bool) -> m -> m
93   -- | Equivalent to 'List.dropWhile' from "Data.List".
94   dropWhile :: (m -> Bool) -> m -> m
95   -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'.
96   spanMaybe :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)
97   -- | Strict version of 'spanMaybe'.
98   spanMaybe' :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)
99   -- | Like 'List.splitAt' from "Data.List" on the list of prime 'factors'.
100   splitAt :: Int -> m -> (m, m)
101   -- | Equivalent to 'List.drop' from "Data.List".
102   drop :: Int -> m -> m
103   -- | Equivalent to 'List.take' from "Data.List".
104   take :: Int -> m -> m
105
106   splitPrimePrefix x = case factors x
107                        of [] -> Nothing
108                           prefix : rest -> Just (prefix, mconcat rest)
109   splitPrimeSuffix x = case factors x
110                        of [] -> Nothing
111                           fs -> Just (mconcat (List.init fs), List.last fs)
112   inits = foldr (\m l-> mempty : List.map (mappend m) l) [mempty]
113   tails m = m : maybe [] (tails . snd) (splitPrimePrefix m)
114   span p m0 = spanAfter id m0
115      where spanAfter f m = case splitPrimePrefix m
116                            of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest
117                               _ -> (f mempty, m)
118   break = span . (not .)
119   spanMaybe s0 f m0 = spanAfter id s0 m0
120      where spanAfter g s m = case splitPrimePrefix m
121                              of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest
122                                                    | otherwise -> (g mempty, m, s)
123                                 Nothing -> (m0, m, s)
124   spanMaybe' s0 f m0 = spanAfter id s0 m0
125      where spanAfter g s m = seq s $
126                              case splitPrimePrefix m
127                              of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest
128                                                    | otherwise -> (g mempty, m, s)
129                                 Nothing -> (m0, m, s)
130   split p m = prefix : splitRest
131      where (prefix, rest) = break p m
132            splitRest = case splitPrimePrefix rest
133                        of Nothing -> []
134                           Just (_, tl) -> split p tl
135   takeWhile p = fst . span p
136   dropWhile p = snd . span p
137   splitAt n0 m0 | n0 <= 0 = (mempty, m0)
138                 | otherwise = split' n0 id m0
139      where split' 0 f m = (f mempty, m)
140            split' n f m = case splitPrimePrefix m
141                           of Nothing -> (f mempty, m)
142                              Just (prime, rest) -> split' (pred n) (f . mappend prime) rest
143   drop n p = snd (splitAt n p)
144   take n p = fst (splitAt n p)
145   {-# MINIMAL #-}
146
147{-# DEPRECATED StableFactorialMonoid "Use Data.Semigroup.Factorial.StableFactorial instead." #-}
148type StableFactorialMonoid m = (StableFactorial m, FactorialMonoid m, PositiveMonoid m)
149
150instance FactorialMonoid () where
151   splitPrimePrefix () = Nothing
152   splitPrimeSuffix () = Nothing
153
154instance FactorialMonoid a => FactorialMonoid (Dual a) where
155   splitPrimePrefix (Dual a) = case splitPrimeSuffix a
156                               of Nothing -> Nothing
157                                  Just (p, s) -> Just (Dual s, Dual p)
158   splitPrimeSuffix (Dual a) = case splitPrimePrefix a
159                               of Nothing -> Nothing
160                                  Just (p, s) -> Just (Dual s, Dual p)
161   inits (Dual a) = fmap Dual (reverse $ tails a)
162   tails (Dual a) = fmap Dual (reverse $ inits a)
163
164instance (Integral a, Eq a) => FactorialMonoid (Sum a) where
165   splitPrimePrefix (Sum 0) = Nothing
166   splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a))
167   splitPrimeSuffix (Sum 0) = Nothing
168   splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a))
169
170instance Integral a => FactorialMonoid (Product a)
171
172instance FactorialMonoid a => FactorialMonoid (Maybe a) where
173   splitPrimePrefix Nothing = Nothing
174   splitPrimePrefix (Just a) = case splitPrimePrefix a
175                               of Nothing -> Just (Just a, Nothing)
176                                  Just (p, s) -> Just (Just p, if null s then Nothing else Just s)
177
178
179instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where
180   splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b)
181                             of (Just (ap, as), _) -> Just ((ap, mempty), (as, b))
182                                (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs))
183                                (Nothing, Nothing) -> Nothing
184   splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b)
185                             of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs))
186                                (Just (ap, as), Nothing) -> Just ((ap, b), (as, b))
187                                (Nothing, Nothing) -> Nothing
188   inits (a, b) = List.map (flip (,) mempty) (inits a) ++ List.map ((,) a) (List.tail $ inits b)
189   tails (a, b) = List.map (flip (,) b) (tails a) ++ List.map ((,) mempty) (List.tail $ tails b)
190   span p (x, y) = ((xp, yp), (xs, ys))
191      where (xp, xs) = span (p . fromFst) x
192            (yp, ys) | null xs = span (p . fromSnd) y
193                     | otherwise = (mempty, y)
194   spanMaybe s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)
195                         | otherwise = ((xp, mempty), (xs, y), s1)
196     where (xp, xs, s1) = spanMaybe s0 (\s-> f s . fromFst) x
197           (yp, ys, s2) = spanMaybe s1 (\s-> f s . fromSnd) y
198   spanMaybe' s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)
199                          | otherwise = ((xp, mempty), (xs, y), s1)
200     where (xp, xs, s1) = spanMaybe' s0 (\s-> f s . fromFst) x
201           (yp, ys, s2) = spanMaybe' s1 (\s-> f s . fromSnd) y
202   split p (x0, y0) = fst $ List.foldr combine (ys, False) xs
203      where xs = List.map fromFst $ split (p . fromFst) x0
204            ys = List.map fromSnd $ split (p . fromSnd) y0
205            combine x (~(y:rest), False) = (mappend x y : rest, True)
206            combine x (rest, True) = (x:rest, True)
207   splitAt n (x, y) = ((xp, yp), (xs, ys))
208      where (xp, xs) = splitAt n x
209            (yp, ys) | null xs = splitAt (n - length x) y
210                     | otherwise = (mempty, y)
211
212{-# INLINE fromFst #-}
213fromFst :: Monoid b => a -> (a, b)
214fromFst a = (a, mempty)
215
216{-# INLINE fromSnd #-}
217fromSnd :: Monoid a => b -> (a, b)
218fromSnd b = (mempty, b)
219
220instance (FactorialMonoid a, FactorialMonoid b, FactorialMonoid c) => FactorialMonoid (a, b, c) where
221   splitPrimePrefix (a, b, c) = case (splitPrimePrefix a, splitPrimePrefix b, splitPrimePrefix c)
222                                of (Just (ap, as), _, _) -> Just ((ap, mempty, mempty), (as, b, c))
223                                   (Nothing, Just (bp, bs), _) -> Just ((a, bp, mempty), (a, bs, c))
224                                   (Nothing, Nothing, Just (cp, cs)) -> Just ((a, b, cp), (a, b, cs))
225                                   (Nothing, Nothing, Nothing) -> Nothing
226   splitPrimeSuffix (a, b, c) = case (splitPrimeSuffix a, splitPrimeSuffix b, splitPrimeSuffix c)
227                                of (_, _, Just (cp, cs)) -> Just ((a, b, cp), (mempty, mempty, cs))
228                                   (_, Just (bp, bs), Nothing) -> Just ((a, bp, c), (mempty, bs, c))
229                                   (Just (ap, as), Nothing, Nothing) -> Just ((ap, b, c), (as, b, c))
230                                   (Nothing, Nothing, Nothing) -> Nothing
231   inits (a, b, c) = List.map (\a1-> (a1, mempty, mempty)) (inits a)
232                     ++ List.map (\b1-> (a, b1, mempty)) (List.tail $ inits b)
233                     ++ List.map (\c1-> (a, b, c1)) (List.tail $ inits c)
234   tails (a, b, c) = List.map (\a1-> (a1, b, c)) (tails a)
235                     ++ List.map (\b1-> (mempty, b1, c)) (List.tail $ tails b)
236                     ++ List.map (\c1-> (mempty, mempty, c1)) (List.tail $ tails c)
237   span p (a, b, c) = ((ap, bp, cp), (as, bs, cs))
238      where (ap, as) = span (p . fromFstOf3) a
239            (bp, bs) | null as = span (p . fromSndOf3) b
240                     | otherwise = (mempty, b)
241            (cp, cs) | null as && null bs = span (p . fromThdOf3) c
242                     | otherwise = (mempty, c)
243   spanMaybe s0 f (a, b, c) | not (null as) = ((ap, mempty, mempty), (as, b, c), s1)
244                            | not (null bs) = ((ap, bp, mempty), (as, bs, c), s2)
245                            | otherwise = ((ap, bp, cp), (as, bs, cs), s3)
246     where (ap, as, s1) = spanMaybe s0 (\s-> f s . fromFstOf3) a
247           (bp, bs, s2) = spanMaybe s1 (\s-> f s . fromSndOf3) b
248           (cp, cs, s3) = spanMaybe s2 (\s-> f s . fromThdOf3) c
249   spanMaybe' s0 f (a, b, c) | not (null as) = ((ap, mempty, mempty), (as, b, c), s1)
250                             | not (null bs) = ((ap, bp, mempty), (as, bs, c), s2)
251                             | otherwise = ((ap, bp, cp), (as, bs, cs), s3)
252     where (ap, as, s1) = spanMaybe' s0 (\s-> f s . fromFstOf3) a
253           (bp, bs, s2) = spanMaybe' s1 (\s-> f s . fromSndOf3) b
254           (cp, cs, s3) = spanMaybe' s2 (\s-> f s . fromThdOf3) c
255   splitAt n (a, b, c) = ((ap, bp, cp), (as, bs, cs))
256      where (ap, as) = splitAt n a
257            (bp, bs) | null as = splitAt (n - length a) b
258                     | otherwise = (mempty, b)
259            (cp, cs) | null as && null bs = splitAt (n - length a - length b) c
260                     | otherwise = (mempty, c)
261
262{-# INLINE fromFstOf3 #-}
263fromFstOf3 :: (Monoid b, Monoid c) => a -> (a, b, c)
264fromFstOf3 a = (a, mempty, mempty)
265
266{-# INLINE fromSndOf3 #-}
267fromSndOf3 :: (Monoid a, Monoid c) => b -> (a, b, c)
268fromSndOf3 b = (mempty, b, mempty)
269
270{-# INLINE fromThdOf3 #-}
271fromThdOf3 :: (Monoid a, Monoid b) => c -> (a, b, c)
272fromThdOf3 c = (mempty, mempty, c)
273
274instance (FactorialMonoid a, FactorialMonoid b, FactorialMonoid c, FactorialMonoid d) =>
275         FactorialMonoid (a, b, c, d) where
276   splitPrimePrefix (a, b, c, d) = case (splitPrimePrefix a, splitPrimePrefix b, splitPrimePrefix c, splitPrimePrefix d)
277                                   of (Just (ap, as), _, _, _) -> Just ((ap, mempty, mempty, mempty), (as, b, c, d))
278                                      (Nothing, Just (bp, bs), _, _) -> Just ((a, bp, mempty, mempty), (a, bs, c, d))
279                                      (Nothing, Nothing, Just (cp, cs), _) -> Just ((a, b, cp, mempty), (a, b, cs, d))
280                                      (Nothing, Nothing, Nothing, Just (dp, ds)) -> Just ((a, b, c, dp), (a, b, c, ds))
281                                      (Nothing, Nothing, Nothing, Nothing) -> Nothing
282   splitPrimeSuffix (a, b, c, d) = case (splitPrimeSuffix a, splitPrimeSuffix b, splitPrimeSuffix c, splitPrimeSuffix d)
283                                   of (_, _, _, Just (dp, ds)) -> Just ((a, b, c, dp), (mempty, mempty, mempty, ds))
284                                      (_, _, Just (cp, cs), Nothing) -> Just ((a, b, cp, d), (mempty, mempty, cs, d))
285                                      (_, Just (bp, bs), Nothing, Nothing) -> Just ((a, bp, c, d), (mempty, bs, c, d))
286                                      (Just (ap, as), Nothing, Nothing, Nothing) -> Just ((ap, b, c, d), (as, b, c, d))
287                                      (Nothing, Nothing, Nothing, Nothing) -> Nothing
288   inits (a, b, c, d) = List.map (\a1-> (a1, mempty, mempty, mempty)) (inits a)
289                        ++ List.map (\b1-> (a, b1, mempty, mempty)) (List.tail $ inits b)
290                        ++ List.map (\c1-> (a, b, c1, mempty)) (List.tail $ inits c)
291                        ++ List.map (\d1-> (a, b, c, d1)) (List.tail $ inits d)
292   tails (a, b, c, d) = List.map (\a1-> (a1, b, c, d)) (tails a)
293                        ++ List.map (\b1-> (mempty, b1, c, d)) (List.tail $ tails b)
294                        ++ List.map (\c1-> (mempty, mempty, c1, d)) (List.tail $ tails c)
295                        ++ List.map (\d1-> (mempty, mempty, mempty, d1)) (List.tail $ tails d)
296   span p (a, b, c, d) = ((ap, bp, cp, dp), (as, bs, cs, ds))
297      where (ap, as) = span (p . fromFstOf4) a
298            (bp, bs) | null as = span (p . fromSndOf4) b
299                     | otherwise = (mempty, b)
300            (cp, cs) | null as && null bs = span (p . fromThdOf4) c
301                     | otherwise = (mempty, c)
302            (dp, ds) | null as && null bs && null cs = span (p . fromFthOf4) d
303                     | otherwise = (mempty, d)
304   spanMaybe s0 f (a, b, c, d) | not (null as) = ((ap, mempty, mempty, mempty), (as, b, c, d), s1)
305                               | not (null bs) = ((ap, bp, mempty, mempty), (as, bs, c, d), s2)
306                               | not (null cs) = ((ap, bp, cp, mempty), (as, bs, cs, d), s3)
307                               | otherwise = ((ap, bp, cp, dp), (as, bs, cs, ds), s4)
308     where (ap, as, s1) = spanMaybe s0 (\s-> f s . fromFstOf4) a
309           (bp, bs, s2) = spanMaybe s1 (\s-> f s . fromSndOf4) b
310           (cp, cs, s3) = spanMaybe s2 (\s-> f s . fromThdOf4) c
311           (dp, ds, s4) = spanMaybe s3 (\s-> f s . fromFthOf4) d
312   spanMaybe' s0 f (a, b, c, d) | not (null as) = ((ap, mempty, mempty, mempty), (as, b, c, d), s1)
313                               | not (null bs) = ((ap, bp, mempty, mempty), (as, bs, c, d), s2)
314                               | not (null cs) = ((ap, bp, cp, mempty), (as, bs, cs, d), s3)
315                               | otherwise = ((ap, bp, cp, dp), (as, bs, cs, ds), s4)
316     where (ap, as, s1) = spanMaybe' s0 (\s-> f s . fromFstOf4) a
317           (bp, bs, s2) = spanMaybe' s1 (\s-> f s . fromSndOf4) b
318           (cp, cs, s3) = spanMaybe' s2 (\s-> f s . fromThdOf4) c
319           (dp, ds, s4) = spanMaybe' s3 (\s-> f s . fromFthOf4) d
320   splitAt n (a, b, c, d) = ((ap, bp, cp, dp), (as, bs, cs, ds))
321      where (ap, as) = splitAt n a
322            (bp, bs) | null as = splitAt (n - length a) b
323                     | otherwise = (mempty, b)
324            (cp, cs) | null as && null bs = splitAt (n - length a - length b) c
325                     | otherwise = (mempty, c)
326            (dp, ds) | null as && null bs && null cs = splitAt (n - length a - length b - length c) d
327                     | otherwise = (mempty, d)
328
329{-# INLINE fromFstOf4 #-}
330fromFstOf4 :: (Monoid b, Monoid c, Monoid d) => a -> (a, b, c, d)
331fromFstOf4 a = (a, mempty, mempty, mempty)
332
333{-# INLINE fromSndOf4 #-}
334fromSndOf4 :: (Monoid a, Monoid c, Monoid d) => b -> (a, b, c, d)
335fromSndOf4 b = (mempty, b, mempty, mempty)
336
337{-# INLINE fromThdOf4 #-}
338fromThdOf4 :: (Monoid a, Monoid b, Monoid d) => c -> (a, b, c, d)
339fromThdOf4 c = (mempty, mempty, c, mempty)
340
341{-# INLINE fromFthOf4 #-}
342fromFthOf4 :: (Monoid a, Monoid b, Monoid c) => d -> (a, b, c, d)
343fromFthOf4 d = (mempty, mempty, mempty, d)
344
345instance FactorialMonoid [x] where
346   splitPrimePrefix [] = Nothing
347   splitPrimePrefix (x:xs) = Just ([x], xs)
348   splitPrimeSuffix [] = Nothing
349   splitPrimeSuffix xs = Just (splitLast id xs)
350      where splitLast f last@[_] = (f [], last)
351            splitLast f ~(x:rest) = splitLast (f . (x:)) rest
352   inits = List.inits
353   tails = List.tails
354   break f = List.break (f . (:[]))
355   span f = List.span (f . (:[]))
356   dropWhile f = List.dropWhile (f . (:[]))
357   takeWhile f = List.takeWhile (f . (:[]))
358   spanMaybe s0 f l = (prefix' [], suffix' [], s')
359      where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l
360            g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = (prefix . (x:), id, s2, True)
361                                           | otherwise = (prefix, suffix . (x:), s1, False)
362   spanMaybe' s0 f l = (prefix' [], suffix' [], s')
363      where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l
364            g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = seq s2 $ (prefix . (x:), id, s2, True)
365                                           | otherwise = (prefix, suffix . (x:), s1, False)
366   splitAt = List.splitAt
367   drop = List.drop
368   take = List.take
369
370instance FactorialMonoid ByteString.ByteString where
371   splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x)
372   splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x)
373   inits = ByteString.inits
374   tails = ByteString.tails
375   break f = ByteString.break (f . ByteString.singleton)
376   span f = ByteString.span (f . ByteString.singleton)
377   spanMaybe s0 f b = case ByteString.foldr g id b (0, s0)
378                      of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')
379      where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s')
380                            | otherwise = (i, s)
381   spanMaybe' s0 f b = case ByteString.foldr g id b (0, s0)
382                       of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')
383      where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')
384                            | otherwise = (i, s)
385   dropWhile f = ByteString.dropWhile (f . ByteString.singleton)
386   takeWhile f = ByteString.takeWhile (f . ByteString.singleton)
387   split f = ByteString.splitWith f'
388      where f' = f . ByteString.singleton
389   splitAt = ByteString.splitAt
390   drop = ByteString.drop
391   take = ByteString.take
392
393instance FactorialMonoid LazyByteString.ByteString where
394   splitPrimePrefix x = if LazyByteString.null x then Nothing
395                        else Just (LazyByteString.splitAt 1 x)
396   splitPrimeSuffix x = if LazyByteString.null x then Nothing
397                        else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x)
398   inits = LazyByteString.inits
399   tails = LazyByteString.tails
400   break f = LazyByteString.break (f . LazyByteString.singleton)
401   span f = LazyByteString.span (f . LazyByteString.singleton)
402   spanMaybe s0 f b = case LazyByteString.foldr g id b (0, s0)
403                      of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')
404      where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ cont (i', s')
405                            | otherwise = (i, s)
406   spanMaybe' s0 f b = case LazyByteString.foldr g id b (0, s0)
407                       of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')
408      where g w cont (i, s)
409              | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')
410              | otherwise = (i, s)
411   dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton)
412   takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton)
413   split f = LazyByteString.splitWith f'
414      where f' = f . LazyByteString.singleton
415   splitAt = LazyByteString.splitAt . fromIntegral
416   drop n = LazyByteString.drop (fromIntegral n)
417   take n = LazyByteString.take (fromIntegral n)
418
419instance FactorialMonoid Text.Text where
420   splitPrimePrefix = fmap (first Text.singleton) . Text.uncons
421   splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x))
422   inits = Text.inits
423   tails = Text.tails
424   span f = Text.span (f . Text.singleton)
425   break f = Text.break (f . Text.singleton)
426   dropWhile f = Text.dropWhile (f . Text.singleton)
427   takeWhile f = Text.takeWhile (f . Text.singleton)
428   spanMaybe s0 f t = case Text.foldr g id t (0, s0)
429                      of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')
430      where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ cont (i', s')
431                            | otherwise = (i, s)
432   spanMaybe' s0 f t = case Text.foldr g id t (0, s0)
433                       of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')
434      where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')
435                            | otherwise = (i, s)
436   split f = Text.split f'
437      where f' = f . Text.singleton
438   splitAt = Text.splitAt
439   drop = Text.drop
440   take = Text.take
441
442instance FactorialMonoid LazyText.Text where
443   splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons
444   splitPrimeSuffix x = if LazyText.null x
445                        then Nothing
446                        else Just (LazyText.init x, LazyText.singleton (LazyText.last x))
447   inits = LazyText.inits
448   tails = LazyText.tails
449   span f = LazyText.span (f . LazyText.singleton)
450   break f = LazyText.break (f . LazyText.singleton)
451   dropWhile f = LazyText.dropWhile (f . LazyText.singleton)
452   takeWhile f = LazyText.takeWhile (f . LazyText.singleton)
453   spanMaybe s0 f t = case LazyText.foldr g id t (0, s0)
454                      of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')
455      where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ cont (i', s')
456                            | otherwise = (i, s)
457   spanMaybe' s0 f t = case LazyText.foldr g id t (0, s0)
458                       of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')
459      where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')
460                            | otherwise = (i, s)
461   split f = LazyText.split f'
462      where f' = f . LazyText.singleton
463   splitAt = LazyText.splitAt . fromIntegral
464   drop n = LazyText.drop (fromIntegral n)
465   take n = LazyText.take (fromIntegral n)
466
467instance Ord k => FactorialMonoid (Map.Map k v) where
468   splitPrimePrefix = fmap singularize . Map.minViewWithKey
469      where singularize ((k, v), rest) = (Map.singleton k v, rest)
470   splitPrimeSuffix = fmap singularize . Map.maxViewWithKey
471      where singularize ((k, v), rest) = (rest, Map.singleton k v)
472
473instance FactorialMonoid (IntMap.IntMap a) where
474   splitPrimePrefix = fmap singularize . IntMap.minViewWithKey
475      where singularize ((k, v), rest) = (IntMap.singleton k v, rest)
476   splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey
477      where singularize ((k, v), rest) = (rest, IntMap.singleton k v)
478
479instance FactorialMonoid IntSet.IntSet where
480   splitPrimePrefix = fmap singularize . IntSet.minView
481      where singularize (min, rest) = (IntSet.singleton min, rest)
482   splitPrimeSuffix = fmap singularize . IntSet.maxView
483      where singularize (max, rest) = (rest, IntSet.singleton max)
484
485instance FactorialMonoid (Sequence.Seq a) where
486   splitPrimePrefix q = case Sequence.viewl q
487                        of Sequence.EmptyL -> Nothing
488                           hd Sequence.:< rest -> Just (Sequence.singleton hd, rest)
489   splitPrimeSuffix q = case Sequence.viewr q
490                        of Sequence.EmptyR -> Nothing
491                           rest Sequence.:> last -> Just (rest, Sequence.singleton last)
492   inits = Foldable.toList . Sequence.inits
493   tails = Foldable.toList . Sequence.tails
494   span f = Sequence.spanl (f . Sequence.singleton)
495   break f = Sequence.breakl (f . Sequence.singleton)
496   dropWhile f = Sequence.dropWhileL (f . Sequence.singleton)
497   takeWhile f = Sequence.takeWhileL (f . Sequence.singleton)
498   spanMaybe s0 f b = case Foldable.foldr g id b (0, s0)
499                      of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')
500      where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ cont (i', s')
501                            | otherwise = (i, s)
502   spanMaybe' s0 f b = case Foldable.foldr g id b (0, s0)
503                       of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')
504      where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')
505                            | otherwise = (i, s)
506   splitAt = Sequence.splitAt
507   drop = Sequence.drop
508   take = Sequence.take
509
510instance Ord a => FactorialMonoid (Set.Set a) where
511   splitPrimePrefix = fmap singularize . Set.minView
512      where singularize (min, rest) = (Set.singleton min, rest)
513   splitPrimeSuffix = fmap singularize . Set.maxView
514      where singularize (max, rest) = (rest, Set.singleton max)
515
516instance FactorialMonoid (Vector.Vector a) where
517   splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x)
518   splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x)
519   inits x0 = initsWith x0 []
520      where initsWith x rest | Vector.null x = x:rest
521                             | otherwise = initsWith (Vector.unsafeInit x) (x:rest)
522   tails x = x : if Vector.null x then [] else tails (Vector.unsafeTail x)
523   break f = Vector.break (f . Vector.singleton)
524   span f = Vector.span (f . Vector.singleton)
525   dropWhile f = Vector.dropWhile (f . Vector.singleton)
526   takeWhile f = Vector.takeWhile (f . Vector.singleton)
527   spanMaybe s0 f v = case Vector.ifoldr g Left v s0
528                      of Left s' -> (v, Vector.empty, s')
529                         Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')
530      where g i x cont s | Just s' <- f s (Vector.singleton x) = cont s'
531                         | otherwise = Right (i, s)
532   spanMaybe' s0 f v = case Vector.ifoldr' g Left v s0
533                       of Left s' -> (v, Vector.empty, s')
534                          Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')
535      where g i x cont s | Just s' <- f s (Vector.singleton x) = seq s' (cont s')
536                         | otherwise = Right (i, s)
537   splitAt = Vector.splitAt
538   drop = Vector.drop
539   take = Vector.take
540