monoid-subclasses-1.2.4/0000755000000000000000000000000007346545000013341 5ustar0000000000000000monoid-subclasses-1.2.4/BSD3-LICENSE.txt0000644000000000000000000000272107346545000015657 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-1.2.4/CHANGELOG.md0000644000000000000000000001335707346545000015163 0ustar0000000000000000Version 1.2.4 --------------- * Added `Data.Monoid.Instances.PrefixMemory.Shadowed` monoid transformer Version 1.2.3 --------------- * Added `DistributiveGCDMonoid` and `DistributiveLCMMonoid` type class by Jonathan Knowles Version 1.2.2 --------------- * Added `Data.Monoid.LCM` module with `LCMMonoid` type class by Jonathan Knowles * Repaired links to Hackage within `README.md` by Jonathan Knowles Version 1.2.1 --------------- * Fix for the `Monus` instance for `Maybe` by Jonathan Knowles Version 1.2 --------------- * Dropped support for GHC < 8.4 * Depending on new `commutative-semigroups` package * Modified the `instance OverlappingMonoid/Monus Map/IntMap` instances to conform with the class laws * Bumped the `vector` dependency upper bounds Version 1.1.4 --------------- * Canonicalized all `mappend` definitions * Added `deriving (Data, Typeable)` to all data types Version 1.1.3 --------------- * Support for text-2.0 by Bodigrim Version 1.1.2 --------------- * CI tests * Fallback implementation of `stripCommonSuffix @Text` for GHCjs by Jack Kelly * Fixed documentation bug #31, Factorial laws too strong Version 1.1.1 --------------- * Fixed compilation with GHC 8.0.2 * `Positioned` doesn't use a column for zero-width characters any more Version 1.1 --------------- * Added a new TextualMonoid method `toText` for performance * Fixed the calculations of `column` of `LinePositioned` * Changed the `column` of `LinePositioned` to be one-based * `LinePositioned` now treats FF, CR, and TAB characters as special, in accordance with Haskell language specification. Version 1.0.1 --------------- * Incremented the lower bound of the base dependency * Fixed Haddock links Version 1.0 --------------- * Fixed issue #24, unlawful LeftReductiveMonoid instance for Map * Tightened the laws of GCD classes, dropped instances for Sum and Product * Introduced the `Monus` class * Introduced the `OverlappingGCDMonoid` class * Added the instances of type `Sum Natural` and `Product Natural` * Using the language extensions `FlexibleInstances` and `OverlappingInstances` * Removed the linear complexity requirement * Added and documented less efficient instances * Moved various GCD classes into the new module `Data.Monoid.GCD` * Added module `Data.Semigroup.Cancellative` with `Semigroup` subclasses * Added module `Data.Semigroup.Factorial` with `Semigroup` subclasses * Deprecated several `Monoid` subclasses and made them constraint synonyms instead: * `type CommutativeMonoid m = (Monoid m, Commutative m)` * `type ReductiveMonoid m = (Monoid m, Reductive m)` * `type LeftReductiveMonoid m = (Monoid m, LeftReductive m)` * `type RightReductiveMonoid m = (Monoid m, RightReductive m)` * `type CancellativeMonoid m = (Monoid m, Cancellative m)` * `type LeftCancellativeMonoid m = (Monoid m, LeftCancellative m)` * `type RightCancellativeMonoid m = (Monoid m, RightCancellative m)` Version 0.4.6.1 --------------- 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-1.2.4/README.md0000644000000000000000000001060007346545000014615 0ustar0000000000000000monoid-subclasses ================= ### Subclasses of Semigroup and Monoid with a solid theoretical foundation and practical purposes ### The monoid-subclasses package has been released [on Hackage](https://hackage.haskell.org/package/monoid-subclasses). The package defines several classes that are richer than [semigroups](https://hackage.haskell.org/package/base/docs/Data-Semigroup.html#t:Semigroup) and [monoids](https://hackage.haskell.org/package/base/docs/Data-Monoid.html#t:Monoid) but less demanding than [groups](https://hackage.haskell.org/package/groups/docs/Data-Group.html): * [Reductive](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Semigroup-Cancellative.html#t:Reductive) provides the operator `` which acts as a partial inverse of the semigroup `<>` operator. * [Cancellative](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Semigroup-Cancellative.html#t:Cancellative) is a subclass of `Reductive` that provides additional guarantees about the `` operation result: (a <> b) a == Just b (a <> b) b == Just a Every group (*i.e.*, every `Monoid a` with the operation `inverse :: a -> a`) is a cancellative monoid where `a b = Just (a <> inverse b)` but not every `Cancellative` monoid is a group. * [GCDMonoid](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-GCD.html#t:GCDMonoid) is a subclass of `Reductive` and `Monoid` that provides the `gcd` operation for getting the greatest common denominator for two given monoid values. * [LCMMonoid](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-LCM.html#t:LCMMonoid) is a subclass of `Reductive` and `Monoid` that provides the `lcm` operation for getting the least common multiple for two given monoid values. * [Monus](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-Monus.html#t:Monus) provides the `<\>` monus operation. The set difference is one familiar instance of this operation. * [MonoidNull](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-Null.html#t:MonoidNull) class provides the Boolean `null` operation that checks if the argument monoid is `mempty`. * [Factorial](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Semigroup-Factorial.html#t:Factorial) and [FactorialMonoid](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-Factorial.html#t:FactorialMonoid) classes represent semigroups and monoids that can be split up into irreducible factors. That's the theoretical point of view. From the practical point of view, the main purpose of the _monoid-subclasses_ package is similar to that of [ListLike](https://hackage.haskell.org/package/ListLike/docs/Data-ListLike.html) - to provide unifying abstractions for various monoidal data types in Haskell, primarily [String](https://hackage.haskell.org/package/base/docs/Data-String.html#t:String), [ByteString](https://hackage.haskell.org/package/bytestring/docs/Data-ByteString.html#t:ByteString), and [Text](https://hackage.haskell.org/package/text). All three types are already instances of the [Monoid](https://hackage.haskell.org/package/base/docs/Data-Monoid.html#t:Monoid) class. While that abstraction is useful for building sequences of data, it doesn't help with deconstructing them. That being said, there are two major differences in the goals of _ListLike_ and _monoid-subclasses_: * _ListLike_ strives to reproduce the standard [Data.List](https://hackage.haskell.org/package/base/docs/Data-List.html) interface, whereas _monoid-subclasses_ builds from deeper theoretical foundations; and * The _monoid-subclasses_ implementation uses standard Haskell 2010, with the exception of two minor extensions which can be worked around if necessary. The [incremental-parser](https://hackage.haskell.org/package/incremental-parser) package can serve as a compact example of a parser library that can be applied to different input types thanks to _monoid-subclasses_. There is also [picoparsec](https://hackage.haskell.org/package/picoparsec), a fork of [attoparsec](https://hackage.haskell.org/package/attoparsec), and the heavy-duty [grammatical-parsers](https://hackage.haskell.org/package/grammatical-parsers) library. A more thorough description of the library design can be found in the Haskell Symposium 2013 paper [Adding Structure to Monoids ](https://github.com/blamario/monoid-subclasses/wiki/Files/HaskellSymposium2013.pdf) monoid-subclasses-1.2.4/Setup.lhs0000644000000000000000000000011707346545000015150 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain monoid-subclasses-1.2.4/Test/0000755000000000000000000000000007346545000014260 5ustar0000000000000000monoid-subclasses-1.2.4/Test/TestMonoidSubclasses.hs0000644000000000000000000022233407346545000020737 0ustar0000000000000000{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} {-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} {- HLINT ignore "Use camelCase" -} module Main where import Prelude (Bool(..), Ordering, Int, Integer, Double, Float, Char, String, Maybe(..), Either(..), Eq, Show, (.), ($), (*), (==), (/=), (&&), (||), (++), (>>=), fmap, maybe, either, map, all, not, undefined, const, flip, succ, uncurry, min, id, replicate, minBound, maxBound, otherwise, fst, snd, concatMap, mappend, div) import Test.Tasty (defaultMain, testGroup) import Test.Tasty.QuickCheck (Arbitrary, CoArbitrary, Property, Gen, arbitrary, coarbitrary, property, label, forAll, mapSize, testProperty, variant, whenFail, (.&&.), (===)) 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 Numeric.Natural (Natural) 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.CharVector () import Data.Monoid.Instances.Concat (Concat) import qualified Data.Monoid.Instances.Concat as Concat import Data.Monoid.Instances.Measured (Measured) import qualified Data.Monoid.Instances.Measured as Measured import qualified Data.Monoid.Instances.PrefixMemory as PrefixMemory import Data.Monoid.Instances.Stateful (Stateful) import qualified Data.Monoid.Instances.Stateful as Stateful import Data.Monoid.Instances.Positioned (OffsetPositioned, LinePositioned) import qualified Data.Monoid.Instances.Positioned as Positioned import Data.Semigroup (Semigroup, (<>)) import Data.Monoid (Monoid, mempty, mconcat, All(All), Any(Any), Dual(Dual), First(First), Last(Last), Sum(Sum), Product(Product)) import Data.Semigroup.Factorial (Factorial, StableFactorial, factors, primePrefix, primeSuffix, foldl, foldl', foldr, length, reverse) import Data.Semigroup.Cancellative (Commutative, Reductive, LeftReductive, RightReductive, Cancellative, LeftCancellative, RightCancellative, (), isPrefixOf, stripPrefix, isSuffixOf, stripSuffix) import Data.Monoid.Null (MonoidNull, PositiveMonoid, null) import Data.Monoid.Factorial (FactorialMonoid, splitPrimePrefix, splitPrimeSuffix, inits, tails, span, spanMaybe, split, splitAt) import Data.Monoid.GCD ( GCDMonoid , LeftGCDMonoid , RightGCDMonoid , DistributiveGCDMonoid , LeftDistributiveGCDMonoid , RightDistributiveGCDMonoid , commonPrefix , commonSuffix , gcd , stripCommonPrefix , stripCommonSuffix ) import Data.Monoid.LCM ( LCMMonoid , DistributiveLCMMonoid , lcm ) import Data.Monoid.Monus (OverlappingGCDMonoid, Monus, (<\>), overlap, stripOverlap, stripPrefixOverlap, stripSuffixOverlap) import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Textual as Textual 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) | OverlappingGCDTest (OverlappingGCDMonoidInstance -> Property) | MonusTest (MonusInstance -> Property) | LeftCancellativeTest (LeftCancellativeMonoidInstance -> Property) | RightCancellativeTest (RightCancellativeMonoidInstance -> Property) | CancellativeTest (CancellativeMonoidInstance -> Property) | LeftGCDTest (LeftGCDMonoidInstance -> Property) | RightGCDTest (RightGCDMonoidInstance -> Property) | GCDTest (GCDMonoidInstance -> Property) | DistributiveGCDTest (DistributiveGCDMonoidInstance -> Property) | LeftDistributiveGCDTest (LeftDistributiveGCDMonoidInstance -> Property) | RightDistributiveGCDTest (RightDistributiveGCDMonoidInstance -> Property) | LCMTest (LCMMonoidInstance -> Property) | DistributiveLCMTest (DistributiveLCMMonoidInstance -> Property) data CommutativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Commutative a, Monoid 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, StableFactorial a, FactorialMonoid a, PositiveMonoid 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, StableFactorial a, FactorialMonoid a, PositiveMonoid a, TextualMonoid a) => StableTextualMonoidInstance a data LeftReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, LeftReductive a) => LeftReductiveMonoidInstance a data RightReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, RightReductive a) => RightReductiveMonoidInstance a data ReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, Reductive a) => ReductiveMonoidInstance a data OverlappingGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, OverlappingGCDMonoid a, FactorialMonoid a) => OverlappingGCDMonoidInstance a data MonusInstance = forall a. (Arbitrary a, Show a, Eq a, Monus a, FactorialMonoid a) => MonusInstance a data LeftCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, LeftCancellative a) => LeftCancellativeMonoidInstance a data RightCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, RightCancellative a) => RightCancellativeMonoidInstance a data CancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, Monoid a, Cancellative a) => CancellativeMonoidInstance a data LeftGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) => 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 DistributiveGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, DistributiveGCDMonoid a) => DistributiveGCDMonoidInstance a data LeftDistributiveGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftDistributiveGCDMonoid a) => LeftDistributiveGCDMonoidInstance a data RightDistributiveGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightDistributiveGCDMonoid a) => RightDistributiveGCDMonoidInstance a data LCMMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LCMMonoid a) => LCMMonoidInstance a data DistributiveLCMMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, DistributiveLCMMonoid a) => DistributiveLCMMonoidInstance a commutativeInstances :: [CommutativeMonoidInstance] commutativeInstances = map upcast reductiveInstances ++ [CommutativeMonoidInstance (mempty :: Product Double)] 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 :: (Product Natural)), PositiveMonoidInstance (mempty :: (Sum Natural)), 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 prefixed 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) prefixed (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (PrefixMemory.shadowed 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), TextualMonoidInstance (mempty :: TestOffsetPositionedString), TextualMonoidInstance (mempty :: TestLinePositionedString)] where upcast (StableTextualMonoidInstance i) = TextualMonoidInstance i stableTextualInstances :: [StableTextualMonoidInstance] stableTextualInstances = stable1 ++ map measure stable1 ++ map prefixed 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) prefixed (StableTextualMonoidInstance i) = StableTextualMonoidInstance (PrefixMemory.shadowed 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 :: IntMap Char), LeftReductiveMonoidInstance (mempty :: Map Char Int), LeftReductiveMonoidInstance (mempty :: Concat String), LeftReductiveMonoidInstance (mempty :: Concat ByteString), LeftReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), LeftReductiveMonoidInstance (mempty :: Concat Text), LeftReductiveMonoidInstance (mempty :: Concat Lazy.Text), LeftReductiveMonoidInstance (mempty :: Concat (Dual Text)), LeftReductiveMonoidInstance (mempty :: LinePositioned Text), LeftReductiveMonoidInstance (mempty :: OffsetPositioned Text), LeftReductiveMonoidInstance (mempty :: Measured Text), LeftReductiveMonoidInstance (mempty :: PrefixMemory.Shadowed Text), LeftReductiveMonoidInstance (mempty :: Stateful (Sum Integer) Text)] where upcast (LeftCancellativeMonoidInstance i) = LeftReductiveMonoidInstance i rightReductiveInstances = map upcast rightCancellativeInstances ++ [RightReductiveMonoidInstance (mempty :: Product Integer), RightReductiveMonoidInstance (mempty :: IntSet), RightReductiveMonoidInstance (mempty :: Map Char Int), RightReductiveMonoidInstance (mempty :: IntMap Char), RightReductiveMonoidInstance (mempty :: Set String), RightReductiveMonoidInstance (mempty :: Concat ByteString), RightReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), RightReductiveMonoidInstance (mempty :: Concat Text), RightReductiveMonoidInstance (mempty :: Concat Lazy.Text), RightReductiveMonoidInstance (mempty :: Concat (Dual Text)), RightReductiveMonoidInstance (mempty :: LinePositioned Text), RightReductiveMonoidInstance (mempty :: OffsetPositioned Text), RightReductiveMonoidInstance (mempty :: Measured Text), RightReductiveMonoidInstance (mempty :: PrefixMemory.Shadowed Text), RightReductiveMonoidInstance (mempty :: Stateful (Sum Integer) Text)] where upcast (RightCancellativeMonoidInstance i) = RightReductiveMonoidInstance i reductiveInstances = map upcast cancellativeInstances ++ [ReductiveMonoidInstance (mempty :: Product Integer), ReductiveMonoidInstance (mempty :: IntSet), ReductiveMonoidInstance (mempty :: Maybe IntSet), ReductiveMonoidInstance (mempty :: Set Integer)] where upcast (CancellativeMonoidInstance i) = ReductiveMonoidInstance i overlappingGCDMonoidInstances = map upcast monusInstances ++ [OverlappingGCDMonoidInstance (mempty :: String), OverlappingGCDMonoidInstance (mempty :: Seq Int), OverlappingGCDMonoidInstance (mempty :: ByteString), OverlappingGCDMonoidInstance (mempty :: Lazy.ByteString), OverlappingGCDMonoidInstance (mempty :: Text), OverlappingGCDMonoidInstance (mempty :: Lazy.Text), OverlappingGCDMonoidInstance (mempty :: Vector Char), OverlappingGCDMonoidInstance (mempty :: IntMap Char), OverlappingGCDMonoidInstance (mempty :: Map Char Int)] where upcast (MonusInstance i) = OverlappingGCDMonoidInstance i monusInstances = [MonusInstance (mempty :: Product Natural), MonusInstance (mempty :: Sum Natural), MonusInstance (mempty :: Dual (Product Natural)), MonusInstance (mempty :: Maybe ()), MonusInstance (mempty :: Maybe (Product Natural)), MonusInstance (mempty :: Maybe (Sum Natural)), MonusInstance (mempty :: IntSet), MonusInstance (mempty :: Set String)] 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 = [CancellativeMonoidInstance ()] 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 :: Text), RightGCDMonoidInstance (mempty :: Lazy.Text), RightGCDMonoidInstance (mempty :: String), 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 = [ GCDMonoidInstance (mempty :: ()) , GCDMonoidInstance (mempty :: Product Natural) , GCDMonoidInstance (mempty :: Dual (Product Natural)) , GCDMonoidInstance (mempty :: IntSet) , GCDMonoidInstance (mempty :: Set String) ] distributiveGCDMonoidInstances :: [DistributiveGCDMonoidInstance] distributiveGCDMonoidInstances = [ DistributiveGCDMonoidInstance (mempty :: ()) , DistributiveGCDMonoidInstance (mempty :: Product Natural) , DistributiveGCDMonoidInstance (mempty :: Sum Natural) , DistributiveGCDMonoidInstance (mempty :: IntSet) , DistributiveGCDMonoidInstance (mempty :: Set ()) , DistributiveGCDMonoidInstance (mempty :: Set Bool) , DistributiveGCDMonoidInstance (mempty :: Set Word) , DistributiveGCDMonoidInstance (mempty :: Dual (Set ())) , DistributiveGCDMonoidInstance (mempty :: Dual (Set Bool)) , DistributiveGCDMonoidInstance (mempty :: Dual (Set Word)) ] leftDistributiveGCDMonoidInstances :: [LeftDistributiveGCDMonoidInstance] leftDistributiveGCDMonoidInstances = [ -- Instances for non-commutative monoids: LeftDistributiveGCDMonoidInstance (mempty :: [()]) , LeftDistributiveGCDMonoidInstance (mempty :: [Bool]) , LeftDistributiveGCDMonoidInstance (mempty :: [Word]) , LeftDistributiveGCDMonoidInstance (mempty :: Seq ()) , LeftDistributiveGCDMonoidInstance (mempty :: Seq Bool) , LeftDistributiveGCDMonoidInstance (mempty :: Seq Word) , LeftDistributiveGCDMonoidInstance (mempty :: Vector ()) , LeftDistributiveGCDMonoidInstance (mempty :: Vector Bool) , LeftDistributiveGCDMonoidInstance (mempty :: Vector Word) , LeftDistributiveGCDMonoidInstance (mempty :: ByteString) , LeftDistributiveGCDMonoidInstance (mempty :: Lazy.ByteString) , LeftDistributiveGCDMonoidInstance (mempty :: Text) , LeftDistributiveGCDMonoidInstance (mempty :: Lazy.Text) -- Instances for commutative monoids: , LeftDistributiveGCDMonoidInstance (mempty :: ()) , LeftDistributiveGCDMonoidInstance (mempty :: Product Natural) , LeftDistributiveGCDMonoidInstance (mempty :: Sum Natural) , LeftDistributiveGCDMonoidInstance (mempty :: IntSet) , LeftDistributiveGCDMonoidInstance (mempty :: Set ()) , LeftDistributiveGCDMonoidInstance (mempty :: Set Bool) , LeftDistributiveGCDMonoidInstance (mempty :: Set Word) -- Instances for monoid transformers: , LeftDistributiveGCDMonoidInstance (mempty :: Dual [()]) , LeftDistributiveGCDMonoidInstance (mempty :: Dual [Bool]) , LeftDistributiveGCDMonoidInstance (mempty :: Dual [Word]) ] rightDistributiveGCDMonoidInstances :: [RightDistributiveGCDMonoidInstance] rightDistributiveGCDMonoidInstances = [ -- Instances for non-commutative monoids: RightDistributiveGCDMonoidInstance (mempty :: [()]) , RightDistributiveGCDMonoidInstance (mempty :: [Bool]) , RightDistributiveGCDMonoidInstance (mempty :: [Word]) , RightDistributiveGCDMonoidInstance (mempty :: Seq ()) , RightDistributiveGCDMonoidInstance (mempty :: Seq Bool) , RightDistributiveGCDMonoidInstance (mempty :: Seq Word) , RightDistributiveGCDMonoidInstance (mempty :: Vector ()) , RightDistributiveGCDMonoidInstance (mempty :: Vector Bool) , RightDistributiveGCDMonoidInstance (mempty :: Vector Word) , RightDistributiveGCDMonoidInstance (mempty :: ByteString) , RightDistributiveGCDMonoidInstance (mempty :: Lazy.ByteString) , RightDistributiveGCDMonoidInstance (mempty :: Text) , RightDistributiveGCDMonoidInstance (mempty :: Lazy.Text) -- Instances for commutative monoids: , RightDistributiveGCDMonoidInstance (mempty :: ()) , RightDistributiveGCDMonoidInstance (mempty :: Product Natural) , RightDistributiveGCDMonoidInstance (mempty :: Sum Natural) , RightDistributiveGCDMonoidInstance (mempty :: IntSet) , RightDistributiveGCDMonoidInstance (mempty :: Set ()) , RightDistributiveGCDMonoidInstance (mempty :: Set Bool) , RightDistributiveGCDMonoidInstance (mempty :: Set Word) -- Instances for monoid transformers: , RightDistributiveGCDMonoidInstance (mempty :: Dual [()]) , RightDistributiveGCDMonoidInstance (mempty :: Dual [Bool]) , RightDistributiveGCDMonoidInstance (mempty :: Dual [Word]) ] lcmInstances = [LCMMonoidInstance (mempty :: Product Natural), LCMMonoidInstance (mempty :: Sum Natural), LCMMonoidInstance (mempty :: Dual (Product Natural)), LCMMonoidInstance (mempty :: Dual (Sum Natural)), LCMMonoidInstance (mempty :: IntSet), LCMMonoidInstance (mempty :: (IntSet, IntSet)), LCMMonoidInstance (mempty :: (IntSet, IntSet, IntSet)), LCMMonoidInstance (mempty :: (IntSet, IntSet, IntSet, IntSet)), -- For sets, test with a variety of different universe sizes, from small -- to large: LCMMonoidInstance (mempty :: Set ()), LCMMonoidInstance (mempty :: Set Bool), LCMMonoidInstance (mempty :: Set Ordering), LCMMonoidInstance (mempty :: Set Word8)] distributiveLCMInstances = [ DistributiveLCMMonoidInstance (mempty :: ()) , DistributiveLCMMonoidInstance (mempty :: Product Natural) , DistributiveLCMMonoidInstance (mempty :: Sum Natural) , DistributiveLCMMonoidInstance (mempty :: IntSet) , DistributiveLCMMonoidInstance (mempty :: Set ()) , DistributiveLCMMonoidInstance (mempty :: Set Bool) , DistributiveLCMMonoidInstance (mempty :: Set Word) , DistributiveLCMMonoidInstance (mempty :: Dual (Product Natural)) , DistributiveLCMMonoidInstance (mempty :: Dual (Sum Natural)) ] main = defaultMain (testGroup "MonoidSubclasses" $ map expand tests) where expand (name, test) = testProperty name (List.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 (OverlappingGCDTest checkType) = (map checkType overlappingGCDMonoidInstances) checkInstances (MonusTest checkType) = (map checkType monusInstances) checkInstances (LeftGCDTest checkType) = (map checkType leftGCDInstances) checkInstances (RightGCDTest checkType) = (map checkType rightGCDInstances) checkInstances (GCDTest checkType) = (map checkType gcdInstances) checkInstances (DistributiveGCDTest checkType) = (map checkType distributiveGCDMonoidInstances) checkInstances (LeftDistributiveGCDTest checkType) = (map checkType leftDistributiveGCDMonoidInstances) checkInstances (RightDistributiveGCDTest checkType) = (map checkType rightDistributiveGCDMonoidInstances) checkInstances (LCMTest checkType) = (map checkType lcmInstances) checkInstances (DistributiveLCMTest checkType) = (map checkType distributiveLCMInstances) tests :: [(String, Test)] tests = [("CommutativeMonoid", CommutativeTest checkCommutative), ("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.toText", TextualTest checkToText), ("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), ("stripPrefixOverlap 1", OverlappingGCDTest checkStripPrefixOverlap1), ("stripPrefixOverlap 2", OverlappingGCDTest checkStripPrefixOverlap2), ("stripPrefixOverlap 3", OverlappingGCDTest checkStripPrefixOverlap3), ("stripSuffixOverlap 1", OverlappingGCDTest checkStripSuffixOverlap1), ("stripSuffixOverlap 2", OverlappingGCDTest checkStripSuffixOverlap2), ("stripSuffixOverlap 3", OverlappingGCDTest checkStripSuffixOverlap3), ("overlap law 1", OverlappingGCDTest checkOverlapLaw1), ("overlap law 2", OverlappingGCDTest checkOverlapLaw2), ("overlap law 3", OverlappingGCDTest checkOverlapLaw3), ("overlap idempotence", OverlappingGCDTest checkOverlap_idempotence), ("overlap identity (left)", OverlappingGCDTest checkOverlap_identity_left), ("overlap identity (right)", OverlappingGCDTest checkOverlap_identity_right), ("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), ("stripCommonPrefix 3", LeftGCDTest checkStripCommonPrefix3), ("stripCommonPrefix 4", LeftGCDTest checkStripCommonPrefix4), ("stripCommonSuffix 1", RightGCDTest checkStripCommonSuffix1), ("stripCommonSuffix 2", RightGCDTest checkStripCommonSuffix2), ("stripCommonSuffix 3", RightGCDTest checkStripCommonSuffix3), ("stripCommonSuffix 4", RightGCDTest checkStripCommonSuffix4), ("gcd", GCDTest checkGCD), ("gcd uniqueness", GCDTest checkGCD_uniqueness), ("gcd idempotence", GCDTest checkGCD_idempotence), ("gcd identity (left)", GCDTest checkGCD_identity_left), ("gcd identity (right)", GCDTest checkGCD_identity_right), ("gcd commutativity", GCDTest checkGCD_commutativity), ("gcd associativity", GCDTest checkGCD_associativity), ("gcd distributivity (left)", DistributiveGCDTest checkGCD_distributivity_left), ("gcd distributivity (right)", DistributiveGCDTest checkGCD_distributivity_right), ("commonPrefix idempotence", LeftGCDTest checkCommonPrefix_idempotence), ("commonPrefix identity (left)", LeftGCDTest checkCommonPrefix_identity_left), ("commonPrefix identity (right)", LeftGCDTest checkCommonPrefix_identity_right), ("commonPrefix commutativity", LeftGCDTest checkCommonPrefix_commutativity), ("commonPrefix associativity", LeftGCDTest checkCommonPrefix_associativity), ("commonPrefix distributivity", LeftDistributiveGCDTest checkCommonPrefix_distributivity), ("commonSuffix idempotence", RightGCDTest checkCommonSuffix_idempotence), ("commonSuffix identity (left)", RightGCDTest checkCommonSuffix_identity_left), ("commonSuffix identity (right)", RightGCDTest checkCommonSuffix_identity_right), ("commonSuffix commutativity", RightGCDTest checkCommonSuffix_commutativity), ("commonSuffix associativity", RightGCDTest checkCommonSuffix_associativity), ("commonSuffix distributivity", RightDistributiveGCDTest checkCommonSuffix_distributivity), ("lcm reductivity (left)", LCMTest checkLCM_reductivity_left), ("lcm reductivity (right)", LCMTest checkLCM_reductivity_right), ("lcm uniqueness", LCMTest checkLCM_uniqueness), ("lcm idempotence", LCMTest checkLCM_idempotence), ("lcm identity (left)", LCMTest checkLCM_identity_left), ("lcm identity (right)", LCMTest checkLCM_identity_right), ("lcm commutativity", LCMTest checkLCM_commutativity), ("lcm associativity", LCMTest checkLCM_associativity), ("lcm absorption (gcd-lcm)", LCMTest checkLCM_absorption_gcd_lcm), ("lcm absorption (lcm-gcd)", LCMTest checkLCM_absorption_lcm_gcd), ("lcm distributivity (left)", DistributiveLCMTest checkLCM_distributivity_left), ("lcm distributivity (right)", DistributiveLCMTest checkLCM_distributivity_right), ("lcm distributivity (gcd-lcm)", DistributiveLCMTest checkLCM_distributivity_gcd_lcm), ("lcm distributivity (lcm-gcd)", DistributiveLCMTest checkLCM_distributivity_lcm_gcd) ] checkCommutative (CommutativeMonoidInstance (e :: a)) = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> a <> b == b <> a) 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 (mappend 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 wrapSucc a == Textual.concatMap (Textual.singleton . wrapSucc) a && Textual.map id a == a check2 s = Textual.map wrapSucc (fromString s :: a) == fromString (List.map wrapSucc s) wrapSucc c | c == maxBound = minBound | otherwise = succ c 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 checkToText (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen Text) check2 where check1 a = forAll arbitrary $ \f-> Textual.toText f a == Textual.foldr (\t s-> f t <> s) Text.cons Text.empty a check2 s = Textual.toText undefined (Textual.fromText s :: a) == s checkTextualMapAccumL (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumL (,)) ((), a) == ((), a) check2 s = Textual.mapAccumL f c (fromString s :: a) == fmap fromString (List.mapAccumL f c s) c = 0 :: Int f n c = if isLetter c then (succ n, succ c) else (2*n, c) checkTextualMapAccumR (TextualMonoidInstance (_ :: a)) = 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.toString undefined (Textual.dropWhile undefined isLetter (fromString s :: a)) == List.dropWhile isLetter s checkTextualSpan (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.span pt pc a == (Textual.takeWhile pt pc a, Textual.dropWhile pt pc a) 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.toString undefined (Textual.dropWhile_ undefined isLetter (fromString s :: a)) == List.dropWhile isLetter s checkTextualSplit (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = List.all (List.all isLetter . rights . textualFactors) (Textual.split (not . isLetter) a) && (mconcat . intersperse (fromString " ") . Textual.split (== ' ')) a == a checkTextualFind (TextualMonoidInstance (_ :: a)) = 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 checkOverlapLaw1 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripOverlap a b == (stripSuffixOverlap b a, overlap a b, stripPrefixOverlap a b) checkOverlapLaw2 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripSuffixOverlap b a <> overlap a b == a checkOverlapLaw3 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = overlap a b <> stripPrefixOverlap a b == b checkOverlap_idempotence (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> overlap a a === a checkOverlap_identity_left (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> overlap mempty a === mempty checkOverlap_identity_right (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> overlap a mempty === mempty checkStripPrefixOverlap1 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = o `isSuffixOf` b && b `isSuffixOf` (a <> o) where o = stripPrefixOverlap a b checkStripPrefixOverlap2 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check (ap, o, bs) = b `isSuffixOf` (a <> b') && b' `isSuffixOf` bs where a = ap <> o b = o <> bs b' = stripPrefixOverlap a b checkStripPrefixOverlap3 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = all (\(_, s)-> null s || not (b `isSuffixOf` (a <> s))) (splitPrimePrefix b') where b' = stripPrefixOverlap a b checkStripSuffixOverlap1 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = o `isPrefixOf` a && a `isPrefixOf` (o <> b) where o = stripSuffixOverlap b a checkStripSuffixOverlap2 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check (ap, o, bs) = a `isPrefixOf` (a' <> b) && a' `isPrefixOf` ap where a = ap <> o b = o <> bs a' = stripSuffixOverlap b a checkStripSuffixOverlap3 (OverlappingGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = all (\(p, _)-> null p || not (a `isPrefixOf` (p <> b))) (splitPrimeSuffix a') where a' = stripSuffixOverlap b a checkStripPrefix' (LeftCancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripPrefix a (a <> b) == Just b 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 checkStripCommonPrefix3 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check (p, as, bs) = p `isPrefixOf` commonPrefix a b where a = p <> as b = p <> bs checkStripCommonPrefix4 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check (p, a, b) = not (c /= c' && c' `isPrefixOf` a && c' `isPrefixOf` b) where c = commonPrefix a b c' = p <> c checkStripCommonSuffix1 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripCommonSuffix a b == (a', b', s) where s = commonSuffix a b 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 checkStripCommonSuffix3 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check (ap, bp, s) = s `isSuffixOf` commonSuffix a b where a = ap <> s b = bp <> s checkStripCommonSuffix4 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check (a, b, s) = not (c /= c' && c' `isSuffixOf` a && c' `isSuffixOf` b) where c = commonSuffix a b c' = c <> s checkGCD (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = d == commonPrefix a b && d == commonSuffix a b && isJust (a d) && isJust (b d) where d = gcd a b checkGCD_uniqueness (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) $ \(a, b, c) -> all isJust [a c, b c, c gcd a b] === (gcd a b == c) checkGCD_idempotence (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> gcd a a === a checkGCD_identity_left (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> gcd mempty a === mempty checkGCD_identity_right (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> gcd a mempty === mempty checkGCD_commutativity (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) $ \a b -> gcd a b === gcd b a checkGCD_associativity (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) $ \a b c -> gcd a (gcd b c) === gcd (gcd a b) c checkGCD_distributivity_left (DistributiveGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) $ \(a, b, c) -> gcd (a <> b) (a <> c) == a <> gcd b c checkGCD_distributivity_right (DistributiveGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) $ \(a, b, c) -> gcd (a <> c) (b <> c) == gcd a b <> c checkCommonPrefix_idempotence (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> commonPrefix a a === a checkCommonPrefix_identity_left (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> commonPrefix mempty a === mempty checkCommonPrefix_identity_right (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> commonPrefix a mempty === mempty checkCommonPrefix_commutativity (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) $ \a b -> commonPrefix a b === commonPrefix b a checkCommonPrefix_associativity (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) $ \a b c -> (commonPrefix a (commonPrefix b c)) === (commonPrefix (commonPrefix a b) c) checkCommonPrefix_distributivity (LeftDistributiveGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) $ \(a, b, c) -> commonPrefix (a <> b) (a <> c) == a <> commonPrefix b c checkCommonSuffix_idempotence (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> commonSuffix a a === a checkCommonSuffix_identity_left (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> commonSuffix mempty a === mempty checkCommonSuffix_identity_right (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) $ \a -> commonSuffix a mempty === mempty checkCommonSuffix_commutativity (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) $ \a b -> commonSuffix a b === commonSuffix b a checkCommonSuffix_associativity (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) $ \a b c -> (commonSuffix a (commonSuffix b c)) === (commonSuffix (commonSuffix a b) c) checkCommonSuffix_distributivity (RightDistributiveGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) $ \(a, b, c) -> commonSuffix (a <> c) (b <> c) == commonSuffix a b <> c checkLCM_reductivity_left (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check a b = isJust (lcm a b a) checkLCM_reductivity_right (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check a b = isJust (lcm a b b) checkLCM_uniqueness (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check a b c = all isJust [c a, c b, lcm a b c] === (lcm a b == c) checkLCM_idempotence (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = lcm a a === a checkLCM_identity_left (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = lcm mempty a === a checkLCM_identity_right (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = lcm a mempty === a checkLCM_commutativity (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check a b = lcm a b === lcm b a checkLCM_associativity (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check a b c = lcm (lcm a b) c === lcm a (lcm b c) checkLCM_absorption_gcd_lcm (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check a b = lcm a (gcd a b) === a checkLCM_absorption_lcm_gcd (LCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check a b = gcd a (lcm a b) === a checkLCM_distributivity_left (DistributiveLCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check a b c = lcm (a <> b) (a <> c) === a <> lcm b c checkLCM_distributivity_right (DistributiveLCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check a b c = lcm (a <> c) (b <> c) === lcm a b <> c checkLCM_distributivity_gcd_lcm (DistributiveLCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check a b c = lcm a (gcd b c) === gcd (lcm a b) (lcm a c) checkLCM_distributivity_lcm_gcd (DistributiveLCMMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check a b c = gcd a (lcm b c) === lcm (gcd a b) (gcd a c) 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, LeftReductive, LeftCancellative, StableFactorial, Monoid, LeftGCDMonoid, MonoidNull, PositiveMonoid, IsString) newtype TestOffsetPositionedString = TestOffsetPositionedString (OffsetPositioned String) deriving (Show, Arbitrary, CoArbitrary, Semigroup, LeftReductive, Monoid, LeftGCDMonoid, MonoidNull, PositiveMonoid, IsString) newtype TestLinePositionedString = TestLinePositionedString (LinePositioned String) deriving (Show, Arbitrary, CoArbitrary, Semigroup, LeftReductive, Monoid, LeftGCDMonoid, MonoidNull, PositiveMonoid, IsString) instance Factorial TestString where factors (TestString s) = TestString <$> factors s instance FactorialMonoid TestString where splitPrimePrefix (TestString []) = Nothing splitPrimePrefix (TestString (x:xs)) = Just (TestString [x], TestString xs) instance TextualMonoid TestString where splitCharacterPrefix (TestString []) = Nothing splitCharacterPrefix (TestString (x:xs)) = Just (x, TestString xs) instance Eq TestOffsetPositionedString where TestOffsetPositionedString a == TestOffsetPositionedString b = a == b && Positioned.position a == Positioned.position b instance Factorial TestOffsetPositionedString where factors (TestOffsetPositionedString s) = TestOffsetPositionedString <$> factors s instance FactorialMonoid TestOffsetPositionedString where splitPrimePrefix (TestOffsetPositionedString s) = rewrap <$> splitPrimePrefix s where rewrap (x, xs) = (TestOffsetPositionedString x, TestOffsetPositionedString xs) instance TextualMonoid TestOffsetPositionedString where splitCharacterPrefix (TestOffsetPositionedString x) = (TestOffsetPositionedString <$>) <$> Textual.splitCharacterPrefix x instance Eq TestLinePositionedString where TestLinePositionedString a == TestLinePositionedString b = a == b && Positioned.line a == Positioned.line b && Positioned.column a == Positioned.column b && Positioned.position a == Positioned.position b instance Factorial TestLinePositionedString where factors (TestLinePositionedString s) = TestLinePositionedString <$> factors s instance FactorialMonoid TestLinePositionedString where splitPrimePrefix (TestLinePositionedString s) = rewrap <$> splitPrimePrefix s where rewrap (x, xs) = (TestLinePositionedString x, TestLinePositionedString xs) instance TextualMonoid TestLinePositionedString where splitCharacterPrefix (TestLinePositionedString x) = (TestLinePositionedString <$>) <$> Textual.splitCharacterPrefix x instance Arbitrary ByteStringUTF8 where arbitrary = fmap ByteStringUTF8 arbitrary 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, Monoid a) => Arbitrary (PrefixMemory.Shadowed a) where arbitrary = fmap PrefixMemory.shadowed arbitrary instance (Arbitrary a, FactorialMonoid a) => Arbitrary (OffsetPositioned a) where arbitrary = fmap pure arbitrary 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 (PrefixMemory.Shadowed a) where coarbitrary = coarbitrary . PrefixMemory.content 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-1.2.4/monoid-subclasses.cabal0000644000000000000000000000531507346545000017763 0ustar0000000000000000Name: monoid-subclasses Version: 1.2.4 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid Category: Data, Algebra, Text Tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 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-2023 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 hs-source-dirs: src Exposed-Modules: Data.Monoid.Cancellative , Data.Monoid.Factorial , Data.Monoid.GCD , Data.Monoid.Instances.ByteString.UTF8 , Data.Monoid.Instances.CharVector , Data.Monoid.Instances.Concat , Data.Monoid.Instances.Measured , Data.Monoid.Instances.Positioned , Data.Monoid.Instances.PrefixMemory , Data.Monoid.Instances.Stateful , Data.Monoid.LCM , Data.Monoid.Monus , Data.Monoid.Null , Data.Monoid.Textual , Data.Semigroup.Cancellative , Data.Semigroup.Factorial Build-Depends: base >= 4.9 && < 5, bytestring >= 0.9 && < 1.0, containers >= 0.5.7.0 && < 0.7, text >= 0.11 && < 1.3 || >= 2.0 && < 2.1, primes == 0.2.*, vector >= 0.12 && < 0.14, commutative-semigroups >= 0.1 && < 0.2 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 || >= 2.0 && < 2.1, vector >= 0.12 && < 0.14, 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-1.2.4/src/Data/Monoid/0000755000000000000000000000000007346545000016226 5ustar0000000000000000monoid-subclasses-1.2.4/src/Data/Monoid/Cancellative.hs0000644000000000000000000000457607346545000021170 0ustar0000000000000000{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'Monoid' => 'CommutativeMonoid' => 'ReductiveMonoid' => 'CancellativeMonoid' constraint -- synonym hierarchy. -- -- Since most practical monoids in Haskell are not commutative, the last two of these synonyms have two symmetric -- superclasses each: -- -- * 'LeftReductiveMonoid' -- -- * 'LeftCancellativeMonoid' -- -- * 'RightReductiveMonoid' -- -- * 'RightCancellativeMonoid' -- -- This module and its constraint synonyms are provided for compatibility with the older versions of the -- @monoid-sublasses@ library. Starting with version 1.0, the classes from the "Data.Semigroup.Cancellative" module -- are recommended instead. {-# LANGUAGE Haskell2010, ConstraintKinds, FlexibleInstances #-} module Data.Monoid.Cancellative {- from 1.1 DEPRECATED "Use \"Data.Semigroup.Cancellative\" and \"Data.Monoid.GCD\" instead" -} ( module Data.Semigroup.Cancellative, module Data.Monoid.GCD, -- * Symmetric, commutative monoid classes CommutativeMonoid, ReductiveMonoid, CancellativeMonoid, -- * Asymmetric monoid classes LeftReductiveMonoid, RightReductiveMonoid, LeftCancellativeMonoid, RightCancellativeMonoid ) where import Data.Monoid (Monoid) import Data.Semigroup.Cancellative import Data.Monoid.GCD {- from 1.1-} {- DEPRECATED CommutativeMonoid "Use Data.Semigroup.Cancellative.Commutative instead." -} {- DEPRECATED ReductiveMonoid "Use Data.Semigroup.Cancellative.Reductive instead." -} {- DEPRECATED LeftReductiveMonoid "Use Data.Semigroup.Cancellative.LeftReductive instead." -} {- DEPRECATED RightReductiveMonoid "Use Data.Semigroup.Cancellative.RightReductive instead." -} {- DEPRECATED CancellativeMonoid "Use Data.Semigroup.Cancellative.Cancellative instead." -} {- DEPRECATED LeftCancellativeMonoid "Use Data.Semigroup.Cancellative.LeftCancellative instead." -} {- DEPRECATED RightCancellativeMonoid "Use Data.Semigroup.Cancellative.RightCancellative instead." -} type CommutativeMonoid m = (Monoid m, Commutative m) type ReductiveMonoid m = (Monoid m, Reductive m) type LeftReductiveMonoid m = (Monoid m, LeftReductive m) type RightReductiveMonoid m = (Monoid m, RightReductive m) type CancellativeMonoid m = (Monoid m, Cancellative m) type LeftCancellativeMonoid m = (Monoid m, LeftCancellative m) type RightCancellativeMonoid m = (Monoid m, RightCancellative m) monoid-subclasses-1.2.4/src/Data/Monoid/Factorial.hs0000644000000000000000000007304307346545000020475 0ustar0000000000000000{- Copyright 2013-2017 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'FactorialMonoid' class and some of its instances. -- {-# LANGUAGE Haskell2010, ConstraintKinds, FlexibleInstances, Trustworthy #-} module Data.Monoid.Factorial ( module Data.Semigroup.Factorial, FactorialMonoid(..), StableFactorialMonoid, ) where import Control.Arrow (first) import Data.Monoid -- (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import qualified Data.Vector as Vector import Data.Int (Int64) import Data.Semigroup.Factorial import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Prelude hiding (break, drop, dropWhile, foldl, foldr, last, length, map, max, min, null, reverse, span, splitAt, take, takeWhile) -- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Note that -- 'mempty' is not considered a factor. Factors of a 'Product' are literally its prime factors: -- -- prop> factors (Product 12) == [Product 2, Product 2, Product 3] -- -- Factors of a list are /not/ its elements but all its single-item sublists: -- -- prop> factors "abc" == ["a", "b", "c"] -- -- The methods of this class satisfy the following laws in addition to those of 'Factorial': -- -- > null == List.null . factors -- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix) -- > reverse == mconcat . List.reverse . factors -- > primePrefix == maybe mempty fst . splitPrimePrefix -- > primeSuffix == maybe mempty snd . splitPrimeSuffix -- > inits == List.map mconcat . List.inits . factors -- > tails == List.map mconcat . List.tails . factors -- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m) -- > List.all (List.all (not . pred) . factors) . split pred -- > mconcat . intersperse prime . split (== prime) == id -- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m) -- > spanMaybe () (const $ bool Nothing (Maybe ()) . p) m == (takeWhile p m, dropWhile p m, ()) -- > spanMaybe s0 (\s m-> Just $ f s m) m0 == (m0, mempty, foldl f s0 m0) -- > let (prefix, suffix, s') = spanMaybe s f m -- > foldMaybe = foldl g (Just s) -- > g s m = s >>= flip f m -- > in all ((Nothing ==) . foldMaybe) (inits prefix) -- > && prefix == last (filter (isJust . foldMaybe) $ inits m) -- > && Just s' == foldMaybe prefix -- > && m == prefix <> suffix -- -- A minimal instance definition should implement 'splitPrimePrefix' for performance reasons, and other methods where -- beneficial. class (Factorial m, MonoidNull m) => FactorialMonoid m where -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'. splitPrimePrefix :: m -> Maybe (m, m) -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'. splitPrimeSuffix :: m -> Maybe (m, m) -- | Returns the list of all prefixes of the argument, 'mempty' first. inits :: m -> [m] -- | Returns the list of all suffixes of the argument, 'mempty' last. tails :: m -> [m] -- | Like 'List.span' from "Data.List" on the list of prime 'factors'. span :: (m -> Bool) -> m -> (m, m) -- | Equivalent to 'List.break' from "Data.List". break :: (m -> Bool) -> m -> (m, m) -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes -- satisfying the predicate are not a part of the result. split :: (m -> Bool) -> m -> [m] -- | Equivalent to 'List.takeWhile' from "Data.List". takeWhile :: (m -> Bool) -> m -> m -- | Equivalent to 'List.dropWhile' from "Data.List". dropWhile :: (m -> Bool) -> m -> m -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'. spanMaybe :: s -> (s -> m -> Maybe s) -> m -> (m, m, s) -- | Strict version of 'spanMaybe'. spanMaybe' :: s -> (s -> m -> Maybe s) -> m -> (m, m, s) -- | Like 'List.splitAt' from "Data.List" on the list of prime 'factors'. splitAt :: Int -> m -> (m, m) -- | Equivalent to 'List.drop' from "Data.List". drop :: Int -> m -> m -- | Equivalent to 'List.take' from "Data.List". take :: Int -> m -> m splitPrimePrefix x = case factors x of [] -> Nothing prefix : rest -> Just (prefix, mconcat rest) splitPrimeSuffix x = case factors x of [] -> Nothing fs -> Just (mconcat (List.init fs), List.last fs) inits = foldr (\m l-> mempty : List.map (mappend m) l) [mempty] tails m = m : maybe [] (tails . snd) (splitPrimePrefix m) span p m0 = spanAfter id m0 where spanAfter f m = case splitPrimePrefix m of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest _ -> (f mempty, m) break = span . (not .) spanMaybe s0 f m0 = spanAfter id s0 m0 where spanAfter g s m = case splitPrimePrefix m of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, m, s) Nothing -> (m0, m, s) spanMaybe' s0 f m0 = spanAfter id s0 m0 where spanAfter g s m = seq s $ case splitPrimePrefix m of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, m, s) Nothing -> (m0, m, s) split p m = prefix : splitRest where (prefix, rest) = break p m splitRest = case splitPrimePrefix rest of Nothing -> [] Just (_, tl) -> split p tl takeWhile p = fst . span p dropWhile p = snd . span p splitAt n0 m0 | n0 <= 0 = (mempty, m0) | otherwise = split' n0 id m0 where split' 0 f m = (f mempty, m) split' n f m = case splitPrimePrefix m of Nothing -> (f mempty, m) Just (prime, rest) -> split' (pred n) (f . mappend prime) rest drop n p = snd (splitAt n p) take n p = fst (splitAt n p) {-# MINIMAL #-} {-# INLINABLE splitPrimePrefix #-} {-# INLINABLE splitPrimeSuffix #-} {-# INLINABLE inits #-} {-# INLINABLE tails #-} {-# INLINABLE span #-} {-# INLINE break #-} {-# INLINABLE spanMaybe #-} {-# INLINABLE spanMaybe' #-} {-# INLINABLE split #-} {-# INLINE takeWhile #-} {-# INLINE dropWhile #-} {-# INLINABLE splitAt #-} {-# DEPRECATED StableFactorialMonoid "Use Data.Semigroup.Factorial.StableFactorial instead." #-} type StableFactorialMonoid m = (StableFactorial m, FactorialMonoid m, PositiveMonoid m) instance FactorialMonoid () where splitPrimePrefix () = Nothing splitPrimeSuffix () = Nothing instance FactorialMonoid a => FactorialMonoid (Dual a) where splitPrimePrefix (Dual a) = case splitPrimeSuffix a of Nothing -> Nothing Just (p, s) -> Just (Dual s, Dual p) splitPrimeSuffix (Dual a) = case splitPrimePrefix a of Nothing -> Nothing Just (p, s) -> Just (Dual s, Dual p) inits (Dual a) = fmap Dual (reverse $ tails a) tails (Dual a) = fmap Dual (reverse $ inits a) instance (Integral a, Eq a) => FactorialMonoid (Sum a) where splitPrimePrefix (Sum 0) = Nothing splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a)) splitPrimeSuffix (Sum 0) = Nothing splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a)) instance Integral a => FactorialMonoid (Product a) instance FactorialMonoid a => FactorialMonoid (Maybe a) where splitPrimePrefix Nothing = Nothing splitPrimePrefix (Just a) = case splitPrimePrefix a of Nothing -> Just (Just a, Nothing) Just (p, s) -> Just (Just p, if null s then Nothing else Just s) instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b) of (Just (ap, as), _) -> Just ((ap, mempty), (as, b)) (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs)) (Nothing, Nothing) -> Nothing splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b) of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs)) (Just (ap, as), Nothing) -> Just ((ap, b), (as, b)) (Nothing, Nothing) -> Nothing inits (a, b) = List.map (flip (,) mempty) (inits a) ++ List.map ((,) a) (List.tail $ inits b) tails (a, b) = List.map (flip (,) b) (tails a) ++ List.map ((,) mempty) (List.tail $ tails b) span p (x, y) = ((xp, yp), (xs, ys)) where (xp, xs) = span (p . fromFst) x (yp, ys) | null xs = span (p . fromSnd) y | otherwise = (mempty, y) spanMaybe s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2) | otherwise = ((xp, mempty), (xs, y), s1) where (xp, xs, s1) = spanMaybe s0 (\s-> f s . fromFst) x (yp, ys, s2) = spanMaybe s1 (\s-> f s . fromSnd) y spanMaybe' s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2) | otherwise = ((xp, mempty), (xs, y), s1) where (xp, xs, s1) = spanMaybe' s0 (\s-> f s . fromFst) x (yp, ys, s2) = spanMaybe' s1 (\s-> f s . fromSnd) y split p (x0, y0) = fst $ List.foldr combine (ys, False) xs where xs = List.map fromFst $ split (p . fromFst) x0 ys = List.map fromSnd $ split (p . fromSnd) y0 combine x (~(y:rest), False) = (mappend x y : rest, True) combine x (rest, True) = (x:rest, True) splitAt n (x, y) = ((xp, yp), (xs, ys)) where (xp, xs) = splitAt n x (yp, ys) | null xs = splitAt (n - length x) y | otherwise = (mempty, y) {-# INLINE fromFst #-} fromFst :: Monoid b => a -> (a, b) fromFst a = (a, mempty) {-# INLINE fromSnd #-} fromSnd :: Monoid a => b -> (a, b) fromSnd b = (mempty, b) instance (FactorialMonoid a, FactorialMonoid b, FactorialMonoid c) => FactorialMonoid (a, b, c) where splitPrimePrefix (a, b, c) = case (splitPrimePrefix a, splitPrimePrefix b, splitPrimePrefix c) of (Just (ap, as), _, _) -> Just ((ap, mempty, mempty), (as, b, c)) (Nothing, Just (bp, bs), _) -> Just ((a, bp, mempty), (a, bs, c)) (Nothing, Nothing, Just (cp, cs)) -> Just ((a, b, cp), (a, b, cs)) (Nothing, Nothing, Nothing) -> Nothing splitPrimeSuffix (a, b, c) = case (splitPrimeSuffix a, splitPrimeSuffix b, splitPrimeSuffix c) of (_, _, Just (cp, cs)) -> Just ((a, b, cp), (mempty, mempty, cs)) (_, Just (bp, bs), Nothing) -> Just ((a, bp, c), (mempty, bs, c)) (Just (ap, as), Nothing, Nothing) -> Just ((ap, b, c), (as, b, c)) (Nothing, Nothing, Nothing) -> Nothing inits (a, b, c) = List.map (\a1-> (a1, mempty, mempty)) (inits a) ++ List.map (\b1-> (a, b1, mempty)) (List.tail $ inits b) ++ List.map (\c1-> (a, b, c1)) (List.tail $ inits c) tails (a, b, c) = List.map (\a1-> (a1, b, c)) (tails a) ++ List.map (\b1-> (mempty, b1, c)) (List.tail $ tails b) ++ List.map (\c1-> (mempty, mempty, c1)) (List.tail $ tails c) span p (a, b, c) = ((ap, bp, cp), (as, bs, cs)) where (ap, as) = span (p . fromFstOf3) a (bp, bs) | null as = span (p . fromSndOf3) b | otherwise = (mempty, b) (cp, cs) | null as && null bs = span (p . fromThdOf3) c | otherwise = (mempty, c) spanMaybe s0 f (a, b, c) | not (null as) = ((ap, mempty, mempty), (as, b, c), s1) | not (null bs) = ((ap, bp, mempty), (as, bs, c), s2) | otherwise = ((ap, bp, cp), (as, bs, cs), s3) where (ap, as, s1) = spanMaybe s0 (\s-> f s . fromFstOf3) a (bp, bs, s2) = spanMaybe s1 (\s-> f s . fromSndOf3) b (cp, cs, s3) = spanMaybe s2 (\s-> f s . fromThdOf3) c spanMaybe' s0 f (a, b, c) | not (null as) = ((ap, mempty, mempty), (as, b, c), s1) | not (null bs) = ((ap, bp, mempty), (as, bs, c), s2) | otherwise = ((ap, bp, cp), (as, bs, cs), s3) where (ap, as, s1) = spanMaybe' s0 (\s-> f s . fromFstOf3) a (bp, bs, s2) = spanMaybe' s1 (\s-> f s . fromSndOf3) b (cp, cs, s3) = spanMaybe' s2 (\s-> f s . fromThdOf3) c splitAt n (a, b, c) = ((ap, bp, cp), (as, bs, cs)) where (ap, as) = splitAt n a (bp, bs) | null as = splitAt (n - length a) b | otherwise = (mempty, b) (cp, cs) | null as && null bs = splitAt (n - length a - length b) c | otherwise = (mempty, c) {-# INLINE fromFstOf3 #-} fromFstOf3 :: (Monoid b, Monoid c) => a -> (a, b, c) fromFstOf3 a = (a, mempty, mempty) {-# INLINE fromSndOf3 #-} fromSndOf3 :: (Monoid a, Monoid c) => b -> (a, b, c) fromSndOf3 b = (mempty, b, mempty) {-# INLINE fromThdOf3 #-} fromThdOf3 :: (Monoid a, Monoid b) => c -> (a, b, c) fromThdOf3 c = (mempty, mempty, c) instance (FactorialMonoid a, FactorialMonoid b, FactorialMonoid c, FactorialMonoid d) => FactorialMonoid (a, b, c, d) where splitPrimePrefix (a, b, c, d) = case (splitPrimePrefix a, splitPrimePrefix b, splitPrimePrefix c, splitPrimePrefix d) of (Just (ap, as), _, _, _) -> Just ((ap, mempty, mempty, mempty), (as, b, c, d)) (Nothing, Just (bp, bs), _, _) -> Just ((a, bp, mempty, mempty), (a, bs, c, d)) (Nothing, Nothing, Just (cp, cs), _) -> Just ((a, b, cp, mempty), (a, b, cs, d)) (Nothing, Nothing, Nothing, Just (dp, ds)) -> Just ((a, b, c, dp), (a, b, c, ds)) (Nothing, Nothing, Nothing, Nothing) -> Nothing splitPrimeSuffix (a, b, c, d) = case (splitPrimeSuffix a, splitPrimeSuffix b, splitPrimeSuffix c, splitPrimeSuffix d) of (_, _, _, Just (dp, ds)) -> Just ((a, b, c, dp), (mempty, mempty, mempty, ds)) (_, _, Just (cp, cs), Nothing) -> Just ((a, b, cp, d), (mempty, mempty, cs, d)) (_, Just (bp, bs), Nothing, Nothing) -> Just ((a, bp, c, d), (mempty, bs, c, d)) (Just (ap, as), Nothing, Nothing, Nothing) -> Just ((ap, b, c, d), (as, b, c, d)) (Nothing, Nothing, Nothing, Nothing) -> Nothing inits (a, b, c, d) = List.map (\a1-> (a1, mempty, mempty, mempty)) (inits a) ++ List.map (\b1-> (a, b1, mempty, mempty)) (List.tail $ inits b) ++ List.map (\c1-> (a, b, c1, mempty)) (List.tail $ inits c) ++ List.map (\d1-> (a, b, c, d1)) (List.tail $ inits d) tails (a, b, c, d) = List.map (\a1-> (a1, b, c, d)) (tails a) ++ List.map (\b1-> (mempty, b1, c, d)) (List.tail $ tails b) ++ List.map (\c1-> (mempty, mempty, c1, d)) (List.tail $ tails c) ++ List.map (\d1-> (mempty, mempty, mempty, d1)) (List.tail $ tails d) span p (a, b, c, d) = ((ap, bp, cp, dp), (as, bs, cs, ds)) where (ap, as) = span (p . fromFstOf4) a (bp, bs) | null as = span (p . fromSndOf4) b | otherwise = (mempty, b) (cp, cs) | null as && null bs = span (p . fromThdOf4) c | otherwise = (mempty, c) (dp, ds) | null as && null bs && null cs = span (p . fromFthOf4) d | otherwise = (mempty, d) spanMaybe s0 f (a, b, c, d) | not (null as) = ((ap, mempty, mempty, mempty), (as, b, c, d), s1) | not (null bs) = ((ap, bp, mempty, mempty), (as, bs, c, d), s2) | not (null cs) = ((ap, bp, cp, mempty), (as, bs, cs, d), s3) | otherwise = ((ap, bp, cp, dp), (as, bs, cs, ds), s4) where (ap, as, s1) = spanMaybe s0 (\s-> f s . fromFstOf4) a (bp, bs, s2) = spanMaybe s1 (\s-> f s . fromSndOf4) b (cp, cs, s3) = spanMaybe s2 (\s-> f s . fromThdOf4) c (dp, ds, s4) = spanMaybe s3 (\s-> f s . fromFthOf4) d spanMaybe' s0 f (a, b, c, d) | not (null as) = ((ap, mempty, mempty, mempty), (as, b, c, d), s1) | not (null bs) = ((ap, bp, mempty, mempty), (as, bs, c, d), s2) | not (null cs) = ((ap, bp, cp, mempty), (as, bs, cs, d), s3) | otherwise = ((ap, bp, cp, dp), (as, bs, cs, ds), s4) where (ap, as, s1) = spanMaybe' s0 (\s-> f s . fromFstOf4) a (bp, bs, s2) = spanMaybe' s1 (\s-> f s . fromSndOf4) b (cp, cs, s3) = spanMaybe' s2 (\s-> f s . fromThdOf4) c (dp, ds, s4) = spanMaybe' s3 (\s-> f s . fromFthOf4) d splitAt n (a, b, c, d) = ((ap, bp, cp, dp), (as, bs, cs, ds)) where (ap, as) = splitAt n a (bp, bs) | null as = splitAt (n - length a) b | otherwise = (mempty, b) (cp, cs) | null as && null bs = splitAt (n - length a - length b) c | otherwise = (mempty, c) (dp, ds) | null as && null bs && null cs = splitAt (n - length a - length b - length c) d | otherwise = (mempty, d) {-# INLINE fromFstOf4 #-} fromFstOf4 :: (Monoid b, Monoid c, Monoid d) => a -> (a, b, c, d) fromFstOf4 a = (a, mempty, mempty, mempty) {-# INLINE fromSndOf4 #-} fromSndOf4 :: (Monoid a, Monoid c, Monoid d) => b -> (a, b, c, d) fromSndOf4 b = (mempty, b, mempty, mempty) {-# INLINE fromThdOf4 #-} fromThdOf4 :: (Monoid a, Monoid b, Monoid d) => c -> (a, b, c, d) fromThdOf4 c = (mempty, mempty, c, mempty) {-# INLINE fromFthOf4 #-} fromFthOf4 :: (Monoid a, Monoid b, Monoid c) => d -> (a, b, c, d) fromFthOf4 d = (mempty, mempty, mempty, d) instance FactorialMonoid [x] where splitPrimePrefix [] = Nothing splitPrimePrefix (x:xs) = Just ([x], xs) splitPrimeSuffix [] = Nothing splitPrimeSuffix xs = Just (splitLast id xs) where splitLast f last@[_] = (f [], last) splitLast f ~(x:rest) = splitLast (f . (x:)) rest inits = List.inits tails = List.tails break f = List.break (f . (:[])) span f = List.span (f . (:[])) dropWhile f = List.dropWhile (f . (:[])) takeWhile f = List.takeWhile (f . (:[])) spanMaybe s0 f l = (prefix' [], suffix' [], s') where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = (prefix . (x:), id, s2, True) | otherwise = (prefix, suffix . (x:), s1, False) spanMaybe' s0 f l = (prefix' [], suffix' [], s') where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = seq s2 $ (prefix . (x:), id, s2, True) | otherwise = (prefix, suffix . (x:), s1, False) splitAt = List.splitAt drop = List.drop take = List.take instance FactorialMonoid ByteString.ByteString where splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x) splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x) inits = ByteString.inits tails = ByteString.tails break f = ByteString.break (f . ByteString.singleton) span f = ByteString.span (f . ByteString.singleton) spanMaybe s0 f b = case ByteString.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s') where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f b = case ByteString.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s') where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) dropWhile f = ByteString.dropWhile (f . ByteString.singleton) takeWhile f = ByteString.takeWhile (f . ByteString.singleton) split f = ByteString.splitWith f' where f' = f . ByteString.singleton splitAt = ByteString.splitAt drop = ByteString.drop take = ByteString.take instance FactorialMonoid LazyByteString.ByteString where splitPrimePrefix x = if LazyByteString.null x then Nothing else Just (LazyByteString.splitAt 1 x) splitPrimeSuffix x = if LazyByteString.null x then Nothing else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x) inits = LazyByteString.inits tails = LazyByteString.tails break f = LazyByteString.break (f . LazyByteString.singleton) span f = LazyByteString.span (f . LazyByteString.singleton) spanMaybe s0 f b = case LazyByteString.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s') where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f b = case LazyByteString.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s') where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton) takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton) split f = LazyByteString.splitWith f' where f' = f . LazyByteString.singleton splitAt = LazyByteString.splitAt . fromIntegral drop n = LazyByteString.drop (fromIntegral n) take n = LazyByteString.take (fromIntegral n) instance FactorialMonoid Text.Text where splitPrimePrefix = fmap (first Text.singleton) . Text.uncons splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x)) inits = Text.inits tails = Text.tails span f = Text.span (f . Text.singleton) break f = Text.break (f . Text.singleton) dropWhile f = Text.dropWhile (f . Text.singleton) takeWhile f = Text.takeWhile (f . Text.singleton) spanMaybe s0 f t = case Text.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f t = case Text.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) split f = Text.split f' where f' = f . Text.singleton splitAt = Text.splitAt drop = Text.drop take = Text.take instance FactorialMonoid LazyText.Text where splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons splitPrimeSuffix x = if LazyText.null x then Nothing else Just (LazyText.init x, LazyText.singleton (LazyText.last x)) inits = LazyText.inits tails = LazyText.tails span f = LazyText.span (f . LazyText.singleton) break f = LazyText.break (f . LazyText.singleton) dropWhile f = LazyText.dropWhile (f . LazyText.singleton) takeWhile f = LazyText.takeWhile (f . LazyText.singleton) spanMaybe s0 f t = case LazyText.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f t = case LazyText.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) split f = LazyText.split f' where f' = f . LazyText.singleton splitAt = LazyText.splitAt . fromIntegral drop n = LazyText.drop (fromIntegral n) take n = LazyText.take (fromIntegral n) instance Ord k => FactorialMonoid (Map.Map k v) where splitPrimePrefix = fmap singularize . Map.minViewWithKey where singularize ((k, v), rest) = (Map.singleton k v, rest) splitPrimeSuffix = fmap singularize . Map.maxViewWithKey where singularize ((k, v), rest) = (rest, Map.singleton k v) instance FactorialMonoid (IntMap.IntMap a) where splitPrimePrefix = fmap singularize . IntMap.minViewWithKey where singularize ((k, v), rest) = (IntMap.singleton k v, rest) splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey where singularize ((k, v), rest) = (rest, IntMap.singleton k v) instance FactorialMonoid IntSet.IntSet where splitPrimePrefix = fmap singularize . IntSet.minView where singularize (min, rest) = (IntSet.singleton min, rest) splitPrimeSuffix = fmap singularize . IntSet.maxView where singularize (max, rest) = (rest, IntSet.singleton max) instance FactorialMonoid (Sequence.Seq a) where splitPrimePrefix q = case Sequence.viewl q of Sequence.EmptyL -> Nothing hd Sequence.:< rest -> Just (Sequence.singleton hd, rest) splitPrimeSuffix q = case Sequence.viewr q of Sequence.EmptyR -> Nothing rest Sequence.:> last -> Just (rest, Sequence.singleton last) inits = Foldable.toList . Sequence.inits tails = Foldable.toList . Sequence.tails span f = Sequence.spanl (f . Sequence.singleton) break f = Sequence.breakl (f . Sequence.singleton) dropWhile f = Sequence.dropWhileL (f . Sequence.singleton) takeWhile f = Sequence.takeWhileL (f . Sequence.singleton) spanMaybe s0 f b = case Foldable.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f b = case Foldable.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) splitAt = Sequence.splitAt drop = Sequence.drop take = Sequence.take instance Ord a => FactorialMonoid (Set.Set a) where splitPrimePrefix = fmap singularize . Set.minView where singularize (min, rest) = (Set.singleton min, rest) splitPrimeSuffix = fmap singularize . Set.maxView where singularize (max, rest) = (rest, Set.singleton max) instance FactorialMonoid (Vector.Vector a) where splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x) splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x) inits x0 = initsWith x0 [] where initsWith x rest | Vector.null x = x:rest | otherwise = initsWith (Vector.unsafeInit x) (x:rest) tails x = x : if Vector.null x then [] else tails (Vector.unsafeTail x) break f = Vector.break (f . Vector.singleton) span f = Vector.span (f . Vector.singleton) dropWhile f = Vector.dropWhile (f . Vector.singleton) takeWhile f = Vector.takeWhile (f . Vector.singleton) spanMaybe s0 f v = case Vector.ifoldr g Left v s0 of Left s' -> (v, Vector.empty, s') Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') where g i x cont s | Just s' <- f s (Vector.singleton x) = cont s' | otherwise = Right (i, s) spanMaybe' s0 f v = case Vector.ifoldr' g Left v s0 of Left s' -> (v, Vector.empty, s') Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') where g i x cont s | Just s' <- f s (Vector.singleton x) = seq s' (cont s') | otherwise = Right (i, s) splitAt = Vector.splitAt drop = Vector.drop take = Vector.take monoid-subclasses-1.2.4/src/Data/Monoid/GCD.hs0000644000000000000000000005762107346545000017172 0ustar0000000000000000{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'GCDMonoid' subclass of the 'Monoid' class. -- -- The 'GCDMonoid' subclass adds the 'gcd' operation which takes two monoidal arguments and finds their greatest -- common divisor, or (more generally) the greatest monoid that can be extracted with the '' operation from both. -- -- The 'GCDMonoid' class is for Abelian, /i.e./, 'Commutative' monoids. -- -- == Non-commutative GCD monoids -- -- Since most practical monoids in Haskell are not Abelian, the 'GCDMonoid' -- class has three symmetric superclasses: -- -- * 'LeftGCDMonoid' -- -- Class of monoids for which it is possible to find the greatest common -- /prefix/ of two monoidal values. -- -- * 'RightGCDMonoid' -- -- Class of monoids for which it is possible to find the greatest common -- /suffix/ of two monoidal values. -- -- * 'OverlappingGCDMonoid' -- -- Class of monoids for which it is possible to find the greatest common -- /overlap/ of two monoidal values. -- -- == Distributive GCD monoids -- -- Since some (but not all) GCD monoids are also distributive, there are three -- subclasses that add distributivity: -- -- * 'DistributiveGCDMonoid' -- -- Subclass of 'GCDMonoid' with /symmetric/ distributivity. -- -- * 'LeftDistributiveGCDMonoid' -- -- Subclass of 'LeftGCDMonoid' with /left/-distributivity. -- -- * 'RightDistributiveGCDMonoid' -- -- Subclass of 'RightGCDMonoid' with /right/-distributivity. -- {-# LANGUAGE CPP, Haskell2010, FlexibleInstances, Trustworthy #-} module Data.Monoid.GCD ( GCDMonoid (..) , LeftGCDMonoid (..) , RightGCDMonoid (..) , OverlappingGCDMonoid (..) , DistributiveGCDMonoid , LeftDistributiveGCDMonoid , RightDistributiveGCDMonoid ) where import qualified Prelude import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..)) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Unsafe as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Encoding as TextEncoding import qualified Data.Text.Internal as Internal import qualified Data.Text.Internal.Lazy as LazyInternal import Data.Text.Unsafe (reverseIter) #if MIN_VERSION_text(2,0,0) import Data.Text.Unsafe (Iter(..)) #endif import qualified Data.Text.Lazy as LazyText import qualified Data.Text.Lazy.Encoding as LazyEncoding import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import Data.Sequence (ViewL((:<)), ViewR((:>)), (<|), (|>)) import qualified Data.Vector as Vector import Numeric.Natural (Natural) import Data.Semigroup.Cancellative import Data.Monoid.Monus -- These imports are marked as redundant, but are actually required by haddock: import Data.Maybe (isJust) import Prelude hiding (gcd) -- | Class of Abelian monoids that allow the greatest common divisor to be found for any two given values. The -- operations must satisfy the following laws: -- -- > gcd a b == commonPrefix a b == commonSuffix a b -- > Just a' = a p && Just b' = b p -- > where p = gcd a b -- -- In addition, the 'gcd' operation must satisfy the following properties: -- -- __/Uniqueness/__ -- -- @ -- 'all' 'isJust' -- [ a '' c -- , b '' c -- , c '' 'gcd' a b -- ] -- ==> -- (c '==' 'gcd' a b) -- @ -- -- __/Idempotence/__ -- -- @ -- 'gcd' a a '==' a -- @ -- -- __/Identity/__ -- -- @ -- 'gcd' 'mempty' a '==' 'mempty' -- @ -- @ -- 'gcd' a 'mempty' '==' 'mempty' -- @ -- -- __/Commutativity/__ -- -- @ -- 'gcd' a b '==' 'gcd' b a -- @ -- -- __/Associativity/__ -- -- @ -- 'gcd' ('gcd' a b) c '==' 'gcd' a ('gcd' b c) -- @ -- class (Monoid m, Commutative m, Reductive m, LeftGCDMonoid m, RightGCDMonoid m, OverlappingGCDMonoid m) => GCDMonoid m where gcd :: m -> m -> m -- | Class of monoids capable of finding the equivalent of greatest common divisor on the left side of two monoidal -- values. The following laws must be respected: -- -- > stripCommonPrefix a b == (p, a', b') -- > where p = commonPrefix a b -- > Just a' = stripPrefix p a -- > Just b' = stripPrefix p b -- > p == commonPrefix a b && p <> a' == a && p <> b' == b -- > where (p, a', b') = stripCommonPrefix a b -- -- Furthermore, 'commonPrefix' must return the unique greatest common prefix that contains, as its prefix, any other -- prefix @x@ of both values: -- -- > not (x `isPrefixOf` a && x `isPrefixOf` b) || x `isPrefixOf` commonPrefix a b -- -- and it cannot itself be a suffix of any other common prefix @y@ of both values: -- -- > not (y `isPrefixOf` a && y `isPrefixOf` b && commonPrefix a b `isSuffixOf` y) -- -- In addition, the 'commonPrefix' operation must satisfy the following -- properties: -- -- __/Idempotence/__ -- -- @ -- 'commonPrefix' a a '==' a -- @ -- -- __/Identity/__ -- -- @ -- 'commonPrefix' 'mempty' a '==' 'mempty' -- @ -- @ -- 'commonPrefix' a 'mempty' '==' 'mempty' -- @ -- -- __/Commutativity/__ -- -- @ -- 'commonPrefix' a b '==' 'commonPrefix' b a -- @ -- -- __/Associativity/__ -- -- @ -- 'commonPrefix' ('commonPrefix' a b) c -- '==' -- 'commonPrefix' a ('commonPrefix' b c) -- @ -- class (Monoid m, LeftReductive m) => LeftGCDMonoid m where commonPrefix :: m -> m -> m stripCommonPrefix :: m -> m -> (m, m, m) commonPrefix x y = p where (p, _, _) = stripCommonPrefix x y stripCommonPrefix x y = (p, x', y') where p = commonPrefix x y Just x' = stripPrefix p x Just y' = stripPrefix p y {-# MINIMAL commonPrefix | stripCommonPrefix #-} -- | Class of monoids capable of finding the equivalent of greatest common divisor on the right side of two monoidal -- values. The following laws must be respected: -- -- > stripCommonSuffix a b == (a', b', s) -- > where s = commonSuffix a b -- > Just a' = stripSuffix p a -- > Just b' = stripSuffix p b -- > s == commonSuffix a b && a' <> s == a && b' <> s == b -- > where (a', b', s) = stripCommonSuffix a b -- -- Furthermore, 'commonSuffix' must return the unique greatest common suffix that contains, as its suffix, any other -- suffix @x@ of both values: -- -- > not (x `isSuffixOf` a && x `isSuffixOf` b) || x `isSuffixOf` commonSuffix a b -- -- and it cannot itself be a prefix of any other common suffix @y@ of both values: -- -- > not (y `isSuffixOf` a && y `isSuffixOf` b && commonSuffix a b `isPrefixOf` y) -- -- In addition, the 'commonSuffix' operation must satisfy the following -- properties: -- -- __/Idempotence/__ -- -- @ -- 'commonSuffix' a a '==' a -- @ -- -- __/Identity/__ -- -- @ -- 'commonSuffix' 'mempty' a '==' 'mempty' -- @ -- @ -- 'commonSuffix' a 'mempty' '==' 'mempty' -- @ -- -- __/Commutativity/__ -- -- @ -- 'commonSuffix' a b '==' 'commonSuffix' b a -- @ -- -- __/Associativity/__ -- -- @ -- 'commonSuffix' ('commonSuffix' a b) c -- '==' -- 'commonSuffix' a ('commonSuffix' b c) -- @ -- class (Monoid m, RightReductive m) => RightGCDMonoid m where commonSuffix :: m -> m -> m stripCommonSuffix :: m -> m -> (m, m, m) commonSuffix x y = s where (_, _, s) = stripCommonSuffix x y stripCommonSuffix x y = (x', y', s) where s = commonSuffix x y Just x' = stripSuffix s x Just y' = stripSuffix s y {-# MINIMAL commonSuffix | stripCommonSuffix #-} -- Unit instances -- | /O(1)/ instance GCDMonoid () where gcd () () = () -- | /O(1)/ instance LeftGCDMonoid () where commonPrefix () () = () -- | /O(1)/ instance RightGCDMonoid () where commonSuffix () () = () -- Dual instances instance GCDMonoid a => GCDMonoid (Dual a) where gcd (Dual a) (Dual b) = Dual (gcd a b) instance LeftGCDMonoid a => RightGCDMonoid (Dual a) where commonSuffix (Dual a) (Dual b) = Dual (commonPrefix a b) instance RightGCDMonoid a => LeftGCDMonoid (Dual a) where commonPrefix (Dual a) (Dual b) = Dual (commonSuffix a b) -- Sum instances -- | /O(1)/ instance GCDMonoid (Sum Natural) where gcd (Sum a) (Sum b) = Sum (min a b) -- | /O(1)/ instance LeftGCDMonoid (Sum Natural) where commonPrefix a b = gcd a b -- | /O(1)/ instance RightGCDMonoid (Sum Natural) where commonSuffix a b = gcd a b -- Product instances -- | /O(1)/ instance GCDMonoid (Product Natural) where gcd (Product a) (Product b) = Product (Prelude.gcd a b) -- | /O(1)/ instance LeftGCDMonoid (Product Natural) where commonPrefix a b = gcd a b -- | /O(1)/ instance RightGCDMonoid (Product Natural) where commonSuffix a b = gcd a b -- Pair instances instance (GCDMonoid a, GCDMonoid b) => GCDMonoid (a, b) where gcd (a, b) (c, d) = (gcd a c, gcd b d) instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (a, b) where commonPrefix (a, b) (c, d) = (commonPrefix a c, commonPrefix b d) instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (a, b) where commonSuffix (a, b) (c, d) = (commonSuffix a c, commonSuffix b d) -- Triple instances instance (GCDMonoid a, GCDMonoid b, GCDMonoid c) => GCDMonoid (a, b, c) where gcd (a1, b1, c1) (a2, b2, c2) = (gcd a1 a2, gcd b1 b2, gcd c1 c2) instance (LeftGCDMonoid a, LeftGCDMonoid b, LeftGCDMonoid c) => LeftGCDMonoid (a, b, c) where commonPrefix (a1, b1, c1) (a2, b2, c2) = (commonPrefix a1 a2, commonPrefix b1 b2, commonPrefix c1 c2) instance (RightGCDMonoid a, RightGCDMonoid b, RightGCDMonoid c) => RightGCDMonoid (a, b, c) where commonSuffix (a1, b1, c1) (a2, b2, c2) = (commonSuffix a1 a2, commonSuffix b1 b2, commonSuffix c1 c2) -- Quadruple instances instance (GCDMonoid a, GCDMonoid b, GCDMonoid c, GCDMonoid d) => GCDMonoid (a, b, c, d) where gcd (a1, b1, c1, d1) (a2, b2, c2, d2) = (gcd a1 a2, gcd b1 b2, gcd c1 c2, gcd d1 d2) instance (LeftGCDMonoid a, LeftGCDMonoid b, LeftGCDMonoid c, LeftGCDMonoid d) => LeftGCDMonoid (a, b, c, d) where commonPrefix (a1, b1, c1, d1) (a2, b2, c2, d2) = (commonPrefix a1 a2, commonPrefix b1 b2, commonPrefix c1 c2, commonPrefix d1 d2) instance (RightGCDMonoid a, RightGCDMonoid b, RightGCDMonoid c, RightGCDMonoid d) => RightGCDMonoid (a, b, c, d) where commonSuffix (a1, b1, c1, d1) (a2, b2, c2, d2) = (commonSuffix a1 a2, commonSuffix b1 b2, commonSuffix c1 c2, commonSuffix d1 d2) -- Maybe instances instance LeftGCDMonoid x => LeftGCDMonoid (Maybe x) where commonPrefix (Just x) (Just y) = Just (commonPrefix x y) commonPrefix _ _ = Nothing stripCommonPrefix (Just x) (Just y) = (Just p, Just x', Just y') where (p, x', y') = stripCommonPrefix x y stripCommonPrefix x y = (Nothing, x, y) instance RightGCDMonoid x => RightGCDMonoid (Maybe x) where commonSuffix (Just x) (Just y) = Just (commonSuffix x y) commonSuffix _ _ = Nothing stripCommonSuffix (Just x) (Just y) = (Just x', Just y', Just s) where (x', y', s) = stripCommonSuffix x y stripCommonSuffix x y = (x, y, Nothing) -- Set instances -- | /O(m*log(n\/m + 1)), m <= n/ instance Ord a => LeftGCDMonoid (Set.Set a) where commonPrefix = Set.intersection -- | /O(m*log(n\/m + 1)), m <= n/ instance Ord a => RightGCDMonoid (Set.Set a) where commonSuffix = Set.intersection -- | /O(m*log(n\/m + 1)), m <= n/ instance Ord a => GCDMonoid (Set.Set a) where gcd = Set.intersection -- IntSet instances -- | /O(m+n)/ instance LeftGCDMonoid IntSet.IntSet where commonPrefix = IntSet.intersection -- | /O(m+n)/ instance RightGCDMonoid IntSet.IntSet where commonSuffix = IntSet.intersection -- | /O(m+n)/ instance GCDMonoid IntSet.IntSet where gcd = IntSet.intersection -- Map instances -- | /O(m+n)/ instance (Ord k, Eq a) => LeftGCDMonoid (Map.Map k a) where commonPrefix = Map.mergeWithKey (\_ a b -> if a == b then Just a else Nothing) (const Map.empty) (const Map.empty) -- IntMap instances -- | /O(m+n)/ instance Eq a => LeftGCDMonoid (IntMap.IntMap a) where commonPrefix = IntMap.mergeWithKey (\_ a b -> if a == b then Just a else Nothing) (const IntMap.empty) (const IntMap.empty) -- List instances -- | /O(prefixLength)/ instance Eq x => LeftGCDMonoid [x] where commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys commonPrefix _ _ = [] stripCommonPrefix x0 y0 = strip' id x0 y0 where strip' f (x:xs) (y:ys) | x == y = strip' (f . (x :)) xs ys strip' f x y = (f [], x, y) -- | @since 1.0 -- /O(m+n)/ instance Eq x => RightGCDMonoid [x] where stripCommonSuffix x0 y0 = go1 x0 y0 where go1 (_:xs) (_:ys) = go1 xs ys go1 [] [] = go2 id id id x0 y0 go1 [] ys = go2 id yp id x0 yr where (yp, yr) = splitAtLengthOf id ys y0 go1 xs [] = go2 xp id id xr y0 where (xp, xr) = splitAtLengthOf id xs x0 go2 xp yp cs [] [] = (xp [], yp [], cs []) go2 xp yp cs (x:xs) (y:ys) | x == y = go2 xp yp (cs . (x:)) xs ys | otherwise = go2 (xp . cs . (x:)) (yp . cs . (y:)) id xs ys go2 _ _ _ _ _ = error "impossible" splitAtLengthOf yp (_:xs) (y:ys) = splitAtLengthOf (yp . (y:)) xs ys splitAtLengthOf yp [] ys = (yp, ys) splitAtLengthOf _ _ _ = error "impossible" -- Seq instances -- | /O(prefixLength)/ instance Eq a => LeftGCDMonoid (Sequence.Seq a) where stripCommonPrefix = findCommonPrefix Sequence.empty where findCommonPrefix prefix a b = case (Sequence.viewl a, Sequence.viewl b) of (a1: findCommonPrefix (prefix |> a1) a' b' _ -> (prefix, a, b) -- | /O(suffixLength)/ instance Eq a => RightGCDMonoid (Sequence.Seq a) where stripCommonSuffix = findCommonSuffix Sequence.empty where findCommonSuffix suffix a b = case (Sequence.viewr a, Sequence.viewr b) of (a':>a1, b':>b1) | a1 == b1 -> findCommonSuffix (a1 <| suffix) a' b' _ -> (a, b, suffix) -- Vector instances -- | /O(prefixLength)/ instance Eq a => LeftGCDMonoid (Vector.Vector a) where stripCommonPrefix x y = (xp, xs, Vector.drop maxPrefixLength y) where maxPrefixLength = prefixLength 0 (Vector.length x `min` Vector.length y) prefixLength n len | n < len && x Vector.! n == y Vector.! n = prefixLength (succ n) len prefixLength n _ = n (xp, xs) = Vector.splitAt maxPrefixLength x -- | /O(suffixLength)/ instance Eq a => RightGCDMonoid (Vector.Vector a) where stripCommonSuffix x y = findSuffix (Vector.length x - 1) (Vector.length y - 1) where findSuffix m n | m >= 0 && n >= 0 && x Vector.! m == y Vector.! n = findSuffix (pred m) (pred n) findSuffix m n = (Vector.take (succ m) x, yp, ys) where (yp, ys) = Vector.splitAt (succ n) y -- ByteString instances -- | /O(prefixLength)/ instance LeftGCDMonoid ByteString.ByteString where stripCommonPrefix x y = (xp, xs, ByteString.unsafeDrop maxPrefixLength y) where maxPrefixLength = prefixLength 0 (ByteString.length x `min` ByteString.length y) prefixLength n len | n < len, ByteString.unsafeIndex x n == ByteString.unsafeIndex y n = prefixLength (succ n) len | otherwise = n (xp, xs) = ByteString.splitAt maxPrefixLength x -- | /O(suffixLength)/ instance RightGCDMonoid ByteString.ByteString where stripCommonSuffix x y = findSuffix (ByteString.length x - 1) (ByteString.length y - 1) where findSuffix m n | m >= 0, n >= 0, ByteString.unsafeIndex x m == ByteString.unsafeIndex y n = findSuffix (pred m) (pred n) | otherwise = let (yp, ys) = ByteString.splitAt (succ n) y in (ByteString.unsafeTake (succ m) x, yp, ys) -- Lazy ByteString instances -- | /O(prefixLength)/ instance LeftGCDMonoid LazyByteString.ByteString where stripCommonPrefix x y = (xp, xs, LazyByteString.drop maxPrefixLength y) where maxPrefixLength = prefixLength 0 (LazyByteString.length x `min` LazyByteString.length y) prefixLength n len | n < len && LazyByteString.index x n == LazyByteString.index y n = prefixLength (succ n) len prefixLength n _ = n (xp, xs) = LazyByteString.splitAt maxPrefixLength x -- | /O(suffixLength)/ instance RightGCDMonoid LazyByteString.ByteString where stripCommonSuffix x y = findSuffix (LazyByteString.length x - 1) (LazyByteString.length y - 1) where findSuffix m n | m >= 0 && n >= 0 && LazyByteString.index x m == LazyByteString.index y n = findSuffix (pred m) (pred n) findSuffix m n = (LazyByteString.take (succ m) x, yp, ys) where (yp, ys) = LazyByteString.splitAt (succ n) y -- Text instances -- | /O(prefixLength)/ instance LeftGCDMonoid Text.Text where stripCommonPrefix x y = maybe (Text.empty, x, y) id (Text.commonPrefixes x y) -- | @since 1.0 -- /O(suffixLength)/, except on GHCjs where it is /O(m+n)/ instance RightGCDMonoid Text.Text where #if !ghcjs_HOST_OS stripCommonSuffix x@(Internal.Text xarr xoff xlen) y@(Internal.Text yarr yoff ylen) = go (pred xlen) (pred ylen) where go i j | i >= 0 && j >= 0 && xc == yc = go (i+xd) (j+yd) | otherwise = (Internal.text xarr xoff (succ i), Internal.text yarr yoff (succ j), Internal.text xarr (xoff+i+1) (xlen-i-1)) #if MIN_VERSION_text(2,0,0) where Iter xc xd = reverseIter x i Iter yc yd = reverseIter y j #else where (xc, xd) = reverseIter x i (yc, yd) = reverseIter y j #endif #else stripCommonSuffix x y = let (xlist, ylist, slist) = stripCommonSuffix (TextEncoding.encodeUtf8 x) (TextEncoding.encodeUtf8 y) in (TextEncoding.decodeUtf8 xlist, TextEncoding.decodeUtf8 ylist, TextEncoding.decodeUtf8 slist) #endif -- Lazy Text instances -- | /O(prefixLength)/ instance LeftGCDMonoid LazyText.Text where stripCommonPrefix x y = maybe (LazyText.empty, x, y) id (LazyText.commonPrefixes x y) -- | @since 1.0 -- /O(m+n)/ instance RightGCDMonoid LazyText.Text where #if !ghcjs_HOST_OS stripCommonSuffix x0 y0 | x0len < y0len = go id y0p id x0 y0s | x0len > y0len = go x0p id id x0s y0 | otherwise = go id id id x0 y0 where (y0p, y0s) = splitWord16 id (y0len - x0len) y0 (x0p, x0s) = splitWord16 id (x0len - y0len) x0 x0len = lazyLengthWord16 x0 y0len = lazyLengthWord16 y0 lazyLengthWord16 = LazyText.foldlChunks addLength 0 addLength n x = n + (\(Internal.Text _ _ l) -> l) x splitWord16 xp 0 x = (xp, x) splitWord16 xp n (LazyInternal.Chunk x@(Internal.Text arr off len) xs) | n < len = (xp . LazyInternal.chunk (Internal.Text arr off n), LazyInternal.chunk (Internal.Text arr (off+n) (len-n)) xs) | otherwise = splitWord16 (xp . LazyInternal.chunk x) (n - len) xs splitWord16 _ _ LazyInternal.Empty = error "impossible" go xp yp cs LazyInternal.Empty LazyInternal.Empty = (xp mempty, yp mempty, cs mempty) go xp yp cs (LazyInternal.Chunk x@(Internal.Text xarr xoff xlen) xs) (LazyInternal.Chunk y@(Internal.Text yarr yoff ylen) ys) | xlen < ylen = go xp yp cs (LazyInternal.Chunk x xs) (LazyInternal.Chunk (Internal.Text yarr yoff xlen) $ LazyInternal.Chunk (Internal.Text yarr (yoff+xlen) (ylen-xlen)) ys) | xlen > ylen = go xp yp cs (LazyInternal.Chunk (Internal.Text xarr xoff ylen) $ LazyInternal.Chunk (Internal.Text xarr (xoff+ylen) (xlen-ylen)) xs) (LazyInternal.Chunk y ys) | x == y = go xp yp (cs . LazyInternal.chunk x) xs ys | (x1p, y1p, c1s) <- stripCommonSuffix x y = go (xp . cs . LazyInternal.chunk x1p) (yp . cs . LazyInternal.chunk y1p) (LazyInternal.chunk c1s) xs ys go _ _ _ _ _ = error "impossible" #else stripCommonSuffix x y = let (xlist, ylist, slist) = stripCommonSuffix (LazyEncoding.encodeUtf8 x) (LazyEncoding.encodeUtf8 y) in (LazyEncoding.decodeUtf8 xlist, LazyEncoding.decodeUtf8 ylist, LazyEncoding.decodeUtf8 slist) #endif -------------------------------------------------------------------------------- -- DistributiveGCDMonoid -------------------------------------------------------------------------------- -- | Class of /commutative/ GCD monoids with /symmetric/ distributivity. -- -- In addition to the general 'GCDMonoid' laws, instances of this class -- must also satisfy the following laws: -- -- @ -- 'gcd' (a '<>' b) (a '<>' c) '==' a '<>' 'gcd' b c -- @ -- @ -- 'gcd' (a '<>' c) (b '<>' c) '==' 'gcd' a b '<>' c -- @ -- class (LeftDistributiveGCDMonoid m, RightDistributiveGCDMonoid m, GCDMonoid m) => DistributiveGCDMonoid m instance DistributiveGCDMonoid () instance DistributiveGCDMonoid (Product Natural) instance DistributiveGCDMonoid (Sum Natural) instance DistributiveGCDMonoid IntSet.IntSet instance DistributiveGCDMonoid a => DistributiveGCDMonoid (Dual a) instance Ord a => DistributiveGCDMonoid (Set.Set a) ------------------------------------------------------------------------------- -- LeftDistributiveGCDMonoid -------------------------------------------------------------------------------- -- | Class of /left/ GCD monoids with /left/-distributivity. -- -- In addition to the general 'LeftGCDMonoid' laws, instances of this class -- must also satisfy the following law: -- -- @ -- 'commonPrefix' (a '<>' b) (a '<>' c) '==' a '<>' 'commonPrefix' b c -- @ -- class LeftGCDMonoid m => LeftDistributiveGCDMonoid m -- Instances for non-commutative monoids: instance Eq a => LeftDistributiveGCDMonoid [a] instance Eq a => LeftDistributiveGCDMonoid (Sequence.Seq a) instance Eq a => LeftDistributiveGCDMonoid (Vector.Vector a) instance LeftDistributiveGCDMonoid ByteString.ByteString instance LeftDistributiveGCDMonoid LazyByteString.ByteString instance LeftDistributiveGCDMonoid Text.Text instance LeftDistributiveGCDMonoid LazyText.Text -- Instances for commutative monoids: instance LeftDistributiveGCDMonoid () instance LeftDistributiveGCDMonoid (Product Natural) instance LeftDistributiveGCDMonoid (Sum Natural) instance LeftDistributiveGCDMonoid IntSet.IntSet instance Ord a => LeftDistributiveGCDMonoid (Set.Set a) -- Instances for monoid transformers: instance RightDistributiveGCDMonoid a => LeftDistributiveGCDMonoid (Dual a) -------------------------------------------------------------------------------- -- RightDistributiveGCDMonoid -------------------------------------------------------------------------------- -- | Class of /right/ GCD monoids with /right/-distributivity. -- -- In addition to the general 'RightGCDMonoid' laws, instances of this class -- must also satisfy the following law: -- -- @ -- 'commonSuffix' (a '<>' c) (b '<>' c) '==' 'commonSuffix' a b '<>' c -- @ -- class RightGCDMonoid m => RightDistributiveGCDMonoid m -- Instances for non-commutative monoids: instance Eq a => RightDistributiveGCDMonoid [a] instance Eq a => RightDistributiveGCDMonoid (Sequence.Seq a) instance Eq a => RightDistributiveGCDMonoid (Vector.Vector a) instance RightDistributiveGCDMonoid ByteString.ByteString instance RightDistributiveGCDMonoid LazyByteString.ByteString instance RightDistributiveGCDMonoid Text.Text instance RightDistributiveGCDMonoid LazyText.Text -- Instances for commutative monoids: instance RightDistributiveGCDMonoid () instance RightDistributiveGCDMonoid (Product Natural) instance RightDistributiveGCDMonoid (Sum Natural) instance RightDistributiveGCDMonoid IntSet.IntSet instance Ord a => RightDistributiveGCDMonoid (Set.Set a) -- Instances for monoid transformers: instance LeftDistributiveGCDMonoid a => RightDistributiveGCDMonoid (Dual a) monoid-subclasses-1.2.4/src/Data/Monoid/Instances/ByteString/0000755000000000000000000000000007346545000022247 5ustar0000000000000000monoid-subclasses-1.2.4/src/Data/Monoid/Instances/ByteString/UTF8.hs0000644000000000000000000006465507346545000023351 0ustar0000000000000000{- Copyright 2013-2022 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'ByteStringUTF8' newtype wrapper around 'ByteString', together with its 'TextualMonoid' -- instance. The 'FactorialMonoid' instance of a wrapped 'ByteStringUTF8' value differs from the original 'ByteString': -- the prime 'factors' of the original value are its bytes, and for the wrapped value the prime 'factors' are its valid -- UTF8 byte sequences. The following example session demonstrates the relationship: -- -- >> let utf8@(ByteStringUTF8 bs) = fromString "E=mc\xb2" -- >> bs -- >"E=mc\194\178" -- >> factors bs -- >["E","=","m","c","\194","\178"] -- >> utf8 -- >"E=mc²" -- >> factors utf8 -- >["E","=","m","c","²"] -- -- The 'TextualMonoid' instance follows the same logic, but it also decodes all valid UTF8 sequences into -- characters. Any invalid UTF8 byte sequence from the original 'ByteString' is preserved as a single prime factor: -- -- >> let utf8'@(ByteStringUTF8 bs') = ByteStringUTF8 (Data.ByteString.map pred bs) -- >> bs' -- >"D> factors bs' -- >["D","<","l","b","\193","\177"] -- >> utf8' -- >"D> factors utf8' -- >["D","<","l","b","\[193,177]"] {-# LANGUAGE Haskell2010, DeriveDataTypeable #-} module Data.Monoid.Instances.ByteString.UTF8 ( ByteStringUTF8(..), decode ) where import Control.Exception (assert) import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Char (chr, ord, isDigit, isPrint) import Data.Data (Data, Typeable) import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.Maybe (fromMaybe, isJust, isNothing) import Data.String (IsString(fromString)) import Data.Word (Word8) import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as ByteString.Char8 import Data.ByteString.Internal (w2c) import Data.ByteString.Unsafe (unsafeDrop, unsafeHead, unsafeTail, unsafeTake, unsafeIndex) import Data.Text (pack, unpack) import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup.Cancellative (LeftReductive(..), LeftCancellative) import Data.Semigroup.Factorial (Factorial(..)) import Data.Monoid.GCD (LeftGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(..), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..)) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial (FactorialMonoid(..)) import qualified Data.Monoid.Textual as Textual (TextualMonoid(..)) import Prelude hiding (any, drop, dropWhile, foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1, map, concatMap, break, span) newtype ByteStringUTF8 = ByteStringUTF8 ByteString deriving (Data, Eq, Ord, Typeable) -- | Takes a raw 'ByteString' chunk and returns a pair of 'ByteStringUTF8' decoding the prefix of the chunk and the -- remaining suffix that is either null or contains the incomplete last character of the chunk. decode :: ByteString -> (ByteStringUTF8, ByteString) decode bs | ByteString.null bs || l < 0x80 = (ByteStringUTF8 bs, mempty) | l >= 0xC0 = (ByteStringUTF8 (ByteString.init bs), ByteString.singleton l) | ByteString.null prefix = (mempty, bs) | otherwise = case toChar (ByteString.last prefix) suffix of Nothing -> (ByteStringUTF8 (ByteString.init prefix), drop (ByteString.length prefix - 1) bs) Just{} -> (ByteStringUTF8 bs, mempty) where (prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs l = ByteString.last bs -- | O(n) instance Semigroup ByteStringUTF8 where ByteStringUTF8 a <> ByteStringUTF8 b = ByteStringUTF8 (a <> b) {-# INLINE (<>) #-} -- | O(n) instance Monoid ByteStringUTF8 where mempty = ByteStringUTF8 ByteString.empty {-# INLINE mempty #-} mappend = (<>) {-# INLINE mappend #-} -- | O(1) instance MonoidNull ByteStringUTF8 where null (ByteStringUTF8 b) = ByteString.null b {-# INLINE null #-} -- | O(n) instance LeftReductive ByteStringUTF8 where stripPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = fmap ByteStringUTF8 (stripPrefix a b) {-# INLINE stripPrefix #-} ByteStringUTF8 a `isPrefixOf` ByteStringUTF8 b = a `isPrefixOf` b {-# INLINE isPrefixOf #-} instance LeftCancellative ByteStringUTF8 -- | O(prefixLength) instance LeftGCDMonoid ByteStringUTF8 where commonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = ByteStringUTF8 (commonPrefix a b) {-# INLINE commonPrefix #-} stripCommonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = wrapTriple (stripCommonPrefix a b) {-# INLINE stripCommonPrefix #-} instance Show ByteStringUTF8 where showsPrec _ bs s0 = '"' : Textual.foldr showsBytes showsChar ('"' : s0) bs where showsBytes (ByteStringUTF8 b) s = '\\' : shows (ByteString.unpack b) s showsChar c s | isPrint c = c : s | h:_ <- s, isDigit h = "\\" ++ show (ord c) ++ "\\&" ++ s | otherwise = "\\" ++ show (ord c) ++ s instance IsString ByteStringUTF8 where fromString = ByteStringUTF8 . Foldable.foldMap fromChar {-# INLINE fromString #-} instance PositiveMonoid ByteStringUTF8 instance Factorial ByteStringUTF8 where primePrefix utf8@(ByteStringUTF8 bs) | ByteString.null bs = utf8 | unsafeHead bs < 0x80 = ByteStringUTF8 (ByteString.take 1 bs) | otherwise = case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Just i -> ByteStringUTF8 (ByteString.take (succ i) bs) Nothing -> utf8 {-# INLINABLE primePrefix #-} factors (ByteStringUTF8 bs) = List.map ByteStringUTF8 $ ByteString.groupBy continued bs where continued a b = a >= 0x80 && b >= 0x80 && b < 0xC0 {-# INLINABLE factors #-} length (ByteStringUTF8 bs) = fst (ByteString.foldl' count (0, False) bs) where count (n, high) byte | byte < 0x80 = (succ n, False) | byte < 0xC0 = (if high then n else succ n, True) | otherwise = (succ n, True) {-# INLINABLE length #-} foldl f a0 (ByteStringUTF8 bs) = List.foldl f' a0 (groupASCII bs) where f' a b | unsafeHead b < 0x80 = ByteString.foldl f'' a b | otherwise = f a (ByteStringUTF8 b) f'' a w = f a (ByteStringUTF8 $ ByteString.singleton w) {-# INLINABLE foldl #-} foldl' f a0 (ByteStringUTF8 bs) = List.foldl' f' a0 (groupASCII bs) where f' a b | unsafeHead b < 0x80 = ByteString.foldl' f'' a b | otherwise = f a (ByteStringUTF8 b) f'' a w = f a (ByteStringUTF8 $ ByteString.singleton w) {-# INLINABLE foldl' #-} foldr f a0 (ByteStringUTF8 bs) = List.foldr f' a0 (groupASCII bs) where f' b a | unsafeHead b < 0x80 = ByteString.foldr f'' a b | otherwise = f (ByteStringUTF8 b) a f'' w a = f (ByteStringUTF8 $ ByteString.singleton w) a {-# INLINABLE foldr #-} reverse (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.concat $ List.reverse $ List.map reverseASCII $ groupASCII bs) where reverseASCII b | unsafeHead b < 0x80 = ByteString.reverse b | otherwise = b {-# INLINABLE reverse #-} instance FactorialMonoid ByteStringUTF8 where splitPrimePrefix utf8@(ByteStringUTF8 bs) | ByteString.null bs = Nothing | unsafeHead bs < 0x80 = Just (wrapPair $ ByteString.splitAt 1 bs) | otherwise = case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Just i -> Just (wrapPair $ ByteString.splitAt (succ i) bs) Nothing -> Just (utf8, ByteStringUTF8 $ ByteString.empty) {-# INLINABLE splitPrimePrefix #-} splitPrimeSuffix (ByteStringUTF8 bs) | ByteString.null bs = Nothing | ByteString.null prefix = Just (wrapPair splitBS) | not (ByteString.null suffix) && ByteString.last prefix < 0x80 = Just (wrapPair splitBS) | otherwise = Just (wrapPair $ ByteString.splitAt (pred $ ByteString.length prefix) bs) where splitBS@(prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs {-# INLINABLE splitPrimeSuffix #-} splitAt n (ByteStringUTF8 bs) = wrapPair (ByteString.splitAt (charStartIndex n bs) bs) {-# INLINE splitAt #-} take n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.take (charStartIndex n bs) bs) {-# INLINE take #-} drop n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.drop (charStartIndex n bs) bs) {-# INLINE drop #-} dropWhile p (ByteStringUTF8 bs0) = dropASCII bs0 where dropASCII bs = let suffix = ByteString.dropWhile (\w-> w < 0x80 && p (ByteStringUTF8 $ ByteString.singleton w)) bs in if ByteString.null suffix || unsafeHead suffix < 0x80 then ByteStringUTF8 suffix else dropMultiByte suffix dropMultiByte bs = let utf8 = ByteStringUTF8 bs in case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Nothing -> if p utf8 then ByteStringUTF8 ByteString.empty else utf8 Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs in if p (ByteStringUTF8 hd) then dropASCII tl else utf8 {-# INLINE dropWhile #-} takeWhile p utf8@(ByteStringUTF8 bs) = ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs where (ByteStringUTF8 s) = Factorial.dropWhile p utf8 {-# INLINE takeWhile #-} span p utf8@(ByteStringUTF8 bs) = (ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs, suffix) where suffix@(ByteStringUTF8 s) = Factorial.dropWhile p utf8 {-# INLINE span #-} break p = Factorial.span (not . p) {-# INLINE break #-} spanMaybe s0 f (ByteStringUTF8 bs0) = (ByteStringUTF8 $ ByteString.take (ByteString.length bs0 - ByteString.length dropped) bs0, ByteStringUTF8 dropped, s') where (dropped, s') = dropASCII s0 bs0 dropASCII s bs = let suffix = ByteString.drop index bs (index, s1) = ByteString.foldr f8 id bs (0, s) f8 w cont (i, s2) | w < 0x80, Just s3 <- f s2 (ByteStringUTF8 $ ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s3) | otherwise = (i, s2) in if ByteString.null suffix || unsafeHead suffix < 0x80 then (suffix, s1) else dropMultiByte s1 suffix dropMultiByte s bs = case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Nothing -> case f s (ByteStringUTF8 bs) of Just s1 -> (ByteString.empty, s1) Nothing -> (bs, s) Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs in case f s (ByteStringUTF8 hd) of Just s1 -> dropASCII s1 tl Nothing -> (bs, s) {-# INLINE spanMaybe #-} spanMaybe' s0 f (ByteStringUTF8 bs0) = (ByteStringUTF8 $ ByteString.take (ByteString.length bs0 - ByteString.length dropped) bs0, ByteStringUTF8 dropped, s') where (dropped, s') = dropASCII s0 bs0 dropASCII s bs = let suffix = ByteString.drop index bs (index, s1) = ByteString.foldr f8 id bs (0, s) f8 w cont (i, s2) | w < 0x80, Just s3 <- f s2 (ByteStringUTF8 $ ByteString.singleton w) = let i' = succ i :: Int in seq i' $ seq s3 $ cont (i', s3) | otherwise = (i, s) in if ByteString.null suffix || unsafeHead suffix < 0x80 then (suffix, s1) else dropMultiByte s1 suffix dropMultiByte s bs = case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Nothing -> case f s (ByteStringUTF8 bs) of Just s1 -> seq s1 (ByteString.empty, s1) Nothing -> (bs, s) Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs in case f s (ByteStringUTF8 hd) of Just s1 -> seq s1 (dropASCII s1 tl) Nothing -> (bs, s) {-# INLINE spanMaybe' #-} instance TextualMonoid ByteStringUTF8 where singleton = ByteStringUTF8 . fromChar {-# INLINE singleton #-} splitCharacterPrefix (ByteStringUTF8 bs) = ByteString.uncons bs >>= uncurry toChar {-# INLINE splitCharacterPrefix #-} foldl ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldl f (a0, []) bs of (a, []) -> a (a, acc) -> multiByte a acc where f (a, []) c | c < '\x80' = (fc a c, []) | otherwise = (a, [fromIntegral $ ord c]) f (a, acc) c | c < '\x80' = (fc (multiByte a acc) c, []) | c < '\xC0' = (a, fromIntegral (ord c) : acc) | otherwise = (multiByte a acc, [fromIntegral $ ord c]) multiByte a acc = reverseBytesToChar (ft a . ByteStringUTF8) (fc a) acc {-# INLINE foldl #-} foldl' ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldl' f (a0, []) bs of (a, []) -> a (a, acc) -> multiByte a acc where f (a, []) c | c < '\x80' = (fc a c, []) | otherwise = seq a (a, [fromIntegral $ ord c]) f (a, acc) c | seq a c < '\x80' = let a' = multiByte a acc in seq a' (fc a' c, []) | c < '\xC0' = (a, fromIntegral (ord c) : acc) | otherwise = let a' = multiByte a acc in seq a' (a', [fromIntegral $ ord c]) multiByte a acc = reverseBytesToChar (ft a . ByteStringUTF8) (fc a) acc {-# INLINE foldl' #-} foldr ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldr f (a0, []) bs of (a, []) -> a (a, acc) -> multiByte a acc where f c (a, []) | c < '\x80' = (fc c a, []) | c < '\xC0' = (a, [fromIntegral $ ord c]) | otherwise = (ft (ByteStringUTF8 $ ByteString.Char8.singleton c) a, []) f c (a, acc) | c < '\x80' = (fc c (ft (ByteStringUTF8 $ ByteString.pack acc) a), []) | c < '\xC0' = (a, fromIntegral (ord c) : acc) | otherwise = (multiByte a (fromIntegral (ord c) : acc), []) multiByte a acc = bytesToChar ((`ft` a) . ByteStringUTF8) (`fc` a) acc {-# INLINE foldr #-} dropWhile pb pc (ByteStringUTF8 bs) = ByteStringUTF8 $ dropASCII bs where dropASCII rest = case ByteString.Char8.findIndex (\c-> c > '\x7f' || not (pc c)) rest of Nothing -> ByteString.empty Just j -> let rest' = unsafeDrop j rest in if unsafeHead rest' > 0x7f then dropMultiByte rest' else rest' dropMultiByte rest = case splitCharacterPrefix (ByteStringUTF8 rest) of Just (c, ByteStringUTF8 rest') | pc c -> dropASCII rest' Nothing -> let j = succ (headIndex $ drop 1 rest) in if pb (ByteStringUTF8 $ ByteString.take j rest) then dropASCII (unsafeDrop j rest) else rest _ -> rest {-# INLINE dropWhile #-} takeWhile pb pc utf8@(ByteStringUTF8 bs) = ByteStringUTF8 $ unsafeTake (ByteString.length bs - ByteString.length suffix) bs where ByteStringUTF8 suffix = Textual.dropWhile pb pc utf8 {-# INLINE takeWhile #-} span pb pc utf8@(ByteStringUTF8 bs) = (ByteStringUTF8 $ unsafeTake (ByteString.length bs - ByteString.length suffix') bs, suffix) where suffix@(ByteStringUTF8 suffix') = Textual.dropWhile pb pc utf8 {-# INLINE span #-} break pb pc = Textual.span (not . pb) (not . pc) {-# INLINE break #-} spanMaybe s0 ft fc (ByteStringUTF8 bs) = let inner i s | i < len = let w = unsafeIndex bs i in if w < 0x80 then case fc s (w2c w) of Just s' -> inner (i + 1) s' Nothing -> done i s else case splitCharacterPrefix (ByteStringUTF8 $ unsafeDrop i bs) of Just (c, ByteStringUTF8 rest) | Just s' <- fc s c -> inner (len - ByteString.length rest) s' Nothing -> let j = succ (headIndex $ drop (i + 1) bs) in case ft s (ByteStringUTF8 $ ByteString.take j $ unsafeDrop i bs) of Just s' -> inner (i + j) s' Nothing -> done i s _ -> done i s | otherwise = done i s done i s = i `seq` s `seq` (ByteStringUTF8 $ unsafeTake i bs, ByteStringUTF8 $ unsafeDrop i bs, s) len = ByteString.length bs in inner 0 s0 {-# INLINE spanMaybe #-} spanMaybe' s0 ft fc (ByteStringUTF8 bs) = let inner i s | i < len = s `seq` let w = unsafeIndex bs i in if w < 0x80 then case fc s (w2c w) of Just s' -> inner (i + 1) s' Nothing -> done i s else case splitCharacterPrefix (ByteStringUTF8 $ unsafeDrop i bs) of Just (c, ByteStringUTF8 rest) | Just s' <- fc s c -> inner (len - ByteString.length rest) s' Nothing -> let j = succ (headIndex $ drop (i + 1) bs) in case ft s (ByteStringUTF8 $ ByteString.take j $ unsafeDrop i bs) of Just s' -> inner (i + j) s' Nothing -> done i s _ -> done i s | otherwise = done i s done i s = i `seq` s `seq` (ByteStringUTF8 $ unsafeTake i bs, ByteStringUTF8 $ unsafeDrop i bs, s) len = ByteString.length bs in inner 0 s0 {-# INLINE spanMaybe' #-} find p (ByteStringUTF8 bs0) = loop bs0 where loop bs = case ByteString.Char8.findIndex (\c-> c >= '\x80' || p c) bs of Nothing -> Nothing Just i -> let x = unsafeIndex bs i bs' = unsafeDrop (i + 1) bs in if x < 0x80 then Just (w2c x) else case toChar x bs' of Just (c, ByteStringUTF8 rest) | p c -> Just c | otherwise -> loop rest Nothing -> loop (ByteString.dropWhile (not . byteStartsCharacter) bs') {-# INLINE find #-} any p utf8 = isJust (find p utf8) {-# INLINE any #-} all p utf8 = isNothing (find (not . p) utf8) {-# INLINE all #-} elem c utf8@(ByteStringUTF8 bs) | c < '\x80' = ByteString.Char8.elem c bs | otherwise = any (== c) utf8 {-# INLINE elem #-} fromText = ByteStringUTF8 . encodeUtf8 toText f t@(ByteStringUTF8 bs) = either (const $ pack $ toString (unpack . f) t) id (decodeUtf8' bs) reverseBytesToChar :: (ByteString -> a) -> (Char -> a) -> [Word8] -> a reverseBytesToChar ft fc [w] = if w < 0x80 then fc (w2c w) else ft (ByteString.singleton w) reverseBytesToChar ft fc [b0, b1] = assert (0x80 <= b0 && b0 < 0xC0) $ if 0xC2 <= b1 && b1 < 0xE0 then fc (chr (shiftL (fromIntegral b1 .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack [b1, b0]) reverseBytesToChar ft fc [b0, b1, b2] = assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0) $ if (0xE0 < b2 || 0xE0 == b2 && 0xA0 <= b1) && b2 < 0xF0 then fc (chr (shiftL (fromIntegral b2 .&. 0xF) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack [b2, b1, b0]) reverseBytesToChar ft fc [b0, b1, b2, b3] = assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0 && 0x80 <= b2 && b2 < 0xC0) $ if (0xF0 < b3 || 0xF0 == b3 && 0x90 <= b2) && b3 < 0xF5 && (b3 < 0xF4 || b2 < 0x90) then fc (chr (shiftL (fromIntegral b3 .&. 0x7) 18 .|. shiftL (fromIntegral b2 .&. 0x3F) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack [b3, b2, b1, b0]) reverseBytesToChar ft _fc bytes = ft (ByteString.reverse $ ByteString.pack bytes) bytesToChar :: (ByteString -> a) -> (Char -> a) -> [Word8] -> a bytesToChar ft fc [w] = if w < 0x80 then fc (w2c w) else ft (ByteString.singleton w) bytesToChar ft fc bytes@[b1, b0] = assert (0x80 <= b0 && b0 < 0xC0) $ if 0xC2 <= b1 && b1 < 0xE0 then fc (chr (shiftL (fromIntegral b1 .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack bytes) bytesToChar ft fc bytes@[b2, b1, b0] = assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0) $ if (0xE0 < b2 || 0xE0 == b2 && 0xA0 <= b1) && b2 < 0xF0 then fc (chr (shiftL (fromIntegral b2 .&. 0xF) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack bytes) bytesToChar ft fc bytes@[b3, b2, b1, b0] = assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0 && 0x80 <= b2 && b2 < 0xC0) $ if (0xF0 < b3 || 0xF0 == b3 && 0x90 <= b2) && b3 < 0xF5 && (b3 < 0xF4 || b2 < 0x90) then fc (chr (shiftL (fromIntegral b3 .&. 0x7) 18 .|. shiftL (fromIntegral b2 .&. 0x3F) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack bytes) bytesToChar ft _fc bytes = ft (ByteString.pack bytes) wrapPair :: (ByteString, ByteString) -> (ByteStringUTF8, ByteStringUTF8) wrapPair (bs1, bs2) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2) {-# INLINE wrapPair #-} wrapTriple :: (ByteString, ByteString, ByteString) -> (ByteStringUTF8, ByteStringUTF8, ByteStringUTF8) wrapTriple (bs1, bs2, bs3) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2, ByteStringUTF8 bs3) {-# INLINE wrapTriple #-} fromChar :: Char -> ByteString fromChar c | c < '\x80' = ByteString.Char8.singleton c | c < '\x800' = ByteString.pack [0xC0 + fromIntegral (shiftR n 6), 0x80 + fromIntegral (n .&. 0x3F)] | c < '\x10000' = ByteString.pack [0xE0 + fromIntegral (shiftR n 12), 0x80 + fromIntegral (shiftR n 6 .&. 0x3F), 0x80 + fromIntegral (n .&. 0x3F)] | n < 0x200000 = ByteString.pack [0xF0 + fromIntegral (shiftR n 18), 0x80 + fromIntegral (shiftR n 12 .&. 0x3F), 0x80 + fromIntegral (shiftR n 6 .&. 0x3F), 0x80 + fromIntegral (n .&. 0x3F)] | otherwise = error ("Data.Char.ord '" ++ (c : "' >=0x200000")) where n = ord c toChar :: Word8 -> ByteString -> Maybe (Char, ByteStringUTF8) toChar hd tl | hd < 0x80 = Just (w2c hd, ByteStringUTF8 tl) | hd < 0xC2 = Nothing | hd < 0xE0 = do (b0, t0) <- ByteString.uncons tl if headIndex tl == 1 then return (chr (shiftL (fromIntegral hd .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F), ByteStringUTF8 t0) else Nothing | hd < 0xF0 = do (b1, t1) <- ByteString.uncons tl (b0, t0) <- ByteString.uncons t1 if (hd > 0xE0 || b1 >= 0xA0) && headIndex tl == 2 then return (chr (shiftL (fromIntegral hd .&. 0xF) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F), ByteStringUTF8 t0) else Nothing | hd < 0xF5 = do (b2, t2) <- ByteString.uncons tl (b1, t1) <- ByteString.uncons t2 (b0, t0) <- ByteString.uncons t1 if (hd > 0xF0 || b2 >= 0x90) && (hd < 0xF4 || b2 < 0x90) && headIndex tl == 3 then return (chr (shiftL (fromIntegral hd .&. 0x7) 18 .|. shiftL (fromIntegral b2 .&. 0x3F) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F), ByteStringUTF8 t0) else Nothing | otherwise = Nothing groupASCII :: ByteString -> [ByteString] groupASCII = ByteString.groupBy continued where continued a b = (a < 0x80) == (b < 0x80) && b < 0xC0 {-# INLINE groupASCII #-} headIndex :: ByteString -> Int headIndex bs = fromMaybe (ByteString.length bs) $ ByteString.findIndex byteStartsCharacter bs {-# INLINE headIndex #-} byteStartsCharacter :: Word8 -> Bool byteStartsCharacter b = b < 0x80 || b >= 0xC0 {-# INLINE byteStartsCharacter #-} charStartIndex :: Int -> ByteString -> Int charStartIndex n _ | n <= 0 = 0 charStartIndex n0 bs = ByteString.foldr count (const $ ByteString.length bs) bs (n0, False, 0) where count byte _ (0, high, i) | byte < 0x80 || byte >= 0xC0 || not high = i count byte cont (n, high, i) | byte < 0x80 = cont (pred n, False, succ i) | byte < 0xC0 = cont (if high then n else pred n, True, succ i) | otherwise = cont (pred n, True, succ i) {-# INLINE charStartIndex #-} monoid-subclasses-1.2.4/src/Data/Monoid/Instances/0000755000000000000000000000000007346545000020155 5ustar0000000000000000monoid-subclasses-1.2.4/src/Data/Monoid/Instances/CharVector.hs0000644000000000000000000000566407346545000022564 0ustar0000000000000000{- Copyright 2017 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module contains orphan 'IsString' and 'TextualMonoid' instances of @Vector Char@. -- {-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-} {-# OPTIONS_GHC -Wno-orphans #-} module Data.Monoid.Instances.CharVector where import Data.String (IsString(fromString)) import qualified Data.Vector as Vector import Data.Monoid.Textual (TextualMonoid(..)) instance IsString (Vector.Vector Char) where fromString = Vector.fromList instance TextualMonoid (Vector.Vector Char) where singleton = Vector.singleton splitCharacterPrefix t = if Vector.null t then Nothing else Just (Vector.unsafeHead t, Vector.unsafeTail t) characterPrefix = (Vector.!? 0) map = Vector.map concatMap = Vector.concatMap toString = const Vector.toList any = Vector.any all = Vector.all foldl = const Vector.foldl foldl' = const Vector.foldl' foldr = const Vector.foldr scanl = Vector.scanl scanl1 f v | Vector.null v = Vector.empty | otherwise = Vector.scanl1 f v scanr = Vector.scanr scanr1 f v | Vector.null v = Vector.empty | otherwise = Vector.scanr1 f v mapAccumL f a0 t = (a', Vector.reverse $ Vector.fromList l') where (a', l') = Vector.foldl fc (a0, []) t fc (a, l) c = (:l) <$> f a c mapAccumR f a0 t = (a', Vector.fromList l') where (a', l') = Vector.foldr fc (a0, []) t fc c (a, l) = (:l) <$> f a c takeWhile _ = Vector.takeWhile dropWhile _ = Vector.dropWhile break _ = Vector.break span _ = Vector.span spanMaybe s0 _ft fc v = case Vector.ifoldr g Left v s0 of Left s' -> (v, Vector.empty, s') Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') where g i c cont s | Just s' <- fc s c = cont s' | otherwise = Right (i, s) spanMaybe' s0 _ft fc v = case Vector.ifoldr' g Left v s0 of Left s' -> (v, Vector.empty, s') Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') where g i c cont s | Just s' <- fc s c = seq s' (cont s') | otherwise = Right (i, s) find = Vector.find elem = Vector.elem {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE elem #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} monoid-subclasses-1.2.4/src/Data/Monoid/Instances/Concat.hs0000644000000000000000000003050407346545000021722 0ustar0000000000000000{- Copyright 2013-2022 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Concat'. -- {-# LANGUAGE Haskell2010, DeriveDataTypeable #-} module Data.Monoid.Instances.Concat ( Concat, concatenate, extract, force ) where import Control.Applicative -- (Applicative(..)) import Control.Arrow (first) import Data.Data (Data, Typeable) import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.String (IsString(..)) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..), First(..), Sum(..)) import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..)) import Data.Semigroup.Factorial (Factorial(..), StableFactorial) import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..)) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Data.Sequence (Seq) import qualified Data.Sequence as Seq import qualified Data.Text as Text import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, pi) -- | @'Concat'@ is a transparent monoid transformer. The behaviour of the @'Concat' a@ instances of monoid subclasses is -- identical to the behaviour of their @a@ instances, up to the 'pure' isomorphism. -- -- The only purpose of 'Concat' then is to change the performance characteristics of various operations. Most -- importantly, injecting a monoid into 'Concat' has the effect of making 'mappend' a constant-time operation. The -- `splitPrimePrefix` and `splitPrimeSuffix` operations are amortized to constant time, provided that only one or the -- other is used. Using both operations alternately will trigger the worst-case behaviour of O(n). -- data Concat a = Leaf a | Concat a :<> Concat a deriving (Data, Show, Typeable) {-# DEPRECATED concatenate, extract "Concat is not wrapping Seq any more, don't use concatenate nor extract." #-} concatenate :: PositiveMonoid a => Seq a -> Concat a concatenate q | Foldable.all null q = mempty | otherwise = Foldable.foldr (\a c-> if null a then c else Leaf a <> c) mempty q extract :: Concat a -> Seq a extract = Seq.fromList . Foldable.toList force :: Semigroup a => Concat a -> a force (Leaf x) = x force (x :<> y) = force x <> force y instance (Eq a, Semigroup a) => Eq (Concat a) where x == y = force x == force y instance (Ord a, Semigroup a) => Ord (Concat a) where compare x y = compare (force x) (force y) instance Functor Concat where fmap f (Leaf x) = Leaf (f x) fmap f (l :<> r) = fmap f l :<> fmap f r instance Applicative Concat where pure = Leaf Leaf f <*> x = f <$> x (f1 :<> f2) <*> x = (f1 <*> x) :<> (f2 <*> x) instance Foldable.Foldable Concat where fold (Leaf x) = x fold (x :<> y) = Foldable.fold x `mappend` Foldable.fold y foldMap f (Leaf x) = f x foldMap f (x :<> y) = Foldable.foldMap f x `mappend` Foldable.foldMap f y foldl f a (Leaf x) = f a x foldl f a (x :<> y) = Foldable.foldl f (Foldable.foldl f a x) y foldl' f a (Leaf x) = f a x foldl' f a (x :<> y) = let a' = Foldable.foldl' f a x in a' `seq` Foldable.foldl' f a' y foldr f a (Leaf x) = f x a foldr f a (x :<> y) = Foldable.foldr f (Foldable.foldr f a y) x foldr' f a (Leaf x) = f x a foldr' f a (x :<> y) = let a' = Foldable.foldr' f a y in Foldable.foldr' f a' x instance PositiveMonoid a => Semigroup (Concat a) where x <> y | null x = y | null y = x | otherwise = x :<> y instance PositiveMonoid a => Monoid (Concat a) where mempty = Leaf mempty mappend = (<>) instance PositiveMonoid a => MonoidNull (Concat a) where null (Leaf x) = null x null _ = False instance PositiveMonoid a => PositiveMonoid (Concat a) instance (LeftReductive a, StableFactorial a, PositiveMonoid a) => LeftReductive (Concat a) where stripPrefix (Leaf x) (Leaf y) = Leaf <$> stripPrefix x y stripPrefix (xp :<> xs) y = stripPrefix xp y >>= stripPrefix xs stripPrefix x (yp :<> ys) = case (stripPrefix x yp, stripPrefix yp x) of (Just yps, _) -> Just (yps <> ys) (Nothing, Nothing) -> Nothing (Nothing, Just xs) -> stripPrefix xs ys instance (RightReductive a, StableFactorial a, PositiveMonoid a) => RightReductive (Concat a) where stripSuffix (Leaf x) (Leaf y) = Leaf <$> stripSuffix x y stripSuffix (xp :<> xs) y = stripSuffix xs y >>= stripSuffix xp stripSuffix x (yp :<> ys) = case (stripSuffix x ys, stripSuffix ys x) of (Just ysp, _) -> Just (yp <> ysp) (Nothing, Nothing) -> Nothing (Nothing, Just xp) -> stripSuffix xp yp instance (LeftGCDMonoid a, StableFactorial a, PositiveMonoid a) => LeftGCDMonoid (Concat a) where stripCommonPrefix (Leaf x) (Leaf y) = map3 Leaf (stripCommonPrefix x y) stripCommonPrefix (xp :<> xs) y | null xps = (xp <> xsp, xss, yss) | otherwise = (xpp, xps <> xs, ys) where (xpp, xps, ys) = stripCommonPrefix xp y (xsp, xss, yss) = stripCommonPrefix xs ys stripCommonPrefix x (yp :<> ys) | null yps = (yp <> ysp, xss, yss) | otherwise = (ypp, xs, yps <> ys) where (ypp, xs, yps) = stripCommonPrefix x yp (ysp, xss, yss) = stripCommonPrefix xs ys instance (RightGCDMonoid a, StableFactorial a, PositiveMonoid a) => RightGCDMonoid (Concat a) where stripCommonSuffix (Leaf x) (Leaf y) = map3 Leaf (stripCommonSuffix x y) stripCommonSuffix (xp :<> xs) y | null xsp = (xpp, ypp, xps <> xs) | otherwise = (xp <> xsp, yp, xss) where (xsp, yp, xss) = stripCommonSuffix xs y (xpp, ypp, xps) = stripCommonSuffix xp yp stripCommonSuffix x (yp :<> ys) | null ysp = (xpp, ypp, yps <> ys) | otherwise = (xp, yp <> ysp, yss) where (xp, ysp, yss) = stripCommonSuffix x ys (xpp, ypp, yps) = stripCommonSuffix xp yp instance (Factorial a, PositiveMonoid a) => Factorial (Concat a) where factors c = toList c [] where toList (Leaf x) rest | null x = rest | otherwise = (Leaf <$> factors x) ++ rest toList (x :<> y) rest = toList x (toList y rest) primePrefix (Leaf x) = Leaf (primePrefix x) primePrefix (x :<> _) = primePrefix x primeSuffix (Leaf x) = Leaf (primeSuffix x) primeSuffix (_ :<> y) = primeSuffix y foldl f = Foldable.foldl g where g = Factorial.foldl (\a-> f a . Leaf) foldl' f = Foldable.foldl' g where g = Factorial.foldl' (\a-> f a . Leaf) foldr f = Foldable.foldr g where g a b = Factorial.foldr (f . Leaf) b a foldMap f = Foldable.foldMap (Factorial.foldMap (f . Leaf)) length x = getSum $ Foldable.foldMap (Sum . length) x reverse (Leaf x) = Leaf (reverse x) reverse (x :<> y) = reverse y :<> reverse x instance (FactorialMonoid a, PositiveMonoid a) => FactorialMonoid (Concat a) where splitPrimePrefix (Leaf x) = map2 Leaf <$> splitPrimePrefix x splitPrimePrefix (x :<> y) = ((<> y) <$>) <$> splitPrimePrefix x splitPrimeSuffix (Leaf x) = map2 Leaf <$> splitPrimeSuffix x splitPrimeSuffix (x :<> y) = first (x <>) <$> splitPrimeSuffix y span p (Leaf x) = map2 Leaf (Factorial.span (p . Leaf) x) span p (x :<> y) | null xs = (x <> yp, ys) | otherwise = (xp, xs :<> y) where (xp, xs) = Factorial.span p x (yp, ys) = Factorial.span p y spanMaybe s0 f (Leaf x) = first2 Leaf (Factorial.spanMaybe s0 (\s-> f s . Leaf) x) spanMaybe s0 f (x :<> y) | null xs = (x :<> yp, ys, s2) | otherwise = (xp, xs :<> y, s1) where (xp, xs, s1) = Factorial.spanMaybe s0 f x (yp, ys, s2) = Factorial.spanMaybe s1 f y spanMaybe' s0 f c = seq s0 $ case c of Leaf x -> first2 Leaf (Factorial.spanMaybe' s0 (\s-> f s . Leaf) x) x :<> y -> let (xp, xs, s1) = Factorial.spanMaybe' s0 f x (yp, ys, s2) = Factorial.spanMaybe' s1 f y in if null xs then (x :<> yp, ys, s2) else (xp, xs :<> y, s1) split p = Foldable.foldr splitNext [mempty] where splitNext a ~(xp:xs) = let as = Leaf <$> Factorial.split (p . Leaf) a in if null xp then as ++ xs else init as ++ (last as <> xp):xs splitAt 0 c = (mempty, c) splitAt n (Leaf x) = map2 Leaf (Factorial.splitAt n x) splitAt n (x :<> y) | k < n = (x :<> yp, ys) | k > n = (xp, xs :<> y) | otherwise = (x, y) where k = length x (yp, ys) = splitAt (n - k) y (xp, xs) = splitAt n x instance (Factorial a, PositiveMonoid a) => StableFactorial (Concat a) instance (IsString a) => IsString (Concat a) where fromString s = Leaf (fromString s) instance (Eq a, TextualMonoid a, StableFactorial a, PositiveMonoid a) => TextualMonoid (Concat a) where fromText t = Leaf (fromText t) singleton = Leaf . singleton splitCharacterPrefix (Leaf x) = (Leaf <$>) <$> splitCharacterPrefix x splitCharacterPrefix (x :<> y) = ((<> y) <$>) <$> splitCharacterPrefix x characterPrefix (Leaf x) = characterPrefix x characterPrefix (x :<> _) = characterPrefix x map f x = map f <$> x toString ft x = List.concatMap (toString $ ft . Leaf) (Foldable.toList x) toText ft x = Text.concat (toText (ft . Leaf) <$> Foldable.toList x) foldl ft fc = Foldable.foldl g where g = Textual.foldl (\a-> ft a . Leaf) fc foldl' ft fc = Foldable.foldl' g where g = Textual.foldl' (\a-> ft a . Leaf) fc foldr ft fc = Foldable.foldr g where g a b = Textual.foldr (ft . Leaf) fc b a any p = Foldable.any (any p) all p = Foldable.all (all p) span pt pc (Leaf x) = map2 Leaf (Textual.span (pt . Leaf) pc x) span pt pc (x :<> y) | null xs = (x <> yp, ys) | otherwise = (xp, xs :<> y) where (xp, xs) = Textual.span pt pc x (yp, ys) = Textual.span pt pc y span_ bt pc (Leaf x) = map2 Leaf (Textual.span_ bt pc x) span_ bt pc (x :<> y) | null xs = (x <> yp, ys) | otherwise = (xp, xs :<> y) where (xp, xs) = Textual.span_ bt pc x (yp, ys) = Textual.span_ bt pc y break pt pc = Textual.span (not . pt) (not . pc) takeWhile_ bt pc = fst . span_ bt pc dropWhile_ bt pc = snd . span_ bt pc break_ bt pc = span_ (not bt) (not . pc) spanMaybe s0 ft fc (Leaf x) = first2 Leaf (Textual.spanMaybe s0 (\s-> ft s . Leaf) fc x) spanMaybe s0 ft fc (x :<> y) | null xs = (x :<> yp, ys, s2) | otherwise = (xp, xs :<> y, s1) where (xp, xs, s1) = Textual.spanMaybe s0 ft fc x (yp, ys, s2) = Textual.spanMaybe s1 ft fc y spanMaybe' s0 ft fc c = seq s0 $ case c of Leaf x -> first2 Leaf (Textual.spanMaybe' s0 (\s-> ft s . Leaf) fc x) x :<> y -> let (xp, xs, s1) = Textual.spanMaybe' s0 ft fc x (yp, ys, s2) = Textual.spanMaybe' s1 ft fc y in if null xs then (x :<> yp, ys, s2) else (xp, xs :<> y, s1) spanMaybe_ s0 fc (Leaf x) = first2 Leaf (Textual.spanMaybe_ s0 fc x) spanMaybe_ s0 fc (x :<> y) | null xs = (x :<> yp, ys, s2) | otherwise = (xp, xs :<> y, s1) where (xp, xs, s1) = Textual.spanMaybe_ s0 fc x (yp, ys, s2) = Textual.spanMaybe_ s1 fc y spanMaybe_' s0 fc c = seq s0 $ case c of Leaf x -> first2 Leaf (Textual.spanMaybe_' s0 fc x) x :<> y -> let (xp, xs, s1) = Textual.spanMaybe_' s0 fc x (yp, ys, s2) = Textual.spanMaybe_' s1 fc y in if null xs then (x :<> yp, ys, s2) else (xp, xs :<> y, s1) split p = Foldable.foldr splitNext [mempty] where splitNext a ~(xp:xs) = let as = Leaf <$> Textual.split p a in if null xp then as ++ xs else init as ++ (last as <> xp):xs find p x = getFirst $ Foldable.foldMap (First . find p) x elem i = Foldable.any (Textual.elem i) -- Utility functions map2 :: (a -> b) -> (a, a) -> (b, b) map2 f (x, y) = (f x, f y) map3 :: (a -> b) -> (a, a, a) -> (b, b, b) map3 f (x, y, z) = (f x, f y, f z) first2 :: (a -> b) -> (a, a, c) -> (b, b, c) first2 f (x, y, z) = (f x, f y, z) monoid-subclasses-1.2.4/src/Data/Monoid/Instances/Measured.hs0000644000000000000000000001321207346545000022255 0ustar0000000000000000{- Copyright 2013-2022 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Measured'. -- {-# LANGUAGE Haskell2010, DeriveDataTypeable #-} module Data.Monoid.Instances.Measured ( Measured, measure, extract ) where import Data.Functor -- ((<$>)) import Data.Data (Data, Typeable) import qualified Data.List as List import Data.String (IsString(..)) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..)) import Data.Semigroup.Factorial (Factorial(..), StableFactorial) import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..)) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) -- | @'Measured' a@ is a wrapper around the 'FactorialMonoid' @a@ that memoizes the monoid's 'length' so it becomes a -- constant-time operation. The parameter is restricted to the 'StableFactorial' class, which guarantees that -- @'length' (a <> b) == 'length' a + 'length' b@. data Measured a = Measured{_measuredLength :: Int, extract :: a} deriving (Data, Eq, Show, Typeable) -- | Create a new 'Measured' value. measure :: Factorial a => a -> Measured a measure x = Measured (length x) x instance Ord a => Ord (Measured a) where compare (Measured _ x) (Measured _ y) = compare x y instance StableFactorial a => Semigroup (Measured a) where Measured m a <> Measured n b = Measured (m + n) (a <> b) instance (StableFactorial a, Monoid a) => Monoid (Measured a) where mempty = Measured 0 mempty mappend = (<>) instance (StableFactorial a, Monoid a) => MonoidNull (Measured a) where null (Measured n _) = n == 0 instance (StableFactorial a, Monoid a) => PositiveMonoid (Measured a) instance (LeftReductive a, StableFactorial a) => LeftReductive (Measured a) where stripPrefix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripPrefix x y) instance (RightReductive a, StableFactorial a) => RightReductive (Measured a) where stripSuffix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripSuffix x y) instance (LeftGCDMonoid a, StableFactorial a) => LeftGCDMonoid (Measured a) where commonPrefix (Measured _ x) (Measured _ y) = measure (commonPrefix x y) instance (RightGCDMonoid a, StableFactorial a) => RightGCDMonoid (Measured a) where commonSuffix (Measured _ x) (Measured _ y) = measure (commonSuffix x y) instance (StableFactorial a, MonoidNull a) => Factorial (Measured a) where factors (Measured _ x) = List.map (Measured 1) (factors x) primePrefix m@(Measured _ x) = if null x then m else Measured 1 (primePrefix x) primeSuffix m@(Measured _ x) = if null x then m else Measured 1 (primeSuffix x) foldl f a0 (Measured _ x) = Factorial.foldl g a0 x where g a = f a . Measured 1 foldl' f a0 (Measured _ x) = Factorial.foldl' g a0 x where g a = f a . Measured 1 foldr f a0 (Measured _ x) = Factorial.foldr g a0 x where g = f . Measured 1 foldMap f (Measured _ x) = Factorial.foldMap (f . Measured 1) x length (Measured n _) = n reverse (Measured n x) = Measured n (reverse x) instance (StableFactorial a, FactorialMonoid a) => FactorialMonoid (Measured a) where splitPrimePrefix (Measured n x) = case splitPrimePrefix x of Nothing -> Nothing Just (p, s) -> Just (Measured 1 p, Measured (n - 1) s) splitPrimeSuffix (Measured n x) = case splitPrimeSuffix x of Nothing -> Nothing Just (p, s) -> Just (Measured (n - 1) p, Measured 1 s) span p (Measured n x) = (xp', xs') where (xp, xs) = Factorial.span (p . Measured 1) x xp' = measure xp xs' = Measured (n - length xp') xs split p (Measured _ x) = measure <$> Factorial.split (p . Measured 1) x splitAt m (Measured n x) | m <= 0 = (mempty, Measured n x) | m >= n = (Measured n x, mempty) | otherwise = (Measured m xp, Measured (n - m) xs) where (xp, xs) = splitAt m x instance (StableFactorial a, MonoidNull a) => StableFactorial (Measured a) instance (FactorialMonoid a, IsString a) => IsString (Measured a) where fromString = measure . fromString instance (Eq a, StableFactorial a, TextualMonoid a) => TextualMonoid (Measured a) where fromText = measure . fromText singleton = Measured 1 . singleton splitCharacterPrefix (Measured n x) = (Measured (n - 1) <$>) <$> splitCharacterPrefix x characterPrefix (Measured _ x) = characterPrefix x map f (Measured n x) = Measured n (map f x) any p (Measured _ x) = any p x all p (Measured _ x) = all p x foldl ft fc a0 (Measured _ x) = Textual.foldl (\a-> ft a . Measured 1) fc a0 x foldl' ft fc a0 (Measured _ x) = Textual.foldl' (\a-> ft a . Measured 1) fc a0 x foldr ft fc a0 (Measured _ x) = Textual.foldr (ft . Measured 1) fc a0 x toString ft (Measured _ x) = toString (ft . Measured 1) x toText ft (Measured _ x) = toText (ft . Measured 1) x span pt pc (Measured n x) = (xp', xs') where (xp, xs) = Textual.span (pt . Measured 1) pc x xp' = measure xp xs' = Measured (n - length xp') xs break pt pc = Textual.span (not . pt) (not . pc) find p (Measured _ x) = find p x monoid-subclasses-1.2.4/src/Data/Monoid/Instances/Positioned.hs0000644000000000000000000011623407346545000022635 0ustar0000000000000000{- Copyright 2014-2022 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines two monoid transformer data types, 'OffsetPositioned' and 'LinePositioned'. Both data types add -- a notion of the current position to their base monoid. In case of 'OffsetPositioned', the current position is a -- simple integer offset from the beginning of the monoid, and it can be applied to any 'StableFactorial'. The -- base monoid of 'LinePositioned' must be a 'TextualMonoid', but for the price it will keep track of the current line -- and column numbers as well. -- -- Line number is zero-based, column one-based: -- -- >> let p = pure "abcd\nefgh\nijkl\nmnop\n" :: LinePositioned String -- >> p -- >"abcd\nefgh\nijkl\nmnop\n" -- >> Data.Monoid.Factorial.drop 13 p -- >Line 2, column 4: "l\nmnop\n" {-# LANGUAGE Haskell2010, DeriveDataTypeable #-} module Data.Monoid.Instances.Positioned ( OffsetPositioned, LinePositioned, extract, position, line, column ) where import Control.Applicative -- (Applicative(..)) import qualified Data.List as List import Data.String (IsString(..)) import Data.Data (Data, Typeable) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..), Endo(..)) import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..)) import Data.Semigroup.Factorial (Factorial(..), StableFactorial) import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..)) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Semigroup.Factorial as Factorial import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, lines, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) class Positioned p where extract :: p a -> a position :: p a -> Int data OffsetPositioned m = OffsetPositioned{offset :: !Int, -- ^ the current offset extractOffset :: m} deriving (Data, Typeable) data LinePositioned m = LinePositioned{fullOffset :: !Int, -- | the current line line :: !Int, lineStart :: !Int, extractLines :: m} deriving (Data, Typeable) -- | the current column column :: LinePositioned m -> Int column lp = position lp - lineStart lp instance Functor OffsetPositioned where fmap f (OffsetPositioned p c) = OffsetPositioned p (f c) instance Functor LinePositioned where fmap f (LinePositioned p l lp c) = LinePositioned p l lp (f c) instance Applicative OffsetPositioned where pure = OffsetPositioned 0 OffsetPositioned _ f <*> OffsetPositioned p c = OffsetPositioned p (f c) instance Applicative LinePositioned where pure = LinePositioned 0 0 (-1) LinePositioned _ _ _ f <*> LinePositioned p l lp c = LinePositioned p l lp (f c) instance Positioned OffsetPositioned where extract = extractOffset position = offset instance Positioned LinePositioned where extract = extractLines position = fullOffset instance Eq m => Eq (OffsetPositioned m) where OffsetPositioned{extractOffset= a} == OffsetPositioned{extractOffset= b} = a == b instance Eq m => Eq (LinePositioned m) where LinePositioned{extractLines= a} == LinePositioned{extractLines= b} = a == b instance Ord m => Ord (OffsetPositioned m) where compare OffsetPositioned{extractOffset= a} OffsetPositioned{extractOffset= b} = compare a b instance Ord m => Ord (LinePositioned m) where compare LinePositioned{extractLines= a} LinePositioned{extractLines= b} = compare a b instance Show m => Show (OffsetPositioned m) where showsPrec prec (OffsetPositioned 0 c) = showsPrec prec c showsPrec prec (OffsetPositioned pos c) = shows pos . (": " ++) . showsPrec prec c instance Show m => Show (LinePositioned m) where showsPrec prec (LinePositioned 0 0 (-1) c) = showsPrec prec c showsPrec prec (LinePositioned pos l lpos c) = ("Line " ++) . shows l . (", column " ++) . shows (pos - lpos) . (": " ++) . showsPrec prec c instance StableFactorial m => Semigroup (OffsetPositioned m) where OffsetPositioned p1 c1 <> OffsetPositioned p2 c2 = OffsetPositioned (if p1 /= 0 || p2 == 0 then p1 else max 0 $ p2 - length c1) (c1 <> c2) {-# INLINE (<>) #-} instance (FactorialMonoid m, StableFactorial m) => Monoid (OffsetPositioned m) where mempty = pure mempty mappend = (<>) {-# INLINE mempty #-} {-# INLINE mappend #-} instance (StableFactorial m, TextualMonoid m) => Semigroup (LinePositioned m) where LinePositioned p1 l1 lp1 c1 <> LinePositioned p2 l2 lp2 c2 | p1 /= 0 || p2 == 0 = LinePositioned p1 l1 lp1 c | otherwise = LinePositioned p2' l2' lp2' c where c = mappend c1 c2 p2' = max 0 $ p2 - length c1 lp2' = p2' - (p2 - lp2 - cd + 1) l2' = if l2 == 0 then 0 else max 0 (l2 - ld) (ld, cd) = linesColumns' c1 {-# INLINE (<>) #-} instance (StableFactorial m, TextualMonoid m) => Monoid (LinePositioned m) where mempty = pure mempty mappend = (<>) {-# INLINE mempty #-} instance (StableFactorial m, FactorialMonoid m) => MonoidNull (OffsetPositioned m) where null = null . extractOffset {-# INLINE null #-} instance (StableFactorial m, TextualMonoid m, MonoidNull m) => MonoidNull (LinePositioned m) where null = null . extractLines {-# INLINE null #-} instance (StableFactorial m, FactorialMonoid m) => PositiveMonoid (OffsetPositioned m) instance (StableFactorial m, TextualMonoid m) => PositiveMonoid (LinePositioned m) instance (StableFactorial m, LeftReductive m) => LeftReductive (OffsetPositioned m) where isPrefixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isPrefixOf c1 c2 stripPrefix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned (p + length c1)) (stripPrefix c1 c2) {-# INLINE isPrefixOf #-} {-# INLINE stripPrefix #-} instance (StableFactorial m, TextualMonoid m) => LeftReductive (LinePositioned m) where isPrefixOf a b = isPrefixOf (extractLines a) (extractLines b) stripPrefix LinePositioned{extractLines= c1} (LinePositioned p l lpos c2) = let (lines, columns) = linesColumns' c1 len = length c1 in fmap (LinePositioned (p + len) (l + lines) (lpos + len - columns)) (stripPrefix c1 c2) {-# INLINE isPrefixOf #-} {-# INLINE stripPrefix #-} instance (StableFactorial m, FactorialMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (OffsetPositioned m) where commonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = OffsetPositioned (min p1 p2) (commonPrefix c1 c2) stripCommonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = (OffsetPositioned (min p1 p2) prefix, OffsetPositioned (p1 + l) c1', OffsetPositioned (p2 + l) c2') where (prefix, c1', c2') = stripCommonPrefix c1 c2 l = length prefix {-# INLINE commonPrefix #-} {-# INLINE stripCommonPrefix #-} instance (StableFactorial m, TextualMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (LinePositioned m) where commonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) = if p1 <= p2 then LinePositioned p1 l1 lp1 (commonPrefix c1 c2) else LinePositioned p2 l2 lp2 (commonPrefix c1 c2) stripCommonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) = let (prefix, c1', c2') = stripCommonPrefix c1 c2 (lines, columns) = linesColumns' prefix len = length prefix in (if p1 <= p2 then LinePositioned p1 l1 lp1 prefix else LinePositioned p2 l2 lp2 prefix, LinePositioned (p1 + len) (l1 + lines) (lp1 + len - columns) c1', LinePositioned (p2 + len) (l2 + lines) (lp2 + len - columns) c2') {-# INLINE commonPrefix #-} {-# INLINE stripCommonPrefix #-} instance (StableFactorial m, FactorialMonoid m, RightReductive m) => RightReductive (OffsetPositioned m) where isSuffixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isSuffixOf c1 c2 stripSuffix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned p) (stripSuffix c1 c2) {-# INLINE isSuffixOf #-} {-# INLINE stripSuffix #-} instance (StableFactorial m, TextualMonoid m, RightReductive m) => RightReductive (LinePositioned m) where isSuffixOf LinePositioned{extractLines=c1} LinePositioned{extractLines=c2} = isSuffixOf c1 c2 stripSuffix (LinePositioned p l lp c1) LinePositioned{extractLines=c2} = fmap (LinePositioned p l lp) (stripSuffix c1 c2) {-# INLINE isSuffixOf #-} {-# INLINE stripSuffix #-} instance (StableFactorial m, FactorialMonoid m, RightGCDMonoid m) => RightGCDMonoid (OffsetPositioned m) where commonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = OffsetPositioned (min (p1 + length c1) (p2 + length c2) - length suffix) suffix where suffix = commonSuffix c1 c2 stripCommonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = (OffsetPositioned p1 c1', OffsetPositioned p2 c2', OffsetPositioned (min (p1 + length c1') (p2 + length c2')) suffix) where (c1', c2', suffix) = stripCommonSuffix c1 c2 {-# INLINE commonSuffix #-} {-# INLINE stripCommonSuffix #-} instance (StableFactorial m, TextualMonoid m, RightGCDMonoid m) => RightGCDMonoid (LinePositioned m) where stripCommonSuffix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) = (LinePositioned p1 l1 lp1 c1', LinePositioned p2 l2 lp2 c2', if p1 < p2 then LinePositioned (p1 + len1) (l1 + lines1) (lp1 + len1 - columns1) suffix else LinePositioned (p2 + len2) (l2 + lines2) (lp2 + len2 - columns2) suffix) where (c1', c2', suffix) = stripCommonSuffix c1 c2 len1 = length c1' len2 = length c2' (lines1, columns1) = linesColumns' c1' (lines2, columns2) = linesColumns' c2' instance StableFactorial m => Factorial (OffsetPositioned m) where factors (OffsetPositioned p c) = snd $ List.mapAccumL next p (factors c) where next p1 c1 = (succ p1, OffsetPositioned p1 c1) primePrefix (OffsetPositioned p c) = OffsetPositioned p (primePrefix c) foldl f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl f' (a0, p0) c0 where f' (a, p) c = (f a (OffsetPositioned p c), succ p) foldl' f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl' f' (a0, p0) c0 where f' (a, p) c = let a' = f a (OffsetPositioned p c) in seq a' (a', succ p) foldr f a0 (OffsetPositioned p0 c0) = Factorial.foldr f' (const a0) c0 p0 where f' c cont p = f (OffsetPositioned p c) (cont $! succ p) foldMap f (OffsetPositioned p c) = appEndo (Factorial.foldMap f' c) (const mempty) p where -- f' :: m -> Endo (Int -> m) f' prime = Endo (\cont pos-> f (OffsetPositioned pos prime) `mappend` cont (succ pos)) length (OffsetPositioned _ c) = length c reverse (OffsetPositioned p c) = OffsetPositioned p (Factorial.reverse c) {-# INLINE primePrefix #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE foldMap #-} instance (StableFactorial m, FactorialMonoid m) => FactorialMonoid (OffsetPositioned m) where splitPrimePrefix (OffsetPositioned p c) = fmap rewrap (splitPrimePrefix c) where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (if null cs then 0 else succ p) cs) splitPrimeSuffix (OffsetPositioned p c) = fmap rewrap (splitPrimeSuffix c) where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (p + length cp) cs) spanMaybe s0 f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe (s0, p0) f' t where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime) let p' = succ p Just $! seq p' (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) spanMaybe' s0 f (OffsetPositioned p0 t) = rewrap $! Factorial.spanMaybe' (s0, p0) f' t where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime) let p' = succ p Just $! s' `seq` p' `seq` (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) span f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe' p0 f' t where f' p prime = if f (OffsetPositioned p prime) then Just $! succ p else Nothing rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix) splitAt n m@(OffsetPositioned p c) | n <= 0 = (mempty, m) | n >= length c = (m, mempty) | otherwise = (OffsetPositioned p prefix, OffsetPositioned (p + n) suffix) where (prefix, suffix) = splitAt n c drop n (OffsetPositioned p c) = OffsetPositioned (p + n) (Factorial.drop n c) take n (OffsetPositioned p c) = OffsetPositioned p (Factorial.take n c) {-# INLINE splitPrimePrefix #-} {-# INLINE splitPrimeSuffix #-} {-# INLINE span #-} {-# INLINE splitAt #-} {-# INLINE take #-} {-# INLINE drop #-} instance (StableFactorial m, TextualMonoid m) => Factorial (LinePositioned m) where factors (LinePositioned p0 l0 lp0 c) = snd $ List.mapAccumL next (p0, l0, lp0) (factors c) where next (p, l, lp) c1 = let p' = succ p in p' `seq` case characterPrefix c1 of Just '\n' -> ((p', succ l, p), LinePositioned p l lp c1) Just '\f' -> ((p', succ l, p), LinePositioned p l lp c1) Just '\r' -> ((p', l, p), LinePositioned p l lp c1) Just '\t' -> ((p', l, lp + (p - lp) `mod` 8 - 8), LinePositioned p l lp c1) Just ch | isZeroWidth ch -> ((p, l, lp), LinePositioned p l lp c1) _ -> ((p', l, lp), LinePositioned p l lp c1) primePrefix (LinePositioned p l lp c) = LinePositioned p l lp (primePrefix c) foldl f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl f' (a0, p0, l0, lp0) c0 where f' (a, p, l, lp) c = case characterPrefix c of Just '\n' -> (f a (LinePositioned p l lp c), succ p, succ l, p) Just '\f' -> (f a (LinePositioned p l lp c), succ p, succ l, p) Just '\r' -> (f a (LinePositioned p l lp c), succ p, l, p) Just '\t' -> (f a (LinePositioned p l lp c), succ p, l, lp + (p - lp) `mod` 8 - 8) Just ch | isZeroWidth ch -> (f a (LinePositioned p l lp c), p, l, lp) _ -> (f a (LinePositioned p l lp c), succ p, l, lp) foldl' f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl' f' (a0, p0, l0, lp0) c0 where f' (a, p, l, lp) c = let a' = f a (LinePositioned p l lp c) in seq a' (case characterPrefix c of Just '\n' -> (a', succ p, succ l, p) Just '\f' -> (a', succ p, succ l, p) Just '\r' -> (a', succ p, l, p) Just '\t' -> (a', succ p, l, lp + (p - lp) `mod` 8 - 8) Just ch | isZeroWidth ch -> (a', p, l, lp) _ -> (a', succ p, l, lp)) foldr f a0 (LinePositioned p0 l0 lp0 c0) = Factorial.foldr f' (const3 a0) c0 p0 l0 lp0 where f' c cont p l lp = case characterPrefix c of Just '\n' -> f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p Just '\f' -> f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p Just '\r' -> f (LinePositioned p l lp c) $ (cont $! succ p) l p Just '\t' -> f (LinePositioned p l lp c) $ (cont $! succ p) l $! lp + (p - lp) `mod` 8 - 8 Just ch | isZeroWidth ch -> f (LinePositioned p l lp c) $ (cont p) l lp _ -> f (LinePositioned p l lp c) $ (cont $! succ p) l lp foldMap f (LinePositioned p0 l0 lp0 c) = appEndo (Factorial.foldMap f' c) (const mempty) p0 l0 lp0 where -- f' :: m -> Endo (Int -> Int -> Int -> m) f' prime = Endo (\cont p l lp-> f (LinePositioned p l lp prime) `mappend` case characterPrefix prime of Just '\n' -> cont (succ p) (succ l) p Just '\f' -> cont (succ p) (succ l) p Just '\r' -> cont (succ p) l p Just '\t' -> cont (succ p) l (lp + (p - lp) `mod` 8 - 8) Just ch | isZeroWidth ch -> cont p l lp _ -> cont (succ p) l lp) length = length . extractLines reverse (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.reverse c) {-# INLINE primePrefix #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE foldMap #-} {-# INLINE length #-} {-# INLINE reverse #-} instance (StableFactorial m, TextualMonoid m) => FactorialMonoid (LinePositioned m) where splitPrimePrefix (LinePositioned p l lp c) = fmap rewrap (splitPrimePrefix c) where rewrap (cp, cs) = (LinePositioned p l lp cp, if null cs then mempty else case characterPrefix cp of Just '\n' -> LinePositioned p' (succ l) p cs Just '\f' -> LinePositioned p' (succ l) p cs Just '\r' -> LinePositioned p' l p cs Just '\t' -> LinePositioned p' l (lp + (p - lp) `mod` 8 - 8) cs Just ch | isZeroWidth ch -> LinePositioned p l lp cs _ -> LinePositioned p' l lp cs) p' = succ p splitPrimeSuffix (LinePositioned p l lp c) = fmap rewrap (splitPrimeSuffix c) where rewrap (cp, cs) = (LinePositioned p l lp cp, LinePositioned p' (l + lines) (p' - columns) cs) where len = length cp (lines, columns) = linesColumns cp p' = p + len spanMaybe s0 f (LinePositioned p0 l0 lp0 c) = rewrap $ Factorial.spanMaybe (s0, p0, l0, lp0) f' c where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime) let p' = succ p l' = succ l Just $! p' `seq` case characterPrefix prime of Just '\n' -> l' `seq` (s', p', l', p) Just '\f' -> l' `seq` (s', p', l', p) Just '\r' -> (s', p', l, p) Just '\t' -> (s', p', l, lp + (p - lp) `mod` 8 - 8) Just ch | isZeroWidth ch -> (s', p, l, lp) _ -> (s', p', l, lp) rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) spanMaybe' s0 f (LinePositioned p0 l0 lp0 c) = rewrap $! Factorial.spanMaybe' (s0, p0, l0, lp0) f' c where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime) let p' = succ p l' = succ l Just $! s' `seq` p' `seq` case characterPrefix prime of Just '\n' -> l' `seq` (s', p', l', p) Just '\f' -> l' `seq` (s', p', l', p) Just '\r' -> (s', p', l, p) Just '\t' -> (s', p', l, lp + (p - lp) `mod` 8 - 8) Just ch | isZeroWidth ch -> (s', p, l, lp) _ -> (s', p', l, lp) rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) span f (LinePositioned p0 l0 lp0 t) = rewrap $ Factorial.spanMaybe' (p0, l0, lp0) f' t where f' (p, l, lp) prime = if f (LinePositioned p l lp prime) then let p' = succ p l' = succ l in Just $! p' `seq` case characterPrefix prime of Just '\n' -> l' `seq` (p', l', p) Just '\f' -> l' `seq` (p', l', p) Just '\r' -> (p', l, p) Just '\t' -> (p', l, lp + (p - lp) `mod` 8 - 8) Just c | isZeroWidth c -> (p, l, lp) _ -> (p', l, lp) else Nothing rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix) splitAt n m@(LinePositioned p l lp c) | n <= 0 = (mempty, m) | n >= length c = (m, mempty) | otherwise = (LinePositioned p l lp prefix, LinePositioned p' (l + lines) (p' - columns) suffix) where (prefix, suffix) = splitAt n c (lines, columns) = linesColumns prefix p' = p + n take n (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.take n c) {-# INLINE splitPrimePrefix #-} {-# INLINE splitPrimeSuffix #-} {-# INLINE span #-} {-# INLINE splitAt #-} {-# INLINE take #-} instance StableFactorial m => StableFactorial (OffsetPositioned m) instance (StableFactorial m, TextualMonoid m) => StableFactorial (LinePositioned m) instance IsString m => IsString (OffsetPositioned m) where fromString = pure . fromString instance IsString m => IsString (LinePositioned m) where fromString = pure . fromString instance (StableFactorial m, TextualMonoid m) => TextualMonoid (OffsetPositioned m) where splitCharacterPrefix (OffsetPositioned p t) = fmap rewrap (splitCharacterPrefix t) where rewrap (c, cs) = if null cs then (c, mempty) else (c, OffsetPositioned (succ p) cs) fromText = pure . fromText singleton = pure . singleton characterPrefix = characterPrefix . extractOffset map f (OffsetPositioned p c) = OffsetPositioned p (map f c) concatMap f (OffsetPositioned p c) = OffsetPositioned p (concatMap (extractOffset . f) c) all p = all p . extractOffset any p = any p . extractOffset foldl ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl ft' fc' (a0, p0) c0 where ft' (a, p) c = (ft a (OffsetPositioned p c), succ p) fc' (a, p) c = (fc a c, succ p) foldl' ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl' ft' fc' (a0, p0) c0 where ft' (a, p) c = ((,) $! ft a (OffsetPositioned p c)) $! succ p fc' (a, p) c = ((,) $! fc a c) $! succ p foldr ft fc a0 (OffsetPositioned p0 c0) = snd $ Textual.foldr ft' fc' (p0, a0) c0 where ft' c (p, a) = (succ p, ft (OffsetPositioned p c) a) fc' c (p, a) = (succ p, fc c a) scanl f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl f ch c) scanl1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl1 f c) scanr f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr f ch c) scanr1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr1 f c) mapAccumL f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumL f a0 c) mapAccumR f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumR f a0 c) spanMaybe s0 ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe (s0, p0) ft' fc' t where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime) let p' = succ p Just $! seq p' (s', p') fc' (s, p) c = do s' <- fc s c let p' = succ p Just $! seq p' (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) spanMaybe' s0 ft fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe' (s0, p0) ft' fc' t where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime) let p' = succ p Just $! s' `seq` p' `seq` (s', p') fc' (s, p) c = do s' <- fc s c let p' = succ p Just $! s' `seq` p' `seq` (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) span ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe' p0 ft' fc' t where ft' p prime = if ft (OffsetPositioned p prime) then Just $! succ p else Nothing fc' p c = if fc c then Just $! succ p else Nothing rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix) split f (OffsetPositioned p0 c0) = rewrap p0 (Textual.split f c0) where rewrap _ [] = [] rewrap p (c:rest) = OffsetPositioned p c : rewrap (p + length c) rest find p = find p . extractOffset foldl_ fc a0 (OffsetPositioned _ c) = Textual.foldl_ fc a0 c foldl_' fc a0 (OffsetPositioned _ c) = Textual.foldl_' fc a0 c foldr_ fc a0 (OffsetPositioned _ c) = Textual.foldr_ fc a0 c spanMaybe_ s0 fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe_' (s0, p0) fc' t where fc' (s, p) c = do s' <- fc s c let p' = succ p Just $! seq p' (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) spanMaybe_' s0 fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe_' (s0, p0) fc' t where fc' (s, p) c = do s' <- fc s c let p' = succ p Just $! s' `seq` p' `seq` (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) span_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.span_ bt fc t where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix) break_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.break_ bt fc t where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix) dropWhile_ bt fc t = snd (span_ bt fc t) takeWhile_ bt fc (OffsetPositioned p t) = OffsetPositioned p (takeWhile_ bt fc t) toString ft (OffsetPositioned _ t) = toString (ft . pure) t toText ft (OffsetPositioned _ t) = toText (ft . pure) t {-# INLINE characterPrefix #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE map #-} {-# INLINE concatMap #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINABLE spanMaybe #-} {-# INLINABLE spanMaybe' #-} {-# INLINABLE span #-} {-# INLINE foldl_' #-} {-# INLINE foldr_ #-} {-# INLINE any #-} {-# INLINE all #-} {-# INLINABLE spanMaybe_ #-} {-# INLINABLE spanMaybe_' #-} {-# INLINE span_ #-} {-# INLINE break_ #-} {-# INLINE dropWhile_ #-} {-# INLINE takeWhile_ #-} {-# INLINE split #-} {-# INLINE find #-} instance (StableFactorial m, TextualMonoid m) => TextualMonoid (LinePositioned m) where splitCharacterPrefix (LinePositioned p l lp t) = case splitCharacterPrefix t of Nothing -> Nothing Just (c, rest) | null rest -> Just (c, mempty) Just ('\n', rest) -> Just ('\n', LinePositioned p' (succ l) p rest) Just ('\f', rest) -> Just ('\f', LinePositioned p' (succ l) p rest) Just ('\r', rest) -> Just ('\r', LinePositioned p' l p rest) Just ('\t', rest) -> Just ('\t', LinePositioned p' l (lp + (p - lp) `mod` 8 - 8) rest) Just (ch, rest) | isZeroWidth ch -> Just (ch, LinePositioned p l lp rest) | otherwise -> Just (ch, LinePositioned p' l lp rest) where p' = succ p fromText = pure . fromText singleton = pure . singleton characterPrefix = characterPrefix . extractLines map f (LinePositioned p l lp c) = LinePositioned p l lp (map f c) concatMap f (LinePositioned p l lp c) = LinePositioned p l lp (concatMap (extractLines . f) c) all p = all p . extractLines any p = any p . extractLines foldl ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl ft' fc' (a0, p0, l0, lp0) c0 where ft' (a, p, l, lp) c = (ft a (LinePositioned p l lp c), succ p, l, lp) fc' (a, p, l, _lp) '\n' = (fc a '\n', succ p, succ l, p) fc' (a, p, l, _lp) '\f' = (fc a '\f', succ p, succ l, p) fc' (a, p, l, _lp) '\r' = (fc a '\r', succ p, l, p) fc' (a, p, l, lp) '\t' = (fc a '\t', succ p, l, lp + (p - lp) `mod` 8 - 8) fc' (a, p, l, lp) c | isZeroWidth c = (fc a c, p, l, lp) | otherwise = (fc a c, succ p, l, lp) foldl' ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl' ft' fc' (a0, p0, l0, lp0) c0 where ft' (a, p, l, lp) c = let a' = ft a (LinePositioned p l lp c) p' = succ p in a' `seq` p' `seq` (a', p', l, lp) fc' (a, p, l, lp) c = let a' = fc a c p' = succ p l' = succ l in a' `seq` p' `seq` case c of '\n' -> l' `seq` (a', p', l', p) '\f' -> l' `seq` (a', p', l', p) '\r' -> (a', p', l, p) '\t' -> (a', p', l, lp + (p - lp) `mod` 8 - 8) _ | isZeroWidth c -> (a', p, l, lp) _ -> (a', p', l, lp) foldr ft fc a0 (LinePositioned p0 l0 lp0 c0) = Textual.foldr ft' fc' (const3 a0) c0 p0 l0 lp0 where ft' c cont p l lp = ft (LinePositioned p l lp c) $ (cont $! succ p) l lp fc' c cont p l lp | c == '\n' = fc c $ ((cont $! succ p) $! succ l) p | c == '\f' = fc c $ ((cont $! succ p) $! succ l) p | c == '\r' = fc c $ (cont $! succ p) l p | c == '\t' = fc c $ (cont $! succ p) l (lp + (p - lp) `mod` 8 - 8) | isZeroWidth c = fc c $ (cont p) l lp | otherwise = fc c $ (cont $! succ p) l lp spanMaybe s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe (s0, p0, l0, lp0) ft' fc' t where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime) let p' = succ p Just $! seq p' (s', p', l, lp) fc' (s, p, l, lp) c = fc s c >>= \s'-> Just $! seq p' (if c == '\n' || c == '\f' then seq l' (s', p', l', p) else if c == '\r' then (s', p', l, p) else if c == '\t' then (s', p', l, lp + (p - lp) `mod` 8 - 8) else if isZeroWidth c then (s', p, l, lp) else (s', p', l, lp)) where p' = succ p l' = succ l rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) spanMaybe' s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $! Textual.spanMaybe' (s0, p0, l0, lp0) ft' fc' t where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime) let p' = succ p Just $! s' `seq` p' `seq` (s', p', l, lp) fc' (s, p, l, lp) c = do s' <- fc s c let p' = succ p l' = succ l Just $! s' `seq` p' `seq` (if c == '\n' || c == '\f' then seq l' (s', p', l', p) else if c == '\r' then (s', p', l, p) else if c == '\t' then (s', p', l, lp + (p - lp) `mod` 8 - 8) else if isZeroWidth c then (s', p, l, lp) else (s', p', l, lp)) rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) span ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe' (p0, l0, lp0) ft' fc' t where ft' (p, l, lp) prime = if ft (LinePositioned p l lp prime) then let p' = succ p in p' `seq` Just (p', l, lp) else Nothing fc' (p, l, lp) c | fc c = Just $! seq p' $ if c == '\n' || c == '\f' then seq l' (p', l', p) else if c == '\r' then (p', l, p) else if c == '\t' then (p', l, lp + (p - lp) `mod` 8 - 8) else if isZeroWidth c then (p, l, lp) else (p', l, lp) | otherwise = Nothing where p' = succ p l' = succ l rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix) scanl f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl f ch c) scanl1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl1 f c) scanr f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr f ch c) scanr1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr1 f c) mapAccumL f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumL f a0 c) mapAccumR f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumR f a0 c) split f (LinePositioned p0 l0 lp0 c0) = rewrap p0 l0 lp0 (Textual.split f c0) where rewrap _ _ _ [] = [] rewrap p l lp (c:rest) = LinePositioned p l lp c : rewrap p' (l + lines) (if lines == 0 then lp else p' - columns) rest where p' = p + length c (lines, columns) = linesColumns c find p = find p . extractLines foldl_ fc a0 (LinePositioned _ _ _ t) = Textual.foldl_ fc a0 t foldl_' fc a0 (LinePositioned _ _ _ t) = Textual.foldl_' fc a0 t foldr_ fc a0 (LinePositioned _ _ _ t) = Textual.foldr_ fc a0 t spanMaybe_ s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_ s0 fc t where rewrap (prefix, suffix, s) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix, s) where (l, col) = linesColumns prefix p1 = p0 + length prefix spanMaybe_' s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_' s0 fc t where rewrap (prefix, suffix, s) = p1 `seq` l1 `seq` lp1 `seq` (LinePositioned p0 l0 lp0 prefix, LinePositioned p1 l1 lp1 suffix, s) where (l, col) = linesColumns' prefix p1 = p0 + length prefix l1 = l0 + l lp1 = if l == 0 then lp0 else p1 - col span_ bt fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.span_ bt fc t where rewrap (prefix, suffix) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix) where (l, col) = linesColumns' prefix p1 = p0 + length prefix break_ bt fc t = span_ (not bt) (not . fc) t dropWhile_ bt fc t = snd (span_ bt fc t) takeWhile_ bt fc (LinePositioned p l lp t) = LinePositioned p l lp (takeWhile_ bt fc t) toString ft lpt = toString (ft . pure) (extractLines lpt) toText ft lpt = toText (ft . pure) (extractLines lpt) {-# INLINE characterPrefix #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE map #-} {-# INLINE concatMap #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE spanMaybe' #-} {-# INLINE span #-} {-# INLINE split #-} {-# INLINE find #-} {-# INLINE foldl_' #-} {-# INLINE foldr_ #-} {-# INLINE any #-} {-# INLINE all #-} {-# INLINABLE spanMaybe_ #-} {-# INLINABLE spanMaybe_' #-} {-# INLINABLE span_ #-} {-# INLINE break_ #-} {-# INLINE dropWhile_ #-} {-# INLINE takeWhile_ #-} linesColumns :: TextualMonoid m => m -> (Int, Int) linesColumns t = Textual.foldl (const . fmap succ) fc (0, 1) t where fc (l, _) '\n' = (succ l, 1) fc (l, _) '\f' = (succ l, 1) fc (l, _) '\r' = (l, 1) fc (l, c) '\t' = (l, c + 9 - c `mod` 8) fc (l, c) ch | isZeroWidth ch = (l, c) fc (l, c) _ = (l, succ c) linesColumns' :: TextualMonoid m => m -> (Int, Int) linesColumns' t = Textual.foldl' (const . fmap succ) fc (0, 1) t where fc (l, _) '\n' = let l' = succ l in seq l' (l', 1) fc (l, _) '\f' = let l' = succ l in seq l' (l', 1) fc (l, _) '\r' = (l, 1) fc (l, c) '\t' = (l, c + 9 - c `mod` 8) fc (l, c) ch | isZeroWidth ch = (l, c) fc (l, c) _ = let c' = succ c in seq c' (l, c') {-# INLINE linesColumns #-} {-# INLINE linesColumns' #-} isZeroWidth :: Char -> Bool isZeroWidth '\x200b' = True -- zero width space isZeroWidth '\x200c' = True -- zero width non-joiner isZeroWidth '\x200d' = True -- zero width joiner isZeroWidth '\xfeff' = True -- zero width no-break space isZeroWidth _ = False const3 :: a -> b -> c -> d -> a const3 a _p _l _lp = a {-# INLINE const3 #-} fstOf4 :: (a, b, c, d) -> a fstOf4 (a, _, _, _) = a {-# INLINE fstOf4 #-} monoid-subclasses-1.2.4/src/Data/Monoid/Instances/PrefixMemory.hs0000644000000000000000000003016507346545000023144 0ustar0000000000000000{- Copyright 2023 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Shadowed'. {-# LANGUAGE Haskell2010, DeriveDataTypeable #-} module Data.Monoid.Instances.PrefixMemory ( Shadowed, shadowed, content, prefix ) where import Control.Applicative -- (Applicative(..)) import qualified Data.List as List import Data.String (IsString(fromString)) import Data.Data (Data, Typeable) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..), Endo(..)) import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..)) import Data.Semigroup.Factorial (Factorial(..), StableFactorial) import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..)) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Semigroup.Factorial as Factorial import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, lines, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) -- | Monoid transformer that keeps track of the former 'prefix' of its 'content'. All functions that return a suffix -- of their argument, such as 'stripPrefix' or 'commonSuffix', preserve the discarded 'prefix'. data Shadowed m = Shadowed{prefix :: !m, -- ^ used to precede the 'content' but has been consumed content :: !m -- ^ the present value } deriving (Data, Typeable) -- | The constructor of a 'Shadowed' monoid, with the initial @prefix = null@ shadowed :: Monoid m => m -> Shadowed m shadowed = Shadowed mempty instance Eq m => Eq (Shadowed m) where Shadowed{content = a} == Shadowed{content = b} = a == b instance Ord m => Ord (Shadowed m) where compare Shadowed{content= a} Shadowed{content= b} = compare a b instance (MonoidNull m, Show m) => Show (Shadowed m) where showsPrec prec (Shadowed p c) rest | null p = showsPrec prec c rest | otherwise = "Shadowed{prefix=" <> shows p (", content=" <> shows c ("}" <> rest)) instance (MonoidNull m, StableFactorial m) => Semigroup (Shadowed m) where Shadowed p1 c1 <> m2@Shadowed{content = c2} | null c1 && null p1 = m2 | otherwise = Shadowed p1 (c1 <> c2) {-# INLINE (<>) #-} instance (MonoidNull m, StableFactorial m) => Monoid (Shadowed m) where mempty = shadowed mempty mappend = (<>) {-# INLINE mempty #-} {-# INLINE mappend #-} instance (MonoidNull m, StableFactorial m) => MonoidNull (Shadowed m) where null = null . content {-# INLINE null #-} instance (PositiveMonoid m, StableFactorial m) => PositiveMonoid (Shadowed m) instance (MonoidNull m, StableFactorial m, LeftReductive m) => LeftReductive (Shadowed m) where t1 `isPrefixOf` t2 = content t1 `isPrefixOf` content t2 stripPrefix (Shadowed _ c1) (Shadowed p c2) = fmap (Shadowed (p <> c1)) (stripPrefix c1 c2) {-# INLINE isPrefixOf #-} {-# INLINE stripPrefix #-} instance (Eq m, StableFactorial m, FactorialMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (Shadowed m) where stripCommonPrefix (Shadowed p1 c1) (Shadowed p2 c2) = (Shadowed prefix' common, Shadowed (p1 <> common) c1', Shadowed (p2 <> common) c2') where (common, c1', c2') = stripCommonPrefix c1 c2 prefix' = if p1 == p2 then p1 <> common else common {-# INLINE stripCommonPrefix #-} instance (StableFactorial m, FactorialMonoid m, RightReductive m) => RightReductive (Shadowed m) where isSuffixOf (Shadowed _ c1) (Shadowed _ c2) = isSuffixOf c1 c2 stripSuffix (Shadowed _ c1) (Shadowed p c2) = fmap (Shadowed p) (stripSuffix c1 c2) {-# INLINE isSuffixOf #-} {-# INLINE stripSuffix #-} instance (StableFactorial m, FactorialMonoid m, RightGCDMonoid m) => RightGCDMonoid (Shadowed m) where commonSuffix (Shadowed _ c1) (Shadowed _ c2) = shadowed suffix where suffix = commonSuffix c1 c2 stripCommonSuffix (Shadowed p1 c1) (Shadowed p2 c2) = (Shadowed p1 c1', Shadowed p2 c2', shadowed suffix) where (c1', c2', suffix) = stripCommonSuffix c1 c2 {-# INLINE commonSuffix #-} {-# INLINE stripCommonSuffix #-} instance (FactorialMonoid m, StableFactorial m) => Factorial (Shadowed m) where factors (Shadowed p c) = rewrap <$> List.tail (inits c) where rewrap t | Just (p', prime) <- splitPrimeSuffix t = Shadowed (p <> p') prime | otherwise = error "all (not . null) . tail . inits" primePrefix (Shadowed p c) = Shadowed p (primePrefix c) foldl f a0 (Shadowed p0 c0) = fst $ Factorial.foldl f' (a0, p0) c0 where f' (a, p) c = (f a (Shadowed p c), p <> c) foldl' f a0 (Shadowed p0 c0) = fst $ Factorial.foldl' f' (a0, p0) c0 where f' (a, p) c = ((,) $! f a (Shadowed p c)) $! p <> c foldr f a0 (Shadowed p0 c0) = Factorial.foldr f' (const a0) c0 p0 where f' c cont p = f (Shadowed p c) (cont $! p <> c) foldMap f (Shadowed p0 c) = appEndo (Factorial.foldMap f' c) (const mempty) p0 where -- f' :: m -> Endo (Int -> m) f' prime = Endo (\cont p-> f (Shadowed p prime) `mappend` (cont $! p <> prime)) length (Shadowed _ c) = length c reverse (Shadowed p c) = Shadowed p (Factorial.reverse c) {-# INLINE primePrefix #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE foldMap #-} instance (StableFactorial m, FactorialMonoid m) => FactorialMonoid (Shadowed m) where splitPrimePrefix (Shadowed p c) = fmap rewrap (splitPrimePrefix c) where rewrap (cp, cs) = (Shadowed p cp, Shadowed (p <> cp) cs) splitPrimeSuffix (Shadowed p c) = fmap rewrap (splitPrimeSuffix c) where rewrap (cp, cs) = (Shadowed p cp, Shadowed (p <> cp) cs) spanMaybe s0 f (Shadowed p0 c) = rewrap $ Factorial.spanMaybe (s0, p0) f' c where f' (s, p) prime = do s' <- f s (Shadowed p prime) let p' = p <> prime Just $! seq p' (s', p') rewrap (cp, cs, (s, p)) = (Shadowed p0 cp, Shadowed p cs, s) spanMaybe' s0 f (Shadowed p0 c) = rewrap $! Factorial.spanMaybe' (s0, p0) f' c where f' (s, p) prime = do s' <- f s (Shadowed p prime) let p' = p <> prime Just $! s' `seq` p' `seq` (s', p') rewrap (cp, cs, (s, p)) = (Shadowed p0 cp, Shadowed p cs, s) span f (Shadowed p0 c) = rewrap $ Factorial.spanMaybe' p0 f' c where f' p prime = if f (Shadowed p prime) then Just $! p <> prime else Nothing rewrap (cp, cs, p) = (Shadowed p0 cp, Shadowed p cs) splitAt n (Shadowed p c) = (Shadowed p cp, Shadowed (p <> cp) cs) where (cp, cs) = splitAt n c take n (Shadowed p c) = Shadowed p (Factorial.take n c) {-# INLINE splitPrimePrefix #-} {-# INLINE splitPrimeSuffix #-} {-# INLINE span #-} {-# INLINE splitAt #-} {-# INLINE take #-} instance (StableFactorial m, FactorialMonoid m) => StableFactorial (Shadowed m) instance (Monoid m, IsString m) => IsString (Shadowed m) where fromString = shadowed . fromString instance (Eq m, StableFactorial m, TextualMonoid m) => TextualMonoid (Shadowed m) where splitCharacterPrefix (Shadowed p t) = (Shadowed p <$>) <$> Textual.splitCharacterPrefix t fromText = shadowed . fromText singleton = shadowed . singleton characterPrefix = characterPrefix . content map f (Shadowed p c) = Shadowed p (map f c) concatMap f (Shadowed p c) = Shadowed p (concatMap (content . f) c) all p = all p . content any p = any p . content foldl ft fc a0 (Shadowed p0 c0) = fst $ Textual.foldl ft' fc' (a0, p0) c0 where ft' (a, p) c = (ft a (Shadowed p c), p <> c) fc' (a, p) c = (fc a c, p <> Textual.singleton c) foldl' ft fc a0 (Shadowed p0 c0) = fst $ Textual.foldl' ft' fc' (a0, p0) c0 where ft' (a, p) c = ((,) $! ft a (Shadowed p c)) $! p <> c fc' (a, p) c = ((,) $! fc a c) $! p <> Textual.singleton c foldr ft fc a0 (Shadowed p0 c0) = snd $ Textual.foldr ft' fc' (p0, a0) c0 where ft' c (p, a) = ((,) $! p <> c) $! ft (Shadowed p c) a fc' c (p, a) = ((,) $! p <> Textual.singleton c) $! fc c a scanl f ch (Shadowed p c) = Shadowed p (Textual.scanl f ch c) scanl1 f (Shadowed p c) = Shadowed p (Textual.scanl1 f c) scanr f ch (Shadowed p c) = Shadowed p (Textual.scanr f ch c) scanr1 f (Shadowed p c) = Shadowed p (Textual.scanr1 f c) mapAccumL f a0 (Shadowed p c) = fmap (Shadowed p) (Textual.mapAccumL f a0 c) mapAccumR f a0 (Shadowed p c) = fmap (Shadowed p) (Textual.mapAccumR f a0 c) spanMaybe s0 ft fc (Shadowed p0 t) = rewrap $ Textual.spanMaybe (s0, p0) ft' fc' t where ft' (s, p) prime = do s' <- ft s (Shadowed p prime) let p' = p <> prime Just $! seq p' (s', p') fc' (s, p) c = do s' <- fc s c let p' = p <> Textual.singleton c Just $! seq p' (s', p') rewrap (tp, ts, (s, p)) = (Shadowed p0 tp, Shadowed p ts, s) spanMaybe' s0 ft fc (Shadowed p0 t) = rewrap $! Textual.spanMaybe' (s0, p0) ft' fc' t where ft' (s, p) prime = do s' <- ft s (Shadowed p prime) let p' = p <> prime Just $! s' `seq` p' `seq` (s', p') fc' (s, p) c = do s' <- fc s c let p' = p <> Textual.singleton c Just $! s' `seq` p' `seq` (s', p') rewrap (tp, ts, (s, p)) = (Shadowed p0 tp, Shadowed p ts, s) span ft fc (Shadowed p0 t) = rewrap $ Textual.spanMaybe' p0 ft' fc' t where ft' p prime = if ft (Shadowed p prime) then Just $! p <> prime else Nothing fc' p c = if fc c then Just $! p <> Textual.singleton c else Nothing rewrap (tp, ts, p) = (Shadowed p0 tp, Shadowed p ts) split f (Shadowed p0 c0) = rewrap p0 (Textual.split f c0) where rewrap _ [] = [] rewrap p (c:rest) = Shadowed p c : rewrap (p <> c) rest find p = find p . content foldl_ fc a0 (Shadowed _ c) = Textual.foldl_ fc a0 c foldl_' fc a0 (Shadowed _ c) = Textual.foldl_' fc a0 c foldr_ fc a0 (Shadowed _ c) = Textual.foldr_ fc a0 c spanMaybe_ s0 fc (Shadowed p0 t) = rewrap $ Textual.spanMaybe_' (s0, p0) fc' t where fc' (s, p) c = do s' <- fc s c let p' = p <> Textual.singleton c Just $! seq p' (s', p') rewrap (tp, ts, (s, p)) = (Shadowed p0 tp, Shadowed p ts, s) spanMaybe_' s0 fc (Shadowed p0 t) = rewrap $! Textual.spanMaybe_' (s0, p0) fc' t where fc' (s, p) c = do s' <- fc s c let p' = p <> Textual.singleton c Just $! s' `seq` p' `seq` (s', p') rewrap (tp, ts, (s, p)) = (Shadowed p0 tp, Shadowed p ts, s) span_ bt fc (Shadowed p0 t) = rewrap $ Textual.span_ bt fc t where rewrap (tp, ts) = (Shadowed p0 tp, Shadowed (p0 <> tp) ts) break_ bt fc (Shadowed p0 t) = rewrap $ Textual.break_ bt fc t where rewrap (tp, ts) = (Shadowed p0 tp, Shadowed (p0 <> tp) ts) dropWhile_ bt fc t = snd (span_ bt fc t) takeWhile_ bt fc (Shadowed p t) = Shadowed p (takeWhile_ bt fc t) toString ft (Shadowed _ t) = toString (ft . shadowed) t toText ft (Shadowed _ t) = toText (ft . shadowed) t {-# INLINE characterPrefix #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE map #-} {-# INLINE concatMap #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINABLE spanMaybe #-} {-# INLINABLE spanMaybe' #-} {-# INLINABLE span #-} {-# INLINE foldl_' #-} {-# INLINE foldr_ #-} {-# INLINE any #-} {-# INLINE all #-} {-# INLINABLE spanMaybe_ #-} {-# INLINABLE spanMaybe_' #-} {-# INLINE span_ #-} {-# INLINE break_ #-} {-# INLINE dropWhile_ #-} {-# INLINE takeWhile_ #-} {-# INLINE split #-} {-# INLINE find #-} monoid-subclasses-1.2.4/src/Data/Monoid/Instances/Stateful.hs0000644000000000000000000002435607346545000022312 0ustar0000000000000000{- Copyright 2013-2022 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Stateful'. -- -- >> let s = setState [4] $ pure "data" :: Stateful [Int] String -- >> s -- >Stateful ("data",[4]) -- >> factors s -- >[Stateful ("d",[]),Stateful ("a",[]),Stateful ("t",[]),Stateful ("a",[]),Stateful ("",[4])] {-# LANGUAGE Haskell2010, DeriveDataTypeable #-} module Data.Monoid.Instances.Stateful ( Stateful(Stateful), extract, state, setState ) where import Control.Applicative -- (Applicative(..)) import Data.Data (Data, Typeable) import Data.Functor -- ((<$>)) import qualified Data.List as List import Data.String (IsString(..)) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..)) import Data.Semigroup.Factorial (Factorial(..), StableFactorial) import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..)) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Semigroup.Factorial as Factorial import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Prelude hiding (all, any, break, elem, drop, filter, foldl, foldl1, foldr, foldr1, gcd, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, take) -- | @'Stateful' a b@ is a wrapper around the 'Monoid' @b@ that carries the state @a@ along. The state type @a@ must be -- a monoid as well if 'Stateful' is to be of any use. In the 'FactorialMonoid' and 'TextualMonoid' class instances, the -- monoid @b@ has the priority and the state @a@ is left for the end. newtype Stateful a b = Stateful (b, a) deriving (Data, Eq, Ord, Show, Typeable) extract :: Stateful a b -> b extract (Stateful (t, _)) = t state :: Stateful a b -> a state (Stateful (_, x)) = x setState :: a -> Stateful a b -> Stateful a b setState s (Stateful (t, _)) = Stateful (t, s) instance Functor (Stateful a) where fmap f (Stateful (x, s)) = Stateful (f x, s) instance Monoid a => Applicative (Stateful a) where pure m = Stateful (m, mempty) Stateful (f, s1) <*> Stateful (x, s2) = Stateful (f x, mappend s1 s2) instance (Semigroup a, Semigroup b) => Semigroup (Stateful a b) where Stateful x <> Stateful y = Stateful (x <> y) {-# INLINE (<>) #-} instance (Semigroup a, Semigroup b, Monoid a, Monoid b) => Monoid (Stateful a b) where mempty = Stateful mempty mappend = (<>) {-# INLINE mempty #-} {-# INLINE mappend #-} instance (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 (LeftReductive a, LeftReductive b) => LeftReductive (Stateful a b) where isPrefixOf (Stateful x) (Stateful x') = isPrefixOf x x' stripPrefix (Stateful x) (Stateful x') = Stateful <$> stripPrefix x x' {-# INLINE isPrefixOf #-} {-# INLINE stripPrefix #-} instance (RightReductive a, RightReductive b) => RightReductive (Stateful a b) where isSuffixOf (Stateful x) (Stateful x') = isSuffixOf x x' stripSuffix (Stateful x) (Stateful x') = Stateful <$> stripSuffix x x' {-# INLINE stripSuffix #-} {-# INLINE isSuffixOf #-} instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (Stateful a b) where commonPrefix (Stateful x) (Stateful x') = Stateful (commonPrefix x x') stripCommonPrefix (Stateful x) (Stateful x') = (Stateful prefix, Stateful suffix1, Stateful suffix2) where (prefix, suffix1, suffix2) = stripCommonPrefix x x' {-# INLINE commonPrefix #-} {-# INLINE stripCommonPrefix #-} instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (Stateful a b) where commonSuffix (Stateful x) (Stateful x') = Stateful (commonSuffix x x') {-# INLINE commonSuffix #-} instance (FactorialMonoid a, FactorialMonoid b) => Factorial (Stateful a b) where factors (Stateful x) = List.map Stateful (factors x) length (Stateful x) = length x reverse (Stateful x) = Stateful (reverse x) primePrefix (Stateful x) = Stateful (primePrefix x) primeSuffix (Stateful x) = Stateful (primeSuffix x) foldl f a0 (Stateful x) = Factorial.foldl f' a0 x where f' a x1 = f a (Stateful x1) foldl' f a0 (Stateful x) = Factorial.foldl' f' a0 x where f' a x1 = f a (Stateful x1) foldr f a (Stateful x) = Factorial.foldr (f . Stateful) a x foldMap f (Stateful x) = Factorial.foldMap (f . Stateful) x {-# INLINE primePrefix #-} {-# INLINE primeSuffix #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE foldMap #-} {-# INLINE length #-} instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (Stateful a b) where splitPrimePrefix (Stateful x) = do (xp, xs) <- splitPrimePrefix x return (Stateful xp, Stateful xs) splitPrimeSuffix (Stateful x) = do (xp, xs) <- splitPrimeSuffix x return (Stateful xp, Stateful xs) span p (Stateful x) = (Stateful xp, Stateful xs) where (xp, xs) = Factorial.span (p . Stateful) x spanMaybe s0 f (Stateful x) = (Stateful xp, Stateful xs, s') where (xp, xs, s') = Factorial.spanMaybe s0 f' x f' s x1 = f s (Stateful x1) spanMaybe' s0 f (Stateful x) = (Stateful xp, Stateful xs, s') where (xp, xs, s') = Factorial.spanMaybe' s0 f' x f' s x1 = f s (Stateful x1) split p (Stateful x) = List.map Stateful (Factorial.split (p . Stateful) x) splitAt n (Stateful x) = (Stateful xp, Stateful xs) where (xp, xs) = splitAt n x take n (Stateful x) = Stateful (take n x) drop n (Stateful x) = Stateful (drop n x) {-# INLINE splitPrimePrefix #-} {-# INLINE splitPrimeSuffix #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE splitAt #-} {-# INLINE take #-} {-# INLINE drop #-} instance (FactorialMonoid a, FactorialMonoid b, StableFactorial a, StableFactorial b) => StableFactorial (Stateful a b) instance (Monoid a, IsString b) => IsString (Stateful a b) where fromString = pure . fromString instance (LeftGCDMonoid a, FactorialMonoid a, TextualMonoid b) => TextualMonoid (Stateful a b) where fromText t = Stateful (fromText t, mempty) singleton c = Stateful (singleton c, mempty) characterPrefix = characterPrefix . extract splitCharacterPrefix (Stateful (t, x)) = do (c, t') <- splitCharacterPrefix t return (c, Stateful (t', x)) map f (Stateful (t, x)) = Stateful (Textual.map f t, x) all p = all p . extract any p = any p . extract foldl fx fc a0 (Stateful (t, x)) = Factorial.foldl f2 (Textual.foldl f1 fc a0 t) x where f1 a = fx a . fromFst f2 a = fx a . fromSnd foldr fx fc a (Stateful (t, x)) = Textual.foldr (fx . fromFst) fc (Factorial.foldr (fx . fromSnd) a x) t foldl' fx fc a0 (Stateful (t, x)) = a' `seq` Factorial.foldl' f2 a' x where a' = Textual.foldl' f1 fc a0 t f1 a = fx a . fromFst f2 a = fx a . fromSnd foldl_' fc a (Stateful (t, _)) = foldl_' fc a t foldr_ fc a (Stateful (t, _)) = Textual.foldr_ fc a t toString fx (Stateful (t, x)) = toString (fx . fromFst) t ++ Factorial.foldMap (fx . fromSnd) x scanl f c (Stateful (t, x)) = Stateful (Textual.scanl f c t, x) scanl1 f (Stateful (t, x)) = Stateful (Textual.scanl1 f t, x) scanr f c (Stateful (t, x)) = Stateful (Textual.scanr f c t, x) scanr1 f (Stateful (t, x)) = Stateful (Textual.scanr1 f t, x) mapAccumL f a (Stateful (t, x)) = (a', Stateful (t', x)) where (a', t') = Textual.mapAccumL f a t mapAccumR f a (Stateful (t, x)) = (a', Stateful (t', x)) where (a', t') = Textual.mapAccumR f a t span pt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs)) where (tp, ts) = Textual.span (pt . fromFst) pc t (xp, xs) | null ts = Factorial.span (pt . fromSnd) x | otherwise = (mempty, x) span_ bt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs)) where (tp, ts) = Textual.span_ bt pc t (xp, xs) | null ts && bt = (x, mempty) | otherwise = (mempty, x) break pt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs)) where (tp, ts) = Textual.break (pt . fromFst) pc t (xp, xs) | null ts = Factorial.break (pt . fromSnd) x | otherwise = (mempty, x) spanMaybe s0 ft fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s'') where (tp, ts, s') = Textual.spanMaybe s0 ft' fc t (xp, xs, s'') | null ts = Factorial.spanMaybe s' ft'' x | otherwise = (mempty, x, s') ft' s t1 = ft s (Stateful (t1, mempty)) ft'' s x1 = ft s (Stateful (mempty, x1)) spanMaybe' s0 ft fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s'') where (tp, ts, s') = Textual.spanMaybe' s0 ft' fc t (xp, xs, s'') | null ts = Factorial.spanMaybe' s' ft'' x | otherwise = (mempty, x, s') ft' s t1 = ft s (Stateful (t1, mempty)) ft'' s x1 = ft s (Stateful (mempty, x1)) spanMaybe_' s0 fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s') where (tp, ts, s') = Textual.spanMaybe_' s0 fc t (xp, xs) | null ts = (x, mempty) | otherwise = (mempty, x) split p (Stateful (t, x)) = restore id ts where ts = Textual.split p t restore f [t1] = f [Stateful (t1, x)] restore f ~(hd:tl) = restore (f . (Stateful (hd, mempty):)) tl find p = find p . extract elem c = elem c . extract {-# INLINE characterPrefix #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE map #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE spanMaybe' #-} {-# INLINE span #-} {-# INLINE spanMaybe_' #-} {-# INLINE span_ #-} {-# INLINE any #-} {-# INLINE all #-} {-# INLINE split #-} {-# INLINE find #-} {-# INLINE elem #-} {-# INLINE fromFst #-} fromFst :: Monoid b => a -> Stateful b a fromFst a = Stateful (a, mempty) {-# INLINE fromSnd #-} fromSnd :: Monoid a => b -> Stateful b a fromSnd b = Stateful (mempty, b) monoid-subclasses-1.2.4/src/Data/Monoid/LCM.hs0000644000000000000000000001047707346545000017206 0ustar0000000000000000{-# LANGUAGE Haskell2010, FlexibleInstances #-} -- | This module defines the 'LCMMonoid' subclass of the 'Monoid' class. -- -- The 'LCMMonoid' subclass adds the 'lcm' operation, which takes two monoidal -- arguments and finds their /least common multiple/, or (more generally) the -- least monoid from which either argument can be subtracted with the '' -- operation. -- -- For LCM monoids that are distributive, this module also provides the -- 'DistributiveLCMMonoid' subclass of 'LCMMonoid'. -- -- All classes in this module are for Abelian, /i.e./, 'Commutative' monoids. -- module Data.Monoid.LCM ( LCMMonoid (..) , DistributiveLCMMonoid ) where import Prelude hiding (gcd, lcm, max) import qualified Prelude import Data.IntSet (IntSet) import Data.Monoid (Dual (..), Product (..), Sum (..)) import Data.Monoid.GCD (GCDMonoid (..), DistributiveGCDMonoid) import Data.Set (Set) import Numeric.Natural (Natural) import qualified Data.IntSet as IntSet import qualified Data.Set as Set -- These imports are marked as redundant, but are actually required by haddock: import Data.Maybe (isJust) import Data.Semigroup.Cancellative (Reductive (())) import Data.Semigroup.Commutative (Commutative) -------------------------------------------------------------------------------- -- LCMMonoid -------------------------------------------------------------------------------- -- | Class of Abelian monoids that allow the /least common multiple/ to be -- found for any two given values. -- -- Operations must satisfy the following laws: -- -- __/Reductivity/__ -- -- @ -- 'isJust' ('lcm' a b '' a) -- @ -- @ -- 'isJust' ('lcm' a b '' b) -- @ -- -- __/Uniqueness/__ -- -- @ -- 'all' 'isJust' -- [ \ \ c '' a -- , \ \ c '' b -- , 'lcm' a b '' c -- ] -- ==> -- ('lcm' a b '==' c) -- @ -- -- __/Idempotence/__ -- -- @ -- 'lcm' a a '==' a -- @ -- -- __/Identity/__ -- -- @ -- 'lcm' 'mempty' a '==' a -- @ -- @ -- 'lcm' a 'mempty' '==' a -- @ -- -- __/Commutativity/__ -- -- @ -- 'lcm' a b '==' 'lcm' b a -- @ -- -- __/Associativity/__ -- -- @ -- 'lcm' ('lcm' a b) c '==' 'lcm' a ('lcm' b c) -- @ -- -- __/Absorption/__ -- -- @ -- 'lcm' a ('gcd' a b) '==' a -- @ -- @ -- 'gcd' a ('lcm' a b) '==' a -- @ -- class GCDMonoid m => LCMMonoid m where lcm :: m -> m -> m instance LCMMonoid () where lcm () () = () instance LCMMonoid a => LCMMonoid (Dual a) where lcm (Dual a) (Dual b) = Dual (lcm a b) instance LCMMonoid (Product Natural) where lcm (Product a) (Product b) = Product (Prelude.lcm a b) instance LCMMonoid (Sum Natural) where lcm (Sum a) (Sum b) = Sum (Prelude.max a b) instance Ord a => LCMMonoid (Set a) where lcm = Set.union instance LCMMonoid IntSet where lcm = IntSet.union instance (LCMMonoid a, LCMMonoid b) => LCMMonoid (a, b) where lcm (a0, a1) (b0, b1) = (lcm a0 b0, lcm a1 b1) instance (LCMMonoid a, LCMMonoid b, LCMMonoid c) => LCMMonoid (a, b, c) where lcm (a0, a1, a2) (b0, b1, b2) = (lcm a0 b0, lcm a1 b1, lcm a2 b2) instance (LCMMonoid a, LCMMonoid b, LCMMonoid c, LCMMonoid d) => LCMMonoid (a, b, c, d) where lcm (a0, a1, a2, a3) (b0, b1, b2, b3) = (lcm a0 b0, lcm a1 b1, lcm a2 b2, lcm a3 b3) -------------------------------------------------------------------------------- -- DistributiveLCMMonoid -------------------------------------------------------------------------------- -- | Class of /commutative/ LCM monoids with /distributivity/. -- -- In addition to the general 'LCMMonoid' laws, instances of this class -- must also satisfy the following laws: -- -- The 'lcm' operation itself must be /both/ left-distributive /and/ -- right-distributive: -- -- @ -- 'lcm' (a '<>' b) (a '<>' c) '==' a '<>' 'lcm' b c -- @ -- @ -- 'lcm' (a '<>' c) (b '<>' c) '==' 'lcm' a b '<>' c -- @ -- -- The 'lcm' and 'gcd' operations must distribute over one another: -- -- @ -- 'lcm' a ('gcd' b c) '==' 'gcd' ('lcm' a b) ('lcm' a c) -- @ -- @ -- 'gcd' a ('lcm' b c) '==' 'lcm' ('gcd' a b) ('gcd' a c) -- @ -- class (DistributiveGCDMonoid m, LCMMonoid m) => DistributiveLCMMonoid m instance DistributiveLCMMonoid () instance DistributiveLCMMonoid (Product Natural) instance DistributiveLCMMonoid (Sum Natural) instance DistributiveLCMMonoid IntSet instance Ord a => DistributiveLCMMonoid (Set a) instance DistributiveLCMMonoid a => DistributiveLCMMonoid (Dual a) monoid-subclasses-1.2.4/src/Data/Monoid/Monus.hs0000644000000000000000000003136207346545000017670 0ustar0000000000000000{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'OverlappingGCDMonoid' => 'Monus' subclass of the 'Monoid' class. -- -- @since 1.0 {-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-} module Data.Monoid.Monus ( Monus(..), OverlappingGCDMonoid(..) ) where import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..)) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import Data.Sequence (ViewL((:<)), (|>)) import qualified Data.Vector as Vector import Numeric.Natural (Natural) import Data.Semigroup.Cancellative import Data.Monoid.Null (MonoidNull(null)) import Prelude hiding (null) -- | Class of Abelian monoids with monus. The monus operation '<\>' is a synonym for both 'stripPrefixOverlap' and -- 'stripSuffixOverlap', which must be equivalent as '<>' is both associative and commutative: -- -- > (<\>) = flip stripPrefixOverlap -- > (<\>) = flip stripSuffixOverlap -- -- @since 1.0 class (Commutative m, Monoid m, OverlappingGCDMonoid m) => Monus m where (<\>) :: m -> m -> m infix 5 <\> -- | Class of monoids for which the greatest overlap can be found between any two values, such that -- -- > a == a' <> overlap a b -- > b == overlap a b <> b' -- -- The methods must satisfy the following laws: -- -- > stripOverlap a b == (stripSuffixOverlap b a, overlap a b, stripPrefixOverlap a b) -- > stripSuffixOverlap b a <> overlap a b == a -- > overlap a b <> stripPrefixOverlap a b == b -- -- The result of @overlap a b@ must be the largest prefix of @b@ and suffix of @a@, in the sense that it contains any -- other value @x@ that satifies the property @(x `isPrefixOf` b) && (x `isSuffixOf` a)@: -- -- > ∀x. (x `isPrefixOf` b && x `isSuffixOf` a) => (x `isPrefixOf` overlap a b && x `isSuffixOf` overlap a b) -- -- and it must be unique so there's no other value @y@ that satisfies the same properties for every such @x@: -- -- > ∀y. ((∀x. (x `isPrefixOf` b && x `isSuffixOf` a) => x `isPrefixOf` y && x `isSuffixOf` y) => y == overlap a b) -- -- @since 1.0 -- -- In addition, the 'overlap' operation must satisfy the following properties: -- -- __/Idempotence/__ -- -- @ -- 'overlap' a a '==' a -- @ -- -- __/Identity/__ -- -- @ -- 'overlap' 'mempty' a '==' 'mempty' -- @ -- @ -- 'overlap' a 'mempty' '==' 'mempty' -- @ -- class (Monoid m, LeftReductive m, RightReductive m) => OverlappingGCDMonoid m where stripPrefixOverlap :: m -> m -> m stripSuffixOverlap :: m -> m -> m overlap :: m -> m -> m stripOverlap :: m -> m -> (m, m, m) stripPrefixOverlap a b = b' where (_, _, b') = stripOverlap a b stripSuffixOverlap a b = b' where (b', _, _) = stripOverlap b a overlap a b = o where (_, o, _) = stripOverlap a b {-# MINIMAL stripOverlap #-} -- Unit instances -- | /O(1)/ instance Monus () where () <\> () = () -- | /O(1)/ instance OverlappingGCDMonoid () where overlap () () = () stripOverlap () () = ((), (), ()) stripPrefixOverlap () () = () stripSuffixOverlap () () = () -- Dual instances instance Monus a => Monus (Dual a) where Dual a <\> Dual b = Dual (a <\> b) instance OverlappingGCDMonoid a => OverlappingGCDMonoid (Dual a) where overlap (Dual a) (Dual b) = Dual (overlap b a) stripOverlap (Dual a) (Dual b) = (Dual s, Dual o, Dual p) where (p, o, s) = stripOverlap b a stripPrefixOverlap (Dual a) (Dual b) = Dual (stripSuffixOverlap a b) stripSuffixOverlap (Dual a) (Dual b) = Dual (stripPrefixOverlap a b) -- Sum instances -- | /O(1)/ instance Monus (Sum Natural) where Sum a <\> Sum b | a > b = Sum (a - b) | otherwise = Sum 0 -- | /O(1)/ instance OverlappingGCDMonoid (Sum Natural) where overlap (Sum a) (Sum b) = Sum (min a b) stripOverlap (Sum a) (Sum b) = (Sum $ a - c, Sum c, Sum $ b - c) where c = min a b stripPrefixOverlap = flip (<\>) stripSuffixOverlap = flip (<\>) -- Product instances -- | /O(1)/ instance Monus (Product Natural) where Product 0 <\> Product 0 = Product 1 Product a <\> Product b = Product (a `div` Prelude.gcd a b) -- | /O(1)/ instance OverlappingGCDMonoid (Product Natural) where overlap (Product a) (Product b) = Product (gcd a b) stripOverlap (Product 0) (Product 0) = (Product 1, Product 0, Product 1) stripOverlap (Product a) (Product b) = (Product $ div a c, Product c, Product $ div b c) where c = gcd a b stripPrefixOverlap = flip (<\>) stripSuffixOverlap = flip (<\>) -- Pair instances instance (Monus a, Monus b) => Monus (a, b) where (a1, b1) <\> (a2, b2) = (a1 <\> a2, b1 <\> b2) instance (OverlappingGCDMonoid a, OverlappingGCDMonoid b) => OverlappingGCDMonoid (a, b) where overlap (a1, b1) (a2, b2) = (overlap a1 a2, overlap b1 b2) stripOverlap (a1, b1) (a2, b2) = ((ap, bp), (ao, bo), (as, bs)) where (ap, ao, as) = stripOverlap a1 a2 (bp, bo, bs) = stripOverlap b1 b2 stripPrefixOverlap (a1, b1) (a2, b2) = (stripPrefixOverlap a1 a2, stripPrefixOverlap b1 b2) stripSuffixOverlap (a1, b1) (a2, b2) = (stripSuffixOverlap a1 a2, stripSuffixOverlap b1 b2) -- Triple instances instance (Monus a, Monus b, Monus c) => Monus (a, b, c) where (a1, b1, c1) <\> (a2, b2, c2) = (a1 <\> a2, b1 <\> b2, c1 <\> c2) instance (OverlappingGCDMonoid a, OverlappingGCDMonoid b, OverlappingGCDMonoid c) => OverlappingGCDMonoid (a, b, c) where overlap (a1, b1, c1) (a2, b2, c2) = (overlap a1 a2, overlap b1 b2, overlap c1 c2) stripOverlap (a1, b1, c1) (a2, b2, c2) = ((ap, bp, cp), (ao, bo, co), (as, bs, cs)) where (ap, ao, as) = stripOverlap a1 a2 (bp, bo, bs) = stripOverlap b1 b2 (cp, co, cs) = stripOverlap c1 c2 stripPrefixOverlap (a1, b1, c1) (a2, b2, c2) = (stripPrefixOverlap a1 a2, stripPrefixOverlap b1 b2, stripPrefixOverlap c1 c2) stripSuffixOverlap (a1, b1, c1) (a2, b2, c2) = (stripSuffixOverlap a1 a2, stripSuffixOverlap b1 b2, stripSuffixOverlap c1 c2) -- Quadruple instances instance (Monus a, Monus b, Monus c, Monus d) => Monus (a, b, c, d) where (a1, b1, c1, d1) <\> (a2, b2, c2, d2) = (a1 <\> a2, b1 <\> b2, c1 <\> c2, d1 <\> d2) instance (OverlappingGCDMonoid a, OverlappingGCDMonoid b, OverlappingGCDMonoid c, OverlappingGCDMonoid d) => OverlappingGCDMonoid (a, b, c, d) where overlap (a1, b1, c1, d1) (a2, b2, c2, d2) = (overlap a1 a2, overlap b1 b2, overlap c1 c2, overlap d1 d2) stripOverlap (a1, b1, c1, d1) (a2, b2, c2, d2) = ((ap, bp, cp, dp), (ao, bo, co, dm), (as, bs, cs, ds)) where (ap, ao, as) = stripOverlap a1 a2 (bp, bo, bs) = stripOverlap b1 b2 (cp, co, cs) = stripOverlap c1 c2 (dp, dm, ds) = stripOverlap d1 d2 stripPrefixOverlap (a1, b1, c1, d1) (a2, b2, c2, d2) = (stripPrefixOverlap a1 a2, stripPrefixOverlap b1 b2, stripPrefixOverlap c1 c2, stripPrefixOverlap d1 d2) stripSuffixOverlap (a1, b1, c1, d1) (a2, b2, c2, d2) = (stripSuffixOverlap a1 a2, stripSuffixOverlap b1 b2, stripSuffixOverlap c1 c2, stripSuffixOverlap d1 d2) -- Maybe instances instance (Monus a, MonoidNull a) => Monus (Maybe a) where Just a <\> Just b | null remainder = Nothing | otherwise = Just remainder where remainder = a <\> b Nothing <\> _ = Nothing x <\> Nothing = x instance (OverlappingGCDMonoid a, MonoidNull a) => OverlappingGCDMonoid (Maybe a) where overlap (Just a) (Just b) = Just (overlap a b) overlap _ _ = Nothing stripOverlap (Just a) (Just b) = (if null a' then Nothing else Just a', Just o, if null b' then Nothing else Just b') where (a', o, b') = stripOverlap a b stripOverlap a b = (a, Nothing, b) stripPrefixOverlap (Just a) (Just b) | null b' = Nothing | otherwise = Just b' where b' = stripPrefixOverlap a b stripPrefixOverlap Nothing x = x stripPrefixOverlap _ Nothing = Nothing stripSuffixOverlap (Just a) (Just b) | null b' = Nothing | otherwise = Just b' where b' = stripSuffixOverlap a b stripSuffixOverlap Nothing x = x stripSuffixOverlap _ Nothing = Nothing -- Set instances -- | /O(m*log(n/m + 1)), m <= n/ instance Ord a => Monus (Set.Set a) where (<\>) = (Set.\\) -- | /O(m*log(n/m + 1)), m <= n/ instance Ord a => OverlappingGCDMonoid (Set.Set a) where overlap = Set.intersection stripOverlap a b = (Set.difference a b, Set.intersection a b, Set.difference b a) stripPrefixOverlap a b = b <\> a stripSuffixOverlap a b = b <\> a -- IntSet instances -- | /O(m+n)/ instance Monus IntSet.IntSet where (<\>) = (IntSet.\\) -- | /O(m+n)/ instance OverlappingGCDMonoid IntSet.IntSet where overlap = IntSet.intersection stripOverlap a b = (IntSet.difference a b, IntSet.intersection a b, IntSet.difference b a) stripPrefixOverlap a b = b <\> a stripSuffixOverlap a b = b <\> a -- Map instances -- | /O(m+n)/ instance (Ord k, Eq v) => OverlappingGCDMonoid (Map.Map k v) where overlap = flip Map.intersection stripOverlap a b = (stripSuffixOverlap b a, overlap a b, stripPrefixOverlap a b) stripPrefixOverlap = flip Map.difference stripSuffixOverlap a b = Map.differenceWith (\x y-> if x == y then Nothing else Just x) b a -- IntMap instances -- | /O(m+n)/ instance Eq a => OverlappingGCDMonoid (IntMap.IntMap a) where overlap = flip IntMap.intersection stripOverlap a b = (stripSuffixOverlap b a, overlap a b, stripPrefixOverlap a b) stripPrefixOverlap = flip IntMap.difference stripSuffixOverlap a b = IntMap.differenceWith (\x y-> if x == y then Nothing else Just x) b a -- List instances -- | /O(m*n)/ instance Eq a => OverlappingGCDMonoid [a] where overlap a b = go a where go x | x `isPrefixOf` b = x | otherwise = go (tail x) stripOverlap a b = go [] a where go p o | Just s <- stripPrefix o b = (reverse p, o, s) | x:xs <- o = go (x:p) xs | otherwise = error "impossible" stripPrefixOverlap a b = go a where go x | Just s <- stripPrefix x b = s | otherwise = go (tail x) -- Seq instances -- | /O(min(m,n)^2)/ instance Eq a => OverlappingGCDMonoid (Sequence.Seq a) where overlap a b = go (Sequence.drop (Sequence.length a - Sequence.length b) a) where go x | x `isPrefixOf` b = x | _ :< x' <- Sequence.viewl x = go x' | otherwise = error "impossible" stripOverlap a b = uncurry go (Sequence.splitAt (Sequence.length a - Sequence.length b) a) where go p o | Just s <- stripPrefix o b = (p, o, s) | x :< xs <- Sequence.viewl o = go (p |> x) xs | otherwise = error "impossible" -- Vector instances -- | /O(min(m,n)^2)/ instance Eq a => OverlappingGCDMonoid (Vector.Vector a) where stripOverlap a b = go (max alen blen) where alen = Vector.length a blen = Vector.length b go i | as == bp = (ap, as, bs) | otherwise = go (pred i) where (ap, as) = Vector.splitAt (alen - i) a (bp, bs) = Vector.splitAt i b -- ByteString instances -- | /O(min(m,n)^2)/ instance OverlappingGCDMonoid ByteString.ByteString where stripOverlap a b = go (max alen blen) where alen = ByteString.length a blen = ByteString.length b go i | as == bp = (ap, as, bs) | otherwise = go (pred i) where (ap, as) = ByteString.splitAt (alen - i) a (bp, bs) = ByteString.splitAt i b -- Lazy ByteString instances -- | /O(m*n)/ instance OverlappingGCDMonoid LazyByteString.ByteString where stripOverlap a b = go (max alen blen) where alen = LazyByteString.length a blen = LazyByteString.length b go i | as == bp = (ap, as, bs) | otherwise = go (pred i) where (ap, as) = LazyByteString.splitAt (alen - i) a (bp, bs) = LazyByteString.splitAt i b -- Text instances -- | /O(min(m,n)^2)/ instance OverlappingGCDMonoid Text.Text where stripOverlap a b | Text.null b = (a, b, b) | otherwise = go (Text.breakOnAll (Text.take 1 b) a) where go [] = (a, mempty, b) go ((ap, as):breaks) | Just bs <- Text.stripPrefix as b = (ap, as, bs) | otherwise = go breaks -- Lazy Text instances -- | /O(m*n)/ instance OverlappingGCDMonoid LazyText.Text where stripOverlap a b | LazyText.null b = (a, b, b) | otherwise = go (LazyText.breakOnAll (LazyText.take 1 b) a) where go [] = (a, mempty, b) go ((ap, as):breaks) | Just bs <- LazyText.stripPrefix as b = (ap, as, bs) | otherwise = go breaks monoid-subclasses-1.2.4/src/Data/Monoid/Null.hs0000644000000000000000000001060207346545000017473 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, FlexibleInstances, 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 Numeric.Natural (Natural) import Prelude hiding (null) -- | Extension of 'Monoid' that allows testing a value for equality with 'mempty'. The following law must hold: -- -- prop> null x == (x == mempty) -- -- Furthermore, the performance of this method should be constant, /i.e./, independent of the length of its argument. class Monoid m => MonoidNull m where null :: m -> Bool -- | 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 PositiveMonoid (Product Natural) instance PositiveMonoid (Sum Natural) 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-1.2.4/src/Data/Monoid/Textual.hs0000644000000000000000000005402407346545000020215 0ustar0000000000000000{- Copyright 2013-2017 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'TextualMonoid' class and several of its instances. -- {-# LANGUAGE Haskell2010, FlexibleInstances #-} module Data.Monoid.Textual ( TextualMonoid(..) ) where import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable import Data.Functor -- ((<$>)) import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import Data.Text (Text) import Data.Monoid -- (Monoid(mappend, mempty)) import qualified Data.Sequence as Sequence import Data.String (IsString(fromString)) import Data.Int (Int64) import Data.Semigroup.Cancellative (LeftReductive) import Data.Monoid.GCD (LeftGCDMonoid) import Data.Monoid.Factorial (FactorialMonoid) import qualified Data.Monoid.Factorial as Factorial import Prelude (Bool(..), Int, Char, String, Maybe(..), (.), ($), (==), (||), (&&), id, seq, succ, const, otherwise, maybe, fst, snd) -- | The 'TextualMonoid' class is an extension of 'FactorialMonoid' specialized for monoids that can contain -- characters. Its methods are generally equivalent to their namesake functions from "Data.List" and "Data.Text", and -- they satisfy the following laws: -- -- > unfoldr splitCharacterPrefix . fromString == id -- > splitCharacterPrefix . primePrefix == fmap (\(c, t)-> (c, mempty)) . splitCharacterPrefix -- > -- > map f . fromString == fromString . List.map f -- > concatMap (fromString . f) . fromString == fromString . List.concatMap f -- > -- > foldl ft fc a . fromString == List.foldl fc a -- > foldr ft fc a . fromString == List.foldr fc a -- > foldl' ft fc a . fromString == List.foldl' fc a -- > -- > scanl f c . fromString == fromString . List.scanl f c -- > scanr f c . fromString == fromString . List.scanr f c -- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a -- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a -- > -- > takeWhile pt pc . fromString == fromString . takeWhile pc -- > dropWhile pt pc . fromString == fromString . dropWhile pc -- > -- > mconcat . intersperse (singleton c) . split (== c) == id -- > find p . fromString == List.find p -- > elem c . fromString == List.elem c -- -- A 'TextualMonoid' may contain non-character data insterspersed between its characters. Every class method that -- returns a modified 'TextualMonoid' instance generally preserves this non-character data. Methods like 'foldr' can -- access both the non-character and character data and expect two arguments for the two purposes. For each of these -- methods there is also a simplified version with underscore in name (like 'foldr_') that ignores the non-character -- data. -- -- All of the following expressions are identities: -- -- > map id -- > concatMap singleton -- > foldl (<>) (\a c-> a <> singleton c) mempty -- > foldr (<>) ((<>) . singleton) mempty -- > foldl' (<>) (\a c-> a <> singleton c) mempty -- > scanl1 (const id) -- > scanr1 const -- > uncurry (mapAccumL (,)) -- > uncurry (mapAccumR (,)) -- > takeWhile (const True) (const True) -- > dropWhile (const False) (const False) -- > toString undefined . fromString -- > toText undefined . fromText class (IsString t, LeftReductive t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where -- | Contructs a new data type instance Like 'fromString', but from a 'Text' input instead of 'String'. -- -- > fromText == fromString . Text.unpack fromText :: Text -> t -- | Creates a prime monoid containing a single character. -- -- > singleton c == fromString [c] singleton :: Char -> t -- | Specialized version of 'Factorial.splitPrimePrefix'. Every prime factor of a textual monoid must consist of a -- single character or no character at all. splitCharacterPrefix :: t -> Maybe (Char, t) -- | Extracts a single character that prefixes the monoid, if the monoid begins with a character. Otherwise returns -- 'Nothing'. -- -- > characterPrefix == fmap fst . splitCharacterPrefix characterPrefix :: t -> Maybe Char -- | Equivalent to 'List.map' from "Data.List" with a @Char -> Char@ function. Preserves all non-character data. -- -- > map f == concatMap (singleton . f) map :: (Char -> Char) -> t -> t -- | Equivalent to 'List.concatMap' from "Data.List" with a @Char -> String@ function. Preserves all non-character -- data. concatMap :: (Char -> t) -> t -> t -- | Returns the list of characters the monoid contains, once the argument function converts all its non-character -- factors into characters. toString :: (t -> String) -> t -> String -- | Converts the monoid into 'Text', given a function to convert the non-character factors into chunks of 'Text'. toText :: (t -> Text) -> t -> Text -- | Equivalent to 'List.any' from "Data.List". Ignores all non-character data. any :: (Char -> Bool) -> t -> Bool -- | Equivalent to 'List.all' from "Data.List". Ignores all non-character data. all :: (Char -> Bool) -> t -> Bool -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent -- to 'List.foldl' from "Data.List". foldl :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a -- | Strict version of 'foldl'. foldl' :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent -- to 'List.foldl\'' from "Data.List". foldr :: (t -> a -> a) -> (Char -> a -> a) -> a -> t -> a -- | Equivalent to 'List.scanl' from "Data.List" when applied to a 'String', but preserves all non-character data. scanl :: (Char -> Char -> Char) -> Char -> t -> t -- | Equivalent to 'List.scanl1' from "Data.List" when applied to a 'String', but preserves all non-character data. -- -- > scanl f c == scanl1 f . (singleton c <>) scanl1 :: (Char -> Char -> Char) -> t -> t -- | Equivalent to 'List.scanr' from "Data.List" when applied to a 'String', but preserves all non-character data. scanr :: (Char -> Char -> Char) -> Char -> t -> t -- | Equivalent to 'List.scanr1' from "Data.List" when applied to a 'String', but preserves all non-character data. -- -- > scanr f c == scanr1 f . (<> singleton c) scanr1 :: (Char -> Char -> Char) -> t -> t -- | Equivalent to 'List.mapAccumL' from "Data.List" when applied to a 'String', but preserves all non-character -- data. mapAccumL :: (a -> Char -> (a, Char)) -> a -> t -> (a, t) -- | Equivalent to 'List.mapAccumR' from "Data.List" when applied to a 'String', but preserves all non-character -- data. mapAccumR :: (a -> Char -> (a, Char)) -> a -> t -> (a, t) -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to -- 'List.takeWhile' from "Data.List" when applied to a 'String'. takeWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to -- 'List.dropWhile' from "Data.List" when applied to a 'String'. dropWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t -- | 'break pt pc' is equivalent to @span (not . pt) (not . pc)@. break :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t) -- | 'span pt pc t' is equivalent to @(takeWhile pt pc t, dropWhile pt pc t)@. span :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t) -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'. spanMaybe :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s) -- | Strict version of 'spanMaybe'. spanMaybe' :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s) -- | Splits the monoid into components delimited by character separators satisfying the given predicate. The -- characters satisfying the predicate are not a part of the result. -- -- > split p == Factorial.split (maybe False p . characterPrefix) split :: (Char -> Bool) -> t -> [t] -- | Like 'List.find' from "Data.List" when applied to a 'String'. Ignores non-character data. find :: (Char -> Bool) -> t -> Maybe Char -- | Like 'List.elem' from "Data.List" when applied to a 'String'. Ignores non-character data. elem :: Char -> t -> Bool -- | > foldl_ = foldl const foldl_ :: (a -> Char -> a) -> a -> t -> a foldl_' :: (a -> Char -> a) -> a -> t -> a foldr_ :: (Char -> a -> a) -> a -> t -> a -- | > takeWhile_ = takeWhile . const takeWhile_ :: Bool -> (Char -> Bool) -> t -> t -- | > dropWhile_ = dropWhile . const dropWhile_ :: Bool -> (Char -> Bool) -> t -> t -- | > break_ = break . const break_ :: Bool -> (Char -> Bool) -> t -> (t, t) -- | > span_ = span . const span_ :: Bool -> (Char -> Bool) -> t -> (t, t) -- | > spanMaybe_ s = spanMaybe s (const . Just) spanMaybe_ :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s) spanMaybe_' :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s) fromText = fromString . Text.unpack singleton = fromString . (:[]) characterPrefix = fmap fst . splitCharacterPrefix map f = concatMap (singleton . f) concatMap f = foldr mappend (mappend . f) mempty toString f = foldr (mappend . f) (:) [] toText f = Text.pack . toString (Text.unpack . f) all p = foldr (const id) ((&&) . p) True any p = foldr (const id) ((||) . p) False foldl ft fc = Factorial.foldl (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime)) foldr ft fc = Factorial.foldr (\prime-> maybe (ft prime) fc (characterPrefix prime)) foldl' ft fc = Factorial.foldl' (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime)) foldl_ = foldl const foldr_ = foldr (const id) foldl_' = foldl' const scanl f c = mappend (singleton c) . fst . foldl foldlOther (foldlChars f) (mempty, c) scanl1 f t = case (Factorial.splitPrimePrefix t, splitCharacterPrefix t) of (Nothing, _) -> t (Just (prefix, suffix), Nothing) -> mappend prefix (scanl1 f suffix) (Just _, Just (c, suffix)) -> scanl f c suffix scanr f c = fst . foldr foldrOther (foldrChars f) (singleton c, c) scanr1 f = fst . foldr foldrOther fc (mempty, Nothing) where fc c (t, Nothing) = (mappend (singleton c) t, Just c) fc c1 (t, Just c2) = (mappend (singleton c') t, Just c') where c' = f c1 c2 mapAccumL f a0 = foldl ft fc (a0, mempty) where ft (a, t1) t2 = (a, mappend t1 t2) fc (a, t) c = (a', mappend t (singleton c')) where (a', c') = f a c mapAccumR f a0 = foldr ft fc (a0, mempty) where ft t1 (a, t2) = (a, mappend t1 t2) fc c (a, t) = (a', mappend (singleton c') t) where (a', c') = f a c takeWhile pt pc = fst . span pt pc dropWhile pt pc = snd . span pt pc span pt pc = Factorial.span (\prime-> maybe (pt prime) pc (characterPrefix prime)) break pt pc = Factorial.break (\prime-> maybe (pt prime) pc (characterPrefix prime)) spanMaybe s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = case Factorial.splitPrimePrefix t of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, t, s) Nothing -> (t0, t, s) spanMaybe' s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = seq s $ case Factorial.splitPrimePrefix t of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, t, s) Nothing -> (t0, t, s) takeWhile_ = takeWhile . const dropWhile_ = dropWhile . const break_ = break . const span_ = span . const spanMaybe_ s = spanMaybe s (const . Just) spanMaybe_' s = spanMaybe' s (const . Just) split p m = prefix : splitRest where (prefix, rest) = break (const False) p m splitRest = case splitCharacterPrefix rest of Nothing -> [] Just (_, tl) -> split p tl find p = foldr (const id) (\c r-> if p c then Just c else r) Nothing elem c = any (== c) {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE fromText #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE split #-} {-# INLINE takeWhile #-} {-# INLINE foldl_ #-} {-# INLINE foldl_' #-} {-# INLINE foldr_ #-} {-# INLINABLE spanMaybe_ #-} {-# INLINABLE spanMaybe_' #-} {-# INLINE span_ #-} {-# INLINE break_ #-} {-# INLINE takeWhile_ #-} {-# INLINE dropWhile_ #-} {-# INLINE elem #-} {-# INLINABLE all #-} {-# INLINABLE any #-} {-# MINIMAL splitCharacterPrefix #-} foldlChars :: TextualMonoid t => (Char -> Char -> Char) -> (t, Char) -> Char -> (t, Char) foldlOther :: Monoid t => (t, Char) -> t -> (t, Char) foldrChars :: TextualMonoid t => (Char -> Char -> Char) -> Char -> (t, Char) -> (t, Char) foldrOther :: Monoid t => t -> (t, a) -> (t, a) foldlChars f (t, c1) c2 = (mappend t (singleton c'), c') where c' = f c1 c2 foldlOther (t1, c) t2 = (mappend t1 t2, c) foldrChars f c1 (t, c2) = (mappend (singleton c') t, c') where c' = f c1 c2 foldrOther t1 (t2, c) = (mappend t1 t2, c) instance TextualMonoid String where fromText = Text.unpack singleton c = [c] splitCharacterPrefix (c:rest) = Just (c, rest) splitCharacterPrefix [] = Nothing characterPrefix (c:_) = Just c characterPrefix [] = Nothing map = List.map concatMap = List.concatMap toString = const id any = List.any all = List.all foldl = const List.foldl foldl' = const List.foldl' foldr = const List.foldr scanl = List.scanl scanl1 = List.scanl1 scanr = List.scanr scanr1 = List.scanr1 mapAccumL = List.mapAccumL mapAccumR = List.mapAccumR takeWhile _ = List.takeWhile dropWhile _ = List.dropWhile break _ = List.break span _ = List.span spanMaybe s0 _ft fc l = (prefix' [], suffix' [], s') where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = (prefix . (c:), id, s1, True) | otherwise = (prefix, suffix . (c:), s, False) spanMaybe' s0 _ft fc l = (prefix' [], suffix' [], s') where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = seq s1 (prefix . (c:), id, s1, True) | otherwise = (prefix, suffix . (c:), s, False) find = List.find elem = List.elem {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE elem #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE fromText #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} instance TextualMonoid Text where fromText = id singleton = Text.singleton splitCharacterPrefix = Text.uncons characterPrefix t = if Text.null t then Nothing else Just (Text.head t) map = Text.map concatMap = Text.concatMap toString = const Text.unpack toText = const id any = Text.any all = Text.all foldl = const Text.foldl foldl' = const Text.foldl' foldr = const Text.foldr scanl = Text.scanl scanl1 = Text.scanl1 scanr = Text.scanr scanr1 = Text.scanr1 mapAccumL = Text.mapAccumL mapAccumR = Text.mapAccumR takeWhile _ = Text.takeWhile dropWhile _ = Text.dropWhile break _ = Text.break span _ = Text.span spanMaybe s0 _ft fc t = case Text.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 _ft fc t = case Text.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) split = Text.split find = Text.find {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE fromText #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE split #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} instance TextualMonoid LazyText.Text where fromText = LazyText.fromStrict singleton = LazyText.singleton splitCharacterPrefix = LazyText.uncons characterPrefix t = if LazyText.null t then Nothing else Just (LazyText.head t) map = LazyText.map concatMap = LazyText.concatMap toString = const LazyText.unpack toText = const LazyText.toStrict any = LazyText.any all = LazyText.all foldl = const LazyText.foldl foldl' = const LazyText.foldl' foldr = const LazyText.foldr scanl = LazyText.scanl scanl1 = LazyText.scanl1 scanr = LazyText.scanr scanr1 = LazyText.scanr1 mapAccumL = LazyText.mapAccumL mapAccumR = LazyText.mapAccumR takeWhile _ = LazyText.takeWhile dropWhile _ = LazyText.dropWhile break _ = LazyText.break span _ = LazyText.span spanMaybe s0 _ft fc t = case LazyText.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 _ft fc t = case LazyText.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) split = LazyText.split find = LazyText.find {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE fromText #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE split #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} instance TextualMonoid (Sequence.Seq Char) where singleton = Sequence.singleton splitCharacterPrefix s = case Sequence.viewl s of Sequence.EmptyL -> Nothing c Sequence.:< rest -> Just (c, rest) characterPrefix s = case Sequence.viewl s of Sequence.EmptyL -> Nothing c Sequence.:< _ -> Just c map = Traversable.fmapDefault concatMap = Foldable.foldMap toString = const Foldable.toList any = Foldable.any all = Foldable.all foldl = const Foldable.foldl foldl' = const Foldable.foldl' foldr = const Foldable.foldr scanl = Sequence.scanl scanl1 f v | Sequence.null v = Sequence.empty | otherwise = Sequence.scanl1 f v scanr = Sequence.scanr scanr1 f v | Sequence.null v = Sequence.empty | otherwise = Sequence.scanr1 f v takeWhile _ = Sequence.takeWhileL dropWhile _ = Sequence.dropWhileL break _ = Sequence.breakl span _ = Sequence.spanl spanMaybe s0 _ft fc b = case Foldable.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 _ft fc b = case Foldable.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) find = Foldable.find elem = Foldable.elem {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE elem #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE map #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} monoid-subclasses-1.2.4/src/Data/Semigroup/0000755000000000000000000000000007346545000016753 5ustar0000000000000000monoid-subclasses-1.2.4/src/Data/Semigroup/Cancellative.hs0000644000000000000000000004311307346545000021703 0ustar0000000000000000{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'Semigroup' => 'Reductive' => 'Cancellative' class hierarchy. -- -- @since 1.0 -- -- The 'Reductive' class introduces operation '' which is the inverse of '<>'. For the 'Sum' semigroup, this -- operation is subtraction; for 'Product' it is division and for 'Set' it's the set difference. A 'Reductive' -- semigroup is not a full group because '' may return 'Nothing'. -- -- The 'Cancellative' subclass does not add any operation but it provides the additional guarantee that '<>' can -- always be undone with ''. Thus 'Sum' is 'Cancellative' but 'Product' is not because @(0*n)/0@ is not defined. -- -- All semigroup subclasses listed above are for Abelian, /i.e./, commutative or symmetric semigroups. Since most -- practical semigroups in Haskell are not Abelian, each of the these classes has two symmetric superclasses: -- -- * 'LeftReductive' -- -- * 'LeftCancellative' -- -- * 'RightReductive' -- -- * 'RightCancellative' {-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-} module Data.Semigroup.Cancellative ( -- * Symmetric, commutative semigroup classes Commutative, Reductive(..), Cancellative, SumCancellative(..), -- * Asymmetric semigroup classes LeftReductive(..), RightReductive(..), LeftCancellative, RightCancellative ) where import Data.Semigroup -- (Semigroup, Dual(..), Sum(..), Product(..)) import Data.Semigroup.Commutative import qualified Data.List as List import Data.Maybe (isJust) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Unsafe as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import qualified Data.Vector as Vector import Numeric.Natural (Natural) import Numeric.Product.Commutative (CommutativeProduct) -- | Class of Abelian semigroups with a partial inverse for the Semigroup '<>' operation. The inverse operation '' must -- satisfy the following laws: -- -- > maybe a (b <>) (a b) == a -- > maybe a (<> b) (a b) == a -- -- The '' operator is a synonym for both 'stripPrefix' and 'stripSuffix', which must be equivalent as '<>' is both -- associative and commutative. -- -- > () = flip stripPrefix -- > () = flip stripSuffix class (Commutative m, LeftReductive m, RightReductive m) => Reductive m where () :: m -> m -> Maybe m infix 5 -- | Subclass of 'Reductive' where '' is a complete inverse of the Semigroup '<>' operation. The class -- instances must satisfy the following additional laws: -- -- > (a <> b) a == Just b -- > (a <> b) b == Just a class (LeftCancellative m, RightCancellative m, Reductive m) => Cancellative m -- | Class of semigroups with a left inverse of 'Data.Semigroup.<>', satisfying the following law: -- -- > isPrefixOf a b == isJust (stripPrefix a b) -- > maybe b (a <>) (stripPrefix a b) == b -- > a `isPrefixOf` (a <> b) -- -- Every instance definition has to implement at least the 'stripPrefix' method. class Semigroup m => LeftReductive m where isPrefixOf :: m -> m -> Bool stripPrefix :: m -> m -> Maybe m isPrefixOf a b = isJust (stripPrefix a b) {-# MINIMAL stripPrefix #-} -- | Class of semigroups with a right inverse of 'Data.Semigroup.<>', satisfying the following law: -- -- > isSuffixOf a b == isJust (stripSuffix a b) -- > maybe b (<> a) (stripSuffix a b) == b -- > b `isSuffixOf` (a <> b) -- -- Every instance definition has to implement at least the 'stripSuffix' method. class Semigroup m => RightReductive m where isSuffixOf :: m -> m -> Bool stripSuffix :: m -> m -> Maybe m isSuffixOf a b = isJust (stripSuffix a b) {-# MINIMAL stripSuffix #-} -- | Subclass of 'LeftReductive' where 'stripPrefix' is a complete inverse of '<>', satisfying the following -- additional law: -- -- > stripPrefix a (a <> b) == Just b class LeftReductive m => LeftCancellative m -- | Subclass of 'LeftReductive' where 'stripPrefix' is a complete inverse of '<>', satisfying the following -- additional law: -- -- > stripSuffix b (a <> b) == Just a class RightReductive m => RightCancellative m -- Unit instances instance Reductive () where () () = Just () instance Cancellative () -- | /O(1)/ instance LeftReductive () where stripPrefix () () = Just () -- | /O(1)/ instance RightReductive () where stripSuffix () () = Just () instance LeftCancellative () instance RightCancellative () -- Dual instances instance Reductive a => Reductive (Dual a) where Dual a Dual b = fmap Dual (a b) instance Cancellative a => Cancellative (Dual a) instance LeftReductive a => RightReductive (Dual a) where stripSuffix (Dual a) (Dual b) = fmap Dual (stripPrefix a b) Dual a `isSuffixOf` Dual b = a `isPrefixOf` b instance RightReductive a => LeftReductive (Dual a) where stripPrefix (Dual a) (Dual b) = fmap Dual (stripSuffix a b) Dual a `isPrefixOf` Dual b = a `isSuffixOf` b instance LeftCancellative a => RightCancellative (Dual a) instance RightCancellative a => LeftCancellative (Dual a) -- Sum instances -- | Helper class to avoid @FlexibleInstances@ class Num a => SumCancellative a where cancelAddition :: a -> a -> Maybe a cancelAddition a b = Just (a - b) instance SumCancellative Int instance SumCancellative Integer instance SumCancellative Rational instance SumCancellative Natural where cancelAddition a b | a < b = Nothing | otherwise = Just (a - b) -- | /O(1)/ instance SumCancellative a => Reductive (Sum a) where Sum a Sum b = Sum <$> cancelAddition a b -- | /O(1)/ instance SumCancellative a => LeftReductive (Sum a) where stripPrefix a b = b a -- | /O(1)/ instance SumCancellative a => RightReductive (Sum a) where stripSuffix a b = b a instance SumCancellative a => Cancellative (Sum a) instance SumCancellative a => LeftCancellative (Sum a) instance SumCancellative a => RightCancellative (Sum a) -- Product instances instance (CommutativeProduct a, Integral a) => Reductive (Product a) where Product 0 Product 0 = Just (Product 0) Product _ Product 0 = Nothing Product a Product b = if remainder == 0 then Just (Product quotient) else Nothing where (quotient, remainder) = quotRem a b instance (CommutativeProduct a, Integral a) => LeftReductive (Product a) where stripPrefix a b = b a instance (CommutativeProduct a, Integral a) => RightReductive (Product a) where stripSuffix a b = b a -- Pair instances instance (Reductive a, Reductive b) => Reductive (a, b) where (a, b) (c, d) = case (a c, b d) of (Just a', Just b') -> Just (a', b') _ -> Nothing instance (Cancellative a, Cancellative b) => Cancellative (a, b) instance (LeftReductive a, LeftReductive b) => LeftReductive (a, b) where stripPrefix (a, b) (c, d) = case (stripPrefix a c, stripPrefix b d) of (Just a', Just b') -> Just (a', b') _ -> Nothing isPrefixOf (a, b) (c, d) = isPrefixOf a c && isPrefixOf b d instance (RightReductive a, RightReductive b) => RightReductive (a, b) where stripSuffix (a, b) (c, d) = case (stripSuffix a c, stripSuffix b d) of (Just a', Just b') -> Just (a', b') _ -> Nothing isSuffixOf (a, b) (c, d) = isSuffixOf a c && isSuffixOf b d instance (LeftCancellative a, LeftCancellative b) => LeftCancellative (a, b) instance (RightCancellative a, RightCancellative b) => RightCancellative (a, b) -- Triple instances instance (Reductive a, Reductive b, Reductive c) => Reductive (a, b, c) where (a1, b1, c1) (a2, b2, c2) = (,,) <$> (a1 a2) <*> (b1 b2) <*> (c1 c2) instance (Cancellative a, Cancellative b, Cancellative c) => Cancellative (a, b, c) instance (LeftReductive a, LeftReductive b, LeftReductive c) => LeftReductive (a, b, c) where stripPrefix (a1, b1, c1) (a2, b2, c2) = (,,) <$> stripPrefix a1 a2 <*> stripPrefix b1 b2 <*> stripPrefix c1 c2 isPrefixOf (a1, b1, c1) (a2, b2, c2) = isPrefixOf a1 a2 && isPrefixOf b1 b2 && isPrefixOf c1 c2 instance (RightReductive a, RightReductive b, RightReductive c) => RightReductive (a, b, c) where stripSuffix (a1, b1, c1) (a2, b2, c2) = (,,) <$> stripSuffix a1 a2 <*> stripSuffix b1 b2 <*> stripSuffix c1 c2 isSuffixOf (a1, b1, c1) (a2, b2, c2) = isSuffixOf a1 a2 && isSuffixOf b1 b2 && isSuffixOf c1 c2 instance (LeftCancellative a, LeftCancellative b, LeftCancellative c) => LeftCancellative (a, b, c) instance (RightCancellative a, RightCancellative b, RightCancellative c) => RightCancellative (a, b, c) -- Quadruple instances instance (Reductive a, Reductive b, Reductive c, Reductive d) => Reductive (a, b, c, d) where (a1, b1, c1, d1) (a2, b2, c2, d2) = (,,,) <$> (a1 a2) <*> (b1 b2) <*> (c1 c2) <*> (d1 d2) instance (Cancellative a, Cancellative b, Cancellative c, Cancellative d) => Cancellative (a, b, c, d) instance (LeftReductive a, LeftReductive b, LeftReductive c, LeftReductive d) => LeftReductive (a, b, c, d) where stripPrefix (a1, b1, c1, d1) (a2, b2, c2, d2) = (,,,) <$> stripPrefix a1 a2 <*> stripPrefix b1 b2 <*> stripPrefix c1 c2 <*> stripPrefix d1 d2 isPrefixOf (a1, b1, c1, d1) (a2, b2, c2, d2) = isPrefixOf a1 a2 && isPrefixOf b1 b2 && isPrefixOf c1 c2 && isPrefixOf d1 d2 instance (RightReductive a, RightReductive b, RightReductive c, RightReductive d) => RightReductive (a, b, c, d) where stripSuffix (a1, b1, c1, d1) (a2, b2, c2, d2) = (,,,) <$> stripSuffix a1 a2 <*> stripSuffix b1 b2 <*> stripSuffix c1 c2 <*> stripSuffix d1 d2 isSuffixOf (a1, b1, c1, d1) (a2, b2, c2, d2) = isSuffixOf a1 a2 && isSuffixOf b1 b2 && isSuffixOf c1 c2 && isSuffixOf d1 d2 instance (LeftCancellative a, LeftCancellative b, LeftCancellative c, LeftCancellative d) => LeftCancellative (a, b, c, d) instance (RightCancellative a, RightCancellative b, RightCancellative c, RightCancellative d) => RightCancellative (a, b, c, d) -- Maybe instances -- | @since 1.0 instance Reductive x => Reductive (Maybe x) where Just x Just y = Just <$> x y x Nothing = Just x Nothing _ = Nothing instance LeftReductive x => LeftReductive (Maybe x) where stripPrefix Nothing y = Just y stripPrefix Just{} Nothing = Nothing stripPrefix (Just x) (Just y) = fmap Just $ stripPrefix x y instance RightReductive x => RightReductive (Maybe x) where stripSuffix Nothing y = Just y stripSuffix Just{} Nothing = Nothing stripSuffix (Just x) (Just y) = fmap Just $ stripSuffix x y -- Set instances -- | /O(m*log(n/m + 1)), m <= n/ instance Ord a => LeftReductive (Set.Set a) where isPrefixOf = Set.isSubsetOf stripPrefix a b = b a -- | /O(m*log(n/m + 1)), m <= n/ instance Ord a => RightReductive (Set.Set a) where isSuffixOf = Set.isSubsetOf stripSuffix a b = b a -- | /O(m*log(n/m + 1)), m <= n/ instance Ord a => Reductive (Set.Set a) where a b | Set.isSubsetOf b a = Just (a Set.\\ b) | otherwise = Nothing -- IntSet instances -- | /O(m+n)/ instance LeftReductive IntSet.IntSet where isPrefixOf = IntSet.isSubsetOf stripPrefix a b = b a -- | /O(m+n)/ instance RightReductive IntSet.IntSet where isSuffixOf = IntSet.isSubsetOf stripSuffix a b = b a -- | /O(m+n)/ instance Reductive IntSet.IntSet where a b | IntSet.isSubsetOf b a = Just (a IntSet.\\ b) | otherwise = Nothing -- Map instances -- | /O(m+n)/ instance (Ord k, Eq a) => LeftReductive (Map.Map k a) where isPrefixOf = Map.isSubmapOf stripPrefix a b | Map.isSubmapOf a b = Just (b Map.\\ a) | otherwise = Nothing -- | /O(m+n)/ instance (Ord k, Eq a) => RightReductive (Map.Map k a) where isSuffixOf = Map.isSubmapOfBy (const $ const True) stripSuffix a b | a `isSuffixOf` b = Just (Map.differenceWith (\x y-> if x == y then Nothing else Just x) b a) | otherwise = Nothing -- IntMap instances -- | /O(m+n)/ instance Eq a => LeftReductive (IntMap.IntMap a) where isPrefixOf = IntMap.isSubmapOf stripPrefix a b | IntMap.isSubmapOf a b = Just (b IntMap.\\ a) | otherwise = Nothing -- | /O(m+n)/ instance Eq a => RightReductive (IntMap.IntMap a) where isSuffixOf = IntMap.isSubmapOfBy (const $ const True) stripSuffix a b | a `isSuffixOf` b = Just (IntMap.differenceWith (\x y-> if x == y then Nothing else Just x) b a) | otherwise = Nothing -- List instances -- | /O(prefixLength)/ instance Eq x => LeftReductive [x] where stripPrefix = List.stripPrefix isPrefixOf = List.isPrefixOf -- | @since 1.0 -- /O(m+n)/ instance Eq x => RightReductive [x] where isSuffixOf = List.isSuffixOf stripSuffix xs0 ys0 = go1 xs0 ys0 where go1 (_:xs) (_:ys) = go1 xs ys go1 [] ys = go2 id ys ys0 go1 _ [] = Nothing go2 fy (_:zs) (y:ys) = go2 (fy . (y:)) zs ys go2 fy [] ys | xs0 == ys = Just (fy []) | otherwise = Nothing go2 _ _ _ = error "impossible" instance Eq x => LeftCancellative [x] -- | @since 1.0 instance Eq x => RightCancellative [x] -- Seq instances -- | /O(log(min(m,n−m)) + prefixLength)/ instance Eq a => LeftReductive (Sequence.Seq a) where stripPrefix p s | p == s1 = Just s2 | otherwise = Nothing where (s1, s2) = Sequence.splitAt (Sequence.length p) s -- | /O(log(min(m,n−m)) + suffixLength)/ instance Eq a => RightReductive (Sequence.Seq a) where stripSuffix p s | p == s2 = Just s1 | otherwise = Nothing where (s1, s2) = Sequence.splitAt (Sequence.length s - Sequence.length p) s instance Eq a => LeftCancellative (Sequence.Seq a) instance Eq a => RightCancellative (Sequence.Seq a) -- Vector instances -- | /O(n)/ instance Eq a => LeftReductive (Vector.Vector a) where stripPrefix p l | prefixLength > Vector.length l = Nothing | otherwise = strip 0 where strip i | i == prefixLength = Just (Vector.drop prefixLength l) | l Vector.! i == p Vector.! i = strip (succ i) | otherwise = Nothing prefixLength = Vector.length p isPrefixOf p l | prefixLength > Vector.length l = False | otherwise = test 0 where test i | i == prefixLength = True | l Vector.! i == p Vector.! i = test (succ i) | otherwise = False prefixLength = Vector.length p -- | /O(n)/ instance Eq a => RightReductive (Vector.Vector a) where stripSuffix s l | suffixLength > Vector.length l = Nothing | otherwise = strip (pred suffixLength) where strip i | i == -1 = Just (Vector.take lengthDifference l) | l Vector.! (lengthDifference + i) == s Vector.! i = strip (pred i) | otherwise = Nothing suffixLength = Vector.length s lengthDifference = Vector.length l - suffixLength isSuffixOf s l | suffixLength > Vector.length l = False | otherwise = test (pred suffixLength) where test i | i == -1 = True | l Vector.! (lengthDifference + i) == s Vector.! i = test (pred i) | otherwise = False suffixLength = Vector.length s lengthDifference = Vector.length l - suffixLength instance Eq a => LeftCancellative (Vector.Vector a) instance Eq a => RightCancellative (Vector.Vector a) -- ByteString instances -- | /O(n)/ instance LeftReductive ByteString.ByteString where stripPrefix p l = if ByteString.isPrefixOf p l then Just (ByteString.unsafeDrop (ByteString.length p) l) else Nothing isPrefixOf = ByteString.isPrefixOf -- | /O(n)/ instance RightReductive ByteString.ByteString where stripSuffix s l = if ByteString.isSuffixOf s l then Just (ByteString.unsafeTake (ByteString.length l - ByteString.length s) l) else Nothing isSuffixOf = ByteString.isSuffixOf instance LeftCancellative ByteString.ByteString instance RightCancellative ByteString.ByteString -- Lazy ByteString instances -- | /O(n)/ instance LeftReductive LazyByteString.ByteString where stripPrefix p l = if LazyByteString.isPrefixOf p l then Just (LazyByteString.drop (LazyByteString.length p) l) else Nothing isPrefixOf = LazyByteString.isPrefixOf -- | /O(n)/ instance RightReductive LazyByteString.ByteString where stripSuffix s l = if LazyByteString.isSuffixOf s l then Just (LazyByteString.take (LazyByteString.length l - LazyByteString.length s) l) else Nothing isSuffixOf = LazyByteString.isSuffixOf instance LeftCancellative LazyByteString.ByteString instance RightCancellative LazyByteString.ByteString -- Text instances -- | /O(n)/ instance LeftReductive Text.Text where stripPrefix = Text.stripPrefix isPrefixOf = Text.isPrefixOf -- | /O(n)/ instance RightReductive Text.Text where stripSuffix = Text.stripSuffix isSuffixOf = Text.isSuffixOf instance LeftCancellative Text.Text instance RightCancellative Text.Text -- Lazy Text instances -- | /O(n)/ instance LeftReductive LazyText.Text where stripPrefix = LazyText.stripPrefix isPrefixOf = LazyText.isPrefixOf -- | /O(n)/ instance RightReductive LazyText.Text where stripSuffix = LazyText.stripSuffix isSuffixOf = LazyText.isSuffixOf instance LeftCancellative LazyText.Text instance RightCancellative LazyText.Text monoid-subclasses-1.2.4/src/Data/Semigroup/Factorial.hs0000644000000000000000000004361507346545000021224 0ustar0000000000000000{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'Semigroup' => 'Factorial' => 'StableFactorial' classes and some of their instances. -- {-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-} module Data.Semigroup.Factorial ( -- * Classes Factorial(..), StableFactorial, -- * Monad function equivalents mapM, mapM_ ) where import qualified Control.Monad as Monad import Data.Semigroup -- (Semigroup (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import qualified Data.Vector as Vector import Data.List.NonEmpty (nonEmpty) import Data.Numbers.Primes (primeFactors) import Numeric.Natural (Natural) import Data.Monoid.Null (MonoidNull(null)) import Prelude (Int, Maybe(..), Eq, Ord, Monoid, Applicative, Monad, Integral, (.), (-), (+), ($), (*>), (++), pure, return, mempty, mappend, mconcat, pred, id, seq, otherwise, uncurry, fromIntegral, not, fmap, max, abs, signum, replicate, maybe, succ, const) -- | Class of semigroups that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of -- a 'Product' are literally its prime factors: -- -- prop> factors (Product 12) == [Product 2, Product 2, Product 3] -- -- Factors of a list are /not/ its elements but all its single-item sublists: -- -- prop> factors "abc" == ["a", "b", "c"] -- -- The methods of this class satisfy the following laws: -- -- > maybe id sconcat . nonEmpty . factors == id -- > List.all (\prime-> factors prime == [prime]) . factors -- > primePrefix s == foldr const s s -- > foldl f a == List.foldl f a . factors -- > foldl' f a == List.foldl' f a . factors -- > foldr f a == List.foldr f a . factors -- -- A minimal instance definition must implement 'factors' or 'foldr'. Other methods can and should be implemented only -- for performance reasons. class Semigroup m => Factorial m where -- | Returns a list of all prime factors; inverse of mconcat. factors :: m -> [m] -- | The prime prefix; @primePrefix mempty == mempty@ for monoids. primePrefix :: m -> m -- | The prime suffix; @primeSuffix mempty == mempty@ for monoids. primeSuffix :: m -> m -- | Like 'List.foldl' from "Data.List" on the list of prime 'factors'. foldl :: (a -> m -> a) -> a -> m -> a -- | Like 'List.foldl'' from "Data.List" on the list of prime 'factors'. foldl' :: (a -> m -> a) -> a -> m -> a -- | Like 'List.foldr' from "Data.List" on the list of prime 'factors'. foldr :: (m -> a -> a) -> a -> m -> a -- | The 'length' of the list of prime 'factors'. length :: m -> Int -- | Generalizes 'Foldable.foldMap' from "Data.Foldable", except the function arguments are prime 'factors' rather -- than the structure elements. foldMap :: Monoid n => (m -> n) -> m -> n -- | Equivalent to 'List.reverse' from "Data.List". reverse :: m -> m factors = foldr (:) [] primePrefix s = foldr const s s primeSuffix s = foldl (const id) s s foldl f f0 = List.foldl f f0 . factors foldl' f f0 = List.foldl' f f0 . factors foldr f f0 = List.foldr f f0 . factors length = foldl' (const . succ) 0 foldMap f = foldr (mappend . f) mempty reverse s = maybe s sconcat (nonEmpty $ List.reverse $ factors s) {-# MINIMAL factors | foldr #-} {-# INLINABLE factors #-} {-# INLINE primePrefix #-} {-# INLINE primeSuffix #-} {-# INLINABLE foldl #-} {-# INLINABLE foldl' #-} {-# INLINABLE foldr #-} {-# INLINE length #-} {-# INLINE foldMap #-} {-# INLINE reverse #-} -- | A subclass of 'Factorial' whose instances satisfy the following additional laws: -- -- > factors (a <> b) == factors a <> factors b -- > factors . reverse == List.reverse . factors -- > primeSuffix s == primePrefix (reverse s) class Factorial m => StableFactorial m instance Factorial () where factors () = [] primePrefix () = () primeSuffix () = () length () = 0 reverse = id instance Factorial a => Factorial (Dual a) where factors (Dual a) = fmap Dual (reverse $ factors a) length (Dual a) = length a primePrefix (Dual a) = Dual (primeSuffix a) primeSuffix (Dual a) = Dual (primePrefix a) reverse (Dual a) = Dual (reverse a) instance (Integral a, Eq a) => Factorial (Sum a) where primePrefix (Sum a) = Sum (signum a ) primeSuffix = primePrefix factors (Sum n) = replicate (fromIntegral $ abs n) (Sum $ signum n) length (Sum a) = abs (fromIntegral a) reverse = id instance Integral a => Factorial (Product a) where factors (Product a) = List.map Product (primeFactors a) reverse = id instance Factorial a => Factorial (Maybe a) where factors Nothing = [] factors (Just a) = case factors a of [] -> [Just a] as -> List.map Just as length Nothing = 0 length (Just a) = max 1 (length a) reverse = fmap reverse instance (Factorial a, Factorial b, MonoidNull a, MonoidNull b) => Factorial (a, b) where factors (a, b) = List.map (\a1-> (a1, mempty)) (factors a) ++ List.map ((,) mempty) (factors b) primePrefix (a, b) | null a = (a, primePrefix b) | otherwise = (primePrefix a, mempty) primeSuffix (a, b) | null b = (primeSuffix a, b) | otherwise = (mempty, primeSuffix b) foldl f a0 (x, y) = foldl f2 (foldl f1 a0 x) y where f1 a = f a . fromFst f2 a = f a . fromSnd foldl' f a0 (x, y) = a' `seq` foldl' f2 a' y where f1 a = f a . fromFst f2 a = f a . fromSnd a' = foldl' f1 a0 x foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x foldMap f (x, y) = Data.Semigroup.Factorial.foldMap (f . fromFst) x `mappend` Data.Semigroup.Factorial.foldMap (f . fromSnd) y length (a, b) = length a + length b reverse (a, b) = (reverse a, reverse b) {-# INLINE fromFst #-} fromFst :: Monoid b => a -> (a, b) fromFst a = (a, mempty) {-# INLINE fromSnd #-} fromSnd :: Monoid a => b -> (a, b) fromSnd b = (mempty, b) instance (Factorial a, Factorial b, Factorial c, MonoidNull a, MonoidNull b, MonoidNull c) => Factorial (a, b, c) where factors (a, b, c) = List.map (\a1-> (a1, mempty, mempty)) (factors a) ++ List.map (\b1-> (mempty, b1, mempty)) (factors b) ++ List.map (\c1-> (mempty, mempty, c1)) (factors c) primePrefix (a, b, c) | not (null a) = (primePrefix a, mempty, mempty) | not (null b) = (mempty, primePrefix b, mempty) | otherwise = (mempty, mempty, primePrefix c) primeSuffix (a, b, c) | not (null c) = (mempty, mempty, primeSuffix c) | not (null b) = (mempty, primeSuffix b, mempty) | otherwise = (primeSuffix a, mempty, mempty) foldl f s0 (a, b, c) = foldl f3 (foldl f2 (foldl f1 s0 a) b) c where f1 x = f x . fromFstOf3 f2 x = f x . fromSndOf3 f3 x = f x . fromThdOf3 foldl' f s0 (a, b, c) = a' `seq` b' `seq` foldl' f3 b' c where f1 x = f x . fromFstOf3 f2 x = f x . fromSndOf3 f3 x = f x . fromThdOf3 a' = foldl' f1 s0 a b' = foldl' f2 a' b foldr f s (a, b, c) = foldr (f . fromFstOf3) (foldr (f . fromSndOf3) (foldr (f . fromThdOf3) s c) b) a foldMap f (a, b, c) = Data.Semigroup.Factorial.foldMap (f . fromFstOf3) a `mappend` Data.Semigroup.Factorial.foldMap (f . fromSndOf3) b `mappend` Data.Semigroup.Factorial.foldMap (f . fromThdOf3) c length (a, b, c) = length a + length b + length c reverse (a, b, c) = (reverse a, reverse b, reverse c) {-# INLINE fromFstOf3 #-} fromFstOf3 :: (Monoid b, Monoid c) => a -> (a, b, c) fromFstOf3 a = (a, mempty, mempty) {-# INLINE fromSndOf3 #-} fromSndOf3 :: (Monoid a, Monoid c) => b -> (a, b, c) fromSndOf3 b = (mempty, b, mempty) {-# INLINE fromThdOf3 #-} fromThdOf3 :: (Monoid a, Monoid b) => c -> (a, b, c) fromThdOf3 c = (mempty, mempty, c) instance (Factorial a, Factorial b, Factorial c, Factorial d, MonoidNull a, MonoidNull b, MonoidNull c, MonoidNull d) => Factorial (a, b, c, d) where factors (a, b, c, d) = List.map (\a1-> (a1, mempty, mempty, mempty)) (factors a) ++ List.map (\b1-> (mempty, b1, mempty, mempty)) (factors b) ++ List.map (\c1-> (mempty, mempty, c1, mempty)) (factors c) ++ List.map (\d1-> (mempty, mempty, mempty, d1)) (factors d) primePrefix (a, b, c, d) | not (null a) = (primePrefix a, mempty, mempty, mempty) | not (null b) = (mempty, primePrefix b, mempty, mempty) | not (null c) = (mempty, mempty, primePrefix c, mempty) | otherwise = (mempty, mempty, mempty, primePrefix d) primeSuffix (a, b, c, d) | not (null d) = (mempty, mempty, mempty, primeSuffix d) | not (null c) = (mempty, mempty, primeSuffix c, mempty) | not (null b) = (mempty, primeSuffix b, mempty, mempty) | otherwise = (primeSuffix a, mempty, mempty, mempty) foldl f s0 (a, b, c, d) = foldl f4 (foldl f3 (foldl f2 (foldl f1 s0 a) b) c) d where f1 x = f x . fromFstOf4 f2 x = f x . fromSndOf4 f3 x = f x . fromThdOf4 f4 x = f x . fromFthOf4 foldl' f s0 (a, b, c, d) = a' `seq` b' `seq` c' `seq` foldl' f4 c' d where f1 x = f x . fromFstOf4 f2 x = f x . fromSndOf4 f3 x = f x . fromThdOf4 f4 x = f x . fromFthOf4 a' = foldl' f1 s0 a b' = foldl' f2 a' b c' = foldl' f3 b' c foldr f s (a, b, c, d) = foldr (f . fromFstOf4) (foldr (f . fromSndOf4) (foldr (f . fromThdOf4) (foldr (f . fromFthOf4) s d) c) b) a foldMap f (a, b, c, d) = Data.Semigroup.Factorial.foldMap (f . fromFstOf4) a `mappend` Data.Semigroup.Factorial.foldMap (f . fromSndOf4) b `mappend` Data.Semigroup.Factorial.foldMap (f . fromThdOf4) c `mappend` Data.Semigroup.Factorial.foldMap (f . fromFthOf4) d length (a, b, c, d) = length a + length b + length c + length d reverse (a, b, c, d) = (reverse a, reverse b, reverse c, reverse d) {-# INLINE fromFstOf4 #-} fromFstOf4 :: (Monoid b, Monoid c, Monoid d) => a -> (a, b, c, d) fromFstOf4 a = (a, mempty, mempty, mempty) {-# INLINE fromSndOf4 #-} fromSndOf4 :: (Monoid a, Monoid c, Monoid d) => b -> (a, b, c, d) fromSndOf4 b = (mempty, b, mempty, mempty) {-# INLINE fromThdOf4 #-} fromThdOf4 :: (Monoid a, Monoid b, Monoid d) => c -> (a, b, c, d) fromThdOf4 c = (mempty, mempty, c, mempty) {-# INLINE fromFthOf4 #-} fromFthOf4 :: (Monoid a, Monoid b, Monoid c) => d -> (a, b, c, d) fromFthOf4 d = (mempty, mempty, mempty, d) instance Factorial [x] where factors xs = List.map (:[]) xs primePrefix [] = [] primePrefix (x:_) = [x] primeSuffix [] = [] primeSuffix xs = [List.last xs] foldl _ a [] = a foldl f a (x:xs) = foldl f (f a [x]) xs foldl' _ a [] = a foldl' f a (x:xs) = let a' = f a [x] in a' `seq` foldl' f a' xs foldr _ f0 [] = f0 foldr f f0 (x:xs) = f [x] (foldr f f0 xs) length = List.length foldMap f = mconcat . List.map (f . (:[])) reverse = List.reverse instance Factorial ByteString.ByteString where factors x = factorize (ByteString.length x) x where factorize 0 _ = [] factorize n xs = xs1 : factorize (pred n) xs' where (xs1, xs') = ByteString.splitAt 1 xs primePrefix = ByteString.take 1 primeSuffix x = ByteString.drop (ByteString.length x - 1) x foldl f = ByteString.foldl f' where f' a byte = f a (ByteString.singleton byte) foldl' f = ByteString.foldl' f' where f' a byte = f a (ByteString.singleton byte) foldr f = ByteString.foldr (f . ByteString.singleton) length = ByteString.length reverse = ByteString.reverse instance Factorial LazyByteString.ByteString where factors x = factorize (LazyByteString.length x) x where factorize 0 _ = [] factorize n xs = xs1 : factorize (pred n) xs' where (xs1, xs') = LazyByteString.splitAt 1 xs primePrefix = LazyByteString.take 1 primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x length = fromIntegral . LazyByteString.length reverse = LazyByteString.reverse instance Factorial Text.Text where factors = Text.chunksOf 1 primePrefix = Text.take 1 primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x) foldl f = Text.foldl f' where f' a char = f a (Text.singleton char) foldl' f = Text.foldl' f' where f' a char = f a (Text.singleton char) foldr f = Text.foldr f' where f' char a = f (Text.singleton char) a length = Text.length reverse = Text.reverse instance Factorial LazyText.Text where factors = LazyText.chunksOf 1 primePrefix = LazyText.take 1 primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x) foldl f = LazyText.foldl f' where f' a char = f a (LazyText.singleton char) foldl' f = LazyText.foldl' f' where f' a char = f a (LazyText.singleton char) foldr f = LazyText.foldr f' where f' char a = f (LazyText.singleton char) a length = fromIntegral . LazyText.length reverse = LazyText.reverse instance Ord k => Factorial (Map.Map k v) where factors = List.map (uncurry Map.singleton) . Map.toAscList primePrefix map | Map.null map = map | otherwise = uncurry Map.singleton $ Map.findMin map primeSuffix map | Map.null map = map | otherwise = uncurry Map.singleton $ Map.findMax map foldl f = Map.foldlWithKey f' where f' a k v = f a (Map.singleton k v) foldl' f = Map.foldlWithKey' f' where f' a k v = f a (Map.singleton k v) foldr f = Map.foldrWithKey f' where f' k v a = f (Map.singleton k v) a length = Map.size reverse = id instance Factorial (IntMap.IntMap a) where factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList primePrefix map | IntMap.null map = map | otherwise = uncurry IntMap.singleton $ IntMap.findMin map primeSuffix map | IntMap.null map = map | otherwise = uncurry IntMap.singleton $ IntMap.findMax map foldl f = IntMap.foldlWithKey f' where f' a k v = f a (IntMap.singleton k v) foldl' f = IntMap.foldlWithKey' f' where f' a k v = f a (IntMap.singleton k v) foldr f = IntMap.foldrWithKey f' where f' k v a = f (IntMap.singleton k v) a length = IntMap.size reverse = id instance Factorial IntSet.IntSet where factors = List.map IntSet.singleton . IntSet.toAscList primePrefix set | IntSet.null set = set | otherwise = IntSet.singleton $ IntSet.findMin set primeSuffix set | IntSet.null set = set | otherwise = IntSet.singleton $ IntSet.findMax set foldl f = IntSet.foldl f' where f' a b = f a (IntSet.singleton b) foldl' f = IntSet.foldl' f' where f' a b = f a (IntSet.singleton b) foldr f = IntSet.foldr f' where f' a b = f (IntSet.singleton a) b length = IntSet.size reverse = id instance Factorial (Sequence.Seq a) where factors = List.map Sequence.singleton . Foldable.toList primePrefix = Sequence.take 1 primeSuffix q = Sequence.drop (Sequence.length q - 1) q foldl f = Foldable.foldl f' where f' a b = f a (Sequence.singleton b) foldl' f = Foldable.foldl' f' where f' a b = f a (Sequence.singleton b) foldr f = Foldable.foldr f' where f' a b = f (Sequence.singleton a) b length = Sequence.length reverse = Sequence.reverse instance Ord a => Factorial (Set.Set a) where factors = List.map Set.singleton . Set.toAscList primePrefix set | Set.null set = set | otherwise = Set.singleton $ Set.findMin set primeSuffix set | Set.null set = set | otherwise = Set.singleton $ Set.findMax set foldl f = Foldable.foldl f' where f' a b = f a (Set.singleton b) foldl' f = Foldable.foldl' f' where f' a b = f a (Set.singleton b) foldr f = Foldable.foldr f' where f' a b = f (Set.singleton a) b length = Set.size reverse = id instance Factorial (Vector.Vector a) where factors x = factorize (Vector.length x) x where factorize 0 _ = [] factorize n xs = xs1 : factorize (pred n) xs' where (xs1, xs') = Vector.splitAt 1 xs primePrefix = Vector.take 1 primeSuffix x = Vector.drop (Vector.length x - 1) x foldl f = Vector.foldl f' where f' a byte = f a (Vector.singleton byte) foldl' f = Vector.foldl' f' where f' a byte = f a (Vector.singleton byte) foldr f = Vector.foldr f' where f' byte a = f (Vector.singleton byte) a length = Vector.length reverse = Vector.reverse instance StableFactorial () instance StableFactorial a => StableFactorial (Dual a) instance StableFactorial [x] instance StableFactorial ByteString.ByteString instance StableFactorial LazyByteString.ByteString instance StableFactorial Text.Text instance StableFactorial LazyText.Text instance StableFactorial (Sequence.Seq a) instance StableFactorial (Vector.Vector a) instance StableFactorial (Sum Natural) -- | A 'Monad.mapM' equivalent. mapM :: (Factorial a, Semigroup b, Monoid b, Monad m) => (a -> m b) -> a -> m b mapM f = ($ return mempty) . appEndo . Data.Semigroup.Factorial.foldMap (Endo . Monad.liftM2 mappend . f) -- | A 'Monad.mapM_' equivalent. mapM_ :: (Factorial a, Applicative m) => (a -> m b) -> a -> m () mapM_ f = foldr ((*>) . f) (pure ())