monoid-subclasses-0.4.6.1/0000755000000000000000000000000013355551371013510 5ustar0000000000000000monoid-subclasses-0.4.6.1/README.md0000644000000000000000000000703013355551371014767 0ustar0000000000000000monoid-subclasses ================= ### Subclasses of Monoid with a solid theoretical foundation and practical purposes ### The monoid-subclasses package has been released [on Hackage](http://hackage.haskell.org/package/monoid-subclasses). The package defines several classes that are richer than [monoids](http://hackage.haskell.org/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: (a <> b) a == Just b (a <> b) b == Just a Every group (i.e., 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. 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. 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 * 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) monoid-subclasses-0.4.6.1/BSD3-LICENSE.txt0000644000000000000000000000272113355551371016026 0ustar0000000000000000Copyright (c) 2012-2013, Mario Blazevic All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of {{the ORGANIZATION nor the names of its contributors}} may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY {{THE COPYRIGHT HOLDERS AND CONTRIBUTORS}} "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL {{THE COPYRIGHT HOLDER OR CONTRIBUTORS}} BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. monoid-subclasses-0.4.6.1/CHANGELOG.md0000644000000000000000000000561113355551371015324 0ustar0000000000000000 Version 0.4.6.1 --------------- Bumped the containers dependency upper bounds Version 0.4.6 --------------- Added the Semigroup instances to fix the compilation errors with base-4.11 Version 0.4.4 --------------- Fixed boundary condition bugs in ByteStringUTF8 uncovered by a new version of QuickCheck Version 0.4.3.2 --------------- Fixed compilation errors with GHC 7.8.4 and older Version 0.4.3.1 --------------- Bumped the vector dependency upper bounds Version 0.4.3 --------------- * Added instances for 3- and 4-tuples * Re-implemented Concat as an own data type, dropping Seq Version 0.4.2.1 --------------- * Fixed compilation problems with GHC 8 and containers-0.5.7 * Fixed compilation problems with GHC 8 and containers-0.5.7 * Merge pull request #10 from mgiles: minor typo in FactorialMonoid laws Version 0.4.2 --------------- * Fixed a bug in splitAt implementation for ByteStringUTF8 * Merge pull request #9 from phadej: use newest quickcheck-instances * Removed the overzealous assertions from ByteStringUTF8 Version 0.4.1.2 --------------- Removing accidental reference to Instances.Markup module Version 0.4.1.1 --------------- * Bumped the vector dependency upper bounds * Removed GHC-prof-options from the cabal file Version 0.4.1 --------------- * Changed the Prelude imports to enable compilation with GHC 7.4 * Added INLINE pragmas * Added the toString method to TextualMonoid class * Importing Text.Show.Functions to avoid overlapping instances * Eliminated the redundant import warnings from GHC 7.10.1 Version 0.4.0.4 --------------- * Added -Wall GHC option and eliminated almost all the warnings * Fixed a bug in the Textual instance of ByteStringUTF8 Version 0.4.0.3 --------------- * Excluding the imports of foldMap from Prelude Version 0.4.0.2 --------------- * Added more tests and fixed a bug in Stateful * Fixed a bug in Positioned.span_ * Optimized the Stateful data type Version 0.3.6.2 --------------- * Added a bunch of pragmas Version 0.3.6 --------------- * Deprecated all the inject functions * Registered the new Stateful module Version 0.3.4.1 --------------- Accommodating the text-1.0 release * Introduced the function ByteStringUTF8.decode * Removed the utf-string dependency * Replaced the utf-string import by a more efficient UTF-8 encoding Version 0.3.1 --------------- * Added the Data.Monoid.Instances.Concat module and tests * Added the PositiveMonoid class * Added the StableFactorialMonoid subclass of FactorialMonoid * Added more instances for () Version 0.3 --------------- Added the CommutativeMonoid class at the root of the Cancellative classes Version 0.2 --------------- * Added TextualMonoid instances for Seq Char and Vector Char * Renamed the FactorialMonoid method map to foldMap in keeping with Foldable Version 0.1.2 --------------- Optimizations of the default Factorial methods and of the ButeStringUTF8 instances Version 0.1 --------------- Initial release monoid-subclasses-0.4.6.1/monoid-subclasses.cabal0000644000000000000000000000377313355551371020140 0ustar0000000000000000Name: monoid-subclasses Version: 0.4.6.1 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid Category: Data, Algebra, Text Tested-with: GHC 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ć Author: Mario Blažević Maintainer: Mario Blažević Homepage: https://github.com/blamario/monoid-subclasses/ Bug-reports: https://github.com/blamario/monoid-subclasses/issues Extra-Source-Files: README.md, CHANGELOG.md Source-repository head type: git 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 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 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, tasty >= 0.7, tasty-quickcheck >= 0.7 && < 1.0, monoid-subclasses Main-is: Test/TestMonoidSubclasses.hs default-language: Haskell2010 monoid-subclasses-0.4.6.1/Setup.lhs0000644000000000000000000000011713355551371015317 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain monoid-subclasses-0.4.6.1/Test/0000755000000000000000000000000013355551371014427 5ustar0000000000000000monoid-subclasses-0.4.6.1/Test/TestMonoidSubclasses.hs0000644000000000000000000013651313355551371021111 0ustar0000000000000000{- Copyright 2013-2018 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} {-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} module Main where import Prelude hiding (foldl, foldr, gcd, length, null, reverse, span, splitAt, takeWhile) import Test.Tasty (defaultMain, testGroup) import Test.Tasty.QuickCheck (Arbitrary, CoArbitrary, Property, Gen, arbitrary, coarbitrary, property, label, forAll, mapSize, testProperty, variant, whenFail, (.&&.)) import Test.QuickCheck.Instances () import Control.Applicative (Applicative(..), liftA2) import Data.Functor ((<$>)) import Data.Foldable (foldMap, toList) import Data.Int (Int8, Int32) import qualified Data.Foldable as Foldable import Data.Traversable (Traversable) import Data.List (intersperse, unfoldr) import qualified Data.List as List import Data.Maybe (isJust) import Data.Either (lefts, rights) import Data.Tuple (swap) import Data.String (IsString, fromString) import Data.Char (isLetter) import Data.Int (Int16) import Data.Word (Word, Word8) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as Lazy (ByteString) import Data.Text (Text) import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.Text as Text import qualified Data.Sequence as Sequence import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Map (Map) import Data.Sequence (Seq) import Data.Set (Set) import Data.Vector (Vector, fromList) import Text.Show.Functions import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(ByteStringUTF8)) 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 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), First(First), Last(Last), Sum(Sum), Product(Product)) 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.Textual (TextualMonoid) import qualified Data.Monoid.Textual as Textual data Test = CommutativeTest (CommutativeMonoidInstance -> Property) | NullTest (NullMonoidInstance -> Property) | PositiveTest (PositiveMonoidInstance -> Property) | FactorialTest (FactorialMonoidInstance -> Property) | StableFactorialTest (StableFactorialMonoidInstance -> Property) | TextualTest (TextualMonoidInstance -> Property) | LeftReductiveTest (LeftReductiveMonoidInstance -> Property) | RightReductiveTest (RightReductiveMonoidInstance -> Property) | ReductiveTest (ReductiveMonoidInstance -> Property) | LeftCancellativeTest (LeftCancellativeMonoidInstance -> Property) | RightCancellativeTest (RightCancellativeMonoidInstance -> Property) | CancellativeTest (CancellativeMonoidInstance -> Property) | LeftGCDTest (LeftGCDMonoidInstance -> Property) | RightGCDTest (RightGCDMonoidInstance -> Property) | GCDTest (GCDMonoidInstance -> Property) | CancellativeGCDTest (CancellativeGCDMonoidInstance -> Property) data CommutativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CommutativeMonoid a) => CommutativeMonoidInstance 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) => StableFactorialMonoidInstance 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, TextualMonoid a) => StableTextualMonoidInstance a data LeftReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => LeftReductiveMonoidInstance a data RightReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightReductiveMonoid a) => RightReductiveMonoidInstance a data ReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, ReductiveMonoid a) => ReductiveMonoidInstance a data LeftCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftCancellativeMonoid a) => LeftCancellativeMonoidInstance a data RightCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightCancellativeMonoid a) => RightCancellativeMonoidInstance a data CancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a) => CancellativeMonoidInstance 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) => RightGCDMonoidInstance 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 commutativeInstances :: [CommutativeMonoidInstance] commutativeInstances = map upcast reductiveInstances ++ [CommutativeMonoidInstance (mempty :: Product Double)] where upcast (ReductiveMonoidInstance i) = CommutativeMonoidInstance i nullInstances :: [NullMonoidInstance] nullInstances = map upcast factorialInstances ++ [NullMonoidInstance (mempty :: Ordering), NullMonoidInstance (mempty :: All), NullMonoidInstance (mempty :: Any), NullMonoidInstance (mempty :: Sum Float), NullMonoidInstance (mempty :: Product Int), NullMonoidInstance (mempty :: First Int), NullMonoidInstance (mempty :: Last Int), NullMonoidInstance (mempty :: Concat Any), NullMonoidInstance (mempty :: Concat (Dual String)), NullMonoidInstance (mempty :: Concat (Map String Int))] where upcast (FactorialMonoidInstance i) = NullMonoidInstance i positiveInstances = map upcast stableFactorialInstances ++ [PositiveMonoidInstance (mempty :: ()), PositiveMonoidInstance (mempty :: Ordering), PositiveMonoidInstance (mempty :: All), PositiveMonoidInstance (mempty :: Any), PositiveMonoidInstance (mempty :: (Maybe (Sum Integer))), PositiveMonoidInstance (mempty :: (First Char)), PositiveMonoidInstance (mempty :: (Last Int)), PositiveMonoidInstance (mempty :: String), PositiveMonoidInstance (mempty :: (Map Int16 Int)), PositiveMonoidInstance (mempty :: (IntMap Char)), PositiveMonoidInstance (mempty :: IntSet), PositiveMonoidInstance (mempty :: (Set Float)), PositiveMonoidInstance (mempty :: (Dual ()))] where upcast (StableFactorialMonoidInstance i) = PositiveMonoidInstance i factorialInstances :: [FactorialMonoidInstance] factorialInstances = map upcast stableFactorialInstances ++ [FactorialMonoidInstance (mempty :: Sum Integer), FactorialMonoidInstance (mempty :: Product Int32), FactorialMonoidInstance (mempty :: Maybe String), FactorialMonoidInstance (mempty :: (Text, String)), FactorialMonoidInstance (mempty :: (Product Int32, ByteString, Sum Integer)), FactorialMonoidInstance (mempty :: (IntSet, Text, Sum Integer, String)), FactorialMonoidInstance (mempty :: IntMap Int), FactorialMonoidInstance (mempty :: IntSet), FactorialMonoidInstance (mempty :: Map String Int), FactorialMonoidInstance (mempty :: Set String), FactorialMonoidInstance (mempty :: Concat ByteString), FactorialMonoidInstance (mempty :: Concat (Dual ByteString)), FactorialMonoidInstance (mempty :: Concat (Maybe String)), FactorialMonoidInstance (mempty :: Concat (Text, String)), FactorialMonoidInstance (mempty :: Concat (IntMap Int))] where upcast (StableFactorialMonoidInstance i) = FactorialMonoidInstance i stableFactorialInstances :: [StableFactorialMonoidInstance] stableFactorialInstances = stable1 ++ map measure stable1 ++ map position stable1 where stable1 = map upcast stableTextualInstances ++ [StableFactorialMonoidInstance (mempty :: ByteString), StableFactorialMonoidInstance (mempty :: Lazy.ByteString), StableFactorialMonoidInstance (mempty :: Dual String), StableFactorialMonoidInstance (mempty :: Seq Int), StableFactorialMonoidInstance (mempty :: Vector Int)] upcast (StableTextualMonoidInstance i) = StableFactorialMonoidInstance i measure (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (Measured.measure i) position (StableFactorialMonoidInstance (i :: a)) = StableFactorialMonoidInstance (pure i :: OffsetPositioned a) textualInstances :: [TextualMonoidInstance] textualInstances = map upcast stableTextualInstances ++ [TextualMonoidInstance (mempty :: ByteStringUTF8), TextualMonoidInstance (mempty :: Text), TextualMonoidInstance (mempty :: Lazy.Text), TextualMonoidInstance (mempty :: Seq Char), TextualMonoidInstance (mempty :: Vector Char), TextualMonoidInstance (mempty :: Stateful (IntMap Int) Text)] where upcast (StableTextualMonoidInstance i) = TextualMonoidInstance i stableTextualInstances :: [StableTextualMonoidInstance] stableTextualInstances = stable1 ++ map measure stable1 ++ concatMap position stable1 where stable1 = [StableTextualMonoidInstance (mempty :: TestString), StableTextualMonoidInstance (mempty :: String), StableTextualMonoidInstance (mempty :: Text), StableTextualMonoidInstance (mempty :: Lazy.Text), StableTextualMonoidInstance (mempty :: Seq Char), StableTextualMonoidInstance (mempty :: Vector Char)] measure (StableTextualMonoidInstance i) = StableTextualMonoidInstance (Measured.measure i) position (StableTextualMonoidInstance (i :: a)) = [StableTextualMonoidInstance (pure i :: OffsetPositioned a), StableTextualMonoidInstance (pure i :: LinePositioned a)] leftReductiveInstances = map upcast leftCancellativeInstances ++ [LeftReductiveMonoidInstance (mempty :: Sum Integer), LeftReductiveMonoidInstance (mempty :: IntSet), LeftReductiveMonoidInstance (mempty :: Set Integer), 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))] where upcast (LeftCancellativeMonoidInstance i) = LeftReductiveMonoidInstance i rightReductiveInstances = map upcast rightCancellativeInstances ++ [RightReductiveMonoidInstance (mempty :: Product Integer), RightReductiveMonoidInstance (mempty :: IntSet), 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))] where upcast (RightCancellativeMonoidInstance i) = RightReductiveMonoidInstance i reductiveInstances = map upcast cancellativeInstances ++ [ReductiveMonoidInstance (mempty :: Product Integer), ReductiveMonoidInstance (mempty :: IntSet), ReductiveMonoidInstance (mempty :: Set Integer)] where upcast (CancellativeMonoidInstance i) = ReductiveMonoidInstance i leftCancellativeInstances = map upcast cancellativeInstances ++ [LeftCancellativeMonoidInstance (mempty :: String), LeftCancellativeMonoidInstance (mempty :: ByteString), LeftCancellativeMonoidInstance (mempty :: Lazy.ByteString), LeftCancellativeMonoidInstance (mempty :: Text), LeftCancellativeMonoidInstance (mempty :: Lazy.Text), LeftCancellativeMonoidInstance (mempty :: Dual Text), LeftCancellativeMonoidInstance (mempty :: (Text, String)), LeftCancellativeMonoidInstance (mempty :: Seq Int), LeftCancellativeMonoidInstance (mempty :: Vector Int)] where upcast (CancellativeMonoidInstance i) = LeftCancellativeMonoidInstance i rightCancellativeInstances = map upcast cancellativeInstances ++ [RightCancellativeMonoidInstance (mempty :: ByteString), RightCancellativeMonoidInstance (mempty :: Lazy.ByteString), RightCancellativeMonoidInstance (mempty :: Text), RightCancellativeMonoidInstance (mempty :: Lazy.Text), RightCancellativeMonoidInstance (mempty :: Dual String), RightCancellativeMonoidInstance (mempty :: (Text, ByteString)), RightCancellativeMonoidInstance (mempty :: Seq Int), RightCancellativeMonoidInstance (mempty :: Vector Int)] where upcast (CancellativeMonoidInstance i) = RightCancellativeMonoidInstance i cancellativeInstances = map upcast cancellativeGCDInstances ++ [] where upcast (CancellativeGCDMonoidInstance i) = CancellativeMonoidInstance i leftGCDInstances = map upcast gcdInstances ++ [LeftGCDMonoidInstance (mempty :: String), LeftGCDMonoidInstance (mempty :: ByteString), LeftGCDMonoidInstance (mempty :: Lazy.ByteString), LeftGCDMonoidInstance (mempty :: Text), LeftGCDMonoidInstance (mempty :: Lazy.Text), LeftGCDMonoidInstance (mempty :: Dual ByteString), LeftGCDMonoidInstance (mempty :: (Text, String)), LeftGCDMonoidInstance (mempty :: (ByteString, Text, String)), LeftGCDMonoidInstance (mempty :: ([Word8], ByteString, String, Text)), LeftGCDMonoidInstance (mempty :: IntMap Int), LeftGCDMonoidInstance (mempty :: Map String Int), LeftGCDMonoidInstance (mempty :: Seq Int), LeftGCDMonoidInstance (mempty :: Vector Int), LeftGCDMonoidInstance (mempty :: Concat String), LeftGCDMonoidInstance (mempty :: Concat ByteString), LeftGCDMonoidInstance (mempty :: Concat Lazy.ByteString), LeftGCDMonoidInstance (mempty :: Concat Text), LeftGCDMonoidInstance (mempty :: Concat Lazy.Text), LeftGCDMonoidInstance (mempty :: Concat (Dual ByteString))] where upcast (GCDMonoidInstance i) = LeftGCDMonoidInstance i rightGCDInstances = map upcast gcdInstances ++ [RightGCDMonoidInstance (mempty :: ByteString), RightGCDMonoidInstance (mempty :: Lazy.ByteString), RightGCDMonoidInstance (mempty :: Dual String), RightGCDMonoidInstance (mempty :: (Seq Int, ByteString)), RightGCDMonoidInstance (mempty :: Seq Int), RightGCDMonoidInstance (mempty :: Vector Int), RightGCDMonoidInstance (mempty :: Concat ByteString), RightGCDMonoidInstance (mempty :: Concat Lazy.ByteString), 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 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)))] main = defaultMain (testGroup "MonoidSubclasses" $ map expand tests) where expand (name, test) = testProperty name (foldr1 (.&&.) $ checkInstances test) checkInstances :: Test -> [Property] checkInstances (CommutativeTest checkType) = (map checkType commutativeInstances) checkInstances (NullTest checkType) = (map checkType nullInstances) checkInstances (PositiveTest checkType) = (map checkType positiveInstances) checkInstances (FactorialTest checkType) = (map checkType factorialInstances) checkInstances (StableFactorialTest checkType) = (map checkType stableFactorialInstances) checkInstances (TextualTest checkType) = (map checkType textualInstances) 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) tests :: [(String, Test)] tests = [("CommutativeMonoid", CommutativeTest checkCommutative), ("MonoidNull", NullTest checkNull), ("PositiveMonoid", PositiveTest checkPositive), ("mconcat . factors == id", FactorialTest checkConcatFactors), ("all factors . factors", FactorialTest checkFactorsOfFactors), ("splitPrimePrefix", FactorialTest checkSplitPrimePrefix), ("splitPrimeSuffix", FactorialTest checkSplitPrimeSuffix), ("primePrefix", FactorialTest checkPrimePrefix), ("primeSuffix", FactorialTest checkPrimeSuffix), ("inits", FactorialTest checkInits), ("tails", FactorialTest checkTails), ("foldl", FactorialTest checkLeftFold), ("foldl'", FactorialTest checkLeftFold'), ("foldr", FactorialTest checkRightFold), ("length", FactorialTest checkLength), ("span", FactorialTest checkSpan), ("spanMaybe", FactorialTest checkSpanMaybe), ("split", FactorialTest checkSplit), ("splitAt", FactorialTest checkSplitAt), ("reverse", FactorialTest checkReverse), ("stable", StableFactorialTest checkStability), ("fromText", TextualTest checkFromText), ("singleton", TextualTest checkSingleton), ("Textual.splitCharacterPrefix", TextualTest checkSplitCharacterPrefix), ("Textual.characterPrefix", TextualTest checkCharacterPrefix), ("Textual factors", TextualTest checkTextualFactors), ("Textual.unfoldr", TextualTest checkUnfoldrToFactors), ("factors . fromString", TextualTest checkFactorsFromString), ("Textual.map", TextualTest checkTextualMap), ("Textual.concatMap", TextualTest checkConcatMap), ("Textual.any", TextualTest checkAny), ("Textual.all", TextualTest checkAll), ("Textual.foldl", TextualTest checkTextualFoldl), ("Textual.foldr", TextualTest checkTextualFoldr), ("Textual.foldl'", TextualTest checkTextualFoldl'), ("Textual.scanl", TextualTest checkTextualScanl), ("Textual.scanr", TextualTest checkTextualScanr), ("Textual.scanl1", TextualTest checkTextualScanl1), ("Textual.scanr1", TextualTest checkTextualScanr1), ("Textual.toString", TextualTest checkToString), ("Textual.mapAccumL", TextualTest checkTextualMapAccumL), ("Textual.mapAccumR", TextualTest checkTextualMapAccumR), ("Textual.takeWhile", TextualTest checkTextualTakeWhile), ("Textual.dropWhile", TextualTest checkTextualDropWhile), ("Textual.span", TextualTest checkTextualSpan), ("Textual.break", TextualTest checkTextualBreak), ("Textual.spanMaybe", TextualTest checkTextualSpanMaybe), ("Textual.split", TextualTest checkTextualSplit), ("Textual.find", TextualTest checkTextualFind), ("Textual.foldl_", TextualTest checkTextualFoldl_), ("Textual.foldr_", TextualTest checkTextualFoldr_), ("Textual.foldl_'", TextualTest checkTextualFoldl_'), ("Textual.span_", TextualTest checkTextualSpan_), ("Textual.break_", TextualTest checkTextualBreak_), ("Textual.spanMaybe_", TextualTest checkTextualSpanMaybe_), ("Textual.spanMaybe_'", TextualTest checkTextualSpanMaybe_'), ("Textual.takeWhile_", TextualTest checkTextualTakeWhile_), ("Textual.dropWhile_", TextualTest checkTextualDropWhile_), ("stripPrefix", LeftReductiveTest checkStripPrefix), ("isPrefixOf", LeftReductiveTest checkIsPrefixOf), ("stripSuffix", RightReductiveTest checkStripSuffix), ("isSuffixOf", RightReductiveTest checkIsSuffixOf), ("", ReductiveTest checkUnAppend), ("cancellative stripPrefix", LeftCancellativeTest checkStripPrefix'), ("cancellative stripSuffix", RightCancellativeTest checkStripSuffix'), ("cancellative ", CancellativeTest checkUnAppend'), ("stripCommonPrefix 1", LeftGCDTest checkStripCommonPrefix1), ("stripCommonPrefix 2", LeftGCDTest checkStripCommonPrefix2), ("stripCommonSuffix 1", RightGCDTest checkStripCommonSuffix1), ("stripCommonSuffix 2", RightGCDTest checkStripCommonSuffix2), ("gcd", GCDTest checkGCD), ("cancellative gcd", CancellativeGCDTest checkCancellativeGCD) ] checkCommutative (CommutativeMonoidInstance (e :: a)) = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> a <> b == b <> a) 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))) checkConcatFactors (FactorialMonoidInstance (e :: a)) = null (factors e) .&&. forAll (arbitrary :: Gen a) check where check a = mconcat (factors a) == a checkFactorsOfFactors (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (all singleton . factors) where singleton prime = factors prime == [prime] 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)) = forAll (arbitrary :: Gen a) (\a-> primePrefix a == maybe mempty fst (splitPrimePrefix a)) checkPrimeSuffix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> primeSuffix a == maybe mempty snd (splitPrimeSuffix a)) checkInits (FactorialMonoidInstance (_ :: a)) = mapSize (`div` 5) $ forAll (arbitrary :: Gen a) (\a-> inits a == List.map mconcat (List.inits $ factors a)) checkTails (FactorialMonoidInstance (_ :: a)) = mapSize (`div` 5) $ forAll (arbitrary :: Gen a) (\a-> tails a == List.map mconcat (List.tails $ factors a)) checkLeftFold (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldl (flip (:)) [] a == List.foldl (flip (:)) [] (factors a)) checkLeftFold' (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldl' (flip (:)) [] a == List.foldl' (flip (:)) [] (factors a)) checkRightFold (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldr (:) [] a == List.foldr (:) [] (factors 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) where check p a = span p a == (mconcat l, mconcat r) where (l, r) = List.span p (factors a) checkSpanMaybe (FactorialMonoidInstance (_ :: a)) = property $ \(f, s)-> forAll (arbitrary :: Gen a) (check f (s :: Bool)) where check f s0 a = a == prefix <> suffix && foldMaybe prefix == Just s' && (null suffix || f s' (primePrefix suffix) == Nothing) where (prefix, suffix, s') = spanMaybe s0 f a foldMaybe = foldl g (Just s0) g s m = s >>= flip f m checkSplit (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = property (\pred-> all (all (not . pred) . factors) (split pred a)) .&&. property (\prime-> mconcat (intersperse prime $ split (== prime) a) == a) checkSplitAt (FactorialMonoidInstance (_ :: a)) = property $ \i-> forAll (arbitrary :: Gen a) (check i) where check i a = splitAt i a == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors 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)) = forAll (arbitrary :: Gen Text) (\t-> Textual.fromText t == (fromString (Text.unpack t) :: a)) checkSingleton (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen Char) (\c-> Textual.singleton c == (fromString [c] :: 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) == fmap (\(c, t)-> (c, mempty)) (Textual.splitCharacterPrefix t) checkCharacterPrefix (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check t = Textual.characterPrefix t == fmap fst (Textual.splitCharacterPrefix t) checkTextualFactors (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = all (maybe True (null . snd) . Textual.splitCharacterPrefix) (factors a) checkUnfoldrToFactors (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = factors a == unfoldr splitPrimePrefix a checkFactorsFromString (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen String) check where check s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s 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 && Textual.map id a == a check2 s = Textual.map succ (fromString s :: a) == fromString (List.map succ s) 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 check2 s = Textual.concatMap (fromString . f) (fromString s :: a) == fromString (List.concatMap f s) f = replicate 3 apply prime = maybe prime (fromString . f) (Textual.characterPrefix prime) checkAll (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.all isLetter a == Textual.foldr (const id) ((&&) . isLetter) True a 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)) = 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)) = 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)) = 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 checkTextualFoldl_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl_ (\l c-> c : l) [] a == List.reverse (rights $ textualFactors a) check2 s = Textual.foldl_ (flip (:)) [] s == List.foldl (flip (:)) [] s checkTextualFoldr_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldr_ (\c l-> c : l) [] a == rights (textualFactors a) check2 s = Textual.foldr_ (:) [] (fromString s :: a) == s checkTextualFoldl_' (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl_' (\l c-> c : l) [] a == List.reverse (rights $ textualFactors a) check2 s = Textual.foldl_' (flip (:)) [] s == List.foldl (flip (:)) [] s checkTextualScanl (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = (rights . textualFactors . Textual.scanl f 'Z') a == (List.scanl f 'Z' . rights . textualFactors) a && (lefts . textualFactors . Textual.scanl f 'Y') a == (lefts . textualFactors) a && Textual.scanl f 'W' a == Textual.scanl1 f (Textual.singleton 'W' <> a) check2 s = Textual.scanl f 'X' (fromString s :: a) == fromString (List.scanl f 'X' s) f c1 c2 = min c1 c2 checkTextualScanr (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = (rights . textualFactors . Textual.scanr f 'Z') a == (List.scanr f 'Z' . rights . textualFactors) a && (lefts . textualFactors . Textual.scanr f 'Y') a == (lefts . textualFactors) a && Textual.scanr f 'W' a == Textual.scanr1 f (a <> Textual.singleton 'W') check2 s = Textual.scanr f 'X' (fromString s :: a) == fromString (List.scanr f 'X' s) f c1 c2 = min c1 c2 checkTextualScanl1 (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.scanl1 (const id) a == a check2 s = Textual.scanl1 f (fromString s :: a) == fromString (List.scanl1 f s) f c1 c2 = min c1 c2 checkTextualScanr1 (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.scanr1 const a == a check2 s = Textual.scanr1 f (fromString s :: a) == fromString (List.scanr1 f s) f c1 c2 = min c1 c2 checkToString (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 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)) = 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)) = 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)) = 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)) = 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) 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) where pt = (== primePrefix a) pc = isLetter checkTextualBreak (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.break pt pc a == Textual.span (not . pt) (not . pc) a where pt = (/= primePrefix a) pc = isLetter checkTextualSpanMaybe (TextualMonoidInstance (_ :: a)) = property $ \(ft, fc, s)-> forAll (arbitrary :: Gen a) (check ft fc (s :: Bool)) where check ft fc s0 a = a == prefix <> suffix && foldMaybe prefix == Just s' && (null suffix || maybe (ft s' (primePrefix suffix)) (fc s') (Textual.characterPrefix suffix) == Nothing) where (prefix, suffix, s') = Textual.spanMaybe s0 ft fc a foldMaybe = Textual.foldl gt gc (Just s0) gt s m = s >>= flip ft m gc s c = s >>= flip fc c checkTextualSpan_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, Bool)) check where check (a, bt) = Textual.span_ bt isLetter a == (Textual.takeWhile_ bt isLetter a, Textual.dropWhile_ bt isLetter a) checkTextualBreak_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, Bool)) check where check (a, bt) = Textual.break_ bt isLetter a == Textual.span_ (not bt) (not . isLetter) a checkTextualSpanMaybe_ (TextualMonoidInstance (_ :: a)) = property $ \(fc, s)-> forAll (arbitrary :: Gen a) (check fc (s :: Bool)) where check fc s0 a = a == prefix <> suffix && foldMaybe prefix == Just s' && (null suffix || (Textual.characterPrefix suffix >>= fc s') == Nothing) where (prefix, suffix, s') = Textual.spanMaybe_ s0 fc a foldMaybe = Textual.foldl_ gc (Just s0) gc s c = s >>= flip fc c checkTextualSpanMaybe_' (TextualMonoidInstance (_ :: a)) = property $ \(fc, s)-> forAll (arbitrary :: Gen a) (check fc (s :: Bool)) where check fc s0 a = a == prefix <> suffix && foldMaybe prefix == Just s' && (null suffix || (Textual.characterPrefix suffix >>= fc s') == Nothing) where (prefix, suffix, s') = Textual.spanMaybe_' s0 fc a foldMaybe = Textual.foldl_' gc (Just s0) gc s c = s >>= flip fc c 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)) = 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) 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)) = 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 checkStripPrefix (LeftReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = maybe b (a <>) (stripPrefix a b) == b checkIsPrefixOf (LeftReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = isPrefixOf a b == isJust (stripPrefix a b) && a `isPrefixOf` (a <> b) checkStripSuffix (RightReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = maybe b (<> a) (stripSuffix a b) == b checkIsSuffixOf (RightReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = isSuffixOf a b == isJust (stripSuffix a b) && b `isSuffixOf` (a <> b) checkUnAppend (ReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = maybe a (b <>) (a b) == a && maybe a (<> b) (a b) == a checkStripPrefix' (LeftCancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripPrefix a (a <> b) == Just b checkStripSuffix' (RightCancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripSuffix b (a <> b) == Just a checkUnAppend' (CancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = a <> b a == Just b && a <> b b == Just a checkStripCommonPrefix1 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripCommonPrefix a b == (p, a', b') where p = commonPrefix a b Just a' = stripPrefix p a Just b' = stripPrefix p b checkStripCommonPrefix2 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = p == commonPrefix a b && p <> a' == a && p <> b' == b where (p, a', b') = stripCommonPrefix a b checkStripCommonSuffix1 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripCommonSuffix a b == (a', b', s) where s = commonSuffix a b Just a' = stripSuffix s a Just b' = stripSuffix s b checkStripCommonSuffix2 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = s == commonSuffix a b && a' <> s == a && b' <> s == b where (a', b', s) = stripCommonSuffix a b checkGCD (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = d == commonPrefix a b && d == commonSuffix a b && isJust (a d) && 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 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) instance FactorialMonoid TestString where splitPrimePrefix (TestString []) = Nothing splitPrimePrefix (TestString (x:xs)) = Just (TestString [x], TestString xs) instance TextualMonoid TestString where splitCharacterPrefix (TestString []) = Nothing splitCharacterPrefix (TestString (x:xs)) = Just (x, TestString xs) instance Arbitrary ByteStringUTF8 where arbitrary = fmap ByteStringUTF8 arbitrary instance (Arbitrary a, MonoidNull a, PositiveMonoid a) => Arbitrary (Concat a) where arbitrary = fmap (foldMap pure) (arbitrary :: Gen [a]) instance (Arbitrary a, FactorialMonoid a) => Arbitrary (Measured a) where arbitrary = fmap Measured.measure arbitrary instance (Arbitrary a, FactorialMonoid a) => Arbitrary (OffsetPositioned a) where arbitrary = fmap pure arbitrary instance (Arbitrary a, TextualMonoid a) => Arbitrary (LinePositioned a) where arbitrary = fmap pure arbitrary instance (Arbitrary a, Arbitrary b) => Arbitrary (Stateful a b) where arbitrary = Stateful.Stateful <$> liftA2 (,) arbitrary arbitrary instance CoArbitrary ByteStringUTF8 where coarbitrary (ByteStringUTF8 bs) = coarbitrary bs instance CoArbitrary a => CoArbitrary (Concat a) where coarbitrary = coarbitrary . toList instance CoArbitrary a => CoArbitrary (Measured a) where coarbitrary = coarbitrary . Measured.extract instance CoArbitrary a => CoArbitrary (OffsetPositioned a) where coarbitrary = coarbitrary . Positioned.extract instance CoArbitrary a => CoArbitrary (LinePositioned a) where coarbitrary = coarbitrary . Positioned.extract instance CoArbitrary b => CoArbitrary (Stateful a b) where coarbitrary = coarbitrary . Stateful.extract instance (PositiveMonoid a, MonoidNull b) => PositiveMonoid (a, b) #if MIN_VERSION_containers(0,5,2) #else instance Applicative Seq where pure = Sequence.singleton fs <*> xs = Foldable.foldl' add mempty fs where add ys f = ys <> fmap f xs #endif monoid-subclasses-0.4.6.1/Data/0000755000000000000000000000000013355551371014361 5ustar0000000000000000monoid-subclasses-0.4.6.1/Data/Monoid/0000755000000000000000000000000013355551371015606 5ustar0000000000000000monoid-subclasses-0.4.6.1/Data/Monoid/Cancellative.hs0000644000000000000000000006770713355551371020555 0ustar0000000000000000{- 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: 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) monoid-subclasses-0.4.6.1/Data/Monoid/Null.hs0000644000000000000000000001037613355551371017063 0ustar0000000000000000{- 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) monoid-subclasses-0.4.6.1/Data/Monoid/Textual.hs0000644000000000000000000006030413355551371017573 0ustar0000000000000000{- 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 #-} monoid-subclasses-0.4.6.1/Data/Monoid/Factorial.hs0000644000000000000000000012431113355551371020050 0ustar0000000000000000{- 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 ()) monoid-subclasses-0.4.6.1/Data/Monoid/Instances/0000755000000000000000000000000013355551371017535 5ustar0000000000000000monoid-subclasses-0.4.6.1/Data/Monoid/Instances/Concat.hs0000644000000000000000000003002613355551371021301 0ustar0000000000000000{- 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) monoid-subclasses-0.4.6.1/Data/Monoid/Instances/Positioned.hs0000644000000000000000000007725513355551371022226 0ustar0000000000000000{- 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 #-} monoid-subclasses-0.4.6.1/Data/Monoid/Instances/Measured.hs0000644000000000000000000001301213355551371021633 0ustar0000000000000000{- 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 monoid-subclasses-0.4.6.1/Data/Monoid/Instances/Stateful.hs0000644000000000000000000002401013355551371021655 0ustar0000000000000000{- 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) monoid-subclasses-0.4.6.1/Data/Monoid/Instances/ByteString/0000755000000000000000000000000013355551371021627 5ustar0000000000000000monoid-subclasses-0.4.6.1/Data/Monoid/Instances/ByteString/UTF8.hs0000644000000000000000000006406613355551371022725 0ustar0000000000000000{- 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> factors bs' -- >["D","<","l","b","\193","\177"] -- >> utf8' -- >"D> 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 #-}