monoid-subclasses-0.3.5/0000755000000000000000000000000012251733717013347 5ustar0000000000000000monoid-subclasses-0.3.5/monoid-subclasses.cabal0000644000000000000000000000412112251733717017763 0ustar0000000000000000Name: monoid-subclasses Version: 0.3.5 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid Category: Data, Algebra, Text Tested-with: GHC Description: A hierarchy of subclasses of 'Monoid' together with their instances for all data structures from base, containers, and text packages. License: BSD3 License-file: BSD3-LICENSE.txt Copyright: (c) 2013 Mario Blazevic Author: Mario Blazevic Maintainer: Mario Blazevic Homepage: https://github.com/blamario/monoid-subclasses/ Bug-reports: https://github.com/blamario/monoid-subclasses/issues Source-repository head type: git location: https://github.com/blamario/monoid-subclasses Library Exposed-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual, Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat, Data.Monoid.Instances.Measured, Data.Monoid.Instances.Stateful Build-Depends: base < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text >= 0.11 && < 1.1, primes == 0.2.*, vector >= 0.9 && < 0.11 GHC-prof-options: -auto-all if impl(ghc >= 7.0.0) default-language: Haskell2010 test-suite Main Type: exitcode-stdio-1.0 x-uses-tf: true Build-Depends: base < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text >= 0.11 && < 1.1, primes == 0.2.*, vector >= 0.9 && < 0.11, QuickCheck == 2.*, quickcheck-instances == 0.3.*, test-framework >= 0.4.1, test-framework-quickcheck2 Main-is: Test/TestMonoidSubclasses.hs Other-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual, Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat, Data.Monoid.Instances.Measured, Data.Monoid.Instances.Stateful default-language: Haskell2010 monoid-subclasses-0.3.5/Setup.lhs0000644000000000000000000000011712251733717015156 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain monoid-subclasses-0.3.5/BSD3-LICENSE.txt0000644000000000000000000000272112251733717015665 0ustar0000000000000000Copyright (c) 2012-2013, Mario Blazevic All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of {{the ORGANIZATION nor the names of its contributors}} may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY {{THE COPYRIGHT HOLDERS AND CONTRIBUTORS}} "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL {{THE COPYRIGHT HOLDER OR CONTRIBUTORS}} BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. monoid-subclasses-0.3.5/Test/0000755000000000000000000000000012251733717014266 5ustar0000000000000000monoid-subclasses-0.3.5/Test/TestMonoidSubclasses.hs0000644000000000000000000012257412251733717020752 0ustar0000000000000000{- Copyright 2013 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} {-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} module Main where import Prelude hiding (foldl, foldr, gcd, length, null, reverse, span, splitAt, takeWhile) import Test.QuickCheck (Arbitrary, CoArbitrary, Property, Gen, quickCheck, arbitrary, coarbitrary, property, label, forAll, variant, whenFail, (.&&.)) import Test.QuickCheck.Instances () import Control.Applicative (Applicative(..), liftA2) import Data.Functor ((<$>)) import Data.Foldable (toList) import Data.Int (Int8, Int32) import qualified Data.Foldable as Foldable import Data.Traversable (Traversable) import Data.List (intersperse, unfoldr) import qualified Data.List as List import Data.Maybe (isJust) import Data.Either (lefts, rights) import Data.Tuple (swap) import Data.String (IsString, fromString) import Data.Char (isLetter) import Data.Int (Int16) import Data.Word (Word, Word8) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as Lazy (ByteString) import Data.Text (Text) import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.Text as Text import qualified Data.Sequence as Sequence import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Map (Map) import Data.Sequence (Seq) import Data.Set (Set) import Data.Vector (Vector, fromList) import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(ByteStringUTF8)) import Data.Monoid.Instances.Concat (Concat) import qualified Data.Monoid.Instances.Concat as Concat import Data.Monoid.Instances.Measured (Measured) import qualified Data.Monoid.Instances.Measured as Measured import Data.Monoid.Instances.Stateful (Stateful) import qualified Data.Monoid.Instances.Stateful as Stateful import Data.Monoid (Monoid, mempty, (<>), mconcat, All(All), Any(Any), Dual(Dual), First(First), Last(Last), Sum(Sum), Product(Product)) import Data.Monoid.Null (MonoidNull, PositiveMonoid, null) import Data.Monoid.Factorial (FactorialMonoid, StableFactorialMonoid, factors, splitPrimePrefix, splitPrimeSuffix, primePrefix, primeSuffix, foldl, foldl', foldr, length, reverse, span, split, splitAt) import Data.Monoid.Cancellative (CommutativeMonoid, ReductiveMonoid, LeftReductiveMonoid, RightReductiveMonoid, CancellativeMonoid, LeftCancellativeMonoid, RightCancellativeMonoid, GCDMonoid, LeftGCDMonoid, RightGCDMonoid, (), gcd, isPrefixOf, stripPrefix, commonPrefix, stripCommonPrefix, isSuffixOf, stripSuffix, commonSuffix, stripCommonSuffix) import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Textual as Textual data Test = CommutativeTest (CommutativeMonoidInstance -> Property) | NullTest (NullMonoidInstance -> Property) | PositiveTest (PositiveMonoidInstance -> Property) | FactorialTest (FactorialMonoidInstance -> Property) | StableFactorialTest (StableFactorialMonoidInstance -> Property) | TextualTest (TextualMonoidInstance -> Property) | LeftReductiveTest (LeftReductiveMonoidInstance -> Property) | RightReductiveTest (RightReductiveMonoidInstance -> Property) | ReductiveTest (ReductiveMonoidInstance -> Property) | LeftCancellativeTest (LeftCancellativeMonoidInstance -> Property) | RightCancellativeTest (RightCancellativeMonoidInstance -> Property) | CancellativeTest (CancellativeMonoidInstance -> Property) | LeftGCDTest (LeftGCDMonoidInstance -> Property) | RightGCDTest (RightGCDMonoidInstance -> Property) | GCDTest (GCDMonoidInstance -> Property) | CancellativeGCDTest (CancellativeGCDMonoidInstance -> Property) data CommutativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CommutativeMonoid a) => CommutativeMonoidInstance a data NullMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => NullMonoidInstance a data PositiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, PositiveMonoid a) => PositiveMonoidInstance a data FactorialMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => FactorialMonoidInstance a data StableFactorialMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, StableFactorialMonoid a) => StableFactorialMonoidInstance a data TextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => TextualMonoidInstance a data StableTextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, StableFactorialMonoid a, TextualMonoid a) => StableTextualMonoidInstance a data LeftReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => LeftReductiveMonoidInstance a data RightReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightReductiveMonoid a) => RightReductiveMonoidInstance a data ReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, ReductiveMonoid a) => ReductiveMonoidInstance a data LeftCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftCancellativeMonoid a) => LeftCancellativeMonoidInstance a data RightCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightCancellativeMonoid a) => RightCancellativeMonoidInstance a data CancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a) => CancellativeMonoidInstance a data LeftGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) => LeftGCDMonoidInstance a data RightGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightGCDMonoid a) => RightGCDMonoidInstance a data GCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, GCDMonoid a) => GCDMonoidInstance a data CancellativeGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a, GCDMonoid a) => CancellativeGCDMonoidInstance a commutativeInstances :: [CommutativeMonoidInstance] commutativeInstances = map upcast reductiveInstances ++ [CommutativeMonoidInstance (mempty :: Product Double)] where upcast (ReductiveMonoidInstance i) = CommutativeMonoidInstance i nullInstances :: [NullMonoidInstance] nullInstances = map upcast factorialInstances ++ [NullMonoidInstance (mempty :: Ordering), NullMonoidInstance (mempty :: All), NullMonoidInstance (mempty :: Any), NullMonoidInstance (mempty :: Sum Float), NullMonoidInstance (mempty :: Product Int), NullMonoidInstance (mempty :: First Int), NullMonoidInstance (mempty :: Last Int), NullMonoidInstance (mempty :: Concat Any), NullMonoidInstance (mempty :: Concat (Dual String)), NullMonoidInstance (mempty :: Concat (Map String Int))] where upcast (FactorialMonoidInstance i) = NullMonoidInstance i positiveInstances = map upcast stableFactorialInstances ++ [PositiveMonoidInstance (mempty :: ()), PositiveMonoidInstance (mempty :: Ordering), PositiveMonoidInstance (mempty :: All), PositiveMonoidInstance (mempty :: Any), PositiveMonoidInstance (mempty :: (Maybe (Sum Int))), 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 Int8), FactorialMonoidInstance (mempty :: Product Int32), FactorialMonoidInstance (mempty :: Maybe String), FactorialMonoidInstance (mempty :: (Text, 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 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.inject i) textualInstances :: [TextualMonoidInstance] textualInstances = map upcast stableTextualInstances ++ [TextualMonoidInstance (mempty :: ByteStringUTF8), TextualMonoidInstance (mempty :: Text), TextualMonoidInstance (mempty :: Lazy.Text), TextualMonoidInstance (mempty :: Seq Char), TextualMonoidInstance (mempty :: Vector Char), TextualMonoidInstance (mempty :: Stateful (IntMap Int) Text)] where upcast (StableTextualMonoidInstance i) = TextualMonoidInstance i stableTextualInstances :: [StableTextualMonoidInstance] stableTextualInstances = [StableTextualMonoidInstance (mempty :: TestString), StableTextualMonoidInstance (mempty :: String), StableTextualMonoidInstance (mempty :: Text), StableTextualMonoidInstance (mempty :: Lazy.Text), StableTextualMonoidInstance (mempty :: Seq Char), StableTextualMonoidInstance (mempty :: Vector Char)] leftReductiveInstances = map upcast leftCancellativeInstances ++ [LeftReductiveMonoidInstance (mempty :: Sum Integer), LeftReductiveMonoidInstance (mempty :: IntSet), LeftReductiveMonoidInstance (mempty :: Set Integer), LeftReductiveMonoidInstance (mempty :: Concat String), LeftReductiveMonoidInstance (mempty :: Concat ByteString), LeftReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), LeftReductiveMonoidInstance (mempty :: Concat Text), LeftReductiveMonoidInstance (mempty :: Concat Lazy.Text), LeftReductiveMonoidInstance (mempty :: Concat (Dual Text))] where upcast (LeftCancellativeMonoidInstance i) = LeftReductiveMonoidInstance i rightReductiveInstances = map upcast rightCancellativeInstances ++ [RightReductiveMonoidInstance (mempty :: Product Integer), RightReductiveMonoidInstance (mempty :: IntSet), RightReductiveMonoidInstance (mempty :: Set String), RightReductiveMonoidInstance (mempty :: Concat ByteString), RightReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), RightReductiveMonoidInstance (mempty :: Concat Text), RightReductiveMonoidInstance (mempty :: Concat Lazy.Text), RightReductiveMonoidInstance (mempty :: Concat (Dual Text))] where upcast (RightCancellativeMonoidInstance i) = RightReductiveMonoidInstance i reductiveInstances = map upcast cancellativeInstances ++ [ReductiveMonoidInstance (mempty :: Product Integer), ReductiveMonoidInstance (mempty :: IntSet), ReductiveMonoidInstance (mempty :: Set Integer)] where upcast (CancellativeMonoidInstance i) = ReductiveMonoidInstance i leftCancellativeInstances = map upcast cancellativeInstances ++ [LeftCancellativeMonoidInstance (mempty :: String), LeftCancellativeMonoidInstance (mempty :: ByteString), LeftCancellativeMonoidInstance (mempty :: Lazy.ByteString), LeftCancellativeMonoidInstance (mempty :: Text), LeftCancellativeMonoidInstance (mempty :: Lazy.Text), LeftCancellativeMonoidInstance (mempty :: Dual Text), LeftCancellativeMonoidInstance (mempty :: (Text, String)), LeftCancellativeMonoidInstance (mempty :: Seq Int), LeftCancellativeMonoidInstance (mempty :: Vector Int)] where upcast (CancellativeMonoidInstance i) = LeftCancellativeMonoidInstance i rightCancellativeInstances = map upcast cancellativeInstances ++ [RightCancellativeMonoidInstance (mempty :: ByteString), RightCancellativeMonoidInstance (mempty :: Lazy.ByteString), RightCancellativeMonoidInstance (mempty :: Text), RightCancellativeMonoidInstance (mempty :: Lazy.Text), RightCancellativeMonoidInstance (mempty :: Dual String), RightCancellativeMonoidInstance (mempty :: (Text, ByteString)), RightCancellativeMonoidInstance (mempty :: Seq Int), RightCancellativeMonoidInstance (mempty :: Vector Int)] where upcast (CancellativeMonoidInstance i) = RightCancellativeMonoidInstance i cancellativeInstances = map upcast cancellativeGCDInstances ++ [] where upcast (CancellativeGCDMonoidInstance i) = CancellativeMonoidInstance i leftGCDInstances = map upcast gcdInstances ++ [LeftGCDMonoidInstance (mempty :: String), LeftGCDMonoidInstance (mempty :: ByteString), LeftGCDMonoidInstance (mempty :: Lazy.ByteString), LeftGCDMonoidInstance (mempty :: Text), LeftGCDMonoidInstance (mempty :: Lazy.Text), LeftGCDMonoidInstance (mempty :: Dual ByteString), LeftGCDMonoidInstance (mempty :: (Text, String)), LeftGCDMonoidInstance (mempty :: IntMap Int), LeftGCDMonoidInstance (mempty :: Map String Int), LeftGCDMonoidInstance (mempty :: Seq Int), LeftGCDMonoidInstance (mempty :: Vector Int), LeftGCDMonoidInstance (mempty :: Concat String), LeftGCDMonoidInstance (mempty :: Concat ByteString), LeftGCDMonoidInstance (mempty :: Concat Lazy.ByteString), LeftGCDMonoidInstance (mempty :: Concat Text), LeftGCDMonoidInstance (mempty :: Concat Lazy.Text), LeftGCDMonoidInstance (mempty :: Concat (Dual ByteString))] where upcast (GCDMonoidInstance i) = LeftGCDMonoidInstance i rightGCDInstances = map upcast gcdInstances ++ [RightGCDMonoidInstance (mempty :: ByteString), RightGCDMonoidInstance (mempty :: Lazy.ByteString), RightGCDMonoidInstance (mempty :: Dual String), RightGCDMonoidInstance (mempty :: (Seq Int, ByteString)), RightGCDMonoidInstance (mempty :: Seq Int), RightGCDMonoidInstance (mempty :: Vector Int), RightGCDMonoidInstance (mempty :: Concat ByteString), RightGCDMonoidInstance (mempty :: Concat Lazy.ByteString), RightGCDMonoidInstance (mempty :: Concat (Dual Text))] where upcast (GCDMonoidInstance i) = RightGCDMonoidInstance i gcdInstances = map upcast cancellativeGCDInstances ++ [GCDMonoidInstance (mempty :: Product Integer), GCDMonoidInstance (mempty :: Dual (Product Integer)), GCDMonoidInstance (mempty :: IntSet), GCDMonoidInstance (mempty :: Set String)] where upcast (CancellativeGCDMonoidInstance i) = GCDMonoidInstance i cancellativeGCDInstances = [CancellativeGCDMonoidInstance (), CancellativeGCDMonoidInstance (mempty :: Sum Integer), CancellativeGCDMonoidInstance (mempty :: Dual (Sum Integer)), CancellativeGCDMonoidInstance (mempty :: (Sum Integer, Sum Int))] main = mapM_ (quickCheck . uncurry checkInstances) tests checkInstances :: String -> Test -> Property checkInstances name (CommutativeTest checkType) = label name $ foldr1 (.&&.) (map checkType commutativeInstances) checkInstances name (NullTest checkType) = label name $ foldr1 (.&&.) (map checkType nullInstances) checkInstances name (PositiveTest checkType) = label name $ foldr1 (.&&.) (map checkType positiveInstances) checkInstances name (FactorialTest checkType) = label name $ foldr1 (.&&.) (map checkType factorialInstances) checkInstances name (StableFactorialTest checkType) = label name $ foldr1 (.&&.) (map checkType stableFactorialInstances) checkInstances name (TextualTest checkType) = label name $ foldr1 (.&&.) (map checkType textualInstances) checkInstances name (LeftReductiveTest checkType) = label name $ foldr1 (.&&.) (map checkType leftReductiveInstances) checkInstances name (RightReductiveTest checkType) = label name $ foldr1 (.&&.) (map checkType rightReductiveInstances) checkInstances name (ReductiveTest checkType) = label name $ foldr1 (.&&.) (map checkType reductiveInstances) checkInstances name (LeftCancellativeTest checkType) = label name $ foldr1 (.&&.) (map checkType leftCancellativeInstances) checkInstances name (RightCancellativeTest checkType) = label name $ foldr1 (.&&.) (map checkType rightCancellativeInstances) checkInstances name (CancellativeTest checkType) = label name $ foldr1 (.&&.) (map checkType cancellativeInstances) checkInstances name (LeftGCDTest checkType) = label name $ foldr1 (.&&.) (map checkType leftGCDInstances) checkInstances name (RightGCDTest checkType) = label name $ foldr1 (.&&.) (map checkType rightGCDInstances) checkInstances name (GCDTest checkType) = label name $ foldr1 (.&&.) (map checkType gcdInstances) checkInstances name (CancellativeGCDTest checkType) = label name $ foldr1 (.&&.) (map checkType cancellativeGCDInstances) tests :: [(String, Test)] tests = [("CommutativeMonoid", CommutativeTest checkCommutative), ("MonoidNull", NullTest checkNull), ("PositiveMonoid", PositiveTest checkPositive), ("mconcat . factors == id", FactorialTest checkConcatFactors), ("all factors . factors", FactorialTest checkFactorsOfFactors), ("splitPrimePrefix", FactorialTest checkSplitPrimePrefix), ("splitPrimeSuffix", FactorialTest checkSplitPrimeSuffix), ("primePrefix", FactorialTest checkPrimePrefix), ("primeSuffix", FactorialTest checkPrimeSuffix), ("foldl", FactorialTest checkLeftFold), ("foldl'", FactorialTest checkLeftFold'), ("foldr", FactorialTest checkRightFold), ("length", FactorialTest checkLength), ("span", FactorialTest checkSpan), ("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.mapAccumL", TextualTest checkTextualMapAccumL), ("Textual.mapAccumR", TextualTest checkTextualMapAccumR), ("Textual.takeWhile", TextualTest checkTextualTakeWhile), ("Textual.dropWhile", TextualTest checkTextualDropWhile), ("Textual.span", TextualTest checkTextualSpan), ("Textual.break", TextualTest checkTextualBreak), ("Textual.split", TextualTest checkTextualSplit), ("Textual.find", TextualTest checkTextualFind), ("stripPrefix", LeftReductiveTest checkStripPrefix), ("isPrefixOf", LeftReductiveTest checkIsPrefixOf), ("stripSuffix", RightReductiveTest checkStripSuffix), ("isSuffixOf", RightReductiveTest checkIsSuffixOf), ("", ReductiveTest checkUnAppend), ("cancellative stripPrefix", LeftCancellativeTest checkStripPrefix'), ("cancellative stripSuffix", RightCancellativeTest checkStripSuffix'), ("cancellative ", CancellativeTest checkUnAppend'), ("stripCommonPrefix 1", LeftGCDTest checkStripCommonPrefix1), ("stripCommonPrefix 2", LeftGCDTest checkStripCommonPrefix2), ("stripCommonSuffix 1", RightGCDTest checkStripCommonSuffix1), ("stripCommonSuffix 2", RightGCDTest checkStripCommonSuffix2), ("gcd", GCDTest checkGCD), ("cancellative gcd", CancellativeGCDTest checkCancellativeGCD) ] checkCommutative (CommutativeMonoidInstance (e :: a)) = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> a <> b == b <> a) checkNull (NullMonoidInstance (e :: a)) = null e .&&. forAll (arbitrary :: Gen a) (\a-> null a == (a == mempty)) checkPositive (PositiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> null a && null b || not (null (a <> b))) checkConcatFactors (FactorialMonoidInstance (e :: a)) = null (factors e) .&&. forAll (arbitrary :: Gen a) check where check a = mconcat (factors a) == a checkFactorsOfFactors (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (all singleton . factors) where singleton prime = factors prime == [prime] checkSplitPrimePrefix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> factors a == unfoldr splitPrimePrefix a) checkSplitPrimeSuffix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = factors a == reverse (unfoldr (fmap swap . splitPrimeSuffix) a) checkPrimePrefix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> primePrefix a == maybe mempty fst (splitPrimePrefix a)) checkPrimeSuffix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> primeSuffix a == maybe mempty snd (splitPrimeSuffix a)) 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) checkSplit (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = property (\pred-> all (all (not . pred) . factors) (split pred a)) .&&. property (\prime-> mconcat (intersperse prime $ split (== prime) a) == a) checkSplitAt (FactorialMonoidInstance (_ :: a)) = property $ \i-> forAll (arbitrary :: Gen a) (check i) where check i a = splitAt i a == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors a) checkReverse (FactorialMonoidInstance (_ :: a)) = property $ forAll (arbitrary :: Gen a) (\a-> reverse a == mconcat (List.reverse $ factors a)) checkStability (StableFactorialMonoidInstance (_ :: a)) = property $ forAll (arbitrary :: Gen (a, a)) (\(a, b)-> factors (a <> b) == factors a <> factors b) checkFromText (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen Text) (\t-> Textual.fromText t == (fromString (Text.unpack t) :: a)) checkSingleton (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen Char) (\c-> Textual.singleton c == (fromString [c] :: a)) checkSplitCharacterPrefix (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen String) check1 .&&. forAll (arbitrary :: Gen a) check2 where check1 s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s check2 t = Textual.splitCharacterPrefix (primePrefix t) == fmap (\(c, t)-> (c, mempty)) (Textual.splitCharacterPrefix t) checkCharacterPrefix (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check t = Textual.characterPrefix t == fmap fst (Textual.splitCharacterPrefix t) checkTextualFactors (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = all (maybe True (null . snd) . Textual.splitCharacterPrefix) (factors a) checkUnfoldrToFactors (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = factors a == unfoldr splitPrimePrefix a checkFactorsFromString (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen String) check where check s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s checkTextualMap (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.map succ a == Textual.concatMap (Textual.singleton . succ) a && Textual.map id a == a check2 s = Textual.map succ (fromString s :: a) == fromString (List.map succ s) checkConcatMap (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.concatMap (fromString . f) a == mconcat (map apply $ factors a) && Textual.concatMap Textual.singleton a == a check2 s = Textual.concatMap (fromString . f) (fromString s :: a) == fromString (List.concatMap f s) f = replicate 3 apply prime = maybe prime (fromString . f) (Textual.characterPrefix prime) checkAll (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.all isLetter a == Textual.foldr (const id) ((&&) . isLetter) True a checkAny (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.any isLetter a == Textual.foldr (const id) ((||) . isLetter) False a checkTextualFoldl (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl (\l a-> Left a : l) (\l c-> Right c : l) [] a == List.reverse (textualFactors a) && Textual.foldl (<>) (\a-> (a <>) . Textual.singleton) mempty a == a check2 s = Textual.foldl undefined (flip (:)) [] s == List.foldl (flip (:)) [] s checkTextualFoldr (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldr (\a l-> Left a : l) (\c l-> Right c : l) [] a == textualFactors a && Textual.foldr (<>) ((<>) . Textual.singleton) mempty a == a check2 s = Textual.foldr undefined (:) [] s == 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 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 checkTextualMapAccumL (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumL (,)) ((), a) == ((), a) check2 s = Textual.mapAccumL f c (fromString s :: a) == fmap fromString (List.mapAccumL f c s) c = 0 :: Int f n c = if isLetter c then (succ n, succ c) else (2*n, c) checkTextualMapAccumR (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumR (,)) ((), a) == ((), a) check2 s = Textual.mapAccumR f c (fromString s :: a) == fmap fromString (List.mapAccumR f c s) c = 0 :: Int f n c = if isLetter c then (succ n, succ c) else (2*n, c) checkTextualTakeWhile (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.takeWhile (const True) isLetter a) == List.takeWhile (either (const True) isLetter) (textualFactors a) && Textual.takeWhile (const True) (const True) a == a check2 s = Textual.takeWhile undefined isLetter (fromString s :: a) == fromString (List.takeWhile isLetter s) checkTextualDropWhile (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.dropWhile (const True) isLetter a) == List.dropWhile (either (const True) isLetter) (textualFactors a) && Textual.dropWhile (const False) (const False) a == a check2 s = Textual.dropWhile undefined isLetter (fromString s :: a) == fromString (List.dropWhile isLetter s) checkTextualSpan (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.span pt pc a == (Textual.takeWhile pt pc a, Textual.dropWhile pt pc a) where pt = (== primePrefix a) pc = isLetter checkTextualBreak (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.break pt pc a == Textual.span (not . pt) (not . pc) a where pt = (/= primePrefix a) pc = isLetter checkTextualSplit (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = List.all (List.all isLetter . rights . textualFactors) (Textual.split (not . isLetter) a) && (mconcat . intersperse (fromString " ") . Textual.split (== ' ')) a == a checkTextualFind (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.find isLetter a == (List.find isLetter . rights . textualFactors) a check2 s = Textual.find isLetter (fromString s :: a) == List.find isLetter s checkStripPrefix (LeftReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = maybe b (a <>) (stripPrefix a b) == b checkIsPrefixOf (LeftReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = isPrefixOf a b == isJust (stripPrefix a b) && a `isPrefixOf` (a <> b) checkStripSuffix (RightReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = maybe b (<> a) (stripSuffix a b) == b checkIsSuffixOf (RightReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = isSuffixOf a b == isJust (stripSuffix a b) && b `isSuffixOf` (a <> b) checkUnAppend (ReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = maybe a (b <>) (a b) == a && maybe a (<> b) (a b) == a checkStripPrefix' (LeftCancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripPrefix a (a <> b) == Just b checkStripSuffix' (RightCancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripSuffix b (a <> b) == Just a checkUnAppend' (CancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = a <> b a == Just b && a <> b b == Just a checkStripCommonPrefix1 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripCommonPrefix a b == (p, a', b') where p = commonPrefix a b Just a' = stripPrefix p a Just b' = stripPrefix p b checkStripCommonPrefix2 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = p == commonPrefix a b && p <> a' == a && p <> b' == b where (p, a', b') = stripCommonPrefix a b checkStripCommonSuffix1 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripCommonSuffix a b == (a', b', s) where s = commonSuffix a b Just a' = stripSuffix s a Just b' = stripSuffix s b checkStripCommonSuffix2 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = s == commonSuffix a b && a' <> s == a && b' <> s == b where (a', b', s) = stripCommonSuffix a b checkGCD (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = d == commonPrefix a b && d == commonSuffix a b && isJust (a d) && isJust (b d) where d = gcd a b checkCancellativeGCD (CancellativeGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check (a, b, c) = commonPrefix (a <> b) (a <> c) == a <> (commonPrefix b c) && commonSuffix (a <> c) (b <> c) == (commonSuffix a b) <> c && gcd (a <> b) (a <> c) == a <> gcd b c && gcd (a <> c) (b <> c) == gcd a b <> c textualFactors :: TextualMonoid t => t -> [Either t Char] textualFactors = map characterize . factors where characterize prime = maybe (Left prime) Right (Textual.characterPrefix prime) newtype TestString = TestString String deriving (Eq, Show, Arbitrary, CoArbitrary, Monoid, LeftReductiveMonoid, LeftCancellativeMonoid, LeftGCDMonoid, MonoidNull, PositiveMonoid, StableFactorialMonoid, IsString) instance FactorialMonoid TestString where splitPrimePrefix (TestString []) = Nothing splitPrimePrefix (TestString (x:xs)) = Just (TestString [x], TestString xs) instance TextualMonoid TestString where splitCharacterPrefix (TestString []) = Nothing splitCharacterPrefix (TestString (x:xs)) = Just (x, TestString xs) instance Arbitrary All where arbitrary = fmap All arbitrary instance Arbitrary Any where arbitrary = fmap Any arbitrary instance Arbitrary a => Arbitrary (Dual a) where arbitrary = fmap Dual arbitrary instance Arbitrary a => Arbitrary (First a) where arbitrary = fmap First arbitrary instance Arbitrary a => Arbitrary (Last a) where arbitrary = fmap Last arbitrary instance Arbitrary a => Arbitrary (Product a) where arbitrary = fmap Product arbitrary instance Arbitrary a => Arbitrary (Sum a) where arbitrary = fmap Sum arbitrary instance Arbitrary a => Arbitrary (Vector a) where arbitrary = fmap fromList arbitrary instance Arbitrary ByteStringUTF8 where arbitrary = fmap ByteStringUTF8 arbitrary instance (Arbitrary a, MonoidNull a, PositiveMonoid a) => Arbitrary (Concat a) where arbitrary = fmap Concat.inject arbitrary instance (Arbitrary a, FactorialMonoid a) => Arbitrary (Measured a) where arbitrary = fmap Measured.inject arbitrary instance (Arbitrary a, Arbitrary b) => Arbitrary (Stateful a b) where arbitrary = Stateful.Stateful <$> liftA2 (,) arbitrary arbitrary instance CoArbitrary All where coarbitrary (All p) = coarbitrary p instance CoArbitrary Any where coarbitrary (Any p) = coarbitrary p instance CoArbitrary a => CoArbitrary (Dual a) where coarbitrary (Dual a) = coarbitrary a instance CoArbitrary a => CoArbitrary (First a) where coarbitrary (First a) = coarbitrary a instance CoArbitrary a => CoArbitrary (Last a) where coarbitrary (Last a) = coarbitrary a instance CoArbitrary a => CoArbitrary (Product a) where coarbitrary (Product a) = coarbitrary a instance CoArbitrary a => CoArbitrary (Sum a) where coarbitrary (Sum a) = coarbitrary a instance CoArbitrary a => CoArbitrary (Vector a) where coarbitrary = coarbitrary . toList instance CoArbitrary ByteStringUTF8 where coarbitrary (ByteStringUTF8 bs) = coarbitrary bs instance CoArbitrary a => CoArbitrary (Concat a) where coarbitrary = coarbitrary . Concat.extract instance CoArbitrary a => CoArbitrary (Measured a) where coarbitrary = coarbitrary . Measured.extract instance CoArbitrary b => CoArbitrary (Stateful a b) where coarbitrary = coarbitrary . Stateful.extract instance Show a => Show (a -> Bool) where show _ = "predicate" 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 #endifmonoid-subclasses-0.3.5/Data/0000755000000000000000000000000012251733717014220 5ustar0000000000000000monoid-subclasses-0.3.5/Data/Monoid/0000755000000000000000000000000012251733717015445 5ustar0000000000000000monoid-subclasses-0.3.5/Data/Monoid/Factorial.hs0000644000000000000000000005521512251733717017715 0ustar0000000000000000{- Copyright 2011-2013 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'FactorialMonoid' class and some of its instances. -- {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Factorial ( -- * Classes FactorialMonoid(..), StableFactorialMonoid, -- * Monad function equivalents mapM, mapM_ ) where import Prelude hiding (break, drop, dropWhile, foldl, foldr, length, map, mapM, mapM_, null, reverse, span, splitAt, take, takeWhile) import Control.Arrow (first) import qualified Control.Monad as Monad import Data.Monoid (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import qualified Data.Vector as Vector import Data.Numbers.Primes (primeFactors) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) -- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of -- a 'Product' are literally its prime factors: -- -- prop> factors (Product 12) == [Product 2, Product 2, Product 3] -- -- Factors of a list are /not/ its elements but all its single-item sublists: -- -- prop> factors "abc" == ["a", "b", "c"] -- -- The methods of this class satisfy the following laws: -- -- > mconcat . factors == id -- > null == List.null . factors -- > List.all (\prime-> factors prime == [prime]) . factors -- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix) -- > reverse == mconcat . List.reverse . factors -- > primePrefix == maybe mempty fst . splitPrimePrefix -- > primeSuffix == maybe mempty snd . splitPrimeSuffix -- > foldl f a == List.foldl f a . factors -- > foldl' f a == List.foldl' f a . factors -- > foldr f a == List.foldr f a . factors -- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m) -- > List.all (List.all (not . pred) . factors) . split pred -- > mconcat . intersperse prime . split (== prime) == id -- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m) -- -- A minimal instance definition must implement 'factors' or 'splitPrimePrefix'. Other methods are provided and should -- be implemented only for performance reasons. class MonoidNull m => FactorialMonoid m where -- | Returns a list of all prime factors; inverse of mconcat. factors :: m -> [m] -- | The prime prefix, 'mempty' if none. primePrefix :: m -> m -- | The prime suffix, 'mempty' if none. primeSuffix :: m -> m -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'. splitPrimePrefix :: m -> Maybe (m, m) -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'. splitPrimeSuffix :: m -> Maybe (m, m) -- | Like 'List.foldl' from "Data.List" on the list of 'primes'. foldl :: (a -> m -> a) -> a -> m -> a -- | Like 'List.foldl'' from "Data.List" on the list of 'primes'. foldl' :: (a -> m -> a) -> a -> m -> a -- | Like 'List.foldr' from "Data.List" on the list of 'primes'. foldr :: (m -> a -> a) -> a -> m -> a -- | The 'length' of the list of 'primes'. length :: m -> Int -- | Generalizes 'foldMap' from "Data.Foldable", except the function arguments are prime factors rather than the -- structure elements. foldMap :: (FactorialMonoid m, Monoid n) => (m -> n) -> m -> n -- | Like 'List.span' from "Data.List" on the list of 'primes'. span :: (m -> Bool) -> m -> (m, m) -- | Equivalent to 'List.break' from "Data.List". break :: FactorialMonoid m => (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 :: FactorialMonoid m => (m -> Bool) -> m -> m -- | Equivalent to 'List.dropWhile' from "Data.List". dropWhile :: FactorialMonoid m => (m -> Bool) -> m -> m -- | Like 'List.splitAt' from "Data.List" on the list of 'primes'. splitAt :: Int -> m -> (m, m) -- | Equivalent to 'List.drop' from "Data.List". drop :: FactorialMonoid m => Int -> m -> m -- | Equivalent to 'List.take' from "Data.List". take :: FactorialMonoid m => Int -> m -> m -- | Equivalent to 'List.reverse' from "Data.List". reverse :: FactorialMonoid m => m -> m factors = List.unfoldr splitPrimePrefix primePrefix = maybe mempty fst . splitPrimePrefix primeSuffix = maybe mempty snd . splitPrimeSuffix splitPrimePrefix x = case factors x of [] -> Nothing prefix : rest -> Just (prefix, mconcat rest) splitPrimeSuffix x = case factors x of [] -> Nothing fs -> Just (mconcat (List.init fs), List.last fs) foldl f f0 = List.foldl f f0 . factors foldl' f f0 = List.foldl' f f0 . factors foldr f f0 = List.foldr f f0 . factors length = List.length . factors foldMap f = foldr (mappend . f) mempty span p m = spanAfter id m where spanAfter f m = case splitPrimePrefix m of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest _ -> (f mempty, m) break = span . (not .) split p m = prefix : splitRest where (prefix, rest) = break p m splitRest = case splitPrimePrefix rest of Nothing -> [] Just (_, tail) -> split p tail takeWhile p = fst . span p dropWhile p = snd . span p splitAt n m | n <= 0 = (mempty, m) | otherwise = split n id m where split 0 f m = (f mempty, m) split n f m = case splitPrimePrefix m of Nothing -> (f mempty, m) Just (prime, rest) -> split (pred n) (f . mappend prime) rest drop n p = snd (splitAt n p) take n p = fst (splitAt n p) reverse = mconcat . List.reverse . factors -- | A subclass of 'FactorialMonoid' whose instances satisfy this additional law: -- -- > factors (a <> b) == factors a <> factors b class (FactorialMonoid m, PositiveMonoid m) => StableFactorialMonoid m instance FactorialMonoid () where factors () = [] primePrefix () = () primeSuffix () = () splitPrimePrefix () = Nothing splitPrimeSuffix () = Nothing length () = 0 reverse = id instance FactorialMonoid a => FactorialMonoid (Dual a) where factors (Dual a) = fmap Dual (reverse $ factors a) length (Dual a) = length a primePrefix (Dual a) = Dual (primeSuffix a) primeSuffix (Dual a) = Dual (primePrefix a) splitPrimePrefix (Dual a) = case splitPrimeSuffix a of Nothing -> Nothing Just (p, s) -> Just (Dual s, Dual p) splitPrimeSuffix (Dual a) = case splitPrimePrefix a of Nothing -> Nothing Just (p, s) -> Just (Dual s, Dual p) reverse (Dual a) = Dual (reverse a) instance (Integral a, Eq a) => FactorialMonoid (Sum a) where primePrefix (Sum a) = Sum (signum a ) primeSuffix = primePrefix splitPrimePrefix (Sum 0) = Nothing splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a)) splitPrimeSuffix (Sum 0) = Nothing splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a)) length (Sum a) = abs (fromIntegral a) reverse = id instance Integral a => FactorialMonoid (Product a) where factors (Product a) = List.map Product (primeFactors a) reverse = id instance FactorialMonoid a => FactorialMonoid (Maybe a) where factors Nothing = [] factors (Just a) | null a = [Just a] | otherwise = List.map Just (factors a) length Nothing = 0 length (Just a) | null a = 1 | otherwise = length a reverse = fmap reverse instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where factors (a, b) = List.map (\a-> (a, mempty)) (factors a) ++ List.map ((,) mempty) (factors b) primePrefix (a, b) | null a = (a, primePrefix b) | otherwise = (primePrefix a, mempty) primeSuffix (a, b) | null b = (primeSuffix a, b) | otherwise = (mempty, primeSuffix b) splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b) of (Just (ap, as), _) -> Just ((ap, mempty), (as, b)) (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs)) (Nothing, Nothing) -> Nothing splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b) of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs)) (Just (ap, as), Nothing) -> Just ((ap, b), (as, b)) (Nothing, Nothing) -> Nothing foldl f a (x, y) = foldl f2 (foldl f1 a x) y where f1 a = f a . fromFst f2 a = f a . fromSnd foldl' f a (x, y) = a' `seq` foldl' f2 a' y where f1 a = f a . fromFst f2 a = f a . fromSnd a' = foldl' f1 a x foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x foldMap f (x, y) = foldMap (f . fromFst) x `mappend` foldMap (f . fromSnd) y length (a, b) = length a + length b span p (x, y) = ((xp, yp), (xs, ys)) where (xp, xs) = span (p . fromFst) x (yp, ys) | null xs = span (p . fromSnd) y | otherwise = (mempty, y) split p (x, y) = fst $ List.foldr combine (ys, False) xs where xs = List.map fromFst $ split (p . fromFst) x ys = List.map fromSnd $ split (p . fromSnd) y combine x (y:ys, False) = (mappend x y : ys, True) combine x (xs, True) = (x:xs, True) splitAt n (x, y) = ((xp, yp), (xs, ys)) where (xp, xs) = splitAt n x (yp, ys) | null xs = splitAt (n - length x) y | otherwise = (mempty, y) reverse (a, b) = (reverse a, reverse b) {-# INLINE fromFst #-} fromFst :: Monoid b => a -> (a, b) fromFst a = (a, mempty) {-# INLINE fromSnd #-} fromSnd :: Monoid a => b -> (a, b) fromSnd b = (mempty, b) instance FactorialMonoid [x] where factors xs = List.map (:[]) xs primePrefix [] = [] primePrefix (x:xs) = [x] primeSuffix [] = [] primeSuffix xs = [List.last xs] splitPrimePrefix [] = Nothing splitPrimePrefix (x:xs) = Just ([x], xs) splitPrimeSuffix [] = Nothing splitPrimeSuffix xs = Just (split id xs) where split f last@[x] = (f [], last) split f (x:xs) = split (f . (x:)) 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 . (:[])) break f = List.break (f . (:[])) span f = List.span (f . (:[])) dropWhile f = List.dropWhile (f . (:[])) takeWhile f = List.takeWhile (f . (:[])) splitAt = List.splitAt drop = List.drop take = List.take reverse = List.reverse instance FactorialMonoid ByteString.ByteString where factors x = factorize (ByteString.length x) x where factorize 0 xs = [] factorize n xs = x : factorize (pred n) xs' where (x, xs') = ByteString.splitAt 1 xs primePrefix = ByteString.take 1 primeSuffix x = ByteString.drop (ByteString.length x - 1) x splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x) splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x) foldl f = ByteString.foldl f' where f' a byte = f a (ByteString.singleton byte) foldl' f = ByteString.foldl' f' where f' a byte = f a (ByteString.singleton byte) foldr f = ByteString.foldr (f . ByteString.singleton) break f = ByteString.break (f . ByteString.singleton) span f = ByteString.span (f . ByteString.singleton) dropWhile f = ByteString.dropWhile (f . ByteString.singleton) takeWhile f = ByteString.takeWhile (f . ByteString.singleton) length = ByteString.length split f = ByteString.splitWith f' where f' = f . ByteString.singleton splitAt = ByteString.splitAt drop = ByteString.drop take = ByteString.take reverse = ByteString.reverse instance FactorialMonoid LazyByteString.ByteString where factors x = factorize (LazyByteString.length x) x where factorize 0 xs = [] factorize n xs = x : factorize (pred n) xs' where (x, xs') = LazyByteString.splitAt 1 xs primePrefix = LazyByteString.take 1 primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x splitPrimePrefix x = if LazyByteString.null x then Nothing else Just (LazyByteString.splitAt 1 x) splitPrimeSuffix x = if LazyByteString.null x then Nothing else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x) foldl f = LazyByteString.foldl f' where f' a byte = f a (LazyByteString.singleton byte) foldl' f = LazyByteString.foldl' f' where f' a byte = f a (LazyByteString.singleton byte) foldr f = LazyByteString.foldr f' where f' byte a = f (LazyByteString.singleton byte) a length = fromIntegral . LazyByteString.length break f = LazyByteString.break (f . LazyByteString.singleton) span f = LazyByteString.span (f . LazyByteString.singleton) dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton) takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton) split f = LazyByteString.splitWith f' where f' = f . LazyByteString.singleton splitAt = LazyByteString.splitAt . fromIntegral drop n = LazyByteString.drop (fromIntegral n) take n = LazyByteString.take (fromIntegral n) reverse = LazyByteString.reverse instance FactorialMonoid Text.Text where factors = Text.chunksOf 1 primePrefix = Text.take 1 primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x) splitPrimePrefix = fmap (first Text.singleton) . Text.uncons splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x)) foldl f = Text.foldl f' where f' a char = f a (Text.singleton char) foldl' f = Text.foldl' f' where f' a char = f a (Text.singleton char) foldr f = Text.foldr f' where f' char a = f (Text.singleton char) a length = Text.length span f = Text.span (f . Text.singleton) break f = Text.break (f . Text.singleton) dropWhile f = Text.dropWhile (f . Text.singleton) takeWhile f = Text.takeWhile (f . Text.singleton) split f = Text.split f' where f' = f . Text.singleton splitAt = Text.splitAt drop = Text.drop take = Text.take reverse = Text.reverse instance FactorialMonoid LazyText.Text where factors = LazyText.chunksOf 1 primePrefix = LazyText.take 1 primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x) splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons splitPrimeSuffix x = if LazyText.null x then Nothing else Just (LazyText.init x, LazyText.singleton (LazyText.last x)) foldl f = LazyText.foldl f' where f' a char = f a (LazyText.singleton char) foldl' f = LazyText.foldl' f' where f' a char = f a (LazyText.singleton char) foldr f = LazyText.foldr f' where f' char a = f (LazyText.singleton char) a length = fromIntegral . LazyText.length span f = LazyText.span (f . LazyText.singleton) break f = LazyText.break (f . LazyText.singleton) dropWhile f = LazyText.dropWhile (f . LazyText.singleton) takeWhile f = LazyText.takeWhile (f . LazyText.singleton) split f = LazyText.split f' where f' = f . LazyText.singleton splitAt = LazyText.splitAt . fromIntegral drop n = LazyText.drop (fromIntegral n) take n = LazyText.take (fromIntegral n) reverse = LazyText.reverse instance Ord k => FactorialMonoid (Map.Map k v) where factors = List.map (uncurry Map.singleton) . Map.toAscList primePrefix map | Map.null map = map | otherwise = uncurry Map.singleton $ Map.findMin map primeSuffix map | Map.null map = map | otherwise = uncurry Map.singleton $ Map.findMax map splitPrimePrefix = fmap singularize . Map.minViewWithKey where singularize ((k, v), rest) = (Map.singleton k v, rest) splitPrimeSuffix = fmap singularize . Map.maxViewWithKey where singularize ((k, v), rest) = (rest, Map.singleton k v) foldl f = Map.foldlWithKey f' where f' a k v = f a (Map.singleton k v) foldl' f = Map.foldlWithKey' f' where f' a k v = f a (Map.singleton k v) foldr f = Map.foldrWithKey f' where f' k v a = f (Map.singleton k v) a length = Map.size reverse = id instance FactorialMonoid (IntMap.IntMap a) where factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList primePrefix map | IntMap.null map = map | otherwise = uncurry IntMap.singleton $ IntMap.findMin map primeSuffix map | IntMap.null map = map | otherwise = uncurry IntMap.singleton $ IntMap.findMax map splitPrimePrefix = fmap singularize . IntMap.minViewWithKey where singularize ((k, v), rest) = (IntMap.singleton k v, rest) splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey where singularize ((k, v), rest) = (rest, IntMap.singleton k v) foldl f = IntMap.foldlWithKey f' where f' a k v = f a (IntMap.singleton k v) foldl' f = IntMap.foldlWithKey' f' where f' a k v = f a (IntMap.singleton k v) foldr f = IntMap.foldrWithKey f' where f' k v a = f (IntMap.singleton k v) a length = IntMap.size reverse = id instance FactorialMonoid IntSet.IntSet where factors = List.map IntSet.singleton . IntSet.toAscList primePrefix set | IntSet.null set = set | otherwise = IntSet.singleton $ IntSet.findMin set primeSuffix set | IntSet.null set = set | otherwise = IntSet.singleton $ IntSet.findMax set splitPrimePrefix = fmap singularize . IntSet.minView where singularize (min, rest) = (IntSet.singleton min, rest) splitPrimeSuffix = fmap singularize . IntSet.maxView where singularize (max, rest) = (rest, IntSet.singleton max) foldl f = IntSet.foldl f' where f' a b = f a (IntSet.singleton b) foldl' f = IntSet.foldl' f' where f' a b = f a (IntSet.singleton b) foldr f = IntSet.foldr f' where f' a b = f (IntSet.singleton a) b length = IntSet.size reverse = id instance FactorialMonoid (Sequence.Seq a) where factors = List.map Sequence.singleton . Foldable.toList primePrefix = Sequence.take 1 primeSuffix seq = Sequence.drop (Sequence.length seq - 1) seq splitPrimePrefix seq = case Sequence.viewl seq of Sequence.EmptyL -> Nothing first Sequence.:< rest -> Just (Sequence.singleton first, rest) splitPrimeSuffix seq = case Sequence.viewr seq of Sequence.EmptyR -> Nothing rest Sequence.:> last -> Just (rest, Sequence.singleton last) foldl f = Foldable.foldl f' where f' a b = f a (Sequence.singleton b) foldl' f = Foldable.foldl' f' where f' a b = f a (Sequence.singleton b) foldr f = Foldable.foldr f' where f' a b = f (Sequence.singleton a) b span f = Sequence.spanl (f . Sequence.singleton) break f = Sequence.breakl (f . Sequence.singleton) dropWhile f = Sequence.dropWhileL (f . Sequence.singleton) takeWhile f = Sequence.takeWhileL (f . Sequence.singleton) splitAt = Sequence.splitAt drop = Sequence.drop take = Sequence.take length = Sequence.length reverse = Sequence.reverse instance Ord a => FactorialMonoid (Set.Set a) where factors = List.map Set.singleton . Set.toAscList primePrefix set | Set.null set = set | otherwise = Set.singleton $ Set.findMin set primeSuffix set | Set.null set = set | otherwise = Set.singleton $ Set.findMax set splitPrimePrefix = fmap singularize . Set.minView where singularize (min, rest) = (Set.singleton min, rest) splitPrimeSuffix = fmap singularize . Set.maxView where singularize (max, rest) = (rest, Set.singleton max) foldl f = Foldable.foldl f' where f' a b = f a (Set.singleton b) foldl' f = Foldable.foldl' f' where f' a b = f a (Set.singleton b) foldr f = Foldable.foldr f' where f' a b = f (Set.singleton a) b length = Set.size reverse = id instance FactorialMonoid (Vector.Vector a) where factors x = factorize (Vector.length x) x where factorize 0 xs = [] factorize n xs = x : factorize (pred n) xs' where (x, xs') = Vector.splitAt 1 xs primePrefix = Vector.take 1 primeSuffix x = Vector.drop (Vector.length x - 1) x splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x) splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x) foldl f = Vector.foldl f' where f' a byte = f a (Vector.singleton byte) foldl' f = Vector.foldl' f' where f' a byte = f a (Vector.singleton byte) foldr f = Vector.foldr f' where f' byte a = f (Vector.singleton byte) a break f = Vector.break (f . Vector.singleton) span f = Vector.span (f . Vector.singleton) dropWhile f = Vector.dropWhile (f . Vector.singleton) takeWhile f = Vector.takeWhile (f . Vector.singleton) splitAt = Vector.splitAt drop = Vector.drop take = Vector.take length = Vector.length reverse = Vector.reverse instance StableFactorialMonoid () instance StableFactorialMonoid a => StableFactorialMonoid (Dual a) instance StableFactorialMonoid [x] instance StableFactorialMonoid ByteString.ByteString instance StableFactorialMonoid LazyByteString.ByteString instance StableFactorialMonoid Text.Text instance StableFactorialMonoid LazyText.Text instance StableFactorialMonoid (Sequence.Seq a) instance StableFactorialMonoid (Vector.Vector a) -- | A 'Monad.mapM' equivalent. mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b mapM f = ($ return mempty) . appEndo . foldMap (Endo . Monad.liftM2 mappend . f) -- | A 'Monad.mapM_' equivalent. mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m () mapM_ f = foldr ((>>) . f) (return ()) monoid-subclasses-0.3.5/Data/Monoid/Cancellative.hs0000644000000000000000000005670412251733717020407 0ustar0000000000000000{- Copyright 2011-2013 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'Monoid' => 'ReductiveMonoid' => ('CancellativeMonoid', 'GCDMonoid') class hierarchy. -- -- The 'ReductiveMonoid' class introduces operation '' which is the inverse of '<>'. For the 'Sum' monoid, this -- operation is subtraction; for 'Product' it is division and for 'Set' it's the set difference. A 'ReductiveMonoid' is -- not a full group because '' may return 'Nothing'. -- -- The 'CancellativeMonoid' subclass does not add any operation but it provides the additional guarantee that '<>' can -- always be undone with ''. Thus 'Sum' is a 'CancellativeMonoid' but 'Product' is not because @(0*n)/0@ is not -- defined. -- -- The 'GCDMonoid' subclass adds the 'gcd' operation which takes two monoidal arguments and finds their greatest common -- divisor, or (more generally) the greatest monoid that can be extracted with the '' operation from both. -- -- All monoid subclasses listed above are for Abelian, /i.e./, commutative or symmetric monoids. Since most practical -- monoids in Haskell are not Abelian, each of the these classes has two symmetric superclasses: -- -- * 'LeftReductiveMonoid' -- -- * 'LeftCancellativeMonoid' -- -- * 'LeftGCDMonoid' -- -- * 'RightReductiveMonoid' -- -- * 'RightCancellativeMonoid' -- -- * 'RightGCDMonoid' {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Cancellative ( -- * Symmetric, commutative monoid classes CommutativeMonoid, ReductiveMonoid(..), CancellativeMonoid(..), GCDMonoid(..), -- * Asymmetric monoid classes LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftCancellativeMonoid(..), RightCancellativeMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..) ) where import Prelude hiding (gcd) import qualified Prelude import Data.Monoid (Monoid (mappend), Dual(..), Sum(..), Product(..)) import qualified Data.List as List import Data.Maybe (isJust) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Unsafe as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import Data.Sequence (ViewL((:<)), ViewR((:>)), (<|), (|>)) import qualified Data.Vector as Vector -- | Class of all Abelian ({i.e.}, commutative) monoids that satisfy the commutativity property: -- -- > a <> b == b <> a class Monoid m => CommutativeMonoid m -- | Class of Abelian monoids with a partial inverse for the Monoid '<>' operation. The inverse operation '' must -- satisfy the following laws: -- -- > maybe a (b <>) (a b) == a -- > maybe a (<> b) (a b) == a class (CommutativeMonoid m, LeftReductiveMonoid m, RightReductiveMonoid m) => ReductiveMonoid m where () :: m -> m -> Maybe m infix 5 -- | Subclass of 'ReductiveMonoid' where '' is a complete inverse of the Monoid '<>' operation. The class instances -- must satisfy the following additional laws: -- -- > (a <> b) a == Just b -- > (a <> b) b == Just a class (LeftCancellativeMonoid m, RightCancellativeMonoid m, ReductiveMonoid m) => CancellativeMonoid m -- | Class of Abelian monoids that allow the greatest common denominator to be found for any two given values. The -- operations must satisfy the following laws: -- -- > gcd a b == commonPrefix a b == commonSuffix a b -- > Just a' = a p && Just b' = b p -- > where p = gcd a b -- -- If a 'GCDMonoid' happens to also be a 'CancellativeMonoid', it should additionally satisfy the following laws: -- -- > gcd (a <> b) (a <> c) == a <> gcd b c -- > gcd (a <> c) (b <> c) == gcd a b <> c class (ReductiveMonoid m, LeftGCDMonoid m, RightGCDMonoid m) => GCDMonoid m where gcd :: m -> m -> m -- | Class of monoids with a left inverse of 'mappend', satisfying the following law: -- -- > isPrefixOf a b == isJust (stripPrefix a b) -- > maybe b (a <>) (stripPrefix a b) == b -- > a `isPrefixOf` (a <> b) -- -- | Every instance definition has to implement at least the 'stripPrefix' method. Its complexity should be no worse -- than linear in the length of the prefix argument. class Monoid m => LeftReductiveMonoid m where isPrefixOf :: m -> m -> Bool stripPrefix :: m -> m -> Maybe m isPrefixOf a b = isJust (stripPrefix a b) -- | Class of monoids with a right inverse of 'mappend', satisfying the following law: -- -- > isSuffixOf a b == isJust (stripSuffix a b) -- > maybe b (<> a) (stripSuffix a b) == b -- > b `isSuffixOf` (a <> b) -- -- | Every instance definition has to implement at least the 'stripSuffix' method. Its complexity should be no worse -- than linear in the length of the suffix argument. class Monoid m => RightReductiveMonoid m where isSuffixOf :: m -> m -> Bool stripSuffix :: m -> m -> Maybe m isSuffixOf a b = isJust (stripSuffix a b) -- | Subclass of 'LeftReductiveMonoid' where 'stripPrefix' is a complete inverse of '<>', satisfying the following -- additional law: -- -- > stripPrefix a (a <> b) == Just b class LeftReductiveMonoid m => LeftCancellativeMonoid m -- | Subclass of 'LeftReductiveMonoid' where 'stripPrefix' is a complete inverse of '<>', satisfying the following -- additional law: -- -- > stripSuffix b (a <> b) == Just a class RightReductiveMonoid m => RightCancellativeMonoid m -- | Class of monoids capable of finding the equivalent of greatest common divisor on the left side of two monoidal -- values. The methods' complexity should be no worse than linear in the length of the common prefix. The following laws -- must be respected: -- -- > stripCommonPrefix a b == (p, a', b') -- > where p = commonPrefix a b -- > Just a' = stripPrefix p a -- > Just b' = stripPrefix p b -- > p == commonPrefix a b && p <> a' == a && p <> b' == b -- > where (p, a', b') = stripCommonPrefix a b class LeftReductiveMonoid m => LeftGCDMonoid m where commonPrefix :: m -> m -> m stripCommonPrefix :: m -> m -> (m, m, m) commonPrefix x y = p where (p, _, _) = stripCommonPrefix x y stripCommonPrefix x y = (p, x', y') where p = commonPrefix x y Just x' = stripPrefix p x Just y' = stripPrefix p y -- | Class of monoids capable of finding the equivalent of greatest common divisor on the right side of two monoidal -- values. The methods' complexity must be no worse than linear in the length of the common suffix. The following laws -- must be respected: -- -- > stripCommonSuffix a b == (a', b', s) -- > where s = commonSuffix a b -- > Just a' = stripSuffix p a -- > Just b' = stripSuffix p b -- > s == commonSuffix a b && a' <> s == a && b' <> s == b -- > where (a', b', s) = stripCommonSuffix a b class RightReductiveMonoid m => RightGCDMonoid m where commonSuffix :: m -> m -> m stripCommonSuffix :: m -> m -> (m, m, m) commonSuffix x y = s where (_, _, s) = stripCommonSuffix x y stripCommonSuffix x y = (x', y', s) where s = commonSuffix x y Just x' = stripSuffix s x Just y' = stripSuffix s y -- Unit instances instance CommutativeMonoid () instance ReductiveMonoid () where () () = Just () instance CancellativeMonoid () instance GCDMonoid () where gcd () () = () instance LeftReductiveMonoid () where stripPrefix () () = Just () instance RightReductiveMonoid () where stripSuffix () () = Just () instance LeftCancellativeMonoid () instance RightCancellativeMonoid () instance LeftGCDMonoid () where commonPrefix () () = () instance RightGCDMonoid () where commonSuffix () () = () -- Dual instances instance CommutativeMonoid a => CommutativeMonoid (Dual a) instance ReductiveMonoid a => ReductiveMonoid (Dual a) where Dual a Dual b = fmap Dual (a b) instance CancellativeMonoid a => CancellativeMonoid (Dual a) instance GCDMonoid a => GCDMonoid (Dual a) where gcd (Dual a) (Dual b) = Dual (gcd a b) instance LeftReductiveMonoid a => RightReductiveMonoid (Dual a) where stripSuffix (Dual a) (Dual b) = fmap Dual (stripPrefix a b) Dual a `isSuffixOf` Dual b = a `isPrefixOf` b instance RightReductiveMonoid a => LeftReductiveMonoid (Dual a) where stripPrefix (Dual a) (Dual b) = fmap Dual (stripSuffix a b) Dual a `isPrefixOf` Dual b = a `isSuffixOf` b instance LeftCancellativeMonoid a => RightCancellativeMonoid (Dual a) instance RightCancellativeMonoid a => LeftCancellativeMonoid (Dual a) instance LeftGCDMonoid a => RightGCDMonoid (Dual a) where commonSuffix (Dual a) (Dual b) = Dual (commonPrefix a b) instance RightGCDMonoid a => LeftGCDMonoid (Dual a) where commonPrefix (Dual a) (Dual b) = Dual (commonSuffix a b) -- Sum instances instance Num a => CommutativeMonoid (Sum a) instance Integral a => ReductiveMonoid (Sum a) where Sum a Sum b = Just $ Sum (a - b) instance Integral a => CancellativeMonoid (Sum a) instance (Integral a, Ord a) => GCDMonoid (Sum a) where gcd (Sum a) (Sum b) = Sum (min a b) instance Integral a => LeftReductiveMonoid (Sum a) where stripPrefix a b = b a instance Integral a => RightReductiveMonoid (Sum a) where stripSuffix a b = b a instance Integral a => LeftCancellativeMonoid (Sum a) instance Integral a => RightCancellativeMonoid (Sum a) instance (Integral a, Ord a) => LeftGCDMonoid (Sum a) where commonPrefix a b = gcd a b instance (Integral a, Ord a) => RightGCDMonoid (Sum a) where commonSuffix a b = gcd a b -- Product instances instance Num a => CommutativeMonoid (Product a) instance Integral a => ReductiveMonoid (Product a) where Product 0 Product 0 = Just (Product 0) Product a Product 0 = Nothing Product a Product b = if remainder == 0 then Just (Product quotient) else Nothing where (quotient, remainder) = quotRem a b instance Integral a => GCDMonoid (Product a) where gcd (Product a) (Product b) = Product (Prelude.gcd a b) instance Integral a => LeftReductiveMonoid (Product a) where stripPrefix a b = b a instance Integral a => RightReductiveMonoid (Product a) where stripSuffix a b = b a instance Integral a => LeftGCDMonoid (Product a) where commonPrefix a b = gcd a b instance Integral a => RightGCDMonoid (Product a) where commonSuffix a b = gcd a b -- Pair instances instance (CommutativeMonoid a, CommutativeMonoid b) => CommutativeMonoid (a, b) instance (ReductiveMonoid a, ReductiveMonoid b) => ReductiveMonoid (a, b) where (a, b) (c, d) = case (a c, b d) of (Just a', Just b') -> Just (a', b') _ -> Nothing instance (CancellativeMonoid a, CancellativeMonoid b) => CancellativeMonoid (a, b) instance (GCDMonoid a, GCDMonoid b) => GCDMonoid (a, b) where gcd (a, b) (c, d) = (gcd a c, gcd b d) instance (LeftReductiveMonoid a, LeftReductiveMonoid b) => LeftReductiveMonoid (a, b) where stripPrefix (a, b) (c, d) = case (stripPrefix a c, stripPrefix b d) of (Just a', Just b') -> Just (a', b') _ -> Nothing isPrefixOf (a, b) (c, d) = isPrefixOf a c && isPrefixOf b d instance (RightReductiveMonoid a, RightReductiveMonoid b) => RightReductiveMonoid (a, b) where stripSuffix (a, b) (c, d) = case (stripSuffix a c, stripSuffix b d) of (Just a', Just b') -> Just (a', b') _ -> Nothing isSuffixOf (a, b) (c, d) = isSuffixOf a c && isSuffixOf b d instance (LeftCancellativeMonoid a, LeftCancellativeMonoid b) => LeftCancellativeMonoid (a, b) instance (RightCancellativeMonoid a, RightCancellativeMonoid b) => RightCancellativeMonoid (a, b) instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (a, b) where commonPrefix (a, b) (c, d) = (commonPrefix a c, commonPrefix b d) instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (a, b) where commonSuffix (a, b) (c, d) = (commonSuffix a c, commonSuffix b d) -- Maybe instances instance LeftReductiveMonoid x => LeftReductiveMonoid (Maybe x) where stripPrefix Nothing y = Just y stripPrefix Just{} Nothing = Nothing stripPrefix (Just x) (Just y) = fmap Just $ stripPrefix x y instance LeftGCDMonoid x => LeftGCDMonoid (Maybe x) where commonPrefix (Just x) (Just y) = Just (commonPrefix x y) commonPrefix _ _ = Nothing stripCommonPrefix (Just x) (Just y) = (Just p, Just x', Just y') where (p, x', y') = stripCommonPrefix x y stripCommonPrefix x y = (Nothing, x, y) instance RightReductiveMonoid x => RightReductiveMonoid (Maybe x) where stripSuffix Nothing y = Just y stripSuffix Just{} Nothing = Nothing stripSuffix (Just x) (Just y) = fmap Just $ stripSuffix x y instance RightGCDMonoid x => RightGCDMonoid (Maybe x) where commonSuffix (Just x) (Just y) = Just (commonSuffix x y) commonSuffix _ _ = Nothing stripCommonSuffix (Just x) (Just y) = (Just x', Just y', Just s) where (x', y', s) = stripCommonSuffix x y stripCommonSuffix x y = (x, y, Nothing) -- Set instances instance Ord a => CommutativeMonoid (Set.Set a) instance Ord a => LeftReductiveMonoid (Set.Set a) where isPrefixOf = Set.isSubsetOf stripPrefix a b = b a instance Ord a => RightReductiveMonoid (Set.Set a) where isSuffixOf = Set.isSubsetOf stripSuffix a b = b a instance Ord a => ReductiveMonoid (Set.Set a) where a b | Set.isSubsetOf b a = Just (a Set.\\ b) | otherwise = Nothing instance Ord a => LeftGCDMonoid (Set.Set a) where commonPrefix = Set.intersection instance Ord a => RightGCDMonoid (Set.Set a) where commonSuffix = Set.intersection instance Ord a => GCDMonoid (Set.Set a) where gcd = Set.intersection -- IntSet instances instance CommutativeMonoid IntSet.IntSet instance LeftReductiveMonoid IntSet.IntSet where isPrefixOf = IntSet.isSubsetOf stripPrefix a b = b a instance RightReductiveMonoid IntSet.IntSet where isSuffixOf = IntSet.isSubsetOf stripSuffix a b = b a instance ReductiveMonoid IntSet.IntSet where a b | IntSet.isSubsetOf b a = Just (a IntSet.\\ b) | otherwise = Nothing instance LeftGCDMonoid IntSet.IntSet where commonPrefix = IntSet.intersection instance RightGCDMonoid IntSet.IntSet where commonSuffix = IntSet.intersection instance GCDMonoid IntSet.IntSet where gcd = IntSet.intersection -- Map instances instance Ord k => LeftReductiveMonoid (Map.Map k a) where isPrefixOf = Map.isSubmapOfBy (\_ _-> True) stripPrefix a b | Map.isSubmapOfBy (\_ _-> True) a b = Just (b Map.\\ a) | otherwise = Nothing instance (Ord k, Eq a) => LeftGCDMonoid (Map.Map k a) where commonPrefix = Map.mergeWithKey (\k a b -> if a == b then Just a else Nothing) (const Map.empty) (const Map.empty) -- IntMap instances instance LeftReductiveMonoid (IntMap.IntMap a) where isPrefixOf = IntMap.isSubmapOfBy (\_ _-> True) stripPrefix a b | IntMap.isSubmapOfBy (\_ _-> True) a b = Just (b IntMap.\\ a) | otherwise = Nothing instance Eq a => LeftGCDMonoid (IntMap.IntMap a) where commonPrefix = IntMap.mergeWithKey (\k a b -> if a == b then Just a else Nothing) (const IntMap.empty) (const IntMap.empty) -- List instances instance Eq x => LeftReductiveMonoid [x] where stripPrefix = List.stripPrefix isPrefixOf = List.isPrefixOf instance Eq x => LeftCancellativeMonoid [x] instance Eq x => LeftGCDMonoid [x] where commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys commonPrefix _ _ = [] stripCommonPrefix x y = strip' id x y where strip' f (x:xs) (y:ys) | x == y = strip' (f . (x :)) xs ys strip' f x y = (f [], x, y) -- Seq instances instance Eq a => LeftReductiveMonoid (Sequence.Seq a) where stripPrefix p s | p == s1 = Just s2 | otherwise = Nothing where (s1, s2) = Sequence.splitAt (Sequence.length p) s instance Eq a => RightReductiveMonoid (Sequence.Seq a) where stripSuffix p s | p == s2 = Just s1 | otherwise = Nothing where (s1, s2) = Sequence.splitAt (Sequence.length s - Sequence.length p) s instance Eq a => LeftCancellativeMonoid (Sequence.Seq a) instance Eq a => RightCancellativeMonoid (Sequence.Seq a) instance Eq a => LeftGCDMonoid (Sequence.Seq a) where stripCommonPrefix = findCommonPrefix Sequence.empty where findCommonPrefix prefix a b = case (Sequence.viewl a, Sequence.viewl b) of (a1: findCommonPrefix (prefix |> a1) a' b' _ -> (prefix, a, b) instance Eq a => RightGCDMonoid (Sequence.Seq a) where stripCommonSuffix = findCommonSuffix Sequence.empty where findCommonSuffix suffix a b = case (Sequence.viewr a, Sequence.viewr b) of (a':>a1, b':>b1) | a1 == b1 -> findCommonSuffix (a1 <| suffix) a' b' _ -> (a, b, suffix) -- Vector instances instance Eq a => LeftReductiveMonoid (Vector.Vector a) where stripPrefix p l | prefixLength > Vector.length l = Nothing | otherwise = strip 0 where strip i | i == prefixLength = Just (Vector.drop prefixLength l) | l Vector.! i == p Vector.! i = strip (succ i) | otherwise = Nothing prefixLength = Vector.length p isPrefixOf p l | prefixLength > Vector.length l = False | otherwise = test 0 where test i | i == prefixLength = True | l Vector.! i == p Vector.! i = test (succ i) | otherwise = False prefixLength = Vector.length p instance Eq a => RightReductiveMonoid (Vector.Vector a) where stripSuffix s l | suffixLength > Vector.length l = Nothing | otherwise = strip (pred suffixLength) where strip i | i == -1 = Just (Vector.take lengthDifference l) | l Vector.! (lengthDifference + i) == s Vector.! i = strip (pred i) | otherwise = Nothing suffixLength = Vector.length s lengthDifference = Vector.length l - suffixLength isSuffixOf s l | suffixLength > Vector.length l = False | otherwise = test (pred suffixLength) where test i | i == -1 = True | l Vector.! (lengthDifference + i) == s Vector.! i = test (pred i) | otherwise = False suffixLength = Vector.length s lengthDifference = Vector.length l - suffixLength instance Eq a => LeftCancellativeMonoid (Vector.Vector a) instance Eq a => RightCancellativeMonoid (Vector.Vector a) instance Eq a => LeftGCDMonoid (Vector.Vector a) where stripCommonPrefix x y = (xp, xs, Vector.drop maxPrefixLength y) where maxPrefixLength = prefixLength 0 (Vector.length x `min` Vector.length y) prefixLength n len | n < len && x Vector.! n == y Vector.! n = prefixLength (succ n) len prefixLength n _ = n (xp, xs) = Vector.splitAt maxPrefixLength x instance Eq a => RightGCDMonoid (Vector.Vector a) where stripCommonSuffix x y = findSuffix (Vector.length x - 1) (Vector.length y - 1) where findSuffix m n | m >= 0 && n >= 0 && x Vector.! m == y Vector.! n = findSuffix (pred m) (pred n) findSuffix m n = (Vector.take (succ m) x, yp, ys) where (yp, ys) = Vector.splitAt (succ n) y -- ByteString instances instance LeftReductiveMonoid ByteString.ByteString where stripPrefix p l = if ByteString.isPrefixOf p l then Just (ByteString.unsafeDrop (ByteString.length p) l) else Nothing isPrefixOf = ByteString.isPrefixOf instance RightReductiveMonoid ByteString.ByteString where stripSuffix s l = if ByteString.isSuffixOf s l then Just (ByteString.unsafeTake (ByteString.length l - ByteString.length s) l) else Nothing isSuffixOf = ByteString.isSuffixOf instance LeftCancellativeMonoid ByteString.ByteString instance RightCancellativeMonoid ByteString.ByteString instance LeftGCDMonoid ByteString.ByteString where stripCommonPrefix x y = (xp, xs, ByteString.unsafeDrop maxPrefixLength y) where maxPrefixLength = prefixLength 0 (ByteString.length x `min` ByteString.length y) prefixLength n len | n < len, ByteString.unsafeIndex x n == ByteString.unsafeIndex y n = prefixLength (succ n) len | otherwise = n (xp, xs) = ByteString.splitAt maxPrefixLength x instance RightGCDMonoid ByteString.ByteString where stripCommonSuffix x y = findSuffix (ByteString.length x - 1) (ByteString.length y - 1) where findSuffix m n | m >= 0, n >= 0, ByteString.unsafeIndex x m == ByteString.unsafeIndex y n = findSuffix (pred m) (pred n) | otherwise = let (yp, ys) = ByteString.splitAt (succ n) y in (ByteString.unsafeTake (succ m) x, yp, ys) -- Lazy ByteString instances instance LeftReductiveMonoid LazyByteString.ByteString where stripPrefix p l = if LazyByteString.isPrefixOf p l then Just (LazyByteString.drop (LazyByteString.length p) l) else Nothing isPrefixOf = LazyByteString.isPrefixOf instance RightReductiveMonoid LazyByteString.ByteString where stripSuffix s l = if LazyByteString.isSuffixOf s l then Just (LazyByteString.take (LazyByteString.length l - LazyByteString.length s) l) else Nothing isSuffixOf = LazyByteString.isSuffixOf instance LeftCancellativeMonoid LazyByteString.ByteString instance RightCancellativeMonoid LazyByteString.ByteString instance LeftGCDMonoid LazyByteString.ByteString where stripCommonPrefix x y = (xp, xs, LazyByteString.drop maxPrefixLength y) where maxPrefixLength = prefixLength 0 (LazyByteString.length x `min` LazyByteString.length y) prefixLength n len | n < len && LazyByteString.index x n == LazyByteString.index y n = prefixLength (succ n) len prefixLength n _ = n (xp, xs) = LazyByteString.splitAt maxPrefixLength x instance RightGCDMonoid LazyByteString.ByteString where stripCommonSuffix x y = findSuffix (LazyByteString.length x - 1) (LazyByteString.length y - 1) where findSuffix m n | m >= 0 && n >= 0 && LazyByteString.index x m == LazyByteString.index y n = findSuffix (pred m) (pred n) findSuffix m n = (LazyByteString.take (succ m) x, yp, ys) where (yp, ys) = LazyByteString.splitAt (succ n) y -- Text instances instance LeftReductiveMonoid Text.Text where stripPrefix = Text.stripPrefix isPrefixOf = Text.isPrefixOf instance RightReductiveMonoid Text.Text where stripSuffix = Text.stripSuffix isSuffixOf = Text.isSuffixOf instance LeftCancellativeMonoid Text.Text instance RightCancellativeMonoid Text.Text instance LeftGCDMonoid Text.Text where stripCommonPrefix x y = maybe (Text.empty, x, y) id (Text.commonPrefixes x y) -- Lazy Text instances instance LeftReductiveMonoid LazyText.Text where stripPrefix = LazyText.stripPrefix isPrefixOf = LazyText.isPrefixOf instance RightReductiveMonoid LazyText.Text where stripSuffix = LazyText.stripSuffix isSuffixOf = LazyText.isSuffixOf instance LeftCancellativeMonoid LazyText.Text instance RightCancellativeMonoid LazyText.Text instance LeftGCDMonoid LazyText.Text where stripCommonPrefix x y = maybe (LazyText.empty, x, y) id (LazyText.commonPrefixes x y) monoid-subclasses-0.3.5/Data/Monoid/Textual.hs0000644000000000000000000003374612251733717017444 0ustar0000000000000000{- Copyright 2013 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'TextualMonoid' class and its most important instances for 'String' and 'Text'. -- {-# LANGUAGE FlexibleInstances #-} module Data.Monoid.Textual ( TextualMonoid(..) ) where import Prelude hiding (foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1, map, concatMap, break, span) import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable import Data.Maybe (fromJust) import Data.Either (rights) 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, mconcat, mempty)) import qualified Data.Sequence as Sequence import qualified Data.Vector as Vector import Data.String (IsString(fromString)) import Data.Monoid.Null (MonoidNull (null)) import Data.Monoid.Cancellative (LeftReductiveMonoid, LeftGCDMonoid) import Data.Monoid.Factorial (FactorialMonoid) import qualified Data.Monoid.Factorial as Factorial -- | 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 -- -- 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. 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) -- -- A minimal instance definition must implement 'splitCharacterPrefix'. class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where -- | Contructs a new data type instance Like 'fromString', but from a 'Text' input instead of 'String'. -- -- > fromText == fromString . Text.unpack fromText :: Text -> t -- | Creates a prime monoid containing a single character. -- -- > singleton c == fromString [c] singleton :: Char -> t -- | Specialized version of 'Factorial.splitPrimePrefix'. Every prime factor of a 'Textual' monoid must consist of a -- single character or no character at all. splitCharacterPrefix :: t -> Maybe (Char, t) -- | Extracts a single character that prefixes the monoid, if the monoid begins with a character. Otherwise returns -- 'Nothing'. -- -- > characterPrefix == fmap fst . splitCharacterPrefix characterPrefix :: t -> Maybe Char -- | Equivalent to 'List.map' from "Data.List" with a @Char -> Char@ function. Preserves all non-character data. -- -- > map f == concatMap (singleton . f) map :: (Char -> Char) -> t -> t -- | Equivalent to 'List.concatMap' from "Data.List" with a @Char -> String@ function. Preserves all non-character -- data. concatMap :: (Char -> t) -> t -> t -- | 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.foldr' 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) -- | 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 fromText = fromString . Text.unpack singleton = fromString . (:[]) characterPrefix = fmap fst . splitCharacterPrefix map f = concatMap (singleton . f) concatMap f = foldr mappend (mappend . f) mempty 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)) 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)) split p m = prefix : splitRest where (prefix, rest) = break (const False) p m splitRest = case splitCharacterPrefix rest of Nothing -> [] Just (_, tail) -> split p tail find p = foldr (const id) (\c r-> if p c then Just c else r) Nothing 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 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 find = List.find 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 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 split = Text.split find = Text.find 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 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 split = LazyText.split find = LazyText.find instance IsString (Sequence.Seq Char) where fromString = Sequence.fromList 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.:< rest -> Just c map = Traversable.fmapDefault concatMap = Foldable.foldMap 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 find = Foldable.find 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 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 = (a', c':l) where (a', c') = f a c mapAccumR f a0 t = (a, Vector.fromList l) where (a, l) = Vector.foldr fc (a0, []) t fc c (a, l) = (a', c':l) where (a', c') = f a c takeWhile _ = Vector.takeWhile dropWhile _ = Vector.dropWhile break _ = Vector.break span _ = Vector.span find = Vector.find monoid-subclasses-0.3.5/Data/Monoid/Null.hs0000644000000000000000000000757012251733717016724 0ustar0000000000000000{- Copyright 2011-2013 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the MonoidNull class and some of its instances. -- {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Null ( MonoidNull(..), PositiveMonoid ) where import Prelude hiding (null) import Data.Monoid (Monoid(mempty), First(..), Last(..), Dual(..), Sum(..), Product(..), All(getAll), Any(getAny)) import qualified Data.List as List import Data.Ord (Ordering(EQ)) 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 -- | 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 '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 [x] where null = List.null instance MonoidNull ByteString.ByteString where null = ByteString.null instance MonoidNull LazyByteString.ByteString where null = LazyByteString.null instance MonoidNull Text.Text where null = Text.null instance MonoidNull LazyText.Text where null = LazyText.null instance Ord k => MonoidNull (Map.Map k v) where null = Map.null instance MonoidNull (IntMap.IntMap v) where null = IntMap.null instance MonoidNull IntSet.IntSet where null = IntSet.null instance MonoidNull (Sequence.Seq a) where null = Sequence.null instance Ord a => MonoidNull (Set.Set a) where null = Set.null instance MonoidNull (Vector.Vector a) where null = Vector.null instance PositiveMonoid () instance PositiveMonoid Ordering instance PositiveMonoid All instance PositiveMonoid Any instance PositiveMonoid ByteString.ByteString instance PositiveMonoid LazyByteString.ByteString instance PositiveMonoid Text.Text instance PositiveMonoid LazyText.Text instance Monoid a => PositiveMonoid (Maybe a) instance PositiveMonoid (First a) instance PositiveMonoid (Last a) instance PositiveMonoid a => PositiveMonoid (Dual a) instance PositiveMonoid [x] instance Ord k => PositiveMonoid (Map.Map k v) instance PositiveMonoid (IntMap.IntMap v) instance PositiveMonoid IntSet.IntSet instance PositiveMonoid (Sequence.Seq a) instance Ord a => PositiveMonoid (Set.Set a) instance PositiveMonoid (Vector.Vector a) -- Both instances are not allowed, so we leave the choice to the user. -- -- instance (PositiveMonoid a, Monoid b) => PositiveMonoid (a, b) -- instance (Monoid a, PositiveMonoid b) => PositiveMonoid (a, b) monoid-subclasses-0.3.5/Data/Monoid/Instances/0000755000000000000000000000000012251733717017374 5ustar0000000000000000monoid-subclasses-0.3.5/Data/Monoid/Instances/Measured.hs0000644000000000000000000001237112251733717021501 0ustar0000000000000000{- Copyright 2013 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Measured'. -- {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Measured ( Measured, inject, extract ) where import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) import Data.Functor ((<$>)) import qualified Data.List as List import Data.String (IsString(..)) import Data.Monoid (Monoid(..), (<>), First(..), Sum(..)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual -- | @'Measured' a@ is a wrapper around the 'FactorialMonoid' @a@ that memoizes the monoid's 'length' so it becomes a -- constant-time operation. The parameter is restricted to the 'StableFactorialMonoid' class, which guarantees that -- @'length' (a <> b) == 'length' a + 'length' b@. data Measured a = Measured{measuredLength :: Int, extract :: a} deriving (Eq, Show) inject :: FactorialMonoid a => a -> Measured a inject x = Measured (length x) x instance Ord a => Ord (Measured a) where compare (Measured _ x) (Measured _ y) = compare x y instance StableFactorialMonoid a => Monoid (Measured a) where mempty = Measured 0 mempty mappend (Measured m a) (Measured n b) = Measured (m + n) (mappend a b) instance StableFactorialMonoid a => MonoidNull (Measured a) where null (Measured n x) = n == 0 instance StableFactorialMonoid a => PositiveMonoid (Measured a) instance (LeftReductiveMonoid a, StableFactorialMonoid a) => LeftReductiveMonoid (Measured a) where stripPrefix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripPrefix x y) instance (RightReductiveMonoid a, StableFactorialMonoid a) => RightReductiveMonoid (Measured a) where stripSuffix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripSuffix x y) instance (LeftGCDMonoid a, StableFactorialMonoid a) => LeftGCDMonoid (Measured a) where commonPrefix (Measured _ x) (Measured _ y) = inject (commonPrefix x y) instance (RightGCDMonoid a, StableFactorialMonoid a) => RightGCDMonoid (Measured a) where commonSuffix (Measured _ x) (Measured _ y) = inject (commonSuffix x y) instance StableFactorialMonoid a => FactorialMonoid (Measured a) where factors (Measured _ x) = List.map (Measured 1) (factors x) primePrefix m@(Measured _ x) = if null x then m else Measured 1 (primePrefix x) primeSuffix m@(Measured _ x) = if null x then m else Measured 1 (primeSuffix x) splitPrimePrefix (Measured n x) = case splitPrimePrefix x of Nothing -> Nothing Just (p, s) -> Just (Measured 1 p, Measured (n - 1) s) splitPrimeSuffix (Measured n x) = case splitPrimeSuffix x of Nothing -> Nothing Just (p, s) -> Just (Measured (n - 1) p, Measured 1 s) foldl f a (Measured _ x) = Factorial.foldl g a x where g a = f a . Measured 1 foldl' f a (Measured _ x) = Factorial.foldl' g a x where g a = f a . Measured 1 foldr f a (Measured _ x) = Factorial.foldr g a x where g = f . Measured 1 length (Measured n _) = n foldMap f (Measured _ x) = Factorial.foldMap (f . Measured 1) x span p (Measured n x) = (xp', xs') where (xp, xs) = Factorial.span (p . Measured 1) x xp' = inject xp xs' = Measured (n - length xp') xs split p (Measured _ x) = inject <$> Factorial.split (p . Measured 1) x splitAt m (Measured n x) | m <= 0 = (mempty, Measured n x) | m >= n = (Measured n x, mempty) | otherwise = (Measured m xp, Measured (n - m) xs) where (xp, xs) = splitAt m x reverse (Measured n x) = Measured n (reverse x) instance StableFactorialMonoid a => StableFactorialMonoid (Measured a) instance (FactorialMonoid a, IsString a) => IsString (Measured a) where fromString = inject . fromString instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Measured a) where fromText = inject . 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 a (Measured _ x) = Textual.foldl (\a-> ft a . Measured 1) fc a x foldl' ft fc a (Measured _ x) = Textual.foldl' (\a-> ft a . Measured 1) fc a x foldr ft fc a (Measured _ x) = Textual.foldr (ft . Measured 1) fc a x span pt pc (Measured n x) = (xp', xs') where (xp, xs) = Textual.span (pt . Measured 1) pc x xp' = inject xp xs' = Measured (n - length xp') xs break pt pc = Textual.span (not . pt) (not . pc) find p (Measured _ x) = find p x monoid-subclasses-0.3.5/Data/Monoid/Instances/Stateful.hs0000644000000000000000000001461212251733717021523 0ustar0000000000000000{- Copyright 2013 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Stateful'. -- {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Stateful ( Stateful(Stateful), inject, extract, state, setState ) where import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) import Data.Functor ((<$>)) import qualified Data.List as List import Data.String (IsString(..)) import Data.Monoid (Monoid(..), (<>), First(..), Sum(..)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), ReductiveMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..), GCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual -- | @'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. data Stateful a b = Stateful (b, a) deriving (Eq, Ord, Show) inject :: Monoid a => b -> Stateful a b inject m = Stateful (m, mempty) 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 (Monoid a, Monoid b) => Monoid (Stateful a b) where mempty = Stateful mempty mappend (Stateful x) (Stateful y) = Stateful (x <> y) instance (MonoidNull a, MonoidNull b) => MonoidNull (Stateful a b) where null (Stateful x) = null x instance (PositiveMonoid a, PositiveMonoid b) => PositiveMonoid (Stateful a b) instance (LeftReductiveMonoid a, LeftReductiveMonoid b) => LeftReductiveMonoid (Stateful a b) where stripPrefix (Stateful x) (Stateful x') = Stateful <$> stripPrefix x x' instance (RightReductiveMonoid a, RightReductiveMonoid b) => RightReductiveMonoid (Stateful a b) where stripSuffix (Stateful x) (Stateful x') = Stateful <$> stripSuffix x x' instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (Stateful a b) where commonPrefix (Stateful x) (Stateful x') = Stateful (commonPrefix x x') instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (Stateful a b) where commonSuffix (Stateful x) (Stateful x') = Stateful (commonSuffix x x') instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (Stateful a b) where factors (Stateful x) = List.map Stateful (factors x) length (Stateful x) = length x reverse (Stateful x) = Stateful (reverse x) primePrefix (Stateful x) = Stateful (primePrefix x) primeSuffix (Stateful x) = Stateful (primeSuffix x) splitPrimePrefix (Stateful x) = do (xp, xs) <- splitPrimePrefix x return (Stateful xp, Stateful xs) splitPrimeSuffix (Stateful x) = do (xp, xs) <- splitPrimeSuffix x return (Stateful xp, Stateful xs) foldl f a (Stateful x) = Factorial.foldl f' a x where f' a x = f a (Stateful x) foldl' f a (Stateful x) = Factorial.foldl' f' a x where f' a x = f a (Stateful x) foldr f a (Stateful x) = Factorial.foldr (f . Stateful) a x foldMap f (Stateful x) = Factorial.foldMap (f . Stateful) x span p (Stateful x) = (Stateful xp, Stateful xs) where (xp, xs) = Factorial.span (p . Stateful) x split p (Stateful x) = List.map Stateful (Factorial.split (p . Stateful) x) splitAt m (Stateful x) = (Stateful xp, Stateful xs) where (xp, xs) = splitAt m x instance (StableFactorialMonoid a, StableFactorialMonoid b) => StableFactorialMonoid (Stateful a b) instance (Monoid a, IsString b) => IsString (Stateful a b) where fromString = inject . 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 = Textual.all p . extract any p = Textual.any p . extract foldl fx fc a (Stateful (t, x)) = Factorial.foldl f2 (Textual.foldl f1 fc a 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 a (Stateful (t, x)) = a' `seq` Factorial.foldl' f2 a' x where a' = Textual.foldl' f1 fc a t f1 a = fx a . fromFst f2 a = fx a . fromSnd 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) 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) split p (Stateful (t, x)) = restore id ts where ts = Textual.split p t restore f [t] = f [Stateful (t, x)] restore f (hd:tl) = restore (f . (Stateful (hd, mempty):)) tl find p = find p . extract {-# INLINE fromFst #-} fromFst :: Monoid b => a -> Stateful b a fromFst a = Stateful (a, mempty) {-# INLINE fromSnd #-} fromSnd :: Monoid a => b -> Stateful b a fromSnd b = Stateful (mempty, b) monoid-subclasses-0.3.5/Data/Monoid/Instances/Concat.hs0000644000000000000000000002405112251733717021141 0ustar0000000000000000{- Copyright 2011-2013 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Concat'. -- {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Concat ( Concat, inject, extract ) where import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) import Data.Foldable (Foldable) import Data.Traversable (Traversable, traverse) import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable import Data.Maybe (fromMaybe) import Data.String (IsString(..)) import Data.Monoid (Monoid(..), (<>), First(..), Sum(..)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Data.Sequence (Seq, empty, filter, (<|), (|>), ViewL((:<)), ViewR((:>))) import qualified Data.Sequence as Seq -- | @'Concat' a@ is a @newtype@ wrapper around @'Seq' a@. The behaviour of the @'Concat' a@ instances of monoid -- subclasses is identical to the behaviour of their @a@ instances, up to the @'inject' . 'singleton'@ isomorphism. -- -- The only purpose of 'Concat' then is to change the performance characteristics of various operations. Most -- importantly, injecting a monoid into a 'Concat' has the effect of making 'mappend' a constant-time operation. -- newtype Concat a = Concat {extract :: Seq a} deriving Show instance (Eq a, Monoid a) => Eq (Concat a) where Concat x == Concat y = Foldable.foldMap id x == Foldable.foldMap id y instance (Ord a, Monoid a) => Ord (Concat a) where compare (Concat x) (Concat y) = compare (Foldable.foldMap id x) (Foldable.foldMap id y) instance Monoid (Concat a) where mempty = Concat Seq.empty mappend (Concat a) (Concat b) = Concat (mappend a b) instance MonoidNull (Concat a) where null (Concat x) = Seq.null x instance PositiveMonoid (Concat a) instance (LeftReductiveMonoid a, MonoidNull a, StableFactorialMonoid a) => LeftReductiveMonoid (Concat a) where stripPrefix (Concat x) (Concat y) = fmap Concat $ strip1 x y where strip1 x y = strip2 (Seq.viewl x) y strip2 Seq.EmptyL y = Just y strip2 (xp :< xs) y = strip3 xp xs (Seq.viewl y) strip3 _ _ Seq.EmptyL = Nothing strip3 xp xs (yp :< ys) = case (stripPrefix xp yp, stripPrefix yp xp) of (Just yps, _) -> strip1 xs (if null yps then ys else yps <| ys) (Nothing, Nothing) -> Nothing (Nothing, Just xps) -> strip3 xps xs (Seq.viewl ys) instance (MonoidNull a, RightReductiveMonoid a, StableFactorialMonoid a) => RightReductiveMonoid (Concat a) where stripSuffix (Concat x) (Concat y) = fmap Concat $ strip1 x y where strip1 x y = strip2 (Seq.viewr x) y strip2 Seq.EmptyR y = Just y strip2 (xp :> xs) y = strip3 xp xs (Seq.viewr y) strip3 _ _ Seq.EmptyR = Nothing strip3 xp xs (yp :> ys) = case (stripSuffix xs ys, stripSuffix ys xs) of (Just ysp, _) -> strip1 xp (if null ysp then yp else yp |> ysp) (Nothing, Nothing) -> Nothing (Nothing, Just xsp) -> strip3 xp xsp (Seq.viewr yp) instance (Eq a, LeftGCDMonoid a, MonoidNull a, StableFactorialMonoid a) => LeftGCDMonoid (Concat a) where stripCommonPrefix (Concat x) (Concat y) = strip cp1 xs1 ys1 where (cp1, xs1, ys1) = stripCommonPrefix x y strip cp xs ys = case (Seq.viewl xs, Seq.viewl ys) of (Seq.EmptyL, _) -> (Concat cp, mempty, Concat ys) (_, Seq.EmptyL) -> (Concat cp, Concat xs, mempty) (xsp :< xss, ysp :< yss) -> let (cs, xsps, ysps) = stripCommonPrefix xsp ysp cp' = cp |> cs prepend p s = if null p then s else p <| s in if null cs then (Concat cp, Concat xs, Concat ys) else if null xsps && null ysps then strip cp' xss yss else (Concat cp', Concat $ prepend xsps xss, Concat $ prepend ysps yss) instance (Eq a, RightGCDMonoid a, MonoidNull a, StableFactorialMonoid a) => RightGCDMonoid (Concat a) where stripCommonSuffix (Concat x) (Concat y) = strip xp1 yp1 cs1 where (xp1, yp1, cs1) = stripCommonSuffix x y strip xp yp cs = case (Seq.viewr xp, Seq.viewr yp) of (Seq.EmptyR, _) -> (mempty, Concat yp, Concat cs) (_, Seq.EmptyR) -> (Concat xp, mempty, Concat cs) (xpp :> xps, ypp :> yps) -> let (xpsp, ypsp, cp) = stripCommonSuffix xps yps cs' = cp <| cs append p s = if null s then p else p |> s in if null cp then (Concat xp, Concat yp, Concat cs) else if null xpsp && null ypsp then strip xpp ypp cs' else (Concat $ append xpp xpsp, Concat $ append ypp ypsp, Concat cs') instance FactorialMonoid a => FactorialMonoid (Concat a) where factors (Concat x) = Foldable.foldMap (fmap (Concat . Seq.singleton) . factors) x primePrefix (Concat x) = Concat (fmap primePrefix $ primePrefix x) primeSuffix (Concat x) = Concat (fmap primeSuffix $ primeSuffix x) splitPrimePrefix (Concat x) = case Seq.viewl x of Seq.EmptyL -> Nothing xp :< xs -> Just (Concat $ Seq.singleton xpp, Concat xs') where Just (xpp, xps) = splitPrimePrefix xp xs' = if null xps then xs else xps <| xs splitPrimeSuffix (Concat x) = case Seq.viewr x of Seq.EmptyR -> Nothing xp :> xs -> Just (Concat xp', Concat $ Seq.singleton xss) where Just (xsp, xss) = splitPrimeSuffix xs xp' = if null xsp then xp else xp |> xsp foldl f a (Concat x) = Foldable.foldl g a x where g = Factorial.foldl (\a-> f a . Concat . Seq.singleton) foldl' f a (Concat x) = Foldable.foldl' g a x where g = Factorial.foldl' (\a-> f a . Concat . Seq.singleton) foldr f a (Concat x) = Foldable.foldr g a x where g a b = Factorial.foldr (f . Concat . Seq.singleton) b a length (Concat x) = getSum $ Foldable.foldMap (Sum . length) x foldMap f (Concat x) = Foldable.foldMap (foldMap (f . Concat . Seq.singleton)) x span p (Concat x) = case Seq.viewl x of Seq.EmptyL -> (mempty, mempty) xp :< xs | null xps -> (Concat (xp <| xsp), xss) | null xpp -> (mempty, Concat x) | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs)) where (xpp, xps) = Factorial.span (p . Concat . Seq.singleton) xp (Concat xsp, xss) = Factorial.span p (Concat xs) split p (Concat x) = Foldable.foldr splitNext [mempty] x where splitNext a (xp:xs) = let as = fmap (Concat . Seq.singleton) (Factorial.split (p . Concat . Seq.singleton) a) in if null xp then as ++ xs else init as ++ (last as <> xp):xs splitAt 0 c = (mempty, c) splitAt n (Concat x) = case Seq.viewl x of Seq.EmptyL -> (mempty, mempty) xp :< xs | k < n -> (Concat (xp <| xsp), xss) | otherwise -> (Concat $ Seq.singleton xpp, Concat (if null xps then xs else xps <| xs)) where k = length xp (Concat xsp, xss) = splitAt (n - k) (Concat xs) (xpp, xps) = splitAt n xp reverse (Concat x) = Concat (fmap reverse $ reverse x) instance (IsString a) => IsString (Concat a) where fromString "" = Concat empty fromString s = Concat (Seq.singleton $ fromString s) instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Concat a) where fromText t | null t = Concat empty | otherwise = Concat (Seq.singleton $ fromText t) singleton = Concat . Seq.singleton . singleton splitCharacterPrefix (Concat x) = case Seq.viewl x of Seq.EmptyL -> Nothing xp :< xs -> case splitCharacterPrefix xp of Just (c, xps) -> Just (c, Concat $ if null xps then xs else xps <| xs) Nothing -> Nothing characterPrefix (Concat x) = case Seq.viewl x of Seq.EmptyL -> Nothing xp :< _ -> characterPrefix xp map f (Concat x) = Concat (fmap (map f) x) any p (Concat x) = Foldable.any (any p) x all p (Concat x) = Foldable.all (all p) x foldl ft fc a (Concat x) = Foldable.foldl g a x where g = Textual.foldl (\a-> ft a . Concat . Seq.singleton) fc foldl' ft fc a (Concat x) = Foldable.foldl' g a x where g = Textual.foldl' (\a-> ft a . Concat . Seq.singleton) fc foldr ft fc a (Concat x) = Foldable.foldr g a x where g a b = Textual.foldr (ft . Concat . Seq.singleton) fc b a span pt pc (Concat x) = case Seq.viewl x of Seq.EmptyL -> (mempty, mempty) xp :< xs | null xps -> (Concat (xp <| xsp), xss) | null xpp -> (mempty, Concat x) | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs)) where (xpp, xps) = Textual.span (pt . Concat . Seq.singleton) pc xp (Concat xsp, xss) = Textual.span pt pc (Concat xs) break pt pc = Textual.span (not . pt) (not . pc) find p (Concat x) = getFirst $ Foldable.foldMap (First . find p) x inject :: (MonoidNull a, PositiveMonoid a) => Seq a -> Concat a inject = Concat . filter (not . null) injectSingleton :: (MonoidNull a, PositiveMonoid a) => a -> Concat a injectSingleton a | null a = mempty | otherwise = Concat (Seq.singleton a) monoid-subclasses-0.3.5/Data/Monoid/Instances/ByteString/0000755000000000000000000000000012251733717021466 5ustar0000000000000000monoid-subclasses-0.3.5/Data/Monoid/Instances/ByteString/UTF8.hs0000644000000000000000000003244612251733717022561 0ustar0000000000000000{- Copyright 2013 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'ByteStringUTF8' newtype wrapper around 'ByteString', together with its 'TextualMonoid' -- instance. -- module Data.Monoid.Instances.ByteString.UTF8 ( ByteStringUTF8(..), decode ) where import Prelude hiding (drop, dropWhile, foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1, map, concatMap, break, span) import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Char (chr, ord) import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.Maybe (fromMaybe) 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.Unsafe (unsafeDrop, unsafeHead, unsafeTail, unsafeIndex) import Data.Monoid (Monoid(mempty, mappend)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), LeftCancellativeMonoid, LeftGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), 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(..)) newtype ByteStringUTF8 = ByteStringUTF8 ByteString deriving (Eq, Ord) -- | Takes a raw 'ByteString' chunk and returns a pair of 'ByteStringUTF8' decoding the prefix of the chunk and the -- remaining suffix that is either null or contains the incomplete last character of the chunk. decode :: ByteString -> (ByteStringUTF8, ByteString) decode bs | ByteString.null bs || l < 0x80 = (ByteStringUTF8 bs, mempty) | l >= 0xC0 = (ByteStringUTF8 (ByteString.init bs), ByteString.singleton l) | ByteString.null prefix = (mempty, bs) | otherwise = case toChar (ByteString.last prefix) suffix of Nothing -> (ByteStringUTF8 (ByteString.init prefix), drop (ByteString.length prefix - 1) bs) Just{} -> (ByteStringUTF8 bs, mempty) where (prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs l = ByteString.last bs instance Monoid ByteStringUTF8 where mempty = ByteStringUTF8 ByteString.empty ByteStringUTF8 a `mappend` ByteStringUTF8 b = ByteStringUTF8 (a `mappend` b) instance MonoidNull ByteStringUTF8 where null (ByteStringUTF8 b) = ByteString.null b instance LeftReductiveMonoid ByteStringUTF8 where stripPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = fmap ByteStringUTF8 (stripPrefix a b) ByteStringUTF8 a `isPrefixOf` ByteStringUTF8 b = a `isPrefixOf` b instance LeftCancellativeMonoid ByteStringUTF8 instance LeftGCDMonoid ByteStringUTF8 where commonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = ByteStringUTF8 (commonPrefix a b) stripCommonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = wrapTriple (stripCommonPrefix a b) instance Show ByteStringUTF8 where showsPrec _ bs s = '"' : Textual.foldr showsBytes (:) ('"' : s) bs where showsBytes (ByteStringUTF8 b) s = '\\' : shows (ByteString.unpack b) s instance IsString ByteStringUTF8 where fromString = ByteStringUTF8 . Foldable.foldMap fromChar instance PositiveMonoid ByteStringUTF8 instance FactorialMonoid ByteStringUTF8 where splitPrimePrefix utf8@(ByteStringUTF8 bs) | ByteString.null bs = Nothing | unsafeHead bs < 0x80 = Just (wrapPair $ ByteString.splitAt 1 bs) | otherwise = case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Just i -> Just (wrapPair $ ByteString.splitAt (succ i) bs) Nothing -> Just (utf8, ByteStringUTF8 $ ByteString.empty) splitPrimeSuffix utf8@(ByteStringUTF8 bs) | ByteString.null bs = Nothing | ByteString.null prefix = Just (wrapPair split) | not (ByteString.null suffix) && ByteString.last prefix < 0x80 = Just (wrapPair split) | otherwise = Just (wrapPair $ ByteString.splitAt (pred $ ByteString.length prefix) bs) where split@(prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs 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 factors (ByteStringUTF8 bs) = List.map ByteStringUTF8 $ ByteString.groupBy continued bs where continued a b = a >= 0x80 && b >= 0x80 && b < 0xC0 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) 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) 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) 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 splitAt n (ByteStringUTF8 bs) = wrapPair (ByteString.splitAt (charStartIndex n bs) bs) take n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.take (charStartIndex n bs) bs) drop n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.drop (charStartIndex n bs) bs) dropWhile p (ByteStringUTF8 bs) = dropASCII bs 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 takeWhile p utf8@(ByteStringUTF8 bs) = ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs where suffix@(ByteStringUTF8 s) = Factorial.dropWhile p utf8 span p utf8@(ByteStringUTF8 bs) = (ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs, suffix) where suffix@(ByteStringUTF8 s) = Factorial.dropWhile p utf8 break p = Factorial.span (not . p) reverse (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.concat $ List.reverse $ List.map reverseASCII $ groupASCII bs) where reverseASCII b | unsafeHead b < 0x80 = ByteString.reverse b | otherwise = b instance TextualMonoid ByteStringUTF8 where singleton = ByteStringUTF8 . fromChar splitCharacterPrefix (ByteStringUTF8 bs) = ByteString.uncons bs >>= uncurry toChar foldl ft fc a0 (ByteStringUTF8 bs) = List.foldl f a0 (groupASCII bs) where f a b = let hd = unsafeHead b in if hd < 0x80 then ByteString.Char8.foldl fc a b else maybe (ft a $ ByteStringUTF8 b) (fc a . fst) (toChar hd $ unsafeTail b) foldl' ft fc a0 (ByteStringUTF8 bs) = List.foldl' f a0 (groupASCII bs) where f a b = let hd = unsafeHead b in if hd < 0x80 then ByteString.Char8.foldl' fc a b else maybe (ft a $ ByteStringUTF8 b) (fc a . fst) (toChar hd $ unsafeTail b) foldr ft fc a0 (ByteStringUTF8 bs) = List.foldr f a0 (groupASCII bs) where f b a = let hd = unsafeHead b in if hd < 0x80 then ByteString.Char8.foldr fc a b else maybe (ft (ByteStringUTF8 b) a) (flip fc a . fst) (toChar hd $ unsafeTail b) 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 takeWhile pb pc utf8@(ByteStringUTF8 bs) = ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length suffix) bs where ByteStringUTF8 suffix = Textual.dropWhile pb pc utf8 span pb pc utf8@(ByteStringUTF8 bs) = wrapPair $ ByteString.splitAt (ByteString.length bs - ByteString.length suffix) bs where ByteStringUTF8 suffix = Textual.dropWhile pb pc utf8 break pb pc = Textual.span (not . pb) (not . pc) wrapPair (bs1, bs2) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2) wrapTriple (bs1, bs2, bs3) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2, ByteStringUTF8 bs3) 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)] where n = ord c toChar :: Word8 -> ByteString -> Maybe (Char, ByteStringUTF8) toChar hd tl | hd < 0x80 = Just (chr $ fromIntegral 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 < 0xF4 = do (b2, t2) <- ByteString.uncons tl (b1, t1) <- ByteString.uncons t2 (b0, t0) <- ByteString.uncons t1 if (hd > 0xF0 || 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 headIndex bs = fromMaybe (ByteString.length bs) $ ByteString.findIndex byteStartsCharacter bs byteStartsCharacter :: Word8 -> Bool byteStartsCharacter b = b < 0x80 || b >= 0xC0 charStartIndex :: Int -> ByteString -> Int charStartIndex n _ | n <= 0 = 0 charStartIndex n bs = case List.drop (pred n) (ByteString.findIndices byteStartsCharacter $ ByteString.drop 1 bs) of [] -> ByteString.length bs k:_ -> succ k