monoid-subclasses 0.4.6.1 → 1.2.6.1
raw patch · 29 files changed
Files
- CHANGELOG.md +130/−0
- Data/Monoid/Cancellative.hs +0/−706
- Data/Monoid/Factorial.hs +0/−827
- Data/Monoid/Instances/ByteString/UTF8.hs +0/−498
- Data/Monoid/Instances/Concat.hs +0/−293
- Data/Monoid/Instances/Measured.hs +0/−124
- Data/Monoid/Instances/Positioned.hs +0/−616
- Data/Monoid/Instances/Stateful.hs +0/−236
- Data/Monoid/Null.hs +0/−148
- Data/Monoid/Textual.hs +0/−615
- README.md +27/−14
- Test/TestMonoidSubclasses.hs +733/−102
- monoid-subclasses.cabal +43/−12
- src/Data/Monoid/Cancellative.hs +57/−0
- src/Data/Monoid/Factorial.hs +559/−0
- src/Data/Monoid/GCD.hs +714/−0
- src/Data/Monoid/Instances/ByteString/UTF8.hs +512/−0
- src/Data/Monoid/Instances/CharVector.hs +90/−0
- src/Data/Monoid/Instances/Concat.hs +299/−0
- src/Data/Monoid/Instances/Measured.hs +129/−0
- src/Data/Monoid/Instances/Positioned.hs +718/−0
- src/Data/Monoid/Instances/PrefixMemory.hs +269/−0
- src/Data/Monoid/Instances/Stateful.hs +242/−0
- src/Data/Monoid/LCM.hs +183/−0
- src/Data/Monoid/Monus.hs +400/−0
- src/Data/Monoid/Null.hs +270/−0
- src/Data/Monoid/Textual.hs +552/−0
- src/Data/Semigroup/Cancellative.hs +572/−0
- src/Data/Semigroup/Factorial.hs +449/−0
CHANGELOG.md view
@@ -1,3 +1,133 @@+Version 1.2.6.1+---------------++* Bumped the `quickcheck-instances` dependency upper bound++Version 1.2.6+---------------++* Improved the performance of `instance FactorialMonoid PrefixMemory`+* Bumped the `containers` dependency upper bound+* Thanks to Jonathan Knowles:+ * Documented and added tests for `Monus` laws+ * Added the missing class instances and tests for `Identity` and `Const`+ * Using `GeneralizedNewtypeDeriving` to simplify existing instances+ * Fixed compilation on older versions of GHC+ * Updated and improved the CI+ * Removed trailing whitespace++Version 1.2.5.1+---------------++* Bumped the `containers` dependency upper bound++Version 1.2.5+---------------++* `Data.Monoid.Null.MonoidNull` now has a default implementation+* Add instances of `MonoidNull` and (where appropriate) `PositiveMonoid` for:+ - `(a, b, c, d, e)`+ - `Data.Functor.Compose f g a`+ - `Data.Functor.Const r a`+ - `Data.Functor.Identity a`+ - `Data.Functor.Product f g a`+ - `Data.Ord.Down a`+ - `Data.Proxy.Proxy a`+ - `Data.Semigroup.Max a`+ - `Data.Semigroup.Min a`+ - `Data.Semigroup.WrappedMonoid a`+ - `GHC.Generics.(:*:) f g a`+ - `GHC.Generics.(:.:) f g a`+ - `GHC.Generics.K1 i c p`+ - `GHC.Generics.M1 i c f p`+ - `GHC.Generics.Par1 p`+ - `GHC.Generics.Rec1 f p`+ - `GHC.Generics.U1 p`+* Added instances of `Reductive` for `Max a`, `Min a`, `Any`, and `All`+* Bumped the `commutative-semigroups` dependency upper bound++Version 1.2.4.1+---------------+* Bumped the `text` dependency upper bound++Version 1.2.4+---------------+* Added `Data.Monoid.Instances.PrefixMemory.Shadowed` monoid transformer++Version 1.2.3+---------------+* Added `DistributiveGCDMonoid` and `DistributiveLCMMonoid` type class by Jonathan Knowles++Version 1.2.2+---------------+* Added `Data.Monoid.LCM` module with `LCMMonoid` type class by Jonathan Knowles+* Repaired links to Hackage within `README.md` by Jonathan Knowles++Version 1.2.1+---------------+* Fix for the `Monus` instance for `Maybe` by Jonathan Knowles++Version 1.2+---------------+* Dropped support for GHC < 8.4+* Depending on new `commutative-semigroups` package+* Modified the `instance OverlappingMonoid/Monus Map/IntMap` instances to conform with the class laws+* Bumped the `vector` dependency upper bounds++Version 1.1.4+---------------+* Canonicalized all `mappend` definitions+* Added `deriving (Data, Typeable)` to all data types++Version 1.1.3+---------------+* Support for text-2.0 by Bodigrim++Version 1.1.2+---------------+* CI tests+* Fallback implementation of `stripCommonSuffix @Text` for GHCjs by Jack Kelly+* Fixed documentation bug #31, Factorial laws too strong++Version 1.1.1+---------------+* Fixed compilation with GHC 8.0.2+* `Positioned` doesn't use a column for zero-width characters any more++Version 1.1+---------------+* Added a new TextualMonoid method `toText` for performance+* Fixed the calculations of `column` of `LinePositioned`+* Changed the `column` of `LinePositioned` to be one-based+* `LinePositioned` now treats FF, CR, and TAB characters as+ special, in accordance with Haskell language specification.++Version 1.0.1+---------------+* Incremented the lower bound of the base dependency+* Fixed Haddock links++Version 1.0+---------------+* Fixed issue #24, unlawful LeftReductiveMonoid instance for Map+* Tightened the laws of GCD classes, dropped instances for Sum and Product+* Introduced the `Monus` class+* Introduced the `OverlappingGCDMonoid` class+* Added the instances of type `Sum Natural` and `Product Natural`+* Using the language extensions `FlexibleInstances` and `OverlappingInstances`+* Removed the linear complexity requirement+* Added and documented less efficient instances+* Moved various GCD classes into the new module `Data.Monoid.GCD`+* Added module `Data.Semigroup.Cancellative` with `Semigroup` subclasses+* Added module `Data.Semigroup.Factorial` with `Semigroup` subclasses+* Deprecated several `Monoid` subclasses and made them constraint synonyms instead:+ * `type CommutativeMonoid m = (Monoid m, Commutative m)`+ * `type ReductiveMonoid m = (Monoid m, Reductive m)`+ * `type LeftReductiveMonoid m = (Monoid m, LeftReductive m)`+ * `type RightReductiveMonoid m = (Monoid m, RightReductive m)`+ * `type CancellativeMonoid m = (Monoid m, Cancellative m)`+ * `type LeftCancellativeMonoid m = (Monoid m, LeftCancellative m)`+ * `type RightCancellativeMonoid m = (Monoid m, RightCancellative m)` Version 0.4.6.1 ---------------
− Data/Monoid/Cancellative.hs
@@ -1,706 +0,0 @@-{- - Copyright 2013-2017 Mario Blazevic-- License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines the 'Monoid' => 'ReductiveMonoid' => ('CancellativeMonoid', 'GCDMonoid') class hierarchy. ------ The 'ReductiveMonoid' class introduces operation '</>' which is the inverse of '<>'. For the 'Sum' monoid, this--- operation is subtraction; for 'Product' it is division and for 'Set' it's the set difference. A 'ReductiveMonoid' is--- not a full group because '</>' may return 'Nothing'.------ The 'CancellativeMonoid' subclass does not add any operation but it provides the additional guarantee that '<>' can--- always be undone with '</>'. Thus 'Sum' is a 'CancellativeMonoid' but 'Product' is not because @(0*n)/0@ is not--- defined.------ The 'GCDMonoid' subclass adds the 'gcd' operation which takes two monoidal arguments and finds their greatest common--- divisor, or (more generally) the greatest monoid that can be extracted with the '</>' operation from both.------ All monoid subclasses listed above are for Abelian, /i.e./, commutative or symmetric monoids. Since most practical--- monoids in Haskell are not Abelian, each of the these classes has two symmetric superclasses:--- --- * 'LeftReductiveMonoid'--- --- * 'LeftCancellativeMonoid'--- --- * 'LeftGCDMonoid'--- --- * 'RightReductiveMonoid'--- --- * 'RightCancellativeMonoid'--- --- * 'RightGCDMonoid'--{-# LANGUAGE Haskell2010, Trustworthy #-}--module Data.Monoid.Cancellative (- -- * Symmetric, commutative monoid classes- CommutativeMonoid, ReductiveMonoid(..), CancellativeMonoid, GCDMonoid(..),- -- * Asymmetric monoid classes- LeftReductiveMonoid(..), RightReductiveMonoid(..),- LeftCancellativeMonoid, RightCancellativeMonoid,- LeftGCDMonoid(..), RightGCDMonoid(..)- )-where--import qualified Prelude--import Control.Applicative ((<$>), (<*>))-import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..))-import qualified Data.List as List-import Data.Maybe (isJust)-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Unsafe as ByteString-import qualified Data.ByteString.Lazy as LazyByteString-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LazyText-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import qualified Data.Map as Map-import qualified Data.Sequence as Sequence-import qualified Data.Set as Set-import Data.Sequence (ViewL((:<)), ViewR((:>)), (<|), (|>))-import qualified Data.Vector as Vector--import Prelude hiding (gcd)---- | Class of all Abelian ({i.e.}, commutative) monoids that satisfy the commutativity property:--- --- > a <> b == b <> a-class Monoid m => CommutativeMonoid m---- | Class of Abelian monoids with a partial inverse for the Monoid '<>' operation. The inverse operation '</>' must--- satisfy the following laws:--- --- > maybe a (b <>) (a </> b) == a--- > maybe a (<> b) (a </> b) == a-class (CommutativeMonoid m, LeftReductiveMonoid m, RightReductiveMonoid m) => ReductiveMonoid m where- (</>) :: m -> m -> Maybe m--infix 5 </>---- | Subclass of 'ReductiveMonoid' where '</>' is a complete inverse of the Monoid '<>' operation. The class instances--- must satisfy the following additional laws:------ > (a <> b) </> a == Just b--- > (a <> b) </> b == Just a-class (LeftCancellativeMonoid m, RightCancellativeMonoid m, ReductiveMonoid m) => CancellativeMonoid m---- | Class of Abelian monoids that allow the greatest common denominator to be found for any two given values. The--- operations must satisfy the following laws:------ > gcd a b == commonPrefix a b == commonSuffix a b--- > Just a' = a </> p && Just b' = b </> p--- > where p = gcd a b--- --- If a 'GCDMonoid' happens to also be a 'CancellativeMonoid', it should additionally satisfy the following laws:--- --- > gcd (a <> b) (a <> c) == a <> gcd b c--- > gcd (a <> c) (b <> c) == gcd a b <> c-class (ReductiveMonoid m, LeftGCDMonoid m, RightGCDMonoid m) => GCDMonoid m where- gcd :: m -> m -> m---- | Class of monoids with a left inverse of 'Data.Monoid.mappend', satisfying the following law:--- --- > isPrefixOf a b == isJust (stripPrefix a b)--- > maybe b (a <>) (stripPrefix a b) == b--- > a `isPrefixOf` (a <> b)--- --- | Every instance definition has to implement at least the 'stripPrefix' method. Its complexity should be no worse--- than linear in the length of the prefix argument.-class Monoid m => LeftReductiveMonoid m where- isPrefixOf :: m -> m -> Bool- stripPrefix :: m -> m -> Maybe m-- isPrefixOf a b = isJust (stripPrefix a b)- {-# MINIMAL stripPrefix #-}---- | Class of monoids with a right inverse of 'Data.Monoid.mappend', satisfying the following law:--- --- > isSuffixOf a b == isJust (stripSuffix a b)--- > maybe b (<> a) (stripSuffix a b) == b--- > b `isSuffixOf` (a <> b)--- --- | Every instance definition has to implement at least the 'stripSuffix' method. Its complexity should be no worse--- than linear in the length of the suffix argument.-class Monoid m => RightReductiveMonoid m where- isSuffixOf :: m -> m -> Bool- stripSuffix :: m -> m -> Maybe m-- isSuffixOf a b = isJust (stripSuffix a b)- {-# MINIMAL stripSuffix #-}---- | Subclass of 'LeftReductiveMonoid' where 'stripPrefix' is a complete inverse of '<>', satisfying the following--- additional law:------ > stripPrefix a (a <> b) == Just b-class LeftReductiveMonoid m => LeftCancellativeMonoid m---- | Subclass of 'LeftReductiveMonoid' where 'stripPrefix' is a complete inverse of '<>', satisfying the following--- additional law:------ > stripSuffix b (a <> b) == Just a-class RightReductiveMonoid m => RightCancellativeMonoid m---- | Class of monoids capable of finding the equivalent of greatest common divisor on the left side of two monoidal--- values. The methods' complexity should be no worse than linear in the length of the common prefix. The following laws--- must be respected:--- --- > stripCommonPrefix a b == (p, a', b')--- > where p = commonPrefix a b--- > Just a' = stripPrefix p a--- > Just b' = stripPrefix p b--- > p == commonPrefix a b && p <> a' == a && p <> b' == b--- > where (p, a', b') = stripCommonPrefix a b-class LeftReductiveMonoid m => LeftGCDMonoid m where- commonPrefix :: m -> m -> m- stripCommonPrefix :: m -> m -> (m, m, m)-- commonPrefix x y = p- where (p, _, _) = stripCommonPrefix x y- stripCommonPrefix x y = (p, x', y')- where p = commonPrefix x y- Just x' = stripPrefix p x- Just y' = stripPrefix p y- {-# MINIMAL commonPrefix | stripCommonPrefix #-}---- | Class of monoids capable of finding the equivalent of greatest common divisor on the right side of two monoidal--- values. The methods' complexity must be no worse than linear in the length of the common suffix. The following laws--- must be respected:--- --- > stripCommonSuffix a b == (a', b', s)--- > where s = commonSuffix a b--- > Just a' = stripSuffix p a--- > Just b' = stripSuffix p b--- > s == commonSuffix a b && a' <> s == a && b' <> s == b--- > where (a', b', s) = stripCommonSuffix a b-class RightReductiveMonoid m => RightGCDMonoid m where- commonSuffix :: m -> m -> m- stripCommonSuffix :: m -> m -> (m, m, m)-- commonSuffix x y = s- where (_, _, s) = stripCommonSuffix x y- stripCommonSuffix x y = (x', y', s)- where s = commonSuffix x y- Just x' = stripSuffix s x- Just y' = stripSuffix s y- {-# MINIMAL commonSuffix | stripCommonSuffix #-}---- Unit instances--instance CommutativeMonoid ()--instance ReductiveMonoid () where- () </> () = Just ()--instance CancellativeMonoid ()--instance GCDMonoid () where- gcd () () = ()--instance LeftReductiveMonoid () where- stripPrefix () () = Just ()--instance RightReductiveMonoid () where- stripSuffix () () = Just ()--instance LeftCancellativeMonoid ()--instance RightCancellativeMonoid ()--instance LeftGCDMonoid () where- commonPrefix () () = ()--instance RightGCDMonoid () where- commonSuffix () () = ()---- Dual instances--instance CommutativeMonoid a => CommutativeMonoid (Dual a)--instance ReductiveMonoid a => ReductiveMonoid (Dual a) where- Dual a </> Dual b = fmap Dual (a </> b)--instance CancellativeMonoid a => CancellativeMonoid (Dual a)--instance GCDMonoid a => GCDMonoid (Dual a) where- gcd (Dual a) (Dual b) = Dual (gcd a b)--instance LeftReductiveMonoid a => RightReductiveMonoid (Dual a) where- stripSuffix (Dual a) (Dual b) = fmap Dual (stripPrefix a b)- Dual a `isSuffixOf` Dual b = a `isPrefixOf` b--instance RightReductiveMonoid a => LeftReductiveMonoid (Dual a) where- stripPrefix (Dual a) (Dual b) = fmap Dual (stripSuffix a b)- Dual a `isPrefixOf` Dual b = a `isSuffixOf` b--instance LeftCancellativeMonoid a => RightCancellativeMonoid (Dual a)--instance RightCancellativeMonoid a => LeftCancellativeMonoid (Dual a)--instance LeftGCDMonoid a => RightGCDMonoid (Dual a) where- commonSuffix (Dual a) (Dual b) = Dual (commonPrefix a b)--instance RightGCDMonoid a => LeftGCDMonoid (Dual a) where- commonPrefix (Dual a) (Dual b) = Dual (commonSuffix a b)---- Sum instances--instance Num a => CommutativeMonoid (Sum a)--instance Integral a => ReductiveMonoid (Sum a) where- Sum a </> Sum b = Just $ Sum (a - b)--instance Integral a => CancellativeMonoid (Sum a)--instance (Integral a, Ord a) => GCDMonoid (Sum a) where- gcd (Sum a) (Sum b) = Sum (min a b)--instance Integral a => LeftReductiveMonoid (Sum a) where- stripPrefix a b = b </> a--instance Integral a => RightReductiveMonoid (Sum a) where- stripSuffix a b = b </> a--instance Integral a => LeftCancellativeMonoid (Sum a)--instance Integral a => RightCancellativeMonoid (Sum a)--instance (Integral a, Ord a) => LeftGCDMonoid (Sum a) where- commonPrefix a b = gcd a b--instance (Integral a, Ord a) => RightGCDMonoid (Sum a) where- commonSuffix a b = gcd a b---- Product instances--instance Num a => CommutativeMonoid (Product a)--instance Integral a => ReductiveMonoid (Product a) where- Product 0 </> Product 0 = Just (Product 0)- Product _ </> Product 0 = Nothing- Product a </> Product b = if remainder == 0 then Just (Product quotient) else Nothing- where (quotient, remainder) = quotRem a b--instance Integral a => GCDMonoid (Product a) where- gcd (Product a) (Product b) = Product (Prelude.gcd a b)--instance Integral a => LeftReductiveMonoid (Product a) where- stripPrefix a b = b </> a--instance Integral a => RightReductiveMonoid (Product a) where- stripSuffix a b = b </> a--instance Integral a => LeftGCDMonoid (Product a) where- commonPrefix a b = gcd a b--instance Integral a => RightGCDMonoid (Product a) where- commonSuffix a b = gcd a b---- Pair instances--instance (CommutativeMonoid a, CommutativeMonoid b) => CommutativeMonoid (a, b)--instance (ReductiveMonoid a, ReductiveMonoid b) => ReductiveMonoid (a, b) where- (a, b) </> (c, d) = case (a </> c, b </> d)- of (Just a', Just b') -> Just (a', b')- _ -> Nothing--instance (CancellativeMonoid a, CancellativeMonoid b) => CancellativeMonoid (a, b)--instance (GCDMonoid a, GCDMonoid b) => GCDMonoid (a, b) where- gcd (a, b) (c, d) = (gcd a c, gcd b d)--instance (LeftReductiveMonoid a, LeftReductiveMonoid b) => LeftReductiveMonoid (a, b) where- stripPrefix (a, b) (c, d) = case (stripPrefix a c, stripPrefix b d)- of (Just a', Just b') -> Just (a', b')- _ -> Nothing- isPrefixOf (a, b) (c, d) = isPrefixOf a c && isPrefixOf b d--instance (RightReductiveMonoid a, RightReductiveMonoid b) => RightReductiveMonoid (a, b) where- stripSuffix (a, b) (c, d) = case (stripSuffix a c, stripSuffix b d)- of (Just a', Just b') -> Just (a', b')- _ -> Nothing- isSuffixOf (a, b) (c, d) = isSuffixOf a c && isSuffixOf b d--instance (LeftCancellativeMonoid a, LeftCancellativeMonoid b) => LeftCancellativeMonoid (a, b)--instance (RightCancellativeMonoid a, RightCancellativeMonoid b) => RightCancellativeMonoid (a, b)--instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (a, b) where- commonPrefix (a, b) (c, d) = (commonPrefix a c, commonPrefix b d)--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- stripPrefix Nothing y = Just y- stripPrefix Just{} Nothing = Nothing- stripPrefix (Just x) (Just y) = fmap Just $ stripPrefix x y--instance LeftGCDMonoid x => LeftGCDMonoid (Maybe x) where- commonPrefix (Just x) (Just y) = Just (commonPrefix x y)- commonPrefix _ _ = Nothing-- stripCommonPrefix (Just x) (Just y) = (Just p, Just x', Just y')- where (p, x', y') = stripCommonPrefix x y- stripCommonPrefix x y = (Nothing, x, y)--instance RightReductiveMonoid x => RightReductiveMonoid (Maybe x) where- stripSuffix Nothing y = Just y- stripSuffix Just{} Nothing = Nothing- stripSuffix (Just x) (Just y) = fmap Just $ stripSuffix x y--instance RightGCDMonoid x => RightGCDMonoid (Maybe x) where- commonSuffix (Just x) (Just y) = Just (commonSuffix x y)- commonSuffix _ _ = Nothing-- stripCommonSuffix (Just x) (Just y) = (Just x', Just y', Just s)- where (x', y', s) = stripCommonSuffix x y- stripCommonSuffix x y = (x, y, Nothing)---- Set instances--instance Ord a => CommutativeMonoid (Set.Set a)--instance Ord a => LeftReductiveMonoid (Set.Set a) where- isPrefixOf = Set.isSubsetOf- stripPrefix a b = b </> a--instance Ord a => RightReductiveMonoid (Set.Set a) where- isSuffixOf = Set.isSubsetOf- stripSuffix a b = b </> a--instance Ord a => ReductiveMonoid (Set.Set a) where- a </> b | Set.isSubsetOf b a = Just (a Set.\\ b)- | otherwise = Nothing--instance Ord a => LeftGCDMonoid (Set.Set a) where- commonPrefix = Set.intersection--instance Ord a => RightGCDMonoid (Set.Set a) where- commonSuffix = Set.intersection--instance Ord a => GCDMonoid (Set.Set a) where- gcd = Set.intersection---- IntSet instances--instance CommutativeMonoid IntSet.IntSet--instance LeftReductiveMonoid IntSet.IntSet where- isPrefixOf = IntSet.isSubsetOf- stripPrefix a b = b </> a--instance RightReductiveMonoid IntSet.IntSet where- isSuffixOf = IntSet.isSubsetOf- stripSuffix a b = b </> a--instance ReductiveMonoid IntSet.IntSet where- a </> b | IntSet.isSubsetOf b a = Just (a IntSet.\\ b)- | otherwise = Nothing--instance LeftGCDMonoid IntSet.IntSet where- commonPrefix = IntSet.intersection--instance RightGCDMonoid IntSet.IntSet where- commonSuffix = IntSet.intersection--instance GCDMonoid IntSet.IntSet where- gcd = IntSet.intersection---- Map instances--instance Ord k => LeftReductiveMonoid (Map.Map k a) where- isPrefixOf = Map.isSubmapOfBy (\_ _-> True)- stripPrefix a b | Map.isSubmapOfBy (\_ _-> True) a b = Just (b Map.\\ a)- | otherwise = Nothing--instance (Ord k, Eq a) => LeftGCDMonoid (Map.Map k a) where- commonPrefix = Map.mergeWithKey (\_ a b -> if a == b then Just a else Nothing) (const Map.empty) (const Map.empty)---- IntMap instances--instance LeftReductiveMonoid (IntMap.IntMap a) where- isPrefixOf = IntMap.isSubmapOfBy (\_ _-> True)- stripPrefix a b | IntMap.isSubmapOfBy (\_ _-> True) a b = Just (b IntMap.\\ a)- | otherwise = Nothing--instance Eq a => LeftGCDMonoid (IntMap.IntMap a) where- commonPrefix = IntMap.mergeWithKey (\_ a b -> if a == b then Just a else Nothing)- (const IntMap.empty) (const IntMap.empty)---- List instances--instance Eq x => LeftReductiveMonoid [x] where- stripPrefix = List.stripPrefix- isPrefixOf = List.isPrefixOf--instance Eq x => LeftCancellativeMonoid [x]--instance Eq x => LeftGCDMonoid [x] where- commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys- commonPrefix _ _ = []-- stripCommonPrefix x0 y0 = strip' id x0 y0- where strip' f (x:xs) (y:ys) | x == y = strip' (f . (x :)) xs ys- strip' f x y = (f [], x, y)---- Seq instances--instance Eq a => LeftReductiveMonoid (Sequence.Seq a) where- stripPrefix p s | p == s1 = Just s2- | otherwise = Nothing- where (s1, s2) = Sequence.splitAt (Sequence.length p) s--instance Eq a => RightReductiveMonoid (Sequence.Seq a) where- stripSuffix p s | p == s2 = Just s1- | otherwise = Nothing- where (s1, s2) = Sequence.splitAt (Sequence.length s - Sequence.length p) s--instance Eq a => LeftCancellativeMonoid (Sequence.Seq a)--instance Eq a => RightCancellativeMonoid (Sequence.Seq a)--instance Eq a => LeftGCDMonoid (Sequence.Seq a) where- stripCommonPrefix = findCommonPrefix Sequence.empty- where findCommonPrefix prefix a b = case (Sequence.viewl a, Sequence.viewl b)- of (a1:<a', b1:<b') | a1 == b1 -> findCommonPrefix (prefix |> a1) a' b'- _ -> (prefix, a, b)--instance Eq a => RightGCDMonoid (Sequence.Seq a) where- stripCommonSuffix = findCommonSuffix Sequence.empty- where findCommonSuffix suffix a b = case (Sequence.viewr a, Sequence.viewr b)- of (a':>a1, b':>b1) | a1 == b1 -> findCommonSuffix (a1 <| suffix) a' b'- _ -> (a, b, suffix)---- Vector instances--instance Eq a => LeftReductiveMonoid (Vector.Vector a) where- stripPrefix p l | prefixLength > Vector.length l = Nothing- | otherwise = strip 0- where strip i | i == prefixLength = Just (Vector.drop prefixLength l)- | l Vector.! i == p Vector.! i = strip (succ i)- | otherwise = Nothing- prefixLength = Vector.length p- isPrefixOf p l | prefixLength > Vector.length l = False- | otherwise = test 0- where test i | i == prefixLength = True- | l Vector.! i == p Vector.! i = test (succ i)- | otherwise = False- prefixLength = Vector.length p--instance Eq a => RightReductiveMonoid (Vector.Vector a) where- stripSuffix s l | suffixLength > Vector.length l = Nothing- | otherwise = strip (pred suffixLength)- where strip i | i == -1 = Just (Vector.take lengthDifference l)- | l Vector.! (lengthDifference + i) == s Vector.! i = strip (pred i)- | otherwise = Nothing- suffixLength = Vector.length s- lengthDifference = Vector.length l - suffixLength- isSuffixOf s l | suffixLength > Vector.length l = False- | otherwise = test (pred suffixLength)- where test i | i == -1 = True- | l Vector.! (lengthDifference + i) == s Vector.! i = test (pred i)- | otherwise = False- suffixLength = Vector.length s- lengthDifference = Vector.length l - suffixLength--instance Eq a => LeftCancellativeMonoid (Vector.Vector a)--instance Eq a => RightCancellativeMonoid (Vector.Vector a)--instance Eq a => LeftGCDMonoid (Vector.Vector a) where- stripCommonPrefix x y = (xp, xs, Vector.drop maxPrefixLength y)- where maxPrefixLength = prefixLength 0 (Vector.length x `min` Vector.length y)- prefixLength n len | n < len && x Vector.! n == y Vector.! n = prefixLength (succ n) len- prefixLength n _ = n- (xp, xs) = Vector.splitAt maxPrefixLength x--instance Eq a => RightGCDMonoid (Vector.Vector a) where- stripCommonSuffix x y = findSuffix (Vector.length x - 1) (Vector.length y - 1)- where findSuffix m n | m >= 0 && n >= 0 && x Vector.! m == y Vector.! n =- findSuffix (pred m) (pred n)- findSuffix m n = (Vector.take (succ m) x, yp, ys)- where (yp, ys) = Vector.splitAt (succ n) y---- ByteString instances--instance LeftReductiveMonoid ByteString.ByteString where- stripPrefix p l = if ByteString.isPrefixOf p l- then Just (ByteString.unsafeDrop (ByteString.length p) l)- else Nothing- isPrefixOf = ByteString.isPrefixOf--instance RightReductiveMonoid ByteString.ByteString where- stripSuffix s l = if ByteString.isSuffixOf s l- then Just (ByteString.unsafeTake (ByteString.length l - ByteString.length s) l)- else Nothing- isSuffixOf = ByteString.isSuffixOf--instance LeftCancellativeMonoid ByteString.ByteString--instance RightCancellativeMonoid ByteString.ByteString--instance LeftGCDMonoid ByteString.ByteString where- stripCommonPrefix x y = (xp, xs, ByteString.unsafeDrop maxPrefixLength y)- where maxPrefixLength = prefixLength 0 (ByteString.length x `min` ByteString.length y)- prefixLength n len | n < len,- ByteString.unsafeIndex x n == ByteString.unsafeIndex y n =- prefixLength (succ n) len- | otherwise = n- (xp, xs) = ByteString.splitAt maxPrefixLength x--instance RightGCDMonoid ByteString.ByteString where- stripCommonSuffix x y = findSuffix (ByteString.length x - 1) (ByteString.length y - 1)- where findSuffix m n | m >= 0, n >= 0,- ByteString.unsafeIndex x m == ByteString.unsafeIndex y n =- findSuffix (pred m) (pred n)- | otherwise = let (yp, ys) = ByteString.splitAt (succ n) y- in (ByteString.unsafeTake (succ m) x, yp, ys)---- Lazy ByteString instances--instance LeftReductiveMonoid LazyByteString.ByteString where- stripPrefix p l = if LazyByteString.isPrefixOf p l- then Just (LazyByteString.drop (LazyByteString.length p) l)- else Nothing- isPrefixOf = LazyByteString.isPrefixOf--instance RightReductiveMonoid LazyByteString.ByteString where- stripSuffix s l = if LazyByteString.isSuffixOf s l- then Just (LazyByteString.take (LazyByteString.length l - LazyByteString.length s) l)- else Nothing- isSuffixOf = LazyByteString.isSuffixOf--instance LeftCancellativeMonoid LazyByteString.ByteString--instance RightCancellativeMonoid LazyByteString.ByteString--instance LeftGCDMonoid LazyByteString.ByteString where- stripCommonPrefix x y = (xp, xs, LazyByteString.drop maxPrefixLength y)- where maxPrefixLength = prefixLength 0 (LazyByteString.length x `min` LazyByteString.length y)- prefixLength n len | n < len && LazyByteString.index x n == LazyByteString.index y n =- prefixLength (succ n) len- prefixLength n _ = n- (xp, xs) = LazyByteString.splitAt maxPrefixLength x--instance RightGCDMonoid LazyByteString.ByteString where- stripCommonSuffix x y = findSuffix (LazyByteString.length x - 1) (LazyByteString.length y - 1)- where findSuffix m n | m >= 0 && n >= 0 && LazyByteString.index x m == LazyByteString.index y n =- findSuffix (pred m) (pred n)- findSuffix m n = (LazyByteString.take (succ m) x, yp, ys)- where (yp, ys) = LazyByteString.splitAt (succ n) y---- Text instances--instance LeftReductiveMonoid Text.Text where- stripPrefix = Text.stripPrefix- isPrefixOf = Text.isPrefixOf--instance RightReductiveMonoid Text.Text where- stripSuffix = Text.stripSuffix- isSuffixOf = Text.isSuffixOf--instance LeftCancellativeMonoid Text.Text--instance RightCancellativeMonoid Text.Text--instance LeftGCDMonoid Text.Text where- stripCommonPrefix x y = maybe (Text.empty, x, y) id (Text.commonPrefixes x y)---- Lazy Text instances--instance LeftReductiveMonoid LazyText.Text where- stripPrefix = LazyText.stripPrefix- isPrefixOf = LazyText.isPrefixOf--instance RightReductiveMonoid LazyText.Text where- stripSuffix = LazyText.stripSuffix- isSuffixOf = LazyText.isSuffixOf--instance LeftCancellativeMonoid LazyText.Text--instance RightCancellativeMonoid LazyText.Text--instance LeftGCDMonoid LazyText.Text where- stripCommonPrefix x y = maybe (LazyText.empty, x, y) id (LazyText.commonPrefixes x y)
− Data/Monoid/Factorial.hs
@@ -1,827 +0,0 @@-{- - Copyright 2013-2015 Mario Blazevic-- License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines the 'FactorialMonoid' class and some of its instances.--- --{-# LANGUAGE Haskell2010, Trustworthy #-}--module Data.Monoid.Factorial (- -- * Classes- FactorialMonoid(..), StableFactorialMonoid,- -- * Monad function equivalents- mapM, mapM_- )-where--import Control.Arrow (first)-import qualified Control.Monad as Monad-import Data.Monoid -- (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo))-import qualified Data.Foldable as Foldable-import qualified Data.List as List-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Lazy as LazyByteString-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LazyText-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import qualified Data.Map as Map-import qualified Data.Sequence as Sequence-import qualified Data.Set as Set-import qualified Data.Vector as Vector-import Data.Int (Int64)-import Data.Numbers.Primes (primeFactors)--import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)--import Prelude hiding (break, drop, dropWhile, foldl, foldr, last, length, map, mapM, mapM_, max, min,- null, reverse, span, splitAt, take, takeWhile)----- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of--- a 'Product' are literally its prime factors:------ prop> factors (Product 12) == [Product 2, Product 2, Product 3]------ Factors of a list are /not/ its elements but all its single-item sublists:------ prop> factors "abc" == ["a", "b", "c"]--- --- The methods of this class satisfy the following laws:--- --- > mconcat . factors == id--- > null == List.null . factors--- > List.all (\prime-> factors prime == [prime]) . factors--- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix)--- > reverse == mconcat . List.reverse . factors--- > primePrefix == maybe mempty fst . splitPrimePrefix--- > primeSuffix == maybe mempty snd . splitPrimeSuffix--- > inits == List.map mconcat . List.inits . factors--- > tails == List.map mconcat . List.tails . factors--- > foldl f a == List.foldl f a . factors--- > foldl' f a == List.foldl' f a . factors--- > foldr f a == List.foldr f a . factors--- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m)--- > List.all (List.all (not . pred) . factors) . split pred--- > mconcat . intersperse prime . split (== prime) == id--- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m)--- > spanMaybe () (const $ bool Nothing (Maybe ()) . p) m == (takeWhile p m, dropWhile p m, ())--- > spanMaybe s0 (\s m-> Just $ f s m) m0 == (m0, mempty, foldl f s0 m0)--- > let (prefix, suffix, s') = spanMaybe s f m--- > foldMaybe = foldl g (Just s)--- > g s m = s >>= flip f m--- > in all ((Nothing ==) . foldMaybe) (inits prefix)--- > && prefix == last (filter (isJust . foldMaybe) $ inits m)--- > && Just s' == foldMaybe prefix--- > && m == prefix <> suffix------ A minimal instance definition must implement 'factors' or 'splitPrimePrefix'. Other methods are provided and should--- be implemented only for performance reasons.-class MonoidNull m => FactorialMonoid m where- -- | Returns a list of all prime factors; inverse of mconcat.- factors :: m -> [m]- -- | The prime prefix, 'mempty' if none.- primePrefix :: m -> m- -- | The prime suffix, 'mempty' if none.- primeSuffix :: m -> m- -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'.- splitPrimePrefix :: m -> Maybe (m, m)- -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'.- splitPrimeSuffix :: m -> Maybe (m, m)- -- | Returns the list of all prefixes of the argument, 'mempty' first.- inits :: m -> [m]- -- | Returns the list of all suffixes of the argument, 'mempty' last.- tails :: m -> [m]- -- | Like 'List.foldl' from "Data.List" on the list of 'primes'.- foldl :: (a -> m -> a) -> a -> m -> a- -- | Like 'List.foldl'' from "Data.List" on the list of 'primes'.- foldl' :: (a -> m -> a) -> a -> m -> a- -- | Like 'List.foldr' from "Data.List" on the list of 'primes'.- foldr :: (m -> a -> a) -> a -> m -> a- -- | The 'length' of the list of 'primes'.- length :: m -> Int- -- | Generalizes 'foldMap' from "Data.Foldable", except the function arguments are prime factors rather than the- -- structure elements.- foldMap :: Monoid n => (m -> n) -> m -> n- -- | Like 'List.span' from "Data.List" on the list of 'primes'.- span :: (m -> Bool) -> m -> (m, m)- -- | Equivalent to 'List.break' from "Data.List".- break :: (m -> Bool) -> m -> (m, m)- -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes- -- satisfying the predicate are not a part of the result.- split :: (m -> Bool) -> m -> [m]- -- | Equivalent to 'List.takeWhile' from "Data.List".- takeWhile :: (m -> Bool) -> m -> m- -- | Equivalent to 'List.dropWhile' from "Data.List".- dropWhile :: (m -> Bool) -> m -> m- -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'.- spanMaybe :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)- -- | Strict version of 'spanMaybe'.- spanMaybe' :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)- -- | Like 'List.splitAt' from "Data.List" on the list of 'primes'.- splitAt :: Int -> m -> (m, m)- -- | Equivalent to 'List.drop' from "Data.List".- drop :: Int -> m -> m- -- | Equivalent to 'List.take' from "Data.List".- take :: Int -> m -> m- -- | Equivalent to 'List.reverse' from "Data.List".- reverse :: m -> m-- factors = List.unfoldr splitPrimePrefix- primePrefix = maybe mempty fst . splitPrimePrefix- primeSuffix = maybe mempty snd . splitPrimeSuffix- splitPrimePrefix x = case factors x- of [] -> Nothing- prefix : rest -> Just (prefix, mconcat rest)- splitPrimeSuffix x = case factors x- of [] -> Nothing- fs -> Just (mconcat (List.init fs), List.last fs)- inits = foldr (\m l-> mempty : List.map (mappend m) l) [mempty]- tails m = m : maybe [] (tails . snd) (splitPrimePrefix m)- foldl f f0 = List.foldl f f0 . factors- foldl' f f0 = List.foldl' f f0 . factors- foldr f f0 = List.foldr f f0 . factors- length = List.length . factors- foldMap f = foldr (mappend . f) mempty- span p m0 = spanAfter id m0- where spanAfter f m = case splitPrimePrefix m- of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest- _ -> (f mempty, m)- break = span . (not .)- spanMaybe s0 f m0 = spanAfter id s0 m0- where spanAfter g s m = case splitPrimePrefix m- of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest- | otherwise -> (g mempty, m, s)- Nothing -> (m0, m, s)- spanMaybe' s0 f m0 = spanAfter id s0 m0- where spanAfter g s m = seq s $- case splitPrimePrefix m- of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest- | otherwise -> (g mempty, m, s)- Nothing -> (m0, m, s)- split p m = prefix : splitRest- where (prefix, rest) = break p m- splitRest = case splitPrimePrefix rest- of Nothing -> []- Just (_, tl) -> split p tl- takeWhile p = fst . span p- dropWhile p = snd . span p- splitAt n0 m0 | n0 <= 0 = (mempty, m0)- | otherwise = split' n0 id m0- where split' 0 f m = (f mempty, m)- split' n f m = case splitPrimePrefix m- of Nothing -> (f mempty, m)- Just (prime, rest) -> split' (pred n) (f . mappend prime) rest- drop n p = snd (splitAt n p)- take n p = fst (splitAt n p)- reverse = mconcat . List.reverse . factors- {-# MINIMAL factors | splitPrimePrefix #-}---- | A subclass of 'FactorialMonoid' whose instances satisfy this additional law:------ > factors (a <> b) == factors a <> factors b-class (FactorialMonoid m, PositiveMonoid m) => StableFactorialMonoid m--instance FactorialMonoid () where- factors () = []- primePrefix () = ()- primeSuffix () = ()- splitPrimePrefix () = Nothing- splitPrimeSuffix () = Nothing- length () = 0- reverse = id--instance FactorialMonoid a => FactorialMonoid (Dual a) where- factors (Dual a) = fmap Dual (reverse $ factors a)- length (Dual a) = length a- primePrefix (Dual a) = Dual (primeSuffix a)- primeSuffix (Dual a) = Dual (primePrefix a)- splitPrimePrefix (Dual a) = case splitPrimeSuffix a- of Nothing -> Nothing- Just (p, s) -> Just (Dual s, Dual p)- splitPrimeSuffix (Dual a) = case splitPrimePrefix a- of Nothing -> Nothing- Just (p, s) -> Just (Dual s, Dual p)- inits (Dual a) = fmap Dual (reverse $ tails a)- tails (Dual a) = fmap Dual (reverse $ inits a)- reverse (Dual a) = Dual (reverse a)--instance (Integral a, Eq a) => FactorialMonoid (Sum a) where- primePrefix (Sum a) = Sum (signum a )- primeSuffix = primePrefix- splitPrimePrefix (Sum 0) = Nothing- splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a))- splitPrimeSuffix (Sum 0) = Nothing- splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a))- length (Sum a) = abs (fromIntegral a)- reverse = id--instance Integral a => FactorialMonoid (Product a) where- factors (Product a) = List.map Product (primeFactors a)- reverse = id--instance FactorialMonoid a => FactorialMonoid (Maybe a) where- factors Nothing = []- factors (Just a) | null a = [Just a]- | otherwise = List.map Just (factors a)- length Nothing = 0- length (Just a) | null a = 1- | otherwise = length a- reverse = fmap reverse--instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where- factors (a, b) = List.map (\a1-> (a1, mempty)) (factors a) ++ List.map ((,) mempty) (factors b)- primePrefix (a, b) | null a = (a, primePrefix b)- | otherwise = (primePrefix a, mempty)- primeSuffix (a, b) | null b = (primeSuffix a, b)- | otherwise = (mempty, primeSuffix b)- splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b)- of (Just (ap, as), _) -> Just ((ap, mempty), (as, b))- (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs))- (Nothing, Nothing) -> Nothing- splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b)- of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs))- (Just (ap, as), Nothing) -> Just ((ap, b), (as, b))- (Nothing, Nothing) -> Nothing- inits (a, b) = List.map (flip (,) mempty) (inits a) ++ List.map ((,) a) (List.tail $ inits b)- tails (a, b) = List.map (flip (,) b) (tails a) ++ List.map ((,) mempty) (List.tail $ tails b)- foldl f a0 (x, y) = foldl f2 (foldl f1 a0 x) y- where f1 a = f a . fromFst- f2 a = f a . fromSnd- foldl' f a0 (x, y) = a' `seq` foldl' f2 a' y- where f1 a = f a . fromFst- f2 a = f a . fromSnd- a' = foldl' f1 a0 x- foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x- foldMap f (x, y) = Data.Monoid.Factorial.foldMap (f . fromFst) x `mappend` Data.Monoid.Factorial.foldMap (f . fromSnd) y- length (a, b) = length a + length b- span p (x, y) = ((xp, yp), (xs, ys))- where (xp, xs) = span (p . fromFst) x- (yp, ys) | null xs = span (p . fromSnd) y- | otherwise = (mempty, y)- spanMaybe s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)- | otherwise = ((xp, mempty), (xs, y), s1)- where (xp, xs, s1) = spanMaybe s0 (\s-> f s . fromFst) x- (yp, ys, s2) = spanMaybe s1 (\s-> f s . fromSnd) y- spanMaybe' s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)- | otherwise = ((xp, mempty), (xs, y), s1)- where (xp, xs, s1) = spanMaybe' s0 (\s-> f s . fromFst) x- (yp, ys, s2) = spanMaybe' s1 (\s-> f s . fromSnd) y- split p (x0, y0) = fst $ List.foldr combine (ys, False) xs- where xs = List.map fromFst $ split (p . fromFst) x0- ys = List.map fromSnd $ split (p . fromSnd) y0- combine x (~(y:rest), False) = (mappend x y : rest, True)- combine x (rest, True) = (x:rest, True)- splitAt n (x, y) = ((xp, yp), (xs, ys))- where (xp, xs) = splitAt n x- (yp, ys) | null xs = splitAt (n - length x) y- | otherwise = (mempty, y)- reverse (a, b) = (reverse a, reverse b)--{-# INLINE fromFst #-}-fromFst :: Monoid b => a -> (a, b)-fromFst a = (a, mempty)--{-# INLINE fromSnd #-}-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 [] = []- primePrefix (x:_) = [x]- primeSuffix [] = []- primeSuffix xs = [List.last xs]- splitPrimePrefix [] = Nothing- splitPrimePrefix (x:xs) = Just ([x], xs)- splitPrimeSuffix [] = Nothing- splitPrimeSuffix xs = Just (splitLast id xs)- where splitLast f last@[_] = (f [], last)- splitLast f ~(x:rest) = splitLast (f . (x:)) rest- inits = List.inits- tails = List.tails- foldl _ a [] = a- foldl f a (x:xs) = foldl f (f a [x]) xs- foldl' _ a [] = a- foldl' f a (x:xs) = let a' = f a [x] in a' `seq` foldl' f a' xs- foldr _ f0 [] = f0- foldr f f0 (x:xs) = f [x] (foldr f f0 xs)- length = List.length- foldMap f = mconcat . List.map (f . (:[]))- break f = List.break (f . (:[]))- span f = List.span (f . (:[]))- dropWhile f = List.dropWhile (f . (:[]))- takeWhile f = List.takeWhile (f . (:[]))- spanMaybe s0 f l = (prefix' [], suffix' [], s')- where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l- g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = (prefix . (x:), id, s2, True)- | otherwise = (prefix, suffix . (x:), s1, False)- spanMaybe' s0 f l = (prefix' [], suffix' [], s')- where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l- g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = seq s2 $ (prefix . (x:), id, s2, True)- | otherwise = (prefix, suffix . (x:), s1, False)- splitAt = List.splitAt- drop = List.drop- take = List.take- reverse = List.reverse--instance FactorialMonoid ByteString.ByteString where- factors x = factorize (ByteString.length x) x- where factorize 0 _ = []- factorize n xs = xs1 : factorize (pred n) xs'- where (xs1, xs') = ByteString.splitAt 1 xs- primePrefix = ByteString.take 1- primeSuffix x = ByteString.drop (ByteString.length x - 1) x- splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x)- splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x)- inits = ByteString.inits- tails = ByteString.tails- foldl f = ByteString.foldl f'- where f' a byte = f a (ByteString.singleton byte)- foldl' f = ByteString.foldl' f'- where f' a byte = f a (ByteString.singleton byte)- foldr f = ByteString.foldr (f . ByteString.singleton)- break f = ByteString.break (f . ByteString.singleton)- span f = ByteString.span (f . ByteString.singleton)- spanMaybe s0 f b = case ByteString.foldr g id b (0, s0)- of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')- where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s')- | otherwise = (i, s)- spanMaybe' s0 f b = case ByteString.foldr g id b (0, s0)- of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')- 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')- | otherwise = (i, s)- dropWhile f = ByteString.dropWhile (f . ByteString.singleton)- takeWhile f = ByteString.takeWhile (f . ByteString.singleton)- length = ByteString.length- split f = ByteString.splitWith f'- where f' = f . ByteString.singleton- splitAt = ByteString.splitAt- drop = ByteString.drop- take = ByteString.take- reverse = ByteString.reverse--instance FactorialMonoid LazyByteString.ByteString where- factors x = factorize (LazyByteString.length x) x- where factorize 0 _ = []- factorize n xs = xs1 : factorize (pred n) xs'- where (xs1, xs') = LazyByteString.splitAt 1 xs- primePrefix = LazyByteString.take 1- primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x- splitPrimePrefix x = if LazyByteString.null x then Nothing- else Just (LazyByteString.splitAt 1 x)- splitPrimeSuffix x = if LazyByteString.null x then Nothing- else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x)- inits = LazyByteString.inits- tails = LazyByteString.tails- foldl f = LazyByteString.foldl f'- where f' a byte = f a (LazyByteString.singleton byte)- foldl' f = LazyByteString.foldl' f'- where f' a byte = f a (LazyByteString.singleton byte)- foldr f = LazyByteString.foldr f'- where f' byte a = f (LazyByteString.singleton byte) a- length = fromIntegral . LazyByteString.length- break f = LazyByteString.break (f . LazyByteString.singleton)- span f = LazyByteString.span (f . LazyByteString.singleton)- spanMaybe s0 f b = case LazyByteString.foldr g id b (0, s0)- of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')- where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ cont (i', s')- | otherwise = (i, s)- spanMaybe' s0 f b = case LazyByteString.foldr g id b (0, s0)- of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')- where g w cont (i, s)- | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')- | otherwise = (i, s)- dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton)- takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton)- split f = LazyByteString.splitWith f'- where f' = f . LazyByteString.singleton- splitAt = LazyByteString.splitAt . fromIntegral- drop n = LazyByteString.drop (fromIntegral n)- take n = LazyByteString.take (fromIntegral n)- reverse = LazyByteString.reverse--instance FactorialMonoid Text.Text where- factors = Text.chunksOf 1- primePrefix = Text.take 1- primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x)- splitPrimePrefix = fmap (first Text.singleton) . Text.uncons- splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x))- inits = Text.inits- tails = Text.tails- foldl f = Text.foldl f'- where f' a char = f a (Text.singleton char)- foldl' f = Text.foldl' f'- where f' a char = f a (Text.singleton char)- foldr f = Text.foldr f'- where f' char a = f (Text.singleton char) a- length = Text.length- span f = Text.span (f . Text.singleton)- break f = Text.break (f . Text.singleton)- dropWhile f = Text.dropWhile (f . Text.singleton)- takeWhile f = Text.takeWhile (f . Text.singleton)- spanMaybe s0 f t = case Text.foldr g id t (0, s0)- of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')- where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ cont (i', s')- | otherwise = (i, s)- spanMaybe' s0 f t = case Text.foldr g id t (0, s0)- of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')- 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')- | otherwise = (i, s)- split f = Text.split f'- where f' = f . Text.singleton- splitAt = Text.splitAt- drop = Text.drop- take = Text.take- reverse = Text.reverse--instance FactorialMonoid LazyText.Text where- factors = LazyText.chunksOf 1- primePrefix = LazyText.take 1- primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x)- splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons- splitPrimeSuffix x = if LazyText.null x- then Nothing- else Just (LazyText.init x, LazyText.singleton (LazyText.last x))- inits = LazyText.inits- tails = LazyText.tails- foldl f = LazyText.foldl f'- where f' a char = f a (LazyText.singleton char)- foldl' f = LazyText.foldl' f'- where f' a char = f a (LazyText.singleton char)- foldr f = LazyText.foldr f'- where f' char a = f (LazyText.singleton char) a- length = fromIntegral . LazyText.length- span f = LazyText.span (f . LazyText.singleton)- break f = LazyText.break (f . LazyText.singleton)- dropWhile f = LazyText.dropWhile (f . LazyText.singleton)- takeWhile f = LazyText.takeWhile (f . LazyText.singleton)- spanMaybe s0 f t = case LazyText.foldr g id t (0, s0)- of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')- where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ cont (i', s')- | otherwise = (i, s)- spanMaybe' s0 f t = case LazyText.foldr g id t (0, s0)- of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')- 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')- | otherwise = (i, s)- split f = LazyText.split f'- where f' = f . LazyText.singleton- splitAt = LazyText.splitAt . fromIntegral- drop n = LazyText.drop (fromIntegral n)- take n = LazyText.take (fromIntegral n)- reverse = LazyText.reverse--instance Ord k => FactorialMonoid (Map.Map k v) where- factors = List.map (uncurry Map.singleton) . Map.toAscList- primePrefix map | Map.null map = map- | otherwise = uncurry Map.singleton $ Map.findMin map- primeSuffix map | Map.null map = map- | otherwise = uncurry Map.singleton $ Map.findMax map- splitPrimePrefix = fmap singularize . Map.minViewWithKey- where singularize ((k, v), rest) = (Map.singleton k v, rest)- splitPrimeSuffix = fmap singularize . Map.maxViewWithKey- where singularize ((k, v), rest) = (rest, Map.singleton k v)- foldl f = Map.foldlWithKey f'- where f' a k v = f a (Map.singleton k v)- foldl' f = Map.foldlWithKey' f'- where f' a k v = f a (Map.singleton k v)- foldr f = Map.foldrWithKey f'- where f' k v a = f (Map.singleton k v) a- length = Map.size- reverse = id--instance FactorialMonoid (IntMap.IntMap a) where- factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList- primePrefix map | IntMap.null map = map- | otherwise = uncurry IntMap.singleton $ IntMap.findMin map- primeSuffix map | IntMap.null map = map- | otherwise = uncurry IntMap.singleton $ IntMap.findMax map- splitPrimePrefix = fmap singularize . IntMap.minViewWithKey- where singularize ((k, v), rest) = (IntMap.singleton k v, rest)- splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey- where singularize ((k, v), rest) = (rest, IntMap.singleton k v)- foldl f = IntMap.foldlWithKey f'- where f' a k v = f a (IntMap.singleton k v)- foldl' f = IntMap.foldlWithKey' f'- where f' a k v = f a (IntMap.singleton k v)- foldr f = IntMap.foldrWithKey f'- where f' k v a = f (IntMap.singleton k v) a- length = IntMap.size- reverse = id--instance FactorialMonoid IntSet.IntSet where- factors = List.map IntSet.singleton . IntSet.toAscList- primePrefix set | IntSet.null set = set- | otherwise = IntSet.singleton $ IntSet.findMin set- primeSuffix set | IntSet.null set = set- | otherwise = IntSet.singleton $ IntSet.findMax set- splitPrimePrefix = fmap singularize . IntSet.minView- where singularize (min, rest) = (IntSet.singleton min, rest)- splitPrimeSuffix = fmap singularize . IntSet.maxView- where singularize (max, rest) = (rest, IntSet.singleton max)- foldl f = IntSet.foldl f'- where f' a b = f a (IntSet.singleton b)- foldl' f = IntSet.foldl' f'- where f' a b = f a (IntSet.singleton b)- foldr f = IntSet.foldr f'- where f' a b = f (IntSet.singleton a) b- length = IntSet.size- reverse = id--instance FactorialMonoid (Sequence.Seq a) where- factors = List.map Sequence.singleton . Foldable.toList- primePrefix = Sequence.take 1- primeSuffix q = Sequence.drop (Sequence.length q - 1) q- splitPrimePrefix q = case Sequence.viewl q- of Sequence.EmptyL -> Nothing- hd Sequence.:< rest -> Just (Sequence.singleton hd, rest)- splitPrimeSuffix q = case Sequence.viewr q- of Sequence.EmptyR -> Nothing- rest Sequence.:> last -> Just (rest, Sequence.singleton last)- inits = Foldable.toList . Sequence.inits- tails = Foldable.toList . Sequence.tails- foldl f = Foldable.foldl f'- where f' a b = f a (Sequence.singleton b)- foldl' f = Foldable.foldl' f'- where f' a b = f a (Sequence.singleton b)- foldr f = Foldable.foldr f'- where f' a b = f (Sequence.singleton a) b- span f = Sequence.spanl (f . Sequence.singleton)- break f = Sequence.breakl (f . Sequence.singleton)- dropWhile f = Sequence.dropWhileL (f . Sequence.singleton)- takeWhile f = Sequence.takeWhileL (f . Sequence.singleton)- spanMaybe s0 f b = case Foldable.foldr g id b (0, s0)- of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')- where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ cont (i', s')- | otherwise = (i, s)- spanMaybe' s0 f b = case Foldable.foldr g id b (0, s0)- of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')- 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')- | otherwise = (i, s)- splitAt = Sequence.splitAt- drop = Sequence.drop- take = Sequence.take- length = Sequence.length- reverse = Sequence.reverse--instance Ord a => FactorialMonoid (Set.Set a) where- factors = List.map Set.singleton . Set.toAscList- primePrefix set | Set.null set = set- | otherwise = Set.singleton $ Set.findMin set- primeSuffix set | Set.null set = set- | otherwise = Set.singleton $ Set.findMax set- splitPrimePrefix = fmap singularize . Set.minView- where singularize (min, rest) = (Set.singleton min, rest)- splitPrimeSuffix = fmap singularize . Set.maxView- where singularize (max, rest) = (rest, Set.singleton max)- foldl f = Foldable.foldl f'- where f' a b = f a (Set.singleton b)- foldl' f = Foldable.foldl' f'- where f' a b = f a (Set.singleton b)- foldr f = Foldable.foldr f'- where f' a b = f (Set.singleton a) b- length = Set.size- reverse = id--instance FactorialMonoid (Vector.Vector a) where- factors x = factorize (Vector.length x) x- where factorize 0 _ = []- factorize n xs = xs1 : factorize (pred n) xs'- where (xs1, xs') = Vector.splitAt 1 xs- primePrefix = Vector.take 1- primeSuffix x = Vector.drop (Vector.length x - 1) x- splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x)- splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x)- inits x0 = initsWith x0 []- where initsWith x rest | Vector.null x = x:rest- | otherwise = initsWith (Vector.unsafeInit x) (x:rest)- tails x = x : if Vector.null x then [] else tails (Vector.unsafeTail x)- foldl f = Vector.foldl f'- where f' a byte = f a (Vector.singleton byte)- foldl' f = Vector.foldl' f'- where f' a byte = f a (Vector.singleton byte)- foldr f = Vector.foldr f'- where f' byte a = f (Vector.singleton byte) a- break f = Vector.break (f . Vector.singleton)- span f = Vector.span (f . Vector.singleton)- dropWhile f = Vector.dropWhile (f . Vector.singleton)- takeWhile f = Vector.takeWhile (f . Vector.singleton)- spanMaybe s0 f v = case Vector.ifoldr g Left v s0- of Left s' -> (v, Vector.empty, s')- Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')- where g i x cont s | Just s' <- f s (Vector.singleton x) = cont s'- | otherwise = Right (i, s)- spanMaybe' s0 f v = case Vector.ifoldr' g Left v s0- of Left s' -> (v, Vector.empty, s')- Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')- where g i x cont s | Just s' <- f s (Vector.singleton x) = seq s' (cont s')- | otherwise = Right (i, s)- splitAt = Vector.splitAt- drop = Vector.drop- take = Vector.take- length = Vector.length- reverse = Vector.reverse--instance StableFactorialMonoid ()-instance StableFactorialMonoid a => StableFactorialMonoid (Dual a)-instance StableFactorialMonoid [x]-instance StableFactorialMonoid ByteString.ByteString-instance StableFactorialMonoid LazyByteString.ByteString-instance StableFactorialMonoid Text.Text-instance StableFactorialMonoid LazyText.Text-instance StableFactorialMonoid (Sequence.Seq a)-instance StableFactorialMonoid (Vector.Vector a)---- | A 'Monad.mapM' equivalent.-mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b-mapM f = ($ return mempty) . appEndo . Data.Monoid.Factorial.foldMap (Endo . Monad.liftM2 mappend . f)---- | A 'Monad.mapM_' equivalent.-mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m ()-mapM_ f = foldr ((>>) . f) (return ())
− Data/Monoid/Instances/ByteString/UTF8.hs
@@ -1,498 +0,0 @@-{- - Copyright 2013-2018 Mario Blazevic-- License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines the 'ByteStringUTF8' newtype wrapper around 'ByteString', together with its 'TextualMonoid'--- instance. The 'FactorialMonoid' instance of a wrapped 'ByteStringUTF8' value differs from the original 'ByteString':--- the prime 'factors' of the original value are its bytes, and for the wrapped value the prime 'factors' are its valid--- UTF8 byte sequences. The following example session demonstrates the relationship:--- --- >> let utf8@(ByteStringUTF8 bs) = fromString "E=mc\xb2"--- >> bs--- >"E=mc\194\178"--- >> factors bs--- >["E","=","m","c","\194","\178"]--- >> utf8--- >"E=mc²"--- >> factors utf8--- >["E","=","m","c","²"]------ The 'TextualMonoid' instance follows the same logic, but it also decodes all valid UTF8 sequences into--- characters. Any invalid UTF8 byte sequence from the original 'ByteString' is preserved as a single prime factor:------ >> let utf8'@(ByteStringUTF8 bs') = ByteStringUTF8 (Data.ByteString.map pred bs)--- >> bs'--- >"D<lb\193\177"--- >> factors bs'--- >["D","<","l","b","\193","\177"]--- >> utf8'--- >"D<lb\[193,177]"--- >> factors utf8'--- >["D","<","l","b","\[193,177]"]--{-# LANGUAGE Haskell2010 #-}--module Data.Monoid.Instances.ByteString.UTF8 (- ByteStringUTF8(..), decode- )-where--import Control.Exception (assert)-import Data.Bits ((.&.), (.|.), shiftL, shiftR)-import Data.Char (chr, ord, isDigit, isPrint)-import qualified Data.Foldable as Foldable-import qualified Data.List as List-import Data.Maybe (fromMaybe, isJust, isNothing)-import Data.String (IsString(fromString))-import Data.Word (Word8)-import Data.ByteString (ByteString)-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Char8 as ByteString.Char8-import Data.ByteString.Internal (w2c)-import Data.ByteString.Unsafe (unsafeDrop, unsafeHead, unsafeTail, unsafeTake, unsafeIndex)--import Data.Semigroup -- (Semigroup(..))-import Data.Monoid (Monoid(mempty, mappend))-import Data.Monoid.Cancellative (LeftReductiveMonoid(..), LeftCancellativeMonoid, LeftGCDMonoid(..))-import Data.Monoid.Null (MonoidNull(..), PositiveMonoid)-import Data.Monoid.Factorial (FactorialMonoid(..))-import Data.Monoid.Textual (TextualMonoid(..))-import qualified Data.Monoid.Factorial as Factorial (FactorialMonoid(..))-import qualified Data.Monoid.Textual as Textual (TextualMonoid(..))--import Prelude hiding (any, drop, dropWhile, foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1,- map, concatMap, break, span)--newtype ByteStringUTF8 = ByteStringUTF8 ByteString deriving (Eq, Ord)---- | Takes a raw 'ByteString' chunk and returns a pair of 'ByteStringUTF8' decoding the prefix of the chunk and the--- remaining suffix that is either null or contains the incomplete last character of the chunk.-decode :: ByteString -> (ByteStringUTF8, ByteString)-decode bs- | ByteString.null bs || l < 0x80 = (ByteStringUTF8 bs, mempty)- | l >= 0xC0 = (ByteStringUTF8 (ByteString.init bs), ByteString.singleton l)- | ByteString.null prefix = (mempty, bs)- | otherwise =- case toChar (ByteString.last prefix) suffix- of Nothing -> (ByteStringUTF8 (ByteString.init prefix), drop (ByteString.length prefix - 1) bs)- Just{} -> (ByteStringUTF8 bs, mempty)- where (prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs- l = ByteString.last bs--instance Semigroup ByteStringUTF8 where- ByteStringUTF8 a <> ByteStringUTF8 b = ByteStringUTF8 (a <> b)- {-# INLINE (<>) #-}--instance Monoid ByteStringUTF8 where- mempty = ByteStringUTF8 ByteString.empty- {-# INLINE mempty #-}- ByteStringUTF8 a `mappend` ByteStringUTF8 b = ByteStringUTF8 (a `mappend` b)- {-# INLINE mappend #-}--instance MonoidNull ByteStringUTF8 where- null (ByteStringUTF8 b) = ByteString.null b- {-# INLINE null #-}--instance LeftReductiveMonoid ByteStringUTF8 where- stripPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = fmap ByteStringUTF8 (stripPrefix a b)- {-# INLINE stripPrefix #-}- ByteStringUTF8 a `isPrefixOf` ByteStringUTF8 b = a `isPrefixOf` b- {-# INLINE isPrefixOf #-}--instance LeftCancellativeMonoid ByteStringUTF8--instance LeftGCDMonoid ByteStringUTF8 where- commonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = ByteStringUTF8 (commonPrefix a b)- {-# INLINE commonPrefix #-}- stripCommonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = wrapTriple (stripCommonPrefix a b)- {-# INLINE stripCommonPrefix #-}--instance Show ByteStringUTF8 where- showsPrec _ bs s0 = '"' : Textual.foldr showsBytes showsChar ('"' : s0) bs- where showsBytes (ByteStringUTF8 b) s = '\\' : shows (ByteString.unpack b) s- showsChar c s- | isPrint c = c : s- | h:_ <- s, isDigit h = "\\" ++ show (ord c) ++ "\\&" ++ s- | otherwise = "\\" ++ show (ord c) ++ s--instance IsString ByteStringUTF8 where- fromString = ByteStringUTF8 . Foldable.foldMap fromChar- {-# INLINE fromString #-}--instance PositiveMonoid ByteStringUTF8--instance FactorialMonoid ByteStringUTF8 where- splitPrimePrefix utf8@(ByteStringUTF8 bs)- | ByteString.null bs = Nothing- | unsafeHead bs < 0x80 = Just (wrapPair $ ByteString.splitAt 1 bs)- | otherwise = case ByteString.findIndex byteStartsCharacter (unsafeTail bs)- of Just i -> Just (wrapPair $ ByteString.splitAt (succ i) bs)- Nothing -> Just (utf8, ByteStringUTF8 $ ByteString.empty)- {-# INLINABLE splitPrimePrefix #-}- splitPrimeSuffix (ByteStringUTF8 bs)- | ByteString.null bs = Nothing- | ByteString.null prefix = Just (wrapPair splitBS)- | not (ByteString.null suffix) && ByteString.last prefix < 0x80 = Just (wrapPair splitBS)- | otherwise = Just (wrapPair $ ByteString.splitAt (pred $ ByteString.length prefix) bs)- where splitBS@(prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs- {-# INLINABLE splitPrimeSuffix #-}- primePrefix utf8@(ByteStringUTF8 bs)- | ByteString.null bs = utf8- | unsafeHead bs < 0x80 = ByteStringUTF8 (ByteString.take 1 bs)- | otherwise = case ByteString.findIndex byteStartsCharacter (unsafeTail bs)- of Just i -> ByteStringUTF8 (ByteString.take (succ i) bs)- Nothing -> utf8- {-# INLINABLE primePrefix #-}- factors (ByteStringUTF8 bs) = List.map ByteStringUTF8 $ ByteString.groupBy continued bs- where continued a b = a >= 0x80 && b >= 0x80 && b < 0xC0- {-# INLINABLE factors #-}- length (ByteStringUTF8 bs) = fst (ByteString.foldl' count (0, False) bs)- where count (n, high) byte | byte < 0x80 = (succ n, False)- | byte < 0xC0 = (if high then n else succ n, True)- | otherwise = (succ n, True)- {-# INLINABLE length #-}- foldl f a0 (ByteStringUTF8 bs) = List.foldl f' a0 (groupASCII bs)- where f' a b | unsafeHead b < 0x80 = ByteString.foldl f'' a b- | otherwise = f a (ByteStringUTF8 b)- f'' a w = f a (ByteStringUTF8 $ ByteString.singleton w)- {-# INLINABLE foldl #-}- foldl' f a0 (ByteStringUTF8 bs) = List.foldl' f' a0 (groupASCII bs)- where f' a b | unsafeHead b < 0x80 = ByteString.foldl' f'' a b- | otherwise = f a (ByteStringUTF8 b)- f'' a w = f a (ByteStringUTF8 $ ByteString.singleton w)- {-# INLINABLE foldl' #-}- foldr f a0 (ByteStringUTF8 bs) = List.foldr f' a0 (groupASCII bs)- where f' b a | unsafeHead b < 0x80 = ByteString.foldr f'' a b- | otherwise = f (ByteStringUTF8 b) a- f'' w a = f (ByteStringUTF8 $ ByteString.singleton w) a- {-# INLINABLE foldr #-}- splitAt n (ByteStringUTF8 bs) = wrapPair (ByteString.splitAt (charStartIndex n bs) bs)- {-# INLINE splitAt #-}- take n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.take (charStartIndex n bs) bs)- {-# INLINE take #-}- drop n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.drop (charStartIndex n bs) bs)- {-# INLINE drop #-}- dropWhile p (ByteStringUTF8 bs0) = dropASCII bs0- where dropASCII bs =- let suffix = ByteString.dropWhile (\w-> w < 0x80 && p (ByteStringUTF8 $ ByteString.singleton w)) bs- in if ByteString.null suffix || unsafeHead suffix < 0x80- then ByteStringUTF8 suffix- else dropMultiByte suffix- dropMultiByte bs =- let utf8 = ByteStringUTF8 bs- in case ByteString.findIndex byteStartsCharacter (unsafeTail bs)- of Nothing -> if p utf8 then ByteStringUTF8 ByteString.empty else utf8- Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs- in if p (ByteStringUTF8 hd)- then dropASCII tl- else utf8- {-# INLINE dropWhile #-}- takeWhile p utf8@(ByteStringUTF8 bs) =- ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs- where (ByteStringUTF8 s) = Factorial.dropWhile p utf8- {-# INLINE takeWhile #-}- span p utf8@(ByteStringUTF8 bs) =- (ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs, suffix)- where suffix@(ByteStringUTF8 s) = Factorial.dropWhile p utf8- {-# INLINE span #-}- break p = Factorial.span (not . p)- {-# INLINE break #-}- spanMaybe s0 f (ByteStringUTF8 bs0) = (ByteStringUTF8 $ ByteString.take (ByteString.length bs0 - ByteString.length dropped) bs0,- ByteStringUTF8 dropped,- s')- where (dropped, s') = dropASCII s0 bs0- dropASCII s bs =- let suffix = ByteString.drop index bs- (index, s1) = ByteString.foldr f8 id bs (0, s)- f8 w cont (i, s2)- | w < 0x80, Just s3 <- f s2 (ByteStringUTF8 $ ByteString.singleton w) =- let i' = succ i :: Int in seq i' $ cont (i', s3)- | otherwise = (i, s2)- in if ByteString.null suffix || unsafeHead suffix < 0x80- then (suffix, s1)- else dropMultiByte s1 suffix- dropMultiByte s bs =- case ByteString.findIndex byteStartsCharacter (unsafeTail bs)- of Nothing -> case f s (ByteStringUTF8 bs)- of Just s1 -> (ByteString.empty, s1)- Nothing -> (bs, s)- Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs- in case f s (ByteStringUTF8 hd)- of Just s1 -> dropASCII s1 tl- Nothing -> (bs, s)- {-# INLINE spanMaybe #-}- spanMaybe' s0 f (ByteStringUTF8 bs0) = (ByteStringUTF8 $- ByteString.take (ByteString.length bs0 - ByteString.length dropped) bs0,- ByteStringUTF8 dropped,- s')- where (dropped, s') = dropASCII s0 bs0- dropASCII s bs =- let suffix = ByteString.drop index bs- (index, s1) = ByteString.foldr f8 id bs (0, s)- f8 w cont (i, s2)- | w < 0x80, Just s3 <- f s2 (ByteStringUTF8 $ ByteString.singleton w) =- let i' = succ i :: Int in seq i' $ seq s3 $ cont (i', s3)- | otherwise = (i, s)- in if ByteString.null suffix || unsafeHead suffix < 0x80- then (suffix, s1)- else dropMultiByte s1 suffix- dropMultiByte s bs =- case ByteString.findIndex byteStartsCharacter (unsafeTail bs)- of Nothing -> case f s (ByteStringUTF8 bs)- of Just s1 -> seq s1 (ByteString.empty, s1)- Nothing -> (bs, s)- Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs- in case f s (ByteStringUTF8 hd)- of Just s1 -> seq s1 (dropASCII s1 tl)- Nothing -> (bs, s)- {-# INLINE spanMaybe' #-}- reverse (ByteStringUTF8 bs) =- ByteStringUTF8 (ByteString.concat $ List.reverse $ List.map reverseASCII $ groupASCII bs)- where reverseASCII b | unsafeHead b < 0x80 = ByteString.reverse b- | otherwise = b- {-# INLINABLE reverse #-}--instance TextualMonoid ByteStringUTF8 where- singleton = ByteStringUTF8 . fromChar- {-# INLINE singleton #-}- splitCharacterPrefix (ByteStringUTF8 bs) = ByteString.uncons bs >>= uncurry toChar- {-# INLINE splitCharacterPrefix #-}- foldl ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldl f (a0, []) bs- of (a, []) -> a- (a, acc) -> multiByte a acc- where f (a, []) c | c < '\x80' = (fc a c, [])- | otherwise = (a, [fromIntegral $ ord c])- f (a, acc) c | c < '\x80' = (fc (multiByte a acc) c, [])- | c < '\xC0' = (a, fromIntegral (ord c) : acc)- | otherwise = (multiByte a acc, [fromIntegral $ ord c])- multiByte a acc = reverseBytesToChar (ft a . ByteStringUTF8) (fc a) acc- {-# INLINE foldl #-}- foldl' ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldl' f (a0, []) bs- of (a, []) -> a- (a, acc) -> multiByte a acc- where f (a, []) c | c < '\x80' = (fc a c, [])- | otherwise = seq a (a, [fromIntegral $ ord c])- f (a, acc) c | seq a c < '\x80' = let a' = multiByte a acc in seq a' (fc a' c, [])- | c < '\xC0' = (a, fromIntegral (ord c) : acc)- | otherwise = let a' = multiByte a acc in seq a' (a', [fromIntegral $ ord c])- multiByte a acc = reverseBytesToChar (ft a . ByteStringUTF8) (fc a) acc- {-# INLINE foldl' #-}- foldr ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldr f (a0, []) bs- of (a, []) -> a- (a, acc) -> multiByte a acc- where f c (a, []) | c < '\x80' = (fc c a, [])- | c < '\xC0' = (a, [fromIntegral $ ord c])- | otherwise = (ft (ByteStringUTF8 $ ByteString.Char8.singleton c) a, [])- f c (a, acc) | c < '\x80' = (fc c (ft (ByteStringUTF8 $ ByteString.pack acc) a), [])- | c < '\xC0' = (a, fromIntegral (ord c) : acc)- | otherwise = (multiByte a (fromIntegral (ord c) : acc), [])- multiByte a acc = bytesToChar ((`ft` a) . ByteStringUTF8) (`fc` a) acc- {-# INLINE foldr #-}- dropWhile pb pc (ByteStringUTF8 bs) = ByteStringUTF8 $ dropASCII bs- where dropASCII rest = case ByteString.Char8.findIndex (\c-> c > '\x7f' || not (pc c)) rest- of Nothing -> ByteString.empty- Just j -> let rest' = unsafeDrop j rest- in if unsafeHead rest' > 0x7f- then dropMultiByte rest'- else rest'- dropMultiByte rest = case splitCharacterPrefix (ByteStringUTF8 rest)- of Just (c, ByteStringUTF8 rest') | pc c -> dropASCII rest'- Nothing -> let j = succ (headIndex $ drop 1 rest)- in if pb (ByteStringUTF8 $ ByteString.take j rest)- then dropASCII (unsafeDrop j rest)- else rest- _ -> rest- {-# INLINE dropWhile #-}- takeWhile pb pc utf8@(ByteStringUTF8 bs) =- ByteStringUTF8 $ unsafeTake (ByteString.length bs - ByteString.length suffix) bs- where ByteStringUTF8 suffix = Textual.dropWhile pb pc utf8- {-# INLINE takeWhile #-}- span pb pc utf8@(ByteStringUTF8 bs) = (ByteStringUTF8 $ unsafeTake (ByteString.length bs - ByteString.length suffix') bs, suffix)- where suffix@(ByteStringUTF8 suffix') = Textual.dropWhile pb pc utf8- {-# INLINE span #-}- break pb pc = Textual.span (not . pb) (not . pc)- {-# INLINE break #-}- spanMaybe s0 ft fc (ByteStringUTF8 bs) =- let inner i s- | i < len =- let w = unsafeIndex bs i- in if w < 0x80- then case fc s (w2c w)- of Just s' -> inner (i + 1) s'- Nothing -> done i s- else case splitCharacterPrefix (ByteStringUTF8 $ unsafeDrop i bs)- of Just (c, ByteStringUTF8 rest) | Just s' <- fc s c -> inner (len - ByteString.length rest) s'- Nothing -> let j = succ (headIndex $ drop (i + 1) bs)- in case ft s (ByteStringUTF8 $ ByteString.take j $ unsafeDrop i bs)- of Just s' -> inner (i + j) s'- Nothing -> done i s- _ -> done i s- | otherwise = done i s- done i s = i `seq` s `seq` (ByteStringUTF8 $ unsafeTake i bs, ByteStringUTF8 $ unsafeDrop i bs, s)- len = ByteString.length bs- in inner 0 s0- {-# INLINE spanMaybe #-}- spanMaybe' s0 ft fc (ByteStringUTF8 bs) =- let inner i s- | i < len =- s `seq`- let w = unsafeIndex bs i- in if w < 0x80- then case fc s (w2c w)- of Just s' -> inner (i + 1) s'- Nothing -> done i s- else case splitCharacterPrefix (ByteStringUTF8 $ unsafeDrop i bs)- of Just (c, ByteStringUTF8 rest) | Just s' <- fc s c -> inner (len - ByteString.length rest) s'- Nothing -> let j = succ (headIndex $ drop (i + 1) bs)- in case ft s (ByteStringUTF8 $ ByteString.take j $ unsafeDrop i bs)- of Just s' -> inner (i + j) s'- Nothing -> done i s- _ -> done i s- | otherwise = done i s- done i s = i `seq` s `seq` (ByteStringUTF8 $ unsafeTake i bs, ByteStringUTF8 $ unsafeDrop i bs, s)- len = ByteString.length bs- in inner 0 s0- {-# INLINE spanMaybe' #-}- find p (ByteStringUTF8 bs0) = loop bs0- where loop bs = case ByteString.Char8.findIndex (\c-> c >= '\x80' || p c) bs- of Nothing -> Nothing- Just i -> let x = unsafeIndex bs i- bs' = unsafeDrop (i + 1) bs- in if x < 0x80- then Just (w2c x)- else case toChar x bs'- of Just (c, ByteStringUTF8 rest) | p c -> Just c- | otherwise -> loop rest- Nothing -> loop (ByteString.dropWhile (not . byteStartsCharacter) bs')- {-# INLINE find #-}- any p utf8 = isJust (find p utf8)- {-# INLINE any #-}- all p utf8 = isNothing (find (not . p) utf8)- {-# INLINE all #-}- elem c utf8@(ByteStringUTF8 bs)- | c < '\x80' = ByteString.Char8.elem c bs- | otherwise = any (== c) utf8- {-# INLINE elem #-}--reverseBytesToChar :: (ByteString -> a) -> (Char -> a) -> [Word8] -> a-reverseBytesToChar ft fc [w] = if w < 0x80 then fc (w2c w) else ft (ByteString.singleton w)-reverseBytesToChar ft fc [b0, b1] =- assert (0x80 <= b0 && b0 < 0xC0) $- if 0xC2 <= b1 && b1 < 0xE0- then fc (chr (shiftL (fromIntegral b1 .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F))- else ft (ByteString.pack [b1, b0])-reverseBytesToChar ft fc [b0, b1, b2] =- assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0) $- if (0xE0 < b2 || 0xE0 == b2 && 0xA0 <= b1) && b2 < 0xF0- then fc (chr (shiftL (fromIntegral b2 .&. 0xF) 12- .|. shiftL (fromIntegral b1 .&. 0x3F) 6- .|. fromIntegral b0 .&. 0x3F))- else ft (ByteString.pack [b2, b1, b0])-reverseBytesToChar ft fc [b0, b1, b2, b3] =- assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0 && 0x80 <= b2 && b2 < 0xC0) $- if (0xF0 < b3 || 0xF0 == b3 && 0x90 <= b2) && b3 < 0xF5 && (b3 < 0xF4 || b2 < 0x90)- then fc (chr (shiftL (fromIntegral b3 .&. 0x7) 18- .|. shiftL (fromIntegral b2 .&. 0x3F) 12- .|. shiftL (fromIntegral b1 .&. 0x3F) 6- .|. fromIntegral b0 .&. 0x3F))- else ft (ByteString.pack [b3, b2, b1, b0])-reverseBytesToChar ft _fc bytes = ft (ByteString.reverse $ ByteString.pack bytes)--bytesToChar :: (ByteString -> a) -> (Char -> a) -> [Word8] -> a-bytesToChar ft fc [w] = if w < 0x80 then fc (w2c w) else ft (ByteString.singleton w)-bytesToChar ft fc bytes@[b1, b0] =- assert (0x80 <= b0 && b0 < 0xC0) $- if 0xC2 <= b1 && b1 < 0xE0- then fc (chr (shiftL (fromIntegral b1 .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F))- else ft (ByteString.pack bytes)-bytesToChar ft fc bytes@[b2, b1, b0] =- assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0) $- if (0xE0 < b2 || 0xE0 == b2 && 0xA0 <= b1) && b2 < 0xF0- then fc (chr (shiftL (fromIntegral b2 .&. 0xF) 12- .|. shiftL (fromIntegral b1 .&. 0x3F) 6- .|. fromIntegral b0 .&. 0x3F))- else ft (ByteString.pack bytes)-bytesToChar ft fc bytes@[b3, b2, b1, b0] =- assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0 && 0x80 <= b2 && b2 < 0xC0) $- if (0xF0 < b3 || 0xF0 == b3 && 0x90 <= b2) && b3 < 0xF5 && (b3 < 0xF4 || b2 < 0x90)- then fc (chr (shiftL (fromIntegral b3 .&. 0x7) 18- .|. shiftL (fromIntegral b2 .&. 0x3F) 12- .|. shiftL (fromIntegral b1 .&. 0x3F) 6- .|. fromIntegral b0 .&. 0x3F))- else ft (ByteString.pack bytes)-bytesToChar ft _fc bytes = ft (ByteString.pack bytes)--wrapPair :: (ByteString, ByteString) -> (ByteStringUTF8, ByteStringUTF8)-wrapPair (bs1, bs2) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2)-{-# INLINE wrapPair #-}--wrapTriple :: (ByteString, ByteString, ByteString) -> (ByteStringUTF8, ByteStringUTF8, ByteStringUTF8)-wrapTriple (bs1, bs2, bs3) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2, ByteStringUTF8 bs3)-{-# INLINE wrapTriple #-}--fromChar :: Char -> ByteString-fromChar c | c < '\x80' = ByteString.Char8.singleton c- | c < '\x800' = ByteString.pack [0xC0 + fromIntegral (shiftR n 6),- 0x80 + fromIntegral (n .&. 0x3F)]- | c < '\x10000' = ByteString.pack [0xE0 + fromIntegral (shiftR n 12),- 0x80 + fromIntegral (shiftR n 6 .&. 0x3F),- 0x80 + fromIntegral (n .&. 0x3F)]- | n < 0x200000 = ByteString.pack [0xF0 + fromIntegral (shiftR n 18),- 0x80 + fromIntegral (shiftR n 12 .&. 0x3F),- 0x80 + fromIntegral (shiftR n 6 .&. 0x3F),- 0x80 + fromIntegral (n .&. 0x3F)]- | otherwise = error ("Data.Char.ord '" ++ (c : "' >=0x200000"))- where n = ord c--toChar :: Word8 -> ByteString -> Maybe (Char, ByteStringUTF8)-toChar hd tl | hd < 0x80 = Just (w2c hd, ByteStringUTF8 tl)- | hd < 0xC2 = Nothing- | hd < 0xE0 = do (b0, t0) <- ByteString.uncons tl- if headIndex tl == 1- then return (chr (shiftL (fromIntegral hd .&. 0x1F) 6- .|. fromIntegral b0 .&. 0x3F),- ByteStringUTF8 t0)- else Nothing- | hd < 0xF0 = do (b1, t1) <- ByteString.uncons tl- (b0, t0) <- ByteString.uncons t1- if (hd > 0xE0 || b1 >= 0xA0) && headIndex tl == 2- then return (chr (shiftL (fromIntegral hd .&. 0xF) 12- .|. shiftL (fromIntegral b1 .&. 0x3F) 6- .|. fromIntegral b0 .&. 0x3F),- ByteStringUTF8 t0)- else Nothing- | hd < 0xF5 = do (b2, t2) <- ByteString.uncons tl- (b1, t1) <- ByteString.uncons t2- (b0, t0) <- ByteString.uncons t1- if (hd > 0xF0 || b2 >= 0x90) && (hd < 0xF4 || b2 < 0x90) && headIndex tl == 3- then return (chr (shiftL (fromIntegral hd .&. 0x7) 18- .|. shiftL (fromIntegral b2 .&. 0x3F) 12- .|. shiftL (fromIntegral b1 .&. 0x3F) 6- .|. fromIntegral b0 .&. 0x3F),- ByteStringUTF8 t0)- else Nothing- | otherwise = Nothing--groupASCII :: ByteString -> [ByteString]-groupASCII = ByteString.groupBy continued- where continued a b = (a < 0x80) == (b < 0x80) && b < 0xC0-{-# INLINE groupASCII #-}--headIndex :: ByteString -> Int-headIndex bs = fromMaybe (ByteString.length bs) $ ByteString.findIndex byteStartsCharacter bs-{-# INLINE headIndex #-}--byteStartsCharacter :: Word8 -> Bool-byteStartsCharacter b = b < 0x80 || b >= 0xC0-{-# INLINE byteStartsCharacter #-}--charStartIndex :: Int -> ByteString -> Int-charStartIndex n _ | n <= 0 = 0-charStartIndex n0 bs = ByteString.foldr count (const $ ByteString.length bs) bs (n0, False, 0)- where count byte _ (0, high, i) | byte < 0x80 || byte >= 0xC0 || not high = i- count byte cont (n, high, i) | byte < 0x80 = cont (pred n, False, succ i)- | byte < 0xC0 = cont (if high then n else pred n, True, succ i)- | otherwise = cont (pred n, True, succ i)-{-# INLINE charStartIndex #-}
− Data/Monoid/Instances/Concat.hs
@@ -1,293 +0,0 @@-{- - Copyright 2013-2018 Mario Blazevic-- License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines the monoid transformer data type 'Concat'.--- --{-# LANGUAGE Haskell2010 #-}--module Data.Monoid.Instances.Concat (- 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(..))-import Data.Semigroup (Semigroup(..))-import Data.Monoid (Monoid(..), First(..), Sum(..))-import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..),- LeftGCDMonoid(..), RightGCDMonoid(..))-import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)-import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid)-import Data.Monoid.Textual (TextualMonoid(..))-import qualified Data.Monoid.Factorial as Factorial-import qualified Data.Monoid.Textual as Textual-import 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, pi)---- | @'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 '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).----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 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 `mappend` force y--instance (Eq a, Monoid a) => Eq (Concat a) where- x == y = force x == force y--instance (Ord a, Monoid a) => Ord (Concat a) where- compare x y = compare (force x) (force y)--instance Functor Concat where- fmap f (Leaf x) = Leaf (f x)- fmap f (l :<> r) = fmap f l :<> fmap f r--instance Applicative Concat where- pure = Leaf- Leaf f <*> x = f <$> x- (f1 :<> f2) <*> x = (f1 <*> x) :<> (f2 <*> x)--instance Foldable.Foldable Concat where- fold (Leaf x) = x- fold (x :<> y) = Foldable.fold x `mappend` Foldable.fold y- foldMap f (Leaf x) = f x- foldMap f (x :<> y) = Foldable.foldMap f x `mappend` 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 PositiveMonoid a => Semigroup (Concat a) where- x <> y- | null x = y- | null y = x- | otherwise = x :<> y--instance PositiveMonoid a => Monoid (Concat a) where- mempty = Leaf mempty- mappend = (<>)--instance PositiveMonoid a => MonoidNull (Concat a) where- null (Leaf x) = null x- null _ = False--instance PositiveMonoid a => PositiveMonoid (Concat a)--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 (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 (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 (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 = 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 (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 s = Leaf (fromString s)--instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Concat a) where- 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 = 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 (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 (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 = Foldable.foldr splitNext [mempty]- where splitNext a ~(xp:xs) =- let as = Leaf <$> Textual.split p a- in if null xp- then as ++ xs- else init as ++ (last as <> xp):xs- 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)
− Data/Monoid/Instances/Measured.hs
@@ -1,124 +0,0 @@-{- - Copyright 2013-2018 Mario Blazevic-- License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines the monoid transformer data type 'Measured'.--- --{-# LANGUAGE Haskell2010 #-}--module Data.Monoid.Instances.Measured (- Measured, measure, extract- )-where--import Data.Functor -- ((<$>))-import qualified Data.List as List-import Data.String (IsString(..))-import Data.Semigroup -- (Semigroup(..))-import Data.Monoid (Monoid(..))-import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..),- LeftGCDMonoid(..), RightGCDMonoid(..))-import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)-import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid)-import Data.Monoid.Textual (TextualMonoid(..))-import qualified Data.Monoid.Factorial as Factorial-import qualified Data.Monoid.Textual as Textual--import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,- length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)---- | @'Measured' a@ is a wrapper around the 'FactorialMonoid' @a@ that memoizes the monoid's 'length' so it becomes a--- constant-time operation. The parameter is restricted to the 'StableFactorialMonoid' class, which guarantees that--- @'length' (a <> b) == 'length' a + 'length' b@.--data Measured a = Measured{_measuredLength :: Int, extract :: a} deriving (Eq, Show)---- | Create a new 'Measured' value.-measure :: FactorialMonoid a => a -> Measured a-measure x = Measured (length x) x--instance Ord a => Ord (Measured a) where- compare (Measured _ x) (Measured _ y) = compare x y--instance StableFactorialMonoid a => Semigroup (Measured a) where- Measured m a <> Measured n b = Measured (m + n) (mappend a b)--instance StableFactorialMonoid a => Monoid (Measured a) where- mempty = Measured 0 mempty- mappend (Measured m a) (Measured n b) = Measured (m + n) (mappend a b)--instance StableFactorialMonoid a => MonoidNull (Measured a) where- null (Measured n _) = n == 0--instance StableFactorialMonoid a => PositiveMonoid (Measured a)--instance (LeftReductiveMonoid a, StableFactorialMonoid a) => LeftReductiveMonoid (Measured a) where- stripPrefix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripPrefix x y)--instance (RightReductiveMonoid a, StableFactorialMonoid a) => RightReductiveMonoid (Measured a) where- stripSuffix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripSuffix x y)--instance (LeftGCDMonoid a, StableFactorialMonoid a) => LeftGCDMonoid (Measured a) where- commonPrefix (Measured _ x) (Measured _ y) = measure (commonPrefix x y)--instance (RightGCDMonoid a, StableFactorialMonoid a) => RightGCDMonoid (Measured a) where- commonSuffix (Measured _ x) (Measured _ y) = measure (commonSuffix x y)--instance StableFactorialMonoid a => FactorialMonoid (Measured a) where- factors (Measured _ x) = List.map (Measured 1) (factors x)- primePrefix m@(Measured _ x) = if null x then m else Measured 1 (primePrefix x)- primeSuffix m@(Measured _ x) = if null x then m else Measured 1 (primeSuffix x)- splitPrimePrefix (Measured n x) = case splitPrimePrefix x- of Nothing -> Nothing- Just (p, s) -> Just (Measured 1 p, Measured (n - 1) s)- splitPrimeSuffix (Measured n x) = case splitPrimeSuffix x- of Nothing -> Nothing- Just (p, s) -> Just (Measured (n - 1) p, Measured 1 s)- foldl f a0 (Measured _ x) = Factorial.foldl g a0 x- where g a = f a . Measured 1- foldl' f a0 (Measured _ x) = Factorial.foldl' g a0 x- where g a = f a . Measured 1- foldr f a0 (Measured _ x) = Factorial.foldr g a0 x- where g = f . Measured 1- length (Measured n _) = n- foldMap f (Measured _ x) = Factorial.foldMap (f . Measured 1) x- span p (Measured n x) = (xp', xs')- where (xp, xs) = Factorial.span (p . Measured 1) x- xp' = measure xp- xs' = Measured (n - length xp') xs- split p (Measured _ x) = measure <$> Factorial.split (p . Measured 1) x- splitAt m (Measured n x) | m <= 0 = (mempty, Measured n x)- | m >= n = (Measured n x, mempty)- | otherwise = (Measured m xp, Measured (n - m) xs)- where (xp, xs) = splitAt m x- reverse (Measured n x) = Measured n (reverse x)--instance StableFactorialMonoid a => StableFactorialMonoid (Measured a)--instance (FactorialMonoid a, IsString a) => IsString (Measured a) where- fromString = measure . fromString--instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Measured a) where- fromText = measure . fromText- singleton = Measured 1 . singleton- splitCharacterPrefix (Measured n x) = (Measured (n - 1) <$>) <$> splitCharacterPrefix x- characterPrefix (Measured _ x) = characterPrefix x- map f (Measured n x) = Measured n (map f x)- any p (Measured _ x) = any p x- all p (Measured _ x) = all p x-- foldl ft fc a0 (Measured _ x) = Textual.foldl (\a-> ft a . Measured 1) fc a0 x- foldl' ft fc a0 (Measured _ x) = Textual.foldl' (\a-> ft a . Measured 1) fc a0 x- foldr ft fc a0 (Measured _ x) = Textual.foldr (ft . Measured 1) fc a0 x- toString ft (Measured _ x) = toString (ft . Measured 1) x-- span pt pc (Measured n x) = (xp', xs')- where (xp, xs) = Textual.span (pt . Measured 1) pc x- xp' = measure xp- xs' = Measured (n - length xp') xs- break pt pc = Textual.span (not . pt) (not . pc)-- find p (Measured _ x) = find p x
− Data/Monoid/Instances/Positioned.hs
@@ -1,616 +0,0 @@-{-- Copyright 2014-2018 Mario Blazevic-- License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines two monoid transformer data types, 'OffsetPositioned' and 'LinePositioned'. Both data types add--- a notion of the current position to their base monoid. In case of 'OffsetPositioned', the current position is a--- simple integer offset from the beginning of the monoid, and it can be applied to any 'StableFactorialMonoid'. The--- base monoid of 'LinePositioned' must be a 'TextualMonoid', but for the price it will keep track of the current line--- and column numbers as well.------ All positions are zero-based:------ >> let p = pure "abcd\nefgh\nijkl\nmnop\n" :: LinePositioned String--- >> p--- >Line 0, column 0: "abcd\nefgh\nijkl\nmnop\n"--- >> Data.Monoid.Factorial.drop 13 p--- >Line 2, column 3: "l\nmnop\n"--{-# LANGUAGE Haskell2010 #-}--module Data.Monoid.Instances.Positioned (- OffsetPositioned, LinePositioned, extract, position, line, column- )-where--import Control.Applicative -- (Applicative(..))-import qualified Data.List as List-import Data.String (IsString(..))--import Data.Semigroup (Semigroup(..))-import Data.Monoid (Monoid(..), Endo(..))-import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..))-import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)-import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid)-import Data.Monoid.Textual (TextualMonoid(..))-import qualified Data.Monoid.Factorial as Factorial-import qualified Data.Monoid.Textual as Textual--import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, lines, map, concatMap,- length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)--class Positioned p where- extract :: p a -> a- position :: p a -> Int--data OffsetPositioned m = OffsetPositioned{offset :: !Int,- -- ^ the current offset- extractOffset :: m}--data LinePositioned m = LinePositioned{fullOffset :: !Int,- -- | the current line- line :: !Int,- lineStart :: !Int,- extractLines :: m}---- | the current column-column :: LinePositioned m -> Int-column lp = position lp - lineStart lp--instance Functor OffsetPositioned where- fmap f (OffsetPositioned p c) = OffsetPositioned p (f c)--instance Functor LinePositioned where- fmap f (LinePositioned p l lp c) = LinePositioned p l lp (f c)--instance Applicative OffsetPositioned where- pure = OffsetPositioned 0- OffsetPositioned _ f <*> OffsetPositioned p c = OffsetPositioned p (f c)--instance Applicative LinePositioned where- pure = LinePositioned 0 0 0- LinePositioned _ _ _ f <*> LinePositioned p l lp c = LinePositioned p l lp (f c)--instance Positioned OffsetPositioned where- extract = extractOffset- position = offset--instance Positioned LinePositioned where- extract = extractLines- position = fullOffset--instance Eq m => Eq (OffsetPositioned m) where- OffsetPositioned{extractOffset= a} == OffsetPositioned{extractOffset= b} = a == b--instance Eq m => Eq (LinePositioned m) where- LinePositioned{extractLines= a} == LinePositioned{extractLines= b} = a == b--instance Ord m => Ord (OffsetPositioned m) where- compare OffsetPositioned{extractOffset= a} OffsetPositioned{extractOffset= b} = compare a b--instance Ord m => Ord (LinePositioned m) where- compare LinePositioned{extractLines= a} LinePositioned{extractLines= b} = compare a b--instance Show m => Show (OffsetPositioned m) where- showsPrec prec (OffsetPositioned pos c) = shows pos . (": " ++) . showsPrec prec c--instance Show m => Show (LinePositioned m) where- showsPrec prec (LinePositioned pos l lpos c) =- ("Line " ++) . shows l . (", column " ++) . shows (pos - lpos) . (": " ++) . showsPrec prec c--instance StableFactorialMonoid m => Semigroup (OffsetPositioned m) where- OffsetPositioned p1 c1 <> OffsetPositioned p2 c2 =- OffsetPositioned (if p1 /= 0 || p2 == 0 then p1 else max 0 $ p2 - length c1) (mappend c1 c2)- {-# INLINE (<>) #-}--instance (StableFactorialMonoid m, TextualMonoid m) => Semigroup (LinePositioned m) where- LinePositioned p1 l1 lp1 c1 <> LinePositioned p2 l2 lp2 c2- | p1 /= 0 || p2 == 0 = LinePositioned p1 l1 lp1 c- | otherwise = LinePositioned p2' l2' lp2' c- where c = mappend c1 c2- p2' = max 0 $ p2 - length c1- lp2' = min p2' lp2- l2' = if l2 == 0 then 0 else max 0 $ l2 - Textual.foldl_' countLines 0 c1- countLines :: Int -> Char -> Int- countLines n '\n' = succ n- countLines n _ = n- {-# INLINE (<>) #-}--instance StableFactorialMonoid m => Monoid (OffsetPositioned m) where- mempty = pure mempty- mappend = (<>)- {-# INLINE mempty #-}- {-# INLINE mappend #-}--instance (StableFactorialMonoid m, TextualMonoid m) => Monoid (LinePositioned m) where- mempty = pure mempty- mappend = (<>)- {-# INLINE mempty #-}- {-# INLINE mappend #-}--instance (StableFactorialMonoid m, MonoidNull m) => MonoidNull (OffsetPositioned m) where- null = null . extractOffset- {-# INLINE null #-}--instance (StableFactorialMonoid m, TextualMonoid m, MonoidNull m) => MonoidNull (LinePositioned m) where- null = null . extractLines- {-# INLINE null #-}--instance StableFactorialMonoid m => PositiveMonoid (OffsetPositioned 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- stripPrefix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned (p + length c1)) (stripPrefix c1 c2)- {-# INLINE isPrefixOf #-}- {-# INLINE stripPrefix #-}--instance (StableFactorialMonoid m, TextualMonoid m, LeftReductiveMonoid m) =>- LeftReductiveMonoid (LinePositioned m) where- isPrefixOf a b = isPrefixOf (extractLines a) (extractLines b)- stripPrefix LinePositioned{extractLines= c1} (LinePositioned p l lpos c2) =- let (lines, columns) = linesColumns' c1- len = length c1- in fmap (LinePositioned (p + len) (l + lines) (lpos + len - columns)) (stripPrefix c1 c2)- {-# INLINE isPrefixOf #-}- {-# INLINE stripPrefix #-}--instance (StableFactorialMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (OffsetPositioned m) where- commonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = OffsetPositioned (min p1 p2) (commonPrefix c1 c2)- stripCommonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) =- (OffsetPositioned (min p1 p2) prefix, OffsetPositioned (p1 + l) c1', OffsetPositioned (p2 + l) c2')- where (prefix, c1', c2') = stripCommonPrefix c1 c2- l = length prefix- {-# INLINE commonPrefix #-}- {-# INLINE stripCommonPrefix #-}--instance (StableFactorialMonoid m, TextualMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (LinePositioned m) where- commonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) =- if p1 <= p2- then LinePositioned p1 l1 lp1 (commonPrefix c1 c2)- else LinePositioned p2 l2 lp2 (commonPrefix c1 c2)- stripCommonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) =- let (prefix, c1', c2') = stripCommonPrefix c1 c2- (lines, columns) = linesColumns' prefix- len = length prefix- in (if p1 <= p2 then LinePositioned p1 l1 lp1 prefix else LinePositioned p2 l2 lp2 prefix,- LinePositioned (p1 + len) (l1 + lines) (lp1 + len - columns) c1',- LinePositioned (p2 + len) (l2 + lines) (lp2 + len - columns) c2')- {-# INLINE commonPrefix #-}- {-# INLINE stripCommonPrefix #-}--instance (StableFactorialMonoid m, RightReductiveMonoid m) => RightReductiveMonoid (OffsetPositioned m) where- isSuffixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isSuffixOf c1 c2- stripSuffix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned p) (stripSuffix c1 c2)- {-# INLINE isSuffixOf #-}- {-# INLINE stripSuffix #-}--instance (StableFactorialMonoid m, TextualMonoid m, RightReductiveMonoid m) =>- RightReductiveMonoid (LinePositioned m) where- isSuffixOf LinePositioned{extractLines=c1} LinePositioned{extractLines=c2} = isSuffixOf c1 c2- stripSuffix (LinePositioned p l lp c1) LinePositioned{extractLines=c2} =- fmap (LinePositioned p l lp) (stripSuffix c1 c2)- {-# INLINE isSuffixOf #-}- {-# INLINE stripSuffix #-}--instance (StableFactorialMonoid m, RightGCDMonoid m) => RightGCDMonoid (OffsetPositioned m) where- commonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) =- OffsetPositioned (min (p1 + length c1) (p2 + length c2) - length suffix) suffix- where suffix = commonSuffix c1 c2- stripCommonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) =- (OffsetPositioned p1 c1', OffsetPositioned p2 c2',- OffsetPositioned (min (p1 + length c1') (p2 + length c2')) suffix)- where (c1', c2', suffix) = stripCommonSuffix c1 c2- {-# INLINE commonSuffix #-}- {-# INLINE stripCommonSuffix #-}--instance (StableFactorialMonoid m, TextualMonoid m, RightGCDMonoid m) => RightGCDMonoid (LinePositioned m) where- stripCommonSuffix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) =- (LinePositioned p1 l1 lp1 c1', LinePositioned p2 l2 lp2 c2',- if p1 < p2- then LinePositioned (p1 + len1) (l1 + lines1) (lp1 + len1 - columns1) suffix- else LinePositioned (p2 + len2) (l2 + lines2) (lp2 + len2 - columns2) suffix)- where (c1', c2', suffix) = stripCommonSuffix c1 c2- len1 = length c1'- len2 = length c2'- (lines1, columns1) = linesColumns' c1'- (lines2, columns2) = linesColumns' c2'--instance StableFactorialMonoid m => FactorialMonoid (OffsetPositioned m) where- factors (OffsetPositioned p c) = snd $ List.mapAccumL next p (factors c)- where next p1 c1 = (succ p1, OffsetPositioned p1 c1)- primePrefix (OffsetPositioned p c) = OffsetPositioned p (primePrefix c)- splitPrimePrefix (OffsetPositioned p c) = fmap rewrap (splitPrimePrefix c)- where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (succ p) cs)- splitPrimeSuffix (OffsetPositioned p c) = fmap rewrap (splitPrimeSuffix c)- where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (p + length cp) cs)- foldl f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl f' (a0, p0) c0- where f' (a, p) c = (f a (OffsetPositioned p c), succ p)- foldl' f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl' f' (a0, p0) c0- where f' (a, p) c = let a' = f a (OffsetPositioned p c) in seq a' (a', succ p)- foldr f a0 (OffsetPositioned p0 c0) = Factorial.foldr f' (const a0) c0 p0- where f' c cont p = f (OffsetPositioned p c) (cont $! succ p)- length (OffsetPositioned _ c) = length c- foldMap f (OffsetPositioned p c) = appEndo (Factorial.foldMap f' c) (const mempty) p- where -- f' :: m -> Endo (Int -> m)- f' prime = Endo (\cont pos-> f (OffsetPositioned pos prime) `mappend` cont (succ pos))-- spanMaybe s0 f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe (s0, p0) f' t- where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime)- let p' = succ p- Just $! seq p' (s', p')- rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)- spanMaybe' s0 f (OffsetPositioned p0 t) = rewrap $! Factorial.spanMaybe' (s0, p0) f' t- where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime)- let p' = succ p- Just $! s' `seq` p' `seq` (s', p')- rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)- span f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe' p0 f' t- where f' p prime = if f (OffsetPositioned p prime)- then Just $! succ p- else Nothing- rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix)- splitAt n m@(OffsetPositioned p c) | n <= 0 = (mempty, m)- | n >= length c = (m, mempty)- | otherwise = (OffsetPositioned p prefix, OffsetPositioned (p + n) suffix)- where (prefix, suffix) = splitAt n c- drop n (OffsetPositioned p c) = OffsetPositioned (p + n) (Factorial.drop n c)- take n (OffsetPositioned p c) = OffsetPositioned p (Factorial.take n c)- reverse (OffsetPositioned p c) = OffsetPositioned p (Factorial.reverse c)- {-# INLINE primePrefix #-}- {-# INLINE splitPrimePrefix #-}- {-# INLINE splitPrimeSuffix #-}- {-# INLINE foldl #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE foldMap #-}- {-# INLINE length #-}- {-# INLINE span #-}- {-# INLINE splitAt #-}- {-# INLINE take #-}- {-# INLINE drop #-}- {-# INLINE reverse #-}--instance (StableFactorialMonoid m, TextualMonoid m) => FactorialMonoid (LinePositioned m) where- factors (LinePositioned p0 l0 lp0 c) = snd $ List.mapAccumL next (p0, l0, lp0) (factors c)- where next (p, l, lp) c1 | characterPrefix c1 == Just '\n' = ((succ p, succ l, p), LinePositioned p l lp c1)- | otherwise = ((succ p, l, lp), LinePositioned p l lp c1)- primePrefix (LinePositioned p l lp c) = LinePositioned p l lp (primePrefix c)- splitPrimePrefix (LinePositioned p l lp c) = fmap rewrap (splitPrimePrefix c)- where rewrap (cp, cs) = (LinePositioned p l lp cp,- if characterPrefix cp == Just '\n'- then LinePositioned (succ p) (succ l) p cs- else LinePositioned (succ p) l lp cs)- splitPrimeSuffix (LinePositioned p l lp c) = fmap rewrap (splitPrimeSuffix c)- where rewrap (cp, cs) = (LinePositioned p l lp cp, LinePositioned p' (l + lines) (p' - columns) cs)- where len = length cp- (lines, columns) = linesColumns cp- p' = p + len- foldl f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl f' (a0, p0, l0, lp0) c0- where f' (a, p, l, lp) c | characterPrefix c == Just '\n' = (f a (LinePositioned p l lp c), succ p, succ l, p)- | otherwise = (f a (LinePositioned p l lp c), succ p, l, lp)- foldl' f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl' f' (a0, p0, l0, lp0) c0- where f' (a, p, l, lp) c = let a' = f a (LinePositioned p l lp c)- in seq a' (if characterPrefix c == Just '\n'- then (a', succ p, succ l, p)- else (a', succ p, l, lp))- foldr f a0 (LinePositioned p0 l0 lp0 c0) = Factorial.foldr f' (const3 a0) c0 p0 l0 lp0- where f' c cont p l lp- | characterPrefix c == Just '\n' = f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p- | otherwise = f (LinePositioned p l lp c) $ (cont $! succ p) l lp- length = length . extractLines- foldMap f (LinePositioned p0 l0 lp0 c) = appEndo (Factorial.foldMap f' c) (const mempty) p0 l0 lp0- where -- f' :: m -> Endo (Int -> Int -> Int -> m)- f' prime = Endo (\cont p l lp-> f (LinePositioned p l lp prime)- `mappend`- if characterPrefix prime == Just '\n'- then cont (succ p) (succ l) p- else cont (succ p) l lp)-- spanMaybe s0 f (LinePositioned p0 l0 lp0 c) = rewrap $ Factorial.spanMaybe (s0, p0, l0, lp0) f' c- where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime)- let p' = succ p- l' = succ l- Just $! p' `seq` if characterPrefix prime == Just '\n'- then l' `seq` (s', p', l', p)- else (s', p', l, lp)- rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s)- spanMaybe' s0 f (LinePositioned p0 l0 lp0 c) = rewrap $! Factorial.spanMaybe' (s0, p0, l0, lp0) f' c- where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime)- let p' = succ p- l' = succ l- Just $! s' `seq` p' `seq` if characterPrefix prime == Just '\n'- then l' `seq` (s', p', l', p)- else (s', p', l, lp)- rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s)-- span f (LinePositioned p0 l0 lp0 t) = rewrap $ Factorial.spanMaybe' (p0, l0, lp0) f' t- where f' (p, l, lp) prime = if f (LinePositioned p l lp prime)- then let p' = succ p- l' = succ l- in Just $! p' `seq` if characterPrefix prime == Just '\n'- then l' `seq` (p', l', p)- else (p', l, lp)- else Nothing- rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix)- splitAt n m@(LinePositioned p l lp c) | n <= 0 = (mempty, m)- | n >= length c = (m, mempty)- | otherwise = (LinePositioned p l lp prefix,- LinePositioned p' (l + lines) (p' - columns) suffix)- where (prefix, suffix) = splitAt n c- (lines, columns) = linesColumns prefix- p' = p + n- take n (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.take n c)- reverse (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.reverse c)- {-# INLINE primePrefix #-}- {-# INLINE splitPrimePrefix #-}- {-# INLINE splitPrimeSuffix #-}- {-# INLINE foldl #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE foldMap #-}- {-# INLINE length #-}- {-# INLINE span #-}- {-# INLINE splitAt #-}- {-# INLINE take #-}- {-# INLINE reverse #-}--instance StableFactorialMonoid m => StableFactorialMonoid (OffsetPositioned m)--instance (StableFactorialMonoid m, TextualMonoid m) => StableFactorialMonoid (LinePositioned m)--instance IsString m => IsString (OffsetPositioned m) where- fromString = pure . fromString--instance IsString m => IsString (LinePositioned m) where- fromString = pure . fromString--instance (StableFactorialMonoid m, TextualMonoid m) => TextualMonoid (OffsetPositioned m) where- splitCharacterPrefix (OffsetPositioned p c) = fmap (fmap $ OffsetPositioned $ succ p) (splitCharacterPrefix c)-- fromText = pure . fromText- singleton = pure . singleton-- characterPrefix = characterPrefix . extractOffset-- map f (OffsetPositioned p c) = OffsetPositioned p (map f c)- concatMap f (OffsetPositioned p c) = OffsetPositioned p (concatMap (extractOffset . f) c)- all p = all p . extractOffset- any p = any p . extractOffset-- foldl ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl ft' fc' (a0, p0) c0- where ft' (a, p) c = (ft a (OffsetPositioned p c), succ p)- fc' (a, p) c = (fc a c, succ p)- foldl' ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl' ft' fc' (a0, p0) c0- where ft' (a, p) c = ((,) $! ft a (OffsetPositioned p c)) $! succ p- fc' (a, p) c = ((,) $! fc a c) $! succ p- foldr ft fc a0 (OffsetPositioned p0 c0) = snd $ Textual.foldr ft' fc' (p0, a0) c0- where ft' c (p, a) = (succ p, ft (OffsetPositioned p c) a)- fc' c (p, a) = (succ p, fc c a)-- scanl f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl f ch c)- scanl1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl1 f c)- scanr f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr f ch c)- scanr1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr1 f c)- mapAccumL f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumL f a0 c)- mapAccumR f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumR f a0 c)-- spanMaybe s0 ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe (s0, p0) ft' fc' t- where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime)- let p' = succ p- Just $! seq p' (s', p')- fc' (s, p) c = do s' <- fc s c- let p' = succ p- Just $! seq p' (s', p')- rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)- spanMaybe' s0 ft fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe' (s0, p0) ft' fc' t- where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime)- let p' = succ p- Just $! s' `seq` p' `seq` (s', p')- fc' (s, p) c = do s' <- fc s c- let p' = succ p- Just $! s' `seq` p' `seq` (s', p')- rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)- span ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe' p0 ft' fc' t- where ft' p prime = if ft (OffsetPositioned p prime)- then Just $! succ p- else Nothing- fc' p c = if fc c- then Just $! succ p- else Nothing- rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix)-- split f (OffsetPositioned p0 c0) = rewrap p0 (Textual.split f c0)- where rewrap _ [] = []- rewrap p (c:rest) = OffsetPositioned p c : rewrap (p + length c) rest- find p = find p . extractOffset-- foldl_ fc a0 (OffsetPositioned _ c) = Textual.foldl_ fc a0 c- foldl_' fc a0 (OffsetPositioned _ c) = Textual.foldl_' fc a0 c- foldr_ fc a0 (OffsetPositioned _ c) = Textual.foldr_ fc a0 c-- spanMaybe_ s0 fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe_' (s0, p0) fc' t- where fc' (s, p) c = do s' <- fc s c- let p' = succ p- Just $! seq p' (s', p')- rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)- spanMaybe_' s0 fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe_' (s0, p0) fc' t- where fc' (s, p) c = do s' <- fc s c- let p' = succ p- Just $! s' `seq` p' `seq` (s', p')- rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)- span_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.span_ bt fc t- where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix)- break_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.break_ bt fc t- where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix)- dropWhile_ bt fc t = snd (span_ bt fc t)- takeWhile_ bt fc (OffsetPositioned p t) = OffsetPositioned p (takeWhile_ bt fc t)-- {-# INLINE characterPrefix #-}- {-# INLINE splitCharacterPrefix #-}- {-# INLINE map #-}- {-# INLINE concatMap #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE spanMaybe' #-}- {-# INLINE span #-}- {-# INLINE foldl_' #-}- {-# INLINE foldr_ #-}- {-# INLINE any #-}- {-# INLINE all #-}- {-# INLINE spanMaybe_' #-}- {-# INLINE span_ #-}- {-# INLINE break_ #-}- {-# INLINE dropWhile_ #-}- {-# INLINE takeWhile_ #-}- {-# INLINE split #-}- {-# INLINE find #-}--instance (StableFactorialMonoid m, TextualMonoid m) => TextualMonoid (LinePositioned m) where- splitCharacterPrefix (LinePositioned p l lp c) =- case splitCharacterPrefix c- of Nothing -> Nothing- Just ('\n', rest) -> Just ('\n', LinePositioned (succ p) (succ l) p rest)- Just (ch, rest) -> Just (ch, LinePositioned (succ p) l lp rest)-- fromText = pure . fromText- singleton = pure . singleton-- characterPrefix = characterPrefix . extractLines-- map f (LinePositioned p l lp c) = LinePositioned p l lp (map f c)- concatMap f (LinePositioned p l lp c) = LinePositioned p l lp (concatMap (extractLines . f) c)- all p = all p . extractLines- any p = any p . extractLines-- foldl ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl ft' fc' (a0, p0, l0, lp0) c0- where ft' (a, p, l, lp) c = (ft a (LinePositioned p l lp c), succ p, l, lp)- fc' (a, p, l, _lp) '\n' = (fc a '\n', succ p, succ l, p)- fc' (a, p, l, lp) c = (fc a c, succ p, l, lp)- foldl' ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl' ft' fc' (a0, p0, l0, lp0) c0- where ft' (a, p, l, lp) c = let a' = ft a (LinePositioned p l lp c)- p' = succ p- in a' `seq` p' `seq` (a', p', l, lp)- fc' (a, p, l, lp) c = let a' = fc a c- p' = succ p- l' = succ l- in a' `seq` p' `seq` if c == '\n'- then l' `seq` (a', p', l', p)- else (a', p', l, lp)- foldr ft fc a0 (LinePositioned p0 l0 lp0 c0) = Textual.foldr ft' fc' (const3 a0) c0 p0 l0 lp0- where ft' c cont p l lp = ft (LinePositioned p l lp c) $ (cont $! succ p) l lp- fc' c cont p l lp- | c == '\n' = fc c $ ((cont $! succ p) $! succ l) p- | otherwise = fc c $ (cont $! succ p) l lp-- spanMaybe s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe (s0, p0, l0, lp0) ft' fc' t- where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime)- let p' = succ p- Just $! seq p' (s', p', l, lp)- fc' (s, p, l, lp) c = fc s c- >>= \s'-> Just $! seq p' (if c == '\n' then seq l' (s', p', l', p) else (s', p', l, lp))- where p' = succ p- l' = succ l- rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s)- spanMaybe' s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $! Textual.spanMaybe' (s0, p0, l0, lp0) ft' fc' t- where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime)- let p' = succ p- Just $! s' `seq` p' `seq` (s', p', l, lp)- fc' (s, p, l, lp) c = do s' <- fc s c- let p' = succ p- l' = succ l- Just $! s' `seq` p' `seq` (if c == '\n' then seq l' (s', p', l', p) else (s', p', l, lp))- rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s)- span ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe' (p0, l0, lp0) ft' fc' t- where ft' (p, l, lp) prime = if ft (LinePositioned p l lp prime)- then let p' = succ p- in p' `seq` Just (p', l, lp)- else Nothing- fc' (p, l, lp) c | fc c = Just $! seq p' (if c == '\n' then seq l' (p', l', p) else (p', l, lp))- | otherwise = Nothing- where p' = succ p- l' = succ l- rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix)-- scanl f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl f ch c)- scanl1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl1 f c)- scanr f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr f ch c)- scanr1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr1 f c)- mapAccumL f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumL f a0 c)- mapAccumR f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumR f a0 c)-- split f (LinePositioned p0 l0 lp0 c0) = rewrap p0 l0 lp0 (Textual.split f c0)- where rewrap _ _ _ [] = []- rewrap p l lp (c:rest) = LinePositioned p l lp c- : rewrap p' (l + lines) (if lines == 0 then lp else p' - columns) rest- where p' = p + length c- (lines, columns) = linesColumns c- find p = find p . extractLines-- foldl_ fc a0 (LinePositioned _ _ _ t) = Textual.foldl_ fc a0 t- foldl_' fc a0 (LinePositioned _ _ _ t) = Textual.foldl_' fc a0 t- foldr_ fc a0 (LinePositioned _ _ _ t) = Textual.foldr_ fc a0 t-- spanMaybe_ s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_ s0 fc t- where rewrap (prefix, suffix, s) = (LinePositioned p0 l0 lp0 prefix,- LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix,- s)- where (l, col) = linesColumns prefix- p1 = p0 + length prefix- spanMaybe_' s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_' s0 fc t- where rewrap (prefix, suffix, s) = p1 `seq` l1 `seq` lp1 `seq`- (LinePositioned p0 l0 lp0 prefix, LinePositioned p1 l1 lp1 suffix, s)- where (l, col) = linesColumns' prefix- p1 = p0 + length prefix- l1 = l0 + l- lp1 = if l == 0 then lp0 else p1 - col- span_ bt fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.span_ bt fc t- where rewrap (prefix, suffix) = (LinePositioned p0 l0 lp0 prefix,- LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix)- where (l, col) = linesColumns' prefix- p1 = p0 + length prefix- break_ bt fc t = span_ (not bt) (not . fc) t- dropWhile_ bt fc t = snd (span_ bt fc t)- takeWhile_ bt fc (LinePositioned p l lp t) = LinePositioned p l lp (takeWhile_ bt fc t)-- {-# INLINE characterPrefix #-}- {-# INLINE splitCharacterPrefix #-}- {-# INLINE map #-}- {-# INLINE concatMap #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE spanMaybe' #-}- {-# INLINE span #-}- {-# INLINE split #-}- {-# INLINE find #-}- {-# INLINE foldl_' #-}- {-# INLINE foldr_ #-}- {-# INLINE any #-}- {-# INLINE all #-}- {-# INLINE spanMaybe_' #-}- {-# INLINE span_ #-}- {-# INLINE break_ #-}- {-# INLINE dropWhile_ #-}- {-# INLINE takeWhile_ #-}--linesColumns :: TextualMonoid m => m -> (Int, Int)-linesColumns t = Textual.foldl (const . fmap succ) fc (0, 0) t- where fc (l, _) '\n' = (succ l, 0)- fc (l, c) _ = (l, succ c)-linesColumns' :: TextualMonoid m => m -> (Int, Int)-linesColumns' t = Textual.foldl' (const . fmap succ) fc (0, 0) t- where fc (l, _) '\n' = let l' = succ l in seq l' (l', 0)- fc (l, c) _ = let c' = succ c in seq c' (l, c')-{-# INLINE linesColumns #-}-{-# INLINE linesColumns' #-}--const3 :: a -> b -> c -> d -> a-const3 a _p _l _lp = a-{-# INLINE const3 #-}--fstOf4 :: (a, b, c, d) -> a-fstOf4 (a, _, _, _) = a-{-# INLINE fstOf4 #-}
− Data/Monoid/Instances/Stateful.hs
@@ -1,236 +0,0 @@-{-- Copyright 2013-2018 Mario Blazevic-- License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines the monoid transformer data type 'Stateful'.------ >> let s = setState [4] $ pure "data" :: Stateful [Int] String--- >> s--- >Stateful ("data",[4])--- >> factors s--- >[Stateful ("d",[]),Stateful ("a",[]),Stateful ("t",[]),Stateful ("a",[]),Stateful ("",[4])]--{-# LANGUAGE Haskell2010 #-}--module Data.Monoid.Instances.Stateful (- Stateful(Stateful), extract, state, setState- )-where--import Control.Applicative -- (Applicative(..))-import Data.Functor -- ((<$>))-import qualified Data.List as List-import Data.String (IsString(..))-import Data.Semigroup -- (Semigroup(..))-import Data.Monoid (Monoid(..))-import Data.Monoid.Cancellative (LeftReductiveMonoid(..), LeftGCDMonoid(..), RightReductiveMonoid(..), RightGCDMonoid(..))-import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)-import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid)-import Data.Monoid.Textual (TextualMonoid(..))-import qualified Data.Monoid.Factorial as Factorial-import qualified Data.Monoid.Textual as Textual--import Prelude hiding (all, any, break, elem, drop, filter, foldl, foldl1, foldr, foldr1, gcd, map, concatMap,- length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, take)---- | @'Stateful' a b@ is a wrapper around the 'Monoid' @b@ that carries the state @a@ along. The state type @a@ must be--- a monoid as well if 'Stateful' is to be of any use. In the 'FactorialMonoid' and 'TextualMonoid' class instances, the--- monoid @b@ has the priority and the state @a@ is left for the end.-newtype Stateful a b = Stateful (b, a) deriving (Eq, Ord, Show)--extract :: Stateful a b -> b-extract (Stateful (t, _)) = t--state :: Stateful a b -> a-state (Stateful (_, x)) = x--setState :: a -> Stateful a b -> Stateful a b-setState s (Stateful (t, _)) = Stateful (t, s)--instance Functor (Stateful a) where- fmap f (Stateful (x, s)) = Stateful (f x, s)--instance Monoid a => Applicative (Stateful a) where- pure m = Stateful (m, mempty)- Stateful (f, s1) <*> Stateful (x, s2) = Stateful (f x, mappend s1 s2)--instance (Semigroup a, Semigroup b) => Semigroup (Stateful a b) where- Stateful x <> Stateful y = Stateful (x <> y)- {-# INLINE (<>) #-}--instance (Monoid a, Monoid b) => Monoid (Stateful a b) where- mempty = Stateful mempty- Stateful x `mappend` Stateful y = Stateful (mappend x y)- {-# INLINE mempty #-}- {-# INLINE mappend #-}--instance (MonoidNull a, MonoidNull b) => MonoidNull (Stateful a b) where- null (Stateful x) = null x- {-# INLINE null #-}--instance (PositiveMonoid a, PositiveMonoid b) => PositiveMonoid (Stateful a b)--instance (LeftReductiveMonoid a, LeftReductiveMonoid b) => LeftReductiveMonoid (Stateful a b) where- isPrefixOf (Stateful x) (Stateful x') = isPrefixOf x x'- stripPrefix (Stateful x) (Stateful x') = Stateful <$> stripPrefix x x'- {-# INLINE isPrefixOf #-}- {-# INLINE stripPrefix #-}--instance (RightReductiveMonoid a, RightReductiveMonoid b) => RightReductiveMonoid (Stateful a b) where- isSuffixOf (Stateful x) (Stateful x') = isSuffixOf x x'- stripSuffix (Stateful x) (Stateful x') = Stateful <$> stripSuffix x x'- {-# INLINE stripSuffix #-}- {-# INLINE isSuffixOf #-}--instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (Stateful a b) where- commonPrefix (Stateful x) (Stateful x') = Stateful (commonPrefix x x')- stripCommonPrefix (Stateful x) (Stateful x') = (Stateful prefix, Stateful suffix1, Stateful suffix2)- where (prefix, suffix1, suffix2) = stripCommonPrefix x x'- {-# INLINE commonPrefix #-}- {-# INLINE stripCommonPrefix #-}--instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (Stateful a b) where- commonSuffix (Stateful x) (Stateful x') = Stateful (commonSuffix x x')- {-# INLINE commonSuffix #-}--instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (Stateful a b) where- factors (Stateful x) = List.map Stateful (factors x)- length (Stateful x) = length x- reverse (Stateful x) = Stateful (reverse x)- primePrefix (Stateful x) = Stateful (primePrefix x)- primeSuffix (Stateful x) = Stateful (primeSuffix x)- splitPrimePrefix (Stateful x) = do (xp, xs) <- splitPrimePrefix x- return (Stateful xp, Stateful xs)- splitPrimeSuffix (Stateful x) = do (xp, xs) <- splitPrimeSuffix x- return (Stateful xp, Stateful xs)- foldl f a0 (Stateful x) = Factorial.foldl f' a0 x- where f' a x1 = f a (Stateful x1)- foldl' f a0 (Stateful x) = Factorial.foldl' f' a0 x- where f' a x1 = f a (Stateful x1)- foldr f a (Stateful x) = Factorial.foldr (f . Stateful) a x- foldMap f (Stateful x) = Factorial.foldMap (f . Stateful) x- span p (Stateful x) = (Stateful xp, Stateful xs)- where (xp, xs) = Factorial.span (p . Stateful) x- spanMaybe s0 f (Stateful x) = (Stateful xp, Stateful xs, s')- where (xp, xs, s') = Factorial.spanMaybe s0 f' x- f' s x1 = f s (Stateful x1)- spanMaybe' s0 f (Stateful x) = (Stateful xp, Stateful xs, s')- where (xp, xs, s') = Factorial.spanMaybe' s0 f' x- f' s x1 = f s (Stateful x1)- split p (Stateful x) = List.map Stateful (Factorial.split (p . Stateful) x)- splitAt n (Stateful x) = (Stateful xp, Stateful xs)- where (xp, xs) = splitAt n x- take n (Stateful x) = Stateful (take n x)- drop n (Stateful x) = Stateful (drop n x)- {-# INLINE primePrefix #-}- {-# INLINE primeSuffix #-}- {-# INLINE splitPrimePrefix #-}- {-# INLINE splitPrimeSuffix #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE foldMap #-}- {-# INLINE length #-}- {-# INLINE span #-}- {-# INLINE spanMaybe #-}- {-# INLINE spanMaybe' #-}- {-# INLINE splitAt #-}- {-# INLINE take #-}- {-# INLINE drop #-}--instance (StableFactorialMonoid a, StableFactorialMonoid b) => StableFactorialMonoid (Stateful a b)--instance (Monoid a, IsString b) => IsString (Stateful a b) where- fromString = pure . fromString--instance (LeftGCDMonoid a, FactorialMonoid a, TextualMonoid b) => TextualMonoid (Stateful a b) where- fromText t = Stateful (fromText t, mempty)- singleton c = Stateful (singleton c, mempty)-- characterPrefix = characterPrefix . extract- splitCharacterPrefix (Stateful (t, x)) = do (c, t') <- splitCharacterPrefix t- return (c, Stateful (t', x))-- map f (Stateful (t, x)) = Stateful (Textual.map f t, x)- all p = all p . extract- any p = any p . extract-- foldl fx fc a0 (Stateful (t, x)) = Factorial.foldl f2 (Textual.foldl f1 fc a0 t) x- where f1 a = fx a . fromFst- f2 a = fx a . fromSnd- foldr fx fc a (Stateful (t, x)) = Textual.foldr (fx . fromFst) fc (Factorial.foldr (fx . fromSnd) a x) t- foldl' fx fc a0 (Stateful (t, x)) = a' `seq` Factorial.foldl' f2 a' x- where a' = Textual.foldl' f1 fc a0 t- f1 a = fx a . fromFst- f2 a = fx a . fromSnd- foldl_' fc a (Stateful (t, _)) = foldl_' fc a t- foldr_ fc a (Stateful (t, _)) = Textual.foldr_ fc a t- toString fx (Stateful (t, x)) = toString (fx . fromFst) t ++ Factorial.foldMap (fx . fromSnd) x-- scanl f c (Stateful (t, x)) = Stateful (Textual.scanl f c t, x)- scanl1 f (Stateful (t, x)) = Stateful (Textual.scanl1 f t, x)- scanr f c (Stateful (t, x)) = Stateful (Textual.scanr f c t, x)- scanr1 f (Stateful (t, x)) = Stateful (Textual.scanr1 f t, x)- mapAccumL f a (Stateful (t, x)) = (a', Stateful (t', x))- where (a', t') = Textual.mapAccumL f a t- mapAccumR f a (Stateful (t, x)) = (a', Stateful (t', x))- where (a', t') = Textual.mapAccumR f a t-- span pt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs))- where (tp, ts) = Textual.span (pt . fromFst) pc t- (xp, xs) | null ts = Factorial.span (pt . fromSnd) x- | otherwise = (mempty, x)- span_ bt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs))- where (tp, ts) = Textual.span_ bt pc t- (xp, xs) | null ts && bt = (x, mempty)- | otherwise = (mempty, x)- break pt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs))- where (tp, ts) = Textual.break (pt . fromFst) pc t- (xp, xs) | null ts = Factorial.break (pt . fromSnd) x- | otherwise = (mempty, x)- spanMaybe s0 ft fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s'')- where (tp, ts, s') = Textual.spanMaybe s0 ft' fc t- (xp, xs, s'') | null ts = Factorial.spanMaybe s' ft'' x- | otherwise = (mempty, x, s')- ft' s t1 = ft s (Stateful (t1, mempty))- ft'' s x1 = ft s (Stateful (mempty, x1))- spanMaybe' s0 ft fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s'')- where (tp, ts, s') = Textual.spanMaybe' s0 ft' fc t- (xp, xs, s'') | null ts = Factorial.spanMaybe' s' ft'' x- | otherwise = (mempty, x, s')- ft' s t1 = ft s (Stateful (t1, mempty))- ft'' s x1 = ft s (Stateful (mempty, x1))- spanMaybe_' s0 fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s')- where (tp, ts, s') = Textual.spanMaybe_' s0 fc t- (xp, xs) | null ts = (x, mempty)- | otherwise = (mempty, x)- split p (Stateful (t, x)) = restore id ts- where ts = Textual.split p t- restore f [t1] = f [Stateful (t1, x)]- restore f ~(hd:tl) = restore (f . (Stateful (hd, mempty):)) tl- find p = find p . extract- elem c = elem c . extract-- {-# INLINE characterPrefix #-}- {-# INLINE splitCharacterPrefix #-}- {-# INLINE map #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE spanMaybe' #-}- {-# INLINE span #-}- {-# INLINE spanMaybe_' #-}- {-# INLINE span_ #-}- {-# INLINE any #-}- {-# INLINE all #-}- {-# INLINE split #-}- {-# INLINE find #-}- {-# INLINE elem #-}--{-# INLINE fromFst #-}-fromFst :: Monoid b => a -> Stateful b a-fromFst a = Stateful (a, mempty)--{-# INLINE fromSnd #-}-fromSnd :: Monoid a => b -> Stateful b a-fromSnd b = Stateful (mempty, b)
− Data/Monoid/Null.hs
@@ -1,148 +0,0 @@-{- - Copyright 2013-2015 Mario Blazevic-- License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines the MonoidNull class and some of its instances.--- --{-# LANGUAGE Haskell2010, Trustworthy #-}--module Data.Monoid.Null (- MonoidNull(..), PositiveMonoid- )-where- -import Data.Monoid -- (Monoid, First(..), Last(..), Dual(..), Sum(..), Product(..), All(getAll), Any(getAny))-import qualified Data.List as List-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Lazy as LazyByteString-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LazyText-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import qualified Data.Map as Map-import qualified Data.Sequence as Sequence-import qualified Data.Set as Set-import qualified Data.Vector as Vector--import Prelude hiding (null)---- | Extension of 'Monoid' that allows testing a value for equality with 'mempty'. The following law must hold:--- --- prop> null x == (x == mempty)--- --- Furthermore, the performance of this method should be constant, /i.e./, independent of the length of its argument.-class Monoid m => MonoidNull m where- null :: m -> Bool---- | Subclass of 'Monoid' for types whose values have no inverse, with the exception of 'Data.Monoid.mempty'. More--- formally, the class instances must satisfy the following law:--- --- prop> null (x <> y) == (null x && null y)-class MonoidNull m => PositiveMonoid m--instance MonoidNull () where- null () = True--instance MonoidNull Ordering where- null = (== EQ)--instance MonoidNull All where- null = getAll--instance MonoidNull Any where- null = not . getAny--instance MonoidNull (First a) where- null (First Nothing) = True- null _ = False--instance MonoidNull (Last a) where- null (Last Nothing) = True- null _ = False--instance MonoidNull a => MonoidNull (Dual a) where- null (Dual a) = null a--instance (Num a, Eq a) => MonoidNull (Sum a) where- null (Sum a) = a == 0--instance (Num a, Eq a) => MonoidNull (Product a) where- null (Product a) = a == 1--instance Monoid a => MonoidNull (Maybe a) where- null Nothing = True- null _ = False--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--instance MonoidNull ByteString.ByteString where- null = ByteString.null- {-# INLINE null #-}--instance MonoidNull LazyByteString.ByteString where- null = LazyByteString.null- {-# INLINE null #-}--instance MonoidNull Text.Text where- null = Text.null- {-# INLINE null #-}--instance MonoidNull LazyText.Text where- null = LazyText.null- {-# INLINE null #-}--instance Ord k => MonoidNull (Map.Map k v) where- null = Map.null--instance MonoidNull (IntMap.IntMap v) where- null = IntMap.null--instance MonoidNull IntSet.IntSet where- null = IntSet.null--instance MonoidNull (Sequence.Seq a) where- null = Sequence.null--instance Ord a => MonoidNull (Set.Set a) where- null = Set.null--instance MonoidNull (Vector.Vector a) where- null = Vector.null--instance PositiveMonoid ()-instance PositiveMonoid Ordering-instance PositiveMonoid All-instance PositiveMonoid Any-instance PositiveMonoid ByteString.ByteString-instance PositiveMonoid LazyByteString.ByteString-instance PositiveMonoid Text.Text-instance PositiveMonoid LazyText.Text-instance Monoid a => PositiveMonoid (Maybe a)-instance PositiveMonoid (First a)-instance PositiveMonoid (Last a)-instance PositiveMonoid a => PositiveMonoid (Dual a)-instance PositiveMonoid [x]-instance Ord k => PositiveMonoid (Map.Map k v)-instance PositiveMonoid (IntMap.IntMap v)-instance PositiveMonoid IntSet.IntSet-instance PositiveMonoid (Sequence.Seq a)-instance Ord a => PositiveMonoid (Set.Set a)-instance PositiveMonoid (Vector.Vector a)---- 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)
− Data/Monoid/Textual.hs
@@ -1,615 +0,0 @@-{- - Copyright 2013-2016 Mario Blazevic-- License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines the 'TextualMonoid' class and several of its instances.--- --{-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-}--module Data.Monoid.Textual (- TextualMonoid(..)- )-where--import qualified Data.Foldable as Foldable-import qualified Data.Traversable as Traversable-import Data.Functor -- ((<$>))-import qualified Data.List as List-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LazyText-import Data.Text (Text)-import Data.Monoid -- (Monoid(mappend, mempty))-import qualified Data.Sequence as Sequence-import qualified Data.Vector as Vector-import Data.String (IsString(fromString))-import Data.Int (Int64)--import Data.Monoid.Cancellative (LeftReductiveMonoid, LeftGCDMonoid)-import Data.Monoid.Factorial (FactorialMonoid)-import qualified Data.Monoid.Factorial as Factorial--import Prelude hiding (all, any, break, concatMap, dropWhile, foldl, foldl1, foldr, foldr1, map, scanl, scanl1, scanr, scanr1,- span, takeWhile)---- | The 'TextualMonoid' class is an extension of 'FactorialMonoid' specialized for monoids that can contain--- characters. Its methods are generally equivalent to their namesake functions from "Data.List" and "Data.Text", and--- they satisfy the following laws:--- --- > unfoldr splitCharacterPrefix . fromString == id--- > splitCharacterPrefix . primePrefix == fmap (\(c, t)-> (c, mempty)) . splitCharacterPrefix--- >--- > map f . fromString == fromString . List.map f--- > concatMap (fromString . f) . fromString == fromString . List.concatMap f--- >--- > foldl ft fc a . fromString == List.foldl fc a--- > foldr ft fc a . fromString == List.foldr fc a--- > foldl' ft fc a . fromString == List.foldl' fc a--- >--- > scanl f c . fromString == fromString . List.scanl f c--- > scanr f c . fromString == fromString . List.scanr f c--- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a--- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a--- >--- > takeWhile pt pc . fromString == fromString . takeWhile pc--- > dropWhile pt pc . fromString == fromString . dropWhile pc--- >--- > mconcat . intersperse (singleton c) . split (== c) == id--- > find p . fromString == List.find p--- > elem c . fromString == List.elem c------ A 'TextualMonoid' may contain non-character data insterspersed between its characters. Every class method that--- returns a modified 'TextualMonoid' instance generally preserves this non-character data. Methods like 'foldr' can--- access both the non-character and character data and expect two arguments for the two purposes. For each of these--- methods there is also a simplified version with underscore in name (like 'foldr_') that ignores the non-character--- data.------ All of the following expressions are identities:------ > map id--- > concatMap singleton--- > foldl (<>) (\a c-> a <> singleton c) mempty--- > foldr (<>) ((<>) . singleton) mempty--- > foldl' (<>) (\a c-> a <> singleton c) mempty--- > scanl1 (const id)--- > scanr1 const--- > uncurry (mapAccumL (,))--- > uncurry (mapAccumR (,))--- > takeWhile (const True) (const True)--- > dropWhile (const False) (const False)--- > toString undefined . fromString--class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where- -- | Contructs a new data type instance Like 'fromString', but from a 'Text' input instead of 'String'.- --- -- > fromText == fromString . Text.unpack- fromText :: Text -> t- -- | Creates a prime monoid containing a single character.- --- -- > singleton c == fromString [c]- singleton :: Char -> t- -- | Specialized version of 'Factorial.splitPrimePrefix'. Every prime factor of a 'Textual' monoid must consist of a- -- single character or no character at all.- splitCharacterPrefix :: t -> Maybe (Char, t)- -- | Extracts a single character that prefixes the monoid, if the monoid begins with a character. Otherwise returns- -- 'Nothing'.- --- -- > characterPrefix == fmap fst . splitCharacterPrefix- characterPrefix :: t -> Maybe Char- -- | Equivalent to 'List.map' from "Data.List" with a @Char -> Char@ function. Preserves all non-character data.- --- -- > map f == concatMap (singleton . f)- map :: (Char -> Char) -> t -> t- -- | Equivalent to 'List.concatMap' from "Data.List" with a @Char -> String@ function. Preserves all non-character- -- data.- concatMap :: (Char -> t) -> t -> t- -- | Returns the list of characters the monoid contains, after having the argument function convert all its- -- non-character factors into characters.- toString :: (t -> String) -> t -> String- -- | Equivalent to 'List.any' from "Data.List". Ignores all non-character data.- any :: (Char -> Bool) -> t -> Bool- -- | Equivalent to 'List.all' from "Data.List". Ignores all non-character data.- all :: (Char -> Bool) -> t -> Bool-- -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent- -- to 'List.foldl' from "Data.List".- foldl :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a- -- | Strict version of 'foldl'.- foldl' :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a- -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent- -- to 'List.foldl\'' from "Data.List".- foldr :: (t -> a -> a) -> (Char -> a -> a) -> a -> t -> a-- -- | Equivalent to 'List.scanl' from "Data.List" when applied to a 'String', but preserves all non-character data.- scanl :: (Char -> Char -> Char) -> Char -> t -> t- -- | Equivalent to 'List.scanl1' from "Data.List" when applied to a 'String', but preserves all non-character data.- --- -- > scanl f c == scanl1 f . (singleton c <>)- scanl1 :: (Char -> Char -> Char) -> t -> t- -- | Equivalent to 'List.scanr' from "Data.List" when applied to a 'String', but preserves all non-character data.- scanr :: (Char -> Char -> Char) -> Char -> t -> t- -- | Equivalent to 'List.scanr1' from "Data.List" when applied to a 'String', but preserves all non-character data.- --- -- > scanr f c == scanr1 f . (<> singleton c)- scanr1 :: (Char -> Char -> Char) -> t -> t- -- | Equivalent to 'List.mapAccumL' from "Data.List" when applied to a 'String', but preserves all non-character- -- data.- mapAccumL :: (a -> Char -> (a, Char)) -> a -> t -> (a, t)- -- | Equivalent to 'List.mapAccumR' from "Data.List" when applied to a 'String', but preserves all non-character- -- data.- mapAccumR :: (a -> Char -> (a, Char)) -> a -> t -> (a, t)-- -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to- -- 'List.takeWhile' from "Data.List" when applied to a 'String'.- takeWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t- -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to- -- 'List.dropWhile' from "Data.List" when applied to a 'String'.- dropWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t- -- | 'break pt pc' is equivalent to |span (not . pt) (not . pc)|.- break :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t)- -- | 'span pt pc t' is equivalent to |(takeWhile pt pc t, dropWhile pt pc t)|.- span :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t)- -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'.- spanMaybe :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s)- -- | Strict version of 'spanMaybe'.- spanMaybe' :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s)- -- | Splits the monoid into components delimited by character separators satisfying the given predicate. The- -- characters satisfying the predicate are not a part of the result.- --- -- > split p == Factorial.split (maybe False p . characterPrefix)- split :: (Char -> Bool) -> t -> [t]- -- | Like 'List.find' from "Data.List" when applied to a 'String'. Ignores non-character data.- find :: (Char -> Bool) -> t -> Maybe Char- -- | Like 'List.elem' from "Data.List" when applied to a 'String'. Ignores non-character data.- elem :: Char -> t -> Bool-- -- | > foldl_ = foldl const- foldl_ :: (a -> Char -> a) -> a -> t -> a- foldl_' :: (a -> Char -> a) -> a -> t -> a- foldr_ :: (Char -> a -> a) -> a -> t -> a- -- | > takeWhile_ = takeWhile . const- takeWhile_ :: Bool -> (Char -> Bool) -> t -> t- -- | > dropWhile_ = dropWhile . const- dropWhile_ :: Bool -> (Char -> Bool) -> t -> t- -- | > break_ = break . const- break_ :: Bool -> (Char -> Bool) -> t -> (t, t)- -- | > span_ = span . const- span_ :: Bool -> (Char -> Bool) -> t -> (t, t)- -- | > spanMaybe_ s = spanMaybe s (const . Just)- spanMaybe_ :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s)- spanMaybe_' :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s)--- fromText = fromString . Text.unpack- singleton = fromString . (:[])-- characterPrefix = fmap fst . splitCharacterPrefix-- map f = concatMap (singleton . f)- concatMap f = foldr mappend (mappend . f) mempty- toString f = foldr (mappend . f) (:) []- all p = foldr (const id) ((&&) . p) True- any p = foldr (const id) ((||) . p) False-- foldl ft fc = Factorial.foldl (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime))- foldr ft fc = Factorial.foldr (\prime-> maybe (ft prime) fc (characterPrefix prime))- foldl' ft fc = Factorial.foldl' (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime))- foldl_ = foldl const- foldr_ = foldr (const id)- foldl_' = foldl' const-- scanl f c = mappend (singleton c) . fst . foldl foldlOther (foldlChars f) (mempty, c)- scanl1 f t = case (Factorial.splitPrimePrefix t, splitCharacterPrefix t)- of (Nothing, _) -> t- (Just (prefix, suffix), Nothing) -> mappend prefix (scanl1 f suffix)- (Just _, Just (c, suffix)) -> scanl f c suffix- scanr f c = fst . foldr foldrOther (foldrChars f) (singleton c, c)- scanr1 f = fst . foldr foldrOther fc (mempty, Nothing)- where fc c (t, Nothing) = (mappend (singleton c) t, Just c)- fc c1 (t, Just c2) = (mappend (singleton c') t, Just c')- where c' = f c1 c2- mapAccumL f a0 = foldl ft fc (a0, mempty)- where ft (a, t1) t2 = (a, mappend t1 t2)- fc (a, t) c = (a', mappend t (singleton c'))- where (a', c') = f a c- mapAccumR f a0 = foldr ft fc (a0, mempty)- where ft t1 (a, t2) = (a, mappend t1 t2)- fc c (a, t) = (a', mappend (singleton c') t)- where (a', c') = f a c-- takeWhile pt pc = fst . span pt pc- dropWhile pt pc = snd . span pt pc- span pt pc = Factorial.span (\prime-> maybe (pt prime) pc (characterPrefix prime))- break pt pc = Factorial.break (\prime-> maybe (pt prime) pc (characterPrefix prime))- spanMaybe s0 ft fc t0 = spanAfter id s0 t0- where spanAfter g s t = case Factorial.splitPrimePrefix t- of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) ->- spanAfter (g . mappend prime) s' rest- | otherwise -> (g mempty, t, s)- Nothing -> (t0, t, s)- spanMaybe' s0 ft fc t0 = spanAfter id s0 t0- where spanAfter g s t = seq s $- case Factorial.splitPrimePrefix t- of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) ->- spanAfter (g . mappend prime) s' rest- | otherwise -> (g mempty, t, s)- Nothing -> (t0, t, s)- takeWhile_ = takeWhile . const- dropWhile_ = dropWhile . const- break_ = break . const- span_ = span . const- spanMaybe_ s = spanMaybe s (const . Just)- spanMaybe_' s = spanMaybe' s (const . Just)-- split p m = prefix : splitRest- where (prefix, rest) = break (const False) p m- splitRest = case splitCharacterPrefix rest- of Nothing -> []- Just (_, tl) -> split p tl- find p = foldr (const id) (\c r-> if p c then Just c else r) Nothing- elem c = any (== c)-- {-# INLINE characterPrefix #-}- {-# INLINE concatMap #-}- {-# INLINE dropWhile #-}- {-# INLINE fromText #-}- {-# INLINE map #-}- {-# INLINE mapAccumL #-}- {-# INLINE mapAccumR #-}- {-# INLINE scanl #-}- {-# INLINE scanl1 #-}- {-# INLINE scanr #-}- {-# INLINE scanr1 #-}- {-# INLINE singleton #-}- {-# INLINE spanMaybe #-}- {-# INLINE spanMaybe' #-}- {-# INLINE split #-}- {-# INLINE takeWhile #-}- {-# INLINE foldl_ #-}- {-# INLINE foldl_' #-}- {-# INLINE foldr_ #-}- {-# INLINE spanMaybe_ #-}- {-# INLINE spanMaybe_' #-}- {-# INLINE span_ #-}- {-# INLINE break_ #-}- {-# INLINE takeWhile_ #-}- {-# INLINE dropWhile_ #-}- {-# MINIMAL splitCharacterPrefix #-}--foldlChars :: TextualMonoid t => (Char -> Char -> Char) -> (t, Char) -> Char -> (t, Char)-foldlOther :: Monoid t => (t, Char) -> t -> (t, Char)-foldrChars :: TextualMonoid t => (Char -> Char -> Char) -> Char -> (t, Char) -> (t, Char)-foldrOther :: Monoid t => t -> (t, a) -> (t, a)-foldlChars f (t, c1) c2 = (mappend t (singleton c'), c')- where c' = f c1 c2-foldlOther (t1, c) t2 = (mappend t1 t2, c)-foldrChars f c1 (t, c2) = (mappend (singleton c') t, c')- where c' = f c1 c2-foldrOther t1 (t2, c) = (mappend t1 t2, c)--instance TextualMonoid String where- fromText = Text.unpack- singleton c = [c]- splitCharacterPrefix (c:rest) = Just (c, rest)- splitCharacterPrefix [] = Nothing- characterPrefix (c:_) = Just c- characterPrefix [] = Nothing- map = List.map- concatMap = List.concatMap- toString = const id- any = List.any- all = List.all-- foldl = const List.foldl- foldl' = const List.foldl'- foldr = const List.foldr-- scanl = List.scanl- scanl1 = List.scanl1- scanr = List.scanr- scanr1 = List.scanr1- mapAccumL = List.mapAccumL- mapAccumR = List.mapAccumR-- takeWhile _ = List.takeWhile- dropWhile _ = List.dropWhile- break _ = List.break- span _ = List.span- spanMaybe s0 _ft fc l = (prefix' [], suffix' [], s')- where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l- g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = (prefix . (c:), id, s1, True)- | otherwise = (prefix, suffix . (c:), s, False)- spanMaybe' s0 _ft fc l = (prefix' [], suffix' [], s')- where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l- g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = seq s1 (prefix . (c:), id, s1, True)- | otherwise = (prefix, suffix . (c:), s, False)- find = List.find- elem = List.elem-- {-# INLINE all #-}- {-# INLINE any #-}- {-# INLINE break #-}- {-# INLINE characterPrefix #-}- {-# INLINE concatMap #-}- {-# INLINE dropWhile #-}- {-# INLINE elem #-}- {-# INLINE find #-}- {-# INLINE foldl #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE fromText #-}- {-# INLINE map #-}- {-# INLINE mapAccumL #-}- {-# INLINE mapAccumR #-}- {-# INLINE scanl #-}- {-# INLINE scanl1 #-}- {-# INLINE scanr #-}- {-# INLINE scanr1 #-}- {-# INLINE singleton #-}- {-# INLINE span #-}- {-# INLINE spanMaybe #-}- {-# INLINE spanMaybe' #-}- {-# INLINE splitCharacterPrefix #-}- {-# INLINE takeWhile #-}--instance TextualMonoid Text where- fromText = id- singleton = Text.singleton- splitCharacterPrefix = Text.uncons- characterPrefix t = if Text.null t then Nothing else Just (Text.head t)- map = Text.map- concatMap = Text.concatMap- toString = const Text.unpack- any = Text.any- all = Text.all-- foldl = const Text.foldl- foldl' = const Text.foldl'- foldr = const Text.foldr-- scanl = Text.scanl- scanl1 = Text.scanl1- scanr = Text.scanr- scanr1 = Text.scanr1- mapAccumL = Text.mapAccumL- mapAccumR = Text.mapAccumR-- takeWhile _ = Text.takeWhile- dropWhile _ = Text.dropWhile- break _ = Text.break- span _ = Text.span- spanMaybe s0 _ft fc t = case Text.foldr g id t (0, s0)- of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')- where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s')- | otherwise = (i, s)- spanMaybe' s0 _ft fc t = case Text.foldr g id t (0, s0)- of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')- where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')- | otherwise = (i, s)- split = Text.split- find = Text.find-- {-# INLINE all #-}- {-# INLINE any #-}- {-# INLINE break #-}- {-# INLINE characterPrefix #-}- {-# INLINE concatMap #-}- {-# INLINE dropWhile #-}- {-# INLINE find #-}- {-# INLINE foldl #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE fromText #-}- {-# INLINE map #-}- {-# INLINE mapAccumL #-}- {-# INLINE mapAccumR #-}- {-# INLINE scanl #-}- {-# INLINE scanl1 #-}- {-# INLINE scanr #-}- {-# INLINE scanr1 #-}- {-# INLINE singleton #-}- {-# INLINE span #-}- {-# INLINE spanMaybe #-}- {-# INLINE spanMaybe' #-}- {-# INLINE split #-}- {-# INLINE splitCharacterPrefix #-}- {-# INLINE takeWhile #-}--instance TextualMonoid LazyText.Text where- fromText = LazyText.fromStrict- singleton = LazyText.singleton- splitCharacterPrefix = LazyText.uncons- characterPrefix t = if LazyText.null t then Nothing else Just (LazyText.head t)- map = LazyText.map- concatMap = LazyText.concatMap- toString = const LazyText.unpack- any = LazyText.any- all = LazyText.all-- foldl = const LazyText.foldl- foldl' = const LazyText.foldl'- foldr = const LazyText.foldr-- scanl = LazyText.scanl- scanl1 = LazyText.scanl1- scanr = LazyText.scanr- scanr1 = LazyText.scanr1- mapAccumL = LazyText.mapAccumL- mapAccumR = LazyText.mapAccumR-- takeWhile _ = LazyText.takeWhile- dropWhile _ = LazyText.dropWhile- break _ = LazyText.break- span _ = LazyText.span- spanMaybe s0 _ft fc t = case LazyText.foldr g id t (0, s0)- of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')- where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ cont (i', s')- | otherwise = (i, s)- spanMaybe' s0 _ft fc t = case LazyText.foldr g id t (0, s0)- of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')- where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')- | otherwise = (i, s)- split = LazyText.split- find = LazyText.find- {-# INLINE all #-}- {-# INLINE any #-}- {-# INLINE break #-}- {-# INLINE characterPrefix #-}- {-# INLINE concatMap #-}- {-# INLINE dropWhile #-}- {-# INLINE find #-}- {-# INLINE foldl #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE fromText #-}- {-# INLINE map #-}- {-# INLINE mapAccumL #-}- {-# INLINE mapAccumR #-}- {-# INLINE scanl #-}- {-# INLINE scanl1 #-}- {-# INLINE scanr #-}- {-# INLINE scanr1 #-}- {-# INLINE singleton #-}- {-# INLINE span #-}- {-# INLINE spanMaybe #-}- {-# INLINE spanMaybe' #-}- {-# INLINE split #-}- {-# INLINE splitCharacterPrefix #-}- {-# INLINE takeWhile #-}--instance TextualMonoid (Sequence.Seq Char) where- singleton = Sequence.singleton- splitCharacterPrefix s = case Sequence.viewl s- of Sequence.EmptyL -> Nothing- c Sequence.:< rest -> Just (c, rest)- characterPrefix s = case Sequence.viewl s- of Sequence.EmptyL -> Nothing- c Sequence.:< _ -> Just c- map = Traversable.fmapDefault- concatMap = Foldable.foldMap- toString = const Foldable.toList- any = Foldable.any- all = Foldable.all-- foldl = const Foldable.foldl- foldl' = const Foldable.foldl'- foldr = const Foldable.foldr-- scanl = Sequence.scanl- scanl1 f v | Sequence.null v = Sequence.empty- | otherwise = Sequence.scanl1 f v- scanr = Sequence.scanr- scanr1 f v | Sequence.null v = Sequence.empty- | otherwise = Sequence.scanr1 f v-- takeWhile _ = Sequence.takeWhileL- dropWhile _ = Sequence.dropWhileL- break _ = Sequence.breakl- span _ = Sequence.spanl- spanMaybe s0 _ft fc b = case Foldable.foldr g id b (0, s0)- of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')- where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s')- | otherwise = (i, s)- spanMaybe' s0 _ft fc b = case Foldable.foldr g id b (0, s0)- of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')- where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')- | otherwise = (i, s)- find = Foldable.find- elem = Foldable.elem-- {-# INLINE all #-}- {-# INLINE any #-}- {-# INLINE break #-}- {-# INLINE characterPrefix #-}- {-# INLINE concatMap #-}- {-# INLINE dropWhile #-}- {-# INLINE elem #-}- {-# INLINE find #-}- {-# INLINE foldl #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE map #-}- {-# INLINE scanl #-}- {-# INLINE scanl1 #-}- {-# INLINE scanr #-}- {-# INLINE scanr1 #-}- {-# INLINE singleton #-}- {-# INLINE span #-}- {-# INLINE spanMaybe #-}- {-# INLINE spanMaybe' #-}- {-# INLINE splitCharacterPrefix #-}- {-# INLINE takeWhile #-}--instance IsString (Vector.Vector Char) where- fromString = Vector.fromList--instance TextualMonoid (Vector.Vector Char) where- singleton = Vector.singleton- splitCharacterPrefix t = if Vector.null t then Nothing else Just (Vector.unsafeHead t, Vector.unsafeTail t)- characterPrefix = (Vector.!? 0)- map = Vector.map- concatMap = Vector.concatMap- toString = const Vector.toList- any = Vector.any- all = Vector.all-- foldl = const Vector.foldl- foldl' = const Vector.foldl'- foldr = const Vector.foldr-- scanl = Vector.scanl- scanl1 f v | Vector.null v = Vector.empty- | otherwise = Vector.scanl1 f v- scanr = Vector.scanr- scanr1 f v | Vector.null v = Vector.empty- | otherwise = Vector.scanr1 f v- mapAccumL f a0 t = (a', Vector.reverse $ Vector.fromList l')- where (a', l') = Vector.foldl fc (a0, []) t- fc (a, l) c = (:l) <$> f a c- mapAccumR f a0 t = (a', Vector.fromList l')- where (a', l') = Vector.foldr fc (a0, []) t- fc c (a, l) = (:l) <$> f a c-- takeWhile _ = Vector.takeWhile- dropWhile _ = Vector.dropWhile- break _ = Vector.break- span _ = Vector.span- spanMaybe s0 _ft fc v = case Vector.ifoldr g Left v s0- of Left s' -> (v, Vector.empty, s')- Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')- where g i c cont s | Just s' <- fc s c = cont s'- | otherwise = Right (i, s)- spanMaybe' s0 _ft fc v = case Vector.ifoldr' g Left v s0- of Left s' -> (v, Vector.empty, s')- Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')- where g i c cont s | Just s' <- fc s c = seq s' (cont s')- | otherwise = Right (i, s)- find = Vector.find- elem = Vector.elem-- {-# INLINE all #-}- {-# INLINE any #-}- {-# INLINE break #-}- {-# INLINE characterPrefix #-}- {-# INLINE concatMap #-}- {-# INLINE dropWhile #-}- {-# INLINE elem #-}- {-# INLINE find #-}- {-# INLINE foldl #-}- {-# INLINE foldl' #-}- {-# INLINE foldr #-}- {-# INLINE map #-}- {-# INLINE mapAccumL #-}- {-# INLINE mapAccumR #-}- {-# INLINE scanl #-}- {-# INLINE scanl1 #-}- {-# INLINE scanr #-}- {-# INLINE scanr1 #-}- {-# INLINE singleton #-}- {-# INLINE span #-}- {-# INLINE spanMaybe #-}- {-# INLINE spanMaybe' #-}- {-# INLINE splitCharacterPrefix #-}- {-# INLINE takeWhile #-}
README.md view
@@ -1,28 +1,41 @@ monoid-subclasses ================= -### Subclasses of Monoid with a solid theoretical foundation and practical purposes ###+### Subclasses of Semigroup and 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/package/base/docs/Data-Monoid.html#t:Monoid) but less demanding than [groups](http://hackage.haskell.org/package/groups/docs/Data-Group.html):- * [ReductiveMonoid](http://hackage.haskell.org/package/monoid-subclasses/docs/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/package/monoid-subclasses/docs/Data-Monoid-Cancellative.html#t:CancellativeMonoid) is a subclass of `ReductiveMonoid` that provides additional guarantees about the `</>` operation result:+The monoid-subclasses package has been released [on+Hackage](https://hackage.haskell.org/package/monoid-subclasses). The package defines several classes that are richer+than [semigroups](https://hackage.haskell.org/package/base/docs/Data-Semigroup.html#t:Semigroup) and+[monoids](https://hackage.haskell.org/package/base/docs/Data-Monoid.html#t:Monoid) but less demanding than+[groups](https://hackage.haskell.org/package/groups/docs/Data-Group.html): +* [Reductive](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Semigroup-Cancellative.html#t:Reductive)+provides the operator `</>` which acts as a partial inverse of the semigroup `<>` operator.+* [Cancellative](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Semigroup-Cancellative.html#t:Cancellative)+is a subclass of `Reductive` 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/package/monoid-subclasses/docs/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/package/monoid-subclasses/docs/Data-Monoid-Null.html) class provides the Boolean `null` operation that checks if the argument monoid is `mempty`.- * [FactorialMonoid](http://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-Factorial.html) class represents monoids that can be split up into irreducible factors.+ Every group (*i.e.*, every `Monoid a` with the operation `inverse :: a -> a`) is a cancellative monoid where `a </> b = Just (a <> inverse b)` but not every `Cancellative` monoid is a group. -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/package/ListLike/docs/Data-ListLike.html) - to provide unifying abstractions for various monoidal data types in Haskell, primarily [String](http://hackage.haskell.org/package/base/docs/Data-String.html#t:String), [ByteString](http://hackage.haskell.org/package/bytestring/docs/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/package/base/docs/Data-Monoid.html#t:Monoid) class. While that abstraction is useful for building sequences of data, it doesn't help with deconstructing them.+* [GCDMonoid](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-GCD.html#t:GCDMonoid) is a subclass of `Reductive` and `Monoid` that provides the `gcd` operation for getting the greatest common denominator for two given monoid values.+* [LCMMonoid](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-LCM.html#t:LCMMonoid) is a subclass of `Reductive` and `Monoid` that provides the `lcm` operation for getting the least common multiple for two given monoid values.+* [Monus](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-Monus.html#t:Monus) provides the `<\>` monus operation. The set difference is one familiar instance of this operation.+* [MonoidNull](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-Null.html#t:MonoidNull) class provides the Boolean `null` operation that checks if the argument monoid is `mempty`.+* [Factorial](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Semigroup-Factorial.html#t:Factorial) and [FactorialMonoid](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-Factorial.html#t:FactorialMonoid) classes represent semigroups and 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](https://hackage.haskell.org/package/ListLike/docs/Data-ListLike.html) - to provide unifying abstractions for various monoidal data types in Haskell, primarily [String](https://hackage.haskell.org/package/base/docs/Data-String.html#t:String), [ByteString](https://hackage.haskell.org/package/bytestring/docs/Data-ByteString.html#t:ByteString), and [Text](https://hackage.haskell.org/package/text). All three types are already instances of the [Monoid](https://hackage.haskell.org/package/base/docs/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/package/base/docs/Data-List.html) interface, whereas _monoid-subclasses_ builds from deeper theoretical foundations; and+ * _ListLike_ strives to reproduce the standard [Data.List](https://hackage.haskell.org/package/base/docs/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)+The [incremental-parser](https://hackage.haskell.org/package/incremental-parser) package can serve as a compact example+of a parser library that can be applied to different input types thanks to _monoid-subclasses_. There is also+[picoparsec](https://hackage.haskell.org/package/picoparsec), a fork of+[attoparsec](https://hackage.haskell.org/package/attoparsec), and the heavy-duty+[grammatical-parsers](https://hackage.haskell.org/package/grammatical-parsers) library. +A more thorough description of the library design can be found in the Haskell Symposium 2013 paper [Adding Structure+to Monoids ](https://github.com/blamario/monoid-subclasses/wiki/Files/HaskellSymposium2013.pdf)
Test/TestMonoidSubclasses.hs view
@@ -1,23 +1,30 @@-{- - Copyright 2013-2018 Mario Blazevic+{-+ Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} {-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-}+{- HLINT ignore "Use camelCase" -} module Main where -import Prelude hiding (foldl, foldr, gcd, length, null, reverse, span, splitAt, takeWhile)+import Prelude (Bool(..), Ordering, Int, Integer, Double, Float, Char, String,+ Maybe(..), Either(..), Eq, Show, (.), ($), (*), (==), (/=),+ (&&), (||), (++), (>>=), fmap, maybe, either, map, all, not,+ undefined, const, flip, succ, uncurry, min, id, replicate,+ minBound, maxBound, otherwise, fst, snd, concatMap, mappend, div) import Test.Tasty (defaultMain, testGroup) import Test.Tasty.QuickCheck (Arbitrary, CoArbitrary, Property, Gen,- arbitrary, coarbitrary, property, label, forAll, mapSize, testProperty, variant, whenFail, (.&&.))+ arbitrary, coarbitrary, property, label, forAll, mapSize, testProperty, variant, whenFail, (.&&.), (===)) import Test.QuickCheck.Instances () import Control.Applicative (Applicative(..), liftA2) import Data.Functor ((<$>))+import Data.Functor.Const (Const(..))+import Data.Functor.Identity (Identity(..)) import Data.Foldable (foldMap, toList) import Data.Int (Int8, Int32) import qualified Data.Foldable as Foldable@@ -26,11 +33,13 @@ import qualified Data.List as List import Data.Maybe (isJust) import Data.Either (lefts, rights)+import Data.Proxy (Proxy) import Data.Tuple (swap) import Data.String (IsString, fromString) import Data.Char (isLetter) import Data.Int (Int16) import Data.Word (Word, Word8)+import Numeric.Natural (Natural) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as Lazy (ByteString)@@ -47,28 +56,49 @@ import Text.Show.Functions import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(ByteStringUTF8))+import Data.Monoid.Instances.CharVector () import Data.Monoid.Instances.Concat (Concat) import qualified Data.Monoid.Instances.Concat as Concat import Data.Monoid.Instances.Measured (Measured) import qualified Data.Monoid.Instances.Measured as Measured+import qualified Data.Monoid.Instances.PrefixMemory as PrefixMemory import Data.Monoid.Instances.Stateful (Stateful) import qualified Data.Monoid.Instances.Stateful as Stateful import Data.Monoid.Instances.Positioned (OffsetPositioned, LinePositioned) import qualified Data.Monoid.Instances.Positioned as Positioned -import Data.Semigroup (Semigroup)-import Data.Monoid (Monoid, mempty, (<>), mconcat, All(All), Any(Any), Dual(Dual),+import Data.Semigroup (Semigroup, (<>), Max, Min)+import Data.Monoid (Monoid, mempty, mconcat, All(All), Any(Any), Dual(Dual), First(First), Last(Last), Sum(Sum), Product(Product))+import Data.Semigroup.Factorial (Factorial, StableFactorial,+ factors, primePrefix, primeSuffix, foldl, foldl', foldr, length, reverse)+import Data.Semigroup.Cancellative (Commutative, Reductive,+ LeftReductive, RightReductive,+ Cancellative, LeftCancellative, RightCancellative,+ (</>), isPrefixOf, stripPrefix, isSuffixOf, stripSuffix) import Data.Monoid.Null (MonoidNull, PositiveMonoid, null)-import Data.Monoid.Factorial (FactorialMonoid, StableFactorialMonoid, - factors, splitPrimePrefix, splitPrimeSuffix, primePrefix, primeSuffix, inits, tails,- foldl, foldl', foldr, length, reverse, span, spanMaybe, split, splitAt)-import Data.Monoid.Cancellative (CommutativeMonoid, ReductiveMonoid, LeftReductiveMonoid, RightReductiveMonoid,- CancellativeMonoid, LeftCancellativeMonoid, RightCancellativeMonoid,- GCDMonoid, LeftGCDMonoid, RightGCDMonoid,- (</>), gcd,- isPrefixOf, stripPrefix, commonPrefix, stripCommonPrefix,- isSuffixOf, stripSuffix, commonSuffix, stripCommonSuffix)+import Data.Monoid.Factorial (FactorialMonoid,+ splitPrimePrefix, splitPrimeSuffix, inits, tails, span, spanMaybe, split, splitAt)+import Data.Monoid.GCD+ ( GCDMonoid+ , LeftGCDMonoid+ , RightGCDMonoid+ , DistributiveGCDMonoid+ , LeftDistributiveGCDMonoid+ , RightDistributiveGCDMonoid+ , commonPrefix+ , commonSuffix+ , gcd+ , stripCommonPrefix+ , stripCommonSuffix+ )+import Data.Monoid.LCM+ ( LCMMonoid+ , DistributiveLCMMonoid+ , lcm+ )+import Data.Monoid.Monus (OverlappingGCDMonoid, Monus,+ (<\>), overlap, stripOverlap, stripPrefixOverlap, stripSuffixOverlap) import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Textual as Textual @@ -81,50 +111,80 @@ | LeftReductiveTest (LeftReductiveMonoidInstance -> Property) | RightReductiveTest (RightReductiveMonoidInstance -> Property) | ReductiveTest (ReductiveMonoidInstance -> Property)+ | OverlappingGCDTest (OverlappingGCDMonoidInstance -> Property)+ | MonusTest (MonusInstance -> Property) | LeftCancellativeTest (LeftCancellativeMonoidInstance -> Property) | RightCancellativeTest (RightCancellativeMonoidInstance -> Property) | CancellativeTest (CancellativeMonoidInstance -> Property) | LeftGCDTest (LeftGCDMonoidInstance -> Property) | RightGCDTest (RightGCDMonoidInstance -> Property) | GCDTest (GCDMonoidInstance -> Property)- | CancellativeGCDTest (CancellativeGCDMonoidInstance -> Property)+ | DistributiveGCDTest (DistributiveGCDMonoidInstance -> Property)+ | LeftDistributiveGCDTest (LeftDistributiveGCDMonoidInstance -> Property)+ | RightDistributiveGCDTest (RightDistributiveGCDMonoidInstance -> Property)+ | LCMTest (LCMMonoidInstance -> Property)+ | DistributiveLCMTest (DistributiveLCMMonoidInstance -> Property) -data CommutativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CommutativeMonoid a) => +data CommutativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Commutative a, Monoid a) => CommutativeMonoidInstance a-data NullMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => +data NullMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => NullMonoidInstance a data PositiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, PositiveMonoid a) => PositiveMonoidInstance a data FactorialMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => FactorialMonoidInstance a-data StableFactorialMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, StableFactorialMonoid a) =>+data StableFactorialMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a,+ StableFactorial a, FactorialMonoid a, PositiveMonoid a) => StableFactorialMonoidInstance a-data TextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => +data TextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => TextualMonoidInstance a-data StableTextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, StableFactorialMonoid a,+data StableTextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a,+ StableFactorial a, FactorialMonoid a, PositiveMonoid a, TextualMonoid a) => StableTextualMonoidInstance a-data LeftReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => +data LeftReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, LeftReductive a) => LeftReductiveMonoidInstance a-data RightReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightReductiveMonoid a) => +data RightReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, RightReductive a) => RightReductiveMonoidInstance a-data ReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, ReductiveMonoid a) => +data ReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, Reductive a) => ReductiveMonoidInstance a-data LeftCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftCancellativeMonoid a) => +data OverlappingGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, OverlappingGCDMonoid a, FactorialMonoid a) =>+ OverlappingGCDMonoidInstance a+data MonusInstance = forall a. (Arbitrary a, Show a, Eq a, Monus a, FactorialMonoid a) =>+ MonusInstance a+data LeftCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, LeftCancellative a) => LeftCancellativeMonoidInstance a-data RightCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightCancellativeMonoid a) => +data RightCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, RightCancellative a) => RightCancellativeMonoidInstance a-data CancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a) => +data CancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, Cancellative a) => CancellativeMonoidInstance a-data LeftGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) => +data LeftGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) => LeftGCDMonoidInstance a-data RightGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightGCDMonoid a) => +data RightGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightGCDMonoid a) => RightGCDMonoidInstance a-data GCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, GCDMonoid a) => +data GCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, GCDMonoid a) => GCDMonoidInstance a-data CancellativeGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a, GCDMonoid a) => - CancellativeGCDMonoidInstance a +data DistributiveGCDMonoidInstance =+ forall a. (Arbitrary a, Show a, Eq a, DistributiveGCDMonoid a)+ => DistributiveGCDMonoidInstance a++data LeftDistributiveGCDMonoidInstance =+ forall a. (Arbitrary a, Show a, Eq a, LeftDistributiveGCDMonoid a)+ => LeftDistributiveGCDMonoidInstance a++data RightDistributiveGCDMonoidInstance =+ forall a. (Arbitrary a, Show a, Eq a, RightDistributiveGCDMonoid a)+ => RightDistributiveGCDMonoidInstance a++data LCMMonoidInstance =+ forall a. (Arbitrary a, Show a, Eq a, LCMMonoid a)+ => LCMMonoidInstance a++data DistributiveLCMMonoidInstance =+ forall a. (Arbitrary a, Show a, Eq a, DistributiveLCMMonoid a)+ => DistributiveLCMMonoidInstance a+ commutativeInstances :: [CommutativeMonoidInstance] commutativeInstances = map upcast reductiveInstances ++ [CommutativeMonoidInstance (mempty :: Product Double)]@@ -149,7 +209,14 @@ PositiveMonoidInstance (mempty :: Ordering), PositiveMonoidInstance (mempty :: All), PositiveMonoidInstance (mempty :: Any),+ PositiveMonoidInstance (mempty :: Max Int),+ PositiveMonoidInstance (mempty :: Min Int),+ PositiveMonoidInstance (mempty :: Const String Float),+ PositiveMonoidInstance (mempty :: Identity Ordering),+ PositiveMonoidInstance (mempty :: (Proxy Float)), PositiveMonoidInstance (mempty :: (Maybe (Sum Integer))),+ PositiveMonoidInstance (mempty :: (Product Natural)),+ PositiveMonoidInstance (mempty :: (Sum Natural)), PositiveMonoidInstance (mempty :: (First Char)), PositiveMonoidInstance (mempty :: (Last Int)), PositiveMonoidInstance (mempty :: String),@@ -164,6 +231,8 @@ factorialInstances = map upcast stableFactorialInstances ++ [FactorialMonoidInstance (mempty :: Sum Integer), FactorialMonoidInstance (mempty :: Product Int32),+ FactorialMonoidInstance (mempty :: Identity String),+ FactorialMonoidInstance (mempty :: Const String Int), FactorialMonoidInstance (mempty :: Maybe String), FactorialMonoidInstance (mempty :: (Text, String)), FactorialMonoidInstance (mempty :: (Product Int32, ByteString, Sum Integer)),@@ -180,7 +249,7 @@ where upcast (StableFactorialMonoidInstance i) = FactorialMonoidInstance i stableFactorialInstances :: [StableFactorialMonoidInstance]-stableFactorialInstances = stable1 ++ map measure stable1 ++ map position stable1 +stableFactorialInstances = stable1 ++ map measure stable1 ++ map prefixed stable1 ++ map position stable1 where stable1 = map upcast stableTextualInstances ++ [StableFactorialMonoidInstance (mempty :: ByteString), StableFactorialMonoidInstance (mempty :: Lazy.ByteString),@@ -189,7 +258,8 @@ StableFactorialMonoidInstance (mempty :: Vector Int)] upcast (StableTextualMonoidInstance i) = StableFactorialMonoidInstance i measure (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (Measured.measure i)- position (StableFactorialMonoidInstance (i :: a)) = + prefixed (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (PrefixMemory.shadowed i)+ position (StableFactorialMonoidInstance (i :: a)) = StableFactorialMonoidInstance (pure i :: OffsetPositioned a) textualInstances :: [TextualMonoidInstance]@@ -199,11 +269,13 @@ TextualMonoidInstance (mempty :: Lazy.Text), TextualMonoidInstance (mempty :: Seq Char), TextualMonoidInstance (mempty :: Vector Char),- TextualMonoidInstance (mempty :: Stateful (IntMap Int) Text)]+ TextualMonoidInstance (mempty :: Stateful (IntMap Int) Text),+ TextualMonoidInstance (mempty :: TestOffsetPositionedString),+ TextualMonoidInstance (mempty :: TestLinePositionedString)] where upcast (StableTextualMonoidInstance i) = TextualMonoidInstance i stableTextualInstances :: [StableTextualMonoidInstance]-stableTextualInstances = stable1 ++ map measure stable1 ++ concatMap position stable1+stableTextualInstances = stable1 ++ map measure stable1 ++ map prefixed stable1 ++ concatMap position stable1 where stable1 = [StableTextualMonoidInstance (mempty :: TestString), StableTextualMonoidInstance (mempty :: String), StableTextualMonoidInstance (mempty :: Text),@@ -211,7 +283,8 @@ StableTextualMonoidInstance (mempty :: Seq Char), StableTextualMonoidInstance (mempty :: Vector Char)] measure (StableTextualMonoidInstance i) = StableTextualMonoidInstance (Measured.measure i)- position (StableTextualMonoidInstance (i :: a)) = + prefixed (StableTextualMonoidInstance i) = StableTextualMonoidInstance (PrefixMemory.shadowed i)+ position (StableTextualMonoidInstance (i :: a)) = [StableTextualMonoidInstance (pure i :: OffsetPositioned a), StableTextualMonoidInstance (pure i :: LinePositioned a)] @@ -219,31 +292,82 @@ ++ [LeftReductiveMonoidInstance (mempty :: Sum Integer), LeftReductiveMonoidInstance (mempty :: IntSet), LeftReductiveMonoidInstance (mempty :: Set Integer),+ LeftReductiveMonoidInstance (mempty :: IntMap Char),+ LeftReductiveMonoidInstance (mempty :: Map Char Int), LeftReductiveMonoidInstance (mempty :: Concat String), LeftReductiveMonoidInstance (mempty :: Concat ByteString), LeftReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), LeftReductiveMonoidInstance (mempty :: Concat Text), LeftReductiveMonoidInstance (mempty :: Concat Lazy.Text),- LeftReductiveMonoidInstance (mempty :: Concat (Dual Text))]+ LeftReductiveMonoidInstance (mempty :: Concat (Dual Text)),+ LeftReductiveMonoidInstance (mempty :: LinePositioned Text),+ LeftReductiveMonoidInstance (mempty :: OffsetPositioned Text),+ LeftReductiveMonoidInstance (mempty :: Measured Text),+ LeftReductiveMonoidInstance (mempty :: PrefixMemory.Shadowed Text),+ LeftReductiveMonoidInstance (mempty :: Stateful (Sum Integer) Text)] where upcast (LeftCancellativeMonoidInstance i) = LeftReductiveMonoidInstance i rightReductiveInstances = map upcast rightCancellativeInstances ++ [RightReductiveMonoidInstance (mempty :: Product Integer), RightReductiveMonoidInstance (mempty :: IntSet),+ RightReductiveMonoidInstance (mempty :: Map Char Int),+ RightReductiveMonoidInstance (mempty :: IntMap Char), RightReductiveMonoidInstance (mempty :: Set String), RightReductiveMonoidInstance (mempty :: Concat ByteString), RightReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), RightReductiveMonoidInstance (mempty :: Concat Text), RightReductiveMonoidInstance (mempty :: Concat Lazy.Text),- RightReductiveMonoidInstance (mempty :: Concat (Dual Text))]+ RightReductiveMonoidInstance (mempty :: Concat (Dual Text)),+ RightReductiveMonoidInstance (mempty :: LinePositioned Text),+ RightReductiveMonoidInstance (mempty :: OffsetPositioned Text),+ RightReductiveMonoidInstance (mempty :: Measured Text),+ RightReductiveMonoidInstance (mempty :: PrefixMemory.Shadowed Text),+ RightReductiveMonoidInstance (mempty :: Stateful (Sum Integer) Text)] where upcast (RightCancellativeMonoidInstance i) = RightReductiveMonoidInstance i reductiveInstances = map upcast cancellativeInstances ++ [ReductiveMonoidInstance (mempty :: Product Integer),+ ReductiveMonoidInstance (mempty :: Max Int),+ ReductiveMonoidInstance (mempty :: Min Int),+ ReductiveMonoidInstance (mempty :: All),+ ReductiveMonoidInstance (mempty :: Any),+ ReductiveMonoidInstance (mempty :: Identity IntSet),+ ReductiveMonoidInstance (mempty :: Const (Sum Int) Float), ReductiveMonoidInstance (mempty :: IntSet),+ ReductiveMonoidInstance (mempty :: Maybe IntSet), ReductiveMonoidInstance (mempty :: Set Integer)] where upcast (CancellativeMonoidInstance i) = ReductiveMonoidInstance i +overlappingGCDMonoidInstances = map upcast monusInstances+ ++ [OverlappingGCDMonoidInstance (mempty :: String),+ OverlappingGCDMonoidInstance (mempty :: Identity String),+ OverlappingGCDMonoidInstance (mempty :: Const String Int),+ OverlappingGCDMonoidInstance (mempty :: Seq Int),+ OverlappingGCDMonoidInstance (mempty :: ByteString),+ OverlappingGCDMonoidInstance (mempty :: Lazy.ByteString),+ OverlappingGCDMonoidInstance (mempty :: Text),+ OverlappingGCDMonoidInstance (mempty :: Lazy.Text),+ OverlappingGCDMonoidInstance (mempty :: Vector Char),+ OverlappingGCDMonoidInstance (mempty :: IntMap Char),+ OverlappingGCDMonoidInstance (mempty :: Map Char Int)]+ where upcast (MonusInstance i) = OverlappingGCDMonoidInstance i++monusInstances = [MonusInstance (mempty :: Product Natural),+ MonusInstance (mempty :: Sum Natural),+ MonusInstance (mempty :: Identity (Sum Natural)),+ MonusInstance (mempty :: Const (Sum Natural) Int),+ MonusInstance (mempty :: Dual (Product Natural)),+ MonusInstance (mempty :: Maybe ()),+ MonusInstance (mempty :: Maybe (Product Natural)),+ MonusInstance (mempty :: Maybe (Sum Natural)),+ MonusInstance (mempty :: IntSet),+ MonusInstance (mempty :: Set String),+ MonusInstance (mempty :: ()),+ MonusInstance (mempty :: (Sum Natural)),+ MonusInstance (mempty :: (Sum Natural, Sum Natural)),+ MonusInstance (mempty :: (Sum Natural, Sum Natural, Sum Natural)),+ MonusInstance (mempty :: (Sum Natural, Sum Natural, Sum Natural, Sum Natural))]+ leftCancellativeInstances = map upcast cancellativeInstances ++ [LeftCancellativeMonoidInstance (mempty :: String), LeftCancellativeMonoidInstance (mempty :: ByteString),@@ -267,9 +391,7 @@ RightCancellativeMonoidInstance (mempty :: Vector Int)] where upcast (CancellativeMonoidInstance i) = RightCancellativeMonoidInstance i -cancellativeInstances = map upcast cancellativeGCDInstances- ++ []- where upcast (CancellativeGCDMonoidInstance i) = CancellativeMonoidInstance i+cancellativeInstances = [CancellativeMonoidInstance ()] leftGCDInstances = map upcast gcdInstances ++ [LeftGCDMonoidInstance (mempty :: String),@@ -277,6 +399,8 @@ LeftGCDMonoidInstance (mempty :: Lazy.ByteString), LeftGCDMonoidInstance (mempty :: Text), LeftGCDMonoidInstance (mempty :: Lazy.Text),+ LeftGCDMonoidInstance (mempty :: Identity ByteString),+ LeftGCDMonoidInstance (mempty :: Const ByteString Int), LeftGCDMonoidInstance (mempty :: Dual ByteString), LeftGCDMonoidInstance (mempty :: (Text, String)), LeftGCDMonoidInstance (mempty :: (ByteString, Text, String)),@@ -296,6 +420,11 @@ rightGCDInstances = map upcast gcdInstances ++ [RightGCDMonoidInstance (mempty :: ByteString), RightGCDMonoidInstance (mempty :: Lazy.ByteString),+ RightGCDMonoidInstance (mempty :: Text),+ RightGCDMonoidInstance (mempty :: Lazy.Text),+ RightGCDMonoidInstance (mempty :: String),+ RightGCDMonoidInstance (mempty :: Identity ByteString),+ RightGCDMonoidInstance (mempty :: Const ByteString Int), RightGCDMonoidInstance (mempty :: Dual String), RightGCDMonoidInstance (mempty :: (Seq Int, ByteString)), RightGCDMonoidInstance (mempty :: Seq Int),@@ -305,23 +434,138 @@ RightGCDMonoidInstance (mempty :: Concat (Dual Text))] where upcast (GCDMonoidInstance i) = RightGCDMonoidInstance i -gcdInstances = map upcast cancellativeGCDInstances- ++ [GCDMonoidInstance (mempty :: Product Integer),- GCDMonoidInstance (mempty :: Dual (Product Integer)),- GCDMonoidInstance (mempty :: IntSet),- GCDMonoidInstance (mempty :: Set String)]- where upcast (CancellativeGCDMonoidInstance i) = GCDMonoidInstance i+gcdInstances =+ [ GCDMonoidInstance (mempty :: ())+ , GCDMonoidInstance (mempty :: Product Natural)+ , GCDMonoidInstance (mempty :: Identity (Sum Natural))+ , GCDMonoidInstance (mempty :: Const (Sum Natural) Int)+ , GCDMonoidInstance (mempty :: Dual (Product Natural))+ , GCDMonoidInstance (mempty :: IntSet)+ , GCDMonoidInstance (mempty :: Set String)+ ] -cancellativeGCDInstances = [CancellativeGCDMonoidInstance (),- CancellativeGCDMonoidInstance (mempty :: Sum Integer),- CancellativeGCDMonoidInstance (mempty :: Dual (Sum Integer)),- CancellativeGCDMonoidInstance (mempty :: (Sum Integer, Dual (Sum Integer))),- CancellativeGCDMonoidInstance (mempty :: (Sum Integer, (), Dual (Sum Integer))),- CancellativeGCDMonoidInstance (mempty :: ((Sum Integer, ()), Sum Integer, (),- Dual (Sum Integer)))]+distributiveGCDMonoidInstances :: [DistributiveGCDMonoidInstance]+distributiveGCDMonoidInstances =+ [ DistributiveGCDMonoidInstance (mempty :: ())+ , DistributiveGCDMonoidInstance (mempty :: Product Natural)+ , DistributiveGCDMonoidInstance (mempty :: Sum Natural)+ , DistributiveGCDMonoidInstance (mempty :: IntSet)+ , DistributiveGCDMonoidInstance (mempty :: Set ())+ , DistributiveGCDMonoidInstance (mempty :: Set Bool)+ , DistributiveGCDMonoidInstance (mempty :: Set Word)+ , DistributiveGCDMonoidInstance (mempty :: Identity (Sum Natural))+ , DistributiveGCDMonoidInstance (mempty :: Const (Sum Natural) Int)+ , DistributiveGCDMonoidInstance (mempty :: Dual (Set ()))+ , DistributiveGCDMonoidInstance (mempty :: Dual (Set Bool))+ , DistributiveGCDMonoidInstance (mempty :: Dual (Set Word))+ ] +leftDistributiveGCDMonoidInstances :: [LeftDistributiveGCDMonoidInstance]+leftDistributiveGCDMonoidInstances =+ [ -- Instances for non-commutative monoids:+ LeftDistributiveGCDMonoidInstance (mempty :: [()])+ , LeftDistributiveGCDMonoidInstance (mempty :: [Bool])+ , LeftDistributiveGCDMonoidInstance (mempty :: [Word])+ , LeftDistributiveGCDMonoidInstance (mempty :: Seq ())+ , LeftDistributiveGCDMonoidInstance (mempty :: Seq Bool)+ , LeftDistributiveGCDMonoidInstance (mempty :: Seq Word)+ , LeftDistributiveGCDMonoidInstance (mempty :: Vector ())+ , LeftDistributiveGCDMonoidInstance (mempty :: Vector Bool)+ , LeftDistributiveGCDMonoidInstance (mempty :: Vector Word)+ , LeftDistributiveGCDMonoidInstance (mempty :: ByteString)+ , LeftDistributiveGCDMonoidInstance (mempty :: Lazy.ByteString)+ , LeftDistributiveGCDMonoidInstance (mempty :: Text)+ , LeftDistributiveGCDMonoidInstance (mempty :: Lazy.Text)+ -- Instances for commutative monoids:+ , LeftDistributiveGCDMonoidInstance (mempty :: ())+ , LeftDistributiveGCDMonoidInstance (mempty :: Product Natural)+ , LeftDistributiveGCDMonoidInstance (mempty :: Sum Natural)+ , LeftDistributiveGCDMonoidInstance (mempty :: IntSet)+ , LeftDistributiveGCDMonoidInstance (mempty :: Set ())+ , LeftDistributiveGCDMonoidInstance (mempty :: Set Bool)+ , LeftDistributiveGCDMonoidInstance (mempty :: Set Word)+ -- Instances for monoid transformers:+ , LeftDistributiveGCDMonoidInstance (mempty :: Identity [()])+ , LeftDistributiveGCDMonoidInstance (mempty :: Identity [Bool])+ , LeftDistributiveGCDMonoidInstance (mempty :: Identity [Word])+ , LeftDistributiveGCDMonoidInstance (mempty :: Const [()] Int)+ , LeftDistributiveGCDMonoidInstance (mempty :: Const [Bool] Int)+ , LeftDistributiveGCDMonoidInstance (mempty :: Const [Word] Int)+ , LeftDistributiveGCDMonoidInstance (mempty :: Dual [()])+ , LeftDistributiveGCDMonoidInstance (mempty :: Dual [Bool])+ , LeftDistributiveGCDMonoidInstance (mempty :: Dual [Word])+ ]++rightDistributiveGCDMonoidInstances :: [RightDistributiveGCDMonoidInstance]+rightDistributiveGCDMonoidInstances =+ [ -- Instances for non-commutative monoids:+ RightDistributiveGCDMonoidInstance (mempty :: [()])+ , RightDistributiveGCDMonoidInstance (mempty :: [Bool])+ , RightDistributiveGCDMonoidInstance (mempty :: [Word])+ , RightDistributiveGCDMonoidInstance (mempty :: Seq ())+ , RightDistributiveGCDMonoidInstance (mempty :: Seq Bool)+ , RightDistributiveGCDMonoidInstance (mempty :: Seq Word)+ , RightDistributiveGCDMonoidInstance (mempty :: Vector ())+ , RightDistributiveGCDMonoidInstance (mempty :: Vector Bool)+ , RightDistributiveGCDMonoidInstance (mempty :: Vector Word)+ , RightDistributiveGCDMonoidInstance (mempty :: ByteString)+ , RightDistributiveGCDMonoidInstance (mempty :: Lazy.ByteString)+ , RightDistributiveGCDMonoidInstance (mempty :: Text)+ , RightDistributiveGCDMonoidInstance (mempty :: Lazy.Text)+ -- Instances for commutative monoids:+ , RightDistributiveGCDMonoidInstance (mempty :: ())+ , RightDistributiveGCDMonoidInstance (mempty :: Product Natural)+ , RightDistributiveGCDMonoidInstance (mempty :: Sum Natural)+ , RightDistributiveGCDMonoidInstance (mempty :: IntSet)+ , RightDistributiveGCDMonoidInstance (mempty :: Set ())+ , RightDistributiveGCDMonoidInstance (mempty :: Set Bool)+ , RightDistributiveGCDMonoidInstance (mempty :: Set Word)+ -- Instances for monoid transformers:+ , RightDistributiveGCDMonoidInstance (mempty :: Identity [()])+ , RightDistributiveGCDMonoidInstance (mempty :: Identity [Bool])+ , RightDistributiveGCDMonoidInstance (mempty :: Identity [Word])+ , RightDistributiveGCDMonoidInstance (mempty :: Const [()] Int)+ , RightDistributiveGCDMonoidInstance (mempty :: Const [Bool] Int)+ , RightDistributiveGCDMonoidInstance (mempty :: Const [Word] Int)+ , RightDistributiveGCDMonoidInstance (mempty :: Dual [()])+ , RightDistributiveGCDMonoidInstance (mempty :: Dual [Bool])+ , RightDistributiveGCDMonoidInstance (mempty :: Dual [Word])+ ]++lcmInstances =+ [LCMMonoidInstance (mempty :: Product Natural),+ LCMMonoidInstance (mempty :: Sum Natural),+ LCMMonoidInstance (mempty :: Identity (Sum Natural)),+ LCMMonoidInstance (mempty :: Const (Sum Natural) Int),+ LCMMonoidInstance (mempty :: Dual (Product Natural)),+ LCMMonoidInstance (mempty :: Dual (Sum Natural)),+ LCMMonoidInstance (mempty :: IntSet),+ LCMMonoidInstance (mempty :: (IntSet, IntSet)),+ LCMMonoidInstance (mempty :: (IntSet, IntSet, IntSet)),+ LCMMonoidInstance (mempty :: (IntSet, IntSet, IntSet, IntSet)),+ -- For sets, test with a variety of different universe sizes, from small+ -- to large:+ LCMMonoidInstance (mempty :: Set ()),+ LCMMonoidInstance (mempty :: Set Bool),+ LCMMonoidInstance (mempty :: Set Ordering),+ LCMMonoidInstance (mempty :: Set Word8)]++distributiveLCMInstances =+ [ DistributiveLCMMonoidInstance (mempty :: ())+ , DistributiveLCMMonoidInstance (mempty :: Product Natural)+ , DistributiveLCMMonoidInstance (mempty :: Sum Natural)+ , DistributiveLCMMonoidInstance (mempty :: IntSet)+ , DistributiveLCMMonoidInstance (mempty :: Set ())+ , DistributiveLCMMonoidInstance (mempty :: Set Bool)+ , DistributiveLCMMonoidInstance (mempty :: Set Word)+ , DistributiveLCMMonoidInstance (mempty :: Identity (Sum Natural))+ , DistributiveLCMMonoidInstance (mempty :: Const (Sum Natural) Int)+ , DistributiveLCMMonoidInstance (mempty :: Dual (Product Natural))+ , DistributiveLCMMonoidInstance (mempty :: Dual (Sum Natural))+ ]+ main = defaultMain (testGroup "MonoidSubclasses" $ map expand tests)- where expand (name, test) = testProperty name (foldr1 (.&&.) $ checkInstances test)+ where expand (name, test) = testProperty name (List.foldr1 (.&&.) $ checkInstances test) checkInstances :: Test -> [Property] checkInstances (CommutativeTest checkType) = (map checkType commutativeInstances)@@ -333,13 +577,19 @@ checkInstances (LeftReductiveTest checkType) = (map checkType leftReductiveInstances) checkInstances (RightReductiveTest checkType) = (map checkType rightReductiveInstances) checkInstances (ReductiveTest checkType) = (map checkType reductiveInstances)-checkInstances (LeftCancellativeTest checkType) = (map checkType leftCancellativeInstances) -checkInstances (RightCancellativeTest checkType) = (map checkType rightCancellativeInstances) -checkInstances (CancellativeTest checkType) = (map checkType cancellativeInstances) -checkInstances (LeftGCDTest checkType) = (map checkType leftGCDInstances) -checkInstances (RightGCDTest checkType) = (map checkType rightGCDInstances) -checkInstances (GCDTest checkType) = (map checkType gcdInstances) -checkInstances (CancellativeGCDTest checkType) = (map checkType cancellativeGCDInstances) +checkInstances (LeftCancellativeTest checkType) = (map checkType leftCancellativeInstances)+checkInstances (RightCancellativeTest checkType) = (map checkType rightCancellativeInstances)+checkInstances (CancellativeTest checkType) = (map checkType cancellativeInstances)+checkInstances (OverlappingGCDTest checkType) = (map checkType overlappingGCDMonoidInstances)+checkInstances (MonusTest checkType) = (map checkType monusInstances)+checkInstances (LeftGCDTest checkType) = (map checkType leftGCDInstances)+checkInstances (RightGCDTest checkType) = (map checkType rightGCDInstances)+checkInstances (GCDTest checkType) = (map checkType gcdInstances)+checkInstances (DistributiveGCDTest checkType) = (map checkType distributiveGCDMonoidInstances)+checkInstances (LeftDistributiveGCDTest checkType) = (map checkType leftDistributiveGCDMonoidInstances)+checkInstances (RightDistributiveGCDTest checkType) = (map checkType rightDistributiveGCDMonoidInstances)+checkInstances (LCMTest checkType) = (map checkType lcmInstances)+checkInstances (DistributiveLCMTest checkType) = (map checkType distributiveLCMInstances) tests :: [(String, Test)] tests = [("CommutativeMonoid", CommutativeTest checkCommutative),@@ -382,6 +632,7 @@ ("Textual.scanl1", TextualTest checkTextualScanl1), ("Textual.scanr1", TextualTest checkTextualScanr1), ("Textual.toString", TextualTest checkToString),+ ("Textual.toText", TextualTest checkToText), ("Textual.mapAccumL", TextualTest checkTextualMapAccumL), ("Textual.mapAccumR", TextualTest checkTextualMapAccumR), ("Textual.takeWhile", TextualTest checkTextualTakeWhile),@@ -401,6 +652,24 @@ ("Textual.takeWhile_", TextualTest checkTextualTakeWhile_), ("Textual.dropWhile_", TextualTest checkTextualDropWhile_), ("stripPrefix", LeftReductiveTest checkStripPrefix),+ ("stripPrefixOverlap 1", OverlappingGCDTest checkStripPrefixOverlap1),+ ("stripPrefixOverlap 2", OverlappingGCDTest checkStripPrefixOverlap2),+ ("stripPrefixOverlap 3", OverlappingGCDTest checkStripPrefixOverlap3),+ ("stripSuffixOverlap 1", OverlappingGCDTest checkStripSuffixOverlap1),+ ("stripSuffixOverlap 2", OverlappingGCDTest checkStripSuffixOverlap2),+ ("stripSuffixOverlap 3", OverlappingGCDTest checkStripSuffixOverlap3),+ ("overlap law 1", OverlappingGCDTest checkOverlapLaw1),+ ("overlap law 2", OverlappingGCDTest checkOverlapLaw2),+ ("overlap law 3", OverlappingGCDTest checkOverlapLaw3),+ ("overlap idempotence", OverlappingGCDTest checkOverlap_idempotence),+ ("overlap identity (left)", OverlappingGCDTest checkOverlap_identity_left),+ ("overlap identity (right)", OverlappingGCDTest checkOverlap_identity_right),+ ("Monus identity (1)", MonusTest checkMonus_identity_1),+ ("Monus identity (2)", MonusTest checkMonus_identity_2),+ ("Monus mappend (1)", MonusTest checkMonus_mappend_1),+ ("Monus mappend (2)", MonusTest checkMonus_mappend_2),+ ("Monus stripPrefixOverlap", MonusTest checkMonus_stripPrefixOverlap),+ ("Monus stripSuffixOverlap", MonusTest checkMonus_stripSuffixOverlap), ("isPrefixOf", LeftReductiveTest checkIsPrefixOf), ("stripSuffix", RightReductiveTest checkStripSuffix), ("isSuffixOf", RightReductiveTest checkIsSuffixOf),@@ -410,10 +679,47 @@ ("cancellative </>", CancellativeTest checkUnAppend'), ("stripCommonPrefix 1", LeftGCDTest checkStripCommonPrefix1), ("stripCommonPrefix 2", LeftGCDTest checkStripCommonPrefix2),+ ("stripCommonPrefix 3", LeftGCDTest checkStripCommonPrefix3),+ ("stripCommonPrefix 4", LeftGCDTest checkStripCommonPrefix4), ("stripCommonSuffix 1", RightGCDTest checkStripCommonSuffix1), ("stripCommonSuffix 2", RightGCDTest checkStripCommonSuffix2),+ ("stripCommonSuffix 3", RightGCDTest checkStripCommonSuffix3),+ ("stripCommonSuffix 4", RightGCDTest checkStripCommonSuffix4), ("gcd", GCDTest checkGCD),- ("cancellative gcd", CancellativeGCDTest checkCancellativeGCD)+ ("gcd uniqueness", GCDTest checkGCD_uniqueness),+ ("gcd idempotence", GCDTest checkGCD_idempotence),+ ("gcd identity (left)", GCDTest checkGCD_identity_left),+ ("gcd identity (right)", GCDTest checkGCD_identity_right),+ ("gcd commutativity", GCDTest checkGCD_commutativity),+ ("gcd associativity", GCDTest checkGCD_associativity),+ ("gcd distributivity (left)", DistributiveGCDTest checkGCD_distributivity_left),+ ("gcd distributivity (right)", DistributiveGCDTest checkGCD_distributivity_right),+ ("commonPrefix idempotence", LeftGCDTest checkCommonPrefix_idempotence),+ ("commonPrefix identity (left)", LeftGCDTest checkCommonPrefix_identity_left),+ ("commonPrefix identity (right)", LeftGCDTest checkCommonPrefix_identity_right),+ ("commonPrefix commutativity", LeftGCDTest checkCommonPrefix_commutativity),+ ("commonPrefix associativity", LeftGCDTest checkCommonPrefix_associativity),+ ("commonPrefix distributivity", LeftDistributiveGCDTest checkCommonPrefix_distributivity),+ ("commonSuffix idempotence", RightGCDTest checkCommonSuffix_idempotence),+ ("commonSuffix identity (left)", RightGCDTest checkCommonSuffix_identity_left),+ ("commonSuffix identity (right)", RightGCDTest checkCommonSuffix_identity_right),+ ("commonSuffix commutativity", RightGCDTest checkCommonSuffix_commutativity),+ ("commonSuffix associativity", RightGCDTest checkCommonSuffix_associativity),+ ("commonSuffix distributivity", RightDistributiveGCDTest checkCommonSuffix_distributivity),+ ("lcm reductivity (left)", LCMTest checkLCM_reductivity_left),+ ("lcm reductivity (right)", LCMTest checkLCM_reductivity_right),+ ("lcm uniqueness", LCMTest checkLCM_uniqueness),+ ("lcm idempotence", LCMTest checkLCM_idempotence),+ ("lcm identity (left)", LCMTest checkLCM_identity_left),+ ("lcm identity (right)", LCMTest checkLCM_identity_right),+ ("lcm commutativity", LCMTest checkLCM_commutativity),+ ("lcm associativity", LCMTest checkLCM_associativity),+ ("lcm absorption (gcd-lcm)", LCMTest checkLCM_absorption_gcd_lcm),+ ("lcm absorption (lcm-gcd)", LCMTest checkLCM_absorption_lcm_gcd),+ ("lcm distributivity (left)", DistributiveLCMTest checkLCM_distributivity_left),+ ("lcm distributivity (right)", DistributiveLCMTest checkLCM_distributivity_right),+ ("lcm distributivity (gcd-lcm)", DistributiveLCMTest checkLCM_distributivity_gcd_lcm),+ ("lcm distributivity (lcm-gcd)", DistributiveLCMTest checkLCM_distributivity_lcm_gcd) ] checkCommutative (CommutativeMonoidInstance (e :: a)) = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> a <> b == b <> a)@@ -421,7 +727,7 @@ checkNull (NullMonoidInstance (e :: a)) = null e .&&. forAll (arbitrary :: Gen a) (\a-> null a == (a == mempty)) checkPositive (PositiveMonoidInstance (_ :: a)) =- forAll (arbitrary :: Gen (a, a)) (\(a, b)-> null a && null b || not (null (a <> b)))+ forAll (arbitrary :: Gen (a, a)) (\(a, b)-> null a && null b || not (null (mappend a b))) checkConcatFactors (FactorialMonoidInstance (e :: a)) = null (factors e) .&&. forAll (arbitrary :: Gen a) check where check a = mconcat (factors a) == a@@ -429,16 +735,16 @@ checkFactorsOfFactors (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (all singleton . factors) where singleton prime = factors prime == [prime] -checkSplitPrimePrefix (FactorialMonoidInstance (_ :: a)) = +checkSplitPrimePrefix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> factors a == unfoldr splitPrimePrefix a) checkSplitPrimeSuffix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = factors a == reverse (unfoldr (fmap swap . splitPrimeSuffix) a) -checkPrimePrefix (FactorialMonoidInstance (_ :: a)) = +checkPrimePrefix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> primePrefix a == maybe mempty fst (splitPrimePrefix a)) -checkPrimeSuffix (FactorialMonoidInstance (_ :: a)) = +checkPrimeSuffix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> primeSuffix a == maybe mempty snd (splitPrimeSuffix a)) checkInits (FactorialMonoidInstance (_ :: a)) =@@ -447,16 +753,16 @@ checkTails (FactorialMonoidInstance (_ :: a)) = mapSize (`div` 5) $ forAll (arbitrary :: Gen a) (\a-> tails a == List.map mconcat (List.tails $ factors a)) -checkLeftFold (FactorialMonoidInstance (_ :: a)) = +checkLeftFold (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldl (flip (:)) [] a == List.foldl (flip (:)) [] (factors a)) -checkLeftFold' (FactorialMonoidInstance (_ :: a)) = +checkLeftFold' (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldl' (flip (:)) [] a == List.foldl' (flip (:)) [] (factors a)) -checkRightFold (FactorialMonoidInstance (_ :: a)) = +checkRightFold (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldr (:) [] a == List.foldr (:) [] (factors a)) -checkLength (FactorialMonoidInstance (_ :: a)) = +checkLength (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> length a == List.length (factors a)) checkSpan (FactorialMonoidInstance (_ :: a)) = property $ \p-> forAll (arbitrary :: Gen a) (check p)@@ -479,19 +785,19 @@ where check i a = splitAt i a == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors a) -checkReverse (FactorialMonoidInstance (_ :: a)) = +checkReverse (FactorialMonoidInstance (_ :: a)) = property $ forAll (arbitrary :: Gen a) (\a-> reverse a == mconcat (List.reverse $ factors a)) checkStability (StableFactorialMonoidInstance (_ :: a)) = property $ forAll (arbitrary :: Gen (a, a)) (\(a, b)-> factors (a <> b) == factors a <> factors b) -checkFromText (TextualMonoidInstance (_ :: a)) = +checkFromText (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen Text) (\t-> Textual.fromText t == (fromString (Text.unpack t) :: a)) -checkSingleton (TextualMonoidInstance (_ :: a)) = +checkSingleton (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen Char) (\c-> Textual.singleton c == (fromString [c] :: a)) -checkSplitCharacterPrefix (TextualMonoidInstance (_ :: a)) = +checkSplitCharacterPrefix (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen String) check1 .&&. forAll (arbitrary :: Gen a) check2 where check1 s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s check2 t = Textual.splitCharacterPrefix (primePrefix t)@@ -509,13 +815,16 @@ checkFactorsFromString (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen String) check where check s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s -checkTextualMap (TextualMonoidInstance (_ :: a)) = +checkTextualMap (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2- where check1 a = Textual.map succ a == Textual.concatMap (Textual.singleton . succ) a+ where check1 a = Textual.map wrapSucc a == Textual.concatMap (Textual.singleton . wrapSucc) a && Textual.map id a == a- check2 s = Textual.map succ (fromString s :: a) == fromString (List.map succ s)+ check2 s = Textual.map wrapSucc (fromString s :: a) == fromString (List.map wrapSucc s)+ wrapSucc c+ | c == maxBound = minBound+ | otherwise = succ c -checkConcatMap (TextualMonoidInstance (_ :: a)) = +checkConcatMap (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.concatMap (fromString . f) a == mconcat (map apply $ factors a) && Textual.concatMap Textual.singleton a == a@@ -529,19 +838,19 @@ checkAny (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.any isLetter a == Textual.foldr (const id) ((||) . isLetter) False a -checkTextualFoldl (TextualMonoidInstance (_ :: a)) = +checkTextualFoldl (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl (\l a-> Left a : l) (\l c-> Right c : l) [] a == List.reverse (textualFactors a) && Textual.foldl (<>) (\a-> (a <>) . Textual.singleton) mempty a == a check2 s = Textual.foldl undefined (flip (:)) [] s == List.foldl (flip (:)) [] s -checkTextualFoldr (TextualMonoidInstance (_ :: a)) = +checkTextualFoldr (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldr (\a l-> Left a : l) (\c l-> Right c : l) [] a == textualFactors a && Textual.foldr (<>) ((<>) . Textual.singleton) mempty a == a check2 s = Textual.foldr undefined (:) [] (fromString s :: a) == s -checkTextualFoldl' (TextualMonoidInstance (_ :: a)) = +checkTextualFoldl' (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl' (\l a-> Left a : l) (\l c-> Right c : l) [] a == List.reverse (textualFactors a) && Textual.foldl' (<>) (\a-> (a <>) . Textual.singleton) mempty a == a@@ -595,34 +904,39 @@ where check1 a = forAll arbitrary $ \f-> Textual.toString f a == Textual.foldr (\t s-> f t ++ s) (:) "" a check2 s = Textual.toString undefined (fromString s :: a) == s -checkTextualMapAccumL (TextualMonoidInstance (_ :: a)) = +checkToText (TextualMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen Text) check2+ where check1 a = forAll arbitrary $ \f-> Textual.toText f a == Textual.foldr (\t s-> f t <> s) Text.cons Text.empty a+ check2 s = Textual.toText undefined (Textual.fromText s :: a) == s++checkTextualMapAccumL (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumL (,)) ((), a) == ((), a) check2 s = Textual.mapAccumL f c (fromString s :: a) == fmap fromString (List.mapAccumL f c s) c = 0 :: Int f n c = if isLetter c then (succ n, succ c) else (2*n, c) -checkTextualMapAccumR (TextualMonoidInstance (_ :: a)) = +checkTextualMapAccumR (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumR (,)) ((), a) == ((), a) check2 s = Textual.mapAccumR f c (fromString s :: a) == fmap fromString (List.mapAccumR f c s) c = 0 :: Int f n c = if isLetter c then (succ n, succ c) else (2*n, c) -checkTextualTakeWhile (TextualMonoidInstance (_ :: a)) = +checkTextualTakeWhile (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.takeWhile (const True) isLetter a) == List.takeWhile (either (const True) isLetter) (textualFactors a) && Textual.takeWhile (const True) (const True) a == a check2 s = Textual.takeWhile undefined isLetter (fromString s :: a) == fromString (List.takeWhile isLetter s) -checkTextualDropWhile (TextualMonoidInstance (_ :: a)) = +checkTextualDropWhile (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.dropWhile (const True) isLetter a) == List.dropWhile (either (const True) isLetter) (textualFactors a) && Textual.dropWhile (const False) (const False) a == a- check2 s = Textual.dropWhile undefined isLetter (fromString s :: a)- == fromString (List.dropWhile isLetter s)+ check2 s = Textual.toString undefined (Textual.dropWhile undefined isLetter (fromString s :: a))+ == List.dropWhile isLetter s checkTextualSpan (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.span pt pc a == (Textual.takeWhile pt pc a, Textual.dropWhile pt pc a)@@ -669,26 +983,26 @@ foldMaybe = Textual.foldl_' gc (Just s0) gc s c = s >>= flip fc c -checkTextualTakeWhile_ (TextualMonoidInstance (_ :: a)) = +checkTextualTakeWhile_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.takeWhile_ True isLetter a) == List.takeWhile (either (const True) isLetter) (textualFactors a) && Textual.takeWhile_ True (const True) a == a check2 s = Textual.takeWhile_ undefined isLetter (fromString s :: a) == fromString (List.takeWhile isLetter s) -checkTextualDropWhile_ (TextualMonoidInstance (_ :: a)) = +checkTextualDropWhile_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.dropWhile_ True isLetter a) == List.dropWhile (either (const True) isLetter) (textualFactors a) && Textual.dropWhile_ False (const False) a == a- check2 s = Textual.dropWhile_ undefined isLetter (fromString s :: a)- == fromString (List.dropWhile isLetter s)+ check2 s = Textual.toString undefined (Textual.dropWhile_ undefined isLetter (fromString s :: a))+ == List.dropWhile isLetter s checkTextualSplit (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = List.all (List.all isLetter . rights . textualFactors) (Textual.split (not . isLetter) a) && (mconcat . intersperse (fromString " ") . Textual.split (== ' ')) a == a -checkTextualFind (TextualMonoidInstance (_ :: a)) = +checkTextualFind (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.find isLetter a == (List.find isLetter . rights . textualFactors) a check2 s = Textual.find isLetter (fromString s :: a) == List.find isLetter s@@ -711,6 +1025,52 @@ where check (a, b) = maybe a (b <>) (a </> b) == a && maybe a (<> b) (a </> b) == a +checkOverlapLaw1 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check+ where check (a, b) = stripOverlap a b == (stripSuffixOverlap b a, overlap a b, stripPrefixOverlap a b)++checkOverlapLaw2 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check+ where check (a, b) = stripSuffixOverlap b a <> overlap a b == a++checkOverlapLaw3 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check+ where check (a, b) = overlap a b <> stripPrefixOverlap a b == b++checkOverlap_idempotence (OverlappingGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $ \a -> overlap a a === a++checkOverlap_identity_left (OverlappingGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $ \a -> overlap mempty a === mempty++checkOverlap_identity_right (OverlappingGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $ \a -> overlap a mempty === mempty++checkStripPrefixOverlap1 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check+ where check (a, b) = o `isSuffixOf` b && b `isSuffixOf` (a <> o)+ where o = stripPrefixOverlap a b++checkStripPrefixOverlap2 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check+ where check (ap, o, bs) = b `isSuffixOf` (a <> b') && b' `isSuffixOf` bs+ where a = ap <> o+ b = o <> bs+ b' = stripPrefixOverlap a b++checkStripPrefixOverlap3 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check+ where check (a, b) = all (\(_, s)-> null s || not (b `isSuffixOf` (a <> s))) (splitPrimePrefix b')+ where b' = stripPrefixOverlap a b++checkStripSuffixOverlap1 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check+ where check (a, b) = o `isPrefixOf` a && a `isPrefixOf` (o <> b)+ where o = stripSuffixOverlap b a++checkStripSuffixOverlap2 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check+ where check (ap, o, bs) = a `isPrefixOf` (a' <> b) && a' `isPrefixOf` ap+ where a = ap <> o+ b = o <> bs+ a' = stripSuffixOverlap b a++checkStripSuffixOverlap3 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check+ where check (a, b) = all (\(p, _)-> null p || not (a `isPrefixOf` (p <> b))) (splitPrimeSuffix a')+ where a' = stripSuffixOverlap b a+ checkStripPrefix' (LeftCancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripPrefix a (a <> b) == Just b @@ -731,6 +1091,16 @@ where check (a, b) = p == commonPrefix a b && p <> a' == a && p <> b' == b where (p, a', b') = stripCommonPrefix a b +checkStripCommonPrefix3 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check+ where check (p, as, bs) = p `isPrefixOf` commonPrefix a b+ where a = p <> as+ b = p <> bs++checkStripCommonPrefix4 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check+ where check (p, a, b) = not (c /= c' && c' `isPrefixOf` a && c' `isPrefixOf` b)+ where c = commonPrefix a b+ c' = p <> c+ checkStripCommonSuffix1 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripCommonSuffix a b == (a', b', s) where s = commonSuffix a b@@ -741,6 +1111,16 @@ where check (a, b) = s == commonSuffix a b && a' <> s == a && b' <> s == b where (a', b', s) = stripCommonSuffix a b +checkStripCommonSuffix3 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check+ where check (ap, bp, s) = s `isSuffixOf` commonSuffix a b+ where a = ap <> s+ b = bp <> s++checkStripCommonSuffix4 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check+ where check (a, b, s) = not (c /= c' && c' `isSuffixOf` a && c' `isSuffixOf` b)+ where c = commonSuffix a b+ c' = c <> s+ checkGCD (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = d == commonPrefix a b && d == commonSuffix a b@@ -748,20 +1128,236 @@ && isJust (b </> d) where d = gcd a b -checkCancellativeGCD (CancellativeGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check- where check (a, b, c) = commonPrefix (a <> b) (a <> c) == a <> (commonPrefix b c)- && commonSuffix (a <> c) (b <> c) == (commonSuffix a b) <> c- && gcd (a <> b) (a <> c) == a <> gcd b c- && gcd (a <> c) (b <> c) == gcd a b <> c+checkGCD_uniqueness+ (GCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) $+ \(a, b, c) ->+ all isJust [a </> c, b </> c, c </> gcd a b] === (gcd a b == c) +checkGCD_idempotence+ (GCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $+ \a -> gcd a a === a++checkGCD_identity_left+ (GCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $+ \a -> gcd mempty a === mempty++checkGCD_identity_right+ (GCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $+ \a -> gcd a mempty === mempty++checkGCD_commutativity+ (GCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) $+ \a b -> gcd a b === gcd b a++checkGCD_associativity+ (GCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) $+ \a b c -> gcd a (gcd b c) === gcd (gcd a b) c++checkGCD_distributivity_left+ (DistributiveGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) $+ \(a, b, c) -> gcd (a <> b) (a <> c) == a <> gcd b c++checkGCD_distributivity_right+ (DistributiveGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) $+ \(a, b, c) -> gcd (a <> c) (b <> c) == gcd a b <> c++checkCommonPrefix_idempotence+ (LeftGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $+ \a -> commonPrefix a a === a++checkCommonPrefix_identity_left+ (LeftGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $+ \a -> commonPrefix mempty a === mempty++checkCommonPrefix_identity_right+ (LeftGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $+ \a -> commonPrefix a mempty === mempty++checkCommonPrefix_commutativity+ (LeftGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) $+ \a b -> commonPrefix a b === commonPrefix b a++checkCommonPrefix_associativity+ (LeftGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) $+ \a b c ->+ (commonPrefix a (commonPrefix b c)) ===+ (commonPrefix (commonPrefix a b) c)++checkCommonPrefix_distributivity+ (LeftDistributiveGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) $+ \(a, b, c) -> commonPrefix (a <> b) (a <> c) == a <> commonPrefix b c++checkCommonSuffix_idempotence+ (RightGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $+ \a -> commonSuffix a a === a++checkCommonSuffix_identity_left+ (RightGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $+ \a -> commonSuffix mempty a === mempty++checkCommonSuffix_identity_right+ (RightGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) $+ \a -> commonSuffix a mempty === mempty++checkCommonSuffix_commutativity+ (RightGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) $+ \a b -> commonSuffix a b === commonSuffix b a++checkCommonSuffix_associativity+ (RightGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) $+ \a b c ->+ (commonSuffix a (commonSuffix b c)) ===+ (commonSuffix (commonSuffix a b) c)++checkCommonSuffix_distributivity+ (RightDistributiveGCDMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) $+ \(a, b, c) -> commonSuffix (a <> c) (b <> c) == commonSuffix a b <> c++checkLCM_reductivity_left (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) check+ where+ check a b = isJust (lcm a b </> a)++checkLCM_reductivity_right (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) check+ where+ check a b = isJust (lcm a b </> b)++checkLCM_uniqueness (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) check+ where+ check a b c =+ all isJust [c </> a, c </> b, lcm a b </> c] === (lcm a b == c)++checkLCM_idempotence (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) check+ where+ check a = lcm a a === a++checkLCM_identity_left (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) check+ where+ check a = lcm mempty a === a++checkLCM_identity_right (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) check+ where+ check a = lcm a mempty === a++checkLCM_commutativity (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) check+ where+ check a b = lcm a b === lcm b a++checkLCM_associativity (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) check+ where+ check a b c = lcm (lcm a b) c === lcm a (lcm b c)++checkLCM_absorption_gcd_lcm (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) check+ where+ check a b = lcm a (gcd a b) === a++checkLCM_absorption_lcm_gcd (LCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) check+ where+ check a b = gcd a (lcm a b) === a++checkLCM_distributivity_left (DistributiveLCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) check+ where+ check a b c = lcm (a <> b) (a <> c) === a <> lcm b c++checkLCM_distributivity_right (DistributiveLCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) check+ where+ check a b c = lcm (a <> c) (b <> c) === lcm a b <> c++checkLCM_distributivity_gcd_lcm (DistributiveLCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) check+ where+ check a b c = lcm a (gcd b c) === gcd (lcm a b) (lcm a c)++checkLCM_distributivity_lcm_gcd (DistributiveLCMMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) check+ where+ check a b c = gcd a (lcm b c) === lcm (gcd a b) (gcd a c)++checkMonus_identity_1 (MonusInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) check+ where+ check a = a <\> a === mempty++checkMonus_identity_2 (MonusInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) check+ where+ check a = mempty <\> a === mempty++checkMonus_mappend_1 (MonusInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) check+ where+ check a b = a <> (b <\> a) === b <> (a <\> b)++checkMonus_mappend_2 (MonusInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a, a)) check+ where+ check (a, b, c) = (a <\> b) <\> c === a <\> (b <> c)++checkMonus_stripPrefixOverlap (MonusInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) check+ where+ check (a, b) = (a <\> b) === stripPrefixOverlap b a++checkMonus_stripSuffixOverlap (MonusInstance (_ :: a)) =+ forAll (arbitrary :: Gen (a, a)) check+ where+ check (a, b) = (a <\> b) === stripSuffixOverlap b a+ textualFactors :: TextualMonoid t => t -> [Either t Char] textualFactors = map characterize . factors where characterize prime = maybe (Left prime) Right (Textual.characterPrefix prime) -newtype TestString = TestString String deriving (Eq, Show, Arbitrary, CoArbitrary, Semigroup,- Monoid, LeftReductiveMonoid, LeftCancellativeMonoid, LeftGCDMonoid,- MonoidNull, PositiveMonoid, StableFactorialMonoid, IsString)+newtype TestString = TestString String deriving (Eq, Show, Arbitrary, CoArbitrary,+ Semigroup, LeftReductive, LeftCancellative, StableFactorial,+ Monoid, LeftGCDMonoid,+ MonoidNull, PositiveMonoid, IsString) +newtype TestOffsetPositionedString = TestOffsetPositionedString (OffsetPositioned String)+ deriving (Show, Arbitrary, CoArbitrary,+ Semigroup, LeftReductive,+ Monoid, LeftGCDMonoid,+ MonoidNull, PositiveMonoid, IsString)++newtype TestLinePositionedString = TestLinePositionedString (LinePositioned String)+ deriving (Show, Arbitrary, CoArbitrary,+ Semigroup, LeftReductive,+ Monoid, LeftGCDMonoid,+ MonoidNull, PositiveMonoid, IsString)++instance Factorial TestString where+ factors (TestString s) = TestString <$> factors s+ instance FactorialMonoid TestString where splitPrimePrefix (TestString []) = Nothing splitPrimePrefix (TestString (x:xs)) = Just (TestString [x], TestString xs)@@ -770,6 +1366,35 @@ splitCharacterPrefix (TestString []) = Nothing splitCharacterPrefix (TestString (x:xs)) = Just (x, TestString xs) +instance Eq TestOffsetPositionedString where+ TestOffsetPositionedString a == TestOffsetPositionedString b =+ a == b && Positioned.position a == Positioned.position b++instance Factorial TestOffsetPositionedString where+ factors (TestOffsetPositionedString s) = TestOffsetPositionedString <$> factors s++instance FactorialMonoid TestOffsetPositionedString where+ splitPrimePrefix (TestOffsetPositionedString s) = rewrap <$> splitPrimePrefix s+ where rewrap (x, xs) = (TestOffsetPositionedString x, TestOffsetPositionedString xs)++instance TextualMonoid TestOffsetPositionedString where+ splitCharacterPrefix (TestOffsetPositionedString x) = (TestOffsetPositionedString <$>) <$> Textual.splitCharacterPrefix x++instance Eq TestLinePositionedString where+ TestLinePositionedString a == TestLinePositionedString b =+ a == b && Positioned.line a == Positioned.line b && Positioned.column a == Positioned.column b+ && Positioned.position a == Positioned.position b++instance Factorial TestLinePositionedString where+ factors (TestLinePositionedString s) = TestLinePositionedString <$> factors s++instance FactorialMonoid TestLinePositionedString where+ splitPrimePrefix (TestLinePositionedString s) = rewrap <$> splitPrimePrefix s+ where rewrap (x, xs) = (TestLinePositionedString x, TestLinePositionedString xs)++instance TextualMonoid TestLinePositionedString where+ splitCharacterPrefix (TestLinePositionedString x) = (TestLinePositionedString <$>) <$> Textual.splitCharacterPrefix x+ instance Arbitrary ByteStringUTF8 where arbitrary = fmap ByteStringUTF8 arbitrary @@ -779,6 +1404,9 @@ instance (Arbitrary a, FactorialMonoid a) => Arbitrary (Measured a) where arbitrary = fmap Measured.measure arbitrary +instance (Arbitrary a, Monoid a) => Arbitrary (PrefixMemory.Shadowed a) where+ arbitrary = fmap PrefixMemory.shadowed arbitrary+ instance (Arbitrary a, FactorialMonoid a) => Arbitrary (OffsetPositioned a) where arbitrary = fmap pure arbitrary @@ -796,6 +1424,9 @@ instance CoArbitrary a => CoArbitrary (Measured a) where coarbitrary = coarbitrary . Measured.extract++instance CoArbitrary a => CoArbitrary (PrefixMemory.Shadowed a) where+ coarbitrary = coarbitrary . PrefixMemory.content instance CoArbitrary a => CoArbitrary (OffsetPositioned a) where coarbitrary = coarbitrary . Positioned.extract
monoid-subclasses.cabal view
@@ -1,17 +1,30 @@ Name: monoid-subclasses-Version: 0.4.6.1+Version: 1.2.6.1 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid Category: Data, Algebra, Text-Tested-with: GHC+Tested-with: GHC==8.0.2+ , GHC==8.2.2+ , GHC==8.4.4+ , GHC==8.6.5+ , GHC==8.8.4+ , GHC==8.10.7+ , GHC==9.0.2+ , GHC==9.2.8+ , GHC==9.4.8+ , GHC==9.6.6+ , GHC==9.8.4+ , GHC==9.10.1+ , GHC==9.12.1+ Description: A hierarchy of subclasses of 'Monoid' together with their instances for all data structures from base, containers, and text packages.- + License: BSD3 License-file: BSD3-LICENSE.txt-Copyright: (c) 2013-2018 Mario Blažević+Copyright: (c) 2013-2024 Mario Blažević Author: Mario Blažević Maintainer: Mario Blažević <blamario@protonmail.com> Homepage: https://github.com/blamario/monoid-subclasses/@@ -22,21 +35,39 @@ location: https://github.com/blamario/monoid-subclasses Library- Exposed-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual,- Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat,- Data.Monoid.Instances.Measured, Data.Monoid.Instances.Positioned, Data.Monoid.Instances.Stateful+ hs-source-dirs: src+ Exposed-Modules:+ Data.Monoid.Cancellative+ , Data.Monoid.Factorial+ , Data.Monoid.GCD+ , Data.Monoid.Instances.ByteString.UTF8+ , Data.Monoid.Instances.CharVector+ , Data.Monoid.Instances.Concat+ , Data.Monoid.Instances.Measured+ , Data.Monoid.Instances.Positioned+ , Data.Monoid.Instances.PrefixMemory+ , Data.Monoid.Instances.Stateful+ , Data.Monoid.LCM+ , Data.Monoid.Monus+ , Data.Monoid.Null+ , Data.Monoid.Textual+ , Data.Semigroup.Cancellative+ , Data.Semigroup.Factorial Build-Depends: base >= 4.9 && < 5,- bytestring >= 0.9 && < 1.0, containers >= 0.5.7.0 && < 0.7, text >= 0.11 && < 1.3,- primes == 0.2.*, vector >= 0.9 && < 0.13+ bytestring >= 0.9 && < 1.0,+ containers >= 0.5.7.0 && < 0.9,+ text >= 0.11 && < 1.3 || >= 2.0 && < 2.2,+ primes == 0.2.*,+ vector >= 0.12 && < 0.14,+ commutative-semigroups >= 0.1 && < 0.3 GHC-options: -Wall default-language: Haskell2010 test-suite Main Type: exitcode-stdio-1.0 Build-Depends: base >= 4.9 && < 5,- bytestring >= 0.9 && < 1.0, containers >= 0.5.7.0 && < 0.7, text >= 0.11 && < 1.3,- vector >= 0.9 && < 0.13, primes == 0.2.*,- QuickCheck >= 2.9 && < 3, quickcheck-instances >= 0.3.12 && <0.4,+ bytestring, containers, text, vector, primes,+ QuickCheck >= 2.9 && < 3, quickcheck-instances >= 0.3.12 && <0.5, tasty >= 0.7, tasty-quickcheck >= 0.7 && < 1.0, monoid-subclasses Main-is: Test/TestMonoidSubclasses.hs
+ src/Data/Monoid/Cancellative.hs view
@@ -0,0 +1,57 @@+{- + Copyright 2013-2019 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'Monoid' => 'CommutativeMonoid' => 'ReductiveMonoid' => 'CancellativeMonoid' constraint+-- synonym hierarchy.+--+-- Since most practical monoids in Haskell are not commutative, the last two of these synonyms have two symmetric+-- superclasses each:+-- +-- * 'LeftReductiveMonoid'+-- +-- * 'LeftCancellativeMonoid'+-- +-- * 'RightReductiveMonoid'+-- +-- * 'RightCancellativeMonoid'+--+-- This module and its constraint synonyms are provided for compatibility with the older versions of the+-- @monoid-sublasses@ library. Starting with version 1.0, the classes from the "Data.Semigroup.Cancellative" module+-- are recommended instead.++{-# LANGUAGE Haskell2010, ConstraintKinds, FlexibleInstances #-}++module Data.Monoid.Cancellative {- from 1.1 DEPRECATED "Use \"Data.Semigroup.Cancellative\" and \"Data.Monoid.GCD\" instead" -} (+ module Data.Semigroup.Cancellative,+ module Data.Monoid.GCD,+ -- * Symmetric, commutative monoid classes+ CommutativeMonoid, ReductiveMonoid, CancellativeMonoid,+ -- * Asymmetric monoid classes+ LeftReductiveMonoid, RightReductiveMonoid,+ LeftCancellativeMonoid, RightCancellativeMonoid+ )+where++import Data.Monoid (Monoid)++import Data.Semigroup.Cancellative+import Data.Monoid.GCD++{- from 1.1-}+{- DEPRECATED CommutativeMonoid "Use Data.Semigroup.Cancellative.Commutative instead." -}+{- DEPRECATED ReductiveMonoid "Use Data.Semigroup.Cancellative.Reductive instead." -}+{- DEPRECATED LeftReductiveMonoid "Use Data.Semigroup.Cancellative.LeftReductive instead." -}+{- DEPRECATED RightReductiveMonoid "Use Data.Semigroup.Cancellative.RightReductive instead." -}+{- DEPRECATED CancellativeMonoid "Use Data.Semigroup.Cancellative.Cancellative instead." -}+{- DEPRECATED LeftCancellativeMonoid "Use Data.Semigroup.Cancellative.LeftCancellative instead." -}+{- DEPRECATED RightCancellativeMonoid "Use Data.Semigroup.Cancellative.RightCancellative instead." -}+type CommutativeMonoid m = (Monoid m, Commutative m)+type ReductiveMonoid m = (Monoid m, Reductive m)+type LeftReductiveMonoid m = (Monoid m, LeftReductive m)+type RightReductiveMonoid m = (Monoid m, RightReductive m)+type CancellativeMonoid m = (Monoid m, Cancellative m)+type LeftCancellativeMonoid m = (Monoid m, LeftCancellative m)+type RightCancellativeMonoid m = (Monoid m, RightCancellative m)
+ src/Data/Monoid/Factorial.hs view
@@ -0,0 +1,559 @@+{-+ Copyright 2013-2017 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'FactorialMonoid' class and some of its instances.+--++{-# LANGUAGE Haskell2010, ConstraintKinds, FlexibleInstances, Trustworthy #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.Monoid.Factorial (+ module Data.Semigroup.Factorial,+ FactorialMonoid(..), StableFactorialMonoid,+ )+where++import Control.Arrow (first)+import Data.Functor.Const (Const (Const))+import Data.Functor.Identity (Identity (Identity))+import Data.Monoid -- (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo))+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LazyText+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Sequence as Sequence+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import Data.Int (Int64)++import Data.Semigroup.Factorial+import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)++import Prelude hiding (break, drop, dropWhile, foldl, foldr, last, length, map, max, min,+ null, reverse, span, splitAt, take, takeWhile)+++-- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Note that+-- 'mempty' is not considered a factor. Factors of a 'Product' are literally its prime factors:+--+-- prop> factors (Product 12) == [Product 2, Product 2, Product 3]+--+-- Factors of a list are /not/ its elements but all its single-item sublists:+--+-- prop> factors "abc" == ["a", "b", "c"]+--+-- The methods of this class satisfy the following laws in addition to those of 'Factorial':+--+-- > null == List.null . factors+-- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix)+-- > reverse == mconcat . List.reverse . factors+-- > primePrefix == maybe mempty fst . splitPrimePrefix+-- > primeSuffix == maybe mempty snd . splitPrimeSuffix+-- > inits == List.map mconcat . List.inits . factors+-- > tails == List.map mconcat . List.tails . factors+-- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m)+-- > List.all (List.all (not . pred) . factors) . split pred+-- > mconcat . intersperse prime . split (== prime) == id+-- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m)+-- > spanMaybe () (const $ bool Nothing (Maybe ()) . p) m == (takeWhile p m, dropWhile p m, ())+-- > spanMaybe s0 (\s m-> Just $ f s m) m0 == (m0, mempty, foldl f s0 m0)+-- > let (prefix, suffix, s') = spanMaybe s f m+-- > foldMaybe = foldl g (Just s)+-- > g s m = s >>= flip f m+-- > in all ((Nothing ==) . foldMaybe) (inits prefix)+-- > && prefix == last (filter (isJust . foldMaybe) $ inits m)+-- > && Just s' == foldMaybe prefix+-- > && m == prefix <> suffix+--+-- A minimal instance definition should implement 'splitPrimePrefix' for performance reasons, and other methods where+-- beneficial.+class (Factorial m, MonoidNull m) => FactorialMonoid m where+ -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'.+ splitPrimePrefix :: m -> Maybe (m, m)+ -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'.+ splitPrimeSuffix :: m -> Maybe (m, m)+ -- | Returns the list of all prefixes of the argument, 'mempty' first.+ inits :: m -> [m]+ -- | Returns the list of all suffixes of the argument, 'mempty' last.+ tails :: m -> [m]+ -- | Like 'List.span' from "Data.List" on the list of prime 'factors'.+ span :: (m -> Bool) -> m -> (m, m)+ -- | Equivalent to 'List.break' from "Data.List".+ break :: (m -> Bool) -> m -> (m, m)+ -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes+ -- satisfying the predicate are not a part of the result.+ split :: (m -> Bool) -> m -> [m]+ -- | Equivalent to 'List.takeWhile' from "Data.List".+ takeWhile :: (m -> Bool) -> m -> m+ -- | Equivalent to 'List.dropWhile' from "Data.List".+ dropWhile :: (m -> Bool) -> m -> m+ -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'.+ spanMaybe :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)+ -- | Strict version of 'spanMaybe'.+ spanMaybe' :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)+ -- | Like 'List.splitAt' from "Data.List" on the list of prime 'factors'.+ splitAt :: Int -> m -> (m, m)+ -- | Equivalent to 'List.drop' from "Data.List".+ drop :: Int -> m -> m+ -- | Equivalent to 'List.take' from "Data.List".+ take :: Int -> m -> m++ splitPrimePrefix x = case factors x+ of [] -> Nothing+ prefix : rest -> Just (prefix, mconcat rest)+ splitPrimeSuffix x = case factors x+ of [] -> Nothing+ fs -> Just (mconcat (List.init fs), List.last fs)+ inits = foldr (\m l-> mempty : List.map (mappend m) l) [mempty]+ tails m = m : maybe [] (tails . snd) (splitPrimePrefix m)+ span p m0 = spanAfter id m0+ where spanAfter f m = case splitPrimePrefix m+ of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest+ _ -> (f mempty, m)+ break = span . (not .)+ spanMaybe s0 f m0 = spanAfter id s0 m0+ where spanAfter g s m = case splitPrimePrefix m+ of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest+ | otherwise -> (g mempty, m, s)+ Nothing -> (m0, m, s)+ spanMaybe' s0 f m0 = spanAfter id s0 m0+ where spanAfter g s m = seq s $+ case splitPrimePrefix m+ of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest+ | otherwise -> (g mempty, m, s)+ Nothing -> (m0, m, s)+ split p m = prefix : splitRest+ where (prefix, rest) = break p m+ splitRest = case splitPrimePrefix rest+ of Nothing -> []+ Just (_, tl) -> split p tl+ takeWhile p = fst . span p+ dropWhile p = snd . span p+ splitAt n0 m0 | n0 <= 0 = (mempty, m0)+ | otherwise = split' n0 id m0+ where split' 0 f m = (f mempty, m)+ split' n f m = case splitPrimePrefix m+ of Nothing -> (f mempty, m)+ Just (prime, rest) -> split' (pred n) (f . mappend prime) rest+ drop n p = snd (splitAt n p)+ take n p = fst (splitAt n p)+ {-# MINIMAL #-}+ {-# INLINABLE splitPrimePrefix #-}+ {-# INLINABLE splitPrimeSuffix #-}+ {-# INLINABLE inits #-}+ {-# INLINABLE tails #-}+ {-# INLINABLE span #-}+ {-# INLINE break #-}+ {-# INLINABLE spanMaybe #-}+ {-# INLINABLE spanMaybe' #-}+ {-# INLINABLE split #-}+ {-# INLINE takeWhile #-}+ {-# INLINE dropWhile #-}+ {-# INLINABLE splitAt #-}++{-# DEPRECATED StableFactorialMonoid "Use Data.Semigroup.Factorial.StableFactorial instead." #-}+type StableFactorialMonoid m = (StableFactorial m, FactorialMonoid m, PositiveMonoid m)++instance FactorialMonoid () where+ splitPrimePrefix () = Nothing+ splitPrimeSuffix () = Nothing++deriving instance FactorialMonoid a => FactorialMonoid (Identity a)++deriving instance FactorialMonoid a => FactorialMonoid (Const a b)++instance FactorialMonoid a => FactorialMonoid (Dual a) where+ splitPrimePrefix (Dual a) = case splitPrimeSuffix a+ of Nothing -> Nothing+ Just (p, s) -> Just (Dual s, Dual p)+ splitPrimeSuffix (Dual a) = case splitPrimePrefix a+ of Nothing -> Nothing+ Just (p, s) -> Just (Dual s, Dual p)+ inits (Dual a) = fmap Dual (reverse $ tails a)+ tails (Dual a) = fmap Dual (reverse $ inits a)++instance (Integral a, Eq a) => FactorialMonoid (Sum a) where+ splitPrimePrefix (Sum 0) = Nothing+ splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a))+ splitPrimeSuffix (Sum 0) = Nothing+ splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a))++instance Integral a => FactorialMonoid (Product a)++instance FactorialMonoid a => FactorialMonoid (Maybe a) where+ splitPrimePrefix Nothing = Nothing+ splitPrimePrefix (Just a) = case splitPrimePrefix a+ of Nothing -> Just (Just a, Nothing)+ Just (p, s) -> Just (Just p, if null s then Nothing else Just s)+++instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where+ splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b)+ of (Just (ap, as), _) -> Just ((ap, mempty), (as, b))+ (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs))+ (Nothing, Nothing) -> Nothing+ splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b)+ of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs))+ (Just (ap, as), Nothing) -> Just ((ap, b), (as, b))+ (Nothing, Nothing) -> Nothing+ inits (a, b) = List.map (flip (,) mempty) (inits a) ++ List.map ((,) a) (List.tail $ inits b)+ tails (a, b) = List.map (flip (,) b) (tails a) ++ List.map ((,) mempty) (List.tail $ tails b)+ span p (x, y) = ((xp, yp), (xs, ys))+ where (xp, xs) = span (p . fromFst) x+ (yp, ys) | null xs = span (p . fromSnd) y+ | otherwise = (mempty, y)+ spanMaybe s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)+ | otherwise = ((xp, mempty), (xs, y), s1)+ where (xp, xs, s1) = spanMaybe s0 (\s-> f s . fromFst) x+ (yp, ys, s2) = spanMaybe s1 (\s-> f s . fromSnd) y+ spanMaybe' s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)+ | otherwise = ((xp, mempty), (xs, y), s1)+ where (xp, xs, s1) = spanMaybe' s0 (\s-> f s . fromFst) x+ (yp, ys, s2) = spanMaybe' s1 (\s-> f s . fromSnd) y+ split p (x0, y0) = fst $ List.foldr combine (ys, False) xs+ where xs = List.map fromFst $ split (p . fromFst) x0+ ys = List.map fromSnd $ split (p . fromSnd) y0+ combine x (~(y:rest), False) = (mappend x y : rest, True)+ combine x (rest, True) = (x:rest, True)+ splitAt n (x, y) = ((xp, yp), (xs, ys))+ where (xp, xs) = splitAt n x+ (yp, ys) | null xs = splitAt (n - length x) y+ | otherwise = (mempty, y)++{-# INLINE fromFst #-}+fromFst :: Monoid b => a -> (a, b)+fromFst a = (a, mempty)++{-# INLINE fromSnd #-}+fromSnd :: Monoid a => b -> (a, b)+fromSnd b = (mempty, b)++instance (FactorialMonoid a, FactorialMonoid b, FactorialMonoid c) => FactorialMonoid (a, b, c) where+ 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)+ 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)++{-# 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+ 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)+ 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)++{-# 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+ splitPrimePrefix [] = Nothing+ splitPrimePrefix (x:xs) = Just ([x], xs)+ splitPrimeSuffix [] = Nothing+ splitPrimeSuffix xs = Just (splitLast id xs)+ where splitLast f last@[_] = (f [], last)+ splitLast f ~(x:rest) = splitLast (f . (x:)) rest+ inits = List.inits+ tails = List.tails+ break f = List.break (f . (:[]))+ span f = List.span (f . (:[]))+ dropWhile f = List.dropWhile (f . (:[]))+ takeWhile f = List.takeWhile (f . (:[]))+ spanMaybe s0 f l = (prefix' [], suffix' [], s')+ where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l+ g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = (prefix . (x:), id, s2, True)+ | otherwise = (prefix, suffix . (x:), s1, False)+ spanMaybe' s0 f l = (prefix' [], suffix' [], s')+ where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l+ g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = seq s2 $ (prefix . (x:), id, s2, True)+ | otherwise = (prefix, suffix . (x:), s1, False)+ splitAt = List.splitAt+ drop = List.drop+ take = List.take++instance FactorialMonoid ByteString.ByteString where+ splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x)+ splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x)+ inits = ByteString.inits+ tails = ByteString.tails+ break f = ByteString.break (f . ByteString.singleton)+ span f = ByteString.span (f . ByteString.singleton)+ spanMaybe s0 f b = case ByteString.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')+ where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f b = case ByteString.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')+ 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')+ | otherwise = (i, s)+ dropWhile f = ByteString.dropWhile (f . ByteString.singleton)+ takeWhile f = ByteString.takeWhile (f . ByteString.singleton)+ split f = ByteString.splitWith f'+ where f' = f . ByteString.singleton+ splitAt = ByteString.splitAt+ drop = ByteString.drop+ take = ByteString.take++instance FactorialMonoid LazyByteString.ByteString where+ splitPrimePrefix x = if LazyByteString.null x then Nothing+ else Just (LazyByteString.splitAt 1 x)+ splitPrimeSuffix x = if LazyByteString.null x then Nothing+ else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x)+ inits = LazyByteString.inits+ tails = LazyByteString.tails+ break f = LazyByteString.break (f . LazyByteString.singleton)+ span f = LazyByteString.span (f . LazyByteString.singleton)+ spanMaybe s0 f b = case LazyByteString.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')+ where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f b = case LazyByteString.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')+ where g w cont (i, s)+ | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')+ | otherwise = (i, s)+ dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton)+ takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton)+ split f = LazyByteString.splitWith f'+ where f' = f . LazyByteString.singleton+ splitAt = LazyByteString.splitAt . fromIntegral+ drop n = LazyByteString.drop (fromIntegral n)+ take n = LazyByteString.take (fromIntegral n)++instance FactorialMonoid Text.Text where+ splitPrimePrefix = fmap (first Text.singleton) . Text.uncons+ splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x))+ inits = Text.inits+ tails = Text.tails+ span f = Text.span (f . Text.singleton)+ break f = Text.break (f . Text.singleton)+ dropWhile f = Text.dropWhile (f . Text.singleton)+ takeWhile f = Text.takeWhile (f . Text.singleton)+ spanMaybe s0 f t = case Text.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f t = case Text.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')+ 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')+ | otherwise = (i, s)+ split f = Text.split f'+ where f' = f . Text.singleton+ splitAt = Text.splitAt+ drop = Text.drop+ take = Text.take++instance FactorialMonoid LazyText.Text where+ splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons+ splitPrimeSuffix x = if LazyText.null x+ then Nothing+ else Just (LazyText.init x, LazyText.singleton (LazyText.last x))+ inits = LazyText.inits+ tails = LazyText.tails+ span f = LazyText.span (f . LazyText.singleton)+ break f = LazyText.break (f . LazyText.singleton)+ dropWhile f = LazyText.dropWhile (f . LazyText.singleton)+ takeWhile f = LazyText.takeWhile (f . LazyText.singleton)+ spanMaybe s0 f t = case LazyText.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f t = case LazyText.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')+ 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')+ | otherwise = (i, s)+ split f = LazyText.split f'+ where f' = f . LazyText.singleton+ splitAt = LazyText.splitAt . fromIntegral+ drop n = LazyText.drop (fromIntegral n)+ take n = LazyText.take (fromIntegral n)++instance Ord k => FactorialMonoid (Map.Map k v) where+ splitPrimePrefix = fmap singularize . Map.minViewWithKey+ where singularize ((k, v), rest) = (Map.singleton k v, rest)+ splitPrimeSuffix = fmap singularize . Map.maxViewWithKey+ where singularize ((k, v), rest) = (rest, Map.singleton k v)++instance FactorialMonoid (IntMap.IntMap a) where+ splitPrimePrefix = fmap singularize . IntMap.minViewWithKey+ where singularize ((k, v), rest) = (IntMap.singleton k v, rest)+ splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey+ where singularize ((k, v), rest) = (rest, IntMap.singleton k v)++instance FactorialMonoid IntSet.IntSet where+ splitPrimePrefix = fmap singularize . IntSet.minView+ where singularize (min, rest) = (IntSet.singleton min, rest)+ splitPrimeSuffix = fmap singularize . IntSet.maxView+ where singularize (max, rest) = (rest, IntSet.singleton max)++instance FactorialMonoid (Sequence.Seq a) where+ splitPrimePrefix q = case Sequence.viewl q+ of Sequence.EmptyL -> Nothing+ hd Sequence.:< rest -> Just (Sequence.singleton hd, rest)+ splitPrimeSuffix q = case Sequence.viewr q+ of Sequence.EmptyR -> Nothing+ rest Sequence.:> last -> Just (rest, Sequence.singleton last)+ inits = Foldable.toList . Sequence.inits+ tails = Foldable.toList . Sequence.tails+ span f = Sequence.spanl (f . Sequence.singleton)+ break f = Sequence.breakl (f . Sequence.singleton)+ dropWhile f = Sequence.dropWhileL (f . Sequence.singleton)+ takeWhile f = Sequence.takeWhileL (f . Sequence.singleton)+ spanMaybe s0 f b = case Foldable.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')+ where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f b = case Foldable.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')+ 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')+ | otherwise = (i, s)+ splitAt = Sequence.splitAt+ drop = Sequence.drop+ take = Sequence.take++instance Ord a => FactorialMonoid (Set.Set a) where+ splitPrimePrefix = fmap singularize . Set.minView+ where singularize (min, rest) = (Set.singleton min, rest)+ splitPrimeSuffix = fmap singularize . Set.maxView+ where singularize (max, rest) = (rest, Set.singleton max)++instance FactorialMonoid (Vector.Vector a) where+ splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x)+ splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x)+ inits x0 = initsWith x0 []+ where initsWith x rest | Vector.null x = x:rest+ | otherwise = initsWith (Vector.unsafeInit x) (x:rest)+ tails x = x : if Vector.null x then [] else tails (Vector.unsafeTail x)+ break f = Vector.break (f . Vector.singleton)+ span f = Vector.span (f . Vector.singleton)+ dropWhile f = Vector.dropWhile (f . Vector.singleton)+ takeWhile f = Vector.takeWhile (f . Vector.singleton)+ spanMaybe s0 f v = case Vector.ifoldr g Left v s0+ of Left s' -> (v, Vector.empty, s')+ Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')+ where g i x cont s | Just s' <- f s (Vector.singleton x) = cont s'+ | otherwise = Right (i, s)+ spanMaybe' s0 f v = case Vector.ifoldr' g Left v s0+ of Left s' -> (v, Vector.empty, s')+ Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')+ where g i x cont s | Just s' <- f s (Vector.singleton x) = seq s' (cont s')+ | otherwise = Right (i, s)+ splitAt = Vector.splitAt+ drop = Vector.drop+ take = Vector.take
+ src/Data/Monoid/GCD.hs view
@@ -0,0 +1,714 @@+{-+ Copyright 2013-2019 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'GCDMonoid' subclass of the 'Monoid' class.+--+-- The 'GCDMonoid' subclass adds the 'gcd' operation which takes two monoidal arguments and finds their greatest+-- common divisor, or (more generally) the greatest monoid that can be extracted with the '</>' operation from both.+--+-- The 'GCDMonoid' class is for Abelian, /i.e./, 'Commutative' monoids.+--+-- == Non-commutative GCD monoids+--+-- Since most practical monoids in Haskell are not Abelian, the 'GCDMonoid'+-- class has three symmetric superclasses:+--+-- * 'LeftGCDMonoid'+--+-- Class of monoids for which it is possible to find the greatest common+-- /prefix/ of two monoidal values.+--+-- * 'RightGCDMonoid'+--+-- Class of monoids for which it is possible to find the greatest common+-- /suffix/ of two monoidal values.+--+-- * 'OverlappingGCDMonoid'+--+-- Class of monoids for which it is possible to find the greatest common+-- /overlap/ of two monoidal values.+--+-- == Distributive GCD monoids+--+-- Since some (but not all) GCD monoids are also distributive, there are three+-- subclasses that add distributivity:+--+-- * 'DistributiveGCDMonoid'+--+-- Subclass of 'GCDMonoid' with /symmetric/ distributivity.+--+-- * 'LeftDistributiveGCDMonoid'+--+-- Subclass of 'LeftGCDMonoid' with /left/-distributivity.+--+-- * 'RightDistributiveGCDMonoid'+--+-- Subclass of 'RightGCDMonoid' with /right/-distributivity.+--+{-# LANGUAGE CPP, Haskell2010, FlexibleInstances, Trustworthy #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.Monoid.GCD+ ( GCDMonoid (..)+ , LeftGCDMonoid (..)+ , RightGCDMonoid (..)+ , OverlappingGCDMonoid (..)+ , DistributiveGCDMonoid+ , LeftDistributiveGCDMonoid+ , RightDistributiveGCDMonoid+ )+ where++import qualified Prelude++import Data.Functor.Const (Const (Const))+import Data.Functor.Identity (Identity (Identity))+import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..))+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Unsafe as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TextEncoding+import qualified Data.Text.Internal as Internal+import qualified Data.Text.Internal.Lazy as LazyInternal+import Data.Text.Unsafe (reverseIter)+#if MIN_VERSION_text(2,0,0)+import Data.Text.Unsafe (Iter(..))+#endif+import qualified Data.Text.Lazy as LazyText+import qualified Data.Text.Lazy.Encoding as LazyEncoding+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Sequence as Sequence+import qualified Data.Set as Set+import Data.Sequence (ViewL((:<)), ViewR((:>)), (<|), (|>))+import qualified Data.Vector as Vector+import Numeric.Natural (Natural)++import Data.Semigroup.Cancellative+import Data.Monoid.Monus++-- These imports are marked as redundant, but are actually required by haddock:+import Data.Maybe (isJust)++import Prelude hiding (gcd)++-- | Class of Abelian monoids that allow the greatest common divisor to be found for any two given values. The+-- operations must satisfy the following laws:+--+-- > gcd a b == commonPrefix a b == commonSuffix a b+-- > Just a' = a </> p && Just b' = b </> p+-- > where p = gcd a b+--+-- In addition, the 'gcd' operation must satisfy the following properties:+--+-- __/Uniqueness/__+--+-- @+-- 'all' 'isJust'+-- [ a '</>' c+-- , b '</>' c+-- , c '</>' 'gcd' a b+-- ]+-- ==>+-- (c '==' 'gcd' a b)+-- @+--+-- __/Idempotence/__+--+-- @+-- 'gcd' a a '==' a+-- @+--+-- __/Identity/__+--+-- @+-- 'gcd' 'mempty' a '==' 'mempty'+-- @+-- @+-- 'gcd' a 'mempty' '==' 'mempty'+-- @+--+-- __/Commutativity/__+--+-- @+-- 'gcd' a b '==' 'gcd' b a+-- @+--+-- __/Associativity/__+--+-- @+-- 'gcd' ('gcd' a b) c '==' 'gcd' a ('gcd' b c)+-- @+--+class (Monoid m, Commutative m, Reductive m, LeftGCDMonoid m, RightGCDMonoid m, OverlappingGCDMonoid m) => GCDMonoid m where+ gcd :: m -> m -> m++-- | Class of monoids capable of finding the equivalent of greatest common divisor on the left side of two monoidal+-- values. The following laws must be respected:+--+-- > stripCommonPrefix a b == (p, a', b')+-- > where p = commonPrefix a b+-- > Just a' = stripPrefix p a+-- > Just b' = stripPrefix p b+-- > p == commonPrefix a b && p <> a' == a && p <> b' == b+-- > where (p, a', b') = stripCommonPrefix a b+--+-- Furthermore, 'commonPrefix' must return the unique greatest common prefix that contains, as its prefix, any other+-- prefix @x@ of both values:+--+-- > not (x `isPrefixOf` a && x `isPrefixOf` b) || x `isPrefixOf` commonPrefix a b+--+-- and it cannot itself be a suffix of any other common prefix @y@ of both values:+--+-- > not (y `isPrefixOf` a && y `isPrefixOf` b && commonPrefix a b `isSuffixOf` y)+--+-- In addition, the 'commonPrefix' operation must satisfy the following+-- properties:+--+-- __/Idempotence/__+--+-- @+-- 'commonPrefix' a a '==' a+-- @+--+-- __/Identity/__+--+-- @+-- 'commonPrefix' 'mempty' a '==' 'mempty'+-- @+-- @+-- 'commonPrefix' a 'mempty' '==' 'mempty'+-- @+--+-- __/Commutativity/__+--+-- @+-- 'commonPrefix' a b '==' 'commonPrefix' b a+-- @+--+-- __/Associativity/__+--+-- @+-- 'commonPrefix' ('commonPrefix' a b) c+-- '=='+-- 'commonPrefix' a ('commonPrefix' b c)+-- @+--+class (Monoid m, LeftReductive m) => LeftGCDMonoid m where+ commonPrefix :: m -> m -> m+ stripCommonPrefix :: m -> m -> (m, m, m)++ commonPrefix x y = p+ where (p, _, _) = stripCommonPrefix x y+ stripCommonPrefix x y = (p, x', y')+ where p = commonPrefix x y+ Just x' = stripPrefix p x+ Just y' = stripPrefix p y+ {-# MINIMAL commonPrefix | stripCommonPrefix #-}++-- | Class of monoids capable of finding the equivalent of greatest common divisor on the right side of two monoidal+-- values. The following laws must be respected:+--+-- > stripCommonSuffix a b == (a', b', s)+-- > where s = commonSuffix a b+-- > Just a' = stripSuffix p a+-- > Just b' = stripSuffix p b+-- > s == commonSuffix a b && a' <> s == a && b' <> s == b+-- > where (a', b', s) = stripCommonSuffix a b+--+-- Furthermore, 'commonSuffix' must return the unique greatest common suffix that contains, as its suffix, any other+-- suffix @x@ of both values:+--+-- > not (x `isSuffixOf` a && x `isSuffixOf` b) || x `isSuffixOf` commonSuffix a b+--+-- and it cannot itself be a prefix of any other common suffix @y@ of both values:+--+-- > not (y `isSuffixOf` a && y `isSuffixOf` b && commonSuffix a b `isPrefixOf` y)+--+-- In addition, the 'commonSuffix' operation must satisfy the following+-- properties:+--+-- __/Idempotence/__+--+-- @+-- 'commonSuffix' a a '==' a+-- @+--+-- __/Identity/__+--+-- @+-- 'commonSuffix' 'mempty' a '==' 'mempty'+-- @+-- @+-- 'commonSuffix' a 'mempty' '==' 'mempty'+-- @+--+-- __/Commutativity/__+--+-- @+-- 'commonSuffix' a b '==' 'commonSuffix' b a+-- @+--+-- __/Associativity/__+--+-- @+-- 'commonSuffix' ('commonSuffix' a b) c+-- '=='+-- 'commonSuffix' a ('commonSuffix' b c)+-- @+--+class (Monoid m, RightReductive m) => RightGCDMonoid m where+ commonSuffix :: m -> m -> m+ stripCommonSuffix :: m -> m -> (m, m, m)++ commonSuffix x y = s+ where (_, _, s) = stripCommonSuffix x y+ stripCommonSuffix x y = (x', y', s)+ where s = commonSuffix x y+ Just x' = stripSuffix s x+ Just y' = stripSuffix s y+ {-# MINIMAL commonSuffix | stripCommonSuffix #-}++-- Unit instances++-- | /O(1)/+instance GCDMonoid () where+ gcd () () = ()++-- | /O(1)/+instance LeftGCDMonoid () where+ commonPrefix () () = ()++-- | /O(1)/+instance RightGCDMonoid () where+ commonSuffix () () = ()++-- Identity instances++deriving instance GCDMonoid a => GCDMonoid (Identity a)+deriving instance LeftGCDMonoid a => LeftGCDMonoid (Identity a)+deriving instance RightGCDMonoid a => RightGCDMonoid (Identity a)++-- Const instances++deriving instance GCDMonoid a => GCDMonoid (Const a b)+deriving instance LeftGCDMonoid a => LeftGCDMonoid (Const a b)+deriving instance RightGCDMonoid a => RightGCDMonoid (Const a b)++-- Dual instances++instance GCDMonoid a => GCDMonoid (Dual a) where+ gcd (Dual a) (Dual b) = Dual (gcd a b)++instance LeftGCDMonoid a => RightGCDMonoid (Dual a) where+ commonSuffix (Dual a) (Dual b) = Dual (commonPrefix a b)++instance RightGCDMonoid a => LeftGCDMonoid (Dual a) where+ commonPrefix (Dual a) (Dual b) = Dual (commonSuffix a b)++-- Sum instances++-- | /O(1)/+instance GCDMonoid (Sum Natural) where+ gcd (Sum a) (Sum b) = Sum (min a b)++-- | /O(1)/+instance LeftGCDMonoid (Sum Natural) where+ commonPrefix a b = gcd a b++-- | /O(1)/+instance RightGCDMonoid (Sum Natural) where+ commonSuffix a b = gcd a b++-- Product instances++-- | /O(1)/+instance GCDMonoid (Product Natural) where+ gcd (Product a) (Product b) = Product (Prelude.gcd a b)++-- | /O(1)/+instance LeftGCDMonoid (Product Natural) where+ commonPrefix a b = gcd a b++-- | /O(1)/+instance RightGCDMonoid (Product Natural) where+ commonSuffix a b = gcd a b++-- Pair instances++instance (GCDMonoid a, GCDMonoid b) => GCDMonoid (a, b) where+ gcd (a, b) (c, d) = (gcd a c, gcd b d)++instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (a, b) where+ commonPrefix (a, b) (c, d) = (commonPrefix a c, commonPrefix b d)++instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (a, b) where+ commonSuffix (a, b) (c, d) = (commonSuffix a c, commonSuffix b d)++-- Triple instances++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 (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 (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 (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 LeftGCDMonoid x => LeftGCDMonoid (Maybe x) where+ commonPrefix (Just x) (Just y) = Just (commonPrefix x y)+ commonPrefix _ _ = Nothing++ stripCommonPrefix (Just x) (Just y) = (Just p, Just x', Just y')+ where (p, x', y') = stripCommonPrefix x y+ stripCommonPrefix x y = (Nothing, x, y)++instance RightGCDMonoid x => RightGCDMonoid (Maybe x) where+ commonSuffix (Just x) (Just y) = Just (commonSuffix x y)+ commonSuffix _ _ = Nothing++ stripCommonSuffix (Just x) (Just y) = (Just x', Just y', Just s)+ where (x', y', s) = stripCommonSuffix x y+ stripCommonSuffix x y = (x, y, Nothing)++-- Set instances++-- | /O(m*log(n\/m + 1)), m <= n/+instance Ord a => LeftGCDMonoid (Set.Set a) where+ commonPrefix = Set.intersection++-- | /O(m*log(n\/m + 1)), m <= n/+instance Ord a => RightGCDMonoid (Set.Set a) where+ commonSuffix = Set.intersection++-- | /O(m*log(n\/m + 1)), m <= n/+instance Ord a => GCDMonoid (Set.Set a) where+ gcd = Set.intersection++-- IntSet instances++-- | /O(m+n)/+instance LeftGCDMonoid IntSet.IntSet where+ commonPrefix = IntSet.intersection++-- | /O(m+n)/+instance RightGCDMonoid IntSet.IntSet where+ commonSuffix = IntSet.intersection++-- | /O(m+n)/+instance GCDMonoid IntSet.IntSet where+ gcd = IntSet.intersection++-- Map instances++-- | /O(m+n)/+instance (Ord k, Eq a) => LeftGCDMonoid (Map.Map k a) where+ commonPrefix = Map.mergeWithKey (\_ a b -> if a == b then Just a else Nothing) (const Map.empty) (const Map.empty)++-- IntMap instances++-- | /O(m+n)/+instance Eq a => LeftGCDMonoid (IntMap.IntMap a) where+ commonPrefix = IntMap.mergeWithKey (\_ a b -> if a == b then Just a else Nothing)+ (const IntMap.empty) (const IntMap.empty)++-- List instances++-- | /O(prefixLength)/+instance Eq x => LeftGCDMonoid [x] where+ commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys+ commonPrefix _ _ = []++ stripCommonPrefix x0 y0 = strip' id x0 y0+ where strip' f (x:xs) (y:ys) | x == y = strip' (f . (x :)) xs ys+ strip' f x y = (f [], x, y)++-- | @since 1.0+-- /O(m+n)/+instance Eq x => RightGCDMonoid [x] where+ stripCommonSuffix x0 y0 = go1 x0 y0+ where go1 (_:xs) (_:ys) = go1 xs ys+ go1 [] [] = go2 id id id x0 y0+ go1 [] ys = go2 id yp id x0 yr+ where (yp, yr) = splitAtLengthOf id ys y0+ go1 xs [] = go2 xp id id xr y0+ where (xp, xr) = splitAtLengthOf id xs x0+ go2 xp yp cs [] [] = (xp [], yp [], cs [])+ go2 xp yp cs (x:xs) (y:ys)+ | x == y = go2 xp yp (cs . (x:)) xs ys+ | otherwise = go2 (xp . cs . (x:)) (yp . cs . (y:)) id xs ys+ go2 _ _ _ _ _ = error "impossible"+ splitAtLengthOf yp (_:xs) (y:ys) = splitAtLengthOf (yp . (y:)) xs ys+ splitAtLengthOf yp [] ys = (yp, ys)+ splitAtLengthOf _ _ _ = error "impossible"++-- Seq instances++-- | /O(prefixLength)/+instance Eq a => LeftGCDMonoid (Sequence.Seq a) where+ stripCommonPrefix = findCommonPrefix Sequence.empty+ where findCommonPrefix prefix a b = case (Sequence.viewl a, Sequence.viewl b)+ of (a1:<a', b1:<b') | a1 == b1 -> findCommonPrefix (prefix |> a1) a' b'+ _ -> (prefix, a, b)++-- | /O(suffixLength)/+instance Eq a => RightGCDMonoid (Sequence.Seq a) where+ stripCommonSuffix = findCommonSuffix Sequence.empty+ where findCommonSuffix suffix a b = case (Sequence.viewr a, Sequence.viewr b)+ of (a':>a1, b':>b1) | a1 == b1 -> findCommonSuffix (a1 <| suffix) a' b'+ _ -> (a, b, suffix)++-- Vector instances++-- | /O(prefixLength)/+instance Eq a => LeftGCDMonoid (Vector.Vector a) where+ stripCommonPrefix x y = (xp, xs, Vector.drop maxPrefixLength y)+ where maxPrefixLength = prefixLength 0 (Vector.length x `min` Vector.length y)+ prefixLength n len | n < len && x Vector.! n == y Vector.! n = prefixLength (succ n) len+ prefixLength n _ = n+ (xp, xs) = Vector.splitAt maxPrefixLength x++-- | /O(suffixLength)/+instance Eq a => RightGCDMonoid (Vector.Vector a) where+ stripCommonSuffix x y = findSuffix (Vector.length x - 1) (Vector.length y - 1)+ where findSuffix m n | m >= 0 && n >= 0 && x Vector.! m == y Vector.! n =+ findSuffix (pred m) (pred n)+ findSuffix m n = (Vector.take (succ m) x, yp, ys)+ where (yp, ys) = Vector.splitAt (succ n) y++-- ByteString instances++-- | /O(prefixLength)/+instance LeftGCDMonoid ByteString.ByteString where+ stripCommonPrefix x y = (xp, xs, ByteString.unsafeDrop maxPrefixLength y)+ where maxPrefixLength = prefixLength 0 (ByteString.length x `min` ByteString.length y)+ prefixLength n len | n < len,+ ByteString.unsafeIndex x n == ByteString.unsafeIndex y n =+ prefixLength (succ n) len+ | otherwise = n+ (xp, xs) = ByteString.splitAt maxPrefixLength x++-- | /O(suffixLength)/+instance RightGCDMonoid ByteString.ByteString where+ stripCommonSuffix x y = findSuffix (ByteString.length x - 1) (ByteString.length y - 1)+ where findSuffix m n | m >= 0, n >= 0,+ ByteString.unsafeIndex x m == ByteString.unsafeIndex y n =+ findSuffix (pred m) (pred n)+ | otherwise = let (yp, ys) = ByteString.splitAt (succ n) y+ in (ByteString.unsafeTake (succ m) x, yp, ys)++-- Lazy ByteString instances++-- | /O(prefixLength)/+instance LeftGCDMonoid LazyByteString.ByteString where+ stripCommonPrefix x y = (xp, xs, LazyByteString.drop maxPrefixLength y)+ where maxPrefixLength = prefixLength 0 (LazyByteString.length x `min` LazyByteString.length y)+ prefixLength n len | n < len && LazyByteString.index x n == LazyByteString.index y n =+ prefixLength (succ n) len+ prefixLength n _ = n+ (xp, xs) = LazyByteString.splitAt maxPrefixLength x++-- | /O(suffixLength)/+instance RightGCDMonoid LazyByteString.ByteString where+ stripCommonSuffix x y = findSuffix (LazyByteString.length x - 1) (LazyByteString.length y - 1)+ where findSuffix m n | m >= 0 && n >= 0 && LazyByteString.index x m == LazyByteString.index y n =+ findSuffix (pred m) (pred n)+ findSuffix m n = (LazyByteString.take (succ m) x, yp, ys)+ where (yp, ys) = LazyByteString.splitAt (succ n) y++-- Text instances++-- | /O(prefixLength)/+instance LeftGCDMonoid Text.Text where+ stripCommonPrefix x y = maybe (Text.empty, x, y) id (Text.commonPrefixes x y)++-- | @since 1.0+-- /O(suffixLength)/, except on GHCjs where it is /O(m+n)/+instance RightGCDMonoid Text.Text where+#if !ghcjs_HOST_OS+ stripCommonSuffix x@(Internal.Text xarr xoff xlen) y@(Internal.Text yarr yoff ylen) = go (pred xlen) (pred ylen)+ where go i j | i >= 0 && j >= 0 && xc == yc = go (i+xd) (j+yd)+ | otherwise = (Internal.text xarr xoff (succ i),+ Internal.text yarr yoff (succ j),+ Internal.text xarr (xoff+i+1) (xlen-i-1))+#if MIN_VERSION_text(2,0,0)+ where Iter xc xd = reverseIter x i+ Iter yc yd = reverseIter y j+#else+ where (xc, xd) = reverseIter x i+ (yc, yd) = reverseIter y j+#endif+#else+ stripCommonSuffix x y =+ let (xlist, ylist, slist) =+ stripCommonSuffix (TextEncoding.encodeUtf8 x) (TextEncoding.encodeUtf8 y)+ in (TextEncoding.decodeUtf8 xlist, TextEncoding.decodeUtf8 ylist, TextEncoding.decodeUtf8 slist)+#endif++-- Lazy Text instances++-- | /O(prefixLength)/+instance LeftGCDMonoid LazyText.Text where+ stripCommonPrefix x y = maybe (LazyText.empty, x, y) id (LazyText.commonPrefixes x y)++-- | @since 1.0+-- /O(m+n)/+instance RightGCDMonoid LazyText.Text where+#if !ghcjs_HOST_OS+ stripCommonSuffix x0 y0+ | x0len < y0len = go id y0p id x0 y0s+ | x0len > y0len = go x0p id id x0s y0+ | otherwise = go id id id x0 y0+ where (y0p, y0s) = splitWord16 id (y0len - x0len) y0+ (x0p, x0s) = splitWord16 id (x0len - y0len) x0+ x0len = lazyLengthWord16 x0+ y0len = lazyLengthWord16 y0+ lazyLengthWord16 = LazyText.foldlChunks addLength 0+ addLength n x = n + (\(Internal.Text _ _ l) -> l) x+ splitWord16 xp 0 x = (xp, x)+ splitWord16 xp n (LazyInternal.Chunk x@(Internal.Text arr off len) xs)+ | n < len = (xp . LazyInternal.chunk (Internal.Text arr off n),+ LazyInternal.chunk (Internal.Text arr (off+n) (len-n)) xs)+ | otherwise = splitWord16 (xp . LazyInternal.chunk x) (n - len) xs+ splitWord16 _ _ LazyInternal.Empty = error "impossible"+ go xp yp cs LazyInternal.Empty LazyInternal.Empty = (xp mempty, yp mempty, cs mempty)+ go xp yp cs (LazyInternal.Chunk x@(Internal.Text xarr xoff xlen) xs)+ (LazyInternal.Chunk y@(Internal.Text yarr yoff ylen) ys)+ | xlen < ylen = go xp yp cs (LazyInternal.Chunk x xs)+ (LazyInternal.Chunk (Internal.Text yarr yoff xlen) $+ LazyInternal.Chunk (Internal.Text yarr (yoff+xlen) (ylen-xlen)) ys)+ | xlen > ylen = go xp yp cs (LazyInternal.Chunk (Internal.Text xarr xoff ylen) $+ LazyInternal.Chunk (Internal.Text xarr (xoff+ylen) (xlen-ylen)) xs)+ (LazyInternal.Chunk y ys)+ | x == y = go xp yp (cs . LazyInternal.chunk x) xs ys+ | (x1p, y1p, c1s) <- stripCommonSuffix x y =+ go (xp . cs . LazyInternal.chunk x1p) (yp . cs . LazyInternal.chunk y1p) (LazyInternal.chunk c1s) xs ys+ go _ _ _ _ _ = error "impossible"+#else+ stripCommonSuffix x y =+ let (xlist, ylist, slist) =+ stripCommonSuffix (LazyEncoding.encodeUtf8 x) (LazyEncoding.encodeUtf8 y)+ in (LazyEncoding.decodeUtf8 xlist, LazyEncoding.decodeUtf8 ylist, LazyEncoding.decodeUtf8 slist)+#endif++--------------------------------------------------------------------------------+-- DistributiveGCDMonoid+--------------------------------------------------------------------------------++-- | Class of /commutative/ GCD monoids with /symmetric/ distributivity.+--+-- In addition to the general 'GCDMonoid' laws, instances of this class+-- must also satisfy the following laws:+--+-- @+-- 'gcd' (a '<>' b) (a '<>' c) '==' a '<>' 'gcd' b c+-- @+-- @+-- 'gcd' (a '<>' c) (b '<>' c) '==' 'gcd' a b '<>' c+-- @+--+class (LeftDistributiveGCDMonoid m, RightDistributiveGCDMonoid m, GCDMonoid m)+ => DistributiveGCDMonoid m++instance DistributiveGCDMonoid ()+instance DistributiveGCDMonoid a => DistributiveGCDMonoid (Identity a)+instance DistributiveGCDMonoid a => DistributiveGCDMonoid (Const a b)+instance DistributiveGCDMonoid (Product Natural)+instance DistributiveGCDMonoid (Sum Natural)+instance DistributiveGCDMonoid IntSet.IntSet+instance DistributiveGCDMonoid a => DistributiveGCDMonoid (Dual a)+instance Ord a => DistributiveGCDMonoid (Set.Set a)++-------------------------------------------------------------------------------+-- LeftDistributiveGCDMonoid+--------------------------------------------------------------------------------++-- | Class of /left/ GCD monoids with /left/-distributivity.+--+-- In addition to the general 'LeftGCDMonoid' laws, instances of this class+-- must also satisfy the following law:+--+-- @+-- 'commonPrefix' (a '<>' b) (a '<>' c) '==' a '<>' 'commonPrefix' b c+-- @+--+class LeftGCDMonoid m => LeftDistributiveGCDMonoid m++-- Instances for non-commutative monoids:+instance Eq a => LeftDistributiveGCDMonoid [a]+instance Eq a => LeftDistributiveGCDMonoid (Sequence.Seq a)+instance Eq a => LeftDistributiveGCDMonoid (Vector.Vector a)+instance LeftDistributiveGCDMonoid ByteString.ByteString+instance LeftDistributiveGCDMonoid LazyByteString.ByteString+instance LeftDistributiveGCDMonoid Text.Text+instance LeftDistributiveGCDMonoid LazyText.Text++-- Instances for commutative monoids:+instance LeftDistributiveGCDMonoid ()+instance LeftDistributiveGCDMonoid (Product Natural)+instance LeftDistributiveGCDMonoid (Sum Natural)+instance LeftDistributiveGCDMonoid IntSet.IntSet+instance Ord a => LeftDistributiveGCDMonoid (Set.Set a)++-- Instances for monoid transformers:+instance LeftDistributiveGCDMonoid a => LeftDistributiveGCDMonoid (Identity a)+instance LeftDistributiveGCDMonoid a => LeftDistributiveGCDMonoid (Const a b)+instance RightDistributiveGCDMonoid a => LeftDistributiveGCDMonoid (Dual a)++--------------------------------------------------------------------------------+-- RightDistributiveGCDMonoid+--------------------------------------------------------------------------------++-- | Class of /right/ GCD monoids with /right/-distributivity.+--+-- In addition to the general 'RightGCDMonoid' laws, instances of this class+-- must also satisfy the following law:+--+-- @+-- 'commonSuffix' (a '<>' c) (b '<>' c) '==' 'commonSuffix' a b '<>' c+-- @+--+class RightGCDMonoid m => RightDistributiveGCDMonoid m++-- Instances for non-commutative monoids:+instance Eq a => RightDistributiveGCDMonoid [a]+instance Eq a => RightDistributiveGCDMonoid (Sequence.Seq a)+instance Eq a => RightDistributiveGCDMonoid (Vector.Vector a)+instance RightDistributiveGCDMonoid ByteString.ByteString+instance RightDistributiveGCDMonoid LazyByteString.ByteString+instance RightDistributiveGCDMonoid Text.Text+instance RightDistributiveGCDMonoid LazyText.Text++-- Instances for commutative monoids:+instance RightDistributiveGCDMonoid ()+instance RightDistributiveGCDMonoid (Product Natural)+instance RightDistributiveGCDMonoid (Sum Natural)+instance RightDistributiveGCDMonoid IntSet.IntSet+instance Ord a => RightDistributiveGCDMonoid (Set.Set a)++-- Instances for monoid transformers:+instance RightDistributiveGCDMonoid a => RightDistributiveGCDMonoid (Identity a)+instance RightDistributiveGCDMonoid a => RightDistributiveGCDMonoid (Const a b)+instance LeftDistributiveGCDMonoid a => RightDistributiveGCDMonoid (Dual a)
+ src/Data/Monoid/Instances/ByteString/UTF8.hs view
@@ -0,0 +1,512 @@+{- + Copyright 2013-2022 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'ByteStringUTF8' newtype wrapper around 'ByteString', together with its 'TextualMonoid'+-- instance. The 'FactorialMonoid' instance of a wrapped 'ByteStringUTF8' value differs from the original 'ByteString':+-- the prime 'factors' of the original value are its bytes, and for the wrapped value the prime 'factors' are its valid+-- UTF8 byte sequences. The following example session demonstrates the relationship:+-- +-- >> let utf8@(ByteStringUTF8 bs) = fromString "E=mc\xb2"+-- >> bs+-- >"E=mc\194\178"+-- >> factors bs+-- >["E","=","m","c","\194","\178"]+-- >> utf8+-- >"E=mc²"+-- >> factors utf8+-- >["E","=","m","c","²"]+--+-- The 'TextualMonoid' instance follows the same logic, but it also decodes all valid UTF8 sequences into+-- characters. Any invalid UTF8 byte sequence from the original 'ByteString' is preserved as a single prime factor:+--+-- >> let utf8'@(ByteStringUTF8 bs') = ByteStringUTF8 (Data.ByteString.map pred bs)+-- >> bs'+-- >"D<lb\193\177"+-- >> factors bs'+-- >["D","<","l","b","\193","\177"]+-- >> utf8'+-- >"D<lb\[193,177]"+-- >> factors utf8'+-- >["D","<","l","b","\[193,177]"]++{-# LANGUAGE Haskell2010, DeriveDataTypeable #-}++module Data.Monoid.Instances.ByteString.UTF8 (+ ByteStringUTF8(..), decode+ )+where++import Control.Exception (assert)+import Data.Bits ((.&.), (.|.), shiftL, shiftR)+import Data.Char (chr, ord, isDigit, isPrint)+import Data.Data (Data, Typeable)+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.String (IsString(fromString))+import Data.Word (Word8)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as ByteString.Char8+import Data.ByteString.Internal (w2c)+import Data.ByteString.Unsafe (unsafeDrop, unsafeHead, unsafeTail, unsafeTake, unsafeIndex)+import Data.Text (pack, unpack)+import Data.Text.Encoding (decodeUtf8', encodeUtf8)++import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(..))+import Data.Semigroup.Cancellative (LeftReductive(..), LeftCancellative)+import Data.Semigroup.Factorial (Factorial(..))+import Data.Monoid.GCD (LeftGCDMonoid(..))+import Data.Monoid.Null (MonoidNull(..), PositiveMonoid)+import Data.Monoid.Factorial (FactorialMonoid(..))+import Data.Monoid.Textual (TextualMonoid(..))+import qualified Data.Monoid.Factorial as Factorial (FactorialMonoid(..))+import qualified Data.Monoid.Textual as Textual (TextualMonoid(..))++import Prelude hiding (any, drop, dropWhile, foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1,+ map, concatMap, break, span)++newtype ByteStringUTF8 = ByteStringUTF8 ByteString deriving (Data, Eq, Ord, Typeable)++-- | Takes a raw 'ByteString' chunk and returns a pair of 'ByteStringUTF8' decoding the prefix of the chunk and the+-- remaining suffix that is either null or contains the incomplete last character of the chunk.+decode :: ByteString -> (ByteStringUTF8, ByteString)+decode bs+ | ByteString.null bs || l < 0x80 = (ByteStringUTF8 bs, mempty)+ | l >= 0xC0 = (ByteStringUTF8 (ByteString.init bs), ByteString.singleton l)+ | ByteString.null prefix = (mempty, bs)+ | otherwise =+ case toChar (ByteString.last prefix) suffix+ of Nothing -> (ByteStringUTF8 (ByteString.init prefix), drop (ByteString.length prefix - 1) bs)+ Just{} -> (ByteStringUTF8 bs, mempty)+ where (prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs+ l = ByteString.last bs++-- | O(n)+instance Semigroup ByteStringUTF8 where+ ByteStringUTF8 a <> ByteStringUTF8 b = ByteStringUTF8 (a <> b)+ {-# INLINE (<>) #-}++-- | O(n)+instance Monoid ByteStringUTF8 where+ mempty = ByteStringUTF8 ByteString.empty+ {-# INLINE mempty #-}+ mappend = (<>)+ {-# INLINE mappend #-}++-- | O(1)+instance MonoidNull ByteStringUTF8 where+ null (ByteStringUTF8 b) = ByteString.null b+ {-# INLINE null #-}++-- | O(n)+instance LeftReductive ByteStringUTF8 where+ stripPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = fmap ByteStringUTF8 (stripPrefix a b)+ {-# INLINE stripPrefix #-}+ ByteStringUTF8 a `isPrefixOf` ByteStringUTF8 b = a `isPrefixOf` b+ {-# INLINE isPrefixOf #-}++instance LeftCancellative ByteStringUTF8++-- | O(prefixLength)+instance LeftGCDMonoid ByteStringUTF8 where+ commonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = ByteStringUTF8 (commonPrefix a b)+ {-# INLINE commonPrefix #-}+ stripCommonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = wrapTriple (stripCommonPrefix a b)+ {-# INLINE stripCommonPrefix #-}++instance Show ByteStringUTF8 where+ showsPrec _ bs s0 = '"' : Textual.foldr showsBytes showsChar ('"' : s0) bs+ where showsBytes (ByteStringUTF8 b) s = '\\' : shows (ByteString.unpack b) s+ showsChar c s+ | isPrint c = c : s+ | h:_ <- s, isDigit h = "\\" ++ show (ord c) ++ "\\&" ++ s+ | otherwise = "\\" ++ show (ord c) ++ s++instance IsString ByteStringUTF8 where+ fromString = ByteStringUTF8 . Foldable.foldMap fromChar+ {-# INLINE fromString #-}++instance PositiveMonoid ByteStringUTF8++instance Factorial ByteStringUTF8 where+ primePrefix utf8@(ByteStringUTF8 bs)+ | ByteString.null bs = utf8+ | unsafeHead bs < 0x80 = ByteStringUTF8 (ByteString.take 1 bs)+ | otherwise = case ByteString.findIndex byteStartsCharacter (unsafeTail bs)+ of Just i -> ByteStringUTF8 (ByteString.take (succ i) bs)+ Nothing -> utf8+ {-# INLINABLE primePrefix #-}+ factors (ByteStringUTF8 bs) = List.map ByteStringUTF8 $ ByteString.groupBy continued bs+ where continued a b = a >= 0x80 && b >= 0x80 && b < 0xC0+ {-# INLINABLE factors #-}+ length (ByteStringUTF8 bs) = fst (ByteString.foldl' count (0, False) bs)+ where count (n, high) byte | byte < 0x80 = (succ n, False)+ | byte < 0xC0 = (if high then n else succ n, True)+ | otherwise = (succ n, True)+ {-# INLINABLE length #-}+ foldl f a0 (ByteStringUTF8 bs) = List.foldl f' a0 (groupASCII bs)+ where f' a b | unsafeHead b < 0x80 = ByteString.foldl f'' a b+ | otherwise = f a (ByteStringUTF8 b)+ f'' a w = f a (ByteStringUTF8 $ ByteString.singleton w)+ {-# INLINABLE foldl #-}+ foldl' f a0 (ByteStringUTF8 bs) = List.foldl' f' a0 (groupASCII bs)+ where f' a b | unsafeHead b < 0x80 = ByteString.foldl' f'' a b+ | otherwise = f a (ByteStringUTF8 b)+ f'' a w = f a (ByteStringUTF8 $ ByteString.singleton w)+ {-# INLINABLE foldl' #-}+ foldr f a0 (ByteStringUTF8 bs) = List.foldr f' a0 (groupASCII bs)+ where f' b a | unsafeHead b < 0x80 = ByteString.foldr f'' a b+ | otherwise = f (ByteStringUTF8 b) a+ f'' w a = f (ByteStringUTF8 $ ByteString.singleton w) a+ {-# INLINABLE foldr #-}+ reverse (ByteStringUTF8 bs) =+ ByteStringUTF8 (ByteString.concat $ List.reverse $ List.map reverseASCII $ groupASCII bs)+ where reverseASCII b | unsafeHead b < 0x80 = ByteString.reverse b+ | otherwise = b+ {-# INLINABLE reverse #-}++instance FactorialMonoid ByteStringUTF8 where+ splitPrimePrefix utf8@(ByteStringUTF8 bs)+ | ByteString.null bs = Nothing+ | unsafeHead bs < 0x80 = Just (wrapPair $ ByteString.splitAt 1 bs)+ | otherwise = case ByteString.findIndex byteStartsCharacter (unsafeTail bs)+ of Just i -> Just (wrapPair $ ByteString.splitAt (succ i) bs)+ Nothing -> Just (utf8, ByteStringUTF8 $ ByteString.empty)+ {-# INLINABLE splitPrimePrefix #-}+ splitPrimeSuffix (ByteStringUTF8 bs)+ | ByteString.null bs = Nothing+ | ByteString.null prefix = Just (wrapPair splitBS)+ | not (ByteString.null suffix) && ByteString.last prefix < 0x80 = Just (wrapPair splitBS)+ | otherwise = Just (wrapPair $ ByteString.splitAt (pred $ ByteString.length prefix) bs)+ where splitBS@(prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs+ {-# INLINABLE splitPrimeSuffix #-}+ splitAt n (ByteStringUTF8 bs) = wrapPair (ByteString.splitAt (charStartIndex n bs) bs)+ {-# INLINE splitAt #-}+ take n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.take (charStartIndex n bs) bs)+ {-# INLINE take #-}+ drop n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.drop (charStartIndex n bs) bs)+ {-# INLINE drop #-}+ dropWhile p (ByteStringUTF8 bs0) = dropASCII bs0+ where dropASCII bs =+ let suffix = ByteString.dropWhile (\w-> w < 0x80 && p (ByteStringUTF8 $ ByteString.singleton w)) bs+ in if ByteString.null suffix || unsafeHead suffix < 0x80+ then ByteStringUTF8 suffix+ else dropMultiByte suffix+ dropMultiByte bs =+ let utf8 = ByteStringUTF8 bs+ in case ByteString.findIndex byteStartsCharacter (unsafeTail bs)+ of Nothing -> if p utf8 then ByteStringUTF8 ByteString.empty else utf8+ Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs+ in if p (ByteStringUTF8 hd)+ then dropASCII tl+ else utf8+ {-# INLINE dropWhile #-}+ takeWhile p utf8@(ByteStringUTF8 bs) =+ ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs+ where (ByteStringUTF8 s) = Factorial.dropWhile p utf8+ {-# INLINE takeWhile #-}+ span p utf8@(ByteStringUTF8 bs) =+ (ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs, suffix)+ where suffix@(ByteStringUTF8 s) = Factorial.dropWhile p utf8+ {-# INLINE span #-}+ break p = Factorial.span (not . p)+ {-# INLINE break #-}+ spanMaybe s0 f (ByteStringUTF8 bs0) = (ByteStringUTF8 $ ByteString.take (ByteString.length bs0 - ByteString.length dropped) bs0,+ ByteStringUTF8 dropped,+ s')+ where (dropped, s') = dropASCII s0 bs0+ dropASCII s bs =+ let suffix = ByteString.drop index bs+ (index, s1) = ByteString.foldr f8 id bs (0, s)+ f8 w cont (i, s2)+ | w < 0x80, Just s3 <- f s2 (ByteStringUTF8 $ ByteString.singleton w) =+ let i' = succ i :: Int in seq i' $ cont (i', s3)+ | otherwise = (i, s2)+ in if ByteString.null suffix || unsafeHead suffix < 0x80+ then (suffix, s1)+ else dropMultiByte s1 suffix+ dropMultiByte s bs =+ case ByteString.findIndex byteStartsCharacter (unsafeTail bs)+ of Nothing -> case f s (ByteStringUTF8 bs)+ of Just s1 -> (ByteString.empty, s1)+ Nothing -> (bs, s)+ Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs+ in case f s (ByteStringUTF8 hd)+ of Just s1 -> dropASCII s1 tl+ Nothing -> (bs, s)+ {-# INLINE spanMaybe #-}+ spanMaybe' s0 f (ByteStringUTF8 bs0) = (ByteStringUTF8 $+ ByteString.take (ByteString.length bs0 - ByteString.length dropped) bs0,+ ByteStringUTF8 dropped,+ s')+ where (dropped, s') = dropASCII s0 bs0+ dropASCII s bs =+ let suffix = ByteString.drop index bs+ (index, s1) = ByteString.foldr f8 id bs (0, s)+ f8 w cont (i, s2)+ | w < 0x80, Just s3 <- f s2 (ByteStringUTF8 $ ByteString.singleton w) =+ let i' = succ i :: Int in seq i' $ seq s3 $ cont (i', s3)+ | otherwise = (i, s)+ in if ByteString.null suffix || unsafeHead suffix < 0x80+ then (suffix, s1)+ else dropMultiByte s1 suffix+ dropMultiByte s bs =+ case ByteString.findIndex byteStartsCharacter (unsafeTail bs)+ of Nothing -> case f s (ByteStringUTF8 bs)+ of Just s1 -> seq s1 (ByteString.empty, s1)+ Nothing -> (bs, s)+ Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs+ in case f s (ByteStringUTF8 hd)+ of Just s1 -> seq s1 (dropASCII s1 tl)+ Nothing -> (bs, s)+ {-# INLINE spanMaybe' #-}++instance TextualMonoid ByteStringUTF8 where+ singleton = ByteStringUTF8 . fromChar+ {-# INLINE singleton #-}+ splitCharacterPrefix (ByteStringUTF8 bs) = ByteString.uncons bs >>= uncurry toChar+ {-# INLINE splitCharacterPrefix #-}+ foldl ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldl f (a0, []) bs+ of (a, []) -> a+ (a, acc) -> multiByte a acc+ where f (a, []) c | c < '\x80' = (fc a c, [])+ | otherwise = (a, [fromIntegral $ ord c])+ f (a, acc) c | c < '\x80' = (fc (multiByte a acc) c, [])+ | c < '\xC0' = (a, fromIntegral (ord c) : acc)+ | otherwise = (multiByte a acc, [fromIntegral $ ord c])+ multiByte a acc = reverseBytesToChar (ft a . ByteStringUTF8) (fc a) acc+ {-# INLINE foldl #-}+ foldl' ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldl' f (a0, []) bs+ of (a, []) -> a+ (a, acc) -> multiByte a acc+ where f (a, []) c | c < '\x80' = (fc a c, [])+ | otherwise = seq a (a, [fromIntegral $ ord c])+ f (a, acc) c | seq a c < '\x80' = let a' = multiByte a acc in seq a' (fc a' c, [])+ | c < '\xC0' = (a, fromIntegral (ord c) : acc)+ | otherwise = let a' = multiByte a acc in seq a' (a', [fromIntegral $ ord c])+ multiByte a acc = reverseBytesToChar (ft a . ByteStringUTF8) (fc a) acc+ {-# INLINE foldl' #-}+ foldr ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldr f (a0, []) bs+ of (a, []) -> a+ (a, acc) -> multiByte a acc+ where f c (a, []) | c < '\x80' = (fc c a, [])+ | c < '\xC0' = (a, [fromIntegral $ ord c])+ | otherwise = (ft (ByteStringUTF8 $ ByteString.Char8.singleton c) a, [])+ f c (a, acc) | c < '\x80' = (fc c (ft (ByteStringUTF8 $ ByteString.pack acc) a), [])+ | c < '\xC0' = (a, fromIntegral (ord c) : acc)+ | otherwise = (multiByte a (fromIntegral (ord c) : acc), [])+ multiByte a acc = bytesToChar ((`ft` a) . ByteStringUTF8) (`fc` a) acc+ {-# INLINE foldr #-}+ dropWhile pb pc (ByteStringUTF8 bs) = ByteStringUTF8 $ dropASCII bs+ where dropASCII rest = case ByteString.Char8.findIndex (\c-> c > '\x7f' || not (pc c)) rest+ of Nothing -> ByteString.empty+ Just j -> let rest' = unsafeDrop j rest+ in if unsafeHead rest' > 0x7f+ then dropMultiByte rest'+ else rest'+ dropMultiByte rest = case splitCharacterPrefix (ByteStringUTF8 rest)+ of Just (c, ByteStringUTF8 rest') | pc c -> dropASCII rest'+ Nothing -> let j = succ (headIndex $ drop 1 rest)+ in if pb (ByteStringUTF8 $ ByteString.take j rest)+ then dropASCII (unsafeDrop j rest)+ else rest+ _ -> rest+ {-# INLINE dropWhile #-}+ takeWhile pb pc utf8@(ByteStringUTF8 bs) =+ ByteStringUTF8 $ unsafeTake (ByteString.length bs - ByteString.length suffix) bs+ where ByteStringUTF8 suffix = Textual.dropWhile pb pc utf8+ {-# INLINE takeWhile #-}+ span pb pc utf8@(ByteStringUTF8 bs) = (ByteStringUTF8 $ unsafeTake (ByteString.length bs - ByteString.length suffix') bs, suffix)+ where suffix@(ByteStringUTF8 suffix') = Textual.dropWhile pb pc utf8+ {-# INLINE span #-}+ break pb pc = Textual.span (not . pb) (not . pc)+ {-# INLINE break #-}+ spanMaybe s0 ft fc (ByteStringUTF8 bs) =+ let inner i s+ | i < len =+ let w = unsafeIndex bs i+ in if w < 0x80+ then case fc s (w2c w)+ of Just s' -> inner (i + 1) s'+ Nothing -> done i s+ else case splitCharacterPrefix (ByteStringUTF8 $ unsafeDrop i bs)+ of Just (c, ByteStringUTF8 rest) | Just s' <- fc s c -> inner (len - ByteString.length rest) s'+ Nothing -> let j = succ (headIndex $ drop (i + 1) bs)+ in case ft s (ByteStringUTF8 $ ByteString.take j $ unsafeDrop i bs)+ of Just s' -> inner (i + j) s'+ Nothing -> done i s+ _ -> done i s+ | otherwise = done i s+ done i s = i `seq` s `seq` (ByteStringUTF8 $ unsafeTake i bs, ByteStringUTF8 $ unsafeDrop i bs, s)+ len = ByteString.length bs+ in inner 0 s0+ {-# INLINE spanMaybe #-}+ spanMaybe' s0 ft fc (ByteStringUTF8 bs) =+ let inner i s+ | i < len =+ s `seq`+ let w = unsafeIndex bs i+ in if w < 0x80+ then case fc s (w2c w)+ of Just s' -> inner (i + 1) s'+ Nothing -> done i s+ else case splitCharacterPrefix (ByteStringUTF8 $ unsafeDrop i bs)+ of Just (c, ByteStringUTF8 rest) | Just s' <- fc s c -> inner (len - ByteString.length rest) s'+ Nothing -> let j = succ (headIndex $ drop (i + 1) bs)+ in case ft s (ByteStringUTF8 $ ByteString.take j $ unsafeDrop i bs)+ of Just s' -> inner (i + j) s'+ Nothing -> done i s+ _ -> done i s+ | otherwise = done i s+ done i s = i `seq` s `seq` (ByteStringUTF8 $ unsafeTake i bs, ByteStringUTF8 $ unsafeDrop i bs, s)+ len = ByteString.length bs+ in inner 0 s0+ {-# INLINE spanMaybe' #-}+ find p (ByteStringUTF8 bs0) = loop bs0+ where loop bs = case ByteString.Char8.findIndex (\c-> c >= '\x80' || p c) bs+ of Nothing -> Nothing+ Just i -> let x = unsafeIndex bs i+ bs' = unsafeDrop (i + 1) bs+ in if x < 0x80+ then Just (w2c x)+ else case toChar x bs'+ of Just (c, ByteStringUTF8 rest) | p c -> Just c+ | otherwise -> loop rest+ Nothing -> loop (ByteString.dropWhile (not . byteStartsCharacter) bs')+ {-# INLINE find #-}+ any p utf8 = isJust (find p utf8)+ {-# INLINE any #-}+ all p utf8 = isNothing (find (not . p) utf8)+ {-# INLINE all #-}+ elem c utf8@(ByteStringUTF8 bs)+ | c < '\x80' = ByteString.Char8.elem c bs+ | otherwise = any (== c) utf8+ {-# INLINE elem #-}+ fromText = ByteStringUTF8 . encodeUtf8+ toText f t@(ByteStringUTF8 bs) = either (const $ pack $ toString (unpack . f) t) id (decodeUtf8' bs)++reverseBytesToChar :: (ByteString -> a) -> (Char -> a) -> [Word8] -> a+reverseBytesToChar ft fc [w] = if w < 0x80 then fc (w2c w) else ft (ByteString.singleton w)+reverseBytesToChar ft fc [b0, b1] =+ assert (0x80 <= b0 && b0 < 0xC0) $+ if 0xC2 <= b1 && b1 < 0xE0+ then fc (chr (shiftL (fromIntegral b1 .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F))+ else ft (ByteString.pack [b1, b0])+reverseBytesToChar ft fc [b0, b1, b2] =+ assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0) $+ if (0xE0 < b2 || 0xE0 == b2 && 0xA0 <= b1) && b2 < 0xF0+ then fc (chr (shiftL (fromIntegral b2 .&. 0xF) 12+ .|. shiftL (fromIntegral b1 .&. 0x3F) 6+ .|. fromIntegral b0 .&. 0x3F))+ else ft (ByteString.pack [b2, b1, b0])+reverseBytesToChar ft fc [b0, b1, b2, b3] =+ assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0 && 0x80 <= b2 && b2 < 0xC0) $+ if (0xF0 < b3 || 0xF0 == b3 && 0x90 <= b2) && b3 < 0xF5 && (b3 < 0xF4 || b2 < 0x90)+ then fc (chr (shiftL (fromIntegral b3 .&. 0x7) 18+ .|. shiftL (fromIntegral b2 .&. 0x3F) 12+ .|. shiftL (fromIntegral b1 .&. 0x3F) 6+ .|. fromIntegral b0 .&. 0x3F))+ else ft (ByteString.pack [b3, b2, b1, b0])+reverseBytesToChar ft _fc bytes = ft (ByteString.reverse $ ByteString.pack bytes)++bytesToChar :: (ByteString -> a) -> (Char -> a) -> [Word8] -> a+bytesToChar ft fc [w] = if w < 0x80 then fc (w2c w) else ft (ByteString.singleton w)+bytesToChar ft fc bytes@[b1, b0] =+ assert (0x80 <= b0 && b0 < 0xC0) $+ if 0xC2 <= b1 && b1 < 0xE0+ then fc (chr (shiftL (fromIntegral b1 .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F))+ else ft (ByteString.pack bytes)+bytesToChar ft fc bytes@[b2, b1, b0] =+ assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0) $+ if (0xE0 < b2 || 0xE0 == b2 && 0xA0 <= b1) && b2 < 0xF0+ then fc (chr (shiftL (fromIntegral b2 .&. 0xF) 12+ .|. shiftL (fromIntegral b1 .&. 0x3F) 6+ .|. fromIntegral b0 .&. 0x3F))+ else ft (ByteString.pack bytes)+bytesToChar ft fc bytes@[b3, b2, b1, b0] =+ assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0 && 0x80 <= b2 && b2 < 0xC0) $+ if (0xF0 < b3 || 0xF0 == b3 && 0x90 <= b2) && b3 < 0xF5 && (b3 < 0xF4 || b2 < 0x90)+ then fc (chr (shiftL (fromIntegral b3 .&. 0x7) 18+ .|. shiftL (fromIntegral b2 .&. 0x3F) 12+ .|. shiftL (fromIntegral b1 .&. 0x3F) 6+ .|. fromIntegral b0 .&. 0x3F))+ else ft (ByteString.pack bytes)+bytesToChar ft _fc bytes = ft (ByteString.pack bytes)++wrapPair :: (ByteString, ByteString) -> (ByteStringUTF8, ByteStringUTF8)+wrapPair (bs1, bs2) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2)+{-# INLINE wrapPair #-}++wrapTriple :: (ByteString, ByteString, ByteString) -> (ByteStringUTF8, ByteStringUTF8, ByteStringUTF8)+wrapTriple (bs1, bs2, bs3) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2, ByteStringUTF8 bs3)+{-# INLINE wrapTriple #-}++fromChar :: Char -> ByteString+fromChar c | c < '\x80' = ByteString.Char8.singleton c+ | c < '\x800' = ByteString.pack [0xC0 + fromIntegral (shiftR n 6),+ 0x80 + fromIntegral (n .&. 0x3F)]+ | c < '\x10000' = ByteString.pack [0xE0 + fromIntegral (shiftR n 12),+ 0x80 + fromIntegral (shiftR n 6 .&. 0x3F),+ 0x80 + fromIntegral (n .&. 0x3F)]+ | n < 0x200000 = ByteString.pack [0xF0 + fromIntegral (shiftR n 18),+ 0x80 + fromIntegral (shiftR n 12 .&. 0x3F),+ 0x80 + fromIntegral (shiftR n 6 .&. 0x3F),+ 0x80 + fromIntegral (n .&. 0x3F)]+ | otherwise = error ("Data.Char.ord '" ++ (c : "' >=0x200000"))+ where n = ord c++toChar :: Word8 -> ByteString -> Maybe (Char, ByteStringUTF8)+toChar hd tl | hd < 0x80 = Just (w2c hd, ByteStringUTF8 tl)+ | hd < 0xC2 = Nothing+ | hd < 0xE0 = do (b0, t0) <- ByteString.uncons tl+ if headIndex tl == 1+ then return (chr (shiftL (fromIntegral hd .&. 0x1F) 6+ .|. fromIntegral b0 .&. 0x3F),+ ByteStringUTF8 t0)+ else Nothing+ | hd < 0xF0 = do (b1, t1) <- ByteString.uncons tl+ (b0, t0) <- ByteString.uncons t1+ if (hd > 0xE0 || b1 >= 0xA0) && headIndex tl == 2+ then return (chr (shiftL (fromIntegral hd .&. 0xF) 12+ .|. shiftL (fromIntegral b1 .&. 0x3F) 6+ .|. fromIntegral b0 .&. 0x3F),+ ByteStringUTF8 t0)+ else Nothing+ | hd < 0xF5 = do (b2, t2) <- ByteString.uncons tl+ (b1, t1) <- ByteString.uncons t2+ (b0, t0) <- ByteString.uncons t1+ if (hd > 0xF0 || b2 >= 0x90) && (hd < 0xF4 || b2 < 0x90) && headIndex tl == 3+ then return (chr (shiftL (fromIntegral hd .&. 0x7) 18+ .|. shiftL (fromIntegral b2 .&. 0x3F) 12+ .|. shiftL (fromIntegral b1 .&. 0x3F) 6+ .|. fromIntegral b0 .&. 0x3F),+ ByteStringUTF8 t0)+ else Nothing+ | otherwise = Nothing++groupASCII :: ByteString -> [ByteString]+groupASCII = ByteString.groupBy continued+ where continued a b = (a < 0x80) == (b < 0x80) && b < 0xC0+{-# INLINE groupASCII #-}++headIndex :: ByteString -> Int+headIndex bs = fromMaybe (ByteString.length bs) $ ByteString.findIndex byteStartsCharacter bs+{-# INLINE headIndex #-}++byteStartsCharacter :: Word8 -> Bool+byteStartsCharacter b = b < 0x80 || b >= 0xC0+{-# INLINE byteStartsCharacter #-}++charStartIndex :: Int -> ByteString -> Int+charStartIndex n _ | n <= 0 = 0+charStartIndex n0 bs = ByteString.foldr count (const $ ByteString.length bs) bs (n0, False, 0)+ where count byte _ (0, high, i) | byte < 0x80 || byte >= 0xC0 || not high = i+ count byte cont (n, high, i) | byte < 0x80 = cont (pred n, False, succ i)+ | byte < 0xC0 = cont (if high then n else pred n, True, succ i)+ | otherwise = cont (pred n, True, succ i)+{-# INLINE charStartIndex #-}
+ src/Data/Monoid/Instances/CharVector.hs view
@@ -0,0 +1,90 @@+{- + Copyright 2017 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module contains orphan 'IsString' and 'TextualMonoid' instances of @Vector Char@.+-- ++{-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Monoid.Instances.CharVector where++import Data.String (IsString(fromString))+import qualified Data.Vector as Vector++import Data.Monoid.Textual (TextualMonoid(..))++instance IsString (Vector.Vector Char) where+ fromString = Vector.fromList++instance TextualMonoid (Vector.Vector Char) where+ singleton = Vector.singleton+ splitCharacterPrefix t = if Vector.null t then Nothing else Just (Vector.unsafeHead t, Vector.unsafeTail t)+ characterPrefix = (Vector.!? 0)+ map = Vector.map+ concatMap = Vector.concatMap+ toString = const Vector.toList+ any = Vector.any+ all = Vector.all++ foldl = const Vector.foldl+ foldl' = const Vector.foldl'+ foldr = const Vector.foldr++ scanl = Vector.scanl+ scanl1 f v | Vector.null v = Vector.empty+ | otherwise = Vector.scanl1 f v+ scanr = Vector.scanr+ scanr1 f v | Vector.null v = Vector.empty+ | otherwise = Vector.scanr1 f v+ mapAccumL f a0 t = (a', Vector.reverse $ Vector.fromList l')+ where (a', l') = Vector.foldl fc (a0, []) t+ fc (a, l) c = (:l) <$> f a c+ mapAccumR f a0 t = (a', Vector.fromList l')+ where (a', l') = Vector.foldr fc (a0, []) t+ fc c (a, l) = (:l) <$> f a c++ takeWhile _ = Vector.takeWhile+ dropWhile _ = Vector.dropWhile+ break _ = Vector.break+ span _ = Vector.span+ spanMaybe s0 _ft fc v = case Vector.ifoldr g Left v s0+ of Left s' -> (v, Vector.empty, s')+ Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')+ where g i c cont s | Just s' <- fc s c = cont s'+ | otherwise = Right (i, s)+ spanMaybe' s0 _ft fc v = case Vector.ifoldr' g Left v s0+ of Left s' -> (v, Vector.empty, s')+ Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')+ where g i c cont s | Just s' <- fc s c = seq s' (cont s')+ | otherwise = Right (i, s)+ find = Vector.find+ elem = Vector.elem++ {-# INLINE all #-}+ {-# INLINE any #-}+ {-# INLINE break #-}+ {-# INLINE characterPrefix #-}+ {-# INLINE concatMap #-}+ {-# INLINE dropWhile #-}+ {-# INLINE elem #-}+ {-# INLINE find #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE map #-}+ {-# INLINE mapAccumL #-}+ {-# INLINE mapAccumR #-}+ {-# INLINE scanl #-}+ {-# INLINE scanl1 #-}+ {-# INLINE scanr #-}+ {-# INLINE scanr1 #-}+ {-# INLINE singleton #-}+ {-# INLINE span #-}+ {-# INLINE spanMaybe #-}+ {-# INLINE spanMaybe' #-}+ {-# INLINE splitCharacterPrefix #-}+ {-# INLINE takeWhile #-}
+ src/Data/Monoid/Instances/Concat.hs view
@@ -0,0 +1,299 @@+{- + Copyright 2013-2022 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the monoid transformer data type 'Concat'.+-- ++{-# LANGUAGE Haskell2010, DeriveDataTypeable #-}++module Data.Monoid.Instances.Concat (+ Concat, concatenate, extract, force+ )+where++import Control.Applicative -- (Applicative(..))+import Control.Arrow (first)+import Data.Data (Data, Typeable)+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import Data.String (IsString(..))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(..), First(..), Sum(..))+import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..))+import Data.Semigroup.Factorial (Factorial(..), StableFactorial)+import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..))+import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)+import Data.Monoid.Factorial (FactorialMonoid(..))+import Data.Monoid.Textual (TextualMonoid(..))+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Data.Text as Text++import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, pi)++-- | @'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 '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).+--+data Concat a = Leaf a+ | Concat a :<> Concat a+ deriving (Data, Show, Typeable)++{-# DEPRECATED concatenate, extract "Concat is not wrapping Seq any more, don't use concatenate nor extract." #-}+concatenate :: PositiveMonoid a => Seq a -> Concat a+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 :: Semigroup a => Concat a -> a+force (Leaf x) = x+force (x :<> y) = force x <> force y++instance (Eq a, Semigroup a) => Eq (Concat a) where+ x == y = force x == force y++instance (Ord a, Semigroup a) => Ord (Concat a) where+ compare x y = compare (force x) (force y)++instance Functor Concat where+ fmap f (Leaf x) = Leaf (f x)+ fmap f (l :<> r) = fmap f l :<> fmap f r++instance Applicative Concat where+ pure = Leaf+ Leaf f <*> x = f <$> x+ (f1 :<> f2) <*> x = (f1 <*> x) :<> (f2 <*> x)++instance Foldable.Foldable Concat where+ fold (Leaf x) = x+ fold (x :<> y) = Foldable.fold x `mappend` Foldable.fold y+ foldMap f (Leaf x) = f x+ foldMap f (x :<> y) = Foldable.foldMap f x `mappend` 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 PositiveMonoid a => Semigroup (Concat a) where+ x <> y + | null x = y+ | null y = x+ | otherwise = x :<> y++instance PositiveMonoid a => Monoid (Concat a) where+ mempty = Leaf mempty+ mappend = (<>)++instance PositiveMonoid a => MonoidNull (Concat a) where+ null (Leaf x) = null x+ null _ = False++instance PositiveMonoid a => PositiveMonoid (Concat a)++instance (LeftReductive a, StableFactorial a, PositiveMonoid a) => LeftReductive (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 (RightReductive a, StableFactorial a, PositiveMonoid a) => RightReductive (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 (LeftGCDMonoid a, StableFactorial a, PositiveMonoid 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 (RightGCDMonoid a, StableFactorial a, PositiveMonoid 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 (Factorial a, PositiveMonoid a) => Factorial (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++ 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+ foldMap f = Foldable.foldMap (Factorial.foldMap (f . Leaf))+ length x = getSum $ Foldable.foldMap (Sum . length) x+ reverse (Leaf x) = Leaf (reverse x)+ reverse (x :<> y) = reverse y :<> reverse x++instance (FactorialMonoid a, PositiveMonoid a) => FactorialMonoid (Concat a) where+ 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+ 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 = 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 (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++instance (Factorial a, PositiveMonoid a) => StableFactorial (Concat a)++instance (IsString a) => IsString (Concat a) where+ fromString s = Leaf (fromString s)++instance (Eq a, TextualMonoid a, StableFactorial a, PositiveMonoid a) => TextualMonoid (Concat a) where+ 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)+ toText ft x = Text.concat (toText (ft . Leaf) <$> 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 (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 (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 = Foldable.foldr splitNext [mempty]+ where splitNext a ~(xp:xs) =+ let as = Leaf <$> Textual.split p a+ in if null xp+ then as ++ xs+ else init as ++ (last as <> xp):xs+ 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)
+ src/Data/Monoid/Instances/Measured.hs view
@@ -0,0 +1,129 @@+{- + Copyright 2013-2022 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the monoid transformer data type 'Measured'.+-- ++{-# LANGUAGE Haskell2010, DeriveDataTypeable #-}++module Data.Monoid.Instances.Measured (+ Measured, measure, extract+ )+where++import Data.Functor -- ((<$>))+import Data.Data (Data, Typeable)+import qualified Data.List as List+import Data.String (IsString(..))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(..))+import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..))+import Data.Semigroup.Factorial (Factorial(..), StableFactorial)+import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..))+import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)+import Data.Monoid.Factorial (FactorialMonoid(..))+import Data.Monoid.Textual (TextualMonoid(..))+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual++import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)++-- | @'Measured' a@ is a wrapper around the 'FactorialMonoid' @a@ that memoizes the monoid's 'length' so it becomes a+-- constant-time operation. The parameter is restricted to the 'StableFactorial' class, which guarantees that+-- @'length' (a <> b) == 'length' a + 'length' b@.++data Measured a = Measured{_measuredLength :: Int, extract :: a} deriving (Data, Eq, Show, Typeable)++-- | Create a new 'Measured' value.+measure :: Factorial a => a -> Measured a+measure x = Measured (length x) x++instance Ord a => Ord (Measured a) where+ compare (Measured _ x) (Measured _ y) = compare x y++instance StableFactorial a => Semigroup (Measured a) where+ Measured m a <> Measured n b = Measured (m + n) (a <> b)++instance (StableFactorial a, Monoid a) => Monoid (Measured a) where+ mempty = Measured 0 mempty+ mappend = (<>)++instance (StableFactorial a, Monoid a) => MonoidNull (Measured a) where+ null (Measured n _) = n == 0++instance (StableFactorial a, Monoid a) => PositiveMonoid (Measured a)++instance (LeftReductive a, StableFactorial a) => LeftReductive (Measured a) where+ stripPrefix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripPrefix x y)++instance (RightReductive a, StableFactorial a) => RightReductive (Measured a) where+ stripSuffix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripSuffix x y)++instance (LeftGCDMonoid a, StableFactorial a) => LeftGCDMonoid (Measured a) where+ commonPrefix (Measured _ x) (Measured _ y) = measure (commonPrefix x y)++instance (RightGCDMonoid a, StableFactorial a) => RightGCDMonoid (Measured a) where+ commonSuffix (Measured _ x) (Measured _ y) = measure (commonSuffix x y)++instance (StableFactorial a, MonoidNull a) => Factorial (Measured a) where+ factors (Measured _ x) = List.map (Measured 1) (factors x)+ primePrefix m@(Measured _ x) = if null x then m else Measured 1 (primePrefix x)+ primeSuffix m@(Measured _ x) = if null x then m else Measured 1 (primeSuffix x)+ foldl f a0 (Measured _ x) = Factorial.foldl g a0 x+ where g a = f a . Measured 1+ foldl' f a0 (Measured _ x) = Factorial.foldl' g a0 x+ where g a = f a . Measured 1+ foldr f a0 (Measured _ x) = Factorial.foldr g a0 x+ where g = f . Measured 1+ foldMap f (Measured _ x) = Factorial.foldMap (f . Measured 1) x+ length (Measured n _) = n+ reverse (Measured n x) = Measured n (reverse x)++instance (StableFactorial a, FactorialMonoid a) => FactorialMonoid (Measured a) where+ splitPrimePrefix (Measured n x) = case splitPrimePrefix x+ of Nothing -> Nothing+ Just (p, s) -> Just (Measured 1 p, Measured (n - 1) s)+ splitPrimeSuffix (Measured n x) = case splitPrimeSuffix x+ of Nothing -> Nothing+ Just (p, s) -> Just (Measured (n - 1) p, Measured 1 s)+ span p (Measured n x) = (xp', xs')+ where (xp, xs) = Factorial.span (p . Measured 1) x+ xp' = measure xp+ xs' = Measured (n - length xp') xs+ split p (Measured _ x) = measure <$> Factorial.split (p . Measured 1) x+ splitAt m (Measured n x) | m <= 0 = (mempty, Measured n x)+ | m >= n = (Measured n x, mempty)+ | otherwise = (Measured m xp, Measured (n - m) xs)+ where (xp, xs) = splitAt m x++instance (StableFactorial a, MonoidNull a) => StableFactorial (Measured a)++instance (FactorialMonoid a, IsString a) => IsString (Measured a) where+ fromString = measure . fromString++instance (Eq a, StableFactorial a, TextualMonoid a) => TextualMonoid (Measured a) where+ fromText = measure . fromText+ singleton = Measured 1 . singleton+ splitCharacterPrefix (Measured n x) = (Measured (n - 1) <$>) <$> splitCharacterPrefix x+ characterPrefix (Measured _ x) = characterPrefix x+ map f (Measured n x) = Measured n (map f x)+ any p (Measured _ x) = any p x+ all p (Measured _ x) = all p x++ foldl ft fc a0 (Measured _ x) = Textual.foldl (\a-> ft a . Measured 1) fc a0 x+ foldl' ft fc a0 (Measured _ x) = Textual.foldl' (\a-> ft a . Measured 1) fc a0 x+ foldr ft fc a0 (Measured _ x) = Textual.foldr (ft . Measured 1) fc a0 x+ toString ft (Measured _ x) = toString (ft . Measured 1) x+ toText ft (Measured _ x) = toText (ft . Measured 1) x++ span pt pc (Measured n x) = (xp', xs')+ where (xp, xs) = Textual.span (pt . Measured 1) pc x+ xp' = measure xp+ xs' = Measured (n - length xp') xs+ break pt pc = Textual.span (not . pt) (not . pc)++ find p (Measured _ x) = find p x
+ src/Data/Monoid/Instances/Positioned.hs view
@@ -0,0 +1,718 @@+{-+ Copyright 2014-2022 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines two monoid transformer data types, 'OffsetPositioned' and 'LinePositioned'. Both data types add+-- a notion of the current position to their base monoid. In case of 'OffsetPositioned', the current position is a+-- simple integer offset from the beginning of the monoid, and it can be applied to any 'StableFactorial'. The+-- base monoid of 'LinePositioned' must be a 'TextualMonoid', but for the price it will keep track of the current line+-- and column numbers as well.+--+-- Line number is zero-based, column one-based:+--+-- >> let p = pure "abcd\nefgh\nijkl\nmnop\n" :: LinePositioned String+-- >> p+-- >"abcd\nefgh\nijkl\nmnop\n"+-- >> Data.Monoid.Factorial.drop 13 p+-- >Line 2, column 4: "l\nmnop\n"++{-# LANGUAGE Haskell2010, DeriveDataTypeable #-}++module Data.Monoid.Instances.Positioned (+ OffsetPositioned, LinePositioned, extract, position, line, column+ )+where++import Control.Applicative -- (Applicative(..))+import qualified Data.List as List+import Data.String (IsString(..))++import Data.Data (Data, Typeable)+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(..), Endo(..))+import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..))+import Data.Semigroup.Factorial (Factorial(..), StableFactorial)+import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..))+import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)+import Data.Monoid.Factorial (FactorialMonoid(..))+import Data.Monoid.Textual (TextualMonoid(..))+import qualified Data.Semigroup.Factorial as Factorial+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual++import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, lines, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)++class Positioned p where+ extract :: p a -> a+ position :: p a -> Int++data OffsetPositioned m = OffsetPositioned{offset :: !Int,+ -- ^ the current offset+ extractOffset :: m} deriving (Data, Typeable)++data LinePositioned m = LinePositioned{fullOffset :: !Int,+ -- | the current line+ line :: !Int,+ lineStart :: !Int,+ extractLines :: m} deriving (Data, Typeable)++-- | the current column+column :: LinePositioned m -> Int+column lp = position lp - lineStart lp++instance Functor OffsetPositioned where+ fmap f (OffsetPositioned p c) = OffsetPositioned p (f c)++instance Functor LinePositioned where+ fmap f (LinePositioned p l lp c) = LinePositioned p l lp (f c)++instance Applicative OffsetPositioned where+ pure = OffsetPositioned 0+ OffsetPositioned _ f <*> OffsetPositioned p c = OffsetPositioned p (f c)++instance Applicative LinePositioned where+ pure = LinePositioned 0 0 (-1)+ LinePositioned _ _ _ f <*> LinePositioned p l lp c = LinePositioned p l lp (f c)++instance Positioned OffsetPositioned where+ extract = extractOffset+ position = offset++instance Positioned LinePositioned where+ extract = extractLines+ position = fullOffset++instance Eq m => Eq (OffsetPositioned m) where+ OffsetPositioned{extractOffset= a} == OffsetPositioned{extractOffset= b} = a == b++instance Eq m => Eq (LinePositioned m) where+ LinePositioned{extractLines= a} == LinePositioned{extractLines= b} = a == b++instance Ord m => Ord (OffsetPositioned m) where+ compare OffsetPositioned{extractOffset= a} OffsetPositioned{extractOffset= b} = compare a b++instance Ord m => Ord (LinePositioned m) where+ compare LinePositioned{extractLines= a} LinePositioned{extractLines= b} = compare a b++instance Show m => Show (OffsetPositioned m) where+ showsPrec prec (OffsetPositioned 0 c) = showsPrec prec c+ showsPrec prec (OffsetPositioned pos c) = shows pos . (": " ++) . showsPrec prec c++instance Show m => Show (LinePositioned m) where+ showsPrec prec (LinePositioned 0 0 (-1) c) = showsPrec prec c+ showsPrec prec (LinePositioned pos l lpos c) =+ ("Line " ++) . shows l . (", column " ++) . shows (pos - lpos) . (": " ++) . showsPrec prec c++instance StableFactorial m => Semigroup (OffsetPositioned m) where+ OffsetPositioned p1 c1 <> OffsetPositioned p2 c2 =+ OffsetPositioned (if p1 /= 0 || p2 == 0 then p1 else max 0 $ p2 - length c1) (c1 <> c2)+ {-# INLINE (<>) #-}++instance (FactorialMonoid m, StableFactorial m) => Monoid (OffsetPositioned m) where+ mempty = pure mempty+ mappend = (<>)+ {-# INLINE mempty #-}+ {-# INLINE mappend #-}++instance (StableFactorial m, TextualMonoid m) => Semigroup (LinePositioned m) where+ LinePositioned p1 l1 lp1 c1 <> LinePositioned p2 l2 lp2 c2+ | p1 /= 0 || p2 == 0 = LinePositioned p1 l1 lp1 c+ | otherwise = LinePositioned p2' l2' lp2' c+ where c = mappend c1 c2+ p2' = max 0 $ p2 - length c1+ lp2' = p2' - (p2 - lp2 - cd + 1)+ l2' = if l2 == 0 then 0 else max 0 (l2 - ld)+ (ld, cd) = linesColumns' c1+ {-# INLINE (<>) #-}++instance (StableFactorial m, TextualMonoid m) => Monoid (LinePositioned m) where+ mempty = pure mempty+ mappend = (<>)+ {-# INLINE mempty #-}++instance (StableFactorial m, FactorialMonoid m) => MonoidNull (OffsetPositioned m) where+ null = null . extractOffset+ {-# INLINE null #-}++instance (StableFactorial m, TextualMonoid m, MonoidNull m) => MonoidNull (LinePositioned m) where+ null = null . extractLines+ {-# INLINE null #-}++instance (StableFactorial m, FactorialMonoid m) => PositiveMonoid (OffsetPositioned m)++instance (StableFactorial m, TextualMonoid m) => PositiveMonoid (LinePositioned m)++instance (StableFactorial m, LeftReductive m) => LeftReductive (OffsetPositioned m) where+ isPrefixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isPrefixOf c1 c2+ stripPrefix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned (p + length c1)) (stripPrefix c1 c2)+ {-# INLINE isPrefixOf #-}+ {-# INLINE stripPrefix #-}++instance (StableFactorial m, TextualMonoid m) => LeftReductive (LinePositioned m) where+ isPrefixOf a b = isPrefixOf (extractLines a) (extractLines b)+ stripPrefix LinePositioned{extractLines= c1} (LinePositioned p l lpos c2) =+ let (lines, columns) = linesColumns' c1+ len = length c1+ in fmap (LinePositioned (p + len) (l + lines) (lpos + len - columns)) (stripPrefix c1 c2)+ {-# INLINE isPrefixOf #-}+ {-# INLINE stripPrefix #-}++instance (StableFactorial m, FactorialMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (OffsetPositioned m) where+ commonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = OffsetPositioned (min p1 p2) (commonPrefix c1 c2)+ stripCommonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) =+ (OffsetPositioned (min p1 p2) prefix, OffsetPositioned (p1 + l) c1', OffsetPositioned (p2 + l) c2')+ where (prefix, c1', c2') = stripCommonPrefix c1 c2+ l = length prefix+ {-# INLINE commonPrefix #-}+ {-# INLINE stripCommonPrefix #-}++instance (StableFactorial m, TextualMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (LinePositioned m) where+ commonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) =+ if p1 <= p2+ then LinePositioned p1 l1 lp1 (commonPrefix c1 c2)+ else LinePositioned p2 l2 lp2 (commonPrefix c1 c2)+ stripCommonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) =+ let (prefix, c1', c2') = stripCommonPrefix c1 c2+ (lines, columns) = linesColumns' prefix+ len = length prefix+ in (if p1 <= p2 then LinePositioned p1 l1 lp1 prefix else LinePositioned p2 l2 lp2 prefix,+ LinePositioned (p1 + len) (l1 + lines) (lp1 + len - columns) c1',+ LinePositioned (p2 + len) (l2 + lines) (lp2 + len - columns) c2')+ {-# INLINE commonPrefix #-}+ {-# INLINE stripCommonPrefix #-}++instance (StableFactorial m, FactorialMonoid m, RightReductive m) => RightReductive (OffsetPositioned m) where+ isSuffixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isSuffixOf c1 c2+ stripSuffix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned p) (stripSuffix c1 c2)+ {-# INLINE isSuffixOf #-}+ {-# INLINE stripSuffix #-}++instance (StableFactorial m, TextualMonoid m, RightReductive m) => RightReductive (LinePositioned m) where+ isSuffixOf LinePositioned{extractLines=c1} LinePositioned{extractLines=c2} = isSuffixOf c1 c2+ stripSuffix (LinePositioned p l lp c1) LinePositioned{extractLines=c2} =+ fmap (LinePositioned p l lp) (stripSuffix c1 c2)+ {-# INLINE isSuffixOf #-}+ {-# INLINE stripSuffix #-}++instance (StableFactorial m, FactorialMonoid m, RightGCDMonoid m) => RightGCDMonoid (OffsetPositioned m) where+ commonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) =+ OffsetPositioned (min (p1 + length c1) (p2 + length c2) - length suffix) suffix+ where suffix = commonSuffix c1 c2+ stripCommonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) =+ (OffsetPositioned p1 c1', OffsetPositioned p2 c2',+ OffsetPositioned (min (p1 + length c1') (p2 + length c2')) suffix)+ where (c1', c2', suffix) = stripCommonSuffix c1 c2+ {-# INLINE commonSuffix #-}+ {-# INLINE stripCommonSuffix #-}++instance (StableFactorial m, TextualMonoid m, RightGCDMonoid m) => RightGCDMonoid (LinePositioned m) where+ stripCommonSuffix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) =+ (LinePositioned p1 l1 lp1 c1', LinePositioned p2 l2 lp2 c2',+ if p1 < p2+ then LinePositioned (p1 + len1) (l1 + lines1) (lp1 + len1 - columns1) suffix+ else LinePositioned (p2 + len2) (l2 + lines2) (lp2 + len2 - columns2) suffix)+ where (c1', c2', suffix) = stripCommonSuffix c1 c2+ len1 = length c1'+ len2 = length c2'+ (lines1, columns1) = linesColumns' c1'+ (lines2, columns2) = linesColumns' c2'++instance StableFactorial m => Factorial (OffsetPositioned m) where+ factors (OffsetPositioned p c) = snd $ List.mapAccumL next p (factors c)+ where next p1 c1 = (succ p1, OffsetPositioned p1 c1)+ primePrefix (OffsetPositioned p c) = OffsetPositioned p (primePrefix c)+ foldl f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl f' (a0, p0) c0+ where f' (a, p) c = (f a (OffsetPositioned p c), succ p)+ foldl' f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl' f' (a0, p0) c0+ where f' (a, p) c = let a' = f a (OffsetPositioned p c) in seq a' (a', succ p)+ foldr f a0 (OffsetPositioned p0 c0) = Factorial.foldr f' (const a0) c0 p0+ where f' c cont p = f (OffsetPositioned p c) (cont $! succ p)+ foldMap f (OffsetPositioned p c) = appEndo (Factorial.foldMap f' c) (const mempty) p+ where -- f' :: m -> Endo (Int -> m)+ f' prime = Endo (\cont pos-> f (OffsetPositioned pos prime) `mappend` cont (succ pos))+ length (OffsetPositioned _ c) = length c+ reverse (OffsetPositioned p c) = OffsetPositioned p (Factorial.reverse c)+ {-# INLINE primePrefix #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE foldMap #-}++instance (StableFactorial m, FactorialMonoid m) => FactorialMonoid (OffsetPositioned m) where+ splitPrimePrefix (OffsetPositioned p c) = fmap rewrap (splitPrimePrefix c)+ where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (if null cs then 0 else succ p) cs)+ splitPrimeSuffix (OffsetPositioned p c) = fmap rewrap (splitPrimeSuffix c)+ where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (p + length cp) cs)+ spanMaybe s0 f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe (s0, p0) f' t+ where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime)+ let p' = succ p+ Just $! seq p' (s', p')+ rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)+ spanMaybe' s0 f (OffsetPositioned p0 t) = rewrap $! Factorial.spanMaybe' (s0, p0) f' t+ where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime)+ let p' = succ p+ Just $! s' `seq` p' `seq` (s', p')+ rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)+ span f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe' p0 f' t+ where f' p prime = if f (OffsetPositioned p prime)+ then Just $! succ p+ else Nothing+ rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix)+ splitAt n m@(OffsetPositioned p c) | n <= 0 = (mempty, m)+ | n >= length c = (m, mempty)+ | otherwise = (OffsetPositioned p prefix, OffsetPositioned (p + n) suffix)+ where (prefix, suffix) = splitAt n c+ drop n (OffsetPositioned p c) = OffsetPositioned (p + n) (Factorial.drop n c)+ take n (OffsetPositioned p c) = OffsetPositioned p (Factorial.take n c)+ {-# INLINE splitPrimePrefix #-}+ {-# INLINE splitPrimeSuffix #-}+ {-# INLINE span #-}+ {-# INLINE splitAt #-}+ {-# INLINE take #-}+ {-# INLINE drop #-}++instance (StableFactorial m, TextualMonoid m) => Factorial (LinePositioned m) where+ factors (LinePositioned p0 l0 lp0 c) = snd $ List.mapAccumL next (p0, l0, lp0) (factors c)+ where next (p, l, lp) c1 = let p' = succ p+ in p' `seq` case characterPrefix c1+ of Just '\n' -> ((p', succ l, p), LinePositioned p l lp c1)+ Just '\f' -> ((p', succ l, p), LinePositioned p l lp c1)+ Just '\r' -> ((p', l, p), LinePositioned p l lp c1)+ Just '\t' -> ((p', l, lp + (p - lp) `mod` 8 - 8),+ LinePositioned p l lp c1)+ Just ch | isZeroWidth ch -> ((p, l, lp), LinePositioned p l lp c1)+ _ -> ((p', l, lp), LinePositioned p l lp c1)+ primePrefix (LinePositioned p l lp c) = LinePositioned p l lp (primePrefix c)+ foldl f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl f' (a0, p0, l0, lp0) c0+ where f' (a, p, l, lp) c = case characterPrefix c+ of Just '\n' -> (f a (LinePositioned p l lp c), succ p, succ l, p)+ Just '\f' -> (f a (LinePositioned p l lp c), succ p, succ l, p)+ Just '\r' -> (f a (LinePositioned p l lp c), succ p, l, p)+ Just '\t' -> (f a (LinePositioned p l lp c), succ p, l, lp + (p - lp) `mod` 8 - 8)+ Just ch | isZeroWidth ch -> (f a (LinePositioned p l lp c), p, l, lp)+ _ -> (f a (LinePositioned p l lp c), succ p, l, lp)+ foldl' f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl' f' (a0, p0, l0, lp0) c0+ where f' (a, p, l, lp) c = let a' = f a (LinePositioned p l lp c)+ in seq a' (case characterPrefix c+ of Just '\n' -> (a', succ p, succ l, p)+ Just '\f' -> (a', succ p, succ l, p)+ Just '\r' -> (a', succ p, l, p)+ Just '\t' -> (a', succ p, l, lp + (p - lp) `mod` 8 - 8)+ Just ch | isZeroWidth ch -> (a', p, l, lp)+ _ -> (a', succ p, l, lp))+ foldr f a0 (LinePositioned p0 l0 lp0 c0) = Factorial.foldr f' (const3 a0) c0 p0 l0 lp0+ where f' c cont p l lp = case characterPrefix c+ of Just '\n' -> f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p+ Just '\f' -> f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p+ Just '\r' -> f (LinePositioned p l lp c) $ (cont $! succ p) l p+ Just '\t' -> f (LinePositioned p l lp c) $ (cont $! succ p) l+ $! lp + (p - lp) `mod` 8 - 8+ Just ch | isZeroWidth ch -> f (LinePositioned p l lp c) $ (cont p) l lp+ _ -> f (LinePositioned p l lp c) $ (cont $! succ p) l lp+ foldMap f (LinePositioned p0 l0 lp0 c) = appEndo (Factorial.foldMap f' c) (const mempty) p0 l0 lp0+ where -- f' :: m -> Endo (Int -> Int -> Int -> m)+ f' prime = Endo (\cont p l lp-> f (LinePositioned p l lp prime)+ `mappend`+ case characterPrefix prime+ of Just '\n' -> cont (succ p) (succ l) p+ Just '\f' -> cont (succ p) (succ l) p+ Just '\r' -> cont (succ p) l p+ Just '\t' -> cont (succ p) l (lp + (p - lp) `mod` 8 - 8)+ Just ch | isZeroWidth ch -> cont p l lp+ _ -> cont (succ p) l lp)+ length = length . extractLines+ reverse (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.reverse c)+ {-# INLINE primePrefix #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE foldMap #-}+ {-# INLINE length #-}+ {-# INLINE reverse #-}++instance (StableFactorial m, TextualMonoid m) => FactorialMonoid (LinePositioned m) where+ splitPrimePrefix (LinePositioned p l lp c) = fmap rewrap (splitPrimePrefix c)+ where rewrap (cp, cs) = (LinePositioned p l lp cp,+ if null cs then mempty+ else case characterPrefix cp+ of Just '\n' -> LinePositioned p' (succ l) p cs+ Just '\f' -> LinePositioned p' (succ l) p cs+ Just '\r' -> LinePositioned p' l p cs+ Just '\t' -> LinePositioned p' l (lp + (p - lp) `mod` 8 - 8) cs+ Just ch | isZeroWidth ch -> LinePositioned p l lp cs+ _ -> LinePositioned p' l lp cs)+ p' = succ p+ splitPrimeSuffix (LinePositioned p l lp c) = fmap rewrap (splitPrimeSuffix c)+ where rewrap (cp, cs) = (LinePositioned p l lp cp, LinePositioned p' (l + lines) (p' - columns) cs)+ where len = length cp+ (lines, columns) = linesColumns cp+ p' = p + len+ spanMaybe s0 f (LinePositioned p0 l0 lp0 c) = rewrap $ Factorial.spanMaybe (s0, p0, l0, lp0) f' c+ where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime)+ let p' = succ p+ l' = succ l+ Just $! p' `seq` case characterPrefix prime+ of Just '\n' -> l' `seq` (s', p', l', p)+ Just '\f' -> l' `seq` (s', p', l', p)+ Just '\r' -> (s', p', l, p)+ Just '\t' -> (s', p', l, lp + (p - lp) `mod` 8 - 8)+ Just ch | isZeroWidth ch -> (s', p, l, lp)+ _ -> (s', p', l, lp)+ rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s)+ spanMaybe' s0 f (LinePositioned p0 l0 lp0 c) = rewrap $! Factorial.spanMaybe' (s0, p0, l0, lp0) f' c+ where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime)+ let p' = succ p+ l' = succ l+ Just $! s' `seq` p' `seq` case characterPrefix prime+ of Just '\n' -> l' `seq` (s', p', l', p)+ Just '\f' -> l' `seq` (s', p', l', p)+ Just '\r' -> (s', p', l, p)+ Just '\t' -> (s', p', l, lp + (p - lp) `mod` 8 - 8)+ Just ch | isZeroWidth ch -> (s', p, l, lp)+ _ -> (s', p', l, lp)+ rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s)++ span f (LinePositioned p0 l0 lp0 t) = rewrap $ Factorial.spanMaybe' (p0, l0, lp0) f' t+ where f' (p, l, lp) prime = if f (LinePositioned p l lp prime)+ then let p' = succ p+ l' = succ l+ in Just $! p' `seq` case characterPrefix prime+ of Just '\n' -> l' `seq` (p', l', p)+ Just '\f' -> l' `seq` (p', l', p)+ Just '\r' -> (p', l, p)+ Just '\t' -> (p', l, lp + (p - lp) `mod` 8 - 8)+ Just c | isZeroWidth c -> (p, l, lp)+ _ -> (p', l, lp)+ else Nothing+ rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix)+ splitAt n m@(LinePositioned p l lp c) | n <= 0 = (mempty, m)+ | n >= length c = (m, mempty)+ | otherwise = (LinePositioned p l lp prefix,+ LinePositioned p' (l + lines) (p' - columns) suffix)+ where (prefix, suffix) = splitAt n c+ (lines, columns) = linesColumns prefix+ p' = p + n+ take n (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.take n c)+ {-# INLINE splitPrimePrefix #-}+ {-# INLINE splitPrimeSuffix #-}+ {-# INLINE span #-}+ {-# INLINE splitAt #-}+ {-# INLINE take #-}++instance StableFactorial m => StableFactorial (OffsetPositioned m)++instance (StableFactorial m, TextualMonoid m) => StableFactorial (LinePositioned m)++instance IsString m => IsString (OffsetPositioned m) where+ fromString = pure . fromString++instance IsString m => IsString (LinePositioned m) where+ fromString = pure . fromString++instance (StableFactorial m, TextualMonoid m) => TextualMonoid (OffsetPositioned m) where+ splitCharacterPrefix (OffsetPositioned p t) = fmap rewrap (splitCharacterPrefix t)+ where rewrap (c, cs) = if null cs then (c, mempty) else (c, OffsetPositioned (succ p) cs)++ fromText = pure . fromText+ singleton = pure . singleton++ characterPrefix = characterPrefix . extractOffset++ map f (OffsetPositioned p c) = OffsetPositioned p (map f c)+ concatMap f (OffsetPositioned p c) = OffsetPositioned p (concatMap (extractOffset . f) c)+ all p = all p . extractOffset+ any p = any p . extractOffset++ foldl ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl ft' fc' (a0, p0) c0+ where ft' (a, p) c = (ft a (OffsetPositioned p c), succ p)+ fc' (a, p) c = (fc a c, succ p)+ foldl' ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl' ft' fc' (a0, p0) c0+ where ft' (a, p) c = ((,) $! ft a (OffsetPositioned p c)) $! succ p+ fc' (a, p) c = ((,) $! fc a c) $! succ p+ foldr ft fc a0 (OffsetPositioned p0 c0) = snd $ Textual.foldr ft' fc' (p0, a0) c0+ where ft' c (p, a) = (succ p, ft (OffsetPositioned p c) a)+ fc' c (p, a) = (succ p, fc c a)++ scanl f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl f ch c)+ scanl1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl1 f c)+ scanr f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr f ch c)+ scanr1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr1 f c)+ mapAccumL f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumL f a0 c)+ mapAccumR f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumR f a0 c)++ spanMaybe s0 ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe (s0, p0) ft' fc' t+ where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime)+ let p' = succ p+ Just $! seq p' (s', p')+ fc' (s, p) c = do s' <- fc s c+ let p' = succ p+ Just $! seq p' (s', p')+ rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)+ spanMaybe' s0 ft fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe' (s0, p0) ft' fc' t+ where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime)+ let p' = succ p+ Just $! s' `seq` p' `seq` (s', p')+ fc' (s, p) c = do s' <- fc s c+ let p' = succ p+ Just $! s' `seq` p' `seq` (s', p')+ rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)+ span ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe' p0 ft' fc' t+ where ft' p prime = if ft (OffsetPositioned p prime)+ then Just $! succ p+ else Nothing+ fc' p c = if fc c+ then Just $! succ p+ else Nothing+ rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix)++ split f (OffsetPositioned p0 c0) = rewrap p0 (Textual.split f c0)+ where rewrap _ [] = []+ rewrap p (c:rest) = OffsetPositioned p c : rewrap (p + length c) rest+ find p = find p . extractOffset++ foldl_ fc a0 (OffsetPositioned _ c) = Textual.foldl_ fc a0 c+ foldl_' fc a0 (OffsetPositioned _ c) = Textual.foldl_' fc a0 c+ foldr_ fc a0 (OffsetPositioned _ c) = Textual.foldr_ fc a0 c++ spanMaybe_ s0 fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe_' (s0, p0) fc' t+ where fc' (s, p) c = do s' <- fc s c+ let p' = succ p+ Just $! seq p' (s', p')+ rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)+ spanMaybe_' s0 fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe_' (s0, p0) fc' t+ where fc' (s, p) c = do s' <- fc s c+ let p' = succ p+ Just $! s' `seq` p' `seq` (s', p')+ rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s)+ span_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.span_ bt fc t+ where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix)+ break_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.break_ bt fc t+ where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix)+ dropWhile_ bt fc t = snd (span_ bt fc t)+ takeWhile_ bt fc (OffsetPositioned p t) = OffsetPositioned p (takeWhile_ bt fc t)+ toString ft (OffsetPositioned _ t) = toString (ft . pure) t+ toText ft (OffsetPositioned _ t) = toText (ft . pure) t++ {-# INLINE characterPrefix #-}+ {-# INLINE splitCharacterPrefix #-}+ {-# INLINE map #-}+ {-# INLINE concatMap #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINABLE spanMaybe #-}+ {-# INLINABLE spanMaybe' #-}+ {-# INLINABLE span #-}+ {-# INLINE foldl_' #-}+ {-# INLINE foldr_ #-}+ {-# INLINE any #-}+ {-# INLINE all #-}+ {-# INLINABLE spanMaybe_ #-}+ {-# INLINABLE spanMaybe_' #-}+ {-# INLINE span_ #-}+ {-# INLINE break_ #-}+ {-# INLINE dropWhile_ #-}+ {-# INLINE takeWhile_ #-}+ {-# INLINE split #-}+ {-# INLINE find #-}++instance (StableFactorial m, TextualMonoid m) => TextualMonoid (LinePositioned m) where+ splitCharacterPrefix (LinePositioned p l lp t) =+ case splitCharacterPrefix t+ of Nothing -> Nothing+ Just (c, rest) | null rest -> Just (c, mempty)+ Just ('\n', rest) -> Just ('\n', LinePositioned p' (succ l) p rest)+ Just ('\f', rest) -> Just ('\f', LinePositioned p' (succ l) p rest)+ Just ('\r', rest) -> Just ('\r', LinePositioned p' l p rest)+ Just ('\t', rest) -> Just ('\t', LinePositioned p' l (lp + (p - lp) `mod` 8 - 8) rest)+ Just (ch, rest)+ | isZeroWidth ch -> Just (ch, LinePositioned p l lp rest)+ | otherwise -> Just (ch, LinePositioned p' l lp rest)+ where p' = succ p++ fromText = pure . fromText+ singleton = pure . singleton++ characterPrefix = characterPrefix . extractLines++ map f (LinePositioned p l lp c) = LinePositioned p l lp (map f c)+ concatMap f (LinePositioned p l lp c) = LinePositioned p l lp (concatMap (extractLines . f) c)+ all p = all p . extractLines+ any p = any p . extractLines++ foldl ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl ft' fc' (a0, p0, l0, lp0) c0+ where ft' (a, p, l, lp) c = (ft a (LinePositioned p l lp c), succ p, l, lp)+ fc' (a, p, l, _lp) '\n' = (fc a '\n', succ p, succ l, p)+ fc' (a, p, l, _lp) '\f' = (fc a '\f', succ p, succ l, p)+ fc' (a, p, l, _lp) '\r' = (fc a '\r', succ p, l, p)+ fc' (a, p, l, lp) '\t' = (fc a '\t', succ p, l, lp + (p - lp) `mod` 8 - 8)+ fc' (a, p, l, lp) c+ | isZeroWidth c = (fc a c, p, l, lp)+ | otherwise = (fc a c, succ p, l, lp)+ foldl' ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl' ft' fc' (a0, p0, l0, lp0) c0+ where ft' (a, p, l, lp) c = let a' = ft a (LinePositioned p l lp c)+ p' = succ p+ in a' `seq` p' `seq` (a', p', l, lp)+ fc' (a, p, l, lp) c = let a' = fc a c+ p' = succ p+ l' = succ l+ in a' `seq` p' `seq` case c+ of '\n' -> l' `seq` (a', p', l', p)+ '\f' -> l' `seq` (a', p', l', p)+ '\r' -> (a', p', l, p)+ '\t' -> (a', p', l, lp + (p - lp) `mod` 8 - 8)+ _ | isZeroWidth c -> (a', p, l, lp)+ _ -> (a', p', l, lp)+ foldr ft fc a0 (LinePositioned p0 l0 lp0 c0) = Textual.foldr ft' fc' (const3 a0) c0 p0 l0 lp0+ where ft' c cont p l lp = ft (LinePositioned p l lp c) $ (cont $! succ p) l lp+ fc' c cont p l lp+ | c == '\n' = fc c $ ((cont $! succ p) $! succ l) p+ | c == '\f' = fc c $ ((cont $! succ p) $! succ l) p+ | c == '\r' = fc c $ (cont $! succ p) l p+ | c == '\t' = fc c $ (cont $! succ p) l (lp + (p - lp) `mod` 8 - 8)+ | isZeroWidth c = fc c $ (cont p) l lp+ | otherwise = fc c $ (cont $! succ p) l lp++ spanMaybe s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe (s0, p0, l0, lp0) ft' fc' t+ where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime)+ let p' = succ p+ Just $! seq p' (s', p', l, lp)+ fc' (s, p, l, lp) c =+ fc s c+ >>= \s'-> Just $! seq p' (if c == '\n' || c == '\f' then seq l' (s', p', l', p)+ else if c == '\r' then (s', p', l, p)+ else if c == '\t' then (s', p', l, lp + (p - lp) `mod` 8 - 8)+ else if isZeroWidth c then (s', p, l, lp)+ else (s', p', l, lp))+ where p' = succ p+ l' = succ l+ rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s)+ spanMaybe' s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $! Textual.spanMaybe' (s0, p0, l0, lp0) ft' fc' t+ where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime)+ let p' = succ p+ Just $! s' `seq` p' `seq` (s', p', l, lp)+ fc' (s, p, l, lp) c = do s' <- fc s c+ let p' = succ p+ l' = succ l+ Just $! s' `seq` p'+ `seq` (if c == '\n' || c == '\f' then seq l' (s', p', l', p)+ else if c == '\r' then (s', p', l, p)+ else if c == '\t' then (s', p', l, lp + (p - lp) `mod` 8 - 8)+ else if isZeroWidth c then (s', p, l, lp)+ else (s', p', l, lp))+ rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s)+ span ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe' (p0, l0, lp0) ft' fc' t+ where ft' (p, l, lp) prime = if ft (LinePositioned p l lp prime)+ then let p' = succ p+ in p' `seq` Just (p', l, lp)+ else Nothing+ fc' (p, l, lp) c | fc c = Just $! seq p'+ $ if c == '\n' || c == '\f' then seq l' (p', l', p)+ else if c == '\r' then (p', l, p)+ else if c == '\t' then (p', l, lp + (p - lp) `mod` 8 - 8)+ else if isZeroWidth c then (p, l, lp)+ else (p', l, lp)+ | otherwise = Nothing+ where p' = succ p+ l' = succ l+ rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix)++ scanl f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl f ch c)+ scanl1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl1 f c)+ scanr f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr f ch c)+ scanr1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr1 f c)+ mapAccumL f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumL f a0 c)+ mapAccumR f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumR f a0 c)++ split f (LinePositioned p0 l0 lp0 c0) = rewrap p0 l0 lp0 (Textual.split f c0)+ where rewrap _ _ _ [] = []+ rewrap p l lp (c:rest) = LinePositioned p l lp c+ : rewrap p' (l + lines) (if lines == 0 then lp else p' - columns) rest+ where p' = p + length c+ (lines, columns) = linesColumns c+ find p = find p . extractLines++ foldl_ fc a0 (LinePositioned _ _ _ t) = Textual.foldl_ fc a0 t+ foldl_' fc a0 (LinePositioned _ _ _ t) = Textual.foldl_' fc a0 t+ foldr_ fc a0 (LinePositioned _ _ _ t) = Textual.foldr_ fc a0 t++ spanMaybe_ s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_ s0 fc t+ where rewrap (prefix, suffix, s) = (LinePositioned p0 l0 lp0 prefix,+ LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix,+ s)+ where (l, col) = linesColumns prefix+ p1 = p0 + length prefix+ spanMaybe_' s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_' s0 fc t+ where rewrap (prefix, suffix, s) = p1 `seq` l1 `seq` lp1 `seq`+ (LinePositioned p0 l0 lp0 prefix, LinePositioned p1 l1 lp1 suffix, s)+ where (l, col) = linesColumns' prefix+ p1 = p0 + length prefix+ l1 = l0 + l+ lp1 = if l == 0 then lp0 else p1 - col+ span_ bt fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.span_ bt fc t+ where rewrap (prefix, suffix) = (LinePositioned p0 l0 lp0 prefix,+ LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix)+ where (l, col) = linesColumns' prefix+ p1 = p0 + length prefix+ break_ bt fc t = span_ (not bt) (not . fc) t+ dropWhile_ bt fc t = snd (span_ bt fc t)+ takeWhile_ bt fc (LinePositioned p l lp t) = LinePositioned p l lp (takeWhile_ bt fc t)+ toString ft lpt = toString (ft . pure) (extractLines lpt)+ toText ft lpt = toText (ft . pure) (extractLines lpt)++ {-# INLINE characterPrefix #-}+ {-# INLINE splitCharacterPrefix #-}+ {-# INLINE map #-}+ {-# INLINE concatMap #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE spanMaybe' #-}+ {-# INLINE span #-}+ {-# INLINE split #-}+ {-# INLINE find #-}+ {-# INLINE foldl_' #-}+ {-# INLINE foldr_ #-}+ {-# INLINE any #-}+ {-# INLINE all #-}+ {-# INLINABLE spanMaybe_ #-}+ {-# INLINABLE spanMaybe_' #-}+ {-# INLINABLE span_ #-}+ {-# INLINE break_ #-}+ {-# INLINE dropWhile_ #-}+ {-# INLINE takeWhile_ #-}++linesColumns :: TextualMonoid m => m -> (Int, Int)+linesColumns t = Textual.foldl (const . fmap succ) fc (0, 1) t+ where fc (l, _) '\n' = (succ l, 1)+ fc (l, _) '\f' = (succ l, 1)+ fc (l, _) '\r' = (l, 1)+ fc (l, c) '\t' = (l, c + 9 - c `mod` 8)+ fc (l, c) ch | isZeroWidth ch = (l, c)+ fc (l, c) _ = (l, succ c)+linesColumns' :: TextualMonoid m => m -> (Int, Int)+linesColumns' t = Textual.foldl' (const . fmap succ) fc (0, 1) t+ where fc (l, _) '\n' = let l' = succ l in seq l' (l', 1)+ fc (l, _) '\f' = let l' = succ l in seq l' (l', 1)+ fc (l, _) '\r' = (l, 1)+ fc (l, c) '\t' = (l, c + 9 - c `mod` 8)+ fc (l, c) ch | isZeroWidth ch = (l, c)+ fc (l, c) _ = let c' = succ c in seq c' (l, c')+{-# INLINE linesColumns #-}+{-# INLINE linesColumns' #-}++isZeroWidth :: Char -> Bool+isZeroWidth '\x200b' = True -- zero width space+isZeroWidth '\x200c' = True -- zero width non-joiner+isZeroWidth '\x200d' = True -- zero width joiner+isZeroWidth '\xfeff' = True -- zero width no-break space+isZeroWidth _ = False++const3 :: a -> b -> c -> d -> a+const3 a _p _l _lp = a+{-# INLINE const3 #-}++fstOf4 :: (a, b, c, d) -> a+fstOf4 (a, _, _, _) = a+{-# INLINE fstOf4 #-}
+ src/Data/Monoid/Instances/PrefixMemory.hs view
@@ -0,0 +1,269 @@+{-+ Copyright 2023 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the monoid transformer data type 'Shadowed'.+{-# LANGUAGE Haskell2010, DeriveDataTypeable #-}++module Data.Monoid.Instances.PrefixMemory (+ Shadowed, shadowed, content, prefix+ )+where++import Control.Applicative -- (Applicative(..))+import qualified Data.List as List+import Data.String (IsString(fromString))++import Data.Data (Data, Typeable)+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(..), Endo(..))+import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..))+import Data.Semigroup.Factorial (Factorial(..), StableFactorial)+import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..))+import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)+import Data.Monoid.Factorial (FactorialMonoid(..))+import Data.Monoid.Textual (TextualMonoid(..))+import qualified Data.Semigroup.Factorial as Factorial+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual++import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, lines, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)++-- | Monoid transformer that keeps track of the former 'prefix' of its 'content'. All functions that return a suffix+-- of their argument, such as 'stripPrefix' or 'commonSuffix', preserve the discarded 'prefix'.+data Shadowed m = Shadowed{prefix :: !m,+ -- ^ used to precede the 'content' but has been consumed+ content :: !m+ -- ^ the present value+ } deriving (Data, Typeable)++-- | The constructor of a 'Shadowed' monoid, with the initial @prefix = null@+shadowed :: Monoid m => m -> Shadowed m+shadowed = Shadowed mempty++instance Eq m => Eq (Shadowed m) where+ Shadowed{content = a} == Shadowed{content = b} = a == b++instance Ord m => Ord (Shadowed m) where+ compare Shadowed{content= a} Shadowed{content= b} = compare a b++instance (MonoidNull m, Show m) => Show (Shadowed m) where+ showsPrec prec (Shadowed p c) rest+ | null p = showsPrec prec c rest+ | otherwise = "Shadowed{prefix=" <> shows p (", content=" <> shows c ("}" <> rest))++instance (MonoidNull m, StableFactorial m) => Semigroup (Shadowed m) where+ Shadowed p1 c1 <> m2@Shadowed{content = c2}+ | null c1 && null p1 = m2+ | otherwise = Shadowed p1 (c1 <> c2)+ {-# INLINE (<>) #-}++instance (MonoidNull m, StableFactorial m) => Monoid (Shadowed m) where+ mempty = shadowed mempty+ mappend = (<>)+ {-# INLINE mempty #-}+ {-# INLINE mappend #-}++instance (MonoidNull m, StableFactorial m) => MonoidNull (Shadowed m) where+ null = null . content+ {-# INLINE null #-}++instance (PositiveMonoid m, StableFactorial m) => PositiveMonoid (Shadowed m)++instance (MonoidNull m, StableFactorial m, LeftReductive m) => LeftReductive (Shadowed m) where+ t1 `isPrefixOf` t2 = content t1 `isPrefixOf` content t2+ stripPrefix (Shadowed _ c1) (Shadowed p c2) = fmap (Shadowed (p <> c1)) (stripPrefix c1 c2)+ {-# INLINE isPrefixOf #-}+ {-# INLINE stripPrefix #-}++instance (Eq m, StableFactorial m, FactorialMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (Shadowed m) where+ stripCommonPrefix (Shadowed p1 c1) (Shadowed p2 c2) =+ (Shadowed prefix' common, Shadowed (p1 <> common) c1', Shadowed (p2 <> common) c2')+ where (common, c1', c2') = stripCommonPrefix c1 c2+ prefix' = if p1 == p2 then p1 <> common else common+ {-# INLINE stripCommonPrefix #-}++instance (StableFactorial m, FactorialMonoid m, RightReductive m) => RightReductive (Shadowed m) where+ isSuffixOf (Shadowed _ c1) (Shadowed _ c2) = isSuffixOf c1 c2+ stripSuffix (Shadowed _ c1) (Shadowed p c2) = fmap (Shadowed p) (stripSuffix c1 c2)+ {-# INLINE isSuffixOf #-}+ {-# INLINE stripSuffix #-}++instance (StableFactorial m, FactorialMonoid m, RightGCDMonoid m) => RightGCDMonoid (Shadowed m) where+ commonSuffix (Shadowed _ c1) (Shadowed _ c2) = shadowed suffix+ where suffix = commonSuffix c1 c2+ stripCommonSuffix (Shadowed p1 c1) (Shadowed p2 c2) =+ (Shadowed p1 c1', Shadowed p2 c2',+ shadowed suffix)+ where (c1', c2', suffix) = stripCommonSuffix c1 c2+ {-# INLINE commonSuffix #-}+ {-# INLINE stripCommonSuffix #-}++instance (FactorialMonoid m, StableFactorial m) => Factorial (Shadowed m) where+ factors (Shadowed p c) = rewrap <$> List.tail (inits c)+ where rewrap t+ | Just (p', prime) <- splitPrimeSuffix t = Shadowed (p <> p') prime+ | otherwise = error "all (not . null) . tail . inits"+ primePrefix (Shadowed p c) = Shadowed p (primePrefix c)+ foldl f a0 (Shadowed p0 c0) = fst $ Factorial.foldl f' (a0, p0) c0+ where f' (a, p) c = (f a (Shadowed p c), p <> c)+ foldl' f a0 (Shadowed p0 c0) = fst $ Factorial.foldl' f' (a0, p0) c0+ where f' (a, p) c = ((,) $! f a (Shadowed p c)) $! p <> c+ foldr f a0 (Shadowed p0 c0) = Factorial.foldr f' (const a0) c0 p0+ where f' c cont p = f (Shadowed p c) (cont $! p <> c)+ foldMap f (Shadowed p0 c) = appEndo (Factorial.foldMap f' c) (const mempty) p0+ where -- f' :: m -> Endo (Int -> m)+ f' prime = Endo (\cont p-> f (Shadowed p prime) `mappend` (cont $! p <> prime))+ length (Shadowed _ c) = length c+ reverse (Shadowed p c) = Shadowed p (Factorial.reverse c)+ {-# INLINE primePrefix #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE foldMap #-}++instance (StableFactorial m, FactorialMonoid m) => FactorialMonoid (Shadowed m) where+ splitPrimePrefix (Shadowed p c) = fmap rewrap (splitPrimePrefix c)+ where rewrap (cp, cs) = (Shadowed p cp, Shadowed (p <> cp) cs)+ splitPrimeSuffix (Shadowed p c) = fmap rewrap (splitPrimeSuffix c)+ where rewrap (cp, cs) = (Shadowed p cp, Shadowed (p <> cp) cs)+ inits (Shadowed p c) = Shadowed p <$> inits c+ tails (Shadowed p c)+ | null p = zipWith Shadowed (inits c) (tails c)+ | otherwise = zipWith (Shadowed . (p <>)) (inits c) (tails c)+ spanMaybe s0 f (Shadowed p0 c) = rewrap $ Factorial.spanMaybe (s0, p0) f' c+ where f' (s, p) prime = do s' <- f s (Shadowed p prime)+ let p' = p <> prime+ Just $! seq p' (s', p')+ rewrap (cp, cs, (s, p)) = (Shadowed p0 cp, Shadowed p cs, s)+ spanMaybe' s0 f (Shadowed p0 c) = rewrap $! Factorial.spanMaybe' (s0, p0) f' c+ where f' (s, p) prime = do s' <- f s (Shadowed p prime)+ let p' = p <> prime+ Just $! s' `seq` p' `seq` (s', p')+ rewrap (cp, cs, (s, p)) = (Shadowed p0 cp, Shadowed p cs, s)+ span f (Shadowed p0 c) = rewrap $ Factorial.spanMaybe' p0 f' c+ where f' p prime = if f (Shadowed p prime)+ then Just $! p <> prime+ else Nothing+ rewrap (cp, cs, p) = (Shadowed p0 cp, Shadowed p cs)+ splitAt n (Shadowed p c) = (Shadowed p cp, Shadowed (p <> cp) cs)+ where (cp, cs) = splitAt n c+ take n (Shadowed p c) = Shadowed p (Factorial.take n c)+ {-# INLINE splitPrimePrefix #-}+ {-# INLINE splitPrimeSuffix #-}+ {-# INLINE span #-}+ {-# INLINE splitAt #-}+ {-# INLINE take #-}++instance (StableFactorial m, FactorialMonoid m) => StableFactorial (Shadowed m)++instance (Monoid m, IsString m) => IsString (Shadowed m) where+ fromString = shadowed . fromString++instance (Eq m, StableFactorial m, TextualMonoid m) => TextualMonoid (Shadowed m) where+ splitCharacterPrefix (Shadowed p t) = (Shadowed p <$>) <$> Textual.splitCharacterPrefix t++ fromText = shadowed . fromText+ singleton = shadowed . singleton++ characterPrefix = characterPrefix . content++ map f (Shadowed p c) = Shadowed p (map f c)+ concatMap f (Shadowed p c) = Shadowed p (concatMap (content . f) c)+ all p = all p . content+ any p = any p . content++ foldl ft fc a0 (Shadowed p0 c0) = fst $ Textual.foldl ft' fc' (a0, p0) c0+ where ft' (a, p) c = (ft a (Shadowed p c), p <> c)+ fc' (a, p) c = (fc a c, p <> Textual.singleton c)+ foldl' ft fc a0 (Shadowed p0 c0) = fst $ Textual.foldl' ft' fc' (a0, p0) c0+ where ft' (a, p) c = ((,) $! ft a (Shadowed p c)) $! p <> c+ fc' (a, p) c = ((,) $! fc a c) $! p <> Textual.singleton c+ foldr ft fc a0 (Shadowed p0 c0) = snd $ Textual.foldr ft' fc' (p0, a0) c0+ where ft' c (p, a) = ((,) $! p <> c) $! ft (Shadowed p c) a+ fc' c (p, a) = ((,) $! p <> Textual.singleton c) $! fc c a++ scanl f ch (Shadowed p c) = Shadowed p (Textual.scanl f ch c)+ scanl1 f (Shadowed p c) = Shadowed p (Textual.scanl1 f c)+ scanr f ch (Shadowed p c) = Shadowed p (Textual.scanr f ch c)+ scanr1 f (Shadowed p c) = Shadowed p (Textual.scanr1 f c)+ mapAccumL f a0 (Shadowed p c) = fmap (Shadowed p) (Textual.mapAccumL f a0 c)+ mapAccumR f a0 (Shadowed p c) = fmap (Shadowed p) (Textual.mapAccumR f a0 c)++ spanMaybe s0 ft fc (Shadowed p0 t) = rewrap $ Textual.spanMaybe (s0, p0) ft' fc' t+ where ft' (s, p) prime = do s' <- ft s (Shadowed p prime)+ let p' = p <> prime+ Just $! seq p' (s', p')+ fc' (s, p) c = do s' <- fc s c+ let p' = p <> Textual.singleton c+ Just $! seq p' (s', p')+ rewrap (tp, ts, (s, p)) = (Shadowed p0 tp, Shadowed p ts, s)+ spanMaybe' s0 ft fc (Shadowed p0 t) = rewrap $! Textual.spanMaybe' (s0, p0) ft' fc' t+ where ft' (s, p) prime = do s' <- ft s (Shadowed p prime)+ let p' = p <> prime+ Just $! s' `seq` p' `seq` (s', p')+ fc' (s, p) c = do s' <- fc s c+ let p' = p <> Textual.singleton c+ Just $! s' `seq` p' `seq` (s', p')+ rewrap (tp, ts, (s, p)) = (Shadowed p0 tp, Shadowed p ts, s)+ span ft fc (Shadowed p0 t) = rewrap $ Textual.spanMaybe' p0 ft' fc' t+ where ft' p prime = if ft (Shadowed p prime)+ then Just $! p <> prime+ else Nothing+ fc' p c = if fc c+ then Just $! p <> Textual.singleton c+ else Nothing+ rewrap (tp, ts, p) = (Shadowed p0 tp, Shadowed p ts)++ split f (Shadowed p0 c0) = rewrap p0 (Textual.split f c0)+ where rewrap _ [] = []+ rewrap p (c:rest) = Shadowed p c : rewrap (p <> c) rest+ find p = find p . content++ foldl_ fc a0 (Shadowed _ c) = Textual.foldl_ fc a0 c+ foldl_' fc a0 (Shadowed _ c) = Textual.foldl_' fc a0 c+ foldr_ fc a0 (Shadowed _ c) = Textual.foldr_ fc a0 c++ spanMaybe_ s0 fc (Shadowed p0 t) = rewrap $ Textual.spanMaybe_' (s0, p0) fc' t+ where fc' (s, p) c = do s' <- fc s c+ let p' = p <> Textual.singleton c+ Just $! seq p' (s', p')+ rewrap (tp, ts, (s, p)) = (Shadowed p0 tp, Shadowed p ts, s)+ spanMaybe_' s0 fc (Shadowed p0 t) = rewrap $! Textual.spanMaybe_' (s0, p0) fc' t+ where fc' (s, p) c = do s' <- fc s c+ let p' = p <> Textual.singleton c+ Just $! s' `seq` p' `seq` (s', p')+ rewrap (tp, ts, (s, p)) = (Shadowed p0 tp, Shadowed p ts, s)+ span_ bt fc (Shadowed p0 t) = rewrap $ Textual.span_ bt fc t+ where rewrap (tp, ts) = (Shadowed p0 tp, Shadowed (p0 <> tp) ts)+ break_ bt fc (Shadowed p0 t) = rewrap $ Textual.break_ bt fc t+ where rewrap (tp, ts) = (Shadowed p0 tp, Shadowed (p0 <> tp) ts)+ dropWhile_ bt fc t = snd (span_ bt fc t)+ takeWhile_ bt fc (Shadowed p t) = Shadowed p (takeWhile_ bt fc t)+ toString ft (Shadowed _ t) = toString (ft . shadowed) t+ toText ft (Shadowed _ t) = toText (ft . shadowed) t++ {-# INLINE characterPrefix #-}+ {-# INLINE splitCharacterPrefix #-}+ {-# INLINE map #-}+ {-# INLINE concatMap #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINABLE spanMaybe #-}+ {-# INLINABLE spanMaybe' #-}+ {-# INLINABLE span #-}+ {-# INLINE foldl_' #-}+ {-# INLINE foldr_ #-}+ {-# INLINE any #-}+ {-# INLINE all #-}+ {-# INLINABLE spanMaybe_ #-}+ {-# INLINABLE spanMaybe_' #-}+ {-# INLINE span_ #-}+ {-# INLINE break_ #-}+ {-# INLINE dropWhile_ #-}+ {-# INLINE takeWhile_ #-}+ {-# INLINE split #-}+ {-# INLINE find #-}
+ src/Data/Monoid/Instances/Stateful.hs view
@@ -0,0 +1,242 @@+{-+ Copyright 2013-2022 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the monoid transformer data type 'Stateful'.+--+-- >> let s = setState [4] $ pure "data" :: Stateful [Int] String+-- >> s+-- >Stateful ("data",[4])+-- >> factors s+-- >[Stateful ("d",[]),Stateful ("a",[]),Stateful ("t",[]),Stateful ("a",[]),Stateful ("",[4])]++{-# LANGUAGE Haskell2010, DeriveDataTypeable #-}++module Data.Monoid.Instances.Stateful (+ Stateful(Stateful), extract, state, setState+ )+where++import Control.Applicative -- (Applicative(..))+import Data.Data (Data, Typeable)+import Data.Functor -- ((<$>))+import qualified Data.List as List+import Data.String (IsString(..))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(..))+import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..))+import Data.Semigroup.Factorial (Factorial(..), StableFactorial)+import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..))+import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)+import Data.Monoid.Factorial (FactorialMonoid(..))+import Data.Monoid.Textual (TextualMonoid(..))+import qualified Data.Semigroup.Factorial as Factorial+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual++import Prelude hiding (all, any, break, elem, drop, filter, foldl, foldl1, foldr, foldr1, gcd, map, concatMap,+ length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, take)++-- | @'Stateful' a b@ is a wrapper around the 'Monoid' @b@ that carries the state @a@ along. The state type @a@ must be+-- a monoid as well if 'Stateful' is to be of any use. In the 'FactorialMonoid' and 'TextualMonoid' class instances, the+-- monoid @b@ has the priority and the state @a@ is left for the end.+newtype Stateful a b = Stateful (b, a) deriving (Data, Eq, Ord, Show, Typeable)++extract :: Stateful a b -> b+extract (Stateful (t, _)) = t++state :: Stateful a b -> a+state (Stateful (_, x)) = x++setState :: a -> Stateful a b -> Stateful a b+setState s (Stateful (t, _)) = Stateful (t, s)++instance Functor (Stateful a) where+ fmap f (Stateful (x, s)) = Stateful (f x, s)++instance Monoid a => Applicative (Stateful a) where+ pure m = Stateful (m, mempty)+ Stateful (f, s1) <*> Stateful (x, s2) = Stateful (f x, mappend s1 s2)++instance (Semigroup a, Semigroup b) => Semigroup (Stateful a b) where+ Stateful x <> Stateful y = Stateful (x <> y)+ {-# INLINE (<>) #-}++instance (Semigroup a, Semigroup b, Monoid a, Monoid b) => Monoid (Stateful a b) where+ mempty = Stateful mempty+ mappend = (<>)+ {-# INLINE mempty #-}+ {-# INLINE mappend #-}++instance (Semigroup a, Semigroup b, MonoidNull a, MonoidNull b) => MonoidNull (Stateful a b) where+ null (Stateful x) = null x+ {-# INLINE null #-}++instance (Semigroup a, Semigroup b, PositiveMonoid a, PositiveMonoid b) => PositiveMonoid (Stateful a b)++instance (LeftReductive a, LeftReductive b) => LeftReductive (Stateful a b) where+ isPrefixOf (Stateful x) (Stateful x') = isPrefixOf x x'+ stripPrefix (Stateful x) (Stateful x') = Stateful <$> stripPrefix x x'+ {-# INLINE isPrefixOf #-}+ {-# INLINE stripPrefix #-}++instance (RightReductive a, RightReductive b) => RightReductive (Stateful a b) where+ isSuffixOf (Stateful x) (Stateful x') = isSuffixOf x x'+ stripSuffix (Stateful x) (Stateful x') = Stateful <$> stripSuffix x x'+ {-# INLINE stripSuffix #-}+ {-# INLINE isSuffixOf #-}++instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (Stateful a b) where+ commonPrefix (Stateful x) (Stateful x') = Stateful (commonPrefix x x')+ stripCommonPrefix (Stateful x) (Stateful x') = (Stateful prefix, Stateful suffix1, Stateful suffix2)+ where (prefix, suffix1, suffix2) = stripCommonPrefix x x'+ {-# INLINE commonPrefix #-}+ {-# INLINE stripCommonPrefix #-}++instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (Stateful a b) where+ commonSuffix (Stateful x) (Stateful x') = Stateful (commonSuffix x x')+ {-# INLINE commonSuffix #-}++instance (FactorialMonoid a, FactorialMonoid b) => Factorial (Stateful a b) where+ factors (Stateful x) = List.map Stateful (factors x)+ length (Stateful x) = length x+ reverse (Stateful x) = Stateful (reverse x)+ primePrefix (Stateful x) = Stateful (primePrefix x)+ primeSuffix (Stateful x) = Stateful (primeSuffix x)+ foldl f a0 (Stateful x) = Factorial.foldl f' a0 x+ where f' a x1 = f a (Stateful x1)+ foldl' f a0 (Stateful x) = Factorial.foldl' f' a0 x+ where f' a x1 = f a (Stateful x1)+ foldr f a (Stateful x) = Factorial.foldr (f . Stateful) a x+ foldMap f (Stateful x) = Factorial.foldMap (f . Stateful) x+ {-# INLINE primePrefix #-}+ {-# INLINE primeSuffix #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE foldMap #-}+ {-# INLINE length #-}++instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (Stateful a b) where+ splitPrimePrefix (Stateful x) = do (xp, xs) <- splitPrimePrefix x+ return (Stateful xp, Stateful xs)+ splitPrimeSuffix (Stateful x) = do (xp, xs) <- splitPrimeSuffix x+ return (Stateful xp, Stateful xs)+ span p (Stateful x) = (Stateful xp, Stateful xs)+ where (xp, xs) = Factorial.span (p . Stateful) x+ spanMaybe s0 f (Stateful x) = (Stateful xp, Stateful xs, s')+ where (xp, xs, s') = Factorial.spanMaybe s0 f' x+ f' s x1 = f s (Stateful x1)+ spanMaybe' s0 f (Stateful x) = (Stateful xp, Stateful xs, s')+ where (xp, xs, s') = Factorial.spanMaybe' s0 f' x+ f' s x1 = f s (Stateful x1)+ split p (Stateful x) = List.map Stateful (Factorial.split (p . Stateful) x)+ splitAt n (Stateful x) = (Stateful xp, Stateful xs)+ where (xp, xs) = splitAt n x+ take n (Stateful x) = Stateful (take n x)+ drop n (Stateful x) = Stateful (drop n x)+ {-# INLINE splitPrimePrefix #-}+ {-# INLINE splitPrimeSuffix #-}+ {-# INLINE span #-}+ {-# INLINE spanMaybe #-}+ {-# INLINE spanMaybe' #-}+ {-# INLINE splitAt #-}+ {-# INLINE take #-}+ {-# INLINE drop #-}++instance (FactorialMonoid a, FactorialMonoid b, StableFactorial a, StableFactorial b) => StableFactorial (Stateful a b)++instance (Monoid a, IsString b) => IsString (Stateful a b) where+ fromString = pure . fromString++instance (LeftGCDMonoid a, FactorialMonoid a, TextualMonoid b) => TextualMonoid (Stateful a b) where+ fromText t = Stateful (fromText t, mempty)+ singleton c = Stateful (singleton c, mempty)++ characterPrefix = characterPrefix . extract+ splitCharacterPrefix (Stateful (t, x)) = do (c, t') <- splitCharacterPrefix t+ return (c, Stateful (t', x))++ map f (Stateful (t, x)) = Stateful (Textual.map f t, x)+ all p = all p . extract+ any p = any p . extract++ foldl fx fc a0 (Stateful (t, x)) = Factorial.foldl f2 (Textual.foldl f1 fc a0 t) x+ where f1 a = fx a . fromFst+ f2 a = fx a . fromSnd+ foldr fx fc a (Stateful (t, x)) = Textual.foldr (fx . fromFst) fc (Factorial.foldr (fx . fromSnd) a x) t+ foldl' fx fc a0 (Stateful (t, x)) = a' `seq` Factorial.foldl' f2 a' x+ where a' = Textual.foldl' f1 fc a0 t+ f1 a = fx a . fromFst+ f2 a = fx a . fromSnd+ foldl_' fc a (Stateful (t, _)) = foldl_' fc a t+ foldr_ fc a (Stateful (t, _)) = Textual.foldr_ fc a t+ toString fx (Stateful (t, x)) = toString (fx . fromFst) t ++ Factorial.foldMap (fx . fromSnd) x++ scanl f c (Stateful (t, x)) = Stateful (Textual.scanl f c t, x)+ scanl1 f (Stateful (t, x)) = Stateful (Textual.scanl1 f t, x)+ scanr f c (Stateful (t, x)) = Stateful (Textual.scanr f c t, x)+ scanr1 f (Stateful (t, x)) = Stateful (Textual.scanr1 f t, x)+ mapAccumL f a (Stateful (t, x)) = (a', Stateful (t', x))+ where (a', t') = Textual.mapAccumL f a t+ mapAccumR f a (Stateful (t, x)) = (a', Stateful (t', x))+ where (a', t') = Textual.mapAccumR f a t++ span pt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs))+ where (tp, ts) = Textual.span (pt . fromFst) pc t+ (xp, xs) | null ts = Factorial.span (pt . fromSnd) x+ | otherwise = (mempty, x)+ span_ bt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs))+ where (tp, ts) = Textual.span_ bt pc t+ (xp, xs) | null ts && bt = (x, mempty)+ | otherwise = (mempty, x)+ break pt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs))+ where (tp, ts) = Textual.break (pt . fromFst) pc t+ (xp, xs) | null ts = Factorial.break (pt . fromSnd) x+ | otherwise = (mempty, x)+ spanMaybe s0 ft fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s'')+ where (tp, ts, s') = Textual.spanMaybe s0 ft' fc t+ (xp, xs, s'') | null ts = Factorial.spanMaybe s' ft'' x+ | otherwise = (mempty, x, s')+ ft' s t1 = ft s (Stateful (t1, mempty))+ ft'' s x1 = ft s (Stateful (mempty, x1))+ spanMaybe' s0 ft fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s'')+ where (tp, ts, s') = Textual.spanMaybe' s0 ft' fc t+ (xp, xs, s'') | null ts = Factorial.spanMaybe' s' ft'' x+ | otherwise = (mempty, x, s')+ ft' s t1 = ft s (Stateful (t1, mempty))+ ft'' s x1 = ft s (Stateful (mempty, x1))+ spanMaybe_' s0 fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s')+ where (tp, ts, s') = Textual.spanMaybe_' s0 fc t+ (xp, xs) | null ts = (x, mempty)+ | otherwise = (mempty, x)+ split p (Stateful (t, x)) = restore id ts+ where ts = Textual.split p t+ restore f [t1] = f [Stateful (t1, x)]+ restore f ~(hd:tl) = restore (f . (Stateful (hd, mempty):)) tl+ find p = find p . extract+ elem c = elem c . extract++ {-# INLINE characterPrefix #-}+ {-# INLINE splitCharacterPrefix #-}+ {-# INLINE map #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE spanMaybe' #-}+ {-# INLINE span #-}+ {-# INLINE spanMaybe_' #-}+ {-# INLINE span_ #-}+ {-# INLINE any #-}+ {-# INLINE all #-}+ {-# INLINE split #-}+ {-# INLINE find #-}+ {-# INLINE elem #-}++{-# INLINE fromFst #-}+fromFst :: Monoid b => a -> Stateful b a+fromFst a = Stateful (a, mempty)++{-# INLINE fromSnd #-}+fromSnd :: Monoid a => b -> Stateful b a+fromSnd b = Stateful (mempty, b)
+ src/Data/Monoid/LCM.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE Haskell2010, FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | This module defines the 'LCMMonoid' subclass of the 'Monoid' class.+--+-- The 'LCMMonoid' subclass adds the 'lcm' operation, which takes two monoidal+-- arguments and finds their /least common multiple/, or (more generally) the+-- least monoid from which either argument can be subtracted with the '</>'+-- operation.+--+-- For LCM monoids that are distributive, this module also provides the+-- 'DistributiveLCMMonoid' subclass of 'LCMMonoid'.+--+-- All classes in this module are for Abelian, /i.e./, 'Commutative' monoids.+--+module Data.Monoid.LCM+ ( LCMMonoid (..)+ , DistributiveLCMMonoid+ )+ where++import Prelude hiding (gcd, lcm, max)+import qualified Prelude++import Data.Functor.Const (Const (Const))+import Data.Functor.Identity (Identity (Identity))+import Data.IntSet (IntSet)+import Data.Monoid (Dual (..), Product (..), Sum (..))+import Data.Monoid.GCD (GCDMonoid (..), DistributiveGCDMonoid)+import Data.Set (Set)+import Numeric.Natural (Natural)+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set++-- These imports are marked as redundant, but are actually required by haddock:+import Data.Maybe (isJust)+import Data.Semigroup.Cancellative (Reductive ((</>)))+import Data.Semigroup.Commutative (Commutative)++--------------------------------------------------------------------------------+-- LCMMonoid+--------------------------------------------------------------------------------++-- | Class of Abelian monoids that allow the /least common multiple/ to be+-- found for any two given values.+--+-- Operations must satisfy the following laws:+--+-- __/Reductivity/__+--+-- @+-- 'isJust' ('lcm' a b '</>' a)+-- @+-- @+-- 'isJust' ('lcm' a b '</>' b)+-- @+--+-- __/Uniqueness/__+--+-- @+-- 'all' 'isJust'+-- [ \ \ c '</>' a+-- , \ \ c '</>' b+-- , 'lcm' a b '</>' c+-- ]+-- ==>+-- ('lcm' a b '==' c)+-- @+--+-- __/Idempotence/__+--+-- @+-- 'lcm' a a '==' a+-- @+--+-- __/Identity/__+--+-- @+-- 'lcm' 'mempty' a '==' a+-- @+-- @+-- 'lcm' a 'mempty' '==' a+-- @+--+-- __/Commutativity/__+--+-- @+-- 'lcm' a b '==' 'lcm' b a+-- @+--+-- __/Associativity/__+--+-- @+-- 'lcm' ('lcm' a b) c '==' 'lcm' a ('lcm' b c)+-- @+--+-- __/Absorption/__+--+-- @+-- 'lcm' a ('gcd' a b) '==' a+-- @+-- @+-- 'gcd' a ('lcm' a b) '==' a+-- @+--+class GCDMonoid m => LCMMonoid m where+ lcm :: m -> m -> m++instance LCMMonoid () where+ lcm () () = ()++deriving instance LCMMonoid a => LCMMonoid (Identity a)++deriving instance LCMMonoid a => LCMMonoid (Const a b)++instance LCMMonoid a => LCMMonoid (Dual a) where+ lcm (Dual a) (Dual b) = Dual (lcm a b)++instance LCMMonoid (Product Natural) where+ lcm (Product a) (Product b) = Product (Prelude.lcm a b)++instance LCMMonoid (Sum Natural) where+ lcm (Sum a) (Sum b) = Sum (Prelude.max a b)++instance Ord a => LCMMonoid (Set a) where+ lcm = Set.union++instance LCMMonoid IntSet where+ lcm = IntSet.union++instance (LCMMonoid a, LCMMonoid b) => LCMMonoid (a, b) where+ lcm (a0, a1) (b0, b1) =+ (lcm a0 b0, lcm a1 b1)++instance (LCMMonoid a, LCMMonoid b, LCMMonoid c) => LCMMonoid (a, b, c) where+ lcm (a0, a1, a2) (b0, b1, b2) =+ (lcm a0 b0, lcm a1 b1, lcm a2 b2)++instance (LCMMonoid a, LCMMonoid b, LCMMonoid c, LCMMonoid d) =>+ LCMMonoid (a, b, c, d)+ where+ lcm (a0, a1, a2, a3) (b0, b1, b2, b3) =+ (lcm a0 b0, lcm a1 b1, lcm a2 b2, lcm a3 b3)++--------------------------------------------------------------------------------+-- DistributiveLCMMonoid+--------------------------------------------------------------------------------++-- | Class of /commutative/ LCM monoids with /distributivity/.+--+-- In addition to the general 'LCMMonoid' laws, instances of this class+-- must also satisfy the following laws:+--+-- The 'lcm' operation itself must be /both/ left-distributive /and/+-- right-distributive:+--+-- @+-- 'lcm' (a '<>' b) (a '<>' c) '==' a '<>' 'lcm' b c+-- @+-- @+-- 'lcm' (a '<>' c) (b '<>' c) '==' 'lcm' a b '<>' c+-- @+--+-- The 'lcm' and 'gcd' operations must distribute over one another:+--+-- @+-- 'lcm' a ('gcd' b c) '==' 'gcd' ('lcm' a b) ('lcm' a c)+-- @+-- @+-- 'gcd' a ('lcm' b c) '==' 'lcm' ('gcd' a b) ('gcd' a c)+-- @+--+class (DistributiveGCDMonoid m, LCMMonoid m) => DistributiveLCMMonoid m++instance DistributiveLCMMonoid ()+instance DistributiveLCMMonoid a => DistributiveLCMMonoid (Identity a)+instance DistributiveLCMMonoid a => DistributiveLCMMonoid (Const a b)+instance DistributiveLCMMonoid (Product Natural)+instance DistributiveLCMMonoid (Sum Natural)+instance DistributiveLCMMonoid IntSet+instance Ord a => DistributiveLCMMonoid (Set a)+instance DistributiveLCMMonoid a => DistributiveLCMMonoid (Dual a)
+ src/Data/Monoid/Monus.hs view
@@ -0,0 +1,400 @@+{-+ Copyright 2013-2019 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'OverlappingGCDMonoid' => 'Monus' subclass of the 'Monoid' class.+--+-- @since 1.0++{-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.Monoid.Monus (+ Monus(..), OverlappingGCDMonoid(..)+ )+where++import Data.Functor.Const (Const (Const))+import Data.Functor.Identity (Identity (Identity))+import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..))+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LazyText+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Sequence as Sequence+import qualified Data.Set as Set+import Data.Sequence (ViewL((:<)), (|>))+import qualified Data.Vector as Vector+import Numeric.Natural (Natural)++import Data.Semigroup.Cancellative+import Data.Monoid.Null (MonoidNull(null))++import Prelude hiding (null)++-- | Class of Abelian monoids with monus.+--+-- The monus operation '<\>' is a synonym for both 'stripPrefixOverlap' and+-- 'stripSuffixOverlap', which must be equivalent as '<>' is both associative+-- and commutative:+--+-- > (<\>) = flip stripPrefixOverlap+-- > (<\>) = flip stripSuffixOverlap+--+-- In addition, the monus operation '<\>' must satisfy the following laws:+--+-- @+-- a '<\>' a '==' 'mempty'+-- @+--+-- @+-- 'mempty' '<\>' a '==' 'mempty'+-- @+--+-- @+-- a '<>' (b '<\>' a) '==' b '<>' (a '<\>' b)+-- @+--+-- @+-- (a '<\>' b) '<\>' c '==' a '<\>' (b '<>' c)+-- @+--+-- @since 1.0+class (Commutative m, Monoid m, OverlappingGCDMonoid m) => Monus m where+ (<\>) :: m -> m -> m++infix 5 <\>++-- | Class of monoids for which the greatest overlap can be found between any two values, such that+--+-- > a == a' <> overlap a b+-- > b == overlap a b <> b'+--+-- The methods must satisfy the following laws:+--+-- > stripOverlap a b == (stripSuffixOverlap b a, overlap a b, stripPrefixOverlap a b)+-- > stripSuffixOverlap b a <> overlap a b == a+-- > overlap a b <> stripPrefixOverlap a b == b+--+-- The result of @overlap a b@ must be the largest prefix of @b@ and suffix of @a@, in the sense that it contains any+-- other value @x@ that satifies the property @(x `isPrefixOf` b) && (x `isSuffixOf` a)@:+--+-- > ∀x. (x `isPrefixOf` b && x `isSuffixOf` a) => (x `isPrefixOf` overlap a b && x `isSuffixOf` overlap a b)+--+-- and it must be unique so there's no other value @y@ that satisfies the same properties for every such @x@:+--+-- > ∀y. ((∀x. (x `isPrefixOf` b && x `isSuffixOf` a) => x `isPrefixOf` y && x `isSuffixOf` y) => y == overlap a b)+--+-- @since 1.0+--+-- In addition, the 'overlap' operation must satisfy the following properties:+--+-- __/Idempotence/__+--+-- @+-- 'overlap' a a '==' a+-- @+--+-- __/Identity/__+--+-- @+-- 'overlap' 'mempty' a '==' 'mempty'+-- @+-- @+-- 'overlap' a 'mempty' '==' 'mempty'+-- @+--+class (Monoid m, LeftReductive m, RightReductive m) => OverlappingGCDMonoid m where+ stripPrefixOverlap :: m -> m -> m+ stripSuffixOverlap :: m -> m -> m+ overlap :: m -> m -> m+ stripOverlap :: m -> m -> (m, m, m)++ stripPrefixOverlap a b = b'+ where (_, _, b') = stripOverlap a b+ stripSuffixOverlap a b = b'+ where (b', _, _) = stripOverlap b a+ overlap a b = o+ where (_, o, _) = stripOverlap a b+ {-# MINIMAL stripOverlap #-}++-- Unit instances++-- | /O(1)/+instance Monus () where+ () <\> () = ()++-- | /O(1)/+instance OverlappingGCDMonoid () where+ overlap () () = ()+ stripOverlap () () = ((), (), ())+ stripPrefixOverlap () () = ()+ stripSuffixOverlap () () = ()++-- Identity instances++deriving instance Monus a => Monus (Identity a)+deriving instance OverlappingGCDMonoid a => OverlappingGCDMonoid (Identity a)++-- Const instances++deriving instance Monus a => Monus (Const a b)+deriving instance OverlappingGCDMonoid a => OverlappingGCDMonoid (Const a b)++-- Dual instances++instance Monus a => Monus (Dual a) where+ Dual a <\> Dual b = Dual (a <\> b)++instance OverlappingGCDMonoid a => OverlappingGCDMonoid (Dual a) where+ overlap (Dual a) (Dual b) = Dual (overlap b a)+ stripOverlap (Dual a) (Dual b) = (Dual s, Dual o, Dual p)+ where (p, o, s) = stripOverlap b a+ stripPrefixOverlap (Dual a) (Dual b) = Dual (stripSuffixOverlap a b)+ stripSuffixOverlap (Dual a) (Dual b) = Dual (stripPrefixOverlap a b)++-- Sum instances++-- | /O(1)/+instance Monus (Sum Natural) where+ Sum a <\> Sum b+ | a > b = Sum (a - b)+ | otherwise = Sum 0++-- | /O(1)/+instance OverlappingGCDMonoid (Sum Natural) where+ overlap (Sum a) (Sum b) = Sum (min a b)+ stripOverlap (Sum a) (Sum b) = (Sum $ a - c, Sum c, Sum $ b - c)+ where c = min a b+ stripPrefixOverlap = flip (<\>)+ stripSuffixOverlap = flip (<\>)++-- Product instances++-- | /O(1)/+instance Monus (Product Natural) where+ Product 0 <\> Product 0 = Product 1+ Product a <\> Product b = Product (a `div` Prelude.gcd a b)++-- | /O(1)/+instance OverlappingGCDMonoid (Product Natural) where+ overlap (Product a) (Product b) = Product (gcd a b)+ stripOverlap (Product 0) (Product 0) = (Product 1, Product 0, Product 1)+ stripOverlap (Product a) (Product b) = (Product $ div a c, Product c, Product $ div b c)+ where c = gcd a b+ stripPrefixOverlap = flip (<\>)+ stripSuffixOverlap = flip (<\>)++-- Pair instances++instance (Monus a, Monus b) => Monus (a, b) where+ (a1, b1) <\> (a2, b2) = (a1 <\> a2, b1 <\> b2)++instance (OverlappingGCDMonoid a, OverlappingGCDMonoid b) => OverlappingGCDMonoid (a, b) where+ overlap (a1, b1) (a2, b2) = (overlap a1 a2, overlap b1 b2)+ stripOverlap (a1, b1) (a2, b2) = ((ap, bp), (ao, bo), (as, bs))+ where (ap, ao, as) = stripOverlap a1 a2+ (bp, bo, bs) = stripOverlap b1 b2+ stripPrefixOverlap (a1, b1) (a2, b2) = (stripPrefixOverlap a1 a2, stripPrefixOverlap b1 b2)+ stripSuffixOverlap (a1, b1) (a2, b2) = (stripSuffixOverlap a1 a2, stripSuffixOverlap b1 b2)++-- Triple instances++instance (Monus a, Monus b, Monus c) => Monus (a, b, c) where+ (a1, b1, c1) <\> (a2, b2, c2) = (a1 <\> a2, b1 <\> b2, c1 <\> c2)++instance (OverlappingGCDMonoid a, OverlappingGCDMonoid b, OverlappingGCDMonoid c) =>+ OverlappingGCDMonoid (a, b, c) where+ overlap (a1, b1, c1) (a2, b2, c2) = (overlap a1 a2, overlap b1 b2, overlap c1 c2)+ stripOverlap (a1, b1, c1) (a2, b2, c2) = ((ap, bp, cp), (ao, bo, co), (as, bs, cs))+ where (ap, ao, as) = stripOverlap a1 a2+ (bp, bo, bs) = stripOverlap b1 b2+ (cp, co, cs) = stripOverlap c1 c2+ stripPrefixOverlap (a1, b1, c1) (a2, b2, c2) = (stripPrefixOverlap a1 a2, stripPrefixOverlap b1 b2, stripPrefixOverlap c1 c2)+ stripSuffixOverlap (a1, b1, c1) (a2, b2, c2) = (stripSuffixOverlap a1 a2, stripSuffixOverlap b1 b2, stripSuffixOverlap c1 c2)++-- Quadruple instances++instance (Monus a, Monus b, Monus c, Monus d) => Monus (a, b, c, d) where+ (a1, b1, c1, d1) <\> (a2, b2, c2, d2) = (a1 <\> a2, b1 <\> b2, c1 <\> c2, d1 <\> d2)++instance (OverlappingGCDMonoid a, OverlappingGCDMonoid b, OverlappingGCDMonoid c, OverlappingGCDMonoid d) =>+ OverlappingGCDMonoid (a, b, c, d) where+ overlap (a1, b1, c1, d1) (a2, b2, c2, d2) = (overlap a1 a2, overlap b1 b2, overlap c1 c2, overlap d1 d2)+ stripOverlap (a1, b1, c1, d1) (a2, b2, c2, d2) = ((ap, bp, cp, dp), (ao, bo, co, dm), (as, bs, cs, ds))+ where (ap, ao, as) = stripOverlap a1 a2+ (bp, bo, bs) = stripOverlap b1 b2+ (cp, co, cs) = stripOverlap c1 c2+ (dp, dm, ds) = stripOverlap d1 d2+ stripPrefixOverlap (a1, b1, c1, d1) (a2, b2, c2, d2) =+ (stripPrefixOverlap a1 a2, stripPrefixOverlap b1 b2, stripPrefixOverlap c1 c2, stripPrefixOverlap d1 d2)+ stripSuffixOverlap (a1, b1, c1, d1) (a2, b2, c2, d2) =+ (stripSuffixOverlap a1 a2, stripSuffixOverlap b1 b2, stripSuffixOverlap c1 c2, stripSuffixOverlap d1 d2)++-- Maybe instances++instance (Monus a, MonoidNull a) => Monus (Maybe a) where+ Just a <\> Just b+ | null remainder = Nothing+ | otherwise = Just remainder+ where+ remainder = a <\> b+ Nothing <\> _ = Nothing+ x <\> Nothing = x++instance (OverlappingGCDMonoid a, MonoidNull a) => OverlappingGCDMonoid (Maybe a) where+ overlap (Just a) (Just b) = Just (overlap a b)+ overlap _ _ = Nothing+ stripOverlap (Just a) (Just b) = (if null a' then Nothing else Just a', Just o, if null b' then Nothing else Just b')+ where (a', o, b') = stripOverlap a b+ stripOverlap a b = (a, Nothing, b)+ stripPrefixOverlap (Just a) (Just b)+ | null b' = Nothing+ | otherwise = Just b'+ where b' = stripPrefixOverlap a b+ stripPrefixOverlap Nothing x = x+ stripPrefixOverlap _ Nothing = Nothing+ stripSuffixOverlap (Just a) (Just b)+ | null b' = Nothing+ | otherwise = Just b'+ where b' = stripSuffixOverlap a b+ stripSuffixOverlap Nothing x = x+ stripSuffixOverlap _ Nothing = Nothing++-- Set instances++-- | /O(m*log(n/m + 1)), m <= n/+instance Ord a => Monus (Set.Set a) where+ (<\>) = (Set.\\)++-- | /O(m*log(n/m + 1)), m <= n/+instance Ord a => OverlappingGCDMonoid (Set.Set a) where+ overlap = Set.intersection+ stripOverlap a b = (Set.difference a b, Set.intersection a b, Set.difference b a)+ stripPrefixOverlap a b = b <\> a+ stripSuffixOverlap a b = b <\> a++-- IntSet instances++-- | /O(m+n)/+instance Monus IntSet.IntSet where+ (<\>) = (IntSet.\\)++-- | /O(m+n)/+instance OverlappingGCDMonoid IntSet.IntSet where+ overlap = IntSet.intersection+ stripOverlap a b = (IntSet.difference a b, IntSet.intersection a b, IntSet.difference b a)+ stripPrefixOverlap a b = b <\> a+ stripSuffixOverlap a b = b <\> a++-- Map instances++-- | /O(m+n)/+instance (Ord k, Eq v) => OverlappingGCDMonoid (Map.Map k v) where+ overlap = flip Map.intersection+ stripOverlap a b = (stripSuffixOverlap b a, overlap a b, stripPrefixOverlap a b)+ stripPrefixOverlap = flip Map.difference+ stripSuffixOverlap a b = Map.differenceWith (\x y-> if x == y then Nothing else Just x) b a++-- IntMap instances++-- | /O(m+n)/+instance Eq a => OverlappingGCDMonoid (IntMap.IntMap a) where+ overlap = flip IntMap.intersection+ stripOverlap a b = (stripSuffixOverlap b a, overlap a b, stripPrefixOverlap a b)+ stripPrefixOverlap = flip IntMap.difference+ stripSuffixOverlap a b = IntMap.differenceWith (\x y-> if x == y then Nothing else Just x) b a++-- List instances++-- | /O(m*n)/+instance Eq a => OverlappingGCDMonoid [a] where+ overlap a b = go a+ where go x | x `isPrefixOf` b = x+ | otherwise = go (tail x)+ stripOverlap a b = go [] a+ where go p o | Just s <- stripPrefix o b = (reverse p, o, s)+ | x:xs <- o = go (x:p) xs+ | otherwise = error "impossible"+ stripPrefixOverlap a b = go a+ where go x | Just s <- stripPrefix x b = s+ | otherwise = go (tail x)++-- Seq instances++-- | /O(min(m,n)^2)/+instance Eq a => OverlappingGCDMonoid (Sequence.Seq a) where+ overlap a b = go (Sequence.drop (Sequence.length a - Sequence.length b) a)+ where go x | x `isPrefixOf` b = x+ | _ :< x' <- Sequence.viewl x = go x'+ | otherwise = error "impossible"+ stripOverlap a b = uncurry go (Sequence.splitAt (Sequence.length a - Sequence.length b) a)+ where go p o | Just s <- stripPrefix o b = (p, o, s)+ | x :< xs <- Sequence.viewl o = go (p |> x) xs+ | otherwise = error "impossible"++-- Vector instances++-- | /O(min(m,n)^2)/+instance Eq a => OverlappingGCDMonoid (Vector.Vector a) where+ stripOverlap a b = go (max alen blen)+ where alen = Vector.length a+ blen = Vector.length b+ go i | as == bp = (ap, as, bs)+ | otherwise = go (pred i)+ where (ap, as) = Vector.splitAt (alen - i) a+ (bp, bs) = Vector.splitAt i b++-- ByteString instances++-- | /O(min(m,n)^2)/+instance OverlappingGCDMonoid ByteString.ByteString where+ stripOverlap a b = go (max alen blen)+ where alen = ByteString.length a+ blen = ByteString.length b+ go i | as == bp = (ap, as, bs)+ | otherwise = go (pred i)+ where (ap, as) = ByteString.splitAt (alen - i) a+ (bp, bs) = ByteString.splitAt i b++-- Lazy ByteString instances++-- | /O(m*n)/+instance OverlappingGCDMonoid LazyByteString.ByteString where+ stripOverlap a b = go (max alen blen)+ where alen = LazyByteString.length a+ blen = LazyByteString.length b+ go i | as == bp = (ap, as, bs)+ | otherwise = go (pred i)+ where (ap, as) = LazyByteString.splitAt (alen - i) a+ (bp, bs) = LazyByteString.splitAt i b++-- Text instances++-- | /O(min(m,n)^2)/+instance OverlappingGCDMonoid Text.Text where+ stripOverlap a b+ | Text.null b = (a, b, b)+ | otherwise = go (Text.breakOnAll (Text.take 1 b) a)+ where go [] = (a, mempty, b)+ go ((ap, as):breaks)+ | Just bs <- Text.stripPrefix as b = (ap, as, bs)+ | otherwise = go breaks++-- Lazy Text instances++-- | /O(m*n)/+instance OverlappingGCDMonoid LazyText.Text where+ stripOverlap a b+ | LazyText.null b = (a, b, b)+ | otherwise = go (LazyText.breakOnAll (LazyText.take 1 b) a)+ where go [] = (a, mempty, b)+ go ((ap, as):breaks)+ | Just bs <- LazyText.stripPrefix as b = (ap, as, bs)+ | otherwise = go breaks
+ src/Data/Monoid/Null.hs view
@@ -0,0 +1,270 @@+{-+ Copyright 2013-2015 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the MonoidNull class and some of its instances.+--++{-# LANGUAGE Haskell2010, CPP, FlexibleInstances, DefaultSignatures, Trustworthy #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.Monoid.Null (+ MonoidNull(..), PositiveMonoid+ )+where++import Data.Functor.Compose (Compose(..))+import Data.Functor.Const (Const(..))+import Data.Functor.Identity (Identity(..))+import Data.Monoid -- (Monoid, First(..), Last(..), Dual(..), Sum(..), Product(..), All(getAll), Any(getAny))+import Data.Ord (Down(..))+import Data.Proxy (Proxy)+import Data.Semigroup (Max, Min, WrappedMonoid(..))+import qualified Data.Functor.Product as Functor+import qualified Data.List as List+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LazyText+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Sequence as Sequence+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import GHC.Generics ((:*:)(..), (:.:)(..), K1(..), M1(..), Par1(..), Rec1(..), U1)+import Numeric.Natural (Natural)++import Prelude hiding (null)++-- | Extension of 'Monoid' that allows testing a value for equality with 'mempty'. The following law must hold:+--+-- prop> null x == (x == mempty)+--+-- Furthermore, the performance of this method should be constant, /i.e./, independent of the length of its argument.+class Monoid m => MonoidNull m where+ null :: m -> Bool+ default null :: Eq m => m -> Bool+ null = (==) mempty++-- | Subclass of 'Monoid' for types whose values have no inverse, with the exception of 'Data.Monoid.mempty'. More+-- formally, the class instances must satisfy the following law:+--+-- prop> null (x <> y) == (null x && null y)+class MonoidNull m => PositiveMonoid m++instance MonoidNull () where+ null () = True++instance MonoidNull Ordering where+ null = (== EQ)++instance MonoidNull All where+ null = getAll++instance MonoidNull Any where+ null = not . getAny++instance MonoidNull (First a) where+ null (First Nothing) = True+ null _ = False++instance MonoidNull (Last a) where+ null (Last Nothing) = True+ null _ = False++instance MonoidNull a => MonoidNull (Dual a) where+ null (Dual a) = null a++instance (Num a, Eq a) => MonoidNull (Sum a) where+ null (Sum a) = a == 0++instance (Num a, Eq a) => MonoidNull (Product a) where+ null (Product a) = a == 1++-- | @since 1.2.5.0+instance (Ord a, Bounded a) => MonoidNull (Max a)++-- | @since 1.2.5.0+instance (Ord a, Bounded a) => MonoidNull (Min a)++instance Monoid a => MonoidNull (Maybe a) where+ null Nothing = True+ null _ = False++#if MIN_VERSION_base(4, 11, 0)+-- | @since 1.2.5.0+instance MonoidNull a => MonoidNull (Down a) where+ null (Down a) = null a+#endif++#if MIN_VERSION_base(4, 12, 0)+-- | @since 1.2.5.0+instance MonoidNull c => MonoidNull (K1 i c p) where+ null (K1 c) = null c++-- | @since 1.2.5.0+instance MonoidNull (f p) => MonoidNull (M1 i c f p) where+ null (M1 fp) = null fp++-- | @since 1.2.5.0+instance MonoidNull p => MonoidNull (Par1 p) where+ null (Par1 p) = null p++-- | @since 1.2.5.0+instance MonoidNull (f p) => MonoidNull (Rec1 f p) where+ null (Rec1 fp) = null fp++-- | @since 1.2.5.0+instance MonoidNull (U1 p) where+ null _ = True++-- | @since 1.2.5.0+instance (MonoidNull (f p), MonoidNull (g p)) => MonoidNull ((:*:) f g p) where+ null (fp :*: gp) = null fp && null gp++-- | @since 1.2.5.0+instance (MonoidNull (f (g p))) => MonoidNull ((:.:) f g p) where+ null (Comp1 fgp) = null fgp+#endif++#if MIN_VERSION_base(4, 16, 0)+-- | @since 1.2.5.0+instance MonoidNull (f (g a)) => MonoidNull (Compose f g a) where+ null (Compose fga) = null fga++-- | @since 1.2.5.0+instance (MonoidNull (f a), MonoidNull (g a)) => MonoidNull (Functor.Product f g a) where+ null (Functor.Pair fa ga) = null fa && null ga+#endif++-- | @since 1.2.5.0+deriving instance MonoidNull a => MonoidNull (Const a b)++-- | @since 1.2.5.0+deriving instance MonoidNull a => MonoidNull (Identity a)++-- | @since 1.2.5.0+instance MonoidNull a => MonoidNull (WrappedMonoid a) where+ null (WrapMonoid a) = null a++-- | @since 1.2.5.0+instance MonoidNull (Proxy a) where+ null _ = True++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++-- | @since 1.2.5.0+instance (MonoidNull a, MonoidNull b, MonoidNull c, MonoidNull d, MonoidNull e) => MonoidNull (a, b, c, d, e) where+ null (a, b, c, d, e) = null a && null b && null c && null d && null e++instance MonoidNull [x] where+ null = List.null++instance MonoidNull ByteString.ByteString where+ null = ByteString.null+ {-# INLINE null #-}++instance MonoidNull LazyByteString.ByteString where+ null = LazyByteString.null+ {-# INLINE null #-}++instance MonoidNull Text.Text where+ null = Text.null+ {-# INLINE null #-}++instance MonoidNull LazyText.Text where+ null = LazyText.null+ {-# INLINE null #-}++instance Ord k => MonoidNull (Map.Map k v) where+ null = Map.null++instance MonoidNull (IntMap.IntMap v) where+ null = IntMap.null++instance MonoidNull IntSet.IntSet where+ null = IntSet.null++instance MonoidNull (Sequence.Seq a) where+ null = Sequence.null++instance Ord a => MonoidNull (Set.Set a) where+ null = Set.null++instance MonoidNull (Vector.Vector a) where+ null = Vector.null++instance PositiveMonoid ()+instance PositiveMonoid Ordering+instance PositiveMonoid All+instance PositiveMonoid Any+instance PositiveMonoid ByteString.ByteString+instance PositiveMonoid LazyByteString.ByteString+instance PositiveMonoid Text.Text+instance PositiveMonoid LazyText.Text+instance PositiveMonoid (Product Natural)+instance PositiveMonoid (Sum Natural)+-- | @since 1.2.5.0+instance (Ord a, Bounded a) => PositiveMonoid (Min a)+-- | @since 1.2.5.0+instance (Ord a, Bounded a) => PositiveMonoid (Max a)+instance Monoid a => PositiveMonoid (Maybe a)+instance PositiveMonoid (First a)+instance PositiveMonoid (Last a)+instance PositiveMonoid a => PositiveMonoid (Dual a)+instance PositiveMonoid [x]+instance Ord k => PositiveMonoid (Map.Map k v)+instance PositiveMonoid (IntMap.IntMap v)+instance PositiveMonoid IntSet.IntSet+instance PositiveMonoid (Sequence.Seq a)+instance Ord a => PositiveMonoid (Set.Set a)+instance PositiveMonoid (Vector.Vector a)+-- | @since 1.2.5.0+instance PositiveMonoid r => PositiveMonoid (Const r a)+-- | @since 1.2.5.0+instance PositiveMonoid a => PositiveMonoid (Identity a)+-- | @since 1.2.5.0+instance PositiveMonoid a => PositiveMonoid (WrappedMonoid a)+-- | @since 1.2.5.0+instance PositiveMonoid (Proxy a)++#if MIN_VERSION_base(4, 11, 0)+-- | @since 1.2.5.0+instance PositiveMonoid a => PositiveMonoid (Down a)+#endif++#if MIN_VERSION_base(4, 12, 0)+-- | @since 1.2.5.0+instance PositiveMonoid c => PositiveMonoid (K1 i c p)+-- | @since 1.2.5.0+instance PositiveMonoid (f p) => PositiveMonoid (M1 i c f p)+-- | @since 1.2.5.0+instance PositiveMonoid p => PositiveMonoid (Par1 p)+-- | @since 1.2.5.0+instance PositiveMonoid (f p) => PositiveMonoid (Rec1 f p)+-- | @since 1.2.5.0+instance PositiveMonoid (U1 p)+-- | @since 1.2.5.0+instance (PositiveMonoid (f (g p))) => PositiveMonoid ((:.:) f g p)+#endif++#if MIN_VERSION_base(4, 16, 0)+-- | @since 1.2.5.0+instance PositiveMonoid (f (g a)) => PositiveMonoid (Compose f g a)+#endif++-- 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)
+ src/Data/Monoid/Textual.hs view
@@ -0,0 +1,552 @@+{- + Copyright 2013-2017 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'TextualMonoid' class and several of its instances.+-- ++{-# LANGUAGE Haskell2010, FlexibleInstances #-}++module Data.Monoid.Textual (+ TextualMonoid(..)+ )+where++import qualified Data.Foldable as Foldable+import qualified Data.Traversable as Traversable+import Data.Functor -- ((<$>))+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LazyText+import Data.Text (Text)+import Data.Monoid -- (Monoid(mappend, mempty))+import qualified Data.Sequence as Sequence+import Data.String (IsString(fromString))+import Data.Int (Int64)++import Data.Semigroup.Cancellative (LeftReductive)+import Data.Monoid.GCD (LeftGCDMonoid)+import Data.Monoid.Factorial (FactorialMonoid)+import qualified Data.Monoid.Factorial as Factorial++import Prelude (Bool(..), Int, Char, String, Maybe(..), (.), ($), (==), (||), (&&),+ id, seq, succ, const, otherwise, maybe, fst, snd)++-- | The 'TextualMonoid' class is an extension of 'FactorialMonoid' specialized for monoids that can contain+-- characters. Its methods are generally equivalent to their namesake functions from "Data.List" and "Data.Text", and+-- they satisfy the following laws:+-- +-- > unfoldr splitCharacterPrefix . fromString == id+-- > splitCharacterPrefix . primePrefix == fmap (\(c, t)-> (c, mempty)) . splitCharacterPrefix+-- >+-- > map f . fromString == fromString . List.map f+-- > concatMap (fromString . f) . fromString == fromString . List.concatMap f+-- >+-- > foldl ft fc a . fromString == List.foldl fc a+-- > foldr ft fc a . fromString == List.foldr fc a+-- > foldl' ft fc a . fromString == List.foldl' fc a+-- >+-- > scanl f c . fromString == fromString . List.scanl f c+-- > scanr f c . fromString == fromString . List.scanr f c+-- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a+-- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a+-- >+-- > takeWhile pt pc . fromString == fromString . takeWhile pc+-- > dropWhile pt pc . fromString == fromString . dropWhile pc+-- >+-- > mconcat . intersperse (singleton c) . split (== c) == id+-- > find p . fromString == List.find p+-- > elem c . fromString == List.elem c+--+-- A 'TextualMonoid' may contain non-character data insterspersed between its characters. Every class method that+-- returns a modified 'TextualMonoid' instance generally preserves this non-character data. Methods like 'foldr' can+-- access both the non-character and character data and expect two arguments for the two purposes. For each of these+-- methods there is also a simplified version with underscore in name (like 'foldr_') that ignores the non-character+-- data.+--+-- All of the following expressions are identities:+--+-- > map id+-- > concatMap singleton+-- > foldl (<>) (\a c-> a <> singleton c) mempty+-- > foldr (<>) ((<>) . singleton) mempty+-- > foldl' (<>) (\a c-> a <> singleton c) mempty+-- > scanl1 (const id)+-- > scanr1 const+-- > uncurry (mapAccumL (,))+-- > uncurry (mapAccumR (,))+-- > takeWhile (const True) (const True)+-- > dropWhile (const False) (const False)+-- > toString undefined . fromString+-- > toText undefined . fromText++class (IsString t, LeftReductive t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where+ -- | Contructs a new data type instance Like 'fromString', but from a 'Text' input instead of 'String'.+ --+ -- > fromText == fromString . Text.unpack+ fromText :: Text -> t+ -- | Creates a prime monoid containing a single character.+ --+ -- > singleton c == fromString [c]+ singleton :: Char -> t+ -- | Specialized version of 'Factorial.splitPrimePrefix'. Every prime factor of a textual monoid must consist of a+ -- single character or no character at all.+ splitCharacterPrefix :: t -> Maybe (Char, t)+ -- | Extracts a single character that prefixes the monoid, if the monoid begins with a character. Otherwise returns+ -- 'Nothing'.+ --+ -- > characterPrefix == fmap fst . splitCharacterPrefix+ characterPrefix :: t -> Maybe Char+ -- | Equivalent to 'List.map' from "Data.List" with a @Char -> Char@ function. Preserves all non-character data.+ --+ -- > map f == concatMap (singleton . f)+ map :: (Char -> Char) -> t -> t+ -- | Equivalent to 'List.concatMap' from "Data.List" with a @Char -> String@ function. Preserves all non-character+ -- data.+ concatMap :: (Char -> t) -> t -> t+ -- | Returns the list of characters the monoid contains, once the argument function converts all its non-character+ -- factors into characters.+ toString :: (t -> String) -> t -> String+ -- | Converts the monoid into 'Text', given a function to convert the non-character factors into chunks of 'Text'.+ toText :: (t -> Text) -> t -> Text+ -- | Equivalent to 'List.any' from "Data.List". Ignores all non-character data.+ any :: (Char -> Bool) -> t -> Bool+ -- | Equivalent to 'List.all' from "Data.List". Ignores all non-character data.+ all :: (Char -> Bool) -> t -> Bool++ -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent+ -- to 'List.foldl' from "Data.List".+ foldl :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a+ -- | Strict version of 'foldl'.+ foldl' :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a+ -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent+ -- to 'List.foldl\'' from "Data.List".+ foldr :: (t -> a -> a) -> (Char -> a -> a) -> a -> t -> a++ -- | Equivalent to 'List.scanl' from "Data.List" when applied to a 'String', but preserves all non-character data.+ scanl :: (Char -> Char -> Char) -> Char -> t -> t+ -- | Equivalent to 'List.scanl1' from "Data.List" when applied to a 'String', but preserves all non-character data.+ --+ -- > scanl f c == scanl1 f . (singleton c <>)+ scanl1 :: (Char -> Char -> Char) -> t -> t+ -- | Equivalent to 'List.scanr' from "Data.List" when applied to a 'String', but preserves all non-character data.+ scanr :: (Char -> Char -> Char) -> Char -> t -> t+ -- | Equivalent to 'List.scanr1' from "Data.List" when applied to a 'String', but preserves all non-character data.+ --+ -- > scanr f c == scanr1 f . (<> singleton c)+ scanr1 :: (Char -> Char -> Char) -> t -> t+ -- | Equivalent to 'List.mapAccumL' from "Data.List" when applied to a 'String', but preserves all non-character+ -- data.+ mapAccumL :: (a -> Char -> (a, Char)) -> a -> t -> (a, t)+ -- | Equivalent to 'List.mapAccumR' from "Data.List" when applied to a 'String', but preserves all non-character+ -- data.+ mapAccumR :: (a -> Char -> (a, Char)) -> a -> t -> (a, t)++ -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to+ -- 'List.takeWhile' from "Data.List" when applied to a 'String'.+ takeWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t+ -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to+ -- 'List.dropWhile' from "Data.List" when applied to a 'String'.+ dropWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t+ -- | 'break pt pc' is equivalent to @span (not . pt) (not . pc)@.+ break :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t)+ -- | 'span pt pc t' is equivalent to @(takeWhile pt pc t, dropWhile pt pc t)@.+ span :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t)+ -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'.+ spanMaybe :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s)+ -- | Strict version of 'spanMaybe'.+ spanMaybe' :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s)+ -- | Splits the monoid into components delimited by character separators satisfying the given predicate. The+ -- characters satisfying the predicate are not a part of the result.+ --+ -- > split p == Factorial.split (maybe False p . characterPrefix)+ split :: (Char -> Bool) -> t -> [t]+ -- | Like 'List.find' from "Data.List" when applied to a 'String'. Ignores non-character data.+ find :: (Char -> Bool) -> t -> Maybe Char+ -- | Like 'List.elem' from "Data.List" when applied to a 'String'. Ignores non-character data.+ elem :: Char -> t -> Bool++ -- | > foldl_ = foldl const+ foldl_ :: (a -> Char -> a) -> a -> t -> a+ foldl_' :: (a -> Char -> a) -> a -> t -> a+ foldr_ :: (Char -> a -> a) -> a -> t -> a+ -- | > takeWhile_ = takeWhile . const+ takeWhile_ :: Bool -> (Char -> Bool) -> t -> t+ -- | > dropWhile_ = dropWhile . const+ dropWhile_ :: Bool -> (Char -> Bool) -> t -> t+ -- | > break_ = break . const+ break_ :: Bool -> (Char -> Bool) -> t -> (t, t)+ -- | > span_ = span . const+ span_ :: Bool -> (Char -> Bool) -> t -> (t, t)+ -- | > spanMaybe_ s = spanMaybe s (const . Just)+ spanMaybe_ :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s)+ spanMaybe_' :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s)+++ fromText = fromString . Text.unpack+ singleton = fromString . (:[])++ characterPrefix = fmap fst . splitCharacterPrefix++ map f = concatMap (singleton . f)+ concatMap f = foldr mappend (mappend . f) mempty+ toString f = foldr (mappend . f) (:) []+ toText f = Text.pack . toString (Text.unpack . f)+ all p = foldr (const id) ((&&) . p) True+ any p = foldr (const id) ((||) . p) False++ foldl ft fc = Factorial.foldl (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime))+ foldr ft fc = Factorial.foldr (\prime-> maybe (ft prime) fc (characterPrefix prime))+ foldl' ft fc = Factorial.foldl' (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime))+ foldl_ = foldl const+ foldr_ = foldr (const id)+ foldl_' = foldl' const++ scanl f c = mappend (singleton c) . fst . foldl foldlOther (foldlChars f) (mempty, c)+ scanl1 f t = case (Factorial.splitPrimePrefix t, splitCharacterPrefix t)+ of (Nothing, _) -> t+ (Just (prefix, suffix), Nothing) -> mappend prefix (scanl1 f suffix)+ (Just _, Just (c, suffix)) -> scanl f c suffix+ scanr f c = fst . foldr foldrOther (foldrChars f) (singleton c, c)+ scanr1 f = fst . foldr foldrOther fc (mempty, Nothing)+ where fc c (t, Nothing) = (mappend (singleton c) t, Just c)+ fc c1 (t, Just c2) = (mappend (singleton c') t, Just c')+ where c' = f c1 c2+ mapAccumL f a0 = foldl ft fc (a0, mempty)+ where ft (a, t1) t2 = (a, mappend t1 t2)+ fc (a, t) c = (a', mappend t (singleton c'))+ where (a', c') = f a c+ mapAccumR f a0 = foldr ft fc (a0, mempty)+ where ft t1 (a, t2) = (a, mappend t1 t2)+ fc c (a, t) = (a', mappend (singleton c') t)+ where (a', c') = f a c++ takeWhile pt pc = fst . span pt pc+ dropWhile pt pc = snd . span pt pc+ span pt pc = Factorial.span (\prime-> maybe (pt prime) pc (characterPrefix prime))+ break pt pc = Factorial.break (\prime-> maybe (pt prime) pc (characterPrefix prime))+ spanMaybe s0 ft fc t0 = spanAfter id s0 t0+ where spanAfter g s t = case Factorial.splitPrimePrefix t+ of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) ->+ spanAfter (g . mappend prime) s' rest+ | otherwise -> (g mempty, t, s)+ Nothing -> (t0, t, s)+ spanMaybe' s0 ft fc t0 = spanAfter id s0 t0+ where spanAfter g s t = seq s $+ case Factorial.splitPrimePrefix t+ of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) ->+ spanAfter (g . mappend prime) s' rest+ | otherwise -> (g mempty, t, s)+ Nothing -> (t0, t, s)+ takeWhile_ = takeWhile . const+ dropWhile_ = dropWhile . const+ break_ = break . const+ span_ = span . const+ spanMaybe_ s = spanMaybe s (const . Just)+ spanMaybe_' s = spanMaybe' s (const . Just)++ split p m = prefix : splitRest+ where (prefix, rest) = break (const False) p m+ splitRest = case splitCharacterPrefix rest+ of Nothing -> []+ Just (_, tl) -> split p tl+ find p = foldr (const id) (\c r-> if p c then Just c else r) Nothing+ elem c = any (== c)++ {-# INLINE characterPrefix #-}+ {-# INLINE concatMap #-}+ {-# INLINE dropWhile #-}+ {-# INLINE fromText #-}+ {-# INLINE map #-}+ {-# INLINE mapAccumL #-}+ {-# INLINE mapAccumR #-}+ {-# INLINE scanl #-}+ {-# INLINE scanl1 #-}+ {-# INLINE scanr #-}+ {-# INLINE scanr1 #-}+ {-# INLINE singleton #-}+ {-# INLINE spanMaybe #-}+ {-# INLINE spanMaybe' #-}+ {-# INLINE split #-}+ {-# INLINE takeWhile #-}+ {-# INLINE foldl_ #-}+ {-# INLINE foldl_' #-}+ {-# INLINE foldr_ #-}+ {-# INLINABLE spanMaybe_ #-}+ {-# INLINABLE spanMaybe_' #-}+ {-# INLINE span_ #-}+ {-# INLINE break_ #-}+ {-# INLINE takeWhile_ #-}+ {-# INLINE dropWhile_ #-}+ {-# INLINE elem #-}+ {-# INLINABLE all #-}+ {-# INLINABLE any #-}+ {-# MINIMAL splitCharacterPrefix #-}++foldlChars :: TextualMonoid t => (Char -> Char -> Char) -> (t, Char) -> Char -> (t, Char)+foldlOther :: Monoid t => (t, Char) -> t -> (t, Char)+foldrChars :: TextualMonoid t => (Char -> Char -> Char) -> Char -> (t, Char) -> (t, Char)+foldrOther :: Monoid t => t -> (t, a) -> (t, a)+foldlChars f (t, c1) c2 = (mappend t (singleton c'), c')+ where c' = f c1 c2+foldlOther (t1, c) t2 = (mappend t1 t2, c)+foldrChars f c1 (t, c2) = (mappend (singleton c') t, c')+ where c' = f c1 c2+foldrOther t1 (t2, c) = (mappend t1 t2, c)++instance TextualMonoid String where+ fromText = Text.unpack+ singleton c = [c]+ splitCharacterPrefix (c:rest) = Just (c, rest)+ splitCharacterPrefix [] = Nothing+ characterPrefix (c:_) = Just c+ characterPrefix [] = Nothing+ map = List.map+ concatMap = List.concatMap+ toString = const id+ any = List.any+ all = List.all++ foldl = const List.foldl+ foldl' = const List.foldl'+ foldr = const List.foldr++ scanl = List.scanl+ scanl1 = List.scanl1+ scanr = List.scanr+ scanr1 = List.scanr1+ mapAccumL = List.mapAccumL+ mapAccumR = List.mapAccumR++ takeWhile _ = List.takeWhile+ dropWhile _ = List.dropWhile+ break _ = List.break+ span _ = List.span+ spanMaybe s0 _ft fc l = (prefix' [], suffix' [], s')+ where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l+ g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = (prefix . (c:), id, s1, True)+ | otherwise = (prefix, suffix . (c:), s, False)+ spanMaybe' s0 _ft fc l = (prefix' [], suffix' [], s')+ where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l+ g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = seq s1 (prefix . (c:), id, s1, True)+ | otherwise = (prefix, suffix . (c:), s, False)+ find = List.find+ elem = List.elem++ {-# INLINE all #-}+ {-# INLINE any #-}+ {-# INLINE break #-}+ {-# INLINE characterPrefix #-}+ {-# INLINE concatMap #-}+ {-# INLINE dropWhile #-}+ {-# INLINE elem #-}+ {-# INLINE find #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE fromText #-}+ {-# INLINE map #-}+ {-# INLINE mapAccumL #-}+ {-# INLINE mapAccumR #-}+ {-# INLINE scanl #-}+ {-# INLINE scanl1 #-}+ {-# INLINE scanr #-}+ {-# INLINE scanr1 #-}+ {-# INLINE singleton #-}+ {-# INLINE span #-}+ {-# INLINE spanMaybe #-}+ {-# INLINE spanMaybe' #-}+ {-# INLINE splitCharacterPrefix #-}+ {-# INLINE takeWhile #-}++instance TextualMonoid Text where+ fromText = id+ singleton = Text.singleton+ splitCharacterPrefix = Text.uncons+ characterPrefix t = if Text.null t then Nothing else Just (Text.head t)+ map = Text.map+ concatMap = Text.concatMap+ toString = const Text.unpack+ toText = const id+ any = Text.any+ all = Text.all++ foldl = const Text.foldl+ foldl' = const Text.foldl'+ foldr = const Text.foldr++ scanl = Text.scanl+ scanl1 = Text.scanl1+ scanr = Text.scanr+ scanr1 = Text.scanr1+ mapAccumL = Text.mapAccumL+ mapAccumR = Text.mapAccumR++ takeWhile _ = Text.takeWhile+ dropWhile _ = Text.dropWhile+ break _ = Text.break+ span _ = Text.span+ spanMaybe s0 _ft fc t = case Text.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 _ft fc t = case Text.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')+ | otherwise = (i, s)+ split = Text.split+ find = Text.find++ {-# INLINE all #-}+ {-# INLINE any #-}+ {-# INLINE break #-}+ {-# INLINE characterPrefix #-}+ {-# INLINE concatMap #-}+ {-# INLINE dropWhile #-}+ {-# INLINE find #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE fromText #-}+ {-# INLINE map #-}+ {-# INLINE mapAccumL #-}+ {-# INLINE mapAccumR #-}+ {-# INLINE scanl #-}+ {-# INLINE scanl1 #-}+ {-# INLINE scanr #-}+ {-# INLINE scanr1 #-}+ {-# INLINE singleton #-}+ {-# INLINE span #-}+ {-# INLINE spanMaybe #-}+ {-# INLINE spanMaybe' #-}+ {-# INLINE split #-}+ {-# INLINE splitCharacterPrefix #-}+ {-# INLINE takeWhile #-}++instance TextualMonoid LazyText.Text where+ fromText = LazyText.fromStrict+ singleton = LazyText.singleton+ splitCharacterPrefix = LazyText.uncons+ characterPrefix t = if LazyText.null t then Nothing else Just (LazyText.head t)+ map = LazyText.map+ concatMap = LazyText.concatMap+ toString = const LazyText.unpack+ toText = const LazyText.toStrict+ any = LazyText.any+ all = LazyText.all++ foldl = const LazyText.foldl+ foldl' = const LazyText.foldl'+ foldr = const LazyText.foldr++ scanl = LazyText.scanl+ scanl1 = LazyText.scanl1+ scanr = LazyText.scanr+ scanr1 = LazyText.scanr1+ mapAccumL = LazyText.mapAccumL+ mapAccumR = LazyText.mapAccumR++ takeWhile _ = LazyText.takeWhile+ dropWhile _ = LazyText.dropWhile+ break _ = LazyText.break+ span _ = LazyText.span+ spanMaybe s0 _ft fc t = case LazyText.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 _ft fc t = case LazyText.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')+ | otherwise = (i, s)+ split = LazyText.split+ find = LazyText.find+ {-# INLINE all #-}+ {-# INLINE any #-}+ {-# INLINE break #-}+ {-# INLINE characterPrefix #-}+ {-# INLINE concatMap #-}+ {-# INLINE dropWhile #-}+ {-# INLINE find #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE fromText #-}+ {-# INLINE map #-}+ {-# INLINE mapAccumL #-}+ {-# INLINE mapAccumR #-}+ {-# INLINE scanl #-}+ {-# INLINE scanl1 #-}+ {-# INLINE scanr #-}+ {-# INLINE scanr1 #-}+ {-# INLINE singleton #-}+ {-# INLINE span #-}+ {-# INLINE spanMaybe #-}+ {-# INLINE spanMaybe' #-}+ {-# INLINE split #-}+ {-# INLINE splitCharacterPrefix #-}+ {-# INLINE takeWhile #-}++instance TextualMonoid (Sequence.Seq Char) where+ singleton = Sequence.singleton+ splitCharacterPrefix s = case Sequence.viewl s+ of Sequence.EmptyL -> Nothing+ c Sequence.:< rest -> Just (c, rest)+ characterPrefix s = case Sequence.viewl s+ of Sequence.EmptyL -> Nothing+ c Sequence.:< _ -> Just c+ map = Traversable.fmapDefault+ concatMap = Foldable.foldMap+ toString = const Foldable.toList+ any = Foldable.any+ all = Foldable.all++ foldl = const Foldable.foldl+ foldl' = const Foldable.foldl'+ foldr = const Foldable.foldr++ scanl = Sequence.scanl+ scanl1 f v | Sequence.null v = Sequence.empty+ | otherwise = Sequence.scanl1 f v+ scanr = Sequence.scanr+ scanr1 f v | Sequence.null v = Sequence.empty+ | otherwise = Sequence.scanr1 f v++ takeWhile _ = Sequence.takeWhileL+ dropWhile _ = Sequence.dropWhileL+ break _ = Sequence.breakl+ span _ = Sequence.spanl+ spanMaybe s0 _ft fc b = case Foldable.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 _ft fc b = case Foldable.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')+ | otherwise = (i, s)+ find = Foldable.find+ elem = Foldable.elem++ {-# INLINE all #-}+ {-# INLINE any #-}+ {-# INLINE break #-}+ {-# INLINE characterPrefix #-}+ {-# INLINE concatMap #-}+ {-# INLINE dropWhile #-}+ {-# INLINE elem #-}+ {-# INLINE find #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl' #-}+ {-# INLINE foldr #-}+ {-# INLINE map #-}+ {-# INLINE scanl #-}+ {-# INLINE scanl1 #-}+ {-# INLINE scanr #-}+ {-# INLINE scanr1 #-}+ {-# INLINE singleton #-}+ {-# INLINE span #-}+ {-# INLINE spanMaybe #-}+ {-# INLINE spanMaybe' #-}+ {-# INLINE splitCharacterPrefix #-}+ {-# INLINE takeWhile #-}
+ src/Data/Semigroup/Cancellative.hs view
@@ -0,0 +1,572 @@+{-+ Copyright 2013-2019 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'Semigroup' => 'Reductive' => 'Cancellative' class hierarchy.+--+-- @since 1.0+--+-- The 'Reductive' class introduces operation '</>' which is the inverse of '<>'. For the 'Sum' semigroup, this+-- operation is subtraction; for 'Product' it is division and for 'Set' it's the set difference. A 'Reductive'+-- semigroup is not a full group because '</>' may return 'Nothing'.+--+-- The 'Cancellative' subclass does not add any operation but it provides the additional guarantee that '<>' can+-- always be undone with '</>'. Thus 'Sum' is 'Cancellative' but 'Product' is not because @(0*n)/0@ is not defined.+--+-- All semigroup subclasses listed above are for Abelian, /i.e./, commutative or symmetric semigroups. Since most+-- practical semigroups in Haskell are not Abelian, each of the these classes has two symmetric superclasses:+--+-- * 'LeftReductive'+--+-- * 'LeftCancellative'+--+-- * 'RightReductive'+--+-- * 'RightCancellative'++{-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.Semigroup.Cancellative (+ -- * Symmetric, commutative semigroup classes+ Commutative, Reductive(..), Cancellative, SumCancellative(..),+ -- * Asymmetric semigroup classes+ LeftReductive(..), RightReductive(..),+ LeftCancellative, RightCancellative+ )+where++import Data.Functor.Const+import Data.Functor.Identity+import Data.Semigroup -- (Semigroup, Dual(..), Sum(..), Product(..))+import Data.Semigroup.Commutative+import qualified Data.List as List+import Data.Maybe (isJust)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Unsafe as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LazyText+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Sequence as Sequence+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import Numeric.Natural (Natural)+import Numeric.Product.Commutative (CommutativeProduct)++-- | Class of Abelian semigroups with a partial inverse for the Semigroup '<>' operation. The inverse operation '</>' must+-- satisfy the following laws:+--+-- > maybe a (b <>) (a </> b) == a+-- > maybe a (<> b) (a </> b) == a+--+-- The '</>' operator is a synonym for both 'stripPrefix' and 'stripSuffix', which must be equivalent as '<>' is both+-- associative and commutative.+--+-- > (</>) = flip stripPrefix+-- > (</>) = flip stripSuffix+class (Commutative m, LeftReductive m, RightReductive m) => Reductive m where+ (</>) :: m -> m -> Maybe m++infix 5 </>++-- | Subclass of 'Reductive' where '</>' is a complete inverse of the Semigroup '<>' operation. The class+-- instances must satisfy the following additional laws:+--+-- > (a <> b) </> a == Just b+-- > (a <> b) </> b == Just a+class (LeftCancellative m, RightCancellative m, Reductive m) => Cancellative m++-- | Class of semigroups with a left inverse of 'Data.Semigroup.<>', satisfying the following law:+--+-- > isPrefixOf a b == isJust (stripPrefix a b)+-- > maybe b (a <>) (stripPrefix a b) == b+-- > a `isPrefixOf` (a <> b)+--+-- Every instance definition has to implement at least the 'stripPrefix' method.+class Semigroup m => LeftReductive m where+ isPrefixOf :: m -> m -> Bool+ stripPrefix :: m -> m -> Maybe m++ isPrefixOf a b = isJust (stripPrefix a b)+ {-# MINIMAL stripPrefix #-}++-- | Class of semigroups with a right inverse of 'Data.Semigroup.<>', satisfying the following law:+--+-- > isSuffixOf a b == isJust (stripSuffix a b)+-- > maybe b (<> a) (stripSuffix a b) == b+-- > b `isSuffixOf` (a <> b)+--+-- Every instance definition has to implement at least the 'stripSuffix' method.+class Semigroup m => RightReductive m where+ isSuffixOf :: m -> m -> Bool+ stripSuffix :: m -> m -> Maybe m++ isSuffixOf a b = isJust (stripSuffix a b)+ {-# MINIMAL stripSuffix #-}++-- | Subclass of 'LeftReductive' where 'stripPrefix' is a complete inverse of '<>', satisfying the following+-- additional law:+--+-- > stripPrefix a (a <> b) == Just b+class LeftReductive m => LeftCancellative m++-- | Subclass of 'LeftReductive' where 'stripPrefix' is a complete inverse of '<>', satisfying the following+-- additional law:+--+-- > stripSuffix b (a <> b) == Just a+class RightReductive m => RightCancellative m++-- Unit instances++instance Reductive () where+ () </> () = Just ()++instance Cancellative ()++-- | /O(1)/+instance LeftReductive () where+ stripPrefix () () = Just ()++-- | /O(1)/+instance RightReductive () where+ stripSuffix () () = Just ()++instance LeftCancellative ()++instance RightCancellative ()++-- Dual instances++instance Reductive a => Reductive (Dual a) where+ Dual a </> Dual b = fmap Dual (a </> b)++instance Cancellative a => Cancellative (Dual a)++instance LeftReductive a => RightReductive (Dual a) where+ stripSuffix (Dual a) (Dual b) = fmap Dual (stripPrefix a b)+ Dual a `isSuffixOf` Dual b = a `isPrefixOf` b++instance RightReductive a => LeftReductive (Dual a) where+ stripPrefix (Dual a) (Dual b) = fmap Dual (stripSuffix a b)+ Dual a `isPrefixOf` Dual b = a `isSuffixOf` b++instance LeftCancellative a => RightCancellative (Dual a)++instance RightCancellative a => LeftCancellative (Dual a)++-- Sum instances++-- | Helper class to avoid @FlexibleInstances@+class Num a => SumCancellative a where+ cancelAddition :: a -> a -> Maybe a+ cancelAddition a b = Just (a - b)++instance SumCancellative Int+instance SumCancellative Integer+instance SumCancellative Rational++instance SumCancellative Natural where+ cancelAddition a b+ | a < b = Nothing+ | otherwise = Just (a - b)++-- | /O(1)/+instance SumCancellative a => Reductive (Sum a) where+ Sum a </> Sum b = Sum <$> cancelAddition a b++-- | /O(1)/+instance SumCancellative a => LeftReductive (Sum a) where+ stripPrefix a b = b </> a++-- | /O(1)/+instance SumCancellative a => RightReductive (Sum a) where+ stripSuffix a b = b </> a++instance SumCancellative a => Cancellative (Sum a)+instance SumCancellative a => LeftCancellative (Sum a)+instance SumCancellative a => RightCancellative (Sum a)++-- Product instances++instance (CommutativeProduct a, Integral a) => Reductive (Product a) where+ Product 0 </> Product 0 = Just (Product 0)+ Product _ </> Product 0 = Nothing+ Product a </> Product b = if remainder == 0 then Just (Product quotient) else Nothing+ where (quotient, remainder) = quotRem a b++instance (CommutativeProduct a, Integral a) => LeftReductive (Product a) where+ stripPrefix a b = b </> a++instance (CommutativeProduct a, Integral a) => RightReductive (Product a) where+ stripSuffix a b = b </> a++-- Max & Min instances++instance Ord a => Reductive (Max a) where+ a </> b = if b <= a then Just a else Nothing+instance Ord a => Reductive (Min a) where+ a </> b = if a <= b then Just a else Nothing++instance Ord a => LeftReductive (Max a) where+ isPrefixOf a b = a <= b+ stripPrefix a b = b </> a+instance Ord a => LeftReductive (Min a) where+ isPrefixOf a b = b <= a+ stripPrefix a b = b </> a++instance Ord a => RightReductive (Max a) where+ isSuffixOf a b = a <= b+ stripSuffix a b = b </> a+instance Ord a => RightReductive (Min a) where+ isSuffixOf a b = b <= a+ stripSuffix a b = b </> a++-- Any & All instances++instance Reductive Any where+ a </> b = if b <= a then Just a else Nothing+instance Reductive All where+ a </> b = if a <= b then Just a else Nothing++instance LeftReductive Any where+ isPrefixOf a b = a <= b+ stripPrefix a b = b </> a+instance LeftReductive All where+ isPrefixOf a b = b <= a+ stripPrefix a b = b </> a++instance RightReductive Any where+ isSuffixOf a b = a <= b+ stripSuffix a b = b </> a+instance RightReductive All where+ isSuffixOf a b = b <= a+ stripSuffix a b = b </> a++-- Identity & Const instances++deriving instance Reductive a => Reductive (Identity a)+deriving instance Reductive a => Reductive (Const a b)++instance Cancellative a => Cancellative (Identity a)+instance Cancellative a => Cancellative (Const a x)++deriving instance LeftReductive a => LeftReductive (Identity a)+deriving instance LeftReductive a => LeftReductive (Const a b)++deriving instance RightReductive a => RightReductive (Identity a)+deriving instance RightReductive a => RightReductive (Const a b)++instance LeftCancellative a => LeftCancellative (Identity a)+instance LeftCancellative a => LeftCancellative (Const a x)++instance RightCancellative a => RightCancellative (Identity a)+instance RightCancellative a => RightCancellative (Const a x)++-- Pair instances++instance (Reductive a, Reductive b) => Reductive (a, b) where+ (a, b) </> (c, d) = case (a </> c, b </> d)+ of (Just a', Just b') -> Just (a', b')+ _ -> Nothing++instance (Cancellative a, Cancellative b) => Cancellative (a, b)++instance (LeftReductive a, LeftReductive b) => LeftReductive (a, b) where+ stripPrefix (a, b) (c, d) = case (stripPrefix a c, stripPrefix b d)+ of (Just a', Just b') -> Just (a', b')+ _ -> Nothing+ isPrefixOf (a, b) (c, d) = isPrefixOf a c && isPrefixOf b d++instance (RightReductive a, RightReductive b) => RightReductive (a, b) where+ stripSuffix (a, b) (c, d) = case (stripSuffix a c, stripSuffix b d)+ of (Just a', Just b') -> Just (a', b')+ _ -> Nothing+ isSuffixOf (a, b) (c, d) = isSuffixOf a c && isSuffixOf b d++instance (LeftCancellative a, LeftCancellative b) => LeftCancellative (a, b)++instance (RightCancellative a, RightCancellative b) => RightCancellative (a, b)++-- Triple instances++instance (Reductive a, Reductive b, Reductive c) => Reductive (a, b, c) where+ (a1, b1, c1) </> (a2, b2, c2) = (,,) <$> (a1 </> a2) <*> (b1 </> b2) <*> (c1 </> c2)++instance (Cancellative a, Cancellative b, Cancellative c) => Cancellative (a, b, c)++instance (LeftReductive a, LeftReductive b, LeftReductive c) => LeftReductive (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 (RightReductive a, RightReductive b, RightReductive c) => RightReductive (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 (LeftCancellative a, LeftCancellative b, LeftCancellative c) => LeftCancellative (a, b, c)++instance (RightCancellative a, RightCancellative b, RightCancellative c) => RightCancellative (a, b, c)++-- Quadruple instances++instance (Reductive a, Reductive b, Reductive c, Reductive d) => Reductive (a, b, c, d) where+ (a1, b1, c1, d1) </> (a2, b2, c2, d2) = (,,,) <$> (a1 </> a2) <*> (b1 </> b2) <*> (c1 </> c2) <*> (d1 </> d2)++instance (Cancellative a, Cancellative b, Cancellative c, Cancellative d) => Cancellative (a, b, c, d)++instance (LeftReductive a, LeftReductive b, LeftReductive c, LeftReductive d) => LeftReductive (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 (RightReductive a, RightReductive b, RightReductive c, RightReductive d) => RightReductive (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 (LeftCancellative a, LeftCancellative b,+ LeftCancellative c, LeftCancellative d) => LeftCancellative (a, b, c, d)++instance (RightCancellative a, RightCancellative b,+ RightCancellative c, RightCancellative d) => RightCancellative (a, b, c, d)++-- Maybe instances++-- | @since 1.0+instance Reductive x => Reductive (Maybe x) where+ Just x </> Just y = Just <$> x </> y+ x </> Nothing = Just x+ Nothing </> _ = Nothing++instance LeftReductive x => LeftReductive (Maybe x) where+ stripPrefix Nothing y = Just y+ stripPrefix Just{} Nothing = Nothing+ stripPrefix (Just x) (Just y) = fmap Just $ stripPrefix x y++instance RightReductive x => RightReductive (Maybe x) where+ stripSuffix Nothing y = Just y+ stripSuffix Just{} Nothing = Nothing+ stripSuffix (Just x) (Just y) = fmap Just $ stripSuffix x y++-- Set instances++-- | /O(m*log(n/m + 1)), m <= n/+instance Ord a => LeftReductive (Set.Set a) where+ isPrefixOf = Set.isSubsetOf+ stripPrefix a b = b </> a++-- | /O(m*log(n/m + 1)), m <= n/+instance Ord a => RightReductive (Set.Set a) where+ isSuffixOf = Set.isSubsetOf+ stripSuffix a b = b </> a++-- | /O(m*log(n/m + 1)), m <= n/+instance Ord a => Reductive (Set.Set a) where+ a </> b | Set.isSubsetOf b a = Just (a Set.\\ b)+ | otherwise = Nothing++-- IntSet instances++-- | /O(m+n)/+instance LeftReductive IntSet.IntSet where+ isPrefixOf = IntSet.isSubsetOf+ stripPrefix a b = b </> a++-- | /O(m+n)/+instance RightReductive IntSet.IntSet where+ isSuffixOf = IntSet.isSubsetOf+ stripSuffix a b = b </> a++-- | /O(m+n)/+instance Reductive IntSet.IntSet where+ a </> b | IntSet.isSubsetOf b a = Just (a IntSet.\\ b)+ | otherwise = Nothing++-- Map instances++-- | /O(m+n)/+instance (Ord k, Eq a) => LeftReductive (Map.Map k a) where+ isPrefixOf = Map.isSubmapOf+ stripPrefix a b | Map.isSubmapOf a b = Just (b Map.\\ a)+ | otherwise = Nothing++-- | /O(m+n)/+instance (Ord k, Eq a) => RightReductive (Map.Map k a) where+ isSuffixOf = Map.isSubmapOfBy (const $ const True)+ stripSuffix a b | a `isSuffixOf` b = Just (Map.differenceWith (\x y-> if x == y then Nothing else Just x) b a)+ | otherwise = Nothing++-- IntMap instances++-- | /O(m+n)/+instance Eq a => LeftReductive (IntMap.IntMap a) where+ isPrefixOf = IntMap.isSubmapOf+ stripPrefix a b | IntMap.isSubmapOf a b = Just (b IntMap.\\ a)+ | otherwise = Nothing++-- | /O(m+n)/+instance Eq a => RightReductive (IntMap.IntMap a) where+ isSuffixOf = IntMap.isSubmapOfBy (const $ const True)+ stripSuffix a b | a `isSuffixOf` b = Just (IntMap.differenceWith (\x y-> if x == y then Nothing else Just x) b a)+ | otherwise = Nothing++-- List instances++-- | /O(prefixLength)/+instance Eq x => LeftReductive [x] where+ stripPrefix = List.stripPrefix+ isPrefixOf = List.isPrefixOf++-- | @since 1.0+-- /O(m+n)/+instance Eq x => RightReductive [x] where+ isSuffixOf = List.isSuffixOf+ stripSuffix xs0 ys0 = go1 xs0 ys0+ where go1 (_:xs) (_:ys) = go1 xs ys+ go1 [] ys = go2 id ys ys0+ go1 _ [] = Nothing+ go2 fy (_:zs) (y:ys) = go2 (fy . (y:)) zs ys+ go2 fy [] ys+ | xs0 == ys = Just (fy [])+ | otherwise = Nothing+ go2 _ _ _ = error "impossible"++instance Eq x => LeftCancellative [x]++-- | @since 1.0+instance Eq x => RightCancellative [x]++-- Seq instances++-- | /O(log(min(m,n−m)) + prefixLength)/+instance Eq a => LeftReductive (Sequence.Seq a) where+ stripPrefix p s | p == s1 = Just s2+ | otherwise = Nothing+ where (s1, s2) = Sequence.splitAt (Sequence.length p) s++-- | /O(log(min(m,n−m)) + suffixLength)/+instance Eq a => RightReductive (Sequence.Seq a) where+ stripSuffix p s | p == s2 = Just s1+ | otherwise = Nothing+ where (s1, s2) = Sequence.splitAt (Sequence.length s - Sequence.length p) s++instance Eq a => LeftCancellative (Sequence.Seq a)++instance Eq a => RightCancellative (Sequence.Seq a)++-- Vector instances++-- | /O(n)/+instance Eq a => LeftReductive (Vector.Vector a) where+ stripPrefix p l | prefixLength > Vector.length l = Nothing+ | otherwise = strip 0+ where strip i | i == prefixLength = Just (Vector.drop prefixLength l)+ | l Vector.! i == p Vector.! i = strip (succ i)+ | otherwise = Nothing+ prefixLength = Vector.length p+ isPrefixOf p l | prefixLength > Vector.length l = False+ | otherwise = test 0+ where test i | i == prefixLength = True+ | l Vector.! i == p Vector.! i = test (succ i)+ | otherwise = False+ prefixLength = Vector.length p++-- | /O(n)/+instance Eq a => RightReductive (Vector.Vector a) where+ stripSuffix s l | suffixLength > Vector.length l = Nothing+ | otherwise = strip (pred suffixLength)+ where strip i | i == -1 = Just (Vector.take lengthDifference l)+ | l Vector.! (lengthDifference + i) == s Vector.! i = strip (pred i)+ | otherwise = Nothing+ suffixLength = Vector.length s+ lengthDifference = Vector.length l - suffixLength+ isSuffixOf s l | suffixLength > Vector.length l = False+ | otherwise = test (pred suffixLength)+ where test i | i == -1 = True+ | l Vector.! (lengthDifference + i) == s Vector.! i = test (pred i)+ | otherwise = False+ suffixLength = Vector.length s+ lengthDifference = Vector.length l - suffixLength++instance Eq a => LeftCancellative (Vector.Vector a)++instance Eq a => RightCancellative (Vector.Vector a)++-- ByteString instances++-- | /O(n)/+instance LeftReductive ByteString.ByteString where+ stripPrefix p l = if ByteString.isPrefixOf p l+ then Just (ByteString.unsafeDrop (ByteString.length p) l)+ else Nothing+ isPrefixOf = ByteString.isPrefixOf++-- | /O(n)/+instance RightReductive ByteString.ByteString where+ stripSuffix s l = if ByteString.isSuffixOf s l+ then Just (ByteString.unsafeTake (ByteString.length l - ByteString.length s) l)+ else Nothing+ isSuffixOf = ByteString.isSuffixOf++instance LeftCancellative ByteString.ByteString++instance RightCancellative ByteString.ByteString++-- Lazy ByteString instances++-- | /O(n)/+instance LeftReductive LazyByteString.ByteString where+ stripPrefix p l = if LazyByteString.isPrefixOf p l+ then Just (LazyByteString.drop (LazyByteString.length p) l)+ else Nothing+ isPrefixOf = LazyByteString.isPrefixOf++-- | /O(n)/+instance RightReductive LazyByteString.ByteString where+ stripSuffix s l = if LazyByteString.isSuffixOf s l+ then Just (LazyByteString.take (LazyByteString.length l - LazyByteString.length s) l)+ else Nothing+ isSuffixOf = LazyByteString.isSuffixOf++instance LeftCancellative LazyByteString.ByteString++instance RightCancellative LazyByteString.ByteString++-- Text instances++-- | /O(n)/+instance LeftReductive Text.Text where+ stripPrefix = Text.stripPrefix+ isPrefixOf = Text.isPrefixOf++-- | /O(n)/+instance RightReductive Text.Text where+ stripSuffix = Text.stripSuffix+ isSuffixOf = Text.isSuffixOf++instance LeftCancellative Text.Text++instance RightCancellative Text.Text++-- Lazy Text instances++-- | /O(n)/+instance LeftReductive LazyText.Text where+ stripPrefix = LazyText.stripPrefix+ isPrefixOf = LazyText.isPrefixOf++-- | /O(n)/+instance RightReductive LazyText.Text where+ stripSuffix = LazyText.stripSuffix+ isSuffixOf = LazyText.isSuffixOf++instance LeftCancellative LazyText.Text++instance RightCancellative LazyText.Text
+ src/Data/Semigroup/Factorial.hs view
@@ -0,0 +1,449 @@+{-+ Copyright 2013-2019 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'Semigroup' => 'Factorial' => 'StableFactorial' classes and some of their instances.+--++{-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.Semigroup.Factorial (+ -- * Classes+ Factorial(..), StableFactorial,+ -- * Monad function equivalents+ mapM, mapM_+ )+where++import qualified Control.Monad as Monad+import Data.Functor.Const (Const (Const))+import Data.Functor.Identity (Identity (Identity))+import Data.Semigroup -- (Semigroup (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo))+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LazyText+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Sequence as Sequence+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import Data.List.NonEmpty (nonEmpty)+import Data.Numbers.Primes (primeFactors)+import Numeric.Natural (Natural)++import Data.Monoid.Null (MonoidNull(null))++import Prelude (Int, Maybe(..), Eq, Ord, Monoid, Applicative, Monad, Integral,+ (.), (-), (+), ($), (*>), (++), pure, return, mempty, mappend,+ mconcat, pred, id, seq, otherwise, uncurry, fromIntegral, not,+ fmap, max, abs, signum, replicate, maybe, succ, const)++-- | Class of semigroups that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of+-- a 'Product' are literally its prime factors:+--+-- prop> factors (Product 12) == [Product 2, Product 2, Product 3]+--+-- Factors of a list are /not/ its elements but all its single-item sublists:+--+-- prop> factors "abc" == ["a", "b", "c"]+--+-- The methods of this class satisfy the following laws:+--+-- > maybe id sconcat . nonEmpty . factors == id+-- > List.all (\prime-> factors prime == [prime]) . factors+-- > primePrefix s == foldr const s s+-- > foldl f a == List.foldl f a . factors+-- > foldl' f a == List.foldl' f a . factors+-- > foldr f a == List.foldr f a . factors+--+-- A minimal instance definition must implement 'factors' or 'foldr'. Other methods can and should be implemented only+-- for performance reasons.+class Semigroup m => Factorial m where+ -- | Returns a list of all prime factors; inverse of mconcat.+ factors :: m -> [m]+ -- | The prime prefix; @primePrefix mempty == mempty@ for monoids.+ primePrefix :: m -> m+ -- | The prime suffix; @primeSuffix mempty == mempty@ for monoids.+ primeSuffix :: m -> m+ -- | Like 'List.foldl' from "Data.List" on the list of prime 'factors'.+ foldl :: (a -> m -> a) -> a -> m -> a+ -- | Like 'List.foldl'' from "Data.List" on the list of prime 'factors'.+ foldl' :: (a -> m -> a) -> a -> m -> a+ -- | Like 'List.foldr' from "Data.List" on the list of prime 'factors'.+ foldr :: (m -> a -> a) -> a -> m -> a+ -- | The 'length' of the list of prime 'factors'.+ length :: m -> Int+ -- | Generalizes 'Foldable.foldMap' from "Data.Foldable", except the function arguments are prime 'factors' rather+ -- than the structure elements.+ foldMap :: Monoid n => (m -> n) -> m -> n+ -- | Equivalent to 'List.reverse' from "Data.List".+ reverse :: m -> m++ factors = foldr (:) []+ primePrefix s = foldr const s s+ primeSuffix s = foldl (const id) s s+ foldl f f0 = List.foldl f f0 . factors+ foldl' f f0 = List.foldl' f f0 . factors+ foldr f f0 = List.foldr f f0 . factors+ length = foldl' (const . succ) 0+ foldMap f = foldr (mappend . f) mempty+ reverse s = maybe s sconcat (nonEmpty $ List.reverse $ factors s)+ {-# MINIMAL factors | foldr #-}+ {-# INLINABLE factors #-}+ {-# INLINE primePrefix #-}+ {-# INLINE primeSuffix #-}+ {-# INLINABLE foldl #-}+ {-# INLINABLE foldl' #-}+ {-# INLINABLE foldr #-}+ {-# INLINE length #-}+ {-# INLINE foldMap #-}+ {-# INLINE reverse #-}++-- | A subclass of 'Factorial' whose instances satisfy the following additional laws:+--+-- > factors (a <> b) == factors a <> factors b+-- > factors . reverse == List.reverse . factors+-- > primeSuffix s == primePrefix (reverse s)+class Factorial m => StableFactorial m++instance Factorial () where+ factors () = []+ primePrefix () = ()+ primeSuffix () = ()+ length () = 0+ reverse = id++deriving instance Factorial a => Factorial (Identity a)++deriving instance Factorial a => Factorial (Const a b)++instance Factorial a => Factorial (Dual a) where+ factors (Dual a) = fmap Dual (reverse $ factors a)+ length (Dual a) = length a+ primePrefix (Dual a) = Dual (primeSuffix a)+ primeSuffix (Dual a) = Dual (primePrefix a)+ reverse (Dual a) = Dual (reverse a)++instance (Integral a, Eq a) => Factorial (Sum a) where+ primePrefix (Sum a) = Sum (signum a )+ primeSuffix = primePrefix+ factors (Sum n) = replicate (fromIntegral $ abs n) (Sum $ signum n)+ length (Sum a) = abs (fromIntegral a)+ reverse = id++instance Integral a => Factorial (Product a) where+ factors (Product a) = List.map Product (primeFactors a)+ reverse = id++instance Factorial a => Factorial (Maybe a) where+ factors Nothing = []+ factors (Just a) = case factors a+ of [] -> [Just a]+ as -> List.map Just as+ length Nothing = 0+ length (Just a) = max 1 (length a)+ reverse = fmap reverse++instance (Factorial a, Factorial b, MonoidNull a, MonoidNull b) => Factorial (a, b) where+ factors (a, b) = List.map (\a1-> (a1, mempty)) (factors a) ++ List.map ((,) mempty) (factors b)+ primePrefix (a, b) | null a = (a, primePrefix b)+ | otherwise = (primePrefix a, mempty)+ primeSuffix (a, b) | null b = (primeSuffix a, b)+ | otherwise = (mempty, primeSuffix b)+ foldl f a0 (x, y) = foldl f2 (foldl f1 a0 x) y+ where f1 a = f a . fromFst+ f2 a = f a . fromSnd+ foldl' f a0 (x, y) = a' `seq` foldl' f2 a' y+ where f1 a = f a . fromFst+ f2 a = f a . fromSnd+ a' = foldl' f1 a0 x+ foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x+ foldMap f (x, y) = Data.Semigroup.Factorial.foldMap (f . fromFst) x `mappend`+ Data.Semigroup.Factorial.foldMap (f . fromSnd) y+ length (a, b) = length a + length b+ reverse (a, b) = (reverse a, reverse b)++{-# INLINE fromFst #-}+fromFst :: Monoid b => a -> (a, b)+fromFst a = (a, mempty)++{-# INLINE fromSnd #-}+fromSnd :: Monoid a => b -> (a, b)+fromSnd b = (mempty, b)++instance (Factorial a, Factorial b, Factorial c,+ MonoidNull a, MonoidNull b, MonoidNull c) => Factorial (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)+ 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.Semigroup.Factorial.foldMap (f . fromFstOf3) a+ `mappend` Data.Semigroup.Factorial.foldMap (f . fromSndOf3) b+ `mappend` Data.Semigroup.Factorial.foldMap (f . fromThdOf3) c+ length (a, b, c) = length a + length b + length 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 (Factorial a, Factorial b, Factorial c, Factorial d,+ MonoidNull a, MonoidNull b, MonoidNull c, MonoidNull d) => Factorial (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)+ 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.Semigroup.Factorial.foldMap (f . fromFstOf4) a+ `mappend` Data.Semigroup.Factorial.foldMap (f . fromSndOf4) b+ `mappend` Data.Semigroup.Factorial.foldMap (f . fromThdOf4) c+ `mappend` Data.Semigroup.Factorial.foldMap (f . fromFthOf4) d+ length (a, b, c, d) = length a + length b + length c + length 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 Factorial [x] where+ factors xs = List.map (:[]) xs+ primePrefix [] = []+ primePrefix (x:_) = [x]+ primeSuffix [] = []+ primeSuffix xs = [List.last xs]+ foldl _ a [] = a+ foldl f a (x:xs) = foldl f (f a [x]) xs+ foldl' _ a [] = a+ foldl' f a (x:xs) = let a' = f a [x] in a' `seq` foldl' f a' xs+ foldr _ f0 [] = f0+ foldr f f0 (x:xs) = f [x] (foldr f f0 xs)+ length = List.length+ foldMap f = mconcat . List.map (f . (:[]))+ reverse = List.reverse++instance Factorial ByteString.ByteString where+ factors x = factorize (ByteString.length x) x+ where factorize 0 _ = []+ factorize n xs = xs1 : factorize (pred n) xs'+ where (xs1, xs') = ByteString.splitAt 1 xs+ primePrefix = ByteString.take 1+ primeSuffix x = ByteString.drop (ByteString.length x - 1) x+ foldl f = ByteString.foldl f'+ where f' a byte = f a (ByteString.singleton byte)+ foldl' f = ByteString.foldl' f'+ where f' a byte = f a (ByteString.singleton byte)+ foldr f = ByteString.foldr (f . ByteString.singleton)+ length = ByteString.length+ reverse = ByteString.reverse++instance Factorial LazyByteString.ByteString where+ factors x = factorize (LazyByteString.length x) x+ where factorize 0 _ = []+ factorize n xs = xs1 : factorize (pred n) xs'+ where (xs1, xs') = LazyByteString.splitAt 1 xs+ primePrefix = LazyByteString.take 1+ primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x+ length = fromIntegral . LazyByteString.length+ reverse = LazyByteString.reverse++instance Factorial Text.Text where+ factors = Text.chunksOf 1+ primePrefix = Text.take 1+ primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x)+ foldl f = Text.foldl f'+ where f' a char = f a (Text.singleton char)+ foldl' f = Text.foldl' f'+ where f' a char = f a (Text.singleton char)+ foldr f = Text.foldr f'+ where f' char a = f (Text.singleton char) a+ length = Text.length+ reverse = Text.reverse++instance Factorial LazyText.Text where+ factors = LazyText.chunksOf 1+ primePrefix = LazyText.take 1+ primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x)+ foldl f = LazyText.foldl f'+ where f' a char = f a (LazyText.singleton char)+ foldl' f = LazyText.foldl' f'+ where f' a char = f a (LazyText.singleton char)+ foldr f = LazyText.foldr f'+ where f' char a = f (LazyText.singleton char) a+ length = fromIntegral . LazyText.length+ reverse = LazyText.reverse++instance Ord k => Factorial (Map.Map k v) where+ factors = List.map (uncurry Map.singleton) . Map.toAscList+ primePrefix map | Map.null map = map+ | otherwise = uncurry Map.singleton $ Map.findMin map+ primeSuffix map | Map.null map = map+ | otherwise = uncurry Map.singleton $ Map.findMax map+ foldl f = Map.foldlWithKey f'+ where f' a k v = f a (Map.singleton k v)+ foldl' f = Map.foldlWithKey' f'+ where f' a k v = f a (Map.singleton k v)+ foldr f = Map.foldrWithKey f'+ where f' k v a = f (Map.singleton k v) a+ length = Map.size+ reverse = id++instance Factorial (IntMap.IntMap a) where+ factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList+ primePrefix map | IntMap.null map = map+ | otherwise = uncurry IntMap.singleton $ IntMap.findMin map+ primeSuffix map | IntMap.null map = map+ | otherwise = uncurry IntMap.singleton $ IntMap.findMax map+ foldl f = IntMap.foldlWithKey f'+ where f' a k v = f a (IntMap.singleton k v)+ foldl' f = IntMap.foldlWithKey' f'+ where f' a k v = f a (IntMap.singleton k v)+ foldr f = IntMap.foldrWithKey f'+ where f' k v a = f (IntMap.singleton k v) a+ length = IntMap.size+ reverse = id++instance Factorial IntSet.IntSet where+ factors = List.map IntSet.singleton . IntSet.toAscList+ primePrefix set | IntSet.null set = set+ | otherwise = IntSet.singleton $ IntSet.findMin set+ primeSuffix set | IntSet.null set = set+ | otherwise = IntSet.singleton $ IntSet.findMax set+ foldl f = IntSet.foldl f'+ where f' a b = f a (IntSet.singleton b)+ foldl' f = IntSet.foldl' f'+ where f' a b = f a (IntSet.singleton b)+ foldr f = IntSet.foldr f'+ where f' a b = f (IntSet.singleton a) b+ length = IntSet.size+ reverse = id++instance Factorial (Sequence.Seq a) where+ factors = List.map Sequence.singleton . Foldable.toList+ primePrefix = Sequence.take 1+ primeSuffix q = Sequence.drop (Sequence.length q - 1) q+ foldl f = Foldable.foldl f'+ where f' a b = f a (Sequence.singleton b)+ foldl' f = Foldable.foldl' f'+ where f' a b = f a (Sequence.singleton b)+ foldr f = Foldable.foldr f'+ where f' a b = f (Sequence.singleton a) b+ length = Sequence.length+ reverse = Sequence.reverse++instance Ord a => Factorial (Set.Set a) where+ factors = List.map Set.singleton . Set.toAscList+ primePrefix set | Set.null set = set+ | otherwise = Set.singleton $ Set.findMin set+ primeSuffix set | Set.null set = set+ | otherwise = Set.singleton $ Set.findMax set+ foldl f = Foldable.foldl f'+ where f' a b = f a (Set.singleton b)+ foldl' f = Foldable.foldl' f'+ where f' a b = f a (Set.singleton b)+ foldr f = Foldable.foldr f'+ where f' a b = f (Set.singleton a) b+ length = Set.size+ reverse = id++instance Factorial (Vector.Vector a) where+ factors x = factorize (Vector.length x) x+ where factorize 0 _ = []+ factorize n xs = xs1 : factorize (pred n) xs'+ where (xs1, xs') = Vector.splitAt 1 xs+ primePrefix = Vector.take 1+ primeSuffix x = Vector.drop (Vector.length x - 1) x+ foldl f = Vector.foldl f'+ where f' a byte = f a (Vector.singleton byte)+ foldl' f = Vector.foldl' f'+ where f' a byte = f a (Vector.singleton byte)+ foldr f = Vector.foldr f'+ where f' byte a = f (Vector.singleton byte) a+ length = Vector.length+ reverse = Vector.reverse++instance StableFactorial ()+instance StableFactorial a => StableFactorial (Identity a)+instance StableFactorial a => StableFactorial (Const a b)+instance StableFactorial a => StableFactorial (Dual a)+instance StableFactorial [x]+instance StableFactorial ByteString.ByteString+instance StableFactorial LazyByteString.ByteString+instance StableFactorial Text.Text+instance StableFactorial LazyText.Text+instance StableFactorial (Sequence.Seq a)+instance StableFactorial (Vector.Vector a)+instance StableFactorial (Sum Natural)++-- | A 'Monad.mapM' equivalent.+mapM :: (Factorial a, Semigroup b, Monoid b, Monad m) => (a -> m b) -> a -> m b+mapM f = ($ return mempty) . appEndo . Data.Semigroup.Factorial.foldMap (Endo . Monad.liftM2 mappend . f)++-- | A 'Monad.mapM_' equivalent.+mapM_ :: (Factorial a, Applicative m) => (a -> m b) -> a -> m ()+mapM_ f = foldr ((*>) . f) (pure ())