monoid-subclasses 0.3.5 → 0.3.6
raw patch · 6 files changed
+488/−24 lines, 6 filesdep ~text
Dependency ranges changed: text
Files
- Data/Monoid/Instances/Concat.hs +7/−3
- Data/Monoid/Instances/Measured.hs +8/−3
- Data/Monoid/Instances/Positioned.hs +425/−0
- Data/Monoid/Instances/Stateful.hs +12/−3
- Test/TestMonoidSubclasses.hs +31/−10
- monoid-subclasses.cabal +5/−5
Data/Monoid/Instances/Concat.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2011-2013 Mario Blazevic+ Copyright 2011-2014 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -10,7 +10,7 @@ {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Concat (- Concat, inject, extract + Concat, concatenate, inject, extract ) where @@ -41,6 +41,9 @@ -- newtype Concat a = Concat {extract :: Seq a} deriving Show +concatenate :: (MonoidNull a, 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 @@ -206,7 +209,8 @@ find p (Concat x) = getFirst $ Foldable.foldMap (First . find p) x inject :: (MonoidNull a, PositiveMonoid a) => Seq a -> Concat a-inject = Concat . filter (not . null)+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 Mario Blazevic+ Copyright 2013-2014 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -10,7 +10,7 @@ {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Instances.Measured (- Measured, inject, extract + Measured, inject, measure, extract ) where @@ -34,8 +34,13 @@ 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+ inject :: FactorialMonoid a => a -> Measured a-inject x = Measured (length x) x+inject = measure+{-# DEPRECATED inject "Use measure instead." #-} instance Ord a => Ord (Measured a) where compare (Measured _ x) (Measured _ y) = compare x y
+ Data/Monoid/Instances/Positioned.hs view
@@ -0,0 +1,425 @@+{-+ Copyright 2014 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.+--++{-# LANGUAGE Haskell2010 #-}++module Data.Monoid.Instances.Positioned (+ OffsetPositioned, LinePositioned, extract, position, line, column, findIndex, findPosition+ )+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.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.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++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 1 1 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 (max p1 (p2 - length c1)) (mappend c1 c2)++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++instance (StableFactorialMonoid m, MonoidNull m) => MonoidNull (OffsetPositioned m) where+ null = null . extractOffset++instance (StableFactorialMonoid m, TextualMonoid m, MonoidNull m) => MonoidNull (LinePositioned m) where+ null = null . extractLines++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)++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)++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++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')++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)++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)++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++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 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)+ 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))+ 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+ 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)++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)+ 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+ 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+ 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+ 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+ 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)+ where (prefix, suffix) = splitAt n c+ (lines, columns) = linesColumns prefix+ 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)++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 = 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)+ 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)++ 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+ split f (OffsetPositioned p0 c0) = rewrap p0 (Textual.split f c0)+ where rewrap p [] = []+ rewrap p (c:rest) = OffsetPositioned p c : rewrap (p + length c) rest+ find p = find p . extractOffset++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)+ 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+ 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 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+ 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++ 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)++ 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 + : 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++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))++findLineIndex f m = findLinePosition f m - position m++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++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)+ fc (l, c) _ = (l, succ c)++const3 a _p _l _lp = a
Data/Monoid/Instances/Stateful.hs view
@@ -1,5 +1,5 @@ {-- Copyright 2013 Mario Blazevic+ Copyright 2013-2014 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -16,6 +16,7 @@ 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.Functor ((<$>)) import qualified Data.List as List import Data.String (IsString(..))@@ -31,10 +32,11 @@ -- | @'Stateful' a b@ is a wrapper around the 'Monoid' @b@ that carries the state @a@ along. The state type @a@ must be -- a monoid as well if 'Stateful' is to be of any use. In the 'FactorialMonoid' and 'TextualMonoid' class instances, the -- monoid @b@ has the priority and the state @a@ is left for the end.-data Stateful a b = Stateful (b, a) deriving (Eq, Ord, Show)+newtype Stateful a b = Stateful (b, a) deriving (Eq, Ord, Show) inject :: Monoid a => b -> Stateful a b-inject m = Stateful (m, mempty)+inject = pure+{-# DEPRECATED inject "Use pure instead." #-} extract :: Stateful a b -> b extract (Stateful (t, _)) = t@@ -44,6 +46,13 @@ 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
Test/TestMonoidSubclasses.hs view
@@ -51,6 +51,8 @@ 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))@@ -173,7 +175,7 @@ where upcast (StableFactorialMonoidInstance i) = FactorialMonoidInstance i stableFactorialInstances :: [StableFactorialMonoidInstance]-stableFactorialInstances = stable1 ++ map measure stable1+stableFactorialInstances = stable1 ++ map measure stable1 ++ map position stable1 where stable1 = map upcast stableTextualInstances ++ [StableFactorialMonoidInstance (mempty :: ByteString), StableFactorialMonoidInstance (mempty :: Lazy.ByteString),@@ -181,7 +183,9 @@ StableFactorialMonoidInstance (mempty :: Seq Int), StableFactorialMonoidInstance (mempty :: Vector Int)] upcast (StableTextualMonoidInstance i) = StableFactorialMonoidInstance i- measure (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (Measured.inject i)+ measure (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (Measured.measure i)+ position (StableFactorialMonoidInstance (i :: a)) = + StableFactorialMonoidInstance (pure i :: OffsetPositioned a) textualInstances :: [TextualMonoidInstance] textualInstances = map upcast stableTextualInstances@@ -194,12 +198,17 @@ where upcast (StableTextualMonoidInstance i) = TextualMonoidInstance i stableTextualInstances :: [StableTextualMonoidInstance]-stableTextualInstances = [StableTextualMonoidInstance (mempty :: TestString),- StableTextualMonoidInstance (mempty :: String),- StableTextualMonoidInstance (mempty :: Text),- StableTextualMonoidInstance (mempty :: Lazy.Text),- StableTextualMonoidInstance (mempty :: Seq Char),- StableTextualMonoidInstance (mempty :: Vector Char)]+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),@@ -683,11 +692,17 @@ arbitrary = fmap ByteStringUTF8 arbitrary instance (Arbitrary a, MonoidNull a, PositiveMonoid a) => Arbitrary (Concat a) where- arbitrary = fmap Concat.inject arbitrary+ arbitrary = fmap Concat.concatenate arbitrary instance (Arbitrary a, FactorialMonoid a) => Arbitrary (Measured a) where- arbitrary = fmap Measured.inject arbitrary+ 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 @@ -723,6 +738,12 @@ 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
monoid-subclasses.cabal view
@@ -1,5 +1,5 @@ Name: monoid-subclasses-Version: 0.3.5+Version: 0.3.6 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid@@ -23,8 +23,8 @@ Library Exposed-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual, Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat,- Data.Monoid.Instances.Measured, Data.Monoid.Instances.Stateful- Build-Depends: base < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text >= 0.11 && < 1.1,+ 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.2, primes == 0.2.*, vector >= 0.9 && < 0.11 GHC-prof-options: -auto-all if impl(ghc >= 7.0.0)@@ -33,11 +33,11 @@ test-suite Main Type: exitcode-stdio-1.0 x-uses-tf: true- Build-Depends: base < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text >= 0.11 && < 1.1,+ Build-Depends: base < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text >= 0.11 && < 1.2, primes == 0.2.*, vector >= 0.9 && < 0.11, QuickCheck == 2.*, quickcheck-instances == 0.3.*, test-framework >= 0.4.1, test-framework-quickcheck2 Main-is: Test/TestMonoidSubclasses.hs Other-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual, Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat,- Data.Monoid.Instances.Measured, Data.Monoid.Instances.Stateful+ Data.Monoid.Instances.Measured, Data.Monoid.Instances.Positioned, Data.Monoid.Instances.Stateful default-language: Haskell2010