packages feed

infinite-list 0.1.2 → 0.1.3

raw patch · 7 files changed

+136/−83 lines, 7 filesdep −tasty-benchdep ~base

Dependencies removed: tasty-bench

Dependency ranges changed: base

Files

CHANGELOG.md view
@@ -1,3 +1,9 @@+# 0.1.3++* Add `mapAccumL'`.+* Make `scanl'` stricter by forcing the initial element.+  Cf. https://github.com/haskell/core-libraries-committee/issues/335+ # 0.1.2  * Add `heteroZip` and `heteroZipWith`.
− bench/Bench.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE PostfixOperators #-}--module Main where---- import qualified Data.List.Infinite as Inf-import Test.Tasty.Bench--main :: IO ()-main = defaultMain-  [-  ]
infinite-list.cabal view
@@ -1,14 +1,14 @@ cabal-version:   2.2 name:            infinite-list-version:         0.1.2+version:         0.1.3 license:         BSD-3-Clause license-file:    LICENSE maintainer:      andrew.lelechenko@gmail.com author:          Bodigrim tested-with:     ghc ==8.2.2 ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.4-    ghc ==8.10.7 ghc ==9.0.2 ghc ==9.2.8 ghc ==9.4.8 ghc ==9.6.5-    ghc ==9.8.4 ghc ==9.10.1 ghc ==9.12.1+    ghc ==8.10.7 ghc ==9.0.2 ghc ==9.2.8 ghc ==9.4.8 ghc ==9.6.7+    ghc ==9.8.4 ghc ==9.10.3 ghc ==9.12.2 ghc ==9.14.1  homepage:        https://github.com/Bodigrim/infinite-list synopsis:        Infinite lists@@ -94,17 +94,3 @@      if impl(ghc <9.2)         buildable: False--benchmark infinite-bench-    type:             exitcode-stdio-1.0-    main-is:          Bench.hs-    hs-source-dirs:   bench-    default-language: Haskell2010-    ghc-options:      -Wall-    build-depends:-        base,-        infinite-list,-        tasty-bench--    if impl(ghc >=8.6)-        ghc-options: -fproc-alignment=64
src/Data/List/Infinite.hs view
@@ -45,6 +45,7 @@   scanl',   scanl1,   mapAccumL,+  mapAccumL',   traverse_,   for_, @@ -178,7 +179,7 @@ import GHC.Exts (oneShot) import qualified GHC.Exts import Numeric.Natural (Natural)-import Prelude (Bool (..), Enum, Int, Integer, Integral, Maybe (..), Traversable, Word, const, enumFrom, enumFromThen, flip, fromIntegral, id, maxBound, minBound, not, otherwise, snd, uncurry, (&&), (+), (-), (.), (||))+import Prelude (Bool (..), Enum, Int, Integer, Integral, Maybe (..), Traversable, Word, const, enumFrom, enumFromThen, flip, fromIntegral, id, maxBound, minBound, not, otherwise, seq, snd, uncurry, (&&), (+), (-), (.), (||))  import Data.List.Infinite.Internal import qualified Data.List.Infinite.Set as Set@@ -371,23 +372,24 @@ -- | @since 0.1.2 instance MonadFix Infinite where   mfix f = map (\(!n) -> fix $ head . genericDrop n . f) ((...) (0 :: Natural))-  -- To put it simply, mfix f !! n = fix ((!! n) . f)-  ---  -- How to derive it? As in Section 1.4 of Erkok's thesis,-  -- we can start by putting mfix f = fix (>>= f).-  ---  -- mfix f !! n-  -- = fix (>>= f) !! n-  -- = [by definition of fix, fix g = g (fix g)]-  -- = (fix (>>= f) >>= f) !! n-  -- = [by the choice of >>= above, (xs >>= g) !! n = g (xs !! n) !! n]-  -- = f (fix (>>= f) !! n) !! n-  -- = ((!! n) . f) (fix (>>= f) !! n)-  -- = [restoring mfix from fix]-  -- = ((!! n) . f) (mfix f !! n)-  ---  -- Then mfix f !! n = fix ((!! n) . f). +-- To put it simply, mfix f !! n = fix ((!! n) . f)+--+-- How to derive it? As in Section 1.4 of Erkok's thesis,+-- we can start by putting mfix f = fix (>>= f).+--+-- mfix f !! n+-- = fix (>>= f) !! n+-- = [by definition of fix, fix g = g (fix g)]+-- = (fix (>>= f) >>= f) !! n+-- = [by the choice of >>= above, (xs >>= g) !! n = g (xs !! n) !! n]+-- = f (fix (>>= f) !! n) !! n+-- = ((!! n) . f) (fix (>>= f) !! n)+-- = [restoring mfix from fix]+-- = ((!! n) . f) (mfix f !! n)+--+-- Then mfix f !! n = fix ((!! n) . f).+ -- | Get the first elements of an infinite list. head :: Infinite a -> a head (x :< _) = x@@ -567,7 +569,7 @@  -- | Same as 'Data.List.Infinite.scanl', but strict in accumulator. scanl' :: (b -> a -> b) -> b -> Infinite a -> Infinite b-scanl' f z0 = (z0 :<) . flip (foldr (\x acc z -> let !fzx = f z x in fzx :< acc fzx)) z0+scanl' f !z0 = (z0 :<) . flip (foldr (\x acc z -> let !fzx = f z x in fzx :< acc fzx)) z0  scanlFB' :: (elt' -> elt -> elt') -> (elt' -> lst -> lst) -> elt -> (elt' -> lst) -> elt' -> lst scanlFB' f cons = \elt g -> oneShot (\x -> let !elt' = f x elt in elt' `cons` g elt')@@ -579,7 +581,7 @@ {-# RULES "scanl'" [~1] forall f a bs.   scanl' f a bs =-    build (\cons -> a `cons` foldr (scanlFB' f cons) bs a)+    build (\cons -> a `seq` a `cons` foldr (scanlFB' f cons) bs a) "scanlList'" [1] forall f (a :: a) bs.   foldr (scanlFB' f (:<)) bs a =     tail (scanl' f a bs)@@ -619,6 +621,26 @@ "mapAccumLList" [1] forall f s xs.   foldr (mapAccumLFB f) xs s =     mapAccumL f s xs+  #-}++-- | Same as 'mapAccumL', but strict in accumulator.+mapAccumL' :: (acc -> x -> (acc, y)) -> acc -> Infinite x -> Infinite y+mapAccumL' f = flip (foldr (\x acc !s -> let (s', y) = f s x in y :< acc s'))++mapAccumL'FB :: (acc -> x -> (acc, y)) -> x -> (acc -> Infinite y) -> acc -> Infinite y+mapAccumL'FB f = \x r -> oneShot (\(!s) -> let (s', y) = f s x in y :< r s')++{-# NOINLINE [1] mapAccumL' #-}++{-# INLINE [0] mapAccumL'FB #-}++{-# RULES+"mapAccumL'" [~1] forall f s xs.+  mapAccumL' f s xs =+    foldr (mapAccumL'FB f) xs s+"mapAccumL'List" [1] forall f s xs.+  foldr (mapAccumL'FB f) xs s =+    mapAccumL' f s xs   #-}  -- | Generate an infinite list of repeated applications.
src/Data/List/Infinite/Set.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-}  -- |@@ -10,12 +11,11 @@   insert, ) where -data Color = Red | Black-  deriving (Show)- -- | Okasaki red-black tree.-data Set a = Empty | Node !Color !(Set a) !a !(Set a)-  deriving (Show)+data Set a+  = Empty+  | Red !(Set a) !a !(Set a)+  | Black !(Set a) !a !(Set a)  empty :: Set a empty = Empty@@ -23,39 +23,55 @@ member :: (a -> a -> Ordering) -> a -> Set a -> Bool member cmp = member'   where-    member' x = go+    member' !x = go       where         go = \case           Empty -> False-          Node _ left center right -> case cmp x center of-            LT -> go left-            EQ -> True-            GT -> go right+          Red left center right -> whereToGo left center right+          Black left center right -> whereToGo left center right +        whereToGo left center right = case x `cmp` center of+          LT -> go left+          EQ -> True+          GT -> go right+{-# INLINE member #-}+ insert :: (a -> a -> Ordering) -> a -> Set a -> Set a insert cmp = insert'   where-    insert' x = blacken . go+    insert' !x = blacken . go       where-        go = \case-          Empty -> Node Red Empty x Empty-          Node color left center right -> case cmp x center of-            LT -> balance color (go left) center right-            EQ -> Node color left center right-            GT -> balance color left center (go right)+        go node = case node of+          Empty -> Red Empty x Empty+          Red left center right -> case x `cmp` center of+            LT -> Red (go left) center right+            EQ -> node+            GT -> Red left center (go right)+          Black left center right -> case x `cmp` center of+            LT -> balanceLeft (go left) center right+            EQ -> node+            GT -> balanceRight left center (go right) -    blacken = \case+    blacken node = case node of       Empty -> Empty-      Node _ left center right -> Node Black left center right+      Red left center right -> Black left center right+      Black {} -> node+{-# INLINE insert #-} -balance :: Color -> Set a -> a -> Set a -> Set a-balance Black (Node Red (Node Red a b c) d e) f g =-  Node Red (Node Black a b c) d (Node Black e f g)-balance Black (Node Red a b (Node Red c d e)) f g =-  Node Red (Node Black a b c) d (Node Black e f g)-balance Black a b (Node Red (Node Red c d e) f g) =-  Node Red (Node Black a b c) d (Node Black e f g)-balance Black a b (Node Red c d (Node Red e f g)) =-  Node Red (Node Black a b c) d (Node Black e f g)-balance color left center right =-  Node color left center right+balanceLeft :: Set a -> a -> Set a -> Set a+balanceLeft (Red (Red a b c) d e) f g =+  Red (Black a b c) d (Black e f g)+balanceLeft (Red a b (Red c d e)) f g =+  Red (Black a b c) d (Black e f g)+balanceLeft left center right =+  Black left center right+{-# INLINE balanceLeft #-}++balanceRight :: Set a -> a -> Set a -> Set a+balanceRight a b (Red (Red c d e) f g) =+  Red (Black a b c) d (Black e f g)+balanceRight a b (Red c d (Red e f g)) =+  Red (Black a b c) d (Black e f g)+balanceRight left center right =+  Black left center right+{-# INLINE balanceRight #-}
test/Fusion.hs view
@@ -84,11 +84,13 @@ mapAccumLRepeat n =   I.mapAccumL (\acc x -> (acc, fromIntegral x)) 'q' (I.repeat (fromIntegral n :: Word)) +mapAccumLRepeat' :: Int -> Infinite Int+mapAccumLRepeat' n =+  I.mapAccumL' (\acc x -> (acc, fromIntegral x)) 'q' (I.repeat (fromIntegral n :: Word))  takeFilterIterate :: [Int] takeFilterIterate = I.take 100 $ I.filter odd $ I.iterate (+ 1) 0 - sumTakeFilterIterate :: Int sumTakeFilterIterate = sum $ I.take 100 $ I.filter odd $ I.iterate (+ 1) 0 @@ -259,6 +261,7 @@   , $(inspectTest $ 'foldrCycle `hasNoType` ''Infinite)   , $(inspectTest $ 'foldrWordsCycle `hasNoType` ''NonEmpty)   , $(inspectTest $ 'mapAccumLRepeat `hasNoType` ''Word)+  , $(inspectTest $ 'mapAccumLRepeat' `hasNoType` ''Word)    , $(inspectTest $ 'takeFilterIterate `hasNoType` ''Infinite)   , $(inspectTest $ 'sumTakeFilterIterate `hasNoTypes` [''Infinite, ''[]])
test/Properties.hs view
@@ -2,6 +2,7 @@ -- Copyright:   (c) 2022 Bodigrim -- Licence:     BSD3 +{-# LANGUAGE CPP                 #-} {-# LANGUAGE PostfixOperators    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-}@@ -23,6 +24,7 @@ import Test.Tasty.QuickCheck as QC  import Control.Applicative+import Control.Exception import Control.Monad import Control.Monad.Fix (mfix) import Data.Bifunctor@@ -44,8 +46,10 @@   arbitrary = (:<) <$> arbitrary <*> arbitrary   shrink = const [] +#if !MIN_VERSION_QuickCheck(2,17,0) instance Arbitrary a => Arbitrary (NonEmpty a) where   arbitrary = (:|) <$> arbitrary <*> arbitrary+#endif  trim :: Infinite a -> [a] trim = I.take 10@@ -214,18 +218,29 @@   , testProperty "scanl" $     \(curry . applyFun -> (f :: Word -> Int -> Word)) s (Blind xs) ->       trim1 (I.scanl f s xs) === L.scanl f s (trim xs)-  , testProperty "scanl laziness" $ once $+  , testProperty "scanl laziness 1" $ once $     I.head (I.scanl undefined 'q' undefined) === 'q'+  , testProperty "scanl laziness 2" $ once $+    I.head (I.tail (I.scanl (const (const 'q')) undefined (I.repeat 'z'))) === 'q'+   , testProperty "scanl'" $     \(curry . applyFun -> (f :: Word -> Int -> Word)) s (Blind xs) ->       trim1 (I.scanl' f s xs) === L.scanl' f s (trim xs)-  , testProperty "scanl' laziness" $ once $+  , testProperty "scanl' laziness 1" $ once $     I.head (I.scanl' undefined 'q' undefined) === 'q'+  , testProperty "scanl' laziness 2" $ once $ ioProperty $ do+    x <- try $ evaluate $ I.scanl' (const (const 'q')) undefined (I.repeat 'z')+    pure $ case x of+      Left (_ :: SomeException) -> True+      _ -> False+   , testProperty "scanl1" $     \(curry . applyFun -> (f :: Int -> Int -> Int)) (Blind xs) ->       trim (I.scanl1 f xs) === L.scanl1 f (trim xs)-  , testProperty "scanl1 laziness" $ once $+  , testProperty "scanl1 laziness 1" $ once $     I.head (I.scanl1 undefined ('q' :< undefined)) === 'q'+  , testProperty "scanl1 laziness 2" $ once $+    I.head (I.tail (I.scanl1 (const (const 'q')) (undefined :< I.repeat 'z'))) === 'q'    , testProperty "mapAccumL" $     \(curry . applyFun -> (f :: Bool -> Int -> (Bool, Word))) (Blind xs) ->@@ -233,16 +248,32 @@   , testProperty "mapAccumL laziness" $ once $     I.head (I.mapAccumL (\_ x -> (undefined, x)) undefined ('q' :< undefined)) === 'q' +  , testProperty "mapAccumL'" $+    \(curry . applyFun -> (f :: Bool -> Int -> (Bool, Word))) (Blind xs) ->+      trim (I.mapAccumL' f False xs) === snd (L.mapAccumL f False (trim xs))+   , testProperty "iterate" $     \(applyFun -> (f :: Int -> Int)) s ->       trim (I.iterate f s) === L.take 10 (L.iterate f s)-  , testProperty "iterate laziness" $ once $+  , testProperty "iterate laziness 1" $ once $       I.head (I.iterate undefined 'q') === 'q'+  , testProperty "iterate laziness 2" $ once $+      I.head  (I.tail (I.iterate (\c -> if c == 'r' then undefined else 'r') 'q')) === 'r'+  , testProperty "iterate laziness 3" $ once $+    I.iterate (const 'q') undefined `seq` () === ()+   , testProperty "iterate'" $     \(applyFun -> (f :: Int -> Int)) s ->       trim (I.iterate' f s) === L.take 10 (L.iterate f s)-  , testProperty "iterate' laziness" $ once $+  , testProperty "iterate' laziness 1" $ once $       I.head (I.iterate' undefined 'q') === 'q'+  , testProperty "iterate' laziness 2" $ once $+      I.head  (I.tail (I.iterate' (\c -> if c == 'r' then undefined else 'r') 'q')) === 'r'+  , testProperty "iterate' laziness 3" $ once $ ioProperty $ do+    xs <- try $ evaluate $ I.iterate' (const 'q') undefined+    pure $ case xs of+      Left (_ :: SomeException) -> True+      _ -> False    , testProperty "repeat" $     \(s :: Int) ->