monoid-subclasses-0.4.2.1/0000755000000000000000000000000012717754212013504 5ustar0000000000000000monoid-subclasses-0.4.2.1/BSD3-LICENSE.txt0000644000000000000000000000272112717754212016022 0ustar0000000000000000Copyright (c) 2012-2013, Mario Blazevic All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of {{the ORGANIZATION nor the names of its contributors}} may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY {{THE COPYRIGHT HOLDERS AND CONTRIBUTORS}} "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL {{THE COPYRIGHT HOLDER OR CONTRIBUTORS}} BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. monoid-subclasses-0.4.2.1/monoid-subclasses.cabal0000644000000000000000000000363612717754212020132 0ustar0000000000000000Name: monoid-subclasses Version: 0.4.2.1 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid Category: Data, Algebra, Text Tested-with: GHC Description: A hierarchy of subclasses of 'Monoid' together with their instances for all data structures from base, containers, and text packages. License: BSD3 License-file: BSD3-LICENSE.txt Copyright: (c) 2013-2015 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.Positioned, Data.Monoid.Instances.Stateful Build-Depends: base >= 4.5 && < 5, bytestring >= 0.9 && < 1.0, containers >= 0.5.7.0 && < 0.6, text >= 0.11 && < 1.3, primes == 0.2.*, vector >= 0.9 && < 0.12 GHC-options: -Wall default-language: Haskell2010 test-suite Main Type: exitcode-stdio-1.0 Build-Depends: base >= 4.5 && < 5, bytestring >= 0.9 && < 1.0, containers >= 0.5.7.0 && < 0.6, text >= 0.11 && < 1.3, vector >= 0.9 && < 0.12, primes == 0.2.*, QuickCheck == 2.*, quickcheck-instances >= 0.3.12 && <0.4, tasty >= 0.7, tasty-quickcheck >= 0.7, monoid-subclasses Main-is: Test/TestMonoidSubclasses.hs default-language: Haskell2010 monoid-subclasses-0.4.2.1/Setup.lhs0000644000000000000000000000011712717754212015313 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain monoid-subclasses-0.4.2.1/Test/0000755000000000000000000000000012717754212014423 5ustar0000000000000000monoid-subclasses-0.4.2.1/Test/TestMonoidSubclasses.hs0000644000000000000000000013735512717754212021112 0ustar0000000000000000{- Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} {-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} module Main where import Prelude hiding (foldl, foldr, gcd, length, null, reverse, span, splitAt, takeWhile) import Test.Tasty (defaultMain, testGroup) import Test.Tasty.QuickCheck (Arbitrary, CoArbitrary, Property, Gen, arbitrary, coarbitrary, property, label, forAll, mapSize, testProperty, variant, whenFail, (.&&.)) import Test.QuickCheck.Instances () import Control.Applicative (Applicative(..), liftA2) import Data.Functor ((<$>)) import Data.Foldable (toList) import Data.Int (Int8, Int32) import qualified Data.Foldable as Foldable import Data.Traversable (Traversable) import Data.List (intersperse, unfoldr) import qualified Data.List as List import Data.Maybe (isJust) import Data.Either (lefts, rights) import Data.Tuple (swap) import Data.String (IsString, fromString) import Data.Char (isLetter) import Data.Int (Int16) import Data.Word (Word, Word8) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as Lazy (ByteString) import Data.Text (Text) import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.Text as Text import qualified Data.Sequence as Sequence import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Map (Map) import Data.Sequence (Seq) import Data.Set (Set) import Data.Vector (Vector, fromList) import Text.Show.Functions import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(ByteStringUTF8)) import Data.Monoid.Instances.Concat (Concat) import qualified Data.Monoid.Instances.Concat as Concat import Data.Monoid.Instances.Measured (Measured) import qualified Data.Monoid.Instances.Measured as Measured import Data.Monoid.Instances.Stateful (Stateful) import qualified Data.Monoid.Instances.Stateful as Stateful import Data.Monoid.Instances.Positioned (OffsetPositioned, LinePositioned) import qualified Data.Monoid.Instances.Positioned as Positioned import Data.Monoid (Monoid, mempty, (<>), mconcat, All(All), Any(Any), Dual(Dual), First(First), Last(Last), Sum(Sum), Product(Product)) import Data.Monoid.Null (MonoidNull, PositiveMonoid, null) import Data.Monoid.Factorial (FactorialMonoid, StableFactorialMonoid, factors, splitPrimePrefix, splitPrimeSuffix, primePrefix, primeSuffix, inits, tails, foldl, foldl', foldr, length, reverse, span, spanMaybe, split, splitAt) import Data.Monoid.Cancellative (CommutativeMonoid, ReductiveMonoid, LeftReductiveMonoid, RightReductiveMonoid, CancellativeMonoid, LeftCancellativeMonoid, RightCancellativeMonoid, GCDMonoid, LeftGCDMonoid, RightGCDMonoid, (), gcd, isPrefixOf, stripPrefix, commonPrefix, stripCommonPrefix, isSuffixOf, stripSuffix, commonSuffix, stripCommonSuffix) import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Textual as Textual data Test = CommutativeTest (CommutativeMonoidInstance -> Property) | NullTest (NullMonoidInstance -> Property) | PositiveTest (PositiveMonoidInstance -> Property) | FactorialTest (FactorialMonoidInstance -> Property) | StableFactorialTest (StableFactorialMonoidInstance -> Property) | TextualTest (TextualMonoidInstance -> Property) | LeftReductiveTest (LeftReductiveMonoidInstance -> Property) | RightReductiveTest (RightReductiveMonoidInstance -> Property) | ReductiveTest (ReductiveMonoidInstance -> Property) | LeftCancellativeTest (LeftCancellativeMonoidInstance -> Property) | RightCancellativeTest (RightCancellativeMonoidInstance -> Property) | CancellativeTest (CancellativeMonoidInstance -> Property) | LeftGCDTest (LeftGCDMonoidInstance -> Property) | RightGCDTest (RightGCDMonoidInstance -> Property) | GCDTest (GCDMonoidInstance -> Property) | CancellativeGCDTest (CancellativeGCDMonoidInstance -> Property) data CommutativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CommutativeMonoid a) => CommutativeMonoidInstance a data NullMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => NullMonoidInstance a data PositiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, PositiveMonoid a) => PositiveMonoidInstance a data FactorialMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => FactorialMonoidInstance a data StableFactorialMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, StableFactorialMonoid a) => StableFactorialMonoidInstance a data TextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => TextualMonoidInstance a data StableTextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, StableFactorialMonoid a, TextualMonoid a) => StableTextualMonoidInstance a data LeftReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => LeftReductiveMonoidInstance a data RightReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightReductiveMonoid a) => RightReductiveMonoidInstance a data ReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, ReductiveMonoid a) => ReductiveMonoidInstance a data LeftCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftCancellativeMonoid a) => LeftCancellativeMonoidInstance a data RightCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightCancellativeMonoid a) => RightCancellativeMonoidInstance a data CancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a) => CancellativeMonoidInstance a data LeftGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) => LeftGCDMonoidInstance a data RightGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightGCDMonoid a) => RightGCDMonoidInstance a data GCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, GCDMonoid a) => GCDMonoidInstance a data CancellativeGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a, GCDMonoid a) => CancellativeGCDMonoidInstance a commutativeInstances :: [CommutativeMonoidInstance] commutativeInstances = map upcast reductiveInstances ++ [CommutativeMonoidInstance (mempty :: Product Double)] where upcast (ReductiveMonoidInstance i) = CommutativeMonoidInstance i nullInstances :: [NullMonoidInstance] nullInstances = map upcast factorialInstances ++ [NullMonoidInstance (mempty :: Ordering), NullMonoidInstance (mempty :: All), NullMonoidInstance (mempty :: Any), NullMonoidInstance (mempty :: Sum Float), NullMonoidInstance (mempty :: Product Int), NullMonoidInstance (mempty :: First Int), NullMonoidInstance (mempty :: Last Int), NullMonoidInstance (mempty :: Concat Any), NullMonoidInstance (mempty :: Concat (Dual String)), NullMonoidInstance (mempty :: Concat (Map String Int))] where upcast (FactorialMonoidInstance i) = NullMonoidInstance i positiveInstances = map upcast stableFactorialInstances ++ [PositiveMonoidInstance (mempty :: ()), PositiveMonoidInstance (mempty :: Ordering), PositiveMonoidInstance (mempty :: All), PositiveMonoidInstance (mempty :: Any), PositiveMonoidInstance (mempty :: (Maybe (Sum 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 ++ map position stable1 where stable1 = map upcast stableTextualInstances ++ [StableFactorialMonoidInstance (mempty :: ByteString), StableFactorialMonoidInstance (mempty :: Lazy.ByteString), StableFactorialMonoidInstance (mempty :: Dual String), StableFactorialMonoidInstance (mempty :: Seq Int), StableFactorialMonoidInstance (mempty :: Vector Int)] upcast (StableTextualMonoidInstance i) = StableFactorialMonoidInstance i measure (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (Measured.measure i) position (StableFactorialMonoidInstance (i :: a)) = StableFactorialMonoidInstance (pure i :: OffsetPositioned a) textualInstances :: [TextualMonoidInstance] textualInstances = map upcast stableTextualInstances ++ [TextualMonoidInstance (mempty :: ByteStringUTF8), TextualMonoidInstance (mempty :: Text), TextualMonoidInstance (mempty :: Lazy.Text), TextualMonoidInstance (mempty :: Seq Char), TextualMonoidInstance (mempty :: Vector Char), TextualMonoidInstance (mempty :: Stateful (IntMap Int) Text)] where upcast (StableTextualMonoidInstance i) = TextualMonoidInstance i stableTextualInstances :: [StableTextualMonoidInstance] stableTextualInstances = stable1 ++ map measure stable1 ++ concatMap position stable1 where stable1 = [StableTextualMonoidInstance (mempty :: TestString), StableTextualMonoidInstance (mempty :: String), StableTextualMonoidInstance (mempty :: Text), StableTextualMonoidInstance (mempty :: Lazy.Text), StableTextualMonoidInstance (mempty :: Seq Char), StableTextualMonoidInstance (mempty :: Vector Char)] measure (StableTextualMonoidInstance i) = StableTextualMonoidInstance (Measured.measure i) position (StableTextualMonoidInstance (i :: a)) = [StableTextualMonoidInstance (pure i :: OffsetPositioned a), StableTextualMonoidInstance (pure i :: LinePositioned a)] leftReductiveInstances = map upcast leftCancellativeInstances ++ [LeftReductiveMonoidInstance (mempty :: Sum Integer), LeftReductiveMonoidInstance (mempty :: IntSet), LeftReductiveMonoidInstance (mempty :: Set Integer), LeftReductiveMonoidInstance (mempty :: Concat String), LeftReductiveMonoidInstance (mempty :: Concat ByteString), LeftReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), LeftReductiveMonoidInstance (mempty :: Concat Text), LeftReductiveMonoidInstance (mempty :: Concat Lazy.Text), LeftReductiveMonoidInstance (mempty :: Concat (Dual Text))] where upcast (LeftCancellativeMonoidInstance i) = LeftReductiveMonoidInstance i rightReductiveInstances = map upcast rightCancellativeInstances ++ [RightReductiveMonoidInstance (mempty :: Product Integer), RightReductiveMonoidInstance (mempty :: IntSet), RightReductiveMonoidInstance (mempty :: Set String), RightReductiveMonoidInstance (mempty :: Concat ByteString), RightReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), RightReductiveMonoidInstance (mempty :: Concat Text), RightReductiveMonoidInstance (mempty :: Concat Lazy.Text), RightReductiveMonoidInstance (mempty :: Concat (Dual Text))] where upcast (RightCancellativeMonoidInstance i) = RightReductiveMonoidInstance i reductiveInstances = map upcast cancellativeInstances ++ [ReductiveMonoidInstance (mempty :: Product Integer), ReductiveMonoidInstance (mempty :: IntSet), ReductiveMonoidInstance (mempty :: Set Integer)] where upcast (CancellativeMonoidInstance i) = ReductiveMonoidInstance i leftCancellativeInstances = map upcast cancellativeInstances ++ [LeftCancellativeMonoidInstance (mempty :: String), LeftCancellativeMonoidInstance (mempty :: ByteString), LeftCancellativeMonoidInstance (mempty :: Lazy.ByteString), LeftCancellativeMonoidInstance (mempty :: Text), LeftCancellativeMonoidInstance (mempty :: Lazy.Text), LeftCancellativeMonoidInstance (mempty :: Dual Text), LeftCancellativeMonoidInstance (mempty :: (Text, String)), LeftCancellativeMonoidInstance (mempty :: Seq Int), LeftCancellativeMonoidInstance (mempty :: Vector Int)] where upcast (CancellativeMonoidInstance i) = LeftCancellativeMonoidInstance i rightCancellativeInstances = map upcast cancellativeInstances ++ [RightCancellativeMonoidInstance (mempty :: ByteString), RightCancellativeMonoidInstance (mempty :: Lazy.ByteString), RightCancellativeMonoidInstance (mempty :: Text), RightCancellativeMonoidInstance (mempty :: Lazy.Text), RightCancellativeMonoidInstance (mempty :: Dual String), RightCancellativeMonoidInstance (mempty :: (Text, ByteString)), RightCancellativeMonoidInstance (mempty :: Seq Int), RightCancellativeMonoidInstance (mempty :: Vector Int)] where upcast (CancellativeMonoidInstance i) = RightCancellativeMonoidInstance i cancellativeInstances = map upcast cancellativeGCDInstances ++ [] where upcast (CancellativeGCDMonoidInstance i) = CancellativeMonoidInstance i leftGCDInstances = map upcast gcdInstances ++ [LeftGCDMonoidInstance (mempty :: String), LeftGCDMonoidInstance (mempty :: ByteString), LeftGCDMonoidInstance (mempty :: Lazy.ByteString), LeftGCDMonoidInstance (mempty :: Text), LeftGCDMonoidInstance (mempty :: Lazy.Text), LeftGCDMonoidInstance (mempty :: Dual ByteString), LeftGCDMonoidInstance (mempty :: (Text, String)), LeftGCDMonoidInstance (mempty :: 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 = defaultMain (testGroup "MonoidSubclasses" $ map expand tests) where expand (name, test) = testProperty name (foldr1 (.&&.) $ checkInstances test) checkInstances :: Test -> [Property] checkInstances (CommutativeTest checkType) = (map checkType commutativeInstances) checkInstances (NullTest checkType) = (map checkType nullInstances) checkInstances (PositiveTest checkType) = (map checkType positiveInstances) checkInstances (FactorialTest checkType) = (map checkType factorialInstances) checkInstances (StableFactorialTest checkType) = (map checkType stableFactorialInstances) checkInstances (TextualTest checkType) = (map checkType textualInstances) checkInstances (LeftReductiveTest checkType) = (map checkType leftReductiveInstances) checkInstances (RightReductiveTest checkType) = (map checkType rightReductiveInstances) checkInstances (ReductiveTest checkType) = (map checkType reductiveInstances) checkInstances (LeftCancellativeTest checkType) = (map checkType leftCancellativeInstances) checkInstances (RightCancellativeTest checkType) = (map checkType rightCancellativeInstances) checkInstances (CancellativeTest checkType) = (map checkType cancellativeInstances) checkInstances (LeftGCDTest checkType) = (map checkType leftGCDInstances) checkInstances (RightGCDTest checkType) = (map checkType rightGCDInstances) checkInstances (GCDTest checkType) = (map checkType gcdInstances) checkInstances (CancellativeGCDTest checkType) = (map checkType cancellativeGCDInstances) tests :: [(String, Test)] tests = [("CommutativeMonoid", CommutativeTest checkCommutative), ("MonoidNull", NullTest checkNull), ("PositiveMonoid", PositiveTest checkPositive), ("mconcat . factors == id", FactorialTest checkConcatFactors), ("all factors . factors", FactorialTest checkFactorsOfFactors), ("splitPrimePrefix", FactorialTest checkSplitPrimePrefix), ("splitPrimeSuffix", FactorialTest checkSplitPrimeSuffix), ("primePrefix", FactorialTest checkPrimePrefix), ("primeSuffix", FactorialTest checkPrimeSuffix), ("inits", FactorialTest checkInits), ("tails", FactorialTest checkTails), ("foldl", FactorialTest checkLeftFold), ("foldl'", FactorialTest checkLeftFold'), ("foldr", FactorialTest checkRightFold), ("length", FactorialTest checkLength), ("span", FactorialTest checkSpan), ("spanMaybe", FactorialTest checkSpanMaybe), ("split", FactorialTest checkSplit), ("splitAt", FactorialTest checkSplitAt), ("reverse", FactorialTest checkReverse), ("stable", StableFactorialTest checkStability), ("fromText", TextualTest checkFromText), ("singleton", TextualTest checkSingleton), ("Textual.splitCharacterPrefix", TextualTest checkSplitCharacterPrefix), ("Textual.characterPrefix", TextualTest checkCharacterPrefix), ("Textual factors", TextualTest checkTextualFactors), ("Textual.unfoldr", TextualTest checkUnfoldrToFactors), ("factors . fromString", TextualTest checkFactorsFromString), ("Textual.map", TextualTest checkTextualMap), ("Textual.concatMap", TextualTest checkConcatMap), ("Textual.any", TextualTest checkAny), ("Textual.all", TextualTest checkAll), ("Textual.foldl", TextualTest checkTextualFoldl), ("Textual.foldr", TextualTest checkTextualFoldr), ("Textual.foldl'", TextualTest checkTextualFoldl'), ("Textual.scanl", TextualTest checkTextualScanl), ("Textual.scanr", TextualTest checkTextualScanr), ("Textual.scanl1", TextualTest checkTextualScanl1), ("Textual.scanr1", TextualTest checkTextualScanr1), ("Textual.toString", TextualTest checkToString), ("Textual.mapAccumL", TextualTest checkTextualMapAccumL), ("Textual.mapAccumR", TextualTest checkTextualMapAccumR), ("Textual.takeWhile", TextualTest checkTextualTakeWhile), ("Textual.dropWhile", TextualTest checkTextualDropWhile), ("Textual.span", TextualTest checkTextualSpan), ("Textual.break", TextualTest checkTextualBreak), ("Textual.spanMaybe", TextualTest checkTextualSpanMaybe), ("Textual.split", TextualTest checkTextualSplit), ("Textual.find", TextualTest checkTextualFind), ("Textual.foldl_", TextualTest checkTextualFoldl_), ("Textual.foldr_", TextualTest checkTextualFoldr_), ("Textual.foldl_'", TextualTest checkTextualFoldl_'), ("Textual.span_", TextualTest checkTextualSpan_), ("Textual.break_", TextualTest checkTextualBreak_), ("Textual.spanMaybe_", TextualTest checkTextualSpanMaybe_), ("Textual.spanMaybe_'", TextualTest checkTextualSpanMaybe_'), ("Textual.takeWhile_", TextualTest checkTextualTakeWhile_), ("Textual.dropWhile_", TextualTest checkTextualDropWhile_), ("stripPrefix", LeftReductiveTest checkStripPrefix), ("isPrefixOf", LeftReductiveTest checkIsPrefixOf), ("stripSuffix", RightReductiveTest checkStripSuffix), ("isSuffixOf", RightReductiveTest checkIsSuffixOf), ("", ReductiveTest checkUnAppend), ("cancellative stripPrefix", LeftCancellativeTest checkStripPrefix'), ("cancellative stripSuffix", RightCancellativeTest checkStripSuffix'), ("cancellative ", CancellativeTest checkUnAppend'), ("stripCommonPrefix 1", LeftGCDTest checkStripCommonPrefix1), ("stripCommonPrefix 2", LeftGCDTest checkStripCommonPrefix2), ("stripCommonSuffix 1", RightGCDTest checkStripCommonSuffix1), ("stripCommonSuffix 2", RightGCDTest checkStripCommonSuffix2), ("gcd", GCDTest checkGCD), ("cancellative gcd", CancellativeGCDTest checkCancellativeGCD) ] checkCommutative (CommutativeMonoidInstance (e :: a)) = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> a <> b == b <> a) checkNull (NullMonoidInstance (e :: a)) = null e .&&. forAll (arbitrary :: Gen a) (\a-> null a == (a == mempty)) checkPositive (PositiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> null a && null b || not (null (a <> b))) checkConcatFactors (FactorialMonoidInstance (e :: a)) = null (factors e) .&&. forAll (arbitrary :: Gen a) check where check a = mconcat (factors a) == a checkFactorsOfFactors (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (all singleton . factors) where singleton prime = factors prime == [prime] checkSplitPrimePrefix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> factors a == unfoldr splitPrimePrefix a) checkSplitPrimeSuffix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = factors a == reverse (unfoldr (fmap swap . splitPrimeSuffix) a) checkPrimePrefix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> primePrefix a == maybe mempty fst (splitPrimePrefix a)) checkPrimeSuffix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> primeSuffix a == maybe mempty snd (splitPrimeSuffix a)) checkInits (FactorialMonoidInstance (_ :: a)) = mapSize (`div` 5) $ forAll (arbitrary :: Gen a) (\a-> inits a == List.map mconcat (List.inits $ factors a)) checkTails (FactorialMonoidInstance (_ :: a)) = mapSize (`div` 5) $ forAll (arbitrary :: Gen a) (\a-> tails a == List.map mconcat (List.tails $ factors a)) checkLeftFold (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldl (flip (:)) [] a == List.foldl (flip (:)) [] (factors a)) checkLeftFold' (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldl' (flip (:)) [] a == List.foldl' (flip (:)) [] (factors a)) checkRightFold (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldr (:) [] a == List.foldr (:) [] (factors a)) checkLength (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> length a == List.length (factors a)) checkSpan (FactorialMonoidInstance (_ :: a)) = property $ \p-> forAll (arbitrary :: Gen a) (check p) where check p a = span p a == (mconcat l, mconcat r) where (l, r) = List.span p (factors a) checkSpanMaybe (FactorialMonoidInstance (_ :: a)) = property $ \(f, s)-> forAll (arbitrary :: Gen a) (check f (s :: Bool)) where check f s0 a = a == prefix <> suffix && foldMaybe prefix == Just s' && (null suffix || f s' (primePrefix suffix) == Nothing) where (prefix, suffix, s') = spanMaybe s0 f a foldMaybe = foldl g (Just s0) g s m = s >>= flip f m checkSplit (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = property (\pred-> all (all (not . pred) . factors) (split pred a)) .&&. property (\prime-> mconcat (intersperse prime $ split (== prime) a) == a) checkSplitAt (FactorialMonoidInstance (_ :: a)) = property $ \i-> forAll (arbitrary :: Gen a) (check i) where check i a = splitAt i a == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors a) checkReverse (FactorialMonoidInstance (_ :: a)) = property $ forAll (arbitrary :: Gen a) (\a-> reverse a == mconcat (List.reverse $ factors a)) checkStability (StableFactorialMonoidInstance (_ :: a)) = property $ forAll (arbitrary :: Gen (a, a)) (\(a, b)-> factors (a <> b) == factors a <> factors b) checkFromText (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen Text) (\t-> Textual.fromText t == (fromString (Text.unpack t) :: a)) checkSingleton (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen Char) (\c-> Textual.singleton c == (fromString [c] :: a)) checkSplitCharacterPrefix (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen String) check1 .&&. forAll (arbitrary :: Gen a) check2 where check1 s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s check2 t = Textual.splitCharacterPrefix (primePrefix t) == fmap (\(c, t)-> (c, mempty)) (Textual.splitCharacterPrefix t) checkCharacterPrefix (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check t = Textual.characterPrefix t == fmap fst (Textual.splitCharacterPrefix t) checkTextualFactors (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = all (maybe True (null . snd) . Textual.splitCharacterPrefix) (factors a) checkUnfoldrToFactors (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = factors a == unfoldr splitPrimePrefix a checkFactorsFromString (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen String) check where check s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s checkTextualMap (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.map succ a == Textual.concatMap (Textual.singleton . succ) a && Textual.map id a == a check2 s = Textual.map succ (fromString s :: a) == fromString (List.map succ s) checkConcatMap (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.concatMap (fromString . f) a == mconcat (map apply $ factors a) && Textual.concatMap Textual.singleton a == a check2 s = Textual.concatMap (fromString . f) (fromString s :: a) == fromString (List.concatMap f s) f = replicate 3 apply prime = maybe prime (fromString . f) (Textual.characterPrefix prime) checkAll (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.all isLetter a == Textual.foldr (const id) ((&&) . isLetter) True a checkAny (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.any isLetter a == Textual.foldr (const id) ((||) . isLetter) False a checkTextualFoldl (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl (\l a-> Left a : l) (\l c-> Right c : l) [] a == List.reverse (textualFactors a) && Textual.foldl (<>) (\a-> (a <>) . Textual.singleton) mempty a == a check2 s = Textual.foldl undefined (flip (:)) [] s == List.foldl (flip (:)) [] s checkTextualFoldr (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldr (\a l-> Left a : l) (\c l-> Right c : l) [] a == textualFactors a && Textual.foldr (<>) ((<>) . Textual.singleton) mempty a == a check2 s = Textual.foldr undefined (:) [] (fromString s :: a) == s checkTextualFoldl' (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl' (\l a-> Left a : l) (\l c-> Right c : l) [] a == List.reverse (textualFactors a) && Textual.foldl' (<>) (\a-> (a <>) . Textual.singleton) mempty a == a check2 s = Textual.foldl' undefined (flip (:)) [] s == List.foldl' (flip (:)) [] s checkTextualFoldl_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl_ (\l c-> c : l) [] a == List.reverse (rights $ textualFactors a) check2 s = Textual.foldl_ (flip (:)) [] s == List.foldl (flip (:)) [] s checkTextualFoldr_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldr_ (\c l-> c : l) [] a == rights (textualFactors a) check2 s = Textual.foldr_ (:) [] (fromString s :: a) == s checkTextualFoldl_' (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl_' (\l c-> c : l) [] a == List.reverse (rights $ textualFactors a) check2 s = Textual.foldl_' (flip (:)) [] s == List.foldl (flip (:)) [] s checkTextualScanl (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = (rights . textualFactors . Textual.scanl f 'Z') a == (List.scanl f 'Z' . rights . textualFactors) a && (lefts . textualFactors . Textual.scanl f 'Y') a == (lefts . textualFactors) a && Textual.scanl f 'W' a == Textual.scanl1 f (Textual.singleton 'W' <> a) check2 s = Textual.scanl f 'X' (fromString s :: a) == fromString (List.scanl f 'X' s) f c1 c2 = min c1 c2 checkTextualScanr (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = (rights . textualFactors . Textual.scanr f 'Z') a == (List.scanr f 'Z' . rights . textualFactors) a && (lefts . textualFactors . Textual.scanr f 'Y') a == (lefts . textualFactors) a && Textual.scanr f 'W' a == Textual.scanr1 f (a <> Textual.singleton 'W') check2 s = Textual.scanr f 'X' (fromString s :: a) == fromString (List.scanr f 'X' s) f c1 c2 = min c1 c2 checkTextualScanl1 (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.scanl1 (const id) a == a check2 s = Textual.scanl1 f (fromString s :: a) == fromString (List.scanl1 f s) f c1 c2 = min c1 c2 checkTextualScanr1 (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.scanr1 const a == a check2 s = Textual.scanr1 f (fromString s :: a) == fromString (List.scanr1 f s) f c1 c2 = min c1 c2 checkToString (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = forAll arbitrary $ \f-> Textual.toString f a == Textual.foldr (\t s-> f t ++ s) (:) "" a check2 s = Textual.toString undefined (fromString s :: a) == s checkTextualMapAccumL (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumL (,)) ((), a) == ((), a) check2 s = Textual.mapAccumL f c (fromString s :: a) == fmap fromString (List.mapAccumL f c s) c = 0 :: Int f n c = if isLetter c then (succ n, succ c) else (2*n, c) checkTextualMapAccumR (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumR (,)) ((), a) == ((), a) check2 s = Textual.mapAccumR f c (fromString s :: a) == fmap fromString (List.mapAccumR f c s) c = 0 :: Int f n c = if isLetter c then (succ n, succ c) else (2*n, c) checkTextualTakeWhile (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.takeWhile (const True) isLetter a) == List.takeWhile (either (const True) isLetter) (textualFactors a) && Textual.takeWhile (const True) (const True) a == a check2 s = Textual.takeWhile undefined isLetter (fromString s :: a) == fromString (List.takeWhile isLetter s) checkTextualDropWhile (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.dropWhile (const True) isLetter a) == List.dropWhile (either (const True) isLetter) (textualFactors a) && Textual.dropWhile (const False) (const False) a == a check2 s = Textual.dropWhile undefined isLetter (fromString s :: a) == fromString (List.dropWhile isLetter s) checkTextualSpan (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.span pt pc a == (Textual.takeWhile pt pc a, Textual.dropWhile pt pc a) where pt = (== primePrefix a) pc = isLetter checkTextualBreak (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.break pt pc a == Textual.span (not . pt) (not . pc) a where pt = (/= primePrefix a) pc = isLetter checkTextualSpanMaybe (TextualMonoidInstance (_ :: a)) = property $ \(ft, fc, s)-> forAll (arbitrary :: Gen a) (check ft fc (s :: Bool)) where check ft fc s0 a = a == prefix <> suffix && foldMaybe prefix == Just s' && (null suffix || maybe (ft s' (primePrefix suffix)) (fc s') (Textual.characterPrefix suffix) == Nothing) where (prefix, suffix, s') = Textual.spanMaybe s0 ft fc a foldMaybe = Textual.foldl gt gc (Just s0) gt s m = s >>= flip ft m gc s c = s >>= flip fc c checkTextualSpan_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, Bool)) check where check (a, bt) = Textual.span_ bt isLetter a == (Textual.takeWhile_ bt isLetter a, Textual.dropWhile_ bt isLetter a) checkTextualBreak_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, Bool)) check where check (a, bt) = Textual.break_ bt isLetter a == Textual.span_ (not bt) (not . isLetter) a checkTextualSpanMaybe_ (TextualMonoidInstance (_ :: a)) = property $ \(fc, s)-> forAll (arbitrary :: Gen a) (check fc (s :: Bool)) where check fc s0 a = a == prefix <> suffix && foldMaybe prefix == Just s' && (null suffix || (Textual.characterPrefix suffix >>= fc s') == Nothing) where (prefix, suffix, s') = Textual.spanMaybe_ s0 fc a foldMaybe = Textual.foldl_ gc (Just s0) gc s c = s >>= flip fc c checkTextualSpanMaybe_' (TextualMonoidInstance (_ :: a)) = property $ \(fc, s)-> forAll (arbitrary :: Gen a) (check fc (s :: Bool)) where check fc s0 a = a == prefix <> suffix && foldMaybe prefix == Just s' && (null suffix || (Textual.characterPrefix suffix >>= fc s') == Nothing) where (prefix, suffix, s') = Textual.spanMaybe_' s0 fc a foldMaybe = Textual.foldl_' gc (Just s0) gc s c = s >>= flip fc c checkTextualTakeWhile_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.takeWhile_ True isLetter a) == List.takeWhile (either (const True) isLetter) (textualFactors a) && Textual.takeWhile_ True (const True) a == a check2 s = Textual.takeWhile_ undefined isLetter (fromString s :: a) == fromString (List.takeWhile isLetter s) checkTextualDropWhile_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.dropWhile_ True isLetter a) == List.dropWhile (either (const True) isLetter) (textualFactors a) && Textual.dropWhile_ False (const False) a == a check2 s = Textual.dropWhile_ undefined isLetter (fromString s :: a) == fromString (List.dropWhile isLetter s) checkTextualSplit (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = List.all (List.all isLetter . rights . textualFactors) (Textual.split (not . isLetter) a) && (mconcat . intersperse (fromString " ") . Textual.split (== ' ')) a == a checkTextualFind (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.find isLetter a == (List.find isLetter . rights . textualFactors) a check2 s = Textual.find isLetter (fromString s :: a) == List.find isLetter s checkStripPrefix (LeftReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = maybe b (a <>) (stripPrefix a b) == b checkIsPrefixOf (LeftReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = isPrefixOf a b == isJust (stripPrefix a b) && a `isPrefixOf` (a <> b) checkStripSuffix (RightReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = maybe b (<> a) (stripSuffix a b) == b checkIsSuffixOf (RightReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = isSuffixOf a b == isJust (stripSuffix a b) && b `isSuffixOf` (a <> b) checkUnAppend (ReductiveMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = maybe a (b <>) (a b) == a && maybe a (<> b) (a b) == a checkStripPrefix' (LeftCancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripPrefix a (a <> b) == Just b checkStripSuffix' (RightCancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripSuffix b (a <> b) == Just a checkUnAppend' (CancellativeMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = a <> b a == Just b && a <> b b == Just a checkStripCommonPrefix1 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripCommonPrefix a b == (p, a', b') where p = commonPrefix a b Just a' = stripPrefix p a Just b' = stripPrefix p b checkStripCommonPrefix2 (LeftGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = p == commonPrefix a b && p <> a' == a && p <> b' == b where (p, a', b') = stripCommonPrefix a b checkStripCommonSuffix1 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = stripCommonSuffix a b == (a', b', s) where s = commonSuffix a b Just a' = stripSuffix s a Just b' = stripSuffix s b checkStripCommonSuffix2 (RightGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = s == commonSuffix a b && a' <> s == a && b' <> s == b where (a', b', s) = stripCommonSuffix a b checkGCD (GCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a)) check where check (a, b) = d == commonPrefix a b && d == commonSuffix a b && isJust (a d) && isJust (b d) where d = gcd a b checkCancellativeGCD (CancellativeGCDMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen (a, a, a)) check where check (a, b, c) = commonPrefix (a <> b) (a <> c) == a <> (commonPrefix b c) && commonSuffix (a <> c) (b <> c) == (commonSuffix a b) <> c && gcd (a <> b) (a <> c) == a <> gcd b c && gcd (a <> c) (b <> c) == gcd a b <> c textualFactors :: TextualMonoid t => t -> [Either t Char] textualFactors = map characterize . factors where characterize prime = maybe (Left prime) Right (Textual.characterPrefix prime) newtype TestString = TestString String deriving (Eq, Show, Arbitrary, CoArbitrary, 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 ByteStringUTF8 where arbitrary = fmap ByteStringUTF8 arbitrary instance (Arbitrary a, MonoidNull a, PositiveMonoid a) => Arbitrary (Concat a) where arbitrary = fmap Concat.concatenate arbitrary instance (Arbitrary a, FactorialMonoid a) => Arbitrary (Measured a) where arbitrary = fmap Measured.measure arbitrary instance (Arbitrary a, FactorialMonoid a) => Arbitrary (OffsetPositioned a) where arbitrary = fmap pure arbitrary instance (Arbitrary a, TextualMonoid a) => Arbitrary (LinePositioned a) where arbitrary = fmap pure arbitrary instance (Arbitrary a, Arbitrary b) => Arbitrary (Stateful a b) where arbitrary = Stateful.Stateful <$> liftA2 (,) arbitrary arbitrary instance CoArbitrary 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 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 a => CoArbitrary (OffsetPositioned a) where coarbitrary = coarbitrary . Positioned.extract instance CoArbitrary a => CoArbitrary (LinePositioned a) where coarbitrary = coarbitrary . Positioned.extract instance CoArbitrary b => CoArbitrary (Stateful a b) where coarbitrary = coarbitrary . Stateful.extract instance (PositiveMonoid a, MonoidNull b) => PositiveMonoid (a, b) #if MIN_VERSION_containers(0,5,2) #else instance Applicative Seq where pure = Sequence.singleton fs <*> xs = Foldable.foldl' add mempty fs where add ys f = ys <> fmap f xs #endif monoid-subclasses-0.4.2.1/Data/0000755000000000000000000000000012717754212014355 5ustar0000000000000000monoid-subclasses-0.4.2.1/Data/Monoid/0000755000000000000000000000000012717754212015602 5ustar0000000000000000monoid-subclasses-0.4.2.1/Data/Monoid/Cancellative.hs0000644000000000000000000005717212717754212020544 0ustar0000000000000000{- Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'Monoid' => 'ReductiveMonoid' => ('CancellativeMonoid', 'GCDMonoid') class hierarchy. -- -- The 'ReductiveMonoid' class introduces operation '' which is the inverse of '<>'. For the 'Sum' monoid, this -- operation is subtraction; for 'Product' it is division and for 'Set' it's the set difference. A 'ReductiveMonoid' is -- not a full group because '' may return 'Nothing'. -- -- The 'CancellativeMonoid' subclass does not add any operation but it provides the additional guarantee that '<>' can -- always be undone with ''. Thus 'Sum' is a 'CancellativeMonoid' but 'Product' is not because @(0*n)/0@ is not -- defined. -- -- The 'GCDMonoid' subclass adds the 'gcd' operation which takes two monoidal arguments and finds their greatest common -- divisor, or (more generally) the greatest monoid that can be extracted with the '' operation from both. -- -- All monoid subclasses listed above are for Abelian, /i.e./, commutative or symmetric monoids. Since most practical -- monoids in Haskell are not Abelian, each of the these classes has two symmetric superclasses: -- -- * 'LeftReductiveMonoid' -- -- * 'LeftCancellativeMonoid' -- -- * 'LeftGCDMonoid' -- -- * 'RightReductiveMonoid' -- -- * 'RightCancellativeMonoid' -- -- * 'RightGCDMonoid' {-# LANGUAGE Haskell2010, Trustworthy #-} module Data.Monoid.Cancellative ( -- * Symmetric, commutative monoid classes CommutativeMonoid, ReductiveMonoid(..), CancellativeMonoid, GCDMonoid(..), -- * Asymmetric monoid classes LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftCancellativeMonoid, RightCancellativeMonoid, LeftGCDMonoid(..), RightGCDMonoid(..) ) where import qualified Prelude import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..)) import qualified Data.List as List import Data.Maybe (isJust) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Unsafe as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import Data.Sequence (ViewL((:<)), ViewR((:>)), (<|), (|>)) import qualified Data.Vector as Vector import Prelude hiding (gcd) -- | Class of all Abelian ({i.e.}, commutative) monoids that satisfy the commutativity property: -- -- > a <> b == b <> a class Monoid m => CommutativeMonoid m -- | Class of Abelian monoids with a partial inverse for the Monoid '<>' operation. The inverse operation '' must -- satisfy the following laws: -- -- > maybe a (b <>) (a b) == a -- > maybe a (<> b) (a b) == a class (CommutativeMonoid m, LeftReductiveMonoid m, RightReductiveMonoid m) => ReductiveMonoid m where () :: m -> m -> Maybe m infix 5 -- | Subclass of 'ReductiveMonoid' where '' is a complete inverse of the Monoid '<>' operation. The class instances -- must satisfy the following additional laws: -- -- > (a <> b) a == Just b -- > (a <> b) b == Just a class (LeftCancellativeMonoid m, RightCancellativeMonoid m, ReductiveMonoid m) => CancellativeMonoid m -- | Class of Abelian monoids that allow the greatest common denominator to be found for any two given values. The -- operations must satisfy the following laws: -- -- > gcd a b == commonPrefix a b == commonSuffix a b -- > Just a' = a p && Just b' = b p -- > where p = gcd a b -- -- If a 'GCDMonoid' happens to also be a 'CancellativeMonoid', it should additionally satisfy the following laws: -- -- > gcd (a <> b) (a <> c) == a <> gcd b c -- > gcd (a <> c) (b <> c) == gcd a b <> c class (ReductiveMonoid m, LeftGCDMonoid m, RightGCDMonoid m) => GCDMonoid m where gcd :: m -> m -> m -- | Class of monoids with a left inverse of 'Data.Monoid.mappend', satisfying the following law: -- -- > isPrefixOf a b == isJust (stripPrefix a b) -- > maybe b (a <>) (stripPrefix a b) == b -- > a `isPrefixOf` (a <> b) -- -- | Every instance definition has to implement at least the 'stripPrefix' method. Its complexity should be no worse -- than linear in the length of the prefix argument. class Monoid m => LeftReductiveMonoid m where isPrefixOf :: m -> m -> Bool stripPrefix :: m -> m -> Maybe m isPrefixOf a b = isJust (stripPrefix a b) {-# MINIMAL stripPrefix #-} -- | Class of monoids with a right inverse of 'Data.Monoid.mappend', satisfying the following law: -- -- > isSuffixOf a b == isJust (stripSuffix a b) -- > maybe b (<> a) (stripSuffix a b) == b -- > b `isSuffixOf` (a <> b) -- -- | Every instance definition has to implement at least the 'stripSuffix' method. Its complexity should be no worse -- than linear in the length of the suffix argument. class Monoid m => RightReductiveMonoid m where isSuffixOf :: m -> m -> Bool stripSuffix :: m -> m -> Maybe m isSuffixOf a b = isJust (stripSuffix a b) {-# MINIMAL stripSuffix #-} -- | Subclass of 'LeftReductiveMonoid' where 'stripPrefix' is a complete inverse of '<>', satisfying the following -- additional law: -- -- > stripPrefix a (a <> b) == Just b class LeftReductiveMonoid m => LeftCancellativeMonoid m -- | Subclass of 'LeftReductiveMonoid' where 'stripPrefix' is a complete inverse of '<>', satisfying the following -- additional law: -- -- > stripSuffix b (a <> b) == Just a class RightReductiveMonoid m => RightCancellativeMonoid m -- | Class of monoids capable of finding the equivalent of greatest common divisor on the left side of two monoidal -- values. The methods' complexity should be no worse than linear in the length of the common prefix. The following laws -- must be respected: -- -- > stripCommonPrefix a b == (p, a', b') -- > where p = commonPrefix a b -- > Just a' = stripPrefix p a -- > Just b' = stripPrefix p b -- > p == commonPrefix a b && p <> a' == a && p <> b' == b -- > where (p, a', b') = stripCommonPrefix a b class LeftReductiveMonoid m => LeftGCDMonoid m where commonPrefix :: m -> m -> m stripCommonPrefix :: m -> m -> (m, m, m) commonPrefix x y = p where (p, _, _) = stripCommonPrefix x y stripCommonPrefix x y = (p, x', y') where p = commonPrefix x y Just x' = stripPrefix p x Just y' = stripPrefix p y {-# MINIMAL commonPrefix | stripCommonPrefix #-} -- | Class of monoids capable of finding the equivalent of greatest common divisor on the right side of two monoidal -- values. The methods' complexity must be no worse than linear in the length of the common suffix. The following laws -- must be respected: -- -- > stripCommonSuffix a b == (a', b', s) -- > where s = commonSuffix a b -- > Just a' = stripSuffix p a -- > Just b' = stripSuffix p b -- > s == commonSuffix a b && a' <> s == a && b' <> s == b -- > where (a', b', s) = stripCommonSuffix a b class RightReductiveMonoid m => RightGCDMonoid m where commonSuffix :: m -> m -> m stripCommonSuffix :: m -> m -> (m, m, m) commonSuffix x y = s where (_, _, s) = stripCommonSuffix x y stripCommonSuffix x y = (x', y', s) where s = commonSuffix x y Just x' = stripSuffix s x Just y' = stripSuffix s y {-# MINIMAL commonSuffix | stripCommonSuffix #-} -- Unit instances instance CommutativeMonoid () instance ReductiveMonoid () where () () = Just () instance CancellativeMonoid () instance GCDMonoid () where gcd () () = () instance LeftReductiveMonoid () where stripPrefix () () = Just () instance RightReductiveMonoid () where stripSuffix () () = Just () instance LeftCancellativeMonoid () instance RightCancellativeMonoid () instance LeftGCDMonoid () where commonPrefix () () = () instance RightGCDMonoid () where commonSuffix () () = () -- Dual instances instance CommutativeMonoid a => CommutativeMonoid (Dual a) instance ReductiveMonoid a => ReductiveMonoid (Dual a) where Dual a Dual b = fmap Dual (a b) instance CancellativeMonoid a => CancellativeMonoid (Dual a) instance GCDMonoid a => GCDMonoid (Dual a) where gcd (Dual a) (Dual b) = Dual (gcd a b) instance LeftReductiveMonoid a => RightReductiveMonoid (Dual a) where stripSuffix (Dual a) (Dual b) = fmap Dual (stripPrefix a b) Dual a `isSuffixOf` Dual b = a `isPrefixOf` b instance RightReductiveMonoid a => LeftReductiveMonoid (Dual a) where stripPrefix (Dual a) (Dual b) = fmap Dual (stripSuffix a b) Dual a `isPrefixOf` Dual b = a `isSuffixOf` b instance LeftCancellativeMonoid a => RightCancellativeMonoid (Dual a) instance RightCancellativeMonoid a => LeftCancellativeMonoid (Dual a) instance LeftGCDMonoid a => RightGCDMonoid (Dual a) where commonSuffix (Dual a) (Dual b) = Dual (commonPrefix a b) instance RightGCDMonoid a => LeftGCDMonoid (Dual a) where commonPrefix (Dual a) (Dual b) = Dual (commonSuffix a b) -- Sum instances instance Num a => CommutativeMonoid (Sum a) instance Integral a => ReductiveMonoid (Sum a) where Sum a Sum b = Just $ Sum (a - b) instance Integral a => CancellativeMonoid (Sum a) instance (Integral a, Ord a) => GCDMonoid (Sum a) where gcd (Sum a) (Sum b) = Sum (min a b) instance Integral a => LeftReductiveMonoid (Sum a) where stripPrefix a b = b a instance Integral a => RightReductiveMonoid (Sum a) where stripSuffix a b = b a instance Integral a => LeftCancellativeMonoid (Sum a) instance Integral a => RightCancellativeMonoid (Sum a) instance (Integral a, Ord a) => LeftGCDMonoid (Sum a) where commonPrefix a b = gcd a b instance (Integral a, Ord a) => RightGCDMonoid (Sum a) where commonSuffix a b = gcd a b -- Product instances instance Num a => CommutativeMonoid (Product a) instance Integral a => ReductiveMonoid (Product a) where Product 0 Product 0 = Just (Product 0) Product _ Product 0 = Nothing Product a Product b = if remainder == 0 then Just (Product quotient) else Nothing where (quotient, remainder) = quotRem a b instance Integral a => GCDMonoid (Product a) where gcd (Product a) (Product b) = Product (Prelude.gcd a b) instance Integral a => LeftReductiveMonoid (Product a) where stripPrefix a b = b a instance Integral a => RightReductiveMonoid (Product a) where stripSuffix a b = b a instance Integral a => LeftGCDMonoid (Product a) where commonPrefix a b = gcd a b instance Integral a => RightGCDMonoid (Product a) where commonSuffix a b = gcd a b -- Pair instances instance (CommutativeMonoid a, CommutativeMonoid b) => CommutativeMonoid (a, b) instance (ReductiveMonoid a, ReductiveMonoid b) => ReductiveMonoid (a, b) where (a, b) (c, d) = case (a c, b d) of (Just a', Just b') -> Just (a', b') _ -> Nothing instance (CancellativeMonoid a, CancellativeMonoid b) => CancellativeMonoid (a, b) instance (GCDMonoid a, GCDMonoid b) => GCDMonoid (a, b) where gcd (a, b) (c, d) = (gcd a c, gcd b d) instance (LeftReductiveMonoid a, LeftReductiveMonoid b) => LeftReductiveMonoid (a, b) where stripPrefix (a, b) (c, d) = case (stripPrefix a c, stripPrefix b d) of (Just a', Just b') -> Just (a', b') _ -> Nothing isPrefixOf (a, b) (c, d) = isPrefixOf a c && isPrefixOf b d instance (RightReductiveMonoid a, RightReductiveMonoid b) => RightReductiveMonoid (a, b) where stripSuffix (a, b) (c, d) = case (stripSuffix a c, stripSuffix b d) of (Just a', Just b') -> Just (a', b') _ -> Nothing isSuffixOf (a, b) (c, d) = isSuffixOf a c && isSuffixOf b d instance (LeftCancellativeMonoid a, LeftCancellativeMonoid b) => LeftCancellativeMonoid (a, b) instance (RightCancellativeMonoid a, RightCancellativeMonoid b) => RightCancellativeMonoid (a, b) instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (a, b) where commonPrefix (a, b) (c, d) = (commonPrefix a c, commonPrefix b d) instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (a, b) where commonSuffix (a, b) (c, d) = (commonSuffix a c, commonSuffix b d) -- Maybe instances instance LeftReductiveMonoid x => LeftReductiveMonoid (Maybe x) where stripPrefix Nothing y = Just y stripPrefix Just{} Nothing = Nothing stripPrefix (Just x) (Just y) = fmap Just $ stripPrefix x y instance LeftGCDMonoid x => LeftGCDMonoid (Maybe x) where commonPrefix (Just x) (Just y) = Just (commonPrefix x y) commonPrefix _ _ = Nothing stripCommonPrefix (Just x) (Just y) = (Just p, Just x', Just y') where (p, x', y') = stripCommonPrefix x y stripCommonPrefix x y = (Nothing, x, y) instance RightReductiveMonoid x => RightReductiveMonoid (Maybe x) where stripSuffix Nothing y = Just y stripSuffix Just{} Nothing = Nothing stripSuffix (Just x) (Just y) = fmap Just $ stripSuffix x y instance RightGCDMonoid x => RightGCDMonoid (Maybe x) where commonSuffix (Just x) (Just y) = Just (commonSuffix x y) commonSuffix _ _ = Nothing stripCommonSuffix (Just x) (Just y) = (Just x', Just y', Just s) where (x', y', s) = stripCommonSuffix x y stripCommonSuffix x y = (x, y, Nothing) -- Set instances instance Ord a => CommutativeMonoid (Set.Set a) instance Ord a => LeftReductiveMonoid (Set.Set a) where isPrefixOf = Set.isSubsetOf stripPrefix a b = b a instance Ord a => RightReductiveMonoid (Set.Set a) where isSuffixOf = Set.isSubsetOf stripSuffix a b = b a instance Ord a => ReductiveMonoid (Set.Set a) where a b | Set.isSubsetOf b a = Just (a Set.\\ b) | otherwise = Nothing instance Ord a => LeftGCDMonoid (Set.Set a) where commonPrefix = Set.intersection instance Ord a => RightGCDMonoid (Set.Set a) where commonSuffix = Set.intersection instance Ord a => GCDMonoid (Set.Set a) where gcd = Set.intersection -- IntSet instances instance CommutativeMonoid IntSet.IntSet instance LeftReductiveMonoid IntSet.IntSet where isPrefixOf = IntSet.isSubsetOf stripPrefix a b = b a instance RightReductiveMonoid IntSet.IntSet where isSuffixOf = IntSet.isSubsetOf stripSuffix a b = b a instance ReductiveMonoid IntSet.IntSet where a b | IntSet.isSubsetOf b a = Just (a IntSet.\\ b) | otherwise = Nothing instance LeftGCDMonoid IntSet.IntSet where commonPrefix = IntSet.intersection instance RightGCDMonoid IntSet.IntSet where commonSuffix = IntSet.intersection instance GCDMonoid IntSet.IntSet where gcd = IntSet.intersection -- Map instances instance Ord k => LeftReductiveMonoid (Map.Map k a) where isPrefixOf = Map.isSubmapOfBy (\_ _-> True) stripPrefix a b | Map.isSubmapOfBy (\_ _-> True) a b = Just (b Map.\\ a) | otherwise = Nothing instance (Ord k, Eq a) => LeftGCDMonoid (Map.Map k a) where commonPrefix = Map.mergeWithKey (\_ a b -> if a == b then Just a else Nothing) (const Map.empty) (const Map.empty) -- IntMap instances instance LeftReductiveMonoid (IntMap.IntMap a) where isPrefixOf = IntMap.isSubmapOfBy (\_ _-> True) stripPrefix a b | IntMap.isSubmapOfBy (\_ _-> True) a b = Just (b IntMap.\\ a) | otherwise = Nothing instance Eq a => LeftGCDMonoid (IntMap.IntMap a) where commonPrefix = IntMap.mergeWithKey (\_ a b -> if a == b then Just a else Nothing) (const IntMap.empty) (const IntMap.empty) -- List instances instance Eq x => LeftReductiveMonoid [x] where stripPrefix = List.stripPrefix isPrefixOf = List.isPrefixOf instance Eq x => LeftCancellativeMonoid [x] instance Eq x => LeftGCDMonoid [x] where commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys commonPrefix _ _ = [] stripCommonPrefix x0 y0 = strip' id x0 y0 where strip' f (x:xs) (y:ys) | x == y = strip' (f . (x :)) xs ys strip' f x y = (f [], x, y) -- Seq instances instance Eq a => LeftReductiveMonoid (Sequence.Seq a) where stripPrefix p s | p == s1 = Just s2 | otherwise = Nothing where (s1, s2) = Sequence.splitAt (Sequence.length p) s instance Eq a => RightReductiveMonoid (Sequence.Seq a) where stripSuffix p s | p == s2 = Just s1 | otherwise = Nothing where (s1, s2) = Sequence.splitAt (Sequence.length s - Sequence.length p) s instance Eq a => LeftCancellativeMonoid (Sequence.Seq a) instance Eq a => RightCancellativeMonoid (Sequence.Seq a) instance Eq a => LeftGCDMonoid (Sequence.Seq a) where stripCommonPrefix = findCommonPrefix Sequence.empty where findCommonPrefix prefix a b = case (Sequence.viewl a, Sequence.viewl b) of (a1: findCommonPrefix (prefix |> a1) a' b' _ -> (prefix, a, b) instance Eq a => RightGCDMonoid (Sequence.Seq a) where stripCommonSuffix = findCommonSuffix Sequence.empty where findCommonSuffix suffix a b = case (Sequence.viewr a, Sequence.viewr b) of (a':>a1, b':>b1) | a1 == b1 -> findCommonSuffix (a1 <| suffix) a' b' _ -> (a, b, suffix) -- Vector instances instance Eq a => LeftReductiveMonoid (Vector.Vector a) where stripPrefix p l | prefixLength > Vector.length l = Nothing | otherwise = strip 0 where strip i | i == prefixLength = Just (Vector.drop prefixLength l) | l Vector.! i == p Vector.! i = strip (succ i) | otherwise = Nothing prefixLength = Vector.length p isPrefixOf p l | prefixLength > Vector.length l = False | otherwise = test 0 where test i | i == prefixLength = True | l Vector.! i == p Vector.! i = test (succ i) | otherwise = False prefixLength = Vector.length p instance Eq a => RightReductiveMonoid (Vector.Vector a) where stripSuffix s l | suffixLength > Vector.length l = Nothing | otherwise = strip (pred suffixLength) where strip i | i == -1 = Just (Vector.take lengthDifference l) | l Vector.! (lengthDifference + i) == s Vector.! i = strip (pred i) | otherwise = Nothing suffixLength = Vector.length s lengthDifference = Vector.length l - suffixLength isSuffixOf s l | suffixLength > Vector.length l = False | otherwise = test (pred suffixLength) where test i | i == -1 = True | l Vector.! (lengthDifference + i) == s Vector.! i = test (pred i) | otherwise = False suffixLength = Vector.length s lengthDifference = Vector.length l - suffixLength instance Eq a => LeftCancellativeMonoid (Vector.Vector a) instance Eq a => RightCancellativeMonoid (Vector.Vector a) instance Eq a => LeftGCDMonoid (Vector.Vector a) where stripCommonPrefix x y = (xp, xs, Vector.drop maxPrefixLength y) where maxPrefixLength = prefixLength 0 (Vector.length x `min` Vector.length y) prefixLength n len | n < len && x Vector.! n == y Vector.! n = prefixLength (succ n) len prefixLength n _ = n (xp, xs) = Vector.splitAt maxPrefixLength x instance Eq a => RightGCDMonoid (Vector.Vector a) where stripCommonSuffix x y = findSuffix (Vector.length x - 1) (Vector.length y - 1) where findSuffix m n | m >= 0 && n >= 0 && x Vector.! m == y Vector.! n = findSuffix (pred m) (pred n) findSuffix m n = (Vector.take (succ m) x, yp, ys) where (yp, ys) = Vector.splitAt (succ n) y -- ByteString instances instance LeftReductiveMonoid ByteString.ByteString where stripPrefix p l = if ByteString.isPrefixOf p l then Just (ByteString.unsafeDrop (ByteString.length p) l) else Nothing isPrefixOf = ByteString.isPrefixOf instance RightReductiveMonoid ByteString.ByteString where stripSuffix s l = if ByteString.isSuffixOf s l then Just (ByteString.unsafeTake (ByteString.length l - ByteString.length s) l) else Nothing isSuffixOf = ByteString.isSuffixOf instance LeftCancellativeMonoid ByteString.ByteString instance RightCancellativeMonoid ByteString.ByteString instance LeftGCDMonoid ByteString.ByteString where stripCommonPrefix x y = (xp, xs, ByteString.unsafeDrop maxPrefixLength y) where maxPrefixLength = prefixLength 0 (ByteString.length x `min` ByteString.length y) prefixLength n len | n < len, ByteString.unsafeIndex x n == ByteString.unsafeIndex y n = prefixLength (succ n) len | otherwise = n (xp, xs) = ByteString.splitAt maxPrefixLength x instance RightGCDMonoid ByteString.ByteString where stripCommonSuffix x y = findSuffix (ByteString.length x - 1) (ByteString.length y - 1) where findSuffix m n | m >= 0, n >= 0, ByteString.unsafeIndex x m == ByteString.unsafeIndex y n = findSuffix (pred m) (pred n) | otherwise = let (yp, ys) = ByteString.splitAt (succ n) y in (ByteString.unsafeTake (succ m) x, yp, ys) -- Lazy ByteString instances instance LeftReductiveMonoid LazyByteString.ByteString where stripPrefix p l = if LazyByteString.isPrefixOf p l then Just (LazyByteString.drop (LazyByteString.length p) l) else Nothing isPrefixOf = LazyByteString.isPrefixOf instance RightReductiveMonoid LazyByteString.ByteString where stripSuffix s l = if LazyByteString.isSuffixOf s l then Just (LazyByteString.take (LazyByteString.length l - LazyByteString.length s) l) else Nothing isSuffixOf = LazyByteString.isSuffixOf instance LeftCancellativeMonoid LazyByteString.ByteString instance RightCancellativeMonoid LazyByteString.ByteString instance LeftGCDMonoid LazyByteString.ByteString where stripCommonPrefix x y = (xp, xs, LazyByteString.drop maxPrefixLength y) where maxPrefixLength = prefixLength 0 (LazyByteString.length x `min` LazyByteString.length y) prefixLength n len | n < len && LazyByteString.index x n == LazyByteString.index y n = prefixLength (succ n) len prefixLength n _ = n (xp, xs) = LazyByteString.splitAt maxPrefixLength x instance RightGCDMonoid LazyByteString.ByteString where stripCommonSuffix x y = findSuffix (LazyByteString.length x - 1) (LazyByteString.length y - 1) where findSuffix m n | m >= 0 && n >= 0 && LazyByteString.index x m == LazyByteString.index y n = findSuffix (pred m) (pred n) findSuffix m n = (LazyByteString.take (succ m) x, yp, ys) where (yp, ys) = LazyByteString.splitAt (succ n) y -- Text instances instance LeftReductiveMonoid Text.Text where stripPrefix = Text.stripPrefix isPrefixOf = Text.isPrefixOf instance RightReductiveMonoid Text.Text where stripSuffix = Text.stripSuffix isSuffixOf = Text.isSuffixOf instance LeftCancellativeMonoid Text.Text instance RightCancellativeMonoid Text.Text instance LeftGCDMonoid Text.Text where stripCommonPrefix x y = maybe (Text.empty, x, y) id (Text.commonPrefixes x y) -- Lazy Text instances instance LeftReductiveMonoid LazyText.Text where stripPrefix = LazyText.stripPrefix isPrefixOf = LazyText.isPrefixOf instance RightReductiveMonoid LazyText.Text where stripSuffix = LazyText.stripSuffix isSuffixOf = LazyText.isSuffixOf instance LeftCancellativeMonoid LazyText.Text instance RightCancellativeMonoid LazyText.Text instance LeftGCDMonoid LazyText.Text where stripCommonPrefix x y = maybe (LazyText.empty, x, y) id (LazyText.commonPrefixes x y) monoid-subclasses-0.4.2.1/Data/Monoid/Null.hs0000644000000000000000000000771112717754212017056 0ustar0000000000000000{- Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the MonoidNull class and some of its instances. -- {-# LANGUAGE Haskell2010, Trustworthy #-} module Data.Monoid.Null ( MonoidNull(..), PositiveMonoid ) where import Data.Monoid -- (Monoid, First(..), Last(..), Dual(..), Sum(..), Product(..), All(getAll), Any(getAny)) import qualified Data.List as List import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import qualified Data.Vector as Vector import Prelude hiding (null) -- | Extension of 'Monoid' that allows testing a value for equality with 'mempty'. The following law must hold: -- -- prop> null x == (x == mempty) -- -- Furthermore, the performance of this method should be constant, /i.e./, independent of the length of its argument. class Monoid m => MonoidNull m where null :: m -> Bool -- | Subclass of 'Monoid' for types whose values have no inverse, with the exception of 'Data.Monoid.mempty'. More -- formally, the class instances must satisfy the following law: -- -- prop> null (x <> y) == (null x && null y) class MonoidNull m => PositiveMonoid m instance MonoidNull () where null () = True instance MonoidNull Ordering where null = (== EQ) instance MonoidNull All where null = getAll instance MonoidNull Any where null = not . getAny instance MonoidNull (First a) where null (First Nothing) = True null _ = False instance MonoidNull (Last a) where null (Last Nothing) = True null _ = False instance MonoidNull a => MonoidNull (Dual a) where null (Dual a) = null a instance (Num a, Eq a) => MonoidNull (Sum a) where null (Sum a) = a == 0 instance (Num a, Eq a) => MonoidNull (Product a) where null (Product a) = a == 1 instance Monoid a => MonoidNull (Maybe a) where null Nothing = True null _ = False instance (MonoidNull a, MonoidNull b) => MonoidNull (a, b) where null (a, b) = null a && null b instance MonoidNull [x] where null = List.null instance MonoidNull ByteString.ByteString where null = ByteString.null {-# INLINE null #-} instance MonoidNull LazyByteString.ByteString where null = LazyByteString.null {-# INLINE null #-} instance MonoidNull Text.Text where null = Text.null {-# INLINE null #-} instance MonoidNull LazyText.Text where null = LazyText.null {-# INLINE null #-} instance Ord k => MonoidNull (Map.Map k v) where null = Map.null instance MonoidNull (IntMap.IntMap v) where null = IntMap.null instance MonoidNull IntSet.IntSet where null = IntSet.null instance MonoidNull (Sequence.Seq a) where null = Sequence.null instance Ord a => MonoidNull (Set.Set a) where null = Set.null instance MonoidNull (Vector.Vector a) where null = Vector.null instance PositiveMonoid () instance PositiveMonoid Ordering instance PositiveMonoid All instance PositiveMonoid Any instance PositiveMonoid ByteString.ByteString instance PositiveMonoid LazyByteString.ByteString instance PositiveMonoid Text.Text instance PositiveMonoid LazyText.Text instance Monoid a => PositiveMonoid (Maybe a) instance PositiveMonoid (First a) instance PositiveMonoid (Last a) instance PositiveMonoid a => PositiveMonoid (Dual a) instance PositiveMonoid [x] instance Ord k => PositiveMonoid (Map.Map k v) instance PositiveMonoid (IntMap.IntMap v) instance PositiveMonoid IntSet.IntSet instance PositiveMonoid (Sequence.Seq a) instance Ord a => PositiveMonoid (Set.Set a) instance PositiveMonoid (Vector.Vector a) -- 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.4.2.1/Data/Monoid/Textual.hs0000644000000000000000000006030412717754212017567 0ustar0000000000000000{- Copyright 2013-2016 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'TextualMonoid' class and several of its instances. -- {-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-} module Data.Monoid.Textual ( TextualMonoid(..) ) where import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable import Data.Functor -- ((<$>)) import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import Data.Text (Text) import Data.Monoid -- (Monoid(mappend, mempty)) import qualified Data.Sequence as Sequence import qualified Data.Vector as Vector import Data.String (IsString(fromString)) import Data.Int (Int64) import Data.Monoid.Cancellative (LeftReductiveMonoid, LeftGCDMonoid) import Data.Monoid.Factorial (FactorialMonoid) import qualified Data.Monoid.Factorial as Factorial import Prelude hiding (all, any, break, concatMap, dropWhile, foldl, foldl1, foldr, foldr1, map, scanl, scanl1, scanr, scanr1, span, takeWhile) -- | The 'TextualMonoid' class is an extension of 'FactorialMonoid' specialized for monoids that can contain -- characters. Its methods are generally equivalent to their namesake functions from "Data.List" and "Data.Text", and -- they satisfy the following laws: -- -- > unfoldr splitCharacterPrefix . fromString == id -- > splitCharacterPrefix . primePrefix == fmap (\(c, t)-> (c, mempty)) . splitCharacterPrefix -- > -- > map f . fromString == fromString . List.map f -- > concatMap (fromString . f) . fromString == fromString . List.concatMap f -- > -- > foldl ft fc a . fromString == List.foldl fc a -- > foldr ft fc a . fromString == List.foldr fc a -- > foldl' ft fc a . fromString == List.foldl' fc a -- > -- > scanl f c . fromString == fromString . List.scanl f c -- > scanr f c . fromString == fromString . List.scanr f c -- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a -- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a -- > -- > takeWhile pt pc . fromString == fromString . takeWhile pc -- > dropWhile pt pc . fromString == fromString . dropWhile pc -- > -- > mconcat . intersperse (singleton c) . split (== c) == id -- > find p . fromString == List.find p -- > elem c . fromString == List.elem c -- -- A 'TextualMonoid' may contain non-character data insterspersed between its characters. Every class method that -- returns a modified 'TextualMonoid' instance generally preserves this non-character data. Methods like 'foldr' can -- access both the non-character and character data and expect two arguments for the two purposes. For each of these -- methods there is also a simplified version with underscore in name (like 'foldr_') that ignores the non-character -- data. -- -- All of the following expressions are identities: -- -- > map id -- > concatMap singleton -- > foldl (<>) (\a c-> a <> singleton c) mempty -- > foldr (<>) ((<>) . singleton) mempty -- > foldl' (<>) (\a c-> a <> singleton c) mempty -- > scanl1 (const id) -- > scanr1 const -- > uncurry (mapAccumL (,)) -- > uncurry (mapAccumR (,)) -- > takeWhile (const True) (const True) -- > dropWhile (const False) (const False) -- > toString undefined . fromString class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where -- | Contructs a new data type instance Like 'fromString', but from a 'Text' input instead of 'String'. -- -- > fromText == fromString . Text.unpack fromText :: Text -> t -- | Creates a prime monoid containing a single character. -- -- > singleton c == fromString [c] singleton :: Char -> t -- | Specialized version of 'Factorial.splitPrimePrefix'. Every prime factor of a 'Textual' monoid must consist of a -- single character or no character at all. splitCharacterPrefix :: t -> Maybe (Char, t) -- | Extracts a single character that prefixes the monoid, if the monoid begins with a character. Otherwise returns -- 'Nothing'. -- -- > characterPrefix == fmap fst . splitCharacterPrefix characterPrefix :: t -> Maybe Char -- | Equivalent to 'List.map' from "Data.List" with a @Char -> Char@ function. Preserves all non-character data. -- -- > map f == concatMap (singleton . f) map :: (Char -> Char) -> t -> t -- | Equivalent to 'List.concatMap' from "Data.List" with a @Char -> String@ function. Preserves all non-character -- data. concatMap :: (Char -> t) -> t -> t -- | Returns the list of characters the monoid contains, after having the argument function convert all its -- non-character factors into characters. toString :: (t -> String) -> t -> String -- | Equivalent to 'List.any' from "Data.List". Ignores all non-character data. any :: (Char -> Bool) -> t -> Bool -- | Equivalent to 'List.all' from "Data.List". Ignores all non-character data. all :: (Char -> Bool) -> t -> Bool -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent -- to 'List.foldl' from "Data.List". foldl :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a -- | Strict version of 'foldl'. foldl' :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent -- to 'List.foldl\'' from "Data.List". foldr :: (t -> a -> a) -> (Char -> a -> a) -> a -> t -> a -- | Equivalent to 'List.scanl' from "Data.List" when applied to a 'String', but preserves all non-character data. scanl :: (Char -> Char -> Char) -> Char -> t -> t -- | Equivalent to 'List.scanl1' from "Data.List" when applied to a 'String', but preserves all non-character data. -- -- > scanl f c == scanl1 f . (singleton c <>) scanl1 :: (Char -> Char -> Char) -> t -> t -- | Equivalent to 'List.scanr' from "Data.List" when applied to a 'String', but preserves all non-character data. scanr :: (Char -> Char -> Char) -> Char -> t -> t -- | Equivalent to 'List.scanr1' from "Data.List" when applied to a 'String', but preserves all non-character data. -- -- > scanr f c == scanr1 f . (<> singleton c) scanr1 :: (Char -> Char -> Char) -> t -> t -- | Equivalent to 'List.mapAccumL' from "Data.List" when applied to a 'String', but preserves all non-character -- data. mapAccumL :: (a -> Char -> (a, Char)) -> a -> t -> (a, t) -- | Equivalent to 'List.mapAccumR' from "Data.List" when applied to a 'String', but preserves all non-character -- data. mapAccumR :: (a -> Char -> (a, Char)) -> a -> t -> (a, t) -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to -- 'List.takeWhile' from "Data.List" when applied to a 'String'. takeWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to -- 'List.dropWhile' from "Data.List" when applied to a 'String'. dropWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t -- | 'break pt pc' is equivalent to |span (not . pt) (not . pc)|. break :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t) -- | 'span pt pc t' is equivalent to |(takeWhile pt pc t, dropWhile pt pc t)|. span :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t) -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'. spanMaybe :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s) -- | Strict version of 'spanMaybe'. spanMaybe' :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s) -- | Splits the monoid into components delimited by character separators satisfying the given predicate. The -- characters satisfying the predicate are not a part of the result. -- -- > split p == Factorial.split (maybe False p . characterPrefix) split :: (Char -> Bool) -> t -> [t] -- | Like 'List.find' from "Data.List" when applied to a 'String'. Ignores non-character data. find :: (Char -> Bool) -> t -> Maybe Char -- | Like 'List.elem' from "Data.List" when applied to a 'String'. Ignores non-character data. elem :: Char -> t -> Bool -- | > foldl_ = foldl const foldl_ :: (a -> Char -> a) -> a -> t -> a foldl_' :: (a -> Char -> a) -> a -> t -> a foldr_ :: (Char -> a -> a) -> a -> t -> a -- | > takeWhile_ = takeWhile . const takeWhile_ :: Bool -> (Char -> Bool) -> t -> t -- | > dropWhile_ = dropWhile . const dropWhile_ :: Bool -> (Char -> Bool) -> t -> t -- | > break_ = break . const break_ :: Bool -> (Char -> Bool) -> t -> (t, t) -- | > span_ = span . const span_ :: Bool -> (Char -> Bool) -> t -> (t, t) -- | > spanMaybe_ s = spanMaybe s (const . Just) spanMaybe_ :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s) spanMaybe_' :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s) fromText = fromString . Text.unpack singleton = fromString . (:[]) characterPrefix = fmap fst . splitCharacterPrefix map f = concatMap (singleton . f) concatMap f = foldr mappend (mappend . f) mempty toString f = foldr (mappend . f) (:) [] all p = foldr (const id) ((&&) . p) True any p = foldr (const id) ((||) . p) False foldl ft fc = Factorial.foldl (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime)) foldr ft fc = Factorial.foldr (\prime-> maybe (ft prime) fc (characterPrefix prime)) foldl' ft fc = Factorial.foldl' (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime)) foldl_ = foldl const foldr_ = foldr (const id) foldl_' = foldl' const scanl f c = mappend (singleton c) . fst . foldl foldlOther (foldlChars f) (mempty, c) scanl1 f t = case (Factorial.splitPrimePrefix t, splitCharacterPrefix t) of (Nothing, _) -> t (Just (prefix, suffix), Nothing) -> mappend prefix (scanl1 f suffix) (Just _, Just (c, suffix)) -> scanl f c suffix scanr f c = fst . foldr foldrOther (foldrChars f) (singleton c, c) scanr1 f = fst . foldr foldrOther fc (mempty, Nothing) where fc c (t, Nothing) = (mappend (singleton c) t, Just c) fc c1 (t, Just c2) = (mappend (singleton c') t, Just c') where c' = f c1 c2 mapAccumL f a0 = foldl ft fc (a0, mempty) where ft (a, t1) t2 = (a, mappend t1 t2) fc (a, t) c = (a', mappend t (singleton c')) where (a', c') = f a c mapAccumR f a0 = foldr ft fc (a0, mempty) where ft t1 (a, t2) = (a, mappend t1 t2) fc c (a, t) = (a', mappend (singleton c') t) where (a', c') = f a c takeWhile pt pc = fst . span pt pc dropWhile pt pc = snd . span pt pc span pt pc = Factorial.span (\prime-> maybe (pt prime) pc (characterPrefix prime)) break pt pc = Factorial.break (\prime-> maybe (pt prime) pc (characterPrefix prime)) spanMaybe s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = case Factorial.splitPrimePrefix t of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, t, s) Nothing -> (t0, t, s) spanMaybe' s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = seq s $ case Factorial.splitPrimePrefix t of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, t, s) Nothing -> (t0, t, s) takeWhile_ = takeWhile . const dropWhile_ = dropWhile . const break_ = break . const span_ = span . const spanMaybe_ s = spanMaybe s (const . Just) spanMaybe_' s = spanMaybe' s (const . Just) split p m = prefix : splitRest where (prefix, rest) = break (const False) p m splitRest = case splitCharacterPrefix rest of Nothing -> [] Just (_, tl) -> split p tl find p = foldr (const id) (\c r-> if p c then Just c else r) Nothing elem c = any (== c) {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE fromText #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE split #-} {-# INLINE takeWhile #-} {-# INLINE foldl_ #-} {-# INLINE foldl_' #-} {-# INLINE foldr_ #-} {-# INLINE spanMaybe_ #-} {-# INLINE spanMaybe_' #-} {-# INLINE span_ #-} {-# INLINE break_ #-} {-# INLINE takeWhile_ #-} {-# INLINE dropWhile_ #-} {-# MINIMAL splitCharacterPrefix #-} foldlChars :: TextualMonoid t => (Char -> Char -> Char) -> (t, Char) -> Char -> (t, Char) foldlOther :: Monoid t => (t, Char) -> t -> (t, Char) foldrChars :: TextualMonoid t => (Char -> Char -> Char) -> Char -> (t, Char) -> (t, Char) foldrOther :: Monoid t => t -> (t, a) -> (t, a) foldlChars f (t, c1) c2 = (mappend t (singleton c'), c') where c' = f c1 c2 foldlOther (t1, c) t2 = (mappend t1 t2, c) foldrChars f c1 (t, c2) = (mappend (singleton c') t, c') where c' = f c1 c2 foldrOther t1 (t2, c) = (mappend t1 t2, c) instance TextualMonoid String where fromText = Text.unpack singleton c = [c] splitCharacterPrefix (c:rest) = Just (c, rest) splitCharacterPrefix [] = Nothing characterPrefix (c:_) = Just c characterPrefix [] = Nothing map = List.map concatMap = List.concatMap toString = const id any = List.any all = List.all foldl = const List.foldl foldl' = const List.foldl' foldr = const List.foldr scanl = List.scanl scanl1 = List.scanl1 scanr = List.scanr scanr1 = List.scanr1 mapAccumL = List.mapAccumL mapAccumR = List.mapAccumR takeWhile _ = List.takeWhile dropWhile _ = List.dropWhile break _ = List.break span _ = List.span spanMaybe s0 _ft fc l = (prefix' [], suffix' [], s') where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = (prefix . (c:), id, s1, True) | otherwise = (prefix, suffix . (c:), s, False) spanMaybe' s0 _ft fc l = (prefix' [], suffix' [], s') where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = seq s1 (prefix . (c:), id, s1, True) | otherwise = (prefix, suffix . (c:), s, False) find = List.find elem = List.elem {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE elem #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE fromText #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} instance TextualMonoid Text where fromText = id singleton = Text.singleton splitCharacterPrefix = Text.uncons characterPrefix t = if Text.null t then Nothing else Just (Text.head t) map = Text.map concatMap = Text.concatMap toString = const Text.unpack any = Text.any all = Text.all foldl = const Text.foldl foldl' = const Text.foldl' foldr = const Text.foldr scanl = Text.scanl scanl1 = Text.scanl1 scanr = Text.scanr scanr1 = Text.scanr1 mapAccumL = Text.mapAccumL mapAccumR = Text.mapAccumR takeWhile _ = Text.takeWhile dropWhile _ = Text.dropWhile break _ = Text.break span _ = Text.span spanMaybe s0 _ft fc t = case Text.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 _ft fc t = case Text.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) split = Text.split find = Text.find {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE fromText #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE split #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} instance TextualMonoid LazyText.Text where fromText = LazyText.fromStrict singleton = LazyText.singleton splitCharacterPrefix = LazyText.uncons characterPrefix t = if LazyText.null t then Nothing else Just (LazyText.head t) map = LazyText.map concatMap = LazyText.concatMap toString = const LazyText.unpack any = LazyText.any all = LazyText.all foldl = const LazyText.foldl foldl' = const LazyText.foldl' foldr = const LazyText.foldr scanl = LazyText.scanl scanl1 = LazyText.scanl1 scanr = LazyText.scanr scanr1 = LazyText.scanr1 mapAccumL = LazyText.mapAccumL mapAccumR = LazyText.mapAccumR takeWhile _ = LazyText.takeWhile dropWhile _ = LazyText.dropWhile break _ = LazyText.break span _ = LazyText.span spanMaybe s0 _ft fc t = case LazyText.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 _ft fc t = case LazyText.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) split = LazyText.split find = LazyText.find {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE fromText #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE split #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} instance TextualMonoid (Sequence.Seq Char) where singleton = Sequence.singleton splitCharacterPrefix s = case Sequence.viewl s of Sequence.EmptyL -> Nothing c Sequence.:< rest -> Just (c, rest) characterPrefix s = case Sequence.viewl s of Sequence.EmptyL -> Nothing c Sequence.:< _ -> Just c map = Traversable.fmapDefault concatMap = Foldable.foldMap toString = const Foldable.toList any = Foldable.any all = Foldable.all foldl = const Foldable.foldl foldl' = const Foldable.foldl' foldr = const Foldable.foldr scanl = Sequence.scanl scanl1 f v | Sequence.null v = Sequence.empty | otherwise = Sequence.scanl1 f v scanr = Sequence.scanr scanr1 f v | Sequence.null v = Sequence.empty | otherwise = Sequence.scanr1 f v takeWhile _ = Sequence.takeWhileL dropWhile _ = Sequence.dropWhileL break _ = Sequence.breakl span _ = Sequence.spanl spanMaybe s0 _ft fc b = case Foldable.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 _ft fc b = case Foldable.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) find = Foldable.find elem = Foldable.elem {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE elem #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE map #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} instance IsString (Vector.Vector Char) where fromString = Vector.fromList instance TextualMonoid (Vector.Vector Char) where singleton = Vector.singleton splitCharacterPrefix t = if Vector.null t then Nothing else Just (Vector.unsafeHead t, Vector.unsafeTail t) characterPrefix = (Vector.!? 0) map = Vector.map concatMap = Vector.concatMap toString = const Vector.toList any = Vector.any all = Vector.all foldl = const Vector.foldl foldl' = const Vector.foldl' foldr = const Vector.foldr scanl = Vector.scanl scanl1 f v | Vector.null v = Vector.empty | otherwise = Vector.scanl1 f v scanr = Vector.scanr scanr1 f v | Vector.null v = Vector.empty | otherwise = Vector.scanr1 f v mapAccumL f a0 t = (a', Vector.reverse $ Vector.fromList l') where (a', l') = Vector.foldl fc (a0, []) t fc (a, l) c = (:l) <$> f a c mapAccumR f a0 t = (a', Vector.fromList l') where (a', l') = Vector.foldr fc (a0, []) t fc c (a, l) = (:l) <$> f a c takeWhile _ = Vector.takeWhile dropWhile _ = Vector.dropWhile break _ = Vector.break span _ = Vector.span spanMaybe s0 _ft fc v = case Vector.ifoldr g Left v s0 of Left s' -> (v, Vector.empty, s') Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') where g i c cont s | Just s' <- fc s c = cont s' | otherwise = Right (i, s) spanMaybe' s0 _ft fc v = case Vector.ifoldr' g Left v s0 of Left s' -> (v, Vector.empty, s') Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') where g i c cont s | Just s' <- fc s c = seq s' (cont s') | otherwise = Right (i, s) find = Vector.find elem = Vector.elem {-# INLINE all #-} {-# INLINE any #-} {-# INLINE break #-} {-# INLINE characterPrefix #-} {-# INLINE concatMap #-} {-# INLINE dropWhile #-} {-# INLINE elem #-} {-# INLINE find #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE map #-} {-# INLINE mapAccumL #-} {-# INLINE mapAccumR #-} {-# INLINE scanl #-} {-# INLINE scanl1 #-} {-# INLINE scanr #-} {-# INLINE scanr1 #-} {-# INLINE singleton #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE takeWhile #-} monoid-subclasses-0.4.2.1/Data/Monoid/Factorial.hs0000644000000000000000000007476712717754212020067 0ustar0000000000000000{- Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'FactorialMonoid' class and some of its instances. -- {-# LANGUAGE Haskell2010, Trustworthy #-} module Data.Monoid.Factorial ( -- * Classes FactorialMonoid(..), StableFactorialMonoid, -- * Monad function equivalents mapM, mapM_ ) where import Control.Arrow (first) import qualified Control.Monad as Monad import Data.Monoid -- (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set import qualified Data.Vector as Vector import Data.Int (Int64) import Data.Numbers.Primes (primeFactors) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Prelude hiding (break, drop, dropWhile, foldl, foldr, last, length, map, mapM, mapM_, max, min, null, reverse, span, splitAt, take, takeWhile) -- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of -- a 'Product' are literally its prime factors: -- -- prop> factors (Product 12) == [Product 2, Product 2, Product 3] -- -- Factors of a list are /not/ its elements but all its single-item sublists: -- -- prop> factors "abc" == ["a", "b", "c"] -- -- The methods of this class satisfy the following laws: -- -- > mconcat . factors == id -- > null == List.null . factors -- > List.all (\prime-> factors prime == [prime]) . factors -- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix) -- > reverse == mconcat . List.reverse . factors -- > primePrefix == maybe mempty fst . splitPrimePrefix -- > primeSuffix == maybe mempty snd . splitPrimeSuffix -- > inits == List.map mconcat . List.inits . factors -- > tails == List.map mconcat . List.tails . factors -- > foldl f a == List.foldl f a . factors -- > foldl' f a == List.foldl' f a . factors -- > foldr f a == List.foldr f a . factors -- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m) -- > List.all (List.all (not . pred) . factors) . split pred -- > mconcat . intersperse prime . split (== prime) == id -- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m) -- > spanMaybe () (const $ bool Nothing (Maybe ()) . p) m == (takeWhile p m, dropWhile p m, ()) -- > spanMaybe s0 (\s m-> Just $ f s m) m0 == (m0, mempty, foldl f s0 m0) -- > let (prefix, suffix, s') = spanMaybe s f m -- > foldMaybe = foldl g (Just s) -- > g s m = s >>= flip f m -- > in all ((Nothing ==) . foldMaybe) (inits prefix) -- > && prefix == last (filter (isJust . foldMaybe) $ inits m) -- > && Just s' == foldMaybe prefix -- > && m == prefix <> suffix -- -- A minimal instance definition must implement 'factors' or 'splitPrimePrefix'. Other methods are provided and should -- be implemented only for performance reasons. class MonoidNull m => FactorialMonoid m where -- | Returns a list of all prime factors; inverse of mconcat. factors :: m -> [m] -- | The prime prefix, 'mempty' if none. primePrefix :: m -> m -- | The prime suffix, 'mempty' if none. primeSuffix :: m -> m -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'. splitPrimePrefix :: m -> Maybe (m, m) -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'. splitPrimeSuffix :: m -> Maybe (m, m) -- | Returns the list of all prefixes of the argument, 'mempty' first. inits :: m -> [m] -- | Returns the list of all suffixes of the argument, 'mempty' last. tails :: m -> [m] -- | Like 'List.foldl' from "Data.List" on the list of 'primes'. foldl :: (a -> m -> a) -> a -> m -> a -- | Like 'List.foldl'' from "Data.List" on the list of 'primes'. foldl' :: (a -> m -> a) -> a -> m -> a -- | Like 'List.foldr' from "Data.List" on the list of 'primes'. foldr :: (m -> a -> a) -> a -> m -> a -- | The 'length' of the list of 'primes'. length :: m -> Int -- | Generalizes 'foldMap' from "Data.Foldable", except the function arguments are prime factors rather than the -- structure elements. foldMap :: Monoid n => (m -> n) -> m -> n -- | Like 'List.span' from "Data.List" on the list of 'primes'. span :: (m -> Bool) -> m -> (m, m) -- | Equivalent to 'List.break' from "Data.List". break :: (m -> Bool) -> m -> (m, m) -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes -- satisfying the predicate are not a part of the result. split :: (m -> Bool) -> m -> [m] -- | Equivalent to 'List.takeWhile' from "Data.List". takeWhile :: (m -> Bool) -> m -> m -- | Equivalent to 'List.dropWhile' from "Data.List". dropWhile :: (m -> Bool) -> m -> m -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'. spanMaybe :: s -> (s -> m -> Maybe s) -> m -> (m, m, s) -- | Strict version of 'spanMaybe'. spanMaybe' :: s -> (s -> m -> Maybe s) -> m -> (m, m, s) -- | Like 'List.splitAt' from "Data.List" on the list of 'primes'. splitAt :: Int -> m -> (m, m) -- | Equivalent to 'List.drop' from "Data.List". drop :: Int -> m -> m -- | Equivalent to 'List.take' from "Data.List". take :: Int -> m -> m -- | Equivalent to 'List.reverse' from "Data.List". reverse :: m -> m factors = List.unfoldr splitPrimePrefix primePrefix = maybe mempty fst . splitPrimePrefix primeSuffix = maybe mempty snd . splitPrimeSuffix splitPrimePrefix x = case factors x of [] -> Nothing prefix : rest -> Just (prefix, mconcat rest) splitPrimeSuffix x = case factors x of [] -> Nothing fs -> Just (mconcat (List.init fs), List.last fs) inits = foldr (\m l-> mempty : List.map (mappend m) l) [mempty] tails m = m : maybe [] (tails . snd) (splitPrimePrefix m) foldl f f0 = List.foldl f f0 . factors foldl' f f0 = List.foldl' f f0 . factors foldr f f0 = List.foldr f f0 . factors length = List.length . factors foldMap f = foldr (mappend . f) mempty span p m0 = spanAfter id m0 where spanAfter f m = case splitPrimePrefix m of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest _ -> (f mempty, m) break = span . (not .) spanMaybe s0 f m0 = spanAfter id s0 m0 where spanAfter g s m = case splitPrimePrefix m of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, m, s) Nothing -> (m0, m, s) spanMaybe' s0 f m0 = spanAfter id s0 m0 where spanAfter g s m = seq s $ case splitPrimePrefix m of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest | otherwise -> (g mempty, m, s) Nothing -> (m0, m, s) split p m = prefix : splitRest where (prefix, rest) = break p m splitRest = case splitPrimePrefix rest of Nothing -> [] Just (_, tl) -> split p tl takeWhile p = fst . span p dropWhile p = snd . span p splitAt n0 m0 | n0 <= 0 = (mempty, m0) | otherwise = split' n0 id m0 where split' 0 f m = (f mempty, m) split' n f m = case splitPrimePrefix m of Nothing -> (f mempty, m) Just (prime, rest) -> split' (pred n) (f . mappend prime) rest drop n p = snd (splitAt n p) take n p = fst (splitAt n p) reverse = mconcat . List.reverse . factors {-# MINIMAL factors | splitPrimePrefix #-} -- | A subclass of 'FactorialMonoid' whose instances satisfy this additional law: -- -- > factors (a <> b) == factors a <> factors b class (FactorialMonoid m, PositiveMonoid m) => StableFactorialMonoid m instance FactorialMonoid () where factors () = [] primePrefix () = () primeSuffix () = () splitPrimePrefix () = Nothing splitPrimeSuffix () = Nothing length () = 0 reverse = id instance FactorialMonoid a => FactorialMonoid (Dual a) where factors (Dual a) = fmap Dual (reverse $ factors a) length (Dual a) = length a primePrefix (Dual a) = Dual (primeSuffix a) primeSuffix (Dual a) = Dual (primePrefix a) splitPrimePrefix (Dual a) = case splitPrimeSuffix a of Nothing -> Nothing Just (p, s) -> Just (Dual s, Dual p) splitPrimeSuffix (Dual a) = case splitPrimePrefix a of Nothing -> Nothing Just (p, s) -> Just (Dual s, Dual p) inits (Dual a) = fmap Dual (reverse $ tails a) tails (Dual a) = fmap Dual (reverse $ inits a) reverse (Dual a) = Dual (reverse a) instance (Integral a, Eq a) => FactorialMonoid (Sum a) where primePrefix (Sum a) = Sum (signum a ) primeSuffix = primePrefix splitPrimePrefix (Sum 0) = Nothing splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a)) splitPrimeSuffix (Sum 0) = Nothing splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a)) length (Sum a) = abs (fromIntegral a) reverse = id instance Integral a => FactorialMonoid (Product a) where factors (Product a) = List.map Product (primeFactors a) reverse = id instance FactorialMonoid a => FactorialMonoid (Maybe a) where factors Nothing = [] factors (Just a) | null a = [Just a] | otherwise = List.map Just (factors a) length Nothing = 0 length (Just a) | null a = 1 | otherwise = length a reverse = fmap reverse instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where factors (a, b) = List.map (\a1-> (a1, mempty)) (factors a) ++ List.map ((,) mempty) (factors b) primePrefix (a, b) | null a = (a, primePrefix b) | otherwise = (primePrefix a, mempty) primeSuffix (a, b) | null b = (primeSuffix a, b) | otherwise = (mempty, primeSuffix b) splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b) of (Just (ap, as), _) -> Just ((ap, mempty), (as, b)) (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs)) (Nothing, Nothing) -> Nothing splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b) of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs)) (Just (ap, as), Nothing) -> Just ((ap, b), (as, b)) (Nothing, Nothing) -> Nothing inits (a, b) = List.map (flip (,) mempty) (inits a) ++ List.map ((,) a) (List.tail $ inits b) tails (a, b) = List.map (flip (,) b) (tails a) ++ List.map ((,) mempty) (List.tail $ tails b) foldl f a0 (x, y) = foldl f2 (foldl f1 a0 x) y where f1 a = f a . fromFst f2 a = f a . fromSnd foldl' f a0 (x, y) = a' `seq` foldl' f2 a' y where f1 a = f a . fromFst f2 a = f a . fromSnd a' = foldl' f1 a0 x foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x foldMap f (x, y) = Data.Monoid.Factorial.foldMap (f . fromFst) x `mappend` Data.Monoid.Factorial.foldMap (f . fromSnd) y length (a, b) = length a + length b span p (x, y) = ((xp, yp), (xs, ys)) where (xp, xs) = span (p . fromFst) x (yp, ys) | null xs = span (p . fromSnd) y | otherwise = (mempty, y) spanMaybe s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2) | otherwise = ((xp, mempty), (xs, y), s1) where (xp, xs, s1) = spanMaybe s0 (\s-> f s . fromFst) x (yp, ys, s2) = spanMaybe s1 (\s-> f s . fromSnd) y spanMaybe' s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2) | otherwise = ((xp, mempty), (xs, y), s1) where (xp, xs, s1) = spanMaybe' s0 (\s-> f s . fromFst) x (yp, ys, s2) = spanMaybe' s1 (\s-> f s . fromSnd) y split p (x0, y0) = fst $ List.foldr combine (ys, False) xs where xs = List.map fromFst $ split (p . fromFst) x0 ys = List.map fromSnd $ split (p . fromSnd) y0 combine x (~(y:rest), False) = (mappend x y : rest, True) combine x (rest, True) = (x:rest, True) splitAt n (x, y) = ((xp, yp), (xs, ys)) where (xp, xs) = splitAt n x (yp, ys) | null xs = splitAt (n - length x) y | otherwise = (mempty, y) reverse (a, b) = (reverse a, reverse b) {-# INLINE fromFst #-} fromFst :: Monoid b => a -> (a, b) fromFst a = (a, mempty) {-# INLINE fromSnd #-} fromSnd :: Monoid a => b -> (a, b) fromSnd b = (mempty, b) instance FactorialMonoid [x] where factors xs = List.map (:[]) xs primePrefix [] = [] primePrefix (x:_) = [x] primeSuffix [] = [] primeSuffix xs = [List.last xs] splitPrimePrefix [] = Nothing splitPrimePrefix (x:xs) = Just ([x], xs) splitPrimeSuffix [] = Nothing splitPrimeSuffix xs = Just (splitLast id xs) where splitLast f last@[_] = (f [], last) splitLast f ~(x:rest) = splitLast (f . (x:)) rest inits = List.inits tails = List.tails foldl _ a [] = a foldl f a (x:xs) = foldl f (f a [x]) xs foldl' _ a [] = a foldl' f a (x:xs) = let a' = f a [x] in a' `seq` foldl' f a' xs foldr _ f0 [] = f0 foldr f f0 (x:xs) = f [x] (foldr f f0 xs) length = List.length foldMap f = mconcat . List.map (f . (:[])) break f = List.break (f . (:[])) span f = List.span (f . (:[])) dropWhile f = List.dropWhile (f . (:[])) takeWhile f = List.takeWhile (f . (:[])) spanMaybe s0 f l = (prefix' [], suffix' [], s') where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = (prefix . (x:), id, s2, True) | otherwise = (prefix, suffix . (x:), s1, False) spanMaybe' s0 f l = (prefix' [], suffix' [], s') where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = seq s2 $ (prefix . (x:), id, s2, True) | otherwise = (prefix, suffix . (x:), s1, False) splitAt = List.splitAt drop = List.drop take = List.take reverse = List.reverse instance FactorialMonoid ByteString.ByteString where factors x = factorize (ByteString.length x) x where factorize 0 _ = [] factorize n xs = xs1 : factorize (pred n) xs' where (xs1, xs') = ByteString.splitAt 1 xs primePrefix = ByteString.take 1 primeSuffix x = ByteString.drop (ByteString.length x - 1) x splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x) splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x) inits = ByteString.inits tails = ByteString.tails foldl f = ByteString.foldl f' where f' a byte = f a (ByteString.singleton byte) foldl' f = ByteString.foldl' f' where f' a byte = f a (ByteString.singleton byte) foldr f = ByteString.foldr (f . ByteString.singleton) break f = ByteString.break (f . ByteString.singleton) span f = ByteString.span (f . ByteString.singleton) spanMaybe s0 f b = case ByteString.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s') where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f b = case ByteString.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s') where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) dropWhile f = ByteString.dropWhile (f . ByteString.singleton) takeWhile f = ByteString.takeWhile (f . ByteString.singleton) length = ByteString.length split f = ByteString.splitWith f' where f' = f . ByteString.singleton splitAt = ByteString.splitAt drop = ByteString.drop take = ByteString.take reverse = ByteString.reverse instance FactorialMonoid LazyByteString.ByteString where factors x = factorize (LazyByteString.length x) x where factorize 0 _ = [] factorize n xs = xs1 : factorize (pred n) xs' where (xs1, xs') = LazyByteString.splitAt 1 xs primePrefix = LazyByteString.take 1 primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x splitPrimePrefix x = if LazyByteString.null x then Nothing else Just (LazyByteString.splitAt 1 x) splitPrimeSuffix x = if LazyByteString.null x then Nothing else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x) inits = LazyByteString.inits tails = LazyByteString.tails foldl f = LazyByteString.foldl f' where f' a byte = f a (LazyByteString.singleton byte) foldl' f = LazyByteString.foldl' f' where f' a byte = f a (LazyByteString.singleton byte) foldr f = LazyByteString.foldr f' where f' byte a = f (LazyByteString.singleton byte) a length = fromIntegral . LazyByteString.length break f = LazyByteString.break (f . LazyByteString.singleton) span f = LazyByteString.span (f . LazyByteString.singleton) spanMaybe s0 f b = case LazyByteString.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s') where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f b = case LazyByteString.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s') where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton) takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton) split f = LazyByteString.splitWith f' where f' = f . LazyByteString.singleton splitAt = LazyByteString.splitAt . fromIntegral drop n = LazyByteString.drop (fromIntegral n) take n = LazyByteString.take (fromIntegral n) reverse = LazyByteString.reverse instance FactorialMonoid Text.Text where factors = Text.chunksOf 1 primePrefix = Text.take 1 primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x) splitPrimePrefix = fmap (first Text.singleton) . Text.uncons splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x)) inits = Text.inits tails = Text.tails foldl f = Text.foldl f' where f' a char = f a (Text.singleton char) foldl' f = Text.foldl' f' where f' a char = f a (Text.singleton char) foldr f = Text.foldr f' where f' char a = f (Text.singleton char) a length = Text.length span f = Text.span (f . Text.singleton) break f = Text.break (f . Text.singleton) dropWhile f = Text.dropWhile (f . Text.singleton) takeWhile f = Text.takeWhile (f . Text.singleton) spanMaybe s0 f t = case Text.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f t = case Text.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) split f = Text.split f' where f' = f . Text.singleton splitAt = Text.splitAt drop = Text.drop take = Text.take reverse = Text.reverse instance FactorialMonoid LazyText.Text where factors = LazyText.chunksOf 1 primePrefix = LazyText.take 1 primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x) splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons splitPrimeSuffix x = if LazyText.null x then Nothing else Just (LazyText.init x, LazyText.singleton (LazyText.last x)) inits = LazyText.inits tails = LazyText.tails foldl f = LazyText.foldl f' where f' a char = f a (LazyText.singleton char) foldl' f = LazyText.foldl' f' where f' a char = f a (LazyText.singleton char) foldr f = LazyText.foldr f' where f' char a = f (LazyText.singleton char) a length = fromIntegral . LazyText.length span f = LazyText.span (f . LazyText.singleton) break f = LazyText.break (f . LazyText.singleton) dropWhile f = LazyText.dropWhile (f . LazyText.singleton) takeWhile f = LazyText.takeWhile (f . LazyText.singleton) spanMaybe s0 f t = case LazyText.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f t = case LazyText.foldr g id t (0, s0) of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) split f = LazyText.split f' where f' = f . LazyText.singleton splitAt = LazyText.splitAt . fromIntegral drop n = LazyText.drop (fromIntegral n) take n = LazyText.take (fromIntegral n) reverse = LazyText.reverse instance Ord k => FactorialMonoid (Map.Map k v) where factors = List.map (uncurry Map.singleton) . Map.toAscList primePrefix map | Map.null map = map | otherwise = uncurry Map.singleton $ Map.findMin map primeSuffix map | Map.null map = map | otherwise = uncurry Map.singleton $ Map.findMax map splitPrimePrefix = fmap singularize . Map.minViewWithKey where singularize ((k, v), rest) = (Map.singleton k v, rest) splitPrimeSuffix = fmap singularize . Map.maxViewWithKey where singularize ((k, v), rest) = (rest, Map.singleton k v) foldl f = Map.foldlWithKey f' where f' a k v = f a (Map.singleton k v) foldl' f = Map.foldlWithKey' f' where f' a k v = f a (Map.singleton k v) foldr f = Map.foldrWithKey f' where f' k v a = f (Map.singleton k v) a length = Map.size reverse = id instance FactorialMonoid (IntMap.IntMap a) where factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList primePrefix map | IntMap.null map = map | otherwise = uncurry IntMap.singleton $ IntMap.findMin map primeSuffix map | IntMap.null map = map | otherwise = uncurry IntMap.singleton $ IntMap.findMax map splitPrimePrefix = fmap singularize . IntMap.minViewWithKey where singularize ((k, v), rest) = (IntMap.singleton k v, rest) splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey where singularize ((k, v), rest) = (rest, IntMap.singleton k v) foldl f = IntMap.foldlWithKey f' where f' a k v = f a (IntMap.singleton k v) foldl' f = IntMap.foldlWithKey' f' where f' a k v = f a (IntMap.singleton k v) foldr f = IntMap.foldrWithKey f' where f' k v a = f (IntMap.singleton k v) a length = IntMap.size reverse = id instance FactorialMonoid IntSet.IntSet where factors = List.map IntSet.singleton . IntSet.toAscList primePrefix set | IntSet.null set = set | otherwise = IntSet.singleton $ IntSet.findMin set primeSuffix set | IntSet.null set = set | otherwise = IntSet.singleton $ IntSet.findMax set splitPrimePrefix = fmap singularize . IntSet.minView where singularize (min, rest) = (IntSet.singleton min, rest) splitPrimeSuffix = fmap singularize . IntSet.maxView where singularize (max, rest) = (rest, IntSet.singleton max) foldl f = IntSet.foldl f' where f' a b = f a (IntSet.singleton b) foldl' f = IntSet.foldl' f' where f' a b = f a (IntSet.singleton b) foldr f = IntSet.foldr f' where f' a b = f (IntSet.singleton a) b length = IntSet.size reverse = id instance FactorialMonoid (Sequence.Seq a) where factors = List.map Sequence.singleton . Foldable.toList primePrefix = Sequence.take 1 primeSuffix q = Sequence.drop (Sequence.length q - 1) q splitPrimePrefix q = case Sequence.viewl q of Sequence.EmptyL -> Nothing hd Sequence.:< rest -> Just (Sequence.singleton hd, rest) splitPrimeSuffix q = case Sequence.viewr q of Sequence.EmptyR -> Nothing rest Sequence.:> last -> Just (rest, Sequence.singleton last) inits = Foldable.toList . Sequence.inits tails = Foldable.toList . Sequence.tails foldl f = Foldable.foldl f' where f' a b = f a (Sequence.singleton b) foldl' f = Foldable.foldl' f' where f' a b = f a (Sequence.singleton b) foldr f = Foldable.foldr f' where f' a b = f (Sequence.singleton a) b span f = Sequence.spanl (f . Sequence.singleton) break f = Sequence.breakl (f . Sequence.singleton) dropWhile f = Sequence.dropWhileL (f . Sequence.singleton) takeWhile f = Sequence.takeWhileL (f . Sequence.singleton) spanMaybe s0 f b = case Foldable.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ cont (i', s') | otherwise = (i, s) spanMaybe' s0 f b = case Foldable.foldr g id b (0, s0) of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') | otherwise = (i, s) splitAt = Sequence.splitAt drop = Sequence.drop take = Sequence.take length = Sequence.length reverse = Sequence.reverse instance Ord a => FactorialMonoid (Set.Set a) where factors = List.map Set.singleton . Set.toAscList primePrefix set | Set.null set = set | otherwise = Set.singleton $ Set.findMin set primeSuffix set | Set.null set = set | otherwise = Set.singleton $ Set.findMax set splitPrimePrefix = fmap singularize . Set.minView where singularize (min, rest) = (Set.singleton min, rest) splitPrimeSuffix = fmap singularize . Set.maxView where singularize (max, rest) = (rest, Set.singleton max) foldl f = Foldable.foldl f' where f' a b = f a (Set.singleton b) foldl' f = Foldable.foldl' f' where f' a b = f a (Set.singleton b) foldr f = Foldable.foldr f' where f' a b = f (Set.singleton a) b length = Set.size reverse = id instance FactorialMonoid (Vector.Vector a) where factors x = factorize (Vector.length x) x where factorize 0 _ = [] factorize n xs = xs1 : factorize (pred n) xs' where (xs1, xs') = Vector.splitAt 1 xs primePrefix = Vector.take 1 primeSuffix x = Vector.drop (Vector.length x - 1) x splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x) splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x) inits x0 = initsWith x0 [] where initsWith x rest | Vector.null x = x:rest | otherwise = initsWith (Vector.unsafeInit x) (x:rest) tails x = x : if Vector.null x then [] else tails (Vector.unsafeTail x) foldl f = Vector.foldl f' where f' a byte = f a (Vector.singleton byte) foldl' f = Vector.foldl' f' where f' a byte = f a (Vector.singleton byte) foldr f = Vector.foldr f' where f' byte a = f (Vector.singleton byte) a break f = Vector.break (f . Vector.singleton) span f = Vector.span (f . Vector.singleton) dropWhile f = Vector.dropWhile (f . Vector.singleton) takeWhile f = Vector.takeWhile (f . Vector.singleton) spanMaybe s0 f v = case Vector.ifoldr g Left v s0 of Left s' -> (v, Vector.empty, s') Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') where g i x cont s | Just s' <- f s (Vector.singleton x) = cont s' | otherwise = Right (i, s) spanMaybe' s0 f v = case Vector.ifoldr' g Left v s0 of Left s' -> (v, Vector.empty, s') Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') where g i x cont s | Just s' <- f s (Vector.singleton x) = seq s' (cont s') | otherwise = Right (i, s) splitAt = Vector.splitAt drop = Vector.drop take = Vector.take length = Vector.length reverse = Vector.reverse instance StableFactorialMonoid () instance StableFactorialMonoid a => StableFactorialMonoid (Dual a) instance StableFactorialMonoid [x] instance StableFactorialMonoid ByteString.ByteString instance StableFactorialMonoid LazyByteString.ByteString instance StableFactorialMonoid Text.Text instance StableFactorialMonoid LazyText.Text instance StableFactorialMonoid (Sequence.Seq a) instance StableFactorialMonoid (Vector.Vector a) -- | A 'Monad.mapM' equivalent. mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b mapM f = ($ return mempty) . appEndo . Data.Monoid.Factorial.foldMap (Endo . Monad.liftM2 mappend . f) -- | A 'Monad.mapM_' equivalent. mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m () mapM_ f = foldr ((>>) . f) (return ()) monoid-subclasses-0.4.2.1/Data/Monoid/Instances/0000755000000000000000000000000012717754212017531 5ustar0000000000000000monoid-subclasses-0.4.2.1/Data/Monoid/Instances/Concat.hs0000644000000000000000000003347712717754212021312 0ustar0000000000000000{- Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Concat'. -- {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Concat ( Concat, concatenate, extract ) where import Control.Applicative -- (Applicative(..)) import qualified Data.Foldable as Foldable 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 import Data.Sequence (Seq, filter, (<|), (|>), ViewL((:<)), ViewR((:>))) import qualified Data.Sequence as Seq import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) -- | @'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 'pure' 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 logarithmic-time operation. -- newtype Concat a = Concat {extract :: Seq a} deriving Show concatenate :: PositiveMonoid a => Seq a -> Concat a concatenate = Concat . filter (not . null) 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 Functor Concat where fmap f (Concat x) = Concat (fmap f x) instance Applicative Concat where pure a = Concat (Seq.singleton a) Concat x <*> Concat y = Concat (x <*> y) Concat x *> Concat y = Concat (x *> 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 c1 c2 = fmap Concat $ strip1 (extract c1) (extract c2) 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 c1 c2 = fmap Concat $ strip1 (extract c1) (extract c2) 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 a0 (Concat x) = Foldable.foldl g a0 x where g = Factorial.foldl (\a-> f a . Concat . Seq.singleton) foldl' f a0 (Concat x) = Foldable.foldl' g a0 x where g = Factorial.foldl' (\a-> f a . Concat . Seq.singleton) foldr f a0 (Concat x) = Foldable.foldr g a0 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 (Factorial.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) spanMaybe s0 f (Concat x) = case Seq.viewl x of Seq.EmptyL -> (mempty, mempty, s0) xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'') | null xpp -> (mempty, Concat x, s') | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s') where (xpp, xps, s') = Factorial.spanMaybe s0 (\s-> f s . Concat . Seq.singleton) xp (Concat xsp, xss, s'') = Factorial.spanMaybe s' f (Concat xs) spanMaybe' s0 f (Concat x) = seq s0 $ case Seq.viewl x of Seq.EmptyL -> (mempty, mempty, s0) xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'') | null xpp -> (mempty, Concat x, s') | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s') where (xpp, xps, s') = Factorial.spanMaybe' s0 (\s-> f s . Concat . Seq.singleton) xp (Concat xsp, xss, s'') = Factorial.spanMaybe' s' f (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 (reverse <$> reverse x) instance (IsString a) => IsString (Concat a) where fromString "" = Concat Seq.empty fromString s = Concat (Seq.singleton $ fromString s) instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Concat a) where fromText t | null t = Concat Seq.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 a0 (Concat x) = Foldable.foldl g a0 x where g = Textual.foldl (\a-> ft a . Concat . Seq.singleton) fc foldl' ft fc a0 (Concat x) = Foldable.foldl' g a0 x where g = Textual.foldl' (\a-> ft a . Concat . Seq.singleton) fc foldr ft fc a0 (Concat x) = Foldable.foldr g a0 x where g a b = Textual.foldr (ft . Concat . Seq.singleton) fc b a toString ft (Concat x) = List.concatMap (toString $ ft . Concat . Seq.singleton) (Foldable.toList x) 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) span_ bt 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_ bt pc xp (Concat xsp, xss) = Textual.span_ bt pc (Concat xs) break pt pc = Textual.span (not . pt) (not . pc) takeWhile_ bt pc = fst . span_ bt pc dropWhile_ bt pc = snd . span_ bt pc break_ bt pc = span_ (not bt) (not . pc) spanMaybe s0 ft fc (Concat x) = case Seq.viewl x of Seq.EmptyL -> (mempty, mempty, s0) xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'') | null xpp -> (mempty, Concat x, s') | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s') where (xpp, xps, s') = Textual.spanMaybe s0 (\s-> ft s . Concat . Seq.singleton) fc xp (Concat xsp, xss, s'') = Textual.spanMaybe s' ft fc (Concat xs) spanMaybe' s0 ft fc (Concat x) = seq s0 $ case Seq.viewl x of Seq.EmptyL -> (mempty, mempty, s0) xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'') | null xpp -> (mempty, Concat x, s') | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s') where (xpp, xps, s') = Textual.spanMaybe' s0 (\s-> ft s . Concat . Seq.singleton) fc xp (Concat xsp, xss, s'') = Textual.spanMaybe' s' ft fc (Concat xs) spanMaybe_ s0 fc (Concat x) = case Seq.viewl x of Seq.EmptyL -> (mempty, mempty, s0) xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'') | null xpp -> (mempty, Concat x, s') | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s') where (xpp, xps, s') = Textual.spanMaybe_ s0 fc xp (Concat xsp, xss, s'') = Textual.spanMaybe_ s' fc (Concat xs) spanMaybe_' s0 fc (Concat x) = seq s0 $ case Seq.viewl x of Seq.EmptyL -> (mempty, mempty, s0) xp :< xs | null xps -> (Concat (xp <| xsp), xss, s'') | null xpp -> (mempty, Concat x, s') | otherwise -> (Concat $ Seq.singleton xpp, Concat (xps <| xs), s') where (xpp, xps, s') = Textual.spanMaybe_' s0 fc xp (Concat xsp, xss, s'') = Textual.spanMaybe_' s' fc (Concat xs) split p (Concat x) = Foldable.foldr splitNext [mempty] x where splitNext a ~(xp:xs) = let as = fmap (Concat . Seq.singleton) (Textual.split p a) in if null xp then as ++ xs else init as ++ (last as <> xp):xs find p (Concat x) = getFirst $ Foldable.foldMap (First . find p) x elem c (Concat x) = Foldable.any (Textual.elem c) x monoid-subclasses-0.4.2.1/Data/Monoid/Instances/Positioned.hs0000644000000000000000000007663512717754212022223 0ustar0000000000000000{- Copyright 2014-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines two monoid transformer data types, 'OffsetPositioned' and 'LinePositioned'. Both data types add -- a notion of the current position to their base monoid. In case of 'OffsetPositioned', the current position is a -- simple integer offset from the beginning of the monoid, and it can be applied to any 'StableFactorialMonoid'. The -- base monoid of 'LinePositioned' must be a 'TextualMonoid', but for the price it will keep track of the current line -- and column numbers as well. -- -- All positions are zero-based: -- -- >> let p = pure "abcd\nefgh\nijkl\nmnop\n" :: LinePositioned String -- >> p -- >Line 0, column 0: "abcd\nefgh\nijkl\nmnop\n" -- >> Data.Monoid.Factorial.drop 13 p -- >Line 2, column 3: "l\nmnop\n" {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Positioned ( OffsetPositioned, LinePositioned, extract, position, line, column ) where import Control.Applicative -- (Applicative(..)) import qualified Data.List as List import Data.String (IsString(..)) import Data.Monoid -- (Monoid(..), (<>), Endo(..)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, lines, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) class Positioned p where extract :: p a -> a position :: p a -> Int data OffsetPositioned m = OffsetPositioned{offset :: !Int, -- ^ the current offset extractOffset :: m} data LinePositioned m = LinePositioned{fullOffset :: !Int, -- | the current line line :: !Int, lineStart :: !Int, extractLines :: m} -- | the current column column :: LinePositioned m -> Int column lp = position lp - lineStart lp instance Functor OffsetPositioned where fmap f (OffsetPositioned p c) = OffsetPositioned p (f c) instance Functor LinePositioned where fmap f (LinePositioned p l lp c) = LinePositioned p l lp (f c) instance Applicative OffsetPositioned where pure = OffsetPositioned 0 OffsetPositioned _ f <*> OffsetPositioned p c = OffsetPositioned p (f c) instance Applicative LinePositioned where pure = LinePositioned 0 0 0 LinePositioned _ _ _ f <*> LinePositioned p l lp c = LinePositioned p l lp (f c) instance Positioned OffsetPositioned where extract = extractOffset position = offset instance Positioned LinePositioned where extract = extractLines position = fullOffset instance Eq m => Eq (OffsetPositioned m) where OffsetPositioned{extractOffset= a} == OffsetPositioned{extractOffset= b} = a == b instance Eq m => Eq (LinePositioned m) where LinePositioned{extractLines= a} == LinePositioned{extractLines= b} = a == b instance Ord m => Ord (OffsetPositioned m) where compare OffsetPositioned{extractOffset= a} OffsetPositioned{extractOffset= b} = compare a b instance Ord m => Ord (LinePositioned m) where compare LinePositioned{extractLines= a} LinePositioned{extractLines= b} = compare a b instance Show m => Show (OffsetPositioned m) where showsPrec prec (OffsetPositioned pos c) = shows pos . (": " ++) . showsPrec prec c instance Show m => Show (LinePositioned m) where showsPrec prec (LinePositioned pos l lpos c) = ("Line " ++) . shows l . (", column " ++) . shows (pos - lpos) . (": " ++) . showsPrec prec c instance StableFactorialMonoid m => Monoid (OffsetPositioned m) where mempty = pure mempty mappend (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = OffsetPositioned (if p1 /= 0 || p2 == 0 then p1 else max 0 $ p2 - length c1) (mappend c1 c2) {-# INLINE mempty #-} {-# INLINE mappend #-} instance (StableFactorialMonoid m, TextualMonoid m) => Monoid (LinePositioned m) where mempty = pure mempty mappend (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) | p1 /= 0 || p2 == 0 = LinePositioned p1 l1 lp1 c | otherwise = LinePositioned p2' l2' lp2' c where c = mappend c1 c2 p2' = max 0 $ p2 - length c1 lp2' = min p2' lp2 l2' = if l2 == 0 then 0 else max 0 $ l2 - Textual.foldl_' countLines 0 c1 countLines :: Int -> Char -> Int countLines n '\n' = succ n countLines n _ = n {-# INLINE mempty #-} {-# INLINE mappend #-} instance (StableFactorialMonoid m, MonoidNull m) => MonoidNull (OffsetPositioned m) where null = null . extractOffset {-# INLINE null #-} instance (StableFactorialMonoid m, TextualMonoid m, MonoidNull m) => MonoidNull (LinePositioned m) where null = null . extractLines {-# INLINE null #-} instance (StableFactorialMonoid m, PositiveMonoid m) => PositiveMonoid (OffsetPositioned m) instance (StableFactorialMonoid m, TextualMonoid m, PositiveMonoid m) => PositiveMonoid (LinePositioned m) instance (StableFactorialMonoid m, LeftReductiveMonoid m) => LeftReductiveMonoid (OffsetPositioned m) where isPrefixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isPrefixOf c1 c2 stripPrefix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned (p + length c1)) (stripPrefix c1 c2) {-# INLINE isPrefixOf #-} {-# INLINE stripPrefix #-} instance (StableFactorialMonoid m, TextualMonoid m, LeftReductiveMonoid m) => LeftReductiveMonoid (LinePositioned m) where isPrefixOf a b = isPrefixOf (extractLines a) (extractLines b) stripPrefix LinePositioned{extractLines= c1} (LinePositioned p l lpos c2) = let (lines, columns) = linesColumns' c1 len = length c1 in fmap (LinePositioned (p + len) (l + lines) (lpos + len - columns)) (stripPrefix c1 c2) {-# INLINE isPrefixOf #-} {-# INLINE stripPrefix #-} instance (StableFactorialMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (OffsetPositioned m) where commonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = OffsetPositioned (min p1 p2) (commonPrefix c1 c2) stripCommonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = (OffsetPositioned (min p1 p2) prefix, OffsetPositioned (p1 + l) c1', OffsetPositioned (p2 + l) c2') where (prefix, c1', c2') = stripCommonPrefix c1 c2 l = length prefix {-# INLINE commonPrefix #-} {-# INLINE stripCommonPrefix #-} instance (StableFactorialMonoid m, TextualMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (LinePositioned m) where commonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) = if p1 <= p2 then LinePositioned p1 l1 lp1 (commonPrefix c1 c2) else LinePositioned p2 l2 lp2 (commonPrefix c1 c2) stripCommonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) = let (prefix, c1', c2') = stripCommonPrefix c1 c2 (lines, columns) = linesColumns' prefix len = length prefix in (if p1 <= p2 then LinePositioned p1 l1 lp1 prefix else LinePositioned p2 l2 lp2 prefix, LinePositioned (p1 + len) (l1 + lines) (lp1 + len - columns) c1', LinePositioned (p2 + len) (l2 + lines) (lp2 + len - columns) c2') {-# INLINE commonPrefix #-} {-# INLINE stripCommonPrefix #-} instance (StableFactorialMonoid m, RightReductiveMonoid m) => RightReductiveMonoid (OffsetPositioned m) where isSuffixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isSuffixOf c1 c2 stripSuffix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned p) (stripSuffix c1 c2) {-# INLINE isSuffixOf #-} {-# INLINE stripSuffix #-} instance (StableFactorialMonoid m, TextualMonoid m, RightReductiveMonoid m) => RightReductiveMonoid (LinePositioned m) where isSuffixOf LinePositioned{extractLines=c1} LinePositioned{extractLines=c2} = isSuffixOf c1 c2 stripSuffix (LinePositioned p l lp c1) LinePositioned{extractLines=c2} = fmap (LinePositioned p l lp) (stripSuffix c1 c2) {-# INLINE isSuffixOf #-} {-# INLINE stripSuffix #-} instance (StableFactorialMonoid m, RightGCDMonoid m) => RightGCDMonoid (OffsetPositioned m) where commonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = OffsetPositioned (min (p1 + length c1) (p2 + length c2) - length suffix) suffix where suffix = commonSuffix c1 c2 stripCommonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = (OffsetPositioned p1 c1', OffsetPositioned p2 c2', OffsetPositioned (min (p1 + length c1') (p2 + length c2')) suffix) where (c1', c2', suffix) = stripCommonSuffix c1 c2 {-# INLINE commonSuffix #-} {-# INLINE stripCommonSuffix #-} instance (StableFactorialMonoid m, TextualMonoid m, RightGCDMonoid m) => RightGCDMonoid (LinePositioned m) where stripCommonSuffix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) = (LinePositioned p1 l1 lp1 c1', LinePositioned p2 l2 lp2 c2', if p1 < p2 then LinePositioned (p1 + len1) (l1 + lines1) (lp1 + len1 - columns1) suffix else LinePositioned (p2 + len2) (l2 + lines2) (lp2 + len2 - columns2) suffix) where (c1', c2', suffix) = stripCommonSuffix c1 c2 len1 = length c1' len2 = length c2' (lines1, columns1) = linesColumns' c1' (lines2, columns2) = linesColumns' c2' instance StableFactorialMonoid m => FactorialMonoid (OffsetPositioned m) where factors (OffsetPositioned p c) = snd $ List.mapAccumL next p (factors c) where next p1 c1 = (succ p1, OffsetPositioned p1 c1) primePrefix (OffsetPositioned p c) = OffsetPositioned p (primePrefix c) splitPrimePrefix (OffsetPositioned p c) = fmap rewrap (splitPrimePrefix c) where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (succ p) cs) splitPrimeSuffix (OffsetPositioned p c) = fmap rewrap (splitPrimeSuffix c) where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (p + length cp) cs) foldl f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl f' (a0, p0) c0 where f' (a, p) c = (f a (OffsetPositioned p c), succ p) foldl' f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl' f' (a0, p0) c0 where f' (a, p) c = let a' = f a (OffsetPositioned p c) in seq a' (a', succ p) foldr f a0 (OffsetPositioned p0 c0) = Factorial.foldr f' (const a0) c0 p0 where f' c cont p = f (OffsetPositioned p c) (cont $! succ p) length (OffsetPositioned _ c) = length c foldMap f (OffsetPositioned p c) = appEndo (Factorial.foldMap f' c) (const mempty) p where -- f' :: m -> Endo (Int -> m) f' prime = Endo (\cont pos-> f (OffsetPositioned pos prime) <> cont (succ pos)) spanMaybe s0 f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe (s0, p0) f' t where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime) let p' = succ p Just $! seq p' (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) spanMaybe' s0 f (OffsetPositioned p0 t) = rewrap $! Factorial.spanMaybe' (s0, p0) f' t where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime) let p' = succ p Just $! s' `seq` p' `seq` (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) span f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe' p0 f' t where f' p prime = if f (OffsetPositioned p prime) then Just $! succ p else Nothing rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix) splitAt n m@(OffsetPositioned p c) | n <= 0 = (mempty, m) | n >= length c = (m, mempty) | otherwise = (OffsetPositioned p prefix, OffsetPositioned (p + n) suffix) where (prefix, suffix) = splitAt n c drop n (OffsetPositioned p c) = OffsetPositioned (p + n) (Factorial.drop n c) take n (OffsetPositioned p c) = OffsetPositioned p (Factorial.take n c) reverse (OffsetPositioned p c) = OffsetPositioned p (Factorial.reverse c) {-# INLINE primePrefix #-} {-# INLINE splitPrimePrefix #-} {-# INLINE splitPrimeSuffix #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE foldMap #-} {-# INLINE length #-} {-# INLINE span #-} {-# INLINE splitAt #-} {-# INLINE take #-} {-# INLINE drop #-} {-# INLINE reverse #-} instance (StableFactorialMonoid m, TextualMonoid m) => FactorialMonoid (LinePositioned m) where factors (LinePositioned p0 l0 lp0 c) = snd $ List.mapAccumL next (p0, l0, lp0) (factors c) where next (p, l, lp) c1 | characterPrefix c1 == Just '\n' = ((succ p, succ l, p), LinePositioned p l lp c1) | otherwise = ((succ p, l, lp), LinePositioned p l lp c1) primePrefix (LinePositioned p l lp c) = LinePositioned p l lp (primePrefix c) splitPrimePrefix (LinePositioned p l lp c) = fmap rewrap (splitPrimePrefix c) where rewrap (cp, cs) = (LinePositioned p l lp cp, if characterPrefix cp == Just '\n' then LinePositioned (succ p) (succ l) p cs else LinePositioned (succ p) l lp cs) splitPrimeSuffix (LinePositioned p l lp c) = fmap rewrap (splitPrimeSuffix c) where rewrap (cp, cs) = (LinePositioned p l lp cp, LinePositioned p' (l + lines) (p' - columns) cs) where len = length cp (lines, columns) = linesColumns cp p' = p + len foldl f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl f' (a0, p0, l0, lp0) c0 where f' (a, p, l, lp) c | characterPrefix c == Just '\n' = (f a (LinePositioned p l lp c), succ p, succ l, p) | otherwise = (f a (LinePositioned p l lp c), succ p, l, lp) foldl' f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl' f' (a0, p0, l0, lp0) c0 where f' (a, p, l, lp) c = let a' = f a (LinePositioned p l lp c) in seq a' (if characterPrefix c == Just '\n' then (a', succ p, succ l, p) else (a', succ p, l, lp)) foldr f a0 (LinePositioned p0 l0 lp0 c0) = Factorial.foldr f' (const3 a0) c0 p0 l0 lp0 where f' c cont p l lp | characterPrefix c == Just '\n' = f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p | otherwise = f (LinePositioned p l lp c) $ (cont $! succ p) l lp length = length . extractLines foldMap f (LinePositioned p0 l0 lp0 c) = appEndo (Factorial.foldMap f' c) (const mempty) p0 l0 lp0 where -- f' :: m -> Endo (Int -> Int -> Int -> m) f' prime = Endo (\cont p l lp-> f (LinePositioned p l lp prime) <> if characterPrefix prime == Just '\n' then cont (succ p) (succ l) p else cont (succ p) l lp) spanMaybe s0 f (LinePositioned p0 l0 lp0 c) = rewrap $ Factorial.spanMaybe (s0, p0, l0, lp0) f' c where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime) let p' = succ p l' = succ l Just $! p' `seq` if characterPrefix prime == Just '\n' then l' `seq` (s', p', l', p) else (s', p', l, lp) rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) spanMaybe' s0 f (LinePositioned p0 l0 lp0 c) = rewrap $! Factorial.spanMaybe' (s0, p0, l0, lp0) f' c where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime) let p' = succ p l' = succ l Just $! s' `seq` p' `seq` if characterPrefix prime == Just '\n' then l' `seq` (s', p', l', p) else (s', p', l, lp) rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) span f (LinePositioned p0 l0 lp0 t) = rewrap $ Factorial.spanMaybe' (p0, l0, lp0) f' t where f' (p, l, lp) prime = if f (LinePositioned p l lp prime) then let p' = succ p l' = succ l in Just $! p' `seq` if characterPrefix prime == Just '\n' then l' `seq` (p', l', p) else (p', l, lp) else Nothing rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix) splitAt n m@(LinePositioned p l lp c) | n <= 0 = (mempty, m) | n >= length c = (m, mempty) | otherwise = (LinePositioned p l lp prefix, LinePositioned p' (l + lines) (p' - columns) suffix) where (prefix, suffix) = splitAt n c (lines, columns) = linesColumns prefix p' = p + n take n (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.take n c) reverse (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.reverse c) {-# INLINE primePrefix #-} {-# INLINE splitPrimePrefix #-} {-# INLINE splitPrimeSuffix #-} {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE foldMap #-} {-# INLINE length #-} {-# INLINE span #-} {-# INLINE splitAt #-} {-# INLINE take #-} {-# INLINE reverse #-} instance StableFactorialMonoid m => StableFactorialMonoid (OffsetPositioned m) instance (StableFactorialMonoid m, TextualMonoid m) => StableFactorialMonoid (LinePositioned m) instance IsString m => IsString (OffsetPositioned m) where fromString = pure . fromString instance IsString m => IsString (LinePositioned m) where fromString = pure . fromString instance (StableFactorialMonoid m, TextualMonoid m) => TextualMonoid (OffsetPositioned m) where splitCharacterPrefix (OffsetPositioned p c) = fmap (fmap $ OffsetPositioned $ succ p) (splitCharacterPrefix c) fromText = pure . fromText singleton = pure . singleton characterPrefix = characterPrefix . extractOffset map f (OffsetPositioned p c) = OffsetPositioned p (map f c) concatMap f (OffsetPositioned p c) = OffsetPositioned p (concatMap (extractOffset . f) c) all p = all p . extractOffset any p = any p . extractOffset foldl ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl ft' fc' (a0, p0) c0 where ft' (a, p) c = (ft a (OffsetPositioned p c), succ p) fc' (a, p) c = (fc a c, succ p) foldl' ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl' ft' fc' (a0, p0) c0 where ft' (a, p) c = ((,) $! ft a (OffsetPositioned p c)) $! succ p fc' (a, p) c = ((,) $! fc a c) $! succ p foldr ft fc a0 (OffsetPositioned p0 c0) = snd $ Textual.foldr ft' fc' (p0, a0) c0 where ft' c (p, a) = (succ p, ft (OffsetPositioned p c) a) fc' c (p, a) = (succ p, fc c a) scanl f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl f ch c) scanl1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl1 f c) scanr f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr f ch c) scanr1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr1 f c) mapAccumL f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumL f a0 c) mapAccumR f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumR f a0 c) spanMaybe s0 ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe (s0, p0) ft' fc' t where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime) let p' = succ p Just $! seq p' (s', p') fc' (s, p) c = do s' <- fc s c let p' = succ p Just $! seq p' (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) spanMaybe' s0 ft fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe' (s0, p0) ft' fc' t where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime) let p' = succ p Just $! s' `seq` p' `seq` (s', p') fc' (s, p) c = do s' <- fc s c let p' = succ p Just $! s' `seq` p' `seq` (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) span ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe' p0 ft' fc' t where ft' p prime = if ft (OffsetPositioned p prime) then Just $! succ p else Nothing fc' p c = if fc c then Just $! succ p else Nothing rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix) split f (OffsetPositioned p0 c0) = rewrap p0 (Textual.split f c0) where rewrap _ [] = [] rewrap p (c:rest) = OffsetPositioned p c : rewrap (p + length c) rest find p = find p . extractOffset foldl_ fc a0 (OffsetPositioned _ c) = Textual.foldl_ fc a0 c foldl_' fc a0 (OffsetPositioned _ c) = Textual.foldl_' fc a0 c foldr_ fc a0 (OffsetPositioned _ c) = Textual.foldr_ fc a0 c spanMaybe_ s0 fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe_' (s0, p0) fc' t where fc' (s, p) c = do s' <- fc s c let p' = succ p Just $! seq p' (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) spanMaybe_' s0 fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe_' (s0, p0) fc' t where fc' (s, p) c = do s' <- fc s c let p' = succ p Just $! s' `seq` p' `seq` (s', p') rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) span_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.span_ bt fc t where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix) break_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.break_ bt fc t where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix) dropWhile_ bt fc t = snd (span_ bt fc t) takeWhile_ bt fc (OffsetPositioned p t) = OffsetPositioned p (takeWhile_ bt fc t) {-# INLINE characterPrefix #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE map #-} {-# INLINE concatMap #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE spanMaybe' #-} {-# INLINE span #-} {-# INLINE foldl_' #-} {-# INLINE foldr_ #-} {-# INLINE any #-} {-# INLINE all #-} {-# INLINE spanMaybe_' #-} {-# INLINE span_ #-} {-# INLINE break_ #-} {-# INLINE dropWhile_ #-} {-# INLINE takeWhile_ #-} {-# INLINE split #-} {-# INLINE find #-} instance (StableFactorialMonoid m, TextualMonoid m) => TextualMonoid (LinePositioned m) where splitCharacterPrefix (LinePositioned p l lp c) = case splitCharacterPrefix c of Nothing -> Nothing Just ('\n', rest) -> Just ('\n', LinePositioned (succ p) (succ l) p rest) Just (ch, rest) -> Just (ch, LinePositioned (succ p) l lp rest) fromText = pure . fromText singleton = pure . singleton characterPrefix = characterPrefix . extractLines map f (LinePositioned p l lp c) = LinePositioned p l lp (map f c) concatMap f (LinePositioned p l lp c) = LinePositioned p l lp (concatMap (extractLines . f) c) all p = all p . extractLines any p = any p . extractLines foldl ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl ft' fc' (a0, p0, l0, lp0) c0 where ft' (a, p, l, lp) c = (ft a (LinePositioned p l lp c), succ p, l, lp) fc' (a, p, l, _lp) '\n' = (fc a '\n', succ p, succ l, p) fc' (a, p, l, lp) c = (fc a c, succ p, l, lp) foldl' ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl' ft' fc' (a0, p0, l0, lp0) c0 where ft' (a, p, l, lp) c = let a' = ft a (LinePositioned p l lp c) p' = succ p in a' `seq` p' `seq` (a', p', l, lp) fc' (a, p, l, lp) c = let a' = fc a c p' = succ p l' = succ l in a' `seq` p' `seq` if c == '\n' then l' `seq` (a', p', l', p) else (a', p', l, lp) foldr ft fc a0 (LinePositioned p0 l0 lp0 c0) = Textual.foldr ft' fc' (const3 a0) c0 p0 l0 lp0 where ft' c cont p l lp = ft (LinePositioned p l lp c) $ (cont $! succ p) l lp fc' c cont p l lp | c == '\n' = fc c $ ((cont $! succ p) $! succ l) p | otherwise = fc c $ (cont $! succ p) l lp spanMaybe s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe (s0, p0, l0, lp0) ft' fc' t where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime) let p' = succ p Just $! seq p' (s', p', l, lp) fc' (s, p, l, lp) c = fc s c >>= \s'-> Just $! seq p' (if c == '\n' then seq l' (s', p', l', p) else (s', p', l, lp)) where p' = succ p l' = succ l rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) spanMaybe' s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $! Textual.spanMaybe' (s0, p0, l0, lp0) ft' fc' t where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime) let p' = succ p Just $! s' `seq` p' `seq` (s', p', l, lp) fc' (s, p, l, lp) c = do s' <- fc s c let p' = succ p l' = succ l Just $! s' `seq` p' `seq` (if c == '\n' then seq l' (s', p', l', p) else (s', p', l, lp)) rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) span ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe' (p0, l0, lp0) ft' fc' t where ft' (p, l, lp) prime = if ft (LinePositioned p l lp prime) then let p' = succ p in p' `seq` Just (p', l, lp) else Nothing fc' (p, l, lp) c | fc c = Just $! seq p' (if c == '\n' then seq l' (p', l', p) else (p', l, lp)) | otherwise = Nothing where p' = succ p l' = succ l rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix) scanl f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl f ch c) scanl1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl1 f c) scanr f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr f ch c) scanr1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr1 f c) mapAccumL f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumL f a0 c) mapAccumR f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumR f a0 c) split f (LinePositioned p0 l0 lp0 c0) = rewrap p0 l0 lp0 (Textual.split f c0) where rewrap _ _ _ [] = [] rewrap p l lp (c:rest) = LinePositioned p l lp c : rewrap p' (l + lines) (if lines == 0 then lp else p' - columns) rest where p' = p + length c (lines, columns) = linesColumns c find p = find p . extractLines foldl_ fc a0 (LinePositioned _ _ _ t) = Textual.foldl_ fc a0 t foldl_' fc a0 (LinePositioned _ _ _ t) = Textual.foldl_' fc a0 t foldr_ fc a0 (LinePositioned _ _ _ t) = Textual.foldr_ fc a0 t spanMaybe_ s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_ s0 fc t where rewrap (prefix, suffix, s) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix, s) where (l, col) = linesColumns prefix p1 = p0 + length prefix spanMaybe_' s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_' s0 fc t where rewrap (prefix, suffix, s) = p1 `seq` l1 `seq` lp1 `seq` (LinePositioned p0 l0 lp0 prefix, LinePositioned p1 l1 lp1 suffix, s) where (l, col) = linesColumns' prefix p1 = p0 + length prefix l1 = l0 + l lp1 = if l == 0 then lp0 else p1 - col span_ bt fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.span_ bt fc t where rewrap (prefix, suffix) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix) where (l, col) = linesColumns' prefix p1 = p0 + length prefix break_ bt fc t = span_ (not bt) (not . fc) t dropWhile_ bt fc t = snd (span_ bt fc t) takeWhile_ bt fc (LinePositioned p l lp t) = LinePositioned p l lp (takeWhile_ bt fc t) {-# INLINE characterPrefix #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE map #-} {-# INLINE concatMap #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE spanMaybe' #-} {-# INLINE span #-} {-# INLINE split #-} {-# INLINE find #-} {-# INLINE foldl_' #-} {-# INLINE foldr_ #-} {-# INLINE any #-} {-# INLINE all #-} {-# INLINE spanMaybe_' #-} {-# INLINE span_ #-} {-# INLINE break_ #-} {-# INLINE dropWhile_ #-} {-# INLINE takeWhile_ #-} linesColumns :: TextualMonoid m => m -> (Int, Int) linesColumns t = Textual.foldl (const . fmap succ) fc (0, 0) t where fc (l, _) '\n' = (succ l, 0) fc (l, c) _ = (l, succ c) linesColumns' :: TextualMonoid m => m -> (Int, Int) linesColumns' t = Textual.foldl' (const . fmap succ) fc (0, 0) t where fc (l, _) '\n' = let l' = succ l in seq l' (l', 0) fc (l, c) _ = let c' = succ c in seq c' (l, c') {-# INLINE linesColumns #-} {-# INLINE linesColumns' #-} const3 :: a -> b -> c -> d -> a const3 a _p _l _lp = a {-# INLINE const3 #-} fstOf4 :: (a, b, c, d) -> a fstOf4 (a, _, _, _) = a {-# INLINE fstOf4 #-} monoid-subclasses-0.4.2.1/Data/Monoid/Instances/Measured.hs0000644000000000000000000001254112717754212021635 0ustar0000000000000000{- Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Measured'. -- {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Measured ( Measured, measure, extract ) where import Data.Functor -- ((<$>)) import qualified Data.List as List import Data.String (IsString(..)) import Data.Monoid -- (Monoid(..)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftGCDMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) -- | @'Measured' a@ is a wrapper around the 'FactorialMonoid' @a@ that memoizes the monoid's 'length' so it becomes a -- constant-time operation. The parameter is restricted to the 'StableFactorialMonoid' class, which guarantees that -- @'length' (a <> b) == 'length' a + 'length' b@. data Measured a = Measured{_measuredLength :: Int, extract :: a} deriving (Eq, Show) -- | Create a new 'Measured' value. measure :: FactorialMonoid a => a -> Measured a measure x = Measured (length x) x instance Ord a => Ord (Measured a) where compare (Measured _ x) (Measured _ y) = compare x y instance StableFactorialMonoid a => Monoid (Measured a) where mempty = Measured 0 mempty mappend (Measured m a) (Measured n b) = Measured (m + n) (mappend a b) instance StableFactorialMonoid a => MonoidNull (Measured a) where null (Measured n _) = n == 0 instance StableFactorialMonoid a => PositiveMonoid (Measured a) instance (LeftReductiveMonoid a, StableFactorialMonoid a) => LeftReductiveMonoid (Measured a) where stripPrefix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripPrefix x y) instance (RightReductiveMonoid a, StableFactorialMonoid a) => RightReductiveMonoid (Measured a) where stripSuffix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripSuffix x y) instance (LeftGCDMonoid a, StableFactorialMonoid a) => LeftGCDMonoid (Measured a) where commonPrefix (Measured _ x) (Measured _ y) = measure (commonPrefix x y) instance (RightGCDMonoid a, StableFactorialMonoid a) => RightGCDMonoid (Measured a) where commonSuffix (Measured _ x) (Measured _ y) = measure (commonSuffix x y) instance StableFactorialMonoid a => FactorialMonoid (Measured a) where factors (Measured _ x) = List.map (Measured 1) (factors x) primePrefix m@(Measured _ x) = if null x then m else Measured 1 (primePrefix x) primeSuffix m@(Measured _ x) = if null x then m else Measured 1 (primeSuffix x) splitPrimePrefix (Measured n x) = case splitPrimePrefix x of Nothing -> Nothing Just (p, s) -> Just (Measured 1 p, Measured (n - 1) s) splitPrimeSuffix (Measured n x) = case splitPrimeSuffix x of Nothing -> Nothing Just (p, s) -> Just (Measured (n - 1) p, Measured 1 s) foldl f a0 (Measured _ x) = Factorial.foldl g a0 x where g a = f a . Measured 1 foldl' f a0 (Measured _ x) = Factorial.foldl' g a0 x where g a = f a . Measured 1 foldr f a0 (Measured _ x) = Factorial.foldr g a0 x where g = f . Measured 1 length (Measured n _) = n foldMap f (Measured _ x) = Factorial.foldMap (f . Measured 1) x span p (Measured n x) = (xp', xs') where (xp, xs) = Factorial.span (p . Measured 1) x xp' = measure xp xs' = Measured (n - length xp') xs split p (Measured _ x) = measure <$> Factorial.split (p . Measured 1) x splitAt m (Measured n x) | m <= 0 = (mempty, Measured n x) | m >= n = (Measured n x, mempty) | otherwise = (Measured m xp, Measured (n - m) xs) where (xp, xs) = splitAt m x reverse (Measured n x) = Measured n (reverse x) instance StableFactorialMonoid a => StableFactorialMonoid (Measured a) instance (FactorialMonoid a, IsString a) => IsString (Measured a) where fromString = measure . fromString instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Measured a) where fromText = measure . fromText singleton = Measured 1 . singleton splitCharacterPrefix (Measured n x) = (Measured (n - 1) <$>) <$> splitCharacterPrefix x characterPrefix (Measured _ x) = characterPrefix x map f (Measured n x) = Measured n (map f x) any p (Measured _ x) = any p x all p (Measured _ x) = all p x foldl ft fc a0 (Measured _ x) = Textual.foldl (\a-> ft a . Measured 1) fc a0 x foldl' ft fc a0 (Measured _ x) = Textual.foldl' (\a-> ft a . Measured 1) fc a0 x foldr ft fc a0 (Measured _ x) = Textual.foldr (ft . Measured 1) fc a0 x toString ft (Measured _ x) = toString (ft . Measured 1) x span pt pc (Measured n x) = (xp', xs') where (xp, xs) = Textual.span (pt . Measured 1) pc x xp' = measure xp xs' = Measured (n - length xp') xs break pt pc = Textual.span (not . pt) (not . pc) find p (Measured _ x) = find p x monoid-subclasses-0.4.2.1/Data/Monoid/Instances/Stateful.hs0000644000000000000000000002352212717754212021660 0ustar0000000000000000{- Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the monoid transformer data type 'Stateful'. -- -- >> let s = setState [4] $ pure "data" :: Stateful [Int] String -- >> s -- >Stateful ("data",[4]) -- >> factors s -- >[Stateful ("d",[]),Stateful ("a",[]),Stateful ("t",[]),Stateful ("a",[]),Stateful ("",[4])] {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Stateful ( Stateful(Stateful), extract, state, setState ) where import Control.Applicative -- (Applicative(..)) import Data.Functor -- ((<$>)) import qualified Data.List as List import Data.String (IsString(..)) import Data.Monoid -- (Monoid(..), (<>)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), LeftGCDMonoid(..), RightReductiveMonoid(..), RightGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Prelude hiding (all, any, break, elem, drop, filter, foldl, foldl1, foldr, foldr1, gcd, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, take) -- | @'Stateful' a b@ is a wrapper around the 'Monoid' @b@ that carries the state @a@ along. The state type @a@ must be -- a monoid as well if 'Stateful' is to be of any use. In the 'FactorialMonoid' and 'TextualMonoid' class instances, the -- monoid @b@ has the priority and the state @a@ is left for the end. newtype Stateful a b = Stateful (b, a) deriving (Eq, Ord, Show) extract :: Stateful a b -> b extract (Stateful (t, _)) = t state :: Stateful a b -> a state (Stateful (_, x)) = x setState :: a -> Stateful a b -> Stateful a b setState s (Stateful (t, _)) = Stateful (t, s) instance Functor (Stateful a) where fmap f (Stateful (x, s)) = Stateful (f x, s) instance Monoid a => Applicative (Stateful a) where pure m = Stateful (m, mempty) Stateful (f, s1) <*> Stateful (x, s2) = Stateful (f x, s1 <> s2) instance (Monoid a, Monoid b) => Monoid (Stateful a b) where mempty = Stateful mempty mappend (Stateful x) (Stateful y) = Stateful (x <> y) {-# INLINE mempty #-} {-# INLINE mappend #-} instance (MonoidNull a, MonoidNull b) => MonoidNull (Stateful a b) where null (Stateful x) = null x {-# INLINE null #-} instance (PositiveMonoid a, PositiveMonoid b) => PositiveMonoid (Stateful a b) instance (LeftReductiveMonoid a, LeftReductiveMonoid b) => LeftReductiveMonoid (Stateful a b) where isPrefixOf (Stateful x) (Stateful x') = isPrefixOf x x' stripPrefix (Stateful x) (Stateful x') = Stateful <$> stripPrefix x x' {-# INLINE isPrefixOf #-} {-# INLINE stripPrefix #-} instance (RightReductiveMonoid a, RightReductiveMonoid b) => RightReductiveMonoid (Stateful a b) where isSuffixOf (Stateful x) (Stateful x') = isSuffixOf x x' stripSuffix (Stateful x) (Stateful x') = Stateful <$> stripSuffix x x' {-# INLINE stripSuffix #-} {-# INLINE isSuffixOf #-} instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (Stateful a b) where commonPrefix (Stateful x) (Stateful x') = Stateful (commonPrefix x x') stripCommonPrefix (Stateful x) (Stateful x') = (Stateful prefix, Stateful suffix1, Stateful suffix2) where (prefix, suffix1, suffix2) = stripCommonPrefix x x' {-# INLINE commonPrefix #-} {-# INLINE stripCommonPrefix #-} instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (Stateful a b) where commonSuffix (Stateful x) (Stateful x') = Stateful (commonSuffix x x') {-# INLINE commonSuffix #-} instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (Stateful a b) where factors (Stateful x) = List.map Stateful (factors x) length (Stateful x) = length x reverse (Stateful x) = Stateful (reverse x) primePrefix (Stateful x) = Stateful (primePrefix x) primeSuffix (Stateful x) = Stateful (primeSuffix x) splitPrimePrefix (Stateful x) = do (xp, xs) <- splitPrimePrefix x return (Stateful xp, Stateful xs) splitPrimeSuffix (Stateful x) = do (xp, xs) <- splitPrimeSuffix x return (Stateful xp, Stateful xs) foldl f a0 (Stateful x) = Factorial.foldl f' a0 x where f' a x1 = f a (Stateful x1) foldl' f a0 (Stateful x) = Factorial.foldl' f' a0 x where f' a x1 = f a (Stateful x1) foldr f a (Stateful x) = Factorial.foldr (f . Stateful) a x foldMap f (Stateful x) = Factorial.foldMap (f . Stateful) x span p (Stateful x) = (Stateful xp, Stateful xs) where (xp, xs) = Factorial.span (p . Stateful) x spanMaybe s0 f (Stateful x) = (Stateful xp, Stateful xs, s') where (xp, xs, s') = Factorial.spanMaybe s0 f' x f' s x1 = f s (Stateful x1) spanMaybe' s0 f (Stateful x) = (Stateful xp, Stateful xs, s') where (xp, xs, s') = Factorial.spanMaybe' s0 f' x f' s x1 = f s (Stateful x1) split p (Stateful x) = List.map Stateful (Factorial.split (p . Stateful) x) splitAt n (Stateful x) = (Stateful xp, Stateful xs) where (xp, xs) = splitAt n x take n (Stateful x) = Stateful (take n x) drop n (Stateful x) = Stateful (drop n x) {-# INLINE primePrefix #-} {-# INLINE primeSuffix #-} {-# INLINE splitPrimePrefix #-} {-# INLINE splitPrimeSuffix #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE foldMap #-} {-# INLINE length #-} {-# INLINE span #-} {-# INLINE spanMaybe #-} {-# INLINE spanMaybe' #-} {-# INLINE splitAt #-} {-# INLINE take #-} {-# INLINE drop #-} instance (StableFactorialMonoid a, StableFactorialMonoid b) => StableFactorialMonoid (Stateful a b) instance (Monoid a, IsString b) => IsString (Stateful a b) where fromString = pure . fromString instance (LeftGCDMonoid a, FactorialMonoid a, TextualMonoid b) => TextualMonoid (Stateful a b) where fromText t = Stateful (fromText t, mempty) singleton c = Stateful (singleton c, mempty) characterPrefix = characterPrefix . extract splitCharacterPrefix (Stateful (t, x)) = do (c, t') <- splitCharacterPrefix t return (c, Stateful (t', x)) map f (Stateful (t, x)) = Stateful (Textual.map f t, x) all p = all p . extract any p = any p . extract foldl fx fc a0 (Stateful (t, x)) = Factorial.foldl f2 (Textual.foldl f1 fc a0 t) x where f1 a = fx a . fromFst f2 a = fx a . fromSnd foldr fx fc a (Stateful (t, x)) = Textual.foldr (fx . fromFst) fc (Factorial.foldr (fx . fromSnd) a x) t foldl' fx fc a0 (Stateful (t, x)) = a' `seq` Factorial.foldl' f2 a' x where a' = Textual.foldl' f1 fc a0 t f1 a = fx a . fromFst f2 a = fx a . fromSnd foldl_' fc a (Stateful (t, _)) = foldl_' fc a t foldr_ fc a (Stateful (t, _)) = Textual.foldr_ fc a t toString fx (Stateful (t, x)) = toString (fx . fromFst) t ++ Factorial.foldMap (fx . fromSnd) x scanl f c (Stateful (t, x)) = Stateful (Textual.scanl f c t, x) scanl1 f (Stateful (t, x)) = Stateful (Textual.scanl1 f t, x) scanr f c (Stateful (t, x)) = Stateful (Textual.scanr f c t, x) scanr1 f (Stateful (t, x)) = Stateful (Textual.scanr1 f t, x) mapAccumL f a (Stateful (t, x)) = (a', Stateful (t', x)) where (a', t') = Textual.mapAccumL f a t mapAccumR f a (Stateful (t, x)) = (a', Stateful (t', x)) where (a', t') = Textual.mapAccumR f a t span pt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs)) where (tp, ts) = Textual.span (pt . fromFst) pc t (xp, xs) | null ts = Factorial.span (pt . fromSnd) x | otherwise = (mempty, x) span_ bt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs)) where (tp, ts) = Textual.span_ bt pc t (xp, xs) | null ts && bt = (x, mempty) | otherwise = (mempty, x) break pt pc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs)) where (tp, ts) = Textual.break (pt . fromFst) pc t (xp, xs) | null ts = Factorial.break (pt . fromSnd) x | otherwise = (mempty, x) spanMaybe s0 ft fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s'') where (tp, ts, s') = Textual.spanMaybe s0 ft' fc t (xp, xs, s'') | null ts = Factorial.spanMaybe s' ft'' x | otherwise = (mempty, x, s') ft' s t1 = ft s (Stateful (t1, mempty)) ft'' s x1 = ft s (Stateful (mempty, x1)) spanMaybe' s0 ft fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s'') where (tp, ts, s') = Textual.spanMaybe' s0 ft' fc t (xp, xs, s'') | null ts = Factorial.spanMaybe' s' ft'' x | otherwise = (mempty, x, s') ft' s t1 = ft s (Stateful (t1, mempty)) ft'' s x1 = ft s (Stateful (mempty, x1)) spanMaybe_' s0 fc (Stateful (t, x)) = (Stateful (tp, xp), Stateful (ts, xs), s') where (tp, ts, s') = Textual.spanMaybe_' s0 fc t (xp, xs) | null ts = (x, mempty) | otherwise = (mempty, x) split p (Stateful (t, x)) = restore id ts where ts = Textual.split p t restore f [t1] = f [Stateful (t1, x)] restore f ~(hd:tl) = restore (f . (Stateful (hd, mempty):)) tl find p = find p . extract elem c = elem c . extract {-# INLINE characterPrefix #-} {-# INLINE splitCharacterPrefix #-} {-# INLINE map #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE spanMaybe' #-} {-# INLINE span #-} {-# INLINE spanMaybe_' #-} {-# INLINE span_ #-} {-# INLINE any #-} {-# INLINE all #-} {-# INLINE split #-} {-# INLINE find #-} {-# INLINE elem #-} {-# INLINE fromFst #-} fromFst :: Monoid b => a -> Stateful b a fromFst a = Stateful (a, mempty) {-# INLINE fromSnd #-} fromSnd :: Monoid a => b -> Stateful b a fromSnd b = Stateful (mempty, b) monoid-subclasses-0.4.2.1/Data/Monoid/Instances/ByteString/0000755000000000000000000000000012717754212021623 5ustar0000000000000000monoid-subclasses-0.4.2.1/Data/Monoid/Instances/ByteString/UTF8.hs0000644000000000000000000006347212717754212022721 0ustar0000000000000000{- Copyright 2013-2016 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'ByteStringUTF8' newtype wrapper around 'ByteString', together with its 'TextualMonoid' -- instance. The 'FactorialMonoid' instance of a wrapped 'ByteStringUTF8' value differs from the original 'ByteString': -- the prime 'factors' of the original value are its bytes, and for the wrapped value the prime 'factors' are its valid -- UTF8 byte sequences. The following example session demonstrates the relationship: -- -- >> let utf8@(ByteStringUTF8 bs) = fromString "E=mc\xb2" -- >> bs -- >"E=mc\194\178" -- >> factors bs -- >["E","=","m","c","\194","\178"] -- >> utf8 -- >"E=mc²" -- >> factors utf8 -- >["E","=","m","c","²"] -- -- The 'TextualMonoid' instance follows the same logic, but it also decodes all valid UTF8 sequences into -- characters. Any invalid UTF8 byte sequence from the original 'ByteString' is preserved as a single prime factor: -- -- >> let utf8'@(ByteStringUTF8 bs') = ByteStringUTF8 (Data.ByteString.map pred bs) -- >> bs' -- >"D> factors bs' -- >["D","<","l","b","\193","\177"] -- >> utf8' -- >"D> factors utf8' -- >["D","<","l","b","\[193,177]"] {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.ByteString.UTF8 ( ByteStringUTF8(..), decode ) where import Control.Exception (assert) import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Char (chr, ord, isDigit, isPrint) import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.Maybe (fromMaybe, isJust, isNothing) import Data.String (IsString(fromString)) import Data.Word (Word8) import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as ByteString.Char8 import Data.ByteString.Internal (w2c) import Data.ByteString.Unsafe (unsafeDrop, unsafeHead, unsafeTail, unsafeTake, unsafeIndex) import Data.Monoid -- (Monoid(mempty, mappend)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..), LeftCancellativeMonoid, LeftGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(..), PositiveMonoid) import Data.Monoid.Factorial (FactorialMonoid(..)) import Data.Monoid.Textual (TextualMonoid(..)) import qualified Data.Monoid.Factorial as Factorial (FactorialMonoid(..)) import qualified Data.Monoid.Textual as Textual (TextualMonoid(..)) import Prelude hiding (any, drop, dropWhile, foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1, map, concatMap, break, span) newtype ByteStringUTF8 = ByteStringUTF8 ByteString deriving (Eq, Ord) -- | Takes a raw 'ByteString' chunk and returns a pair of 'ByteStringUTF8' decoding the prefix of the chunk and the -- remaining suffix that is either null or contains the incomplete last character of the chunk. decode :: ByteString -> (ByteStringUTF8, ByteString) decode bs | ByteString.null bs || l < 0x80 = (ByteStringUTF8 bs, mempty) | l >= 0xC0 = (ByteStringUTF8 (ByteString.init bs), ByteString.singleton l) | ByteString.null prefix = (mempty, bs) | otherwise = case toChar (ByteString.last prefix) suffix of Nothing -> (ByteStringUTF8 (ByteString.init prefix), drop (ByteString.length prefix - 1) bs) Just{} -> (ByteStringUTF8 bs, mempty) where (prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs l = ByteString.last bs instance Monoid ByteStringUTF8 where mempty = ByteStringUTF8 ByteString.empty {-# INLINE mempty #-} ByteStringUTF8 a `mappend` ByteStringUTF8 b = ByteStringUTF8 (a `mappend` b) {-# INLINE mappend #-} instance MonoidNull ByteStringUTF8 where null (ByteStringUTF8 b) = ByteString.null b {-# INLINE null #-} instance LeftReductiveMonoid ByteStringUTF8 where stripPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = fmap ByteStringUTF8 (stripPrefix a b) {-# INLINE stripPrefix #-} ByteStringUTF8 a `isPrefixOf` ByteStringUTF8 b = a `isPrefixOf` b {-# INLINE isPrefixOf #-} instance LeftCancellativeMonoid ByteStringUTF8 instance LeftGCDMonoid ByteStringUTF8 where commonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = ByteStringUTF8 (commonPrefix a b) {-# INLINE commonPrefix #-} stripCommonPrefix (ByteStringUTF8 a) (ByteStringUTF8 b) = wrapTriple (stripCommonPrefix a b) {-# INLINE stripCommonPrefix #-} instance Show ByteStringUTF8 where showsPrec _ bs s0 = '"' : Textual.foldr showsBytes showsChar ('"' : s0) bs where showsBytes (ByteStringUTF8 b) s = '\\' : shows (ByteString.unpack b) s showsChar c s | isPrint c = c : s | h:_ <- s, isDigit h = "\\" ++ show (ord c) ++ "\\&" ++ s | otherwise = "\\" ++ show (ord c) ++ s instance IsString ByteStringUTF8 where fromString = ByteStringUTF8 . Foldable.foldMap fromChar {-# INLINE fromString #-} instance PositiveMonoid ByteStringUTF8 instance FactorialMonoid ByteStringUTF8 where splitPrimePrefix utf8@(ByteStringUTF8 bs) | ByteString.null bs = Nothing | unsafeHead bs < 0x80 = Just (wrapPair $ ByteString.splitAt 1 bs) | otherwise = case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Just i -> Just (wrapPair $ ByteString.splitAt (succ i) bs) Nothing -> Just (utf8, ByteStringUTF8 $ ByteString.empty) {-# INLINABLE splitPrimePrefix #-} splitPrimeSuffix (ByteStringUTF8 bs) | ByteString.null bs = Nothing | ByteString.null prefix = Just (wrapPair splitBS) | not (ByteString.null suffix) && ByteString.last prefix < 0x80 = Just (wrapPair splitBS) | otherwise = Just (wrapPair $ ByteString.splitAt (pred $ ByteString.length prefix) bs) where splitBS@(prefix, suffix) = ByteString.breakEnd byteStartsCharacter bs {-# INLINABLE splitPrimeSuffix #-} primePrefix utf8@(ByteStringUTF8 bs) | ByteString.null bs = utf8 | unsafeHead bs < 0x80 = ByteStringUTF8 (ByteString.take 1 bs) | otherwise = case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Just i -> ByteStringUTF8 (ByteString.take (succ i) bs) Nothing -> utf8 {-# INLINABLE primePrefix #-} factors (ByteStringUTF8 bs) = List.map ByteStringUTF8 $ ByteString.groupBy continued bs where continued a b = a >= 0x80 && b >= 0x80 && b < 0xC0 {-# INLINABLE factors #-} length (ByteStringUTF8 bs) = fst (ByteString.foldl' count (0, False) bs) where count (n, high) byte | byte < 0x80 = (succ n, False) | byte < 0xC0 = (if high then n else succ n, True) | otherwise = (succ n, True) {-# INLINABLE length #-} foldl f a0 (ByteStringUTF8 bs) = List.foldl f' a0 (groupASCII bs) where f' a b | unsafeHead b < 0x80 = ByteString.foldl f'' a b | otherwise = f a (ByteStringUTF8 b) f'' a w = f a (ByteStringUTF8 $ ByteString.singleton w) {-# INLINABLE foldl #-} foldl' f a0 (ByteStringUTF8 bs) = List.foldl' f' a0 (groupASCII bs) where f' a b | unsafeHead b < 0x80 = ByteString.foldl' f'' a b | otherwise = f a (ByteStringUTF8 b) f'' a w = f a (ByteStringUTF8 $ ByteString.singleton w) {-# INLINABLE foldl' #-} foldr f a0 (ByteStringUTF8 bs) = List.foldr f' a0 (groupASCII bs) where f' b a | unsafeHead b < 0x80 = ByteString.foldr f'' a b | otherwise = f (ByteStringUTF8 b) a f'' w a = f (ByteStringUTF8 $ ByteString.singleton w) a {-# INLINABLE foldr #-} splitAt n (ByteStringUTF8 bs) = wrapPair (ByteString.splitAt (charStartIndex n bs) bs) {-# INLINE splitAt #-} take n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.take (charStartIndex n bs) bs) {-# INLINE take #-} drop n (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.drop (charStartIndex n bs) bs) {-# INLINE drop #-} dropWhile p (ByteStringUTF8 bs0) = dropASCII bs0 where dropASCII bs = let suffix = ByteString.dropWhile (\w-> w < 0x80 && p (ByteStringUTF8 $ ByteString.singleton w)) bs in if ByteString.null suffix || unsafeHead suffix < 0x80 then ByteStringUTF8 suffix else dropMultiByte suffix dropMultiByte bs = let utf8 = ByteStringUTF8 bs in case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Nothing -> if p utf8 then ByteStringUTF8 ByteString.empty else utf8 Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs in if p (ByteStringUTF8 hd) then dropASCII tl else utf8 {-# INLINE dropWhile #-} takeWhile p utf8@(ByteStringUTF8 bs) = ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs where (ByteStringUTF8 s) = Factorial.dropWhile p utf8 {-# INLINE takeWhile #-} span p utf8@(ByteStringUTF8 bs) = (ByteStringUTF8 $ ByteString.take (ByteString.length bs - ByteString.length s) bs, suffix) where suffix@(ByteStringUTF8 s) = Factorial.dropWhile p utf8 {-# INLINE span #-} break p = Factorial.span (not . p) {-# INLINE break #-} spanMaybe s0 f (ByteStringUTF8 bs0) = (ByteStringUTF8 $ ByteString.take (ByteString.length bs0 - ByteString.length dropped) bs0, ByteStringUTF8 dropped, s') where (dropped, s') = dropASCII s0 bs0 dropASCII s bs = let suffix = ByteString.drop index bs (index, s1) = ByteString.foldr f8 id bs (0, s) f8 w cont (i, s2) | w < 0x80, Just s3 <- f s2 (ByteStringUTF8 $ ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s3) | otherwise = (i, s2) in if ByteString.null suffix || unsafeHead suffix < 0x80 then (suffix, s1) else dropMultiByte s1 suffix dropMultiByte s bs = case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Nothing -> case f s (ByteStringUTF8 bs) of Just s1 -> (ByteString.empty, s1) Nothing -> (bs, s) Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs in case f s (ByteStringUTF8 hd) of Just s1 -> dropASCII s1 tl Nothing -> (bs, s) {-# INLINE spanMaybe #-} spanMaybe' s0 f (ByteStringUTF8 bs0) = (ByteStringUTF8 $ ByteString.take (ByteString.length bs0 - ByteString.length dropped) bs0, ByteStringUTF8 dropped, s') where (dropped, s') = dropASCII s0 bs0 dropASCII s bs = let suffix = ByteString.drop index bs (index, s1) = ByteString.foldr f8 id bs (0, s) f8 w cont (i, s2) | w < 0x80, Just s3 <- f s2 (ByteStringUTF8 $ ByteString.singleton w) = let i' = succ i :: Int in seq i' $ seq s3 $ cont (i', s3) | otherwise = (i, s) in if ByteString.null suffix || unsafeHead suffix < 0x80 then (suffix, s1) else dropMultiByte s1 suffix dropMultiByte s bs = case ByteString.findIndex byteStartsCharacter (unsafeTail bs) of Nothing -> case f s (ByteStringUTF8 bs) of Just s1 -> seq s1 (ByteString.empty, s1) Nothing -> (bs, s) Just i -> let (hd, tl) = ByteString.splitAt (succ i) bs in case f s (ByteStringUTF8 hd) of Just s1 -> seq s1 (dropASCII s1 tl) Nothing -> (bs, s) {-# INLINE spanMaybe' #-} reverse (ByteStringUTF8 bs) = ByteStringUTF8 (ByteString.concat $ List.reverse $ List.map reverseASCII $ groupASCII bs) where reverseASCII b | unsafeHead b < 0x80 = ByteString.reverse b | otherwise = b {-# INLINABLE reverse #-} instance TextualMonoid ByteStringUTF8 where singleton = ByteStringUTF8 . fromChar {-# INLINE singleton #-} splitCharacterPrefix (ByteStringUTF8 bs) = ByteString.uncons bs >>= uncurry toChar {-# INLINE splitCharacterPrefix #-} foldl ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldl f (a0, []) bs of (a, []) -> a (a, acc) -> multiByte a acc where f (a, []) c | c < '\x80' = (fc a c, []) | otherwise = (a, [fromIntegral $ ord c]) f (a, acc) c | c < '\x80' = (fc (multiByte a acc) c, []) | c < '\xC0' = (a, fromIntegral (ord c) : acc) | otherwise = (multiByte a acc, [fromIntegral $ ord c]) multiByte a acc = reverseBytesToChar (ft a . ByteStringUTF8) (fc a) acc {-# INLINE foldl #-} foldl' ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldl' f (a0, []) bs of (a, []) -> a (a, acc) -> multiByte a acc where f (a, []) c | c < '\x80' = (fc a c, []) | otherwise = seq a (a, [fromIntegral $ ord c]) f (a, acc) c | seq a c < '\x80' = let a' = multiByte a acc in seq a' (fc a' c, []) | c < '\xC0' = (a, fromIntegral (ord c) : acc) | otherwise = let a' = multiByte a acc in seq a' (a', [fromIntegral $ ord c]) multiByte a acc = reverseBytesToChar (ft a . ByteStringUTF8) (fc a) acc {-# INLINE foldl' #-} foldr ft fc a0 (ByteStringUTF8 bs) = case ByteString.Char8.foldr f (a0, []) bs of (a, []) -> a (a, acc) -> multiByte a acc where f c (a, []) | c < '\x80' = (fc c a, []) | c < '\xC0' = (a, [fromIntegral $ ord c]) | otherwise = (ft (ByteStringUTF8 $ ByteString.Char8.singleton c) a, []) f c (a, acc) | c < '\x80' = (fc c (ft (ByteStringUTF8 $ ByteString.pack acc) a), []) | c < '\xC0' = (a, fromIntegral (ord c) : acc) | otherwise = (multiByte a (fromIntegral (ord c) : acc), []) multiByte a acc = bytesToChar ((`ft` a) . ByteStringUTF8) (`fc` a) acc {-# INLINE foldr #-} dropWhile pb pc (ByteStringUTF8 bs) = ByteStringUTF8 $ dropASCII bs where dropASCII rest = case ByteString.Char8.findIndex (\c-> c > '\x7f' || not (pc c)) rest of Nothing -> ByteString.empty Just j -> let rest' = unsafeDrop j rest in if unsafeHead rest' > 0x7f then dropMultiByte rest' else rest' dropMultiByte rest = case splitCharacterPrefix (ByteStringUTF8 rest) of Just (c, ByteStringUTF8 rest') | pc c -> dropASCII rest' Nothing -> let j = succ (headIndex $ drop 1 rest) in if pb (ByteStringUTF8 $ ByteString.take j rest) then dropASCII (unsafeDrop j rest) else rest _ -> rest {-# INLINE dropWhile #-} takeWhile pb pc utf8@(ByteStringUTF8 bs) = ByteStringUTF8 $ unsafeTake (ByteString.length bs - ByteString.length suffix) bs where ByteStringUTF8 suffix = Textual.dropWhile pb pc utf8 {-# INLINE takeWhile #-} span pb pc utf8@(ByteStringUTF8 bs) = (ByteStringUTF8 $ unsafeTake (ByteString.length bs - ByteString.length suffix') bs, suffix) where suffix@(ByteStringUTF8 suffix') = Textual.dropWhile pb pc utf8 {-# INLINE span #-} break pb pc = Textual.span (not . pb) (not . pc) {-# INLINE break #-} spanMaybe s0 ft fc (ByteStringUTF8 bs) = let inner i s | i < len = let w = unsafeIndex bs i in if w < 0x80 then case fc s (w2c w) of Just s' -> inner (i + 1) s' Nothing -> done i s else case splitCharacterPrefix (ByteStringUTF8 $ unsafeDrop i bs) of Just (c, ByteStringUTF8 rest) | Just s' <- fc s c -> inner (len - ByteString.length rest) s' Nothing -> let j = succ (headIndex $ drop (i + 1) bs) in case ft s (ByteStringUTF8 $ ByteString.take j $ unsafeDrop i bs) of Just s' -> inner (i + j) s' Nothing -> done i s _ -> done i s | otherwise = done i s done i s = i `seq` s `seq` (ByteStringUTF8 $ unsafeTake i bs, ByteStringUTF8 $ unsafeDrop i bs, s) len = ByteString.length bs in inner 0 s0 {-# INLINE spanMaybe #-} spanMaybe' s0 ft fc (ByteStringUTF8 bs) = let inner i s | i < len = s `seq` let w = unsafeIndex bs i in if w < 0x80 then case fc s (w2c w) of Just s' -> inner (i + 1) s' Nothing -> done i s else case splitCharacterPrefix (ByteStringUTF8 $ unsafeDrop i bs) of Just (c, ByteStringUTF8 rest) | Just s' <- fc s c -> inner (len - ByteString.length rest) s' Nothing -> let j = succ (headIndex $ drop (i + 1) bs) in case ft s (ByteStringUTF8 $ ByteString.take j $ unsafeDrop i bs) of Just s' -> inner (i + j) s' Nothing -> done i s _ -> done i s | otherwise = done i s done i s = i `seq` s `seq` (ByteStringUTF8 $ unsafeTake i bs, ByteStringUTF8 $ unsafeDrop i bs, s) len = ByteString.length bs in inner 0 s0 {-# INLINE spanMaybe' #-} find p (ByteStringUTF8 bs0) = loop bs0 where loop bs = case ByteString.Char8.findIndex (\c-> c >= '\x80' || p c) bs of Nothing -> Nothing Just i -> let x = unsafeIndex bs i bs' = unsafeDrop (i + 1) bs in if x < 0x80 then Just (w2c x) else case toChar x bs' of Just (c, ByteStringUTF8 rest) | p c -> Just c | otherwise -> loop rest Nothing -> loop (ByteString.dropWhile (not . byteStartsCharacter) bs') {-# INLINE find #-} any p utf8 = isJust (find p utf8) {-# INLINE any #-} all p utf8 = isNothing (find (not . p) utf8) {-# INLINE all #-} elem c utf8@(ByteStringUTF8 bs) | c < '\x80' = ByteString.Char8.elem c bs | otherwise = any (== c) utf8 {-# INLINE elem #-} reverseBytesToChar :: (ByteString -> a) -> (Char -> a) -> [Word8] -> a reverseBytesToChar ft fc [w] = if w < 0x80 then fc (w2c w) else ft (ByteString.singleton w) reverseBytesToChar ft fc [b0, b1] = assert (0x80 <= b0 && b0 < 0xC0) $ if 0xC2 <= b1 && b1 < 0xE0 then fc (chr (shiftL (fromIntegral b1 .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack [b1, b0]) reverseBytesToChar ft fc [b0, b1, b2] = assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0) $ if (0xE0 < b2 || 0xE0 == b2 && 0xA0 <= b1) && b2 < 0xF0 then fc (chr (shiftL (fromIntegral b2 .&. 0xF) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack [b2, b1, b0]) reverseBytesToChar ft fc [b0, b1, b2, b3] = assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0 && 0x80 <= b2 && b2 < 0xC0) $ if (0xF0 < b3 || 0xF0 == b3 && 0x90 <= b2) && b3 < 0xF4 then fc (chr (shiftL (fromIntegral b3 .&. 0x7) 18 .|. shiftL (fromIntegral b2 .&. 0x3F) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack [b3, b2, b1, b0]) reverseBytesToChar ft _fc bytes = ft (ByteString.reverse $ ByteString.pack bytes) bytesToChar :: (ByteString -> a) -> (Char -> a) -> [Word8] -> a bytesToChar ft fc [w] = if w < 0x80 then fc (w2c w) else ft (ByteString.singleton w) bytesToChar ft fc bytes@[b1, b0] = assert (0x80 <= b0 && b0 < 0xC0) $ if 0xC2 <= b1 && b1 < 0xE0 then fc (chr (shiftL (fromIntegral b1 .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack bytes) bytesToChar ft fc bytes@[b2, b1, b0] = assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0) $ if (0xE0 < b2 || 0xE0 == b2 && 0xA0 <= b1) && b2 < 0xF0 then fc (chr (shiftL (fromIntegral b2 .&. 0xF) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack bytes) bytesToChar ft fc bytes@[b3, b2, b1, b0] = assert (0x80 <= b0 && b0 < 0xC0 && 0x80 <= b1 && b1 < 0xC0 && 0x80 <= b2 && b2 < 0xC0) $ if (0xF0 < b3 || 0xF0 == b3 && 0x90 <= b2) && b3 < 0xF4 then fc (chr (shiftL (fromIntegral b3 .&. 0x7) 18 .|. shiftL (fromIntegral b2 .&. 0x3F) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F)) else ft (ByteString.pack bytes) bytesToChar ft _fc bytes = ft (ByteString.pack bytes) wrapPair :: (ByteString, ByteString) -> (ByteStringUTF8, ByteStringUTF8) wrapPair (bs1, bs2) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2) {-# INLINE wrapPair #-} wrapTriple :: (ByteString, ByteString, ByteString) -> (ByteStringUTF8, ByteStringUTF8, ByteStringUTF8) wrapTriple (bs1, bs2, bs3) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2, ByteStringUTF8 bs3) {-# INLINE wrapTriple #-} fromChar :: Char -> ByteString fromChar c | c < '\x80' = ByteString.Char8.singleton c | c < '\x800' = ByteString.pack [0xC0 + fromIntegral (shiftR n 6), 0x80 + fromIntegral (n .&. 0x3F)] | c < '\x10000' = ByteString.pack [0xE0 + fromIntegral (shiftR n 12), 0x80 + fromIntegral (shiftR n 6 .&. 0x3F), 0x80 + fromIntegral (n .&. 0x3F)] | n < 0x200000 = ByteString.pack [0xF0 + fromIntegral (shiftR n 18), 0x80 + fromIntegral (shiftR n 12 .&. 0x3F), 0x80 + fromIntegral (shiftR n 6 .&. 0x3F), 0x80 + fromIntegral (n .&. 0x3F)] | otherwise = error ("Data.Char.ord '" ++ (c : "' >=0x200000")) where n = ord c toChar :: Word8 -> ByteString -> Maybe (Char, ByteStringUTF8) toChar hd tl | hd < 0x80 = Just (w2c hd, ByteStringUTF8 tl) | hd < 0xC2 = Nothing | hd < 0xE0 = do (b0, t0) <- ByteString.uncons tl if headIndex tl == 1 then return (chr (shiftL (fromIntegral hd .&. 0x1F) 6 .|. fromIntegral b0 .&. 0x3F), ByteStringUTF8 t0) else Nothing | hd < 0xF0 = do (b1, t1) <- ByteString.uncons tl (b0, t0) <- ByteString.uncons t1 if (hd > 0xE0 || b1 >= 0xA0) && headIndex tl == 2 then return (chr (shiftL (fromIntegral hd .&. 0xF) 12 .|. shiftL (fromIntegral b1 .&. 0x3F) 6 .|. fromIntegral b0 .&. 0x3F), ByteStringUTF8 t0) else Nothing | hd < 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 {-# INLINE groupASCII #-} headIndex :: ByteString -> Int headIndex bs = fromMaybe (ByteString.length bs) $ ByteString.findIndex byteStartsCharacter bs {-# INLINE headIndex #-} byteStartsCharacter :: Word8 -> Bool byteStartsCharacter b = b < 0x80 || b >= 0xC0 {-# INLINE byteStartsCharacter #-} charStartIndex :: Int -> ByteString -> Int charStartIndex n _ | n <= 0 = 0 charStartIndex n0 bs = ByteString.foldr count (const $ ByteString.length bs) bs (n0, False, 0) where count byte _ (0, high, i) | byte < 0x80 || byte >= 0xC0 || not high = i count byte cont (n, high, i) | byte < 0x80 = cont (pred n, False, succ i) | byte < 0xC0 = cont (if high then n else pred n, True, succ i) | otherwise = cont (pred n, True, succ i) {-# INLINE charStartIndex #-}