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