monoid-subclasses 0.3.6.2 → 0.4
raw patch · 11 files changed
+512/−222 lines, 11 filesdep +monoid-subclassesdep +tastydep +tasty-quickcheckdep −test-frameworkdep −test-framework-quickcheck2dep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies added: monoid-subclasses, tasty, tasty-quickcheck
Dependencies removed: test-framework, test-framework-quickcheck2
Dependency ranges changed: containers
API changes (from Hackage documentation)
- Data.Monoid.Instances.Concat: inject :: (MonoidNull a, PositiveMonoid a) => Seq a -> Concat a
- Data.Monoid.Instances.Measured: inject :: FactorialMonoid a => a -> Measured a
- Data.Monoid.Instances.Positioned: findIndex :: FactorialMonoid a => (OffsetPositioned a -> Bool) -> OffsetPositioned a -> Int
- Data.Monoid.Instances.Positioned: findPosition :: FactorialMonoid m => (OffsetPositioned m -> Bool) -> OffsetPositioned m -> Int
- Data.Monoid.Instances.Stateful: inject :: Monoid a => b -> Stateful a b
+ Data.Monoid.Instances.Concat: instance Applicative Concat
+ Data.Monoid.Instances.Concat: instance Functor Concat
+ Data.Monoid.Textual: break_ :: TextualMonoid t => Bool -> (Char -> Bool) -> t -> (t, t)
+ Data.Monoid.Textual: dropWhile_ :: TextualMonoid t => Bool -> (Char -> Bool) -> t -> t
+ Data.Monoid.Textual: elem :: TextualMonoid t => Char -> t -> Bool
+ Data.Monoid.Textual: foldl_ :: TextualMonoid t => (a -> Char -> a) -> a -> t -> a
+ Data.Monoid.Textual: foldl_' :: TextualMonoid t => (a -> Char -> a) -> a -> t -> a
+ Data.Monoid.Textual: foldr_ :: TextualMonoid t => (Char -> a -> a) -> a -> t -> a
+ Data.Monoid.Textual: spanMaybe_ :: TextualMonoid t => s -> (s -> Char -> Maybe s) -> t -> (t, t, s)
+ Data.Monoid.Textual: spanMaybe_' :: TextualMonoid t => s -> (s -> Char -> Maybe s) -> t -> (t, t, s)
+ Data.Monoid.Textual: span_ :: TextualMonoid t => Bool -> (Char -> Bool) -> t -> (t, t)
+ Data.Monoid.Textual: takeWhile_ :: TextualMonoid t => Bool -> (Char -> Bool) -> t -> t
- Data.Monoid.Textual: class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where fromText = fromString . unpack singleton = fromString . (: []) characterPrefix = fmap fst . splitCharacterPrefix map f = concatMap (singleton . f) concatMap f = foldr mappend (mappend . f) mempty all p = foldr (const id) ((&&) . p) True any p = foldr (const id) ((||) . p) False foldl ft fc = foldl (\ a prime -> maybe (ft a prime) (fc a) (characterPrefix prime)) foldr ft fc = foldr (\ prime -> maybe (ft prime) fc (characterPrefix prime)) foldl' ft fc = foldl' (\ a prime -> maybe (ft a prime) (fc a) (characterPrefix prime)) scanl f c = mappend (singleton c) . fst . foldl foldlOther (foldlChars f) (mempty, c) scanl1 f t = case (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 = span (\ prime -> maybe (pt prime) pc (characterPrefix prime)) break pt pc = break (\ prime -> maybe (pt prime) pc (characterPrefix prime)) spanMaybe s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = case 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 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) } 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
+ Data.Monoid.Textual: class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where fromText = fromString . unpack singleton = fromString . (: []) characterPrefix = fmap fst . splitCharacterPrefix map f = concatMap (singleton . f) concatMap f = foldr mappend (mappend . f) mempty all p = foldr (const id) ((&&) . p) True any p = foldr (const id) ((||) . p) False foldl ft fc = foldl (\ a prime -> maybe (ft a prime) (fc a) (characterPrefix prime)) foldr ft fc = foldr (\ prime -> maybe (ft prime) fc (characterPrefix prime)) foldl' ft fc = 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 (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 = span (\ prime -> maybe (pt prime) pc (characterPrefix prime)) break pt pc = break (\ prime -> maybe (pt prime) pc (characterPrefix prime)) spanMaybe s0 ft fc t0 = spanAfter id s0 t0 where spanAfter g s t = case 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 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 (_, tail) -> split p tail } find p = foldr (const id) (\ c r -> if p c then Just c else r) Nothing elem c = any (== c)
Files
- Data/Monoid/Cancellative.hs +2/−2
- Data/Monoid/Factorial.hs +2/−2
- Data/Monoid/Instances/ByteString/UTF8.hs +73/−12
- Data/Monoid/Instances/Concat.hs +12/−7
- Data/Monoid/Instances/Measured.hs +9/−13
- Data/Monoid/Instances/Positioned.hs +289/−112
- Data/Monoid/Instances/Stateful.hs +10/−8
- Data/Monoid/Null.hs +2/−2
- Data/Monoid/Textual.hs +81/−26
- Test/TestMonoidSubclasses.hs +24/−26
- monoid-subclasses.cabal +8/−12
Data/Monoid/Cancellative.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2011-2013 Mario Blazevic+ Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -32,7 +32,7 @@ -- -- * 'RightGCDMonoid' -{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Haskell2010, Trustworthy #-} module Data.Monoid.Cancellative ( -- * Symmetric, commutative monoid classes
Data/Monoid/Factorial.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2011-2014 Mario Blazevic+ Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -7,7 +7,7 @@ -- | This module defines the 'FactorialMonoid' class and some of its instances. -- -{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Haskell2010, Trustworthy #-} module Data.Monoid.Factorial ( -- * Classes
Data/Monoid/Instances/ByteString/UTF8.hs view
@@ -1,12 +1,36 @@ {- - Copyright 2013 Mario Blazevic+ Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'ByteStringUTF8' newtype wrapper around 'ByteString', together with its 'TextualMonoid'--- instance.+-- instance. The 'FactorialMonoid' instance of a wrapped 'ByteStringUTF8' value differs from the original 'ByteString':+-- the prime 'factors' of the original value are bytes, while UTF8 character byte sequences make up the wrapped value's+-- prime 'factors'. 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<lb\193\177"+-- >> factors bs'+-- >["D","<","l","b","\193","\177"]+-- >> utf8'+-- >"D<lb\[193,177]"+-- >> factors utf8'+-- >["D","<","l","b","\[193,177]"] {-# LANGUAGE Haskell2010 #-} @@ -15,16 +39,16 @@ ) where -import Prelude hiding (drop, dropWhile, foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1,+import Prelude hiding (any, drop, dropWhile, foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1, map, concatMap, break, span) import Control.Exception (assert) import Data.Bits ((.&.), (.|.), shiftL, shiftR)-import Data.Char (chr, ord)+import Data.Char (chr, ord, isDigit, isPrint) import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.Functor ((<$>))-import Data.Maybe (fromJust, fromMaybe)+import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import Data.String (IsString(fromString)) import Data.Word (Word8) import Data.ByteString (ByteString)@@ -82,8 +106,12 @@ {-# INLINE stripCommonPrefix #-} instance Show ByteStringUTF8 where- showsPrec _ bs s = '"' : Textual.foldr showsBytes (:) ('"' : s) bs+ showsPrec _ bs s = '"' : Textual.foldr showsBytes showsChar ('"' : s) 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@@ -245,17 +273,17 @@ | 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, [])- | otherwise = (a, [fromIntegral $ ord c])- f c (a, acc) | c < '\x80' = (fc c (multiByte a acc), [])+ | 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 acc, [fromIntegral $ ord c])- multiByte a acc = reverseBytesToChar ((`ft` a) . ByteStringUTF8) (`fc` a) 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@@ -334,12 +362,20 @@ | 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 && 0xC0 <= b1) $- if b1 < 0xE0+ 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] =@@ -357,6 +393,31 @@ .|. 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) && 0xC0 <= b2 && 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 && 0xA0 <= b2) && 0xC0 <= b3 && 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 (bs1, bs2) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2) {-# INLINE wrapPair #-}
Data/Monoid/Instances/Concat.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2011-2014 Mario Blazevic+ Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -10,12 +10,13 @@ {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Concat (- Concat, concatenate, inject, extract + Concat, concatenate, extract ) where import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)+import Control.Applicative (Applicative(..)) import Data.Foldable (Foldable) import Data.Traversable (Traversable, traverse) import qualified Data.Foldable as Foldable@@ -34,7 +35,7 @@ import qualified Data.Sequence as Seq -- | @'Concat' a@ is a @newtype@ wrapper around @'Seq' a@. The behaviour of the @'Concat' a@ instances of monoid--- subclasses is identical to the behaviour of their @a@ instances, up to the @'inject' . 'singleton'@ isomorphism.+-- 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 constant-time operation.@@ -50,6 +51,14 @@ 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)@@ -207,10 +216,6 @@ break pt pc = Textual.span (not . pt) (not . pc) find p (Concat x) = getFirst $ Foldable.foldMap (First . find p) x--inject :: (MonoidNull a, PositiveMonoid a) => Seq a -> Concat a-inject = concatenate-{-# DEPRECATED inject "Use concatenate instead." #-} injectSingleton :: (MonoidNull a, PositiveMonoid a) => a -> Concat a injectSingleton a | null a = mempty
Data/Monoid/Instances/Measured.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2013-2014 Mario Blazevic+ Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -10,7 +10,7 @@ {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Measured (- Measured, inject, measure, extract+ Measured, measure, extract ) where @@ -38,10 +38,6 @@ measure :: FactorialMonoid a => a -> Measured a measure x = Measured (length x) x -inject :: FactorialMonoid a => a -> Measured a-inject = measure-{-# DEPRECATED inject "Use measure instead." #-}- instance Ord a => Ord (Measured a) where compare (Measured _ x) (Measured _ y) = compare x y @@ -61,10 +57,10 @@ stripSuffix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripSuffix x y) instance (LeftGCDMonoid a, StableFactorialMonoid a) => LeftGCDMonoid (Measured a) where- commonPrefix (Measured _ x) (Measured _ y) = inject (commonPrefix x y)+ commonPrefix (Measured _ x) (Measured _ y) = measure (commonPrefix x y) instance (RightGCDMonoid a, StableFactorialMonoid a) => RightGCDMonoid (Measured a) where- commonSuffix (Measured _ x) (Measured _ y) = inject (commonSuffix x y)+ 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)@@ -86,9 +82,9 @@ foldMap f (Measured _ x) = Factorial.foldMap (f . Measured 1) x span p (Measured n x) = (xp', xs') where (xp, xs) = Factorial.span (p . Measured 1) x- xp' = inject xp+ xp' = measure xp xs' = Measured (n - length xp') xs- split p (Measured _ x) = inject <$> Factorial.split (p . Measured 1) x+ 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)@@ -98,10 +94,10 @@ instance StableFactorialMonoid a => StableFactorialMonoid (Measured a) instance (FactorialMonoid a, IsString a) => IsString (Measured a) where- fromString = inject . fromString+ fromString = measure . fromString instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Measured a) where- fromText = inject . fromText+ fromText = measure . fromText singleton = Measured 1 . singleton splitCharacterPrefix (Measured n x) = (Measured (n - 1) <$>) <$> splitCharacterPrefix x characterPrefix (Measured _ x) = characterPrefix x@@ -115,7 +111,7 @@ span pt pc (Measured n x) = (xp', xs') where (xp, xs) = Textual.span (pt . Measured 1) pc x- xp' = inject xp+ xp' = measure xp xs' = Measured (n - length xp') xs break pt pc = Textual.span (not . pt) (not . pc)
Data/Monoid/Instances/Positioned.hs view
@@ -1,5 +1,5 @@ {-- Copyright 2014 Mario Blazevic+ Copyright 2014-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -10,26 +10,29 @@ -- 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, findIndex, findPosition+ OffsetPositioned, LinePositioned, extract, position, line, column ) where -import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,+import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, lines, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) import Control.Applicative (Applicative(..))-import Data.Functor ((<$>)) import qualified Data.List as List import Data.String (IsString(..))-import Data.Sequence (Seq, filter, (<|), (|>), ViewL((:<)), ViewR((:>)))-import qualified Data.Sequence as Seq -import Data.Monoid (Monoid(..), (<>), Endo(..), First(..), Sum(..))-import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), ReductiveMonoid(..),- LeftGCDMonoid(..), RightGCDMonoid(..), GCDMonoid(..))+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(..))@@ -65,7 +68,7 @@ OffsetPositioned _ f <*> OffsetPositioned p c = OffsetPositioned p (f c) instance Applicative LinePositioned where- pure = LinePositioned 1 1 0+ pure = LinePositioned 0 0 0 LinePositioned _ _ _ f <*> LinePositioned p l lp c = LinePositioned p l lp (f c) instance Positioned OffsetPositioned where@@ -98,24 +101,32 @@ instance StableFactorialMonoid m => Monoid (OffsetPositioned m) where mempty = pure mempty mappend (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) =- OffsetPositioned (max p1 (p2 - length c1)) (mappend c1 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) =- let p2' = p2 - length c1- l2' = l2 - lines- (lines, _) = linesColumns c1- c = mappend c1 c2- in if p1 >= p2' || l1 > l2' || lp1 > lp2- then LinePositioned p1 l1 lp1 c- else LinePositioned p2' l2' (if lines == 0 then lp2 else lp1) c+ 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) @@ -124,14 +135,18 @@ 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+ 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)@@ -139,6 +154,8 @@ (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) =@@ -147,21 +164,27 @@ 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+ (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) = @@ -171,6 +194,8 @@ (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) =@@ -181,17 +206,17 @@ where (c1', c2', suffix) = stripCommonSuffix c1 c2 len1 = length c1' len2 = length c2'- (lines1, columns1) = linesColumns c1'- (lines2, columns2) = linesColumns 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 position (splitPrimePrefix c)- where position (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (succ p) cs)- splitPrimeSuffix (OffsetPositioned p c) = fmap position (splitPrimeSuffix c)- where position (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (p + length cp) cs)+ 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@@ -202,10 +227,22 @@ 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))- span f m = Factorial.splitAt (findIndex (not . f) m) m- break f m = Factorial.splitAt (findIndex f m) m- takeWhile f m = Factorial.take (findIndex (not . f) m) m- dropWhile f m = Factorial.drop (findIndex (not . f) m) m++ 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)@@ -213,55 +250,103 @@ 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 position (splitPrimePrefix c)- where position (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 position (splitPrimeSuffix c)- where position (cp, cs) = (LinePositioned p l lp cp, LinePositioned (p + len) (l + lines) (lp + len - columns) cs)+ 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- foldl f a0 (LinePositioned p0 l0 lp0 c0) = fst $ Factorial.foldl f' (a0, p0, l0, lp0) c0+ 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)- fst (a, _, _, _) = a- foldl' f a0 (LinePositioned p0 l0 lp0 c0) = fst $ Factorial.foldl' f' (a0, p0, l0, lp0) c0+ 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))- fst (a, _, _, _) = a 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 p l lp c) = appEndo (Factorial.foldMap f' c) (const mempty) p l lp+ foldMap f (LinePositioned p0 l0 lp0 c) = appEndo (Factorial.foldMap f' c) (const mempty) p0 l0 lp0 where -- f' :: m -> Endo (Int -> Int -> Int -> m) f' prime = Endo (\cont p l lp-> f (LinePositioned p l lp prime) <> if characterPrefix prime == Just '\n' then cont (succ p) (succ l) p else cont (succ p) l lp)- - span f m = Factorial.splitAt (findLineIndex (not . f) m) m- break f m = Factorial.splitAt (findLineIndex f m) m- takeWhile f m = Factorial.take (findLineIndex (not . f) m) m- dropWhile f m = Factorial.drop (findLineIndex (not . f) m) m++ 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 + n) (l + lines) (lp + n - columns) suffix)+ 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 drop #-}+ {-# INLINE reverse #-} instance StableFactorialMonoid m => StableFactorialMonoid (OffsetPositioned m) @@ -290,8 +375,8 @@ 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 = let a' = ft a (OffsetPositioned p c) in seq a' (a', succ p)- fc' (a, p) c = let a' = fc a c in seq a' (a', succ p)+ 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)@@ -303,27 +388,75 @@ 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) - span pt pc (OffsetPositioned p c) = - case (splitCharacterPrefix cs, splitPrimePrefix cs)- of (Nothing, Just (csp, css)) | pt (OffsetPositioned p' csp) ->- let (OffsetPositioned _ cssp, ms) = Textual.span pt pc (OffsetPositioned (succ p') css)- in (OffsetPositioned p (cp <> csp <> cssp), ms)- _ -> (OffsetPositioned p cp, OffsetPositioned p' cs)- where (cp, cs) = Textual.span (const False) pc c- p' = p + length cp- break pt pc (OffsetPositioned p c) =- case (splitCharacterPrefix cs, splitPrimePrefix cs)- of (Nothing, Just (csp, css)) | not (pt (OffsetPositioned p' csp)) ->- let (OffsetPositioned _ cssp, ms) = Textual.break pt pc (OffsetPositioned (succ p') css)- in (OffsetPositioned p (cp <> csp <> cssp), ms)- _ -> (OffsetPositioned p cp, OffsetPositioned p' cs)- where (cp, cs) = Textual.break (const True) pc c- p' = p + length cp+ 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 p [] = []+ 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 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@@ -343,9 +476,8 @@ 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) '\n' = (fc a '\n', succ p, succ l, p) fc' (a, p, l, lp) c = (fc a c, succ p, l, lp)- fstOf4 (a, _, _, _) = a 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@@ -353,16 +485,44 @@ fc' (a, p, l, lp) c = let a' = fc a c p' = succ p l' = succ l- in if c == '\n'- then a' `seq` p' `seq` l' `seq` (a', p', l', p)- else a' `seq` p' `seq` (a', p', l, lp)- fstOf4 (a, _, _, _) = a+ 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)@@ -370,28 +530,6 @@ 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) - span pt pc (LinePositioned p l lp c) = - case (splitCharacterPrefix cs, splitPrimePrefix cs)- of (Nothing, Just (csp, css)) | pt (LinePositioned p' l' lp' csp) ->- let (LinePositioned{extractLines= cssp}, ms) = Textual.span pt pc (LinePositioned (succ p') l' lp' css)- in (LinePositioned p l lp (cp <> csp <> cssp), ms)- _ -> (LinePositioned p l lp cp, LinePositioned p' l' lp' cs)- where (cp, cs) = Textual.span (const False) pc c- p' = p + length cp- l' = l + lines- lp' = if lines == 0 then lp else p' - columns- (lines, columns) = linesColumns cp- break pt pc (LinePositioned p l lp c) =- case (splitCharacterPrefix cs, splitPrimePrefix cs)- of (Nothing, Just (csp, css)) | not (pt (LinePositioned p' l' lp' csp)) ->- let (LinePositioned{extractLines= cssp}, ms) = Textual.break pt pc (LinePositioned (succ p') l' lp' css)- in (LinePositioned p l lp (cp <> csp <> cssp), ms)- _ -> (LinePositioned p l lp cp, LinePositioned p' l' lp' cs)- where (cp, cs) = Textual.break (const True) pc c- p' = p + length cp- l' = l + lines- lp' = if lines == 0 then lp else p' - columns- (lines, columns) = linesColumns cp 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 @@ -400,26 +538,65 @@ (lines, columns) = linesColumns c find p = find p . extractLines -findIndex f m = findPosition f m - position m--findPosition :: FactorialMonoid m => (OffsetPositioned m -> Bool) -> OffsetPositioned m -> Int-findPosition f (OffsetPositioned p c) = appEndo (foldMap f' c) id p- where -- f' :: m -> Endo ((Int -> Int) -> Int -> Int)- f' prime = Endo (\cont pos-> if f (OffsetPositioned pos prime) then pos else cont (succ pos))+ 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 -findLineIndex f m = findLinePosition f m - position m+ 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) -findLinePosition :: TextualMonoid m => (LinePositioned m -> Bool) -> LinePositioned m -> Int-findLinePosition f (LinePositioned p l lp c) = Factorial.foldr f' const2 c p l lp- where -- f' :: m -> (Int -> Int -> Int -> Int) -> Int -> Int -> Int -> Int- f' t cont p l lp | f (LinePositioned p l lp t) = p - | characterPrefix t == Just '\n' = cont (succ p) (succ l) p- | otherwise = cont (succ p) l lp- const2 p _l _lp = p+ {-# 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 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, c) '\n' = (succ l, 0)+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 #-}
Data/Monoid/Instances/Stateful.hs view
@@ -1,20 +1,25 @@ {-- Copyright 2013-2014 Mario Blazevic+ 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), inject, extract, state, setState+ Stateful(Stateful), extract, state, setState ) where -import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,+import Prelude hiding (all, any, break, elem, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) import Control.Applicative (Applicative(..)) import Data.Functor ((<$>))@@ -34,10 +39,6 @@ -- 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) -inject :: Monoid a => b -> Stateful a b-inject = pure-{-# DEPRECATED inject "Use pure instead." #-}- extract :: Stateful a b -> b extract (Stateful (t, _)) = t @@ -100,7 +101,7 @@ instance (StableFactorialMonoid a, StableFactorialMonoid b) => StableFactorialMonoid (Stateful a b) instance (Monoid a, IsString b) => IsString (Stateful a b) where- fromString = inject . fromString+ fromString = pure . fromString instance (LeftGCDMonoid a, FactorialMonoid a, TextualMonoid b) => TextualMonoid (Stateful a b) where fromText t = Stateful (fromText t, mempty)@@ -145,6 +146,7 @@ restore f [t] = f [Stateful (t, x)] restore f (hd:tl) = restore (f . (Stateful (hd, mempty):)) tl find p = find p . extract+ elem c = elem c . extract {-# INLINE fromFst #-} fromFst :: Monoid b => a -> Stateful b a
Data/Monoid/Null.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2011-2013 Mario Blazevic+ Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -7,7 +7,7 @@ -- | This module defines the MonoidNull class and some of its instances. -- -{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Haskell2010, Trustworthy #-} module Data.Monoid.Null ( MonoidNull(..), PositiveMonoid
Data/Monoid/Textual.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2013 Mario Blazevic+ Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -7,14 +7,15 @@ -- | This module defines the 'TextualMonoid' class and its most important instances for 'String' and 'Text'. -- -{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-} module Data.Monoid.Textual ( TextualMonoid(..) ) where -import Prelude hiding (foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1, map, concatMap, break, span)+import Prelude hiding (all, any, break, concatMap, dropWhile, foldl, foldl1, foldr, foldr1, map, scanl, scanl1, scanr, scanr1,+ span, takeWhile) import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable@@ -59,11 +60,16 @@ -- > -- > 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. All of the following--- expressions are identities:+-- 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@@ -156,7 +162,26 @@ 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 . (:[]) @@ -170,6 +195,9 @@ 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)@@ -207,16 +235,24 @@ 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 (_, tail) -> split p tail 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 find #-} {-# INLINE fromText #-} {-# INLINE map #-} {-# INLINE mapAccumL #-}@@ -230,6 +266,15 @@ {-# INLINE spanMaybe' #-} {-# INLINE split #-} {-# INLINE takeWhile #-}+ {-# INLINE foldl_ #-}+ {-# INLINE foldl_' #-}+ {-# INLINE foldr_ #-}+ {-# INLINE spanMaybe_ #-}+ {-# INLINE spanMaybe_' #-}+ {-# INLINE span_ #-}+ {-# INLINE break_ #-}+ {-# INLINE takeWhile_ #-}+ {-# INLINE dropWhile_ #-} foldlChars f (t, c1) c2 = (mappend t (singleton c'), c') where c' = f c1 c2@@ -265,21 +310,24 @@ dropWhile _ = List.dropWhile break _ = List.break span _ = List.span- spanMaybe s0 ft fc l = (prefix' [], suffix' [], s')+ spanMaybe s0 _ft fc l = (prefix' [], suffix' [], s') where (prefix', suffix', s', live') = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s, live) c | live, Just s' <- fc s c = (prefix . (c:), id, s', True) | otherwise = (prefix, suffix . (c:), s, False)- spanMaybe' s0 ft fc l = (prefix' [], suffix' [], s')+ spanMaybe' s0 _ft fc l = (prefix' [], suffix' [], s') where (prefix', suffix', s', live') = List.foldl' g (id, id, s0, True) l g (prefix, suffix, s, live) c | live, Just s' <- fc s c = seq s' (prefix . (c:), id, s', 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' #-}@@ -325,16 +373,17 @@ 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')+ 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')+ 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 #-}@@ -386,12 +435,12 @@ 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')+ 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')+ 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@@ -453,21 +502,24 @@ 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')+ 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')+ 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' #-}@@ -523,23 +575,26 @@ 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+ 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' #-}
Test/TestMonoidSubclasses.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2013 Mario Blazevic+ Copyright 2013-2015 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -11,8 +11,9 @@ import Prelude hiding (foldl, foldr, gcd, length, null, reverse, span, splitAt, takeWhile) -import Test.QuickCheck (Arbitrary, CoArbitrary, Property, Gen,- quickCheck, arbitrary, coarbitrary, property, label, forAll, mapSize, variant, whenFail, (.&&.))+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)@@ -310,29 +311,26 @@ CancellativeGCDMonoidInstance (mempty :: Dual (Sum Integer)), CancellativeGCDMonoidInstance (mempty :: (Sum Integer, Sum Int))] -main = mapM_ (quickCheck . uncurry checkInstances) tests+main = defaultMain (testGroup "MonoidSubclasses" $ map expand tests)+ where expand (name, test) = testProperty name (foldr1 (.&&.) $ checkInstances test) -checkInstances :: String -> Test -> Property-checkInstances name (CommutativeTest checkType) = label name $ foldr1 (.&&.) (map checkType commutativeInstances)-checkInstances name (NullTest checkType) = label name $ foldr1 (.&&.) (map checkType nullInstances)-checkInstances name (PositiveTest checkType) = label name $ foldr1 (.&&.) (map checkType positiveInstances)-checkInstances name (FactorialTest checkType) = label name $ foldr1 (.&&.) (map checkType factorialInstances)-checkInstances name (StableFactorialTest checkType) =- label name $ foldr1 (.&&.) (map checkType stableFactorialInstances)-checkInstances name (TextualTest checkType) = label name $ foldr1 (.&&.) (map checkType textualInstances)-checkInstances name (LeftReductiveTest checkType) = label name $ foldr1 (.&&.) (map checkType leftReductiveInstances)-checkInstances name (RightReductiveTest checkType) = label name $ foldr1 (.&&.) (map checkType rightReductiveInstances)-checkInstances name (ReductiveTest checkType) = label name $ foldr1 (.&&.) (map checkType reductiveInstances)-checkInstances name (LeftCancellativeTest checkType) =- label name $ foldr1 (.&&.) (map checkType leftCancellativeInstances) -checkInstances name (RightCancellativeTest checkType) =- label name $ foldr1 (.&&.) (map checkType rightCancellativeInstances) -checkInstances name (CancellativeTest checkType) = label name $ foldr1 (.&&.) (map checkType cancellativeInstances) -checkInstances name (LeftGCDTest checkType) = label name $ foldr1 (.&&.) (map checkType leftGCDInstances) -checkInstances name (RightGCDTest checkType) = label name $ foldr1 (.&&.) (map checkType rightGCDInstances) -checkInstances name (GCDTest checkType) = label name $ foldr1 (.&&.) (map checkType gcdInstances) -checkInstances name (CancellativeGCDTest checkType) = - label name $ foldr1 (.&&.) (map checkType cancellativeGCDInstances) +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),@@ -521,7 +519,7 @@ forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldr (\a l-> Left a : l) (\c l-> Right c : l) [] a == textualFactors a && Textual.foldr (<>) ((<>) . Textual.singleton) mempty a == a- check2 s = Textual.foldr undefined (:) [] s == s+ check2 s = Textual.foldr undefined (:) [] (fromString s :: a) == s checkTextualFoldl' (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2
monoid-subclasses.cabal view
@@ -1,5 +1,5 @@ Name: monoid-subclasses-Version: 0.3.6.2+Version: 0.4 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid@@ -11,7 +11,7 @@ License: BSD3 License-file: BSD3-LICENSE.txt-Copyright: (c) 2013-2014 Mario Blazevic+Copyright: (c) 2013-2015 Mario Blazevic Author: Mario Blazevic Maintainer: Mario Blazevic <blamario@yahoo.com> Homepage: https://github.com/blamario/monoid-subclasses/@@ -24,20 +24,16 @@ 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 < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text >= 0.11 && < 1.3,+ Build-Depends: base >= 4 && < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text >= 0.11 && < 1.3, primes == 0.2.*, vector >= 0.9 && < 0.11 GHC-prof-options: -auto-all- if impl(ghc >= 7.0.0)- default-language: Haskell2010+ default-language: Haskell2010 test-suite Main Type: exitcode-stdio-1.0- x-uses-tf: true- Build-Depends: base < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text >= 0.11 && < 1.3,- primes == 0.2.*, vector >= 0.9 && < 0.11, QuickCheck == 2.*, quickcheck-instances == 0.3.*,- test-framework >= 0.4.1, test-framework-quickcheck2+ Build-Depends: base >= 4 && < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text >= 0.11 && < 1.3,+ vector >= 0.9 && < 0.11, primes == 0.2.*,+ QuickCheck == 2.*, quickcheck-instances == 0.3.*, tasty >= 0.7, tasty-quickcheck >= 0.7,+ monoid-subclasses Main-is: Test/TestMonoidSubclasses.hs- Other-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual,- Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat,- Data.Monoid.Instances.Measured, Data.Monoid.Instances.Positioned, Data.Monoid.Instances.Stateful default-language: Haskell2010