monoid-subclasses 1.0.1 → 1.1
raw patch · 9 files changed
+197/−61 lines, 9 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Data.Monoid.Textual: toText :: TextualMonoid t => (t -> Text) -> t -> Text
Files
- CHANGELOG.md +8/−1
- Test/TestMonoidSubclasses.hs +54/−5
- monoid-subclasses.cabal +2/−2
- src/Data/Monoid/Instances/ByteString/UTF8.hs +4/−0
- src/Data/Monoid/Instances/Concat.hs +2/−0
- src/Data/Monoid/Instances/Measured.hs +1/−0
- src/Data/Monoid/Instances/Positioned.hs +119/−52
- src/Data/Monoid/Textual.hs +6/−0
- src/Data/Semigroup/Factorial.hs +1/−1
CHANGELOG.md view
@@ -1,3 +1,10 @@+Version 1.1+---------------+* Added a new TextualMonoid method `toText` for performance+* Fixed the calculations of `column` of `LinePositioned`+* Changed the `column` of `LinePositioned` to be one-based+* `LinePositioned` now treats FF, CR, and TAB characters as+ special, in accordance with Haskell language specification. Version 1.0.1 ---------------@@ -11,7 +18,7 @@ * Introduced the `Monus` class * Introduced the `OverlappingGCDMonoid` class * Added the instances of type `Sum Natural` and `Product Natural`-* Using the language extensions 'FlexibleInstances' and 'OverlappingInstances'+* Using the language extensions `FlexibleInstances` and `OverlappingInstances` * Removed the linear complexity requirement * Added and documented less efficient instances * Moved various GCD classes into the new module `Data.Monoid.GCD`
Test/TestMonoidSubclasses.hs view
@@ -214,7 +214,9 @@ TextualMonoidInstance (mempty :: Lazy.Text), TextualMonoidInstance (mempty :: Seq Char), TextualMonoidInstance (mempty :: Vector Char),- TextualMonoidInstance (mempty :: Stateful (IntMap Int) Text)]+ TextualMonoidInstance (mempty :: Stateful (IntMap Int) Text),+ TextualMonoidInstance (mempty :: TestOffsetPositionedString),+ TextualMonoidInstance (mempty :: TestLinePositionedString)] where upcast (StableTextualMonoidInstance i) = TextualMonoidInstance i stableTextualInstances :: [StableTextualMonoidInstance]@@ -428,6 +430,7 @@ ("Textual.scanl1", TextualTest checkTextualScanl1), ("Textual.scanr1", TextualTest checkTextualScanr1), ("Textual.toString", TextualTest checkToString),+ ("Textual.toText", TextualTest checkToText), ("Textual.mapAccumL", TextualTest checkTextualMapAccumL), ("Textual.mapAccumR", TextualTest checkTextualMapAccumR), ("Textual.takeWhile", TextualTest checkTextualTakeWhile),@@ -654,6 +657,11 @@ where check1 a = forAll arbitrary $ \f-> Textual.toString f a == Textual.foldr (\t s-> f t ++ s) (:) "" a check2 s = Textual.toString undefined (fromString s :: a) == s +checkToText (TextualMonoidInstance (_ :: a)) =+ forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen Text) check2+ where check1 a = forAll arbitrary $ \f-> Textual.toText f a == Textual.foldr (\t s-> f t <> s) Text.cons Text.empty a+ check2 s = Textual.toText undefined (Textual.fromText s :: a) == s+ checkTextualMapAccumL (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumL (,)) ((), a) == ((), a)@@ -680,8 +688,8 @@ where check1 a = textualFactors (Textual.dropWhile (const True) isLetter a) == List.dropWhile (either (const True) isLetter) (textualFactors a) && Textual.dropWhile (const False) (const False) a == a- check2 s = Textual.dropWhile undefined isLetter (fromString s :: a)- == fromString (List.dropWhile isLetter s)+ check2 s = Textual.toString undefined (Textual.dropWhile undefined isLetter (fromString s :: a))+ == List.dropWhile isLetter s checkTextualSpan (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.span pt pc a == (Textual.takeWhile pt pc a, Textual.dropWhile pt pc a)@@ -740,8 +748,8 @@ where check1 a = textualFactors (Textual.dropWhile_ True isLetter a) == List.dropWhile (either (const True) isLetter) (textualFactors a) && Textual.dropWhile_ False (const False) a == a- check2 s = Textual.dropWhile_ undefined isLetter (fromString s :: a)- == fromString (List.dropWhile isLetter s)+ check2 s = Textual.toString undefined (Textual.dropWhile_ undefined isLetter (fromString s :: a))+ == List.dropWhile isLetter s checkTextualSplit (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = List.all (List.all isLetter . rights . textualFactors) (Textual.split (not . isLetter) a)@@ -870,6 +878,18 @@ Monoid, LeftGCDMonoid, MonoidNull, PositiveMonoid, IsString) +newtype TestOffsetPositionedString = TestOffsetPositionedString (OffsetPositioned String)+ deriving (Show, Arbitrary, CoArbitrary,+ Semigroup, LeftReductive, LeftCancellative,+ Monoid, LeftGCDMonoid,+ MonoidNull, PositiveMonoid, IsString)++newtype TestLinePositionedString = TestLinePositionedString (LinePositioned String)+ deriving (Show, Arbitrary, CoArbitrary,+ Semigroup, LeftReductive, LeftCancellative,+ Monoid, LeftGCDMonoid,+ MonoidNull, PositiveMonoid, IsString)+ instance Factorial TestString where factors (TestString s) = TestString <$> factors s @@ -880,6 +900,35 @@ instance TextualMonoid TestString where splitCharacterPrefix (TestString []) = Nothing splitCharacterPrefix (TestString (x:xs)) = Just (x, TestString xs)++instance Eq TestOffsetPositionedString where+ TestOffsetPositionedString a == TestOffsetPositionedString b =+ a == b && Positioned.position a == Positioned.position b++instance Factorial TestOffsetPositionedString where+ factors (TestOffsetPositionedString s) = TestOffsetPositionedString <$> factors s++instance FactorialMonoid TestOffsetPositionedString where+ splitPrimePrefix (TestOffsetPositionedString s) = rewrap <$> splitPrimePrefix s+ where rewrap (x, xs) = (TestOffsetPositionedString x, TestOffsetPositionedString xs)++instance TextualMonoid TestOffsetPositionedString where+ splitCharacterPrefix (TestOffsetPositionedString x) = (TestOffsetPositionedString <$>) <$> Textual.splitCharacterPrefix x++instance Eq TestLinePositionedString where+ TestLinePositionedString a == TestLinePositionedString b =+ a == b && Positioned.line a == Positioned.line b && Positioned.column a == Positioned.column b+ && Positioned.position a == Positioned.position b++instance Factorial TestLinePositionedString where+ factors (TestLinePositionedString s) = TestLinePositionedString <$> factors s++instance FactorialMonoid TestLinePositionedString where+ splitPrimePrefix (TestLinePositionedString s) = rewrap <$> splitPrimePrefix s+ where rewrap (x, xs) = (TestLinePositionedString x, TestLinePositionedString xs)++instance TextualMonoid TestLinePositionedString where+ splitCharacterPrefix (TestLinePositionedString x) = (TestLinePositionedString <$>) <$> Textual.splitCharacterPrefix x instance Arbitrary ByteStringUTF8 where arbitrary = fmap ByteStringUTF8 arbitrary
monoid-subclasses.cabal view
@@ -1,5 +1,5 @@ Name: monoid-subclasses-Version: 1.0.1+Version: 1.1 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid@@ -29,7 +29,7 @@ Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.CharVector, Data.Monoid.Instances.Concat, Data.Monoid.Instances.Measured, Data.Monoid.Instances.Positioned, Data.Monoid.Instances.Stateful- Build-Depends: base >= 4.11 && < 5,+ Build-Depends: base >= 4.10 && < 5, bytestring >= 0.9 && < 1.0, containers >= 0.5.7.0 && < 0.7, text >= 0.11 && < 1.3, primes == 0.2.*, vector >= 0.12 && < 0.13 GHC-options: -Wall
src/Data/Monoid/Instances/ByteString/UTF8.hs view
@@ -52,6 +52,8 @@ import qualified Data.ByteString.Char8 as ByteString.Char8 import Data.ByteString.Internal (w2c) import Data.ByteString.Unsafe (unsafeDrop, unsafeHead, unsafeTail, unsafeTake, unsafeIndex)+import Data.Text (pack, unpack)+import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..))@@ -384,6 +386,8 @@ | c < '\x80' = ByteString.Char8.elem c bs | otherwise = any (== c) utf8 {-# INLINE elem #-}+ fromText = ByteStringUTF8 . encodeUtf8+ toText f t@(ByteStringUTF8 bs) = either (const $ pack $ toString (unpack . f) t) id (decodeUtf8' bs) reverseBytesToChar :: (ByteString -> a) -> (Char -> a) -> [Word8] -> a reverseBytesToChar ft fc [w] = if w < 0x80 then fc (w2c w) else ft (ByteString.singleton w)
src/Data/Monoid/Instances/Concat.hs view
@@ -31,6 +31,7 @@ import qualified Data.Monoid.Textual as Textual import Data.Sequence (Seq) import qualified Data.Sequence as Seq+import qualified Data.Text as Text import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt, pi)@@ -223,6 +224,7 @@ characterPrefix (x :<> _) = characterPrefix x map f x = map f <$> x toString ft x = List.concatMap (toString $ ft . Leaf) (Foldable.toList x)+ toText ft x = Text.concat (toText (ft . Leaf) <$> Foldable.toList x) foldl ft fc = Foldable.foldl g where g = Textual.foldl (\a-> ft a . Leaf) fc
src/Data/Monoid/Instances/Measured.hs view
@@ -117,6 +117,7 @@ foldl' ft fc a0 (Measured _ x) = Textual.foldl' (\a-> ft a . Measured 1) fc a0 x foldr ft fc a0 (Measured _ x) = Textual.foldr (ft . Measured 1) fc a0 x toString ft (Measured _ x) = toString (ft . Measured 1) x+ toText ft (Measured _ x) = toText (ft . Measured 1) x span pt pc (Measured n x) = (xp', xs') where (xp, xs) = Textual.span (pt . Measured 1) pc x
src/Data/Monoid/Instances/Positioned.hs view
@@ -1,5 +1,5 @@ {-- Copyright 2014-2019 Mario Blazevic+ Copyright 2014-2021 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -}@@ -10,13 +10,13 @@ -- 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:+-- Line number is zero-based, column one-based: -- -- >> let p = pure "abcd\nefgh\nijkl\nmnop\n" :: LinePositioned String -- >> p--- >Line 0, column 0: "abcd\nefgh\nijkl\nmnop\n"+-- >"abcd\nefgh\nijkl\nmnop\n" -- >> Data.Monoid.Factorial.drop 13 p--- >Line 2, column 3: "l\nmnop\n"+-- >Line 2, column 4: "l\nmnop\n" {-# LANGUAGE Haskell2010 #-} @@ -73,7 +73,7 @@ OffsetPositioned _ f <*> OffsetPositioned p c = OffsetPositioned p (f c) instance Applicative LinePositioned where- pure = LinePositioned 0 0 0+ pure = LinePositioned 0 0 (-1) LinePositioned _ _ _ f <*> LinePositioned p l lp c = LinePositioned p l lp (f c) instance Positioned OffsetPositioned where@@ -97,9 +97,11 @@ compare LinePositioned{extractLines= a} LinePositioned{extractLines= b} = compare a b instance Show m => Show (OffsetPositioned m) where+ showsPrec prec (OffsetPositioned 0 c) = showsPrec prec c showsPrec prec (OffsetPositioned pos c) = shows pos . (": " ++) . showsPrec prec c instance Show m => Show (LinePositioned m) where+ showsPrec prec (LinePositioned 0 0 (-1) c) = showsPrec prec c showsPrec prec (LinePositioned pos l lpos c) = ("Line " ++) . shows l . (", column " ++) . shows (pos - lpos) . (": " ++) . showsPrec prec c @@ -120,11 +122,9 @@ | 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+ lp2' = p2' - (p2 - lp2 - cd + 1)+ l2' = if l2 == 0 then 0 else max 0 (l2 - ld)+ (ld, cd) = linesColumns' c1 {-# INLINE (<>) #-} instance (StableFactorial m, TextualMonoid m) => Monoid (LinePositioned m) where@@ -242,7 +242,7 @@ instance (StableFactorial m, FactorialMonoid m) => FactorialMonoid (OffsetPositioned m) where splitPrimePrefix (OffsetPositioned p c) = fmap rewrap (splitPrimePrefix c)- where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (succ p) cs)+ where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (if null cs then 0 else succ p) cs) splitPrimeSuffix (OffsetPositioned p c) = fmap rewrap (splitPrimeSuffix c) where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (p + length cp) cs) spanMaybe s0 f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe (s0, p0) f' t@@ -275,28 +275,46 @@ instance (StableFactorial m, TextualMonoid m) => Factorial (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)+ where next (p, l, lp) c1 = let p' = succ p+ in p' `seq` case characterPrefix c1+ of Just '\n' -> ((p', succ l, p), LinePositioned p l lp c1)+ Just '\f' -> ((p', succ l, p), LinePositioned p l lp c1)+ Just '\r' -> ((p', l, p), LinePositioned p l lp c1)+ Just '\t' -> ((p', l, lp + (p - lp) `mod` 8 - 8), LinePositioned p l lp c1)+ _ -> ((p', l, lp), LinePositioned p l lp c1) primePrefix (LinePositioned p l lp c) = LinePositioned p l lp (primePrefix c) 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)+ where f' (a, p, l, lp) c = case characterPrefix c+ of Just '\n' -> (f a (LinePositioned p l lp c), succ p, succ l, p)+ Just '\f' -> (f a (LinePositioned p l lp c), succ p, succ l, p)+ Just '\r' -> (f a (LinePositioned p l lp c), succ p, l, p)+ Just '\t' -> (f a (LinePositioned p l lp c), succ p, l, lp + (p - lp) `mod` 8 - 8)+ _ -> (f a (LinePositioned p l lp c), succ p, l, lp) foldl' f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl' f' (a0, p0, l0, lp0) c0 where f' (a, p, l, lp) c = let a' = f a (LinePositioned p l lp c)- in seq a' (if characterPrefix c == Just '\n'- then (a', succ p, succ l, p)- else (a', succ p, l, lp))+ in seq a' (case characterPrefix c+ of Just '\n' -> (a', succ p, succ l, p)+ Just '\f' -> (a', succ p, succ l, p)+ Just '\r' -> (a', succ p, l, p)+ Just '\t' -> (a', succ p, l, lp + (p - lp) `mod` 8 - 8)+ _ -> (a', succ p, l, lp)) foldr f a0 (LinePositioned p0 l0 lp0 c0) = Factorial.foldr f' (const3 a0) c0 p0 l0 lp0- where f' c cont p l lp- | characterPrefix c == Just '\n' = f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p- | otherwise = f (LinePositioned p l lp c) $ (cont $! succ p) l lp+ where f' c cont p l lp = case characterPrefix c+ of Just '\n' -> f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p+ Just '\f' -> f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p+ Just '\r' -> f (LinePositioned p l lp c) $ (cont $! succ p) l p+ Just '\t' -> f (LinePositioned p l lp c) $ (cont $! succ p) l $! lp + (p - lp) `mod` 8 - 8+ _ -> f (LinePositioned p l lp c) $ (cont $! succ 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)+ `mappend`+ case characterPrefix prime+ of Just '\n' -> cont (succ p) (succ l) p+ Just '\f' -> cont (succ p) (succ l) p+ Just '\r' -> cont (succ p) l p+ Just '\t' -> cont (succ p) l (lp + (p - lp) `mod` 8 - 8)+ _ -> cont (succ p) l lp) length = length . extractLines reverse (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.reverse c) {-# INLINE primePrefix #-}@@ -310,9 +328,14 @@ instance (StableFactorial m, TextualMonoid m) => FactorialMonoid (LinePositioned m) where 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)+ if null cs then mempty+ else case characterPrefix cp+ of Just '\n' -> LinePositioned p' (succ l) p cs+ Just '\f' -> LinePositioned p' (succ l) p cs+ Just '\r' -> LinePositioned p' l p cs+ Just '\t' -> LinePositioned p' l (lp + (p - lp) `mod` 8 - 8) cs+ _ -> LinePositioned p' l lp cs)+ p' = succ p 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@@ -322,26 +345,35 @@ 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)+ Just $! p' `seq` case characterPrefix prime+ of Just '\n' -> l' `seq` (s', p', l', p)+ Just '\f' -> l' `seq` (s', p', l', p)+ Just '\r' -> (s', p', l, p)+ Just '\t' -> (s', p', l, lp + (p - lp) `mod` 8 - 8)+ _ -> (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)+ Just $! s' `seq` p' `seq` case characterPrefix prime+ of Just '\n' -> l' `seq` (s', p', l', p)+ Just '\f' -> l' `seq` (s', p', l', p)+ Just '\r' -> (s', p', l, p)+ Just '\t' -> (s', p', l, lp + (p - lp) `mod` 8 - 8)+ _ -> (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)+ in Just $! p' `seq` case characterPrefix prime+ of Just '\n' -> l' `seq` (p', l', p)+ Just '\f' -> l' `seq` (p', l', p)+ Just '\r' -> (p', l, p)+ Just '\t' -> (p', l, lp + (p - lp) `mod` 8 - 8)+ _ -> (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)@@ -369,7 +401,8 @@ fromString = pure . fromString instance (StableFactorial m, TextualMonoid m) => TextualMonoid (OffsetPositioned m) where- splitCharacterPrefix (OffsetPositioned p c) = fmap (fmap $ OffsetPositioned $ succ p) (splitCharacterPrefix c)+ splitCharacterPrefix (OffsetPositioned p t) = fmap rewrap (splitCharacterPrefix t)+ where rewrap (c, cs) = if null cs then (c, mempty) else (c, OffsetPositioned (succ p) cs) fromText = pure . fromText singleton = pure . singleton@@ -448,6 +481,8 @@ 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)+ toString ft (OffsetPositioned _ t) = toString (ft . pure) t+ toText ft (OffsetPositioned _ t) = toText (ft . pure) t {-# INLINE characterPrefix #-} {-# INLINE splitCharacterPrefix #-}@@ -470,11 +505,16 @@ {-# INLINE find #-} instance (StableFactorial m, TextualMonoid m) => TextualMonoid (LinePositioned m) where- splitCharacterPrefix (LinePositioned p l lp c) =- case splitCharacterPrefix c+ splitCharacterPrefix (LinePositioned p l lp t) =+ case splitCharacterPrefix t 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)+ Just (c, rest) | null rest -> Just (c, mempty)+ Just ('\n', rest) -> Just ('\n', LinePositioned p' (succ l) p rest)+ Just ('\f', rest) -> Just ('\f', LinePositioned p' (succ l) p rest)+ Just ('\r', rest) -> Just ('\r', LinePositioned p' l p rest)+ Just ('\t', rest) -> Just ('\t', LinePositioned p' l (lp + (p - lp) `mod` 8 - 8) rest)+ Just (ch, rest) -> Just (ch, LinePositioned p' l lp rest)+ where p' = succ p fromText = pure . fromText singleton = pure . singleton@@ -489,6 +529,9 @@ 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) '\f' = (fc a '\f', succ p, succ l, p)+ fc' (a, p, l, _lp) '\r' = (fc a '\r', succ p, l, p)+ fc' (a, p, l, lp) '\t' = (fc a '\t', succ p, l, lp + (p - lp) `mod` 8 - 8) fc' (a, p, l, lp) c = (fc a c, succ p, l, lp) foldl' ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl' ft' fc' (a0, p0, l0, lp0) c0 where ft' (a, p, l, lp) c = let a' = ft a (LinePositioned p l lp c)@@ -497,13 +540,19 @@ fc' (a, p, l, lp) c = let a' = fc a c p' = succ p l' = succ l- in a' `seq` p' `seq` if c == '\n'- then l' `seq` (a', p', l', p)- else (a', p', l, lp)+ in a' `seq` p' `seq` case c+ of '\n' -> l' `seq` (a', p', l', p)+ '\f' -> l' `seq` (a', p', l', p)+ '\r' -> (a', p', l, p)+ '\t' -> (a', p', l, lp + (p - lp) `mod` 8 - 8)+ _ -> (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+ | c == '\f' = fc c $ ((cont $! succ p) $! succ l) p+ | c == '\r' = fc c $ (cont $! succ p) l p+ | c == '\t' = fc c $ (cont $! succ p) l (lp + (p - lp) `mod` 8 - 8) | 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@@ -511,7 +560,10 @@ 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))+ >>= \s'-> Just $! seq p' (if c == '\n' || c == '\f' then seq l' (s', p', l', p)+ else if c == '\r' then (s', p', l, p)+ else if c == '\t' then (s', p', l, lp + (p - lp) `mod` 8 - 8)+ 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)@@ -522,14 +574,21 @@ 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))+ Just $! s' `seq` p' `seq` (if c == '\n' || c == '\f' then seq l' (s', p', l', p)+ else if c == '\r' then (s', p', l, p)+ else if c == '\t' then (s', p', l, lp + (p - lp) `mod` 8 - 8)+ 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))+ fc' (p, l, lp) c | fc c = Just $! seq p'+ $ if c == '\n' || c == '\f' then seq l' (p', l', p)+ else if c == '\r' then (p', l, p)+ else if c == '\t' then (p', l, lp + (p - lp) `mod` 8 - 8)+ else (p', l, lp) | otherwise = Nothing where p' = succ p l' = succ l@@ -575,6 +634,8 @@ 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)+ toString ft lpt = toString (ft . pure) (extractLines lpt)+ toText ft lpt = toText (ft . pure) (extractLines lpt) {-# INLINE characterPrefix #-} {-# INLINE splitCharacterPrefix #-}@@ -597,12 +658,18 @@ {-# INLINE takeWhile_ #-} linesColumns :: TextualMonoid m => m -> (Int, Int)-linesColumns t = Textual.foldl (const . fmap succ) fc (0, 0) t- where fc (l, _) '\n' = (succ l, 0)+linesColumns t = Textual.foldl (const . fmap succ) fc (0, 1) t+ where fc (l, _) '\n' = (succ l, 1)+ fc (l, _) '\f' = (succ l, 1)+ fc (l, _) '\r' = (l, 1)+ fc (l, c) '\t' = (l, c + 9 - c `mod` 8) 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)+linesColumns' t = Textual.foldl' (const . fmap succ) fc (0, 1) t+ where fc (l, _) '\n' = let l' = succ l in seq l' (l', 1)+ fc (l, _) '\f' = let l' = succ l in seq l' (l', 1)+ fc (l, _) '\r' = (l, 1)+ fc (l, c) '\t' = (l, c + 9 - c `mod` 8) fc (l, c) _ = let c' = succ c in seq c' (l, c') {-# INLINE linesColumns #-} {-# INLINE linesColumns' #-}
src/Data/Monoid/Textual.hs view
@@ -80,6 +80,7 @@ -- > takeWhile (const True) (const True) -- > dropWhile (const False) (const False) -- > toString undefined . fromString+-- > toText undefined . fromText class (IsString t, LeftReductive t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where -- | Contructs a new data type instance Like 'fromString', but from a 'Text' input instead of 'String'.@@ -108,6 +109,8 @@ -- | Returns the list of characters the monoid contains, once the argument function converts all its non-character -- factors into characters. toString :: (t -> String) -> t -> String+ -- | Converts the monoid into 'Text', given a function to convert the non-character factors into chunks of 'Text'.+ toText :: (t -> Text) -> t -> Text -- | Equivalent to 'List.any' from "Data.List". Ignores all non-character data. any :: (Char -> Bool) -> t -> Bool -- | Equivalent to 'List.all' from "Data.List". Ignores all non-character data.@@ -190,6 +193,7 @@ map f = concatMap (singleton . f) concatMap f = foldr mappend (mappend . f) mempty toString f = foldr (mappend . f) (:) []+ toText f = Text.pack . toString (Text.unpack . f) all p = foldr (const id) ((&&) . p) True any p = foldr (const id) ((||) . p) False @@ -362,6 +366,7 @@ map = Text.map concatMap = Text.concatMap toString = const Text.unpack+ toText = const id any = Text.any all = Text.all @@ -425,6 +430,7 @@ map = LazyText.map concatMap = LazyText.concatMap toString = const LazyText.unpack+ toText = const LazyText.toStrict any = LazyText.any all = LazyText.all
src/Data/Semigroup/Factorial.hs view
@@ -420,7 +420,7 @@ -- | A 'Monad.mapM' equivalent. mapM :: (Factorial a, Monoid b, Monad m) => (a -> m b) -> a -> m b-mapM f = ($ return mempty) . appEndo . Data.Semigroup.Factorial.foldMap (Endo . Monad.liftM2 (<>) . f)+mapM f = ($ return mempty) . appEndo . Data.Semigroup.Factorial.foldMap (Endo . Monad.liftM2 mappend . f) -- | A 'Monad.mapM_' equivalent. mapM_ :: (Factorial a, Applicative m) => (a -> m b) -> a -> m ()