diff --git a/Data/Monoid/Cancellative.hs b/Data/Monoid/Cancellative.hs --- a/Data/Monoid/Cancellative.hs +++ b/Data/Monoid/Cancellative.hs @@ -51,6 +51,7 @@ 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 @@ -451,13 +452,13 @@ instance LeftReductiveMonoid ByteString.ByteString where stripPrefix p l = if ByteString.isPrefixOf p l - then Just (ByteString.drop (ByteString.length 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.take (ByteString.length l - ByteString.length s) l) + then Just (ByteString.unsafeTake (ByteString.length l - ByteString.length s) l) else Nothing isSuffixOf = ByteString.isSuffixOf @@ -466,18 +467,21 @@ instance RightCancellativeMonoid ByteString.ByteString instance LeftGCDMonoid ByteString.ByteString where - stripCommonPrefix x y = (xp, xs, ByteString.drop maxPrefixLength y) + 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.index x n == ByteString.index y n = prefixLength (succ n) len - prefixLength n _ = n + 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.index x m == ByteString.index y n = - findSuffix (pred m) (pred n) - findSuffix m n = (ByteString.take (succ m) x, yp, ys) - where (yp, ys) = ByteString.splitAt (succ n) y + 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 diff --git a/Data/Monoid/Factorial.hs b/Data/Monoid/Factorial.hs --- a/Data/Monoid/Factorial.hs +++ b/Data/Monoid/Factorial.hs @@ -20,6 +20,7 @@ import Prelude hiding (break, drop, dropWhile, foldl, foldr, length, map, mapM, mapM_, null, reverse, span, splitAt, take, takeWhile) +import Control.Arrow (first) import qualified Control.Monad as Monad import Data.Monoid (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) import qualified Data.Foldable as Foldable @@ -89,9 +90,9 @@ foldr :: (m -> a -> a) -> a -> m -> a -- | The 'length' of the list of 'primes'. length :: m -> Int - -- | Equivalent to 'List.map' from "Data.List", except the argument function works on prime factors rather than list - -- elements. - map :: (FactorialMonoid m, Monoid n) => (m -> n) -> m -> n + -- | Generalizes 'foldMap' from "Data.Foldable", except the function arguments are prime factors rather than the + -- structure elements. + foldMap :: (FactorialMonoid m, Monoid n) => (m -> n) -> m -> n -- | Like 'List.span' from "Data.List" on the list of 'primes'. span :: (m -> Bool) -> m -> (m, m) -- | Equivalent to 'List.break' from "Data.List". @@ -125,15 +126,17 @@ foldl' f f0 = List.foldl' f f0 . factors foldr f f0 = List.foldr f f0 . factors length = List.length . factors - map f = foldr (mappend . f) mempty + foldMap f = foldr (mappend . f) mempty span p m = spanAfter id m where spanAfter f m = case splitPrimePrefix m of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest _ -> (f mempty, m) break = span . (not .) - split p m = foldr f [mempty] m - where f prime s@(x:xs) | p prime = mempty : s - | otherwise = mappend prime x : xs + split p m = prefix : splitRest + where (prefix, rest) = break p m + splitRest = case splitPrimePrefix rest + of Nothing -> [] + Just (_, tail) -> split p tail takeWhile p = fst . span p dropWhile p = snd . span p splitAt n m | n <= 0 = (mempty, m) @@ -206,7 +209,7 @@ foldr _ f0 [] = f0 foldr f f0 (x:xs) = f [x] (foldr f f0 xs) length = List.length - map f = mconcat . List.map (f . (:[])) + foldMap f = mconcat . List.map (f . (:[])) break f = List.break (f . (:[])) span f = List.span (f . (:[])) dropWhile f = List.dropWhile (f . (:[])) @@ -275,8 +278,8 @@ 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 (\(c, t)-> (Text.singleton c, t)) . Text.uncons - splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.splitAt (Text.length x - 1) x) + splitPrimePrefix = fmap (first Text.singleton) . Text.uncons + splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x)) foldl f = Text.foldl f' where f' a char = f a (Text.singleton char) foldl' f = Text.foldl' f' @@ -299,8 +302,10 @@ 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 (\(c, t)-> (LazyText.singleton c, t)) . LazyText.uncons - splitPrimeSuffix x = if LazyText.null x then Nothing else Just (LazyText.splitAt (LazyText.length x - 1) x) + splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons + splitPrimeSuffix x = if LazyText.null x + then Nothing + else Just (LazyText.init x, LazyText.singleton (LazyText.last x)) foldl f = LazyText.foldl f' where f' a char = f a (LazyText.singleton char) foldl' f = LazyText.foldl' f' @@ -448,7 +453,7 @@ -- | A 'Monad.mapM' equivalent. mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b -mapM f = ($ return mempty) . appEndo . map (Endo . Monad.liftM2 mappend . f) +mapM f = ($ return mempty) . appEndo . foldMap (Endo . Monad.liftM2 mappend . f) -- | A 'Monad.mapM_' equivalent. mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m () diff --git a/Data/Monoid/Null.hs b/Data/Monoid/Null.hs --- a/Data/Monoid/Null.hs +++ b/Data/Monoid/Null.hs @@ -33,6 +33,8 @@ -- | 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 diff --git a/Data/Monoid/Textual.hs b/Data/Monoid/Textual.hs --- a/Data/Monoid/Textual.hs +++ b/Data/Monoid/Textual.hs @@ -16,6 +16,8 @@ import Prelude hiding (foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1, map, concatMap, break, span) +import qualified Data.Foldable as Foldable +import qualified Data.Traversable as Traversable import Data.Maybe (fromJust) import Data.Either (rights) import qualified Data.List as List @@ -23,6 +25,8 @@ import qualified Data.Text.Lazy as LazyText import Data.Text (Text) import Data.Monoid (Monoid(mappend, mconcat, mempty)) +import qualified Data.Sequence as Sequence +import qualified Data.Vector as Vector import Data.String (IsString(fromString)) import Data.Monoid.Null (MonoidNull (null)) @@ -185,8 +189,12 @@ dropWhile pt pc = snd . span pt pc span pt pc = Factorial.span (\prime-> maybe (pt prime) pc (characterPrefix prime)) break pt pc = Factorial.break (\prime-> maybe (pt prime) pc (characterPrefix prime)) - split f = Factorial.split (maybe False f . characterPrefix) - find f = foldr (const id) (\c r-> if f c then Just c else r) Nothing + split p m = prefix : splitRest + where (prefix, rest) = break (const False) p m + splitRest = case splitCharacterPrefix rest + of Nothing -> [] + Just (_, tail) -> split p tail + find p = foldr (const id) (\c r-> if p c then Just c else r) Nothing foldlChars f (t, c1) c2 = (mappend t (singleton c'), c') where c' = f c1 c2 @@ -279,3 +287,73 @@ span _ = LazyText.span split = LazyText.split find = LazyText.find + +instance IsString (Sequence.Seq Char) where + fromString = Sequence.fromList + +instance TextualMonoid (Sequence.Seq Char) where + singleton = Sequence.singleton + splitCharacterPrefix s = case Sequence.viewl s + of Sequence.EmptyL -> Nothing + c Sequence.:< rest -> Just (c, rest) + characterPrefix s = case Sequence.viewl s + of Sequence.EmptyL -> Nothing + c Sequence.:< rest -> Just c + map = Traversable.fmapDefault + concatMap = Foldable.foldMap + any = Foldable.any + all = Foldable.all + + foldl = const Foldable.foldl + foldl' = const Foldable.foldl' + foldr = const Foldable.foldr + + scanl = Sequence.scanl + scanl1 f v | Sequence.null v = Sequence.empty + | otherwise = Sequence.scanl1 f v + scanr = Sequence.scanr + scanr1 f v | Sequence.null v = Sequence.empty + | otherwise = Sequence.scanr1 f v + + takeWhile _ = Sequence.takeWhileL + dropWhile _ = Sequence.dropWhileL + break _ = Sequence.breakl + span _ = Sequence.spanl + find = Foldable.find + +instance IsString (Vector.Vector Char) where + fromString = Vector.fromList + +instance TextualMonoid (Vector.Vector Char) where + singleton = Vector.singleton + splitCharacterPrefix t = if Vector.null t then Nothing else Just (Vector.unsafeHead t, Vector.unsafeTail t) + characterPrefix = (Vector.!? 0) + map = Vector.map + concatMap = Vector.concatMap + any = Vector.any + all = Vector.all + + foldl = const Vector.foldl + foldl' = const Vector.foldl' + foldr = const Vector.foldr + + scanl = Vector.scanl + scanl1 f v | Vector.null v = Vector.empty + | otherwise = Vector.scanl1 f v + scanr = Vector.scanr + scanr1 f v | Vector.null v = Vector.empty + | otherwise = Vector.scanr1 f v + mapAccumL f a0 t = (a, Vector.reverse $ Vector.fromList l) + where (a, l) = Vector.foldl fc (a0, []) t + fc (a, l) c = (a', c':l) + where (a', c') = f a c + mapAccumR f a0 t = (a, Vector.fromList l) + where (a, l) = Vector.foldr fc (a0, []) t + fc c (a, l) = (a', c':l) + where (a', c') = f a c + + takeWhile _ = Vector.takeWhile + dropWhile _ = Vector.dropWhile + break _ = Vector.break + span _ = Vector.span + find = Vector.find diff --git a/Test/TestMonoidSubclasses.hs b/Test/TestMonoidSubclasses.hs --- a/Test/TestMonoidSubclasses.hs +++ b/Test/TestMonoidSubclasses.hs @@ -114,7 +114,9 @@ .&&. checkType (mempty :: String) .&&. checkType (mempty :: ByteStringUTF8) .&&. checkType (mempty :: Text) - .&&. checkType (mempty :: Lazy.Text)) + .&&. checkType (mempty :: Lazy.Text) + .&&. checkType (mempty :: Seq Char) + .&&. checkType (mempty :: Vector Char)) checkInstances name (LeftReductiveTest checkType) = label name (checkType (mempty :: String) .&&. checkType (mempty :: ByteString) .&&. checkType (mempty :: Lazy.ByteString) diff --git a/monoid-subclasses.cabal b/monoid-subclasses.cabal --- a/monoid-subclasses.cabal +++ b/monoid-subclasses.cabal @@ -1,5 +1,5 @@ Name: monoid-subclasses -Version: 0.1.2 +Version: 0.2 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid