diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Bodigrim + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Bodigrim nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,66 @@ +# infinite-list + +Modern lightweight library for infinite lists with fusion: + +* API similar to `Data.List`. +* No non-boot dependencies. +* Top performance, driven by fusion. +* Avoid dangerous instances like `Foldable`. +* Use `NonEmpty` where applicable. +* Use `Word` for indices. +* Be lazy, but not too lazy. + +```haskell +{-# LANGUAGE PostfixOperators #-} +import Data.List.Infinite (Infinite(..), (...), (....)) +import qualified Data.List.Infinite as Inf +``` + +## Prior art and inspiration + +* [`Data.Stream.Infinite`](https://hackage.haskell.org/package/streams/docs/Data-Stream-Infinite.html) from [`streams`](https://hackage.haskell.org/package/streams) package: + * Large dependency footprint, e. g., `adjunctions`. + * Provides dangerous instances such as `Foldable`. + * No fusion framework. + +* [`Data.Stream`](https://hackage.haskell.org/package/Stream/docs/Data-Stream.html) from [`Stream`](https://hackage.haskell.org/package/Stream) package: + * No fusion framework. + * No repository or issue tracker. + +* [`GHC.Data.List.Infinite`](https://gitlab.haskell.org/ghc/ghc/-/blob/080fffa1015bcc0cff8ab4ad1eeb507fb7a13383/compiler/GHC/Data/List/Infinite.hs) in GHC source tree: + * Limited API, only to cater for GHC internals. + * Not available as a separate package outside of GHC. + +## Why no `Foldable` or `Traversable`? + +The breakdown of members of `Foldable` is as follows: + +* `foldr`, `foldr1`, `foldMap`, `fold`, `toList` and `null` can be productive on infinite lists; +* `foldr'`, `foldMap'` cannot, because forcing an accumulator even to a WHNF makes fold non-terminating; +* `foldl`, `foldl'`, `foldl1` cannot, because no left fold can; +* `length` always diverges; +* `elem` either returns `True`, or does not terminate, but never returns `False`; +* `maximum`, `minimum`, `sum` and `product` are unlikely to be productive, unless an underlying `instance Ord` or `instance Num` is extremely lazy. + +Altogether it means that code, polymorphic by `Foldable`, cannot confidently work with infinite lists. Even a trivial refactoring can get you in a deep trouble. It's better to save users from this pitfall and do not provide `instance Foldable` at all. We do provide a right fold however. + +Since there is no `Foldable`, there could be no `Traversable`. Even if it was not prohibited because of a missing superclass, there are only a few monads, which are lazy enough to be productive for infinite traversals. If you are looking for a traverse with a lazy state, use `mapAccumL`. + +## Laziness + +Operations, returning a data type with a single constructor, can be implemented in an extremely lazy fashion. Namely, always return the constructor before inspecting any of the arguments. For instance, note the irrefutable pattern matching in `Data.List.NonEmpty`: + +```haskell +map :: (a -> b) -> NonEmpty a -> NonEmpty b +map f ~(a :| as) = f a :| fmap f as +``` + +Because of it forcing the result to WHNF does not force any of the arguments, e. g., ``Data.List.NonEmpty.map undefined undefined `seq` 1`` returns `1`. This is not the case for normal lists: since there are two constructors, `map` has to inspect the argument before returning anything, and ``Data.List.map undefined undefined `seq` 1`` throws an error. + +While `Data.List.Infinite` has a single constructor, we believe that following the example of `Data.List.NonEmpty` is harmful for the majority of applications. Instead the laziness of the API is modeled on the laziness of respective operations on `Data.List`: a function `Data.List.Infinite.foo` operating over `Infinite a` is expected to have the same strictness properties as `Data.List.foo` operating over `[a]`. For instance, ``Data.List.Infinite.map undefined undefined `seq` 1`` diverges. + +## Indexing + +Most of historical APIs (such as `Data.List`) use `Int` to index elements of containers. This library makes another choice: namely, indices are represented by an unsigned type, `Word`. This way the notorious partial function `(!!) :: [a] -> Int -> a` becomes a total `(!!) :: Infinite a -> Word -> a`. + +An argument can be made to use an arbitrary-precision type `Natural` instead of finite `Word`. Unfortunately, this causes performance penalties since `Natural` is represented by a heap object and cannot be easily unboxed. On any GHC-supported architecture the addressable memory is less than `maxBound :: Word` bytes and thus it's impossible to materialize a container with more than `maxBound :: Word` elements. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PostfixOperators #-} + +module Main where + +-- import qualified Data.List.Infinite as Inf +import Test.Tasty.Bench + +main :: IO () +main = defaultMain + [ + ] diff --git a/infinite-list.cabal b/infinite-list.cabal new file mode 100644 --- /dev/null +++ b/infinite-list.cabal @@ -0,0 +1,93 @@ +cabal-version: 1.18 +name: infinite-list +version: 0.1 +license: BSD3 +license-file: LICENSE +maintainer: andrew.lelechenko@gmail.com +author: Bodigrim +tested-with: + ghc ==8.0.2 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.5 ghc ==9.4.3 + +homepage: https://github.com/Bodigrim/infinite-list +synopsis: Infinite lists +description: + Modern lightweight library for infinite lists with fusion: + . + * API similar to "Data.List". + * No non-boot dependencies. + * Top performance, driven by fusion. + * Avoid dangerous instances like `Foldable`. + * Use `NonEmpty` where applicable. + * Use `Word` for indices. + * Be lazy, but not too lazy. + . + @ + {\-# LANGUAGE PostfixOperators #-\} + import Data.List.Infinite (Infinite(..), (...), (....)) + import qualified Data.List.Infinite as Inf + @ + +category: Data +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/Bodigrim/infinite-list + +library + exposed-modules: Data.List.Infinite + hs-source-dirs: src + other-modules: + Data.List.Infinite.Zip + Data.List.Infinite.Internal + + default-language: Haskell2010 + ghc-options: -Wall + build-depends: base >=4.9 && <5 + + if impl(ghc <8.2) + build-depends: ghc-prim + +test-suite infinite-properties + type: exitcode-stdio-1.0 + main-is: Properties.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base, + infinite-list, + QuickCheck, + tasty, + tasty-quickcheck + +test-suite infinite-fusion + type: exitcode-stdio-1.0 + main-is: Fusion.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base, + infinite-list, + tasty, + tasty-inspection-testing, + tasty-expected-failure + + 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 diff --git a/src/Data/List/Infinite.hs b/src/Data/List/Infinite.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Infinite.hs @@ -0,0 +1,1099 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant lambda" #-} + +-- | +-- Copyright: (c) 2022 Bodigrim +-- License: BSD3 +-- +-- Modern lightweight library for infinite lists with fusion: +-- +-- * API similar to "Data.List". +-- * No non-boot dependencies. +-- * Top performance, driven by fusion. +-- * Avoid dangerous instances like `Data.Foldable.Foldable`. +-- * Use `NonEmpty` where applicable. +-- * Use `Word` for indices. +-- * Be lazy, but not too lazy. +-- +-- @ +-- {\-# LANGUAGE PostfixOperators #-\} +-- import Data.List.Infinite (Infinite(..), (...), (....)) +-- import qualified Data.List.Infinite as Inf +-- @ +module Data.List.Infinite ( + -- * Construction + Infinite (..), + + -- * Elimination + head, + tail, + uncons, + toList, + foldr, + + -- * Traversals + map, + scanl, + scanl', + scanl1, + mapAccumL, + + -- * Transformations + concat, + concatMap, + intersperse, + intercalate, + interleave, + transpose, + subsequences, + subsequences1, + permutations, + + -- * Building + (...), + (....), + iterate, + iterate', + unfoldr, + tabulate, + repeat, + cycle, + + -- * Sublists + prependList, + take, + drop, + splitAt, + takeWhile, + dropWhile, + span, + break, + group, + inits, + inits1, + tails, + isPrefixOf, + stripPrefix, + + -- * Searching + lookup, + find, + filter, + partition, + + -- * Indexing + (!!), + elemIndex, + elemIndices, + findIndex, + findIndices, + + -- * Zipping + zip, + zipWith, + zip3, + zipWith3, + zip4, + zipWith4, + zip5, + zipWith5, + zip6, + zipWith6, + zip7, + zipWith7, + unzip, + unzip3, + unzip4, + unzip5, + unzip6, + unzip7, + + -- * Functions on strings + lines, + words, + unlines, + unwords, + + -- * Set operations + nub, + delete, + (\\), + union, + intersect, + + -- * Ordered lists + insert, + + -- * Generalized functions + nubBy, + deleteBy, + deleteFirstsBy, + unionBy, + intersectBy, + groupBy, + insertBy, + genericTake, + genericDrop, + genericSplitAt, +) where + +import Control.Applicative (Applicative (..)) +import Control.Arrow (first, second) +import Control.Monad (Monad (..)) +import Data.Bits ((.&.)) +import Data.Char (Char, isSpace) +import Data.Coerce (coerce) +import Data.Eq (Eq, (/=), (==)) +import qualified Data.Foldable as F +import Data.Functor (Functor (..)) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Ord (Ord, Ordering (..), compare, (<), (<=), (>), (>=)) +import qualified GHC.Exts +import Numeric.Natural (Natural) +import Prelude (Bool (..), Enum, Int, Integer, Integral, Maybe (..), Word, const, enumFrom, enumFromThen, flip, id, maxBound, minBound, not, otherwise, snd, uncurry, (&&), (+), (-), (.), (||)) + +#if MIN_VERSION_base(4,10,0) +import GHC.Exts (oneShot) +#else +import GHC.Magic (oneShot) +#endif + +import Data.List.Infinite.Internal +import Data.List.Infinite.Zip + +-- | Right-associative fold of an infinite list, necessarily lazy in the accumulator. +-- Any unconditional attempt to force the accumulator even to WHNF +-- will hang the computation. E. g., the following definition isn't productive: +-- +-- > import Data.List.NonEmpty (NonEmpty(..)) +-- > toNonEmpty = foldr (\a (x :| xs) -> a :| x : xs) :: Infinite a -> NonEmpty a +-- +-- One should use lazy patterns, e. g., +-- +-- > toNonEmpty = foldr (\a ~(x :| xs) -> a :| x : xs) +foldr :: (a -> b -> b) -> Infinite a -> b +foldr f = go + where + go (x :< xs) = f x (go xs) +{-# INLINE [0] foldr #-} + +{-# RULES +"foldr/build" forall cons (g :: forall b. (a -> b -> b) -> b). + foldr cons (build g) = + g cons +"foldr/cons/build" forall cons x (g :: forall b. (a -> b -> b) -> b). + foldr cons (x :< build g) = + cons x (g cons) + #-} + +-- | Convert to a list. Use 'cycle' to go in another direction. +toList :: Infinite a -> [a] +toList = foldr (:) +{-# NOINLINE [0] toList #-} + +{-# RULES +"toList" [~1] forall xs. + toList xs = + GHC.Exts.build (\cons -> const (foldr cons xs)) + #-} + +-- | Generate infinite sequences, starting from a given element, +-- similar to @[x..]@. +-- For better user experience consider enabling @{\-# LANGUAGE PostfixOperators #-\}@: +-- +-- >>> :set -XPostfixOperators +-- >>> Data.List.Infinite.take 10 (0...) +-- [0,1,2,3,4,5,6,7,8,9] +-- +-- Beware that for finite types '(...)' applies 'cycle' atop of @[x..]@: +-- +-- >>> :set -XPostfixOperators +-- >>> Data.List.Infinite.take 10 (EQ...) +-- [EQ,GT,EQ,GT,EQ,GT,EQ,GT,EQ,GT] +(...) :: Enum a => a -> Infinite a +(...) = unsafeCycle . enumFrom +{-# INLINE [0] (...) #-} + +{-# RULES +"ellipsis3Int" (...) = ellipsis3Int +"ellipsis3Word" (...) = ellipsis3Word +"ellipsis3Integer" (...) = ellipsis3Integer +"ellipsis3Natural" (...) = ellipsis3Natural + #-} + +ellipsis3Int :: Int -> Infinite Int +ellipsis3Int from = iterate' (\n -> if n == maxBound then from else n + 1) from +{-# INLINE ellipsis3Int #-} + +ellipsis3Word :: Word -> Infinite Word +ellipsis3Word from = iterate' (\n -> if n == maxBound then from else n + 1) from +{-# INLINE ellipsis3Word #-} + +ellipsis3Integer :: Integer -> Infinite Integer +ellipsis3Integer = iterate' (+ 1) +{-# INLINE ellipsis3Integer #-} + +ellipsis3Natural :: Natural -> Infinite Natural +ellipsis3Natural = iterate' (+ 1) +{-# INLINE ellipsis3Natural #-} + +-- | Generate infinite sequences, starting from given elements, +-- similar to @[x,y..]@. +-- For better user experience consider enabling @{\-# LANGUAGE PostfixOperators #-\}@: +-- +-- >>> :set -XPostfixOperators +-- >>> Data.List.Infinite.take 10 ((1,3)....) +-- [1,3,5,7,9,11,13,15,17,19] +-- +-- Beware that for finite types '(....)' applies 'cycle' atop of @[x,y..]@: +-- +-- >>> :set -XPostfixOperators +-- >>> Data.List.Infinite.take 10 ((EQ,GT)....) +-- [EQ,GT,EQ,GT,EQ,GT,EQ,GT,EQ,GT] +(....) :: Enum a => (a, a) -> Infinite a +(....) = unsafeCycle . uncurry enumFromThen +{-# INLINE [0] (....) #-} + +{-# RULES +"ellipsis4Int" (....) = ellipsis4Int +"ellipsis4Word" (....) = ellipsis4Word +"ellipsis4Integer" (....) = ellipsis4Integer +"ellipsis4Natural" (....) = ellipsis4Natural + #-} + +ellipsis4Int :: (Int, Int) -> Infinite Int +ellipsis4Int (from, thn) + | from <= thn = + let d = thn - from + in iterate' (\n -> if n > maxBound - d then from else n + d) from + | otherwise = + let d = from - thn + in iterate' (\n -> if n < minBound + d then from else n - d) from +{-# INLINE ellipsis4Int #-} + +ellipsis4Word :: (Word, Word) -> Infinite Word +ellipsis4Word (from, thn) + | from <= thn = + let d = thn - from + in iterate' (\n -> if n > maxBound - d then from else n + d) from + | otherwise = + let d = from - thn + in iterate' (\n -> if n < d then from else n - d) from +{-# INLINE ellipsis4Word #-} + +ellipsis4Integer :: (Integer, Integer) -> Infinite Integer +ellipsis4Integer (from, thn) = iterate' (+ (thn - from)) from +{-# INLINE ellipsis4Integer #-} + +ellipsis4Natural :: (Natural, Natural) -> Infinite Natural +ellipsis4Natural (from, thn) + | from <= thn = + iterate' (+ (thn - from)) from + | otherwise = + let d = from - thn + in iterate' (\n -> if n < d then from else n - d) from +{-# INLINE ellipsis4Natural #-} + +-- | Just a pointwise 'map'. +instance Functor Infinite where + fmap = map + (<$) = const . repeat + +-- | This instance operates pointwise, similar to 'Control.Applicative.ZipList'. +instance Applicative Infinite where + pure = repeat + (f :< fs) <*> (x :< xs) = f x :< (fs <*> xs) + (<*) = const + (*>) = const id +#if MIN_VERSION_base(4,10,0) + liftA2 = zipWith +#endif + +-- | 'Control.Applicative.ZipList' cannot be made a lawful 'Monad', +-- but 'Infinite', being a +-- , +-- can. Namely, 'Control.Monad.join' +-- picks up a diagonal of an infinite matrix of 'Infinite' ('Infinite' @a@). +-- This is mostly useful for parallel list comprehensions once +-- @{\-# LANGUAGE MonadComprehensions #-\}@ is enabled. +instance Monad Infinite where + xs >>= f = go 0 xs + where + go n (y :< ys) = f y !! n :< go (n + 1) ys + (>>) = (*>) + +-- | Get the first elements of an infinite list. +head :: Infinite a -> a +head (x :< _) = x +{-# NOINLINE [1] head #-} + +{-# RULES +"head/build" forall (g :: forall b. (a -> b -> b) -> b). + head (build g) = + g const + #-} + +-- | Get the elements of an infinite list after the first one. +tail :: Infinite a -> Infinite a +tail (_ :< xs) = xs + +-- | Split an infinite list into its 'head' and 'tail'. +uncons :: Infinite a -> (a, Infinite a) +uncons (x :< xs) = (x, xs) + +-- | Apply a function to every element of an infinite list. +map :: (a -> b) -> Infinite a -> Infinite b +map = foldr . ((:<) .) + +mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst +mapFB = (.) + +{-# NOINLINE [0] map #-} + +{-# INLINE [0] mapFB #-} + +{-# RULES +"map" [~1] forall f xs. + map f xs = + build (\cons -> foldr (mapFB cons f) xs) +"mapList" [1] forall f. + foldr (mapFB (:<) f) = + map f +"mapFB" forall cons f g. + mapFB (mapFB cons f) g = + mapFB cons (f . g) +"map/coerce" [1] + map coerce = + coerce + #-} + +-- | Flatten out an infinite list of non-empty lists. +concat :: Infinite (NonEmpty a) -> Infinite a +concat = foldr (\(x :| xs) acc -> x :< (xs `prependList` acc)) +{-# NOINLINE [1] concat #-} + +{-# RULES +"concat" forall xs. + concat xs = + build (\cons -> foldr (flip (F.foldr cons)) xs) + #-} + +-- | First 'map' every element, then 'concat'. +concatMap :: (a -> NonEmpty b) -> Infinite a -> Infinite b +concatMap f = foldr (\a acc -> let (x :| xs) = f a in x :< (xs `prependList` acc)) +{-# NOINLINE [1] concatMap #-} + +{-# RULES +"concatMap" forall f xs. + concatMap f xs = + build (\cons -> foldr (flip (F.foldr cons) . f) xs) + #-} + +-- | Interleave two infinite lists. +interleave :: Infinite a -> Infinite a -> Infinite a +interleave (x :< xs) ys = x :< interleave ys xs + +-- | Insert an element between adjacent elements of an infinite list. +intersperse :: a -> Infinite a -> Infinite a +intersperse a = foldr (\x -> (x :<) . (a :<)) +{-# NOINLINE [1] intersperse #-} + +{-# RULES +"intersperse" forall a xs. + intersperse a xs = + build (\cons -> foldr (\x -> cons x . cons a) xs) + #-} + +-- | Insert a non-empty list between adjacent elements of an infinite list, +-- and subsequently flatten it out. +intercalate :: NonEmpty a -> Infinite [a] -> Infinite a +intercalate ~(a :| as) = foldr (\xs -> prependList xs . (a :<) . prependList as) +{-# NOINLINE [1] intercalate #-} + +{-# RULES +"intercalate" forall as xss. + intercalate as xss = + build (\cons -> foldr (\xs acc -> F.foldr cons (F.foldr cons acc as) xs) xss) + #-} + +-- | Transpose rows and columns of an argument. +-- +-- This is actually @distribute@ from +-- +-- type class in disguise. +transpose :: Functor f => f (Infinite a) -> Infinite (f a) +transpose xss = fmap head xss :< transpose (fmap tail xss) + +-- | Generate an infinite list of all subsequences of the argument. +subsequences :: Infinite a -> Infinite [a] +subsequences = ([] :<) . map NE.toList . subsequences1 + +-- | Generate an infinite list of all non-empty subsequences of the argument. +subsequences1 :: Infinite a -> Infinite (NonEmpty a) +subsequences1 (x :< xs) = (x :| []) :< foldr f (subsequences1 xs) + where + f ys r = ys :< (x `NE.cons` ys) :< r + +-- | Generate an infinite list of all permutations of the argument. +permutations :: Infinite a -> Infinite (Infinite a) +permutations xs0 = xs0 :< perms xs0 [] + where + perms :: forall a. Infinite a -> [a] -> Infinite (Infinite a) + perms (t :< ts) is = List.foldr interleaveList (perms ts (t : is)) (List.permutations is) + where + interleaveList :: [a] -> Infinite (Infinite a) -> Infinite (Infinite a) + interleaveList = (snd .) . interleaveList' id + + interleaveList' :: (Infinite a -> b) -> [a] -> Infinite b -> (Infinite a, Infinite b) + interleaveList' _ [] r = (ts, r) + interleaveList' f (y : ys) r = (y :< us, f (t :< y :< us) :< zs) + where + (us, zs) = interleaveList' (f . (y :<)) ys r + +-- | +-- > scanl f acc (x1 :< x2 :< ...) = acc :< f acc x1 :< f (f acc x1) x2 :< ... +scanl :: (b -> a -> b) -> b -> Infinite a -> Infinite b +scanl f = go + where + go z ~(x :< xs) = z :< go (f z x) xs + +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') + +{-# NOINLINE [1] scanl #-} + +{-# INLINE [0] scanlFB #-} + +{-# RULES +"scanl" [~1] forall f a bs. + scanl f a bs = + build (\cons -> 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) + #-} + +-- | Same as 'scanl', but strict in accumulator. +scanl' :: (b -> a -> b) -> b -> Infinite a -> Infinite b +scanl' f = go + where + go !z ~(x :< xs) = z :< go (f z x) xs + +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') + +{-# NOINLINE [1] scanl' #-} + +{-# INLINE [0] scanlFB' #-} + +{-# RULES +"scanl'" [~1] forall f a bs. + scanl' f a bs = + build (\cons -> 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) + #-} + +-- | +-- > scanl1 f (x0 :< x1 :< x2 :< ...) = x0 :< f x0 x1 :< f (f x0 x1) x2 :< ... +scanl1 :: (a -> a -> a) -> Infinite a -> Infinite a +scanl1 f (x :< xs) = scanl f x xs + +-- | If you are looking how to traverse with a state, look no further: +-- +-- > mapAccumL f acc0 (x1 :< x2 :< ...) = +-- > let (acc1, y1) = f acc0 x1 in +-- > let (acc2, y2) = f acc1 x2 in +-- > ... +-- > y1 :< y2 :< ... +mapAccumL :: (acc -> x -> (acc, y)) -> acc -> Infinite x -> Infinite y +mapAccumL f = go + where + go s (x :< xs) = y :< go s' xs + where + (s', y) = f s x + +mapAccumLFB :: (acc -> x -> (acc, y)) -> x -> (acc -> Infinite y) -> acc -> Infinite y +mapAccumLFB f = \x r -> oneShot (\s -> let (s', y) = f s x in y :< r s') + +{-# NOINLINE [1] mapAccumL #-} + +{-# INLINE [0] mapAccumLFB #-} + +{-# RULES +"mapAccumL" [~1] forall f s xs. + mapAccumL f s xs = + foldr (mapAccumLFB f) xs s +"mapAccumLList" [1] forall f s xs. + foldr (mapAccumLFB f) xs s = + mapAccumL f s xs + #-} + +-- | Generate an infinite list of repeated applications. +iterate :: (a -> a) -> a -> Infinite a +iterate f = go + where + go x = x :< go (f x) + +iterateFB :: (elt -> lst -> lst) -> (elt -> elt) -> elt -> lst +iterateFB cons f = go + where + go x = x `cons` go (f x) + +{-# NOINLINE [1] iterate #-} + +{-# INLINE [0] iterateFB #-} + +{-# RULES +"iterate" [~1] forall f x. iterate f x = build (\cons -> iterateFB cons f x) +"iterateFB" [1] iterateFB (:<) = iterate + #-} + +-- | Same as 'iterate', but strict in accumulator. +iterate' :: (a -> a) -> a -> Infinite a +iterate' f = go + where + go !x = x :< go (f x) + +iterateFB' :: (elt -> lst -> lst) -> (elt -> elt) -> elt -> lst +iterateFB' cons f = go + where + go !x = x `cons` go (f x) + +{-# NOINLINE [1] iterate' #-} + +{-# INLINE [0] iterateFB' #-} + +{-# RULES +"iterate'" [~1] forall f x. iterate' f x = build (\cons -> iterateFB' cons f x) +"iterateFB'" [1] iterateFB' (:<) = iterate' + #-} + +-- | Repeat the same element ad infinitum. +repeat :: a -> Infinite a +repeat x = go + where + go = x :< go + +repeatFB :: (elt -> lst -> lst) -> elt -> lst +repeatFB cons x = go + where + go = x `cons` go + +{-# NOINLINE [1] repeat #-} + +{-# INLINE [0] repeatFB #-} + +{-# RULES +"repeat" [~1] forall x. repeat x = build (`repeatFB` x) +"repeatFB" [1] repeatFB (:<) = repeat + #-} + +-- | Repeat a non-empty list ad infinitum. +-- If you were looking for something like @fromList :: [a] -> Infinite a@, +-- look no further. +cycle :: NonEmpty a -> Infinite a +cycle (x :| xs) = unsafeCycle (x : xs) +{-# INLINE cycle #-} + +unsafeCycle :: [a] -> Infinite a +unsafeCycle xs = go + where + go = xs `prependList` go + +unsafeCycleFB :: (elt -> lst -> lst) -> [elt] -> lst +unsafeCycleFB cons xs = go + where + go = F.foldr cons go xs + +{-# NOINLINE [1] unsafeCycle #-} + +{-# INLINE [0] unsafeCycleFB #-} + +{-# RULES +"unsafeCycle" [~1] forall x. unsafeCycle x = build (`unsafeCycleFB` x) +"unsafeCycleFB" [1] unsafeCycleFB (:<) = unsafeCycle + #-} + +-- | Build an infinite list from a seed value. +unfoldr :: (b -> (a, b)) -> b -> Infinite a +unfoldr f = go + where + go b = let (a, b') = f b in a :< go b' +{-# INLINE unfoldr #-} + +-- | Generate an infinite list of @f@ 0, @f@ 1, @f@ 2... +-- +-- 'tabulate' and '(!!)' witness that 'Infinite' is +-- . +tabulate :: (Word -> a) -> Infinite a +tabulate f = unfoldr (\n -> (f n, n + 1)) 0 +{-# INLINE tabulate #-} + +-- | Take a prefix of given length. +take :: Int -> Infinite a -> [a] +take = GHC.Exts.inline genericTake + +takeFB :: (elt -> lst -> lst) -> lst -> elt -> (Int -> lst) -> Int -> lst +takeFB cons nil x xs = \m -> if m <= 1 then x `cons` nil else x `cons` xs (m - 1) + +{-# INLINE [1] take #-} + +{-# INLINE [0] takeFB #-} + +{-# RULES +"take" [~1] forall n xs. + take n xs = + GHC.Exts.build + ( \cons nil -> + if n >= 1 + then foldr (takeFB cons nil) xs n + else nil + ) +"takeList" [1] forall n xs. + foldr (takeFB (:) []) xs n = + take n xs + #-} + +-- | Take a prefix of given length. +genericTake :: Integral i => i -> Infinite a -> [a] +genericTake n + | n < 1 = const [] + | otherwise = unsafeTake n + where + unsafeTake 1 (x :< _) = [x] + unsafeTake m (x :< xs) = x : unsafeTake (m - 1) xs + +-- | Drop a prefix of given length. +drop :: Int -> Infinite a -> Infinite a +drop = GHC.Exts.inline genericDrop + +dropFB :: (elt -> lst -> lst) -> elt -> (Int -> lst) -> Int -> lst +dropFB cons x xs = \m -> if m < 1 then x `cons` xs m else xs (m - 1) + +{-# INLINE [1] drop #-} + +{-# INLINE [0] dropFB #-} + +{-# RULES +"drop" [~1] forall n xs. + drop n xs = + build + ( \cons -> + if n >= 1 + then foldr (dropFB cons) xs n + else foldr cons xs + ) +"dropList" [1] forall n xs. + foldr (dropFB (:<)) xs n = + drop n xs + #-} + +-- | Drop a prefix of given length. +genericDrop :: Integral i => i -> Infinite a -> Infinite a +genericDrop n + | n < 1 = id + | otherwise = unsafeDrop n + where + unsafeDrop 1 (_ :< xs) = xs + unsafeDrop m (_ :< xs) = unsafeDrop (m - 1) xs + +-- | Split an infinite list into a prefix of given length and the rest. +splitAt :: Int -> Infinite a -> ([a], Infinite a) +splitAt = GHC.Exts.inline genericSplitAt + +-- | Split an infinite list into a prefix of given length and the rest. +genericSplitAt :: Integral i => i -> Infinite a -> ([a], Infinite a) +genericSplitAt n + | n < 1 = ([],) + | otherwise = unsafeSplitAt n + where + unsafeSplitAt 1 (x :< xs) = ([x], xs) + unsafeSplitAt m (x :< xs) = first (x :) (unsafeSplitAt (m - 1) xs) + +-- | Take the longest prefix satisfying a predicate. +takeWhile :: (a -> Bool) -> Infinite a -> [a] +takeWhile p = go + where + go (x :< xs) + | p x = x : go xs + | otherwise = [] + +takeWhileFB :: (elt -> Bool) -> (elt -> lst -> lst) -> lst -> elt -> lst -> lst +takeWhileFB p cons nil = \x r -> if p x then x `cons` r else nil + +{-# NOINLINE [1] takeWhile #-} + +{-# INLINE [0] takeWhileFB #-} + +{-# RULES +"takeWhile" [~1] forall p xs. + takeWhile p xs = + GHC.Exts.build (\cons nil -> foldr (takeWhileFB p cons nil) xs) +"takeWhileList" [1] forall p. + foldr (takeWhileFB p (:) []) = + takeWhile p + #-} + +-- | Drop the longest prefix satisfying a predicate. +-- +-- This function isn't productive (e. g., 'head' . 'dropWhile' @f@ won't terminate), +-- if all elements of the input list satisfy the predicate. +dropWhile :: (a -> Bool) -> Infinite a -> Infinite a +dropWhile p = go + where + go xxs@(x :< xs) + | p x = go xs + | otherwise = xxs + +dropWhileFB :: (elt -> Bool) -> (elt -> lst -> lst) -> elt -> (Bool -> lst) -> (Bool -> lst) +dropWhileFB p cons = \x r drp -> if drp && p x then r True else x `cons` r False + +{-# NOINLINE [1] dropWhile #-} + +{-# INLINE [0] dropWhileFB #-} + +{-# RULES +"dropWhile" [~1] forall p xs. + dropWhile p xs = + build (\cons -> foldr (dropWhileFB p cons) xs True) +"dropWhileList" [1] forall p xs. + foldr (dropWhileFB p (:<)) xs True = + dropWhile p xs + #-} + +-- | Split an infinite list into the longest prefix satisfying a predicate and the rest. +-- +-- This function isn't productive in the second component of the tuple +-- (e. g., 'head' . 'snd' . 'span' @f@ won't terminate), +-- if all elements of the input list satisfy the predicate. +span :: (a -> Bool) -> Infinite a -> ([a], Infinite a) +span p = go + where + go xxs@(x :< xs) + | p x = first (x :) (go xs) + | otherwise = ([], xxs) + +-- | Split an infinite list into the longest prefix /not/ satisfying a predicate and the rest. +-- +-- This function isn't productive in the second component of the tuple +-- (e. g., 'head' . 'snd' . 'break' @f@ won't terminate), +-- if no elements of the input list satisfy the predicate. +break :: (a -> Bool) -> Infinite a -> ([a], Infinite a) +break = span . (not .) + +-- | If a list is a prefix of an infinite list, strip it and return the rest. +-- Otherwise return 'Nothing'. +stripPrefix :: Eq a => [a] -> Infinite a -> Maybe (Infinite a) +stripPrefix [] ys = Just ys +stripPrefix (x : xs) (y :< ys) + | x == y = stripPrefix xs ys + | otherwise = Nothing + +-- | Group consecutive equal elements. +group :: Eq a => Infinite a -> Infinite (NonEmpty a) +group = groupBy (==) + +-- | Overloaded version of 'group'. +groupBy :: (a -> a -> Bool) -> Infinite a -> Infinite (NonEmpty a) +groupBy f = go + where + go (x :< xs) = (x :| ys) :< go zs + where + (ys, zs) = span (f x) xs + +-- | Generate all prefixes of an infinite list. +inits :: Infinite a -> Infinite [a] +inits = + map (\(SnocBuilder _ front rear) -> front List.++ List.reverse rear) + . scanl' + (\(SnocBuilder count front rear) x -> snocBuilder (count + 1) front (x : rear)) + (SnocBuilder 0 [] []) + +data SnocBuilder a = SnocBuilder + { _count :: !Word + , _front :: [a] + , _rear :: [a] + } + +snocBuilder :: Word -> [a] -> [a] -> SnocBuilder a +snocBuilder count front rear + | count < 8 || (count .&. (count + 1)) /= 0 = + SnocBuilder count front rear + | otherwise = + SnocBuilder count (front List.++ List.reverse rear) [] +{-# INLINE snocBuilder #-} + +-- | Generate all non-empty prefixes of an infinite list. +inits1 :: Infinite a -> Infinite (NonEmpty a) +inits1 (x :< xs) = map (x :|) (inits xs) + +-- | Generate all suffixes of an infinite list. +tails :: Infinite a -> Infinite (Infinite a) +tails = foldr (\x xss@(~(xs :< _)) -> (x :< xs) :< xss) + +-- | Check whether a list is a prefix of an infinite list. +isPrefixOf :: Eq a => [a] -> Infinite a -> Bool +isPrefixOf [] _ = True +isPrefixOf (x : xs) (y :< ys) + | x == y = isPrefixOf xs ys + | otherwise = False + +-- | Find the first pair, whose first component is equal to the first argument, +-- and return the second component. +-- If there is nothing to be found, this function will hang indefinitely. +lookup :: Eq a => a -> Infinite (a, b) -> b +lookup a = foldr (\(a', b) b' -> if a == a' then b else b') + +-- | Find the first element, satisfying a predicate. +-- If there is nothing to be found, this function will hang indefinitely. +find :: (a -> Bool) -> Infinite a -> a +find f = foldr (\a a' -> if f a then a else a') + +-- | Filter an infinite list, removing elements which does not satisfy a predicate. +-- +-- This function isn't productive (e. g., 'head' . 'filter' @f@ won't terminate), +-- if no elements of the input list satisfy the predicate. +filter :: (a -> Bool) -> Infinite a -> Infinite a +filter f = foldr (\a -> if f a then (a :<) else id) + +filterFB :: (elt -> lst -> lst) -> (elt -> Bool) -> elt -> lst -> lst +filterFB cons f x r + | f x = x `cons` r + | otherwise = r + +{-# NOINLINE [1] filter #-} + +{-# INLINE [0] filterFB #-} + +{-# RULES +"filter" [~1] forall f xs. + filter f xs = + build (\cons -> foldr (filterFB cons f) xs) +"filterList" [1] forall f. + foldr (filterFB (:<) f) = + filter f +"filterFB" forall cons f g. + filterFB (filterFB cons f) g = + filterFB cons (\x -> f x && g x) + #-} + +-- | Split an infinite list into two infinite lists: the first one contains elements, +-- satisfying a predicate, and the second one the rest. +-- +-- This function isn't productive in the first component of the tuple +-- (e. g., 'head' . 'Data.Tuple.fst' . 'partition' @f@ won't terminate), +-- if no elements of the input list satisfy the predicate. +-- Same for the second component, +-- if all elements of the input list satisfy the predicate. +partition :: (a -> Bool) -> Infinite a -> (Infinite a, Infinite a) +partition f = foldr (\a -> if f a then first (a :<) else second (a :<)) + +-- | Return /n/-th element of an infinite list. +-- On contrary to @Data.List.@'List.!!', this function takes 'Word' instead of 'Int' +-- to avoid 'Prelude.error' on negative arguments. +-- +-- This is actually @index@ from +-- +-- type class in disguise. +(!!) :: Infinite a -> Word -> a +(!!) = flip go + where + go 0 (x :< _) = x + go !m (_ :< ys) = go (m - 1) ys + +infixl 9 !! + +-- | Return an index of the first element, equal to a given. +-- If there is nothing to be found, this function will hang indefinitely. +elemIndex :: Eq a => a -> Infinite a -> Word +elemIndex = findIndex . (==) + +-- | Return indices of all elements, equal to a given. +-- +-- This function isn't productive (e. g., 'head' . 'elemIndices' @f@ won't terminate), +-- if no elements of the input list are equal the given one. +elemIndices :: Eq a => a -> Infinite a -> Infinite Word +elemIndices = findIndices . (==) + +-- | Return an index of the first element, satisfying a predicate. +-- If there is nothing to be found, this function will hang indefinitely. +findIndex :: (a -> Bool) -> Infinite a -> Word +findIndex f = go 0 + where + go !n (x :< xs) + | f x = n + | otherwise = go (n + 1) xs + +-- | Return indices of all elements, satisfying a predicate. +-- +-- This function isn't productive (e. g., 'head' . 'elemIndices' @f@ won't terminate), +-- if no elements of the input list satisfy the predicate. +findIndices :: (a -> Bool) -> Infinite a -> Infinite Word +findIndices f = go 0 + where + go !n (x :< xs) = (if f x then (n :<) else id) (go (n + 1) xs) + +-- | Unzip an infinite list of tuples. +unzip :: Infinite (a, b) -> (Infinite a, Infinite b) +unzip = foldr (\(a, b) ~(as, bs) -> (a :< as, b :< bs)) +{-# INLINE unzip #-} + +-- | Unzip an infinite list of triples. +unzip3 :: Infinite (a, b, c) -> (Infinite a, Infinite b, Infinite c) +unzip3 = foldr (\(a, b, c) ~(as, bs, cs) -> (a :< as, b :< bs, c :< cs)) +{-# INLINE unzip3 #-} + +-- | Unzip an infinite list of quadruples. +unzip4 :: Infinite (a, b, c, d) -> (Infinite a, Infinite b, Infinite c, Infinite d) +unzip4 = foldr (\(a, b, c, d) ~(as, bs, cs, ds) -> (a :< as, b :< bs, c :< cs, d :< ds)) +{-# INLINE unzip4 #-} + +-- | Unzip an infinite list of quintuples. +unzip5 :: Infinite (a, b, c, d, e) -> (Infinite a, Infinite b, Infinite c, Infinite d, Infinite e) +unzip5 = foldr (\(a, b, c, d, e) ~(as, bs, cs, ds, es) -> (a :< as, b :< bs, c :< cs, d :< ds, e :< es)) +{-# INLINE unzip5 #-} + +-- | Unzip an infinite list of sextuples. +unzip6 :: Infinite (a, b, c, d, e, f) -> (Infinite a, Infinite b, Infinite c, Infinite d, Infinite e, Infinite f) +unzip6 = foldr (\(a, b, c, d, e, f) ~(as, bs, cs, ds, es, fs) -> (a :< as, b :< bs, c :< cs, d :< ds, e :< es, f :< fs)) +{-# INLINE unzip6 #-} + +-- | Unzip an infinite list of septuples. +unzip7 :: Infinite (a, b, c, d, e, f, g) -> (Infinite a, Infinite b, Infinite c, Infinite d, Infinite e, Infinite f, Infinite g) +unzip7 = foldr (\(a, b, c, d, e, f, g) ~(as, bs, cs, ds, es, fs, gs) -> (a :< as, b :< bs, c :< cs, d :< ds, e :< es, f :< fs, g :< gs)) +{-# INLINE unzip7 #-} + +-- | Split an infinite string into lines, by @\\n@. +lines :: Infinite Char -> Infinite [Char] +lines xs = l :< lines xs' + where + (l, ~(_ :< xs')) = break (== '\n') xs + +-- | Concatenate lines together with @\\n@. +unlines :: Infinite [Char] -> Infinite Char +unlines = foldr (\l xs -> l `prependList` ('\n' :< xs)) + +-- | Split an infinite string into words, by any 'isSpace' symbol. +words :: Infinite Char -> Infinite (NonEmpty Char) +words xs = (u :| us) :< words vs + where + u :< ys = dropWhile isSpace xs + (us, vs) = break isSpace ys + +wordsFB :: (NonEmpty Char -> lst -> lst) -> Infinite Char -> lst +wordsFB cons = go + where + go xs = (u :| us) `cons` go vs + where + u :< ys = dropWhile isSpace xs + (us, vs) = break isSpace ys + +{-# NOINLINE [1] words #-} + +{-# INLINE [0] wordsFB #-} + +{-# RULES +"words" [~1] forall s. words s = build (`wordsFB` s) +"wordsList" [1] wordsFB (:<) = words + #-} + +-- | Concatenate words together with a space. +unwords :: Infinite (NonEmpty Char) -> Infinite Char +unwords = foldr (\(l :| ls) acc -> l :< ls `prependList` (' ' :< acc)) + +unwordsFB :: (Char -> lst -> lst) -> Infinite (NonEmpty Char) -> lst +unwordsFB cons = foldr (\(l :| ls) acc -> l `cons` List.foldr cons (' ' `cons` acc) ls) + +{-# NOINLINE [1] unwords #-} + +{-# INLINE [0] unwordsFB #-} + +{-# RULES +"unwords" [~1] forall s. unwords s = build (`unwordsFB` s) +"unwordsList" [1] unwordsFB (:<) = unwords + #-} + +-- | Remove duplicate from a list, keeping only the first occurrence of each element. +nub :: Eq a => Infinite a -> Infinite a +nub = nubBy (==) + +-- | Overloaded version of 'nub'. +nubBy :: (a -> a -> Bool) -> Infinite a -> Infinite a +nubBy eq = go [] + where + go seen (x :< xs) + | elemBy x seen = go seen xs + | otherwise = x :< go (x : seen) xs + + elemBy _ [] = False + elemBy y (x : xs) = eq x y || elemBy y xs + +-- | Remove all occurrences of an element from an infinite list. +delete :: Eq a => a -> Infinite a -> Infinite a +delete = deleteBy (==) + +-- | Overloaded version of 'delete'. +deleteBy :: (a -> b -> Bool) -> a -> Infinite b -> Infinite b +deleteBy eq x = go + where + go (y :< ys) + | eq x y = ys + | otherwise = y :< go ys + +-- | Take an infinite list and remove the first occurrence of every element +-- of a finite list. +(\\) :: Eq a => Infinite a -> [a] -> Infinite a +(\\) = deleteFirstsBy (==) + +-- | Overloaded version of '(\\)'. +deleteFirstsBy :: (a -> b -> Bool) -> Infinite b -> [a] -> Infinite b +deleteFirstsBy eq = List.foldl (flip (deleteBy eq)) + +-- | Union of a finite and an infinite list. It contains the finite list +-- as a prefix and afterwards all non-duplicate elements of the infinite list, +-- which are not members of the finite list. +union :: Eq a => [a] -> Infinite a -> Infinite a +union = unionBy (==) + +-- | Overloaded version of 'union'. +unionBy :: (a -> a -> Bool) -> [a] -> Infinite a -> Infinite a +unionBy eq xs ys = xs `prependList` List.foldl (flip (deleteBy eq)) (nubBy eq ys) xs + +-- | Insert an element at the first position where it is less than or equal +-- to the next one. If the input was sorted, the output remains sorted as well. +insert :: Ord a => a -> Infinite a -> Infinite a +insert = insertBy compare + +-- | Overloaded version of 'insert'. +insertBy :: (a -> a -> Ordering) -> a -> Infinite a -> Infinite a +insertBy cmp x = go + where + go yys@(y :< ys) = case cmp x y of + GT -> y :< go ys + _ -> x :< yys + +-- | Return all elements of an infinite list, which are simultaneously +-- members of a finite list. +intersect :: Eq a => Infinite a -> [a] -> Infinite a +intersect = intersectBy (==) + +-- | Overloaded version of 'intersect'. +intersectBy :: (a -> b -> Bool) -> Infinite a -> [b] -> Infinite a +intersectBy eq xs ys = filter (\x -> List.any (eq x) ys) xs + +-- | Prepend a list to an infinite list. +prependList :: [a] -> Infinite a -> Infinite a +prependList = flip (F.foldr (:<)) diff --git a/src/Data/List/Infinite/Internal.hs b/src/Data/List/Infinite/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Infinite/Internal.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE RankNTypes #-} + +-- | +-- Copyright: (c) 2022 Bodigrim +-- License: BSD3 +module Data.List.Infinite.Internal ( + Infinite (..), + build, +) where + +-- | Type of infinite lists. +data Infinite a = a :< Infinite a + +infixr 5 :< + +build :: forall a. (forall b. (a -> b -> b) -> b) -> Infinite a +build g = g (:<) +{-# INLINE [1] build #-} diff --git a/src/Data/List/Infinite/Zip.hs b/src/Data/List/Infinite/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Infinite/Zip.hs @@ -0,0 +1,336 @@ +-- | +-- Copyright: (c) 2022 Bodigrim +-- License: BSD3 +module Data.List.Infinite.Zip ( + zip, + zipWith, + zip3, + zipWith3, + zip4, + zipWith4, + zip5, + zipWith5, + zip6, + zipWith6, + zip7, + zipWith7, +) where + +import Prelude (flip, (.)) + +import Data.List.Infinite.Internal + +-- | Zip two infinite lists. +zip :: Infinite a -> Infinite b -> Infinite (a, b) +zip = zipWith (,) +{-# INLINE zip #-} + +-- | Zip two infinite lists with a given function. +zipWith :: (a -> b -> c) -> Infinite a -> Infinite b -> Infinite c +zipWith fun = go + where + go (a :< as) (b :< bs) = fun a b :< go as bs + +zipWithFB :: (elt -> lst -> lst') -> (a -> b -> elt) -> a -> b -> lst -> lst' +zipWithFB = (.) . (.) + +{-# NOINLINE [1] zipWith #-} + +{-# INLINE [0] zipWithFB #-} + +{-# RULES +"zipWith" [~1] forall f xs ys. + zipWith f xs ys = + build (\cons -> foldr2 (zipWithFB cons f) xs ys) +"zipWithList" [1] forall f. + foldr2 (zipWithFB (:<) f) = + zipWith f + #-} + +foldr2 :: (elt1 -> elt2 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> lst +foldr2 cons = go + where + go (a :< as) (b :< bs) = cons a b (go as bs) +{-# INLINE [0] foldr2 #-} + +foldr2_left :: (elt1 -> elt2 -> lst -> lst') -> elt1 -> (Infinite elt2 -> lst) -> Infinite elt2 -> lst' +foldr2_left cons a r (b :< bs) = cons a b (r bs) + +{-# RULES +"foldr2/1" forall (cons :: elt1 -> elt2 -> lst -> lst) (bs :: Infinite elt2) (g :: forall b. (elt1 -> b -> b) -> b). + foldr2 cons (build g) bs = + g (foldr2_left cons) bs +"foldr2/2" forall (cons :: elt1 -> elt2 -> lst -> lst) (as :: Infinite elt1) (g :: forall b. (elt2 -> b -> b) -> b). + foldr2 cons as (build g) = + g (foldr2_left (flip cons)) as + #-} + +-- | Zip three infinite lists. +zip3 :: Infinite a -> Infinite b -> Infinite c -> Infinite (a, b, c) +zip3 = zipWith3 (,,) +{-# INLINE zip3 #-} + +-- | Zip three infinite lists with a given function. +zipWith3 :: (a -> b -> c -> d) -> Infinite a -> Infinite b -> Infinite c -> Infinite d +zipWith3 fun = go + where + go (a :< as) (b :< bs) (c :< cs) = fun a b c :< go as bs cs + +zipWith3FB :: (elt -> lst -> lst') -> (a -> b -> c -> elt) -> a -> b -> c -> lst -> lst' +zipWith3FB = (.) . (.) . (.) + +{-# NOINLINE [1] zipWith3 #-} + +{-# INLINE [0] zipWith3FB #-} + +{-# RULES +"zipWith3" [~1] forall f xs ys zs. + zipWith3 f xs ys zs = + build (\cons -> foldr3 (zipWith3FB cons f) xs ys zs) +"zipWith3List" [1] forall f. + foldr3 (zipWith3FB (:<) f) = + zipWith3 f + #-} + +foldr3 :: (elt1 -> elt2 -> elt3 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> Infinite elt3 -> lst +foldr3 cons = go + where + go (a :< as) (b :< bs) (c :< cs) = cons a b c (go as bs cs) +{-# INLINE [0] foldr3 #-} + +foldr3_left :: (elt1 -> elt2 -> elt3 -> lst -> lst') -> elt1 -> (Infinite elt2 -> Infinite elt3 -> lst) -> Infinite elt2 -> Infinite elt3 -> lst' +foldr3_left cons a r (b :< bs) (c :< cs) = cons a b c (r bs cs) + +{-# RULES +"foldr3/1" forall (cons :: elt1 -> elt2 -> elt3 -> lst -> lst) (bs :: Infinite elt2) (cs :: Infinite elt3) (g :: forall b. (elt1 -> b -> b) -> b). + foldr3 cons (build g) bs cs = + g (foldr3_left cons) bs cs +"foldr3/2" forall (cons :: elt1 -> elt2 -> elt3 -> lst -> lst) (as :: Infinite elt1) (cs :: Infinite elt3) (g :: forall b. (elt2 -> b -> b) -> b). + foldr3 cons as (build g) cs = + g (foldr3_left (flip cons)) as cs +"foldr3/3" forall (cons :: elt1 -> elt2 -> elt3 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (g :: forall b. (elt3 -> b -> b) -> b). + foldr3 cons as bs (build g) = + g (foldr3_left (\c a b -> cons a b c)) as bs + #-} + +-- | Zip four infinite lists. +zip4 :: Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite (a, b, c, d) +zip4 = zipWith4 (,,,) +{-# INLINE zip4 #-} + +-- | Zip four infinite lists with a given function. +zipWith4 :: (a -> b -> c -> d -> e) -> Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e +zipWith4 fun = go + where + go (a :< as) (b :< bs) (c :< cs) (d :< ds) = fun a b c d :< go as bs cs ds + +zipWith4FB :: (elt -> lst -> lst') -> (a -> b -> c -> d -> elt) -> a -> b -> c -> d -> lst -> lst' +zipWith4FB = (.) . (.) . (.) . (.) + +{-# NOINLINE [1] zipWith4 #-} + +{-# INLINE [0] zipWith4FB #-} + +{-# RULES +"zipWith4" [~1] forall f xs ys zs ts. + zipWith4 f xs ys zs ts = + build (\cons -> foldr4 (zipWith4FB cons f) xs ys zs ts) +"zipWith4List" [1] forall f. + foldr4 (zipWith4FB (:<) f) = + zipWith4 f + #-} + +foldr4 :: (elt1 -> elt2 -> elt3 -> elt4 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> lst +foldr4 cons = go + where + go (a :< as) (b :< bs) (c :< cs) (d :< ds) = cons a b c d (go as bs cs ds) +{-# INLINE [0] foldr4 #-} + +foldr4_left :: (elt1 -> elt2 -> elt3 -> elt4 -> lst -> lst') -> elt1 -> (Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> lst) -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> lst' +foldr4_left cons a r (b :< bs) (c :< cs) (d :< ds) = cons a b c d (r bs cs ds) + +{-# RULES +"foldr4/1" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> lst -> lst) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (g :: forall b. (elt1 -> b -> b) -> b). + foldr4 cons (build g) bs cs ds = + g (foldr4_left cons) bs cs ds +"foldr4/2" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> lst -> lst) (as :: Infinite elt1) (cs :: Infinite elt3) (ds :: Infinite elt4) (g :: forall b. (elt2 -> b -> b) -> b). + foldr4 cons as (build g) cs ds = + g (foldr4_left (flip cons)) as cs ds +"foldr4/3" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (ds :: Infinite elt4) (g :: forall b. (elt3 -> b -> b) -> b). + foldr4 cons as bs (build g) ds = + g (foldr4_left (\c a b d -> cons a b c d)) as bs ds +"foldr4/4" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (g :: forall b. (elt4 -> b -> b) -> b). + foldr4 cons as bs cs (build g) = + g (foldr4_left (\d a b c -> cons a b c d)) as bs cs + #-} + +-- | Zip five infinite lists. +zip5 :: Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite (a, b, c, d, e) +zip5 = zipWith5 (,,,,) +{-# INLINE zip5 #-} + +-- | Zip five infinite lists with a given function. +zipWith5 :: (a -> b -> c -> d -> e -> f) -> Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite f +zipWith5 fun = go + where + go (a :< as) (b :< bs) (c :< cs) (d :< ds) (e :< es) = fun a b c d e :< go as bs cs ds es + +zipWith5FB :: (elt -> lst -> lst') -> (a -> b -> c -> d -> e -> elt) -> a -> b -> c -> d -> e -> lst -> lst' +zipWith5FB = (.) . (.) . (.) . (.) . (.) + +{-# NOINLINE [1] zipWith5 #-} + +{-# INLINE [0] zipWith5FB #-} + +{-# RULES +"zipWith5" [~1] forall f xs ys zs ts us. + zipWith5 f xs ys zs ts us = + build (\cons -> foldr5 (zipWith5FB cons f) xs ys zs ts us) +"zipWith5List" [1] forall f. + foldr5 (zipWith5FB (:<) f) = + zipWith5 f + #-} + +foldr5 :: (elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> lst +foldr5 cons = go + where + go (a :< as) (b :< bs) (c :< cs) (d :< ds) (e :< es) = cons a b c d e (go as bs cs ds es) +{-# INLINE [0] foldr5 #-} + +foldr5_left :: (elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> lst -> lst') -> elt1 -> (Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> lst) -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> lst' +foldr5_left cons a r (b :< bs) (c :< cs) (d :< ds) (e :< es) = cons a b c d e (r bs cs ds es) + +{-# RULES +"foldr5/1" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> lst -> lst) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (es :: Infinite elt5) (g :: forall b. (elt1 -> b -> b) -> b). + foldr5 cons (build g) bs cs ds es = + g (foldr5_left cons) bs cs ds es +"foldr5/2" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> lst -> lst) (as :: Infinite elt1) (cs :: Infinite elt3) (ds :: Infinite elt4) (es :: Infinite elt5) (g :: forall b. (elt2 -> b -> b) -> b). + foldr5 cons as (build g) cs ds es = + g (foldr5_left (flip cons)) as cs ds es +"foldr5/3" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (ds :: Infinite elt4) (es :: Infinite elt5) (g :: forall b. (elt3 -> b -> b) -> b). + foldr5 cons as bs (build g) ds es = + g (foldr5_left (\c a b d e -> cons a b c d e)) as bs ds es +"foldr5/4" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (es :: Infinite elt5) (g :: forall b. (elt4 -> b -> b) -> b). + foldr5 cons as bs cs (build g) es = + g (foldr5_left (\d a b c e -> cons a b c d e)) as bs cs es +"foldr5/5" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (g :: forall b. (elt5 -> b -> b) -> b). + foldr5 cons as bs cs ds (build g) = + g (foldr5_left (\e a b c d -> cons a b c d e)) as bs cs ds + #-} + +-- | Zip six infinite lists. +zip6 :: Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite f -> Infinite (a, b, c, d, e, f) +zip6 = zipWith6 (,,,,,) +{-# INLINE zip6 #-} + +-- | Zip six infinite lists with a given function. +zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite f -> Infinite g +zipWith6 fun = go + where + go (a :< as) (b :< bs) (c :< cs) (d :< ds) (e :< es) (f :< fs) = fun a b c d e f :< go as bs cs ds es fs + +zipWith6FB :: (elt -> lst -> lst') -> (a -> b -> c -> d -> e -> f -> elt) -> a -> b -> c -> d -> e -> f -> lst -> lst' +zipWith6FB = (.) . (.) . (.) . (.) . (.) . (.) + +{-# NOINLINE [1] zipWith6 #-} + +{-# INLINE [0] zipWith6FB #-} + +{-# RULES +"zipWith6" [~1] forall f xs ys zs ts us vs. + zipWith6 f xs ys zs ts us vs = + build (\cons -> foldr6 (zipWith6FB cons f) xs ys zs ts us vs) +"zipWith6List" [1] forall f. + foldr6 (zipWith6FB (:<) f) = + zipWith6 f + #-} + +foldr6 :: (elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> Infinite elt6 -> lst +foldr6 cons = go + where + go (a :< as) (b :< bs) (c :< cs) (d :< ds) (e :< es) (f :< fs) = cons a b c d e f (go as bs cs ds es fs) +{-# INLINE [0] foldr6 #-} + +foldr6_left :: (elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> lst -> lst') -> elt1 -> (Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> Infinite elt6 -> lst) -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> Infinite elt6 -> lst' +foldr6_left cons a r (b :< bs) (c :< cs) (d :< ds) (e :< es) (f :< fs) = cons a b c d e f (r bs cs ds es fs) + +{-# RULES +"foldr6/1" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> lst -> lst) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (es :: Infinite elt5) (fs :: Infinite elt6) (g :: forall b. (elt1 -> b -> b) -> b). + foldr6 cons (build g) bs cs ds es fs = + g (foldr6_left cons) bs cs ds es fs +"foldr6/2" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> lst -> lst) (as :: Infinite elt1) (cs :: Infinite elt3) (ds :: Infinite elt4) (es :: Infinite elt5) (fs :: Infinite elt6) (g :: forall b. (elt2 -> b -> b) -> b). + foldr6 cons as (build g) cs ds es fs = + g (foldr6_left (flip cons)) as cs ds es fs +"foldr6/3" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (ds :: Infinite elt4) (es :: Infinite elt5) (fs :: Infinite elt6) (g :: forall b. (elt3 -> b -> b) -> b). + foldr6 cons as bs (build g) ds es fs = + g (foldr6_left (\c a b d e f -> cons a b c d e f)) as bs ds es fs +"foldr6/4" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (es :: Infinite elt5) (fs :: Infinite elt6) (g :: forall b. (elt4 -> b -> b) -> b). + foldr6 cons as bs cs (build g) es fs = + g (foldr6_left (\d a b c e f -> cons a b c d e f)) as bs cs es fs +"foldr6/5" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (fs :: Infinite elt6) (g :: forall b. (elt5 -> b -> b) -> b). + foldr6 cons as bs cs ds (build g) fs = + g (foldr6_left (\e a b c d f -> cons a b c d e f)) as bs cs ds fs +"foldr6/6" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (es :: Infinite elt5) (g :: forall b. (elt6 -> b -> b) -> b). + foldr6 cons as bs cs ds es (build g) = + g (foldr6_left (\f a b c d e -> cons a b c d e f)) as bs cs ds es + #-} + +-- | Zip seven infinite lists. +zip7 :: Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite f -> Infinite g -> Infinite (a, b, c, d, e, f, g) +zip7 = zipWith7 (,,,,,,) +{-# INLINE zip7 #-} + +-- | Zip seven infinite lists with a given function. +zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite f -> Infinite g -> Infinite h +zipWith7 fun = go + where + go (a :< as) (b :< bs) (c :< cs) (d :< ds) (e :< es) (f :< fs) (g :< gs) = fun a b c d e f g :< go as bs cs ds es fs gs + +zipWith7FB :: (elt -> lst -> lst') -> (a -> b -> c -> d -> e -> f -> g -> elt) -> a -> b -> c -> d -> e -> f -> g -> lst -> lst' +zipWith7FB = (.) . (.) . (.) . (.) . (.) . (.) . (.) + +{-# NOINLINE [1] zipWith7 #-} + +{-# INLINE [0] zipWith7FB #-} + +{-# RULES +"zipWith7" [~1] forall f xs ys zs ts us vs ws. + zipWith7 f xs ys zs ts us vs ws = + build (\cons -> foldr7 (zipWith7FB cons f) xs ys zs ts us vs ws) +"zipWith7List" [1] forall f. + foldr7 (zipWith7FB (:<) f) = + zipWith7 f + #-} + +foldr7 :: (elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> elt7 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> Infinite elt6 -> Infinite elt7 -> lst +foldr7 cons = go + where + go (a :< as) (b :< bs) (c :< cs) (d :< ds) (e :< es) (f :< fs) (g :< gs) = cons a b c d e f g (go as bs cs ds es fs gs) +{-# INLINE [0] foldr7 #-} + +foldr7_left :: (elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> elt7 -> lst -> lst') -> elt1 -> (Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> Infinite elt6 -> Infinite elt7 -> lst) -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> Infinite elt6 -> Infinite elt7 -> lst' +foldr7_left cons a r (b :< bs) (c :< cs) (d :< ds) (e :< es) (f :< fs) (g :< gs) = cons a b c d e f g (r bs cs ds es fs gs) + +{-# RULES +"foldr7/1" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> elt7 -> lst -> lst) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (es :: Infinite elt5) (fs :: Infinite elt6) (gs :: Infinite elt7) (g :: forall b. (elt1 -> b -> b) -> b). + foldr7 cons (build g) bs cs ds es fs gs = + g (foldr7_left cons) bs cs ds es fs gs +"foldr7/2" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> elt7 -> lst -> lst) (as :: Infinite elt1) (cs :: Infinite elt3) (ds :: Infinite elt4) (es :: Infinite elt5) (fs :: Infinite elt6) (gs :: Infinite elt7) (g :: forall b. (elt2 -> b -> b) -> b). + foldr7 cons as (build g) cs ds es fs gs = + g (foldr7_left (flip cons)) as cs ds es fs gs +"foldr7/3" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> elt7 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (ds :: Infinite elt4) (es :: Infinite elt5) (fs :: Infinite elt6) (gs :: Infinite elt7) (g :: forall b. (elt3 -> b -> b) -> b). + foldr7 cons as bs (build g) ds es fs gs = + g (foldr7_left (\c a b d e f g' -> cons a b c d e f g')) as bs ds es fs gs +"foldr7/4" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> elt7 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (es :: Infinite elt5) (fs :: Infinite elt6) (gs :: Infinite elt7) (g :: forall b. (elt4 -> b -> b) -> b). + foldr7 cons as bs cs (build g) es fs gs = + g (foldr7_left (\d a b c e f g' -> cons a b c d e f g')) as bs cs es fs gs +"foldr7/5" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> elt7 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (fs :: Infinite elt6) (gs :: Infinite elt7) (g :: forall b. (elt5 -> b -> b) -> b). + foldr7 cons as bs cs ds (build g) fs gs = + g (foldr7_left (\e a b c d f g' -> cons a b c d e f g')) as bs cs ds fs gs +"foldr7/6" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> elt7 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (es :: Infinite elt5) (gs :: Infinite elt7) (g :: forall b. (elt6 -> b -> b) -> b). + foldr7 cons as bs cs ds es (build g) gs = + g (foldr7_left (\f a b c d e g' -> cons a b c d e f g')) as bs cs ds es gs +"foldr7/7" forall (cons :: elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> elt7 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (cs :: Infinite elt3) (ds :: Infinite elt4) (es :: Infinite elt5) (fs :: Infinite elt6) (g :: forall b. (elt7 -> b -> b) -> b). + foldr7 cons as bs cs ds es fs (build g) = + g (foldr7_left (\g' a b c d e f -> cons a b c d e f g')) as bs cs ds es fs + #-} diff --git a/test/Fusion.hs b/test/Fusion.hs new file mode 100644 --- /dev/null +++ b/test/Fusion.hs @@ -0,0 +1,332 @@ +-- | +-- Copyright: (c) 2022 Bodigrim +-- Licence: BSD3 + +{-# LANGUAGE PostfixOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} + +module Main where + +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.Inspection +import Test.Tasty.Runners + +import Data.Coerce +import Data.Ord +import Data.List.Infinite (Infinite(..)) +import qualified Data.List.Infinite as I +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE + +foldrMap :: Infinite Int -> Infinite Int +foldrMap xs = I.foldr (\x acc -> fromIntegral x :< acc) (I.map fromIntegral xs :: Infinite Word) + +foldrConsMap :: Int -> Infinite Int -> Infinite Int +foldrConsMap i xs = I.foldr (\x acc -> fromIntegral x :< acc) (fromIntegral i :< (I.map fromIntegral xs :: Infinite Word)) + +mapMap :: Infinite Int -> Infinite Int +mapMap xs = I.map fromIntegral (I.map fromIntegral xs :: Infinite Word) + +mapId :: Infinite Int -> Infinite Int +mapId xs = I.map id (I.map id xs) + +mapCoerce :: Infinite Int -> Infinite (Down Int) +mapCoerce xs = I.map coerce xs + +headIterate :: Int -> Int +headIterate x = I.head (I.iterate (+ 1) x) + +foldrIterate :: Int -> [Int] +foldrIterate x = I.foldr (\a acc -> a : a : acc) (I.iterate (+ 1) x) + +foldrIterate' :: Int -> [Int] +foldrIterate' x = I.foldr (\a acc -> a : a : acc) (I.iterate (+ 1) x) + +foldrRepeat :: Int -> [Int] +foldrRepeat x = I.foldr (\a acc -> a : a : acc) (I.repeat x) + +headFilterIterate :: Int -> Int +headFilterIterate x = I.head (I.filter (> 10) (I.iterate (+ 1) x)) + +filterFilter :: Infinite Int -> Infinite Int +filterFilter xs = I.filter (> 10) (I.filter (> 5) xs) + +filterFilter' :: Infinite Int -> Infinite Int +filterFilter' xs = I.filter (\x -> x > 10 && x > 5) xs + +foldrScanl :: Infinite Int -> Infinite Int +foldrScanl xs = I.foldr (\a acc -> fromIntegral a :< acc) + (I.scanl (\_acc a -> fromIntegral a) (0 :: Word) xs) + +foldrScanl' :: Infinite Int -> Infinite Int +foldrScanl' xs = I.foldr (\a acc -> fromIntegral a :< acc) + (I.scanl' (\_acc a -> fromIntegral a) (0 :: Word) xs) + +takeRepeat :: Int -> [Int] +takeRepeat x = I.take x (I.repeat x) + +takeDropRepeat :: Int -> [Int] +takeDropRepeat x = I.take x (I.drop x (I.repeat x)) + +takeWhileIterate :: Int -> [Int] +takeWhileIterate x = I.takeWhile (< 10) (I.iterate (+ 1) x) + +takeWhileDropWhileIterate :: Int -> [Int] +takeWhileDropWhileIterate x = I.takeWhile (< 20) $ I.dropWhile (< 10) (I.iterate (+ 1) x) + +foldrCycle :: NonEmpty Int -> [Int] +foldrCycle xs = I.foldr (:) (I.cycle xs) + +foldrWordsCycle :: [Char] -> [Char] +foldrWordsCycle xs = I.foldr (\a acc -> NE.head a : acc) (I.words (I.cycle (' ' :| xs))) + +foldrMapAccumL :: Infinite Int -> Infinite Int +foldrMapAccumL xs = I.foldr (\a acc -> fromIntegral a :< acc) + (I.mapAccumL (\acc x -> (acc, fromIntegral x :: Word)) (0 :: Int) xs) + +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 + +takeFilterCycle :: [Int] +takeFilterCycle = I.take 100 $ I.filter odd $ I.cycle $ 0 :| [1..] + +takeFilterEllipsis3 :: [Int] +takeFilterEllipsis3 = I.take 100 $ I.filter odd (0 I....) + +takeFilterEllipsis4 :: [Int] +takeFilterEllipsis4 = I.take 100 $ I.filter odd ((0, 3) I.....) + +sumTakeFilterEllipsis3 :: Int +sumTakeFilterEllipsis3 = sum $ I.take 100 $ I.filter odd (0 I....) + +sumTakeFilterEllipsis4 :: Int +sumTakeFilterEllipsis4 = sum $ I.take 100 $ I.filter odd ((0, 3) I.....) + + +takeToListFilterIterate :: [Int] +takeToListFilterIterate = Prelude.take 100 $ I.toList $ I.filter odd $ I.iterate (+ 1) 0 + +sumTakeToListFilterIterate :: Int +sumTakeToListFilterIterate = sum $ Prelude.take 100 $ I.toList $ I.filter odd $ I.iterate (+ 1) 0 + +takeToListFilterCycle :: [Int] +takeToListFilterCycle = Prelude.take 100 $ I.toList $ I.filter odd $ I.cycle $ 0 :| [1..] + +takeToListFilterEllipsis3 :: [Int] +takeToListFilterEllipsis3 = Prelude.take 100 $ I.toList $ I.filter odd (0 I....) + +takeToListFilterEllipsis4 :: [Int] +takeToListFilterEllipsis4 = Prelude.take 100 $ I.toList $ I.filter odd ((0, 3) I.....) + +sumTakeToListFilterEllipsis3 :: Int +sumTakeToListFilterEllipsis3 = sum $ Prelude.take 100 $ I.toList $ I.filter odd (0 I....) + +sumTakeToListFilterEllipsis4 :: Int +sumTakeToListFilterEllipsis4 = sum $ Prelude.take 100 $ I.toList $ I.filter odd ((0, 3) I.....) + + +headFilterMapEllipsis3 :: Int +headFilterMapEllipsis3 = I.head $ I.filter odd $ I.map (+ 1) (0 I....) + +headFilterMapEllipsis4 :: Int +headFilterMapEllipsis4 = I.head $ I.filter odd $ I.map (+ 1) ((0, 3) I.....) + +toListConcatRepeat :: [Int] +toListConcatRepeat = I.toList $ I.concat $ I.repeat $ NE.singleton 1 + +toListConcatMapRepeat :: [Int] +toListConcatMapRepeat = I.toList $ I.concatMap NE.singleton $ I.repeat 1 + +toListIntersperseRepeat :: [Int] +toListIntersperseRepeat = I.toList $ I.intersperse 1 $ I.repeat 0 + +toListIntercalateRepeat :: [Int] +toListIntercalateRepeat = I.toList $ I.intercalate (NE.singleton 1) $ I.repeat [0] + +headMapZipIterate :: Bool +headMapZipIterate = I.head $ I.map ((> 0) . snd) $ I.zip (I.repeat (1 :: Word)) $ I.iterate id (0 :: Int) + +headMapFlipZipIterate :: Bool +headMapFlipZipIterate = I.head $ I.map ((> 0) . fst) $ flip I.zip (I.repeat (1 :: Word)) $ I.iterate id (0 :: Int) + +zeros :: Infinite Word +zeros = I.repeat 0 +{-# NOINLINE zeros #-} + +zipWithRepeat1 :: Infinite Bool +zipWithRepeat1 = I.zipWith (\x y -> x == fromIntegral y) (I.repeat (1 :: Int)) zeros + +zipWithRepeat2 :: Infinite Bool +zipWithRepeat2 = I.zipWith (\x y -> y == fromIntegral x) zeros (I.repeat (1 :: Int)) + +zipWith3Repeat1 :: Infinite Bool +zipWith3Repeat1 = I.zipWith3 (\x y z -> x == fromIntegral (y + z)) (I.repeat (1 :: Int)) zeros zeros + +zipWith3Repeat2 :: Infinite Bool +zipWith3Repeat2 = I.zipWith3 (\x y z -> y == fromIntegral (x + z)) zeros (I.repeat (1 :: Int)) zeros + +zipWith3Repeat3 :: Infinite Bool +zipWith3Repeat3 = I.zipWith3 (\x y z -> z == fromIntegral (x + y)) zeros zeros (I.repeat (1 :: Int)) + +zipWith4Repeat1 :: Infinite Bool +zipWith4Repeat1 = I.zipWith4 (\x y z t -> x == fromIntegral (y + z + t)) (I.repeat (1 :: Int)) zeros zeros zeros + +zipWith4Repeat2 :: Infinite Bool +zipWith4Repeat2 = I.zipWith4 (\x y z t -> y == fromIntegral (x + z + t)) zeros (I.repeat (1 :: Int)) zeros zeros + +zipWith4Repeat3 :: Infinite Bool +zipWith4Repeat3 = I.zipWith4 (\x y z t -> z == fromIntegral (x + y + t)) zeros zeros (I.repeat (1 :: Int)) zeros + +zipWith4Repeat4 :: Infinite Bool +zipWith4Repeat4 = I.zipWith4 (\x y z t -> t == fromIntegral (x + y + z)) zeros zeros zeros (I.repeat (1 :: Int)) + +zipWith5Repeat1 :: Infinite Bool +zipWith5Repeat1 = I.zipWith5 (\x y z t u -> x == fromIntegral (y + z + t + u)) (I.repeat (1 :: Int)) zeros zeros zeros zeros + +zipWith5Repeat2 :: Infinite Bool +zipWith5Repeat2 = I.zipWith5 (\x y z t u -> y == fromIntegral (x + z + t + u)) zeros (I.repeat (1 :: Int)) zeros zeros zeros + +zipWith5Repeat3 :: Infinite Bool +zipWith5Repeat3 = I.zipWith5 (\x y z t u -> z == fromIntegral (x + y + t + u)) zeros zeros (I.repeat (1 :: Int)) zeros zeros + +zipWith5Repeat4 :: Infinite Bool +zipWith5Repeat4 = I.zipWith5 (\x y z t u -> t == fromIntegral (x + y + z + u)) zeros zeros zeros (I.repeat (1 :: Int)) zeros + +zipWith5Repeat5 :: Infinite Bool +zipWith5Repeat5 = I.zipWith5 (\x y z t u -> u == fromIntegral (x + y + z + t)) zeros zeros zeros zeros (I.repeat (1 :: Int)) + +zipWith6Repeat1 :: Infinite Bool +zipWith6Repeat1 = I.zipWith6 (\x y z t u v -> x == fromIntegral (y + z + t + u + v)) (I.repeat (1 :: Int)) zeros zeros zeros zeros zeros + +zipWith6Repeat2 :: Infinite Bool +zipWith6Repeat2 = I.zipWith6 (\x y z t u v -> y == fromIntegral (x + z + t + u + v)) zeros (I.repeat (1 :: Int)) zeros zeros zeros zeros + +zipWith6Repeat3 :: Infinite Bool +zipWith6Repeat3 = I.zipWith6 (\x y z t u v -> z == fromIntegral (x + y + t + u + v)) zeros zeros (I.repeat (1 :: Int)) zeros zeros zeros + +zipWith6Repeat4 :: Infinite Bool +zipWith6Repeat4 = I.zipWith6 (\x y z t u v -> t == fromIntegral (x + y + z + u + v)) zeros zeros zeros (I.repeat (1 :: Int)) zeros zeros + +zipWith6Repeat5 :: Infinite Bool +zipWith6Repeat5 = I.zipWith6 (\x y z t u v -> u == fromIntegral (x + y + z + t + v)) zeros zeros zeros zeros (I.repeat (1 :: Int)) zeros + +zipWith6Repeat6 :: Infinite Bool +zipWith6Repeat6 = I.zipWith6 (\x y z t u v -> v == fromIntegral (x + y + z + t + u)) zeros zeros zeros zeros zeros (I.repeat (1 :: Int)) + +zipWith7Repeat1 :: Infinite Bool +zipWith7Repeat1 = I.zipWith7 (\x y z t u v w -> x == fromIntegral (y + z + t + u + v + w)) (I.repeat (1 :: Int)) zeros zeros zeros zeros zeros zeros + +zipWith7Repeat2 :: Infinite Bool +zipWith7Repeat2 = I.zipWith7 (\x y z t u v w -> y == fromIntegral (x + z + t + u + v + w)) zeros (I.repeat (1 :: Int)) zeros zeros zeros zeros zeros + +zipWith7Repeat3 :: Infinite Bool +zipWith7Repeat3 = I.zipWith7 (\x y z t u v w -> z == fromIntegral (x + y + t + u + v + w)) zeros zeros (I.repeat (1 :: Int)) zeros zeros zeros zeros + +zipWith7Repeat4 :: Infinite Bool +zipWith7Repeat4 = I.zipWith7 (\x y z t u v w -> t == fromIntegral (x + y + z + u + v + w)) zeros zeros zeros (I.repeat (1 :: Int)) zeros zeros zeros + +zipWith7Repeat5 :: Infinite Bool +zipWith7Repeat5 = I.zipWith7 (\x y z t u v w -> u == fromIntegral (x + y + z + t + v + w)) zeros zeros zeros zeros (I.repeat (1 :: Int)) zeros zeros + +zipWith7Repeat6 :: Infinite Bool +zipWith7Repeat6 = I.zipWith7 (\x y z t u v w -> v == fromIntegral (x + y + z + t + u + w)) zeros zeros zeros zeros zeros (I.repeat (1 :: Int)) zeros + +zipWith7Repeat7 :: Infinite Bool +zipWith7Repeat7 = I.zipWith7 (\x y z t u v w -> w == fromIntegral (x + y + z + t + u + v)) zeros zeros zeros zeros zeros zeros (I.repeat (1 :: Int)) + +main :: IO () +main = defaultMain $ testGroup "All" + [ $(inspectTest $ 'foldrMap `hasNoType` ''Word) + , $(inspectTest $ 'foldrConsMap `hasNoType` ''Word) + , $(inspectTest $ 'mapMap `hasNoType` ''Word) + , $(inspectTest $ 'mapId `hasNoType` ''Word) + , $(inspectTest $ 'mapCoerce ==- 'mapId) + , $(inspectTest $ 'headIterate `hasNoType` ''Infinite) + , $(inspectTest $ 'foldrIterate `hasNoType` ''Infinite) + , $(inspectTest $ 'foldrIterate' `hasNoType` ''Infinite) + , $(inspectTest $ 'foldrRepeat `hasNoType` ''Infinite) + , $(inspectTest $ 'headFilterIterate `hasNoType` ''Infinite) + , $(inspectTest $ 'filterFilter ==- 'filterFilter') + , $(inspectTest $ 'foldrScanl `hasNoType` ''Word) + , $(inspectTest $ 'foldrScanl' `hasNoType` ''Word) + , $(inspectTest $ 'takeRepeat `hasNoType` ''Infinite) + , $(inspectTest $ 'takeDropRepeat `hasNoType` ''Infinite) + , $(inspectTest $ 'takeWhileIterate `hasNoType` ''Infinite) + , $(inspectTest $ 'takeWhileDropWhileIterate `hasNoType` ''Infinite) + , $(inspectTest $ 'foldrCycle `hasNoType` ''Infinite) + , $(inspectTest $ 'foldrWordsCycle `hasNoType` ''NonEmpty) + , $(inspectTest $ 'mapAccumLRepeat `hasNoType` ''Word) + + , $(inspectTest $ 'takeFilterIterate `hasNoType` ''Infinite) + , $(inspectTest $ 'sumTakeFilterIterate `hasNoTypes` [''Infinite, ''[]]) + , $(inspectTest $ 'takeFilterCycle `hasNoType` ''Infinite) + , $(inspectTest $ 'takeFilterEllipsis3 `hasNoType` ''Infinite) + , $(inspectTest $ 'takeFilterEllipsis4 `hasNoType` ''Infinite) + , $(inspectTest $ 'sumTakeFilterEllipsis3 `hasNoTypes` [''Infinite, ''[]]) + , $(inspectTest $ 'sumTakeFilterEllipsis4 `hasNoTypes` [''Infinite, ''[]]) + + , $(inspectTest $ 'takeToListFilterIterate `hasNoType` ''Infinite) + , $(inspectTest $ 'sumTakeToListFilterIterate `hasNoTypes` [''Infinite, ''[]]) + , $(inspectTest $ 'takeToListFilterCycle `hasNoType` ''Infinite) + , $(inspectTest $ 'takeToListFilterEllipsis3 `hasNoType` ''Infinite) + , $(inspectTest $ 'takeToListFilterEllipsis4 `hasNoType` ''Infinite) + , $(inspectTest $ 'sumTakeToListFilterEllipsis3 `hasNoTypes` [''Infinite, ''[]]) + , $(inspectTest $ 'sumTakeToListFilterEllipsis4 `hasNoTypes` [''Infinite, ''[]]) + + , $(inspectTest $ 'headFilterMapEllipsis3 `hasNoTypes` [''Infinite, ''[]]) + , $(inspectTest $ 'headFilterMapEllipsis4 `hasNoTypes` [''Infinite, ''[]]) + , $(inspectTest $ 'toListConcatRepeat `hasNoType` ''Infinite) + , $(inspectTest $ 'toListConcatMapRepeat `hasNoType` ''Infinite) + , $(inspectTest $ 'toListIntersperseRepeat `hasNoType` ''Infinite) + , $(inspectTest $ 'toListIntercalateRepeat `hasNoType` ''Infinite) + , $(inspectTest $ 'headMapZipIterate `hasNoType` ''Word) + , $(inspectTest $ 'headMapFlipZipIterate `hasNoType` ''Int) + + , $(inspectTest $ 'zipWithRepeat1 `hasNoType` ''Int) + , $(inspectTest $ 'zipWithRepeat2 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith3Repeat1 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith3Repeat2 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith3Repeat3 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith4Repeat1 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith4Repeat2 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith4Repeat3 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith4Repeat4 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith5Repeat1 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith5Repeat2 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith5Repeat3 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith5Repeat4 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith5Repeat5 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith6Repeat1 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith6Repeat2 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith6Repeat3 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith6Repeat4 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith6Repeat5 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith6Repeat6 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith7Repeat1 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith7Repeat2 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith7Repeat3 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith7Repeat4 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith7Repeat5 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith7Repeat6 `hasNoType` ''Int) + , $(inspectTest $ 'zipWith7Repeat7 `hasNoType` ''Int) + ] + +invertResult :: TestTree -> TestTree +invertResult = wrapTest (fmap change) + where + change r + | resultSuccessful r + = r { resultOutcome = Failure TestFailed, resultShortDescription = "FAIL" } + | otherwise + = r { resultOutcome = Success, resultShortDescription = "OK", resultDescription = "" } diff --git a/test/Properties.hs b/test/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Properties.hs @@ -0,0 +1,472 @@ +-- | +-- Copyright: (c) 2022 Bodigrim +-- Licence: BSD3 + +{-# LANGUAGE PostfixOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use <$>" #-} +{-# HLINT ignore "Monad law, left identity" #-} +{-# HLINT ignore "Monad law, right identity" #-} + +module Main where + +import Test.QuickCheck.Function +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +import Control.Applicative +import Control.Monad +import Data.Bifunctor +import qualified Data.List as L +import Data.List.Infinite (Infinite(..)) +import qualified Data.List.Infinite as I +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Numeric.Natural + +instance Arbitrary a => Arbitrary (Infinite a) where + arbitrary = (:<) <$> arbitrary <*> arbitrary + shrink = const [] + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = (:|) <$> arbitrary <*> arbitrary + +trim :: Infinite a -> [a] +trim = I.take 10 + +trim1 :: Infinite a -> [a] +trim1 = I.take 11 + +mapMapFusion :: Infinite Int -> Infinite Int +mapMapFusion xs = I.map fromIntegral (I.map fromIntegral xs :: Infinite Word) + +main :: IO () +main = defaultMain $ testGroup "All" + [ testProperty "head" $ + \(Blind (xs :: Infinite Int)) -> + I.head xs == L.head (trim xs) + , testProperty "tail" $ + \(Blind (xs :: Infinite Int)) -> + trim (I.tail xs) == L.tail (trim1 xs) + , testProperty "uncons" $ + \(Blind (xs :: Infinite Int)) -> + Just (fmap trim (I.uncons xs)) == L.uncons (trim1 xs) + + , testProperty "map" $ + \(applyFun -> f :: Int -> Word) (Blind (xs :: Infinite Int)) -> + trim (I.map f xs) == L.map f (trim xs) + + , testProperty "fmap" $ + \(applyFun -> f :: Int -> Int) (Blind (xs :: Infinite Int)) -> + trim (fmap f xs) == fmap f (trim xs) + , testProperty "<$" $ + \(x :: Word) (Blind (xs :: Infinite Int)) -> + trim (x <$ xs) == trim (fmap (const x) xs) + + , testProperty "pure" $ + \(applyFun -> f :: Int -> Word) (x :: Int) -> + trim (pure f <*> pure x) == trim (pure (f x)) + , testProperty "*>" $ + \(Blind (xs :: Infinite Int)) (Blind (ys :: Infinite Word)) -> + trim (xs *> ys) == trim ((id <$ xs) <*> ys) + , testProperty "<*" $ + \(Blind (xs :: Infinite Int)) (Blind (ys :: Infinite Word)) -> + trim (xs <* ys) == trim (liftA2 const xs ys) + + , testProperty ">>= 1" $ + \x ((I.cycle .) . applyFun -> k :: Int -> Infinite Word) -> + trim (return x >>= k) == trim (k x) + , testProperty ">>= 2" $ + \(Blind (xs :: Infinite Int)) -> + trim (xs >>= return) == trim xs + , testProperty ">>= 3" $ + \(Blind xs) ((I.cycle .) . applyFun -> k :: Int -> Infinite Word) ((I.cycle .) . applyFun -> h :: Word -> Infinite Char) -> + trim (xs >>= (k >=> h)) == trim ((xs >>= k) >>= h) + , testProperty ">>" $ + \(Blind (xs :: Infinite Int)) (Blind (ys :: Infinite Word)) -> + trim (xs >> ys) == trim ys + + , testProperty "concat" $ + \(Blind (xs :: Infinite (NonEmpty Int))) -> + trim (I.concat xs) == L.take 10 (L.concatMap NE.toList (I.toList xs)) + , testProperty "concatMap" $ + \(applyFun -> f :: Int -> NonEmpty Word) (Blind xs) -> + trim (I.concatMap f xs) == L.take 10 (L.concatMap (NE.toList . f) (I.toList xs)) + + , testProperty "intersperse" $ + \(x :: Int) (Blind xs) -> + I.take 19 (I.intersperse x xs) == L.intersperse x (trim xs) + , testProperty "intersperse laziness 1" $ + I.head (I.intersperse undefined ('q' :< undefined)) == 'q' + , testProperty "intersperse laziness 2" $ + I.take 2 (I.intersperse 'w' ('q' :< undefined)) == "qw" + + , testProperty "intercalate" $ + \(x :: NonEmpty Int) (Blind xs) -> + I.take (sum (map length (trim xs)) + 9 * length x) (I.intercalate x xs) == L.intercalate (NE.toList x) (trim xs) + , testProperty "intercalate laziness 1" $ + I.take 3 (I.intercalate undefined ("foo" :< undefined)) == "foo" + , testProperty "intercalate laziness 2" $ + I.take 6 (I.intercalate (NE.fromList "bar") ("foo" :< undefined)) == "foobar" + + , testProperty "interleave 1" $ + \(Blind (xs :: Infinite Int)) (Blind ys) -> + trim (I.map snd (I.filter fst (I.zip (I.cycle (True :| [False])) (I.interleave xs ys)))) == trim xs + , testProperty "interleave 2" $ + \(Blind (xs :: Infinite Int)) (Blind ys) -> + trim (I.map snd (I.filter fst (I.zip (I.cycle (False :| [True])) (I.interleave xs ys)))) == trim ys + , testProperty "interleave laziness" $ + I.head (I.interleave ('a' :< undefined) undefined) == 'a' + + , testProperty "transpose []" $ + \(fmap getBlind -> xss :: [Infinite Int]) -> not (null xss) ==> + trim (I.transpose xss) == L.transpose (map trim xss) + , testProperty "transpose NE" $ + \(fmap getBlind -> xss :: NonEmpty (Infinite Int)) -> + NE.fromList (trim (I.transpose xss)) == NE.transpose (NE.map (NE.fromList . trim) xss) + , testProperty "transpose laziness 1" $ + I.head (I.transpose ['a' :< undefined, 'b' :< undefined]) == "ab" + , testProperty "transpose laziness 2" $ + I.head (I.transpose (('a' :< undefined) :| ['b' :< undefined])) == 'a' :| "b" + + , testProperty "subsequences" $ + \(Blind (xs :: Infinite Int)) -> + I.take 16 (I.subsequences xs) == L.subsequences (I.take 4 xs) + , testProperty "subsequences laziness 1" $ + I.head (I.subsequences undefined) == "" + , testProperty "subsequences laziness 2" $ + I.take 2 (I.subsequences ('q' :< undefined)) == ["", "q"] + + , testProperty "permutations" $ + \(Blind (xs :: Infinite Int)) -> + map (I.take 4) (I.take 24 (I.permutations xs)) == L.permutations (I.take 4 xs) + , testProperty "permutations laziness" $ + I.take 6 (I.map (I.take 3) (I.permutations ('q' :< 'w' :< 'e' :< undefined))) == ["qwe","wqe","ewq","weq","eqw","qew"] + + , testProperty "... Bool" $ + \(x :: Bool) -> + trim (x I....) === L.take 10 (L.cycle [x..]) + , testProperty "... Int" $ + \(x :: Int) -> + trim (x I....) == L.take 10 (L.cycle [x..]) + , testProperty "... Int maxBound" $ + \(NonNegative (x' :: Int)) -> let x = maxBound - x' in + trim (x I....) == L.take 10 (L.cycle [x..]) + , testProperty "... Word" $ + \(x :: Word) -> + trim (x I....) == L.take 10 (L.cycle [x..]) + , testProperty "... Word maxBound" $ + \(NonNegative (x' :: Word)) -> let x = maxBound - x' in + trim (x I....) == L.take 10 (L.cycle [x..]) + , testProperty "... Integer" $ + \(x :: Integer) -> + trim (x I....) == L.take 10 (L.cycle [x..]) + , testProperty "... Natural" $ + \(NonNegative (x' :: Integer)) -> let x = fromInteger x' :: Natural in + trim (x I....) == L.take 10 (L.cycle [x..]) + + , testProperty ".... Bool" $ + \(x :: Bool) y -> + trim ((x, y) I.....) == L.take 10 (L.cycle [x, y..]) + , testProperty ".... Int" $ + \(x :: Int) y -> + trim ((x, y) I.....) == L.take 10 (L.cycle [x, y..]) .&&. + trim ((maxBound + x, y) I.....) == L.take 10 (L.cycle [maxBound + x, y..]) && + trim ((x, maxBound + y) I.....) == L.take 10 (L.cycle [x, maxBound + y..]) && + trim ((maxBound + x, maxBound + y) I.....) == L.take 10 (L.cycle [maxBound + x, maxBound + y..]) + , testProperty ".... Word" $ + \(x :: Word) y -> + trim ((x, y) I.....) == L.take 10 (L.cycle [x, y..]) .&&. + trim ((maxBound + x, y) I.....) == L.take 10 (L.cycle [maxBound + x, y..]) && + trim ((x, maxBound + y) I.....) == L.take 10 (L.cycle [x, maxBound + y..]) && + trim ((maxBound + x, maxBound + y) I.....) == L.take 10 (L.cycle [maxBound + x, maxBound + y..]) + , testProperty ".... Integer" $ + \(x :: Integer) y -> + trim ((x, y) I.....) == L.take 10 (L.cycle [x, y..]) + , testProperty ".... Natural" $ + \(NonNegative (x' :: Integer)) (NonNegative (y' :: Integer)) -> + let x = fromInteger x' :: Natural in let y = fromInteger y' in + trim ((x, y) I.....) == L.take 10 (L.cycle [x, y..]) + + , testProperty "toList" $ + \(Blind (xs :: Infinite Int)) -> + L.take 10 (I.toList xs) == trim xs + + , 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" $ + I.head (I.scanl undefined 'q' undefined) == '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" $ + I.head (I.scanl' undefined 'q' undefined) == 'q' + , testProperty "scanl1" $ + \(curry . applyFun -> f :: Int -> Int -> Int) (Blind xs) -> + trim (I.scanl1 f xs) == L.scanl1 f (trim xs) + , testProperty "scanl1 laziness" $ + I.head (I.scanl1 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 "mapAccumL laziness" $ + I.head (I.mapAccumL (\_ x -> (undefined, x)) undefined ('q' :< undefined)) == 'q' + + , testProperty "iterate" $ + \(applyFun -> f :: Int -> Int) s -> + trim (I.iterate f s) == L.take 10 (L.iterate f s) + , testProperty "iterate laziness" $ + I.head (I.iterate undefined 'q') == 'q' + , testProperty "iterate'" $ + \(applyFun -> f :: Int -> Int) s -> + trim (I.iterate' f s) == L.take 10 (L.iterate f s) + , testProperty "iterate' laziness" $ + I.head (I.iterate' undefined 'q') == 'q' + + , testProperty "repeat" $ + \(s :: Int) -> + trim (I.repeat s) == L.replicate 10 s + + , testProperty "cycle" $ + \(xs :: NonEmpty Int) -> + trim (I.cycle xs) == L.take 10 (L.cycle (NE.toList xs)) + , testProperty "cycle laziness" $ + I.head (I.cycle ('q' :| undefined)) == 'q' + + , testProperty "unfoldr" $ + \(applyFun -> f :: Word -> (Int, Word)) s -> + trim (I.unfoldr f s) == L.take 10 (L.unfoldr (Just . f) s) + , testProperty "unfoldr laziness" $ + I.head (I.unfoldr (, undefined) 'q') == 'q' + + , testProperty "take" $ + \n (Blind (xs :: Infinite Int)) -> + L.take 10 (I.take n xs) == L.take n (trim xs) + , testProperty "take laziness 1" $ + I.take 0 undefined == "" + , testProperty "take laziness 2" $ + I.take 1 ('q' :< undefined) == "q" + , testProperty "drop" $ + \n (Blind (xs :: Infinite Int)) -> + trim (I.drop n xs) == L.drop n (I.take (max n 0 + 10) xs) + , testProperty "splitAt" $ + \n (Blind (xs :: Infinite Int)) -> + bimap (L.take 10) trim (I.splitAt n xs) == + first (L.take 10) (L.splitAt n (I.take (max n 0 + 10) xs)) + , testProperty "splitAt laziness 1" $ + fst (I.splitAt 0 undefined) == "" + , testProperty "splitAt laziness 2" $ + fst (I.splitAt 1 ('q' :< undefined)) == "q" + + , testProperty "takeWhile" $ + \(applyFun -> f :: Ordering -> Bool) (Blind xs) -> + let ys = L.take 10 (I.takeWhile f xs) in + L.take 10 (L.takeWhile f (I.take (length ys + 10) xs)) == + L.take 10 (I.takeWhile f xs) + , testProperty "takeWhile laziness 1" $ + L.null (I.takeWhile (const False) ('q' :< undefined)) + , testProperty "takeWhile laziness 2" $ + L.head (I.takeWhile (const True) ('q' :< undefined)) == 'q' + , testProperty "fst . span" $ + \(applyFun -> f :: Ordering -> Bool) (Blind xs) -> + let ys = L.take 10 (fst (I.span f xs)) in + L.take 10 (L.takeWhile f (I.take (length ys + 10) xs)) == + L.take 10 (fst (I.span f xs)) + , testProperty "fst . break" $ + \(applyFun -> f :: Ordering -> Bool) (Blind xs) -> + let ys = L.take 10 (fst (I.break f xs)) in + L.take 10 (L.takeWhile (not . f) (I.take (length ys + 10) xs)) == + L.take 10 (fst (I.break f xs)) + , testProperty "dropWhile" $ + \(applyFun -> f :: Ordering -> Bool) (Blind xs) -> + trim (L.foldr (:<) (I.dropWhile f xs) (I.takeWhile f xs)) == trim xs + , testProperty "snd . span" $ + \(applyFun -> f :: Ordering -> Bool) (Blind xs) -> + trim (L.foldr (:<) (snd (I.span f xs)) (I.takeWhile f xs)) == trim xs + , testProperty "snd . break" $ + \(applyFun -> f :: Ordering -> Bool) (Blind xs) -> + trim (L.foldr (:<) (snd (I.break f xs)) (I.takeWhile (not . f) xs)) == trim xs + , testProperty "span laziness" $ + L.head (fst (I.span (/= '\n') ('q' :< undefined))) == 'q' + , testProperty "break laziness" $ + L.head (fst (I.break (== '\n') ('q' :< undefined))) == 'q' + + , testProperty "stripPrefix" $ + \(xs :: [Int]) (Blind (ys :: Infinite Int)) -> + fmap trim (I.stripPrefix xs ys) == fmap (L.take 10) (L.stripPrefix xs (I.take (length xs + 10) ys)) + , testProperty "stripPrefix laziness 1" $ + isNothing (I.stripPrefix ('q' : undefined) ('w' :< undefined)) + , testProperty "stripPrefix laziness 2" $ + isJust (I.stripPrefix "foo" ('f' :< 'o' :< 'o' :< undefined)) + , testProperty "isPrefixOf" $ + \(xs :: [Int]) (Blind (ys :: Infinite Int)) -> + I.isPrefixOf xs ys == L.isPrefixOf xs (I.take (length xs + 10) ys) + , testProperty "isPrefixOf laziness 1" $ + not (I.isPrefixOf ('q' : undefined) ('w' :< undefined)) + , testProperty "isPrefixOf laziness 2" $ + I.isPrefixOf "foo" ('f' :< 'o' :< 'o' :< undefined) + + , testProperty "zip" $ + \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) -> + trim (I.zip xs1 xs2) == L.zip (trim xs1) (trim xs2) + , testProperty "zip3" $ + \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) (Blind (xs3 :: Infinite Bool)) -> + trim (I.zip3 xs1 xs2 xs3) == L.zip3 (trim xs1) (trim xs2) (trim xs3) + , testProperty "zip4" $ + \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) (Blind (xs3 :: Infinite Bool)) (Blind (xs4 :: Infinite Char)) -> + trim (I.zip4 xs1 xs2 xs3 xs4) == L.zip4 (trim xs1) (trim xs2) (trim xs3) (trim xs4) + , testProperty "zip5" $ + \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) (Blind (xs3 :: Infinite Bool)) (Blind (xs4 :: Infinite Char)) (Blind (xs5 :: Infinite Ordering)) -> + trim (I.zip5 xs1 xs2 xs3 xs4 xs5) == L.zip5 (trim xs1) (trim xs2) (trim xs3) (trim xs4) (trim xs5) + , testProperty "zip6" $ + \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) (Blind (xs3 :: Infinite Bool)) (Blind (xs4 :: Infinite Char)) (Blind (xs5 :: Infinite Ordering)) (Blind (xs6 :: Infinite String)) -> + trim (I.zip6 xs1 xs2 xs3 xs4 xs5 xs6) == L.zip6 (trim xs1) (trim xs2) (trim xs3) (trim xs4) (trim xs5) (trim xs6) + , testProperty "zip7" $ + \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) (Blind (xs3 :: Infinite Bool)) (Blind (xs4 :: Infinite Char)) (Blind (xs5 :: Infinite Ordering)) (Blind (xs6 :: Infinite String)) (Blind (xs7 :: Infinite Integer)) -> + trim (I.zip7 xs1 xs2 xs3 xs4 xs5 xs6 xs7) == L.zip7 (trim xs1) (trim xs2) (trim xs3) (trim xs4) (trim xs5) (trim xs6) (trim xs7) + + , testProperty "unzip" $ + \(Blind (xs :: Infinite (Int, Word))) -> + bimap trim trim (I.unzip xs) == L.unzip (trim xs) + , testProperty "unzip3" $ + \(Blind (xs :: Infinite (Int, Word, Bool))) -> + (\(xs1, xs2, xs3) -> (trim xs1, trim xs2, trim xs3)) (I.unzip3 xs) == L.unzip3 (trim xs) + , testProperty "unzip4" $ + \(Blind (xs :: Infinite (Int, Word, Bool, Char))) -> + (\(xs1, xs2, xs3, xs4) -> (trim xs1, trim xs2, trim xs3, trim xs4)) (I.unzip4 xs) == L.unzip4 (trim xs) + , testProperty "unzip5" $ + \(Blind (xs :: Infinite (Int, Word, Bool, Char, Ordering))) -> + (\(xs1, xs2, xs3, xs4, xs5) -> (trim xs1, trim xs2, trim xs3, trim xs4, trim xs5)) (I.unzip5 xs) == L.unzip5 (trim xs) + , testProperty "unzip6" $ + \(Blind (xs :: Infinite (Int, Word, Bool, Char, Ordering, String))) -> + (\(xs1, xs2, xs3, xs4, xs5, xs6) -> (trim xs1, trim xs2, trim xs3, trim xs4, trim xs5, trim xs6)) (I.unzip6 xs) == L.unzip6 (trim xs) + , testProperty "unzip7" $ + \(Blind (xs :: Infinite (Int, Word, Bool, Char, Ordering, String, Integer))) -> + (\(xs1, xs2, xs3, xs4, xs5, xs6, xs7) -> (trim xs1, trim xs2, trim xs3, trim xs4, trim xs5, trim xs6, trim xs7)) (I.unzip7 xs) == L.unzip7 (trim xs) + + , testProperty "lines" $ + \(Blind (xs :: Infinite Char)) -> + I.take 3 (I.lines xs) == L.take 3 (L.lines (I.foldr (:) xs)) + , testProperty "lines laziness 1" $ + L.head (I.head (I.lines ('q' :< undefined))) == 'q' + , testProperty "lines laziness 2" $ + L.null (I.head (I.lines ('\n' :< undefined))) + , testProperty "words" $ + \(Blind (xs :: Infinite Char)) -> + I.take 3 (I.map NE.toList (I.words xs)) == L.take 3 (L.words (I.foldr (:) xs)) + , testProperty "words laziness" $ + NE.head (I.head (I.words ('q' :< undefined))) == 'q' + , testProperty "unlines" $ + \(Blind (xs :: Infinite [Char])) -> + trim (I.unlines xs) == L.take 10 (L.unlines (trim xs)) + , testProperty "unlines laziness" $ + I.take 2 (I.unlines ("q" :< undefined)) == "q\n" + , testProperty "unwords" $ + \(Blind (xs :: Infinite (NonEmpty Char))) -> + trim (I.unwords xs) == L.take 10 (L.unwords (L.map NE.toList (trim xs))) + , testProperty "unwords laziness" $ + I.take 2 (I.unwords (('q' :| []) :< undefined)) == "q " + + , testProperty "group" $ + \(Blind (ys :: Infinite Ordering)) -> + trim (I.group ys) == L.take 10 (NE.group (I.foldr (:) ys)) + , testProperty "group laziness" $ + NE.head (I.head (I.group ('q' :< undefined))) == 'q' + , testProperty "nub" $ + \(Blind (ys :: Infinite (Large Int))) -> + I.take 3 (I.nub ys) == L.take 3 (L.nub (I.foldr (:) ys)) + , testProperty "nub laziness" $ + I.head (I.nub ('q' :< undefined)) == 'q' + + , testProperty "delete" $ + \(x :: Ordering) (Blind xs) -> + trim (I.delete x xs) == L.take 10 (L.delete x (I.foldr (:) xs)) + , testProperty "delete laziness" $ + I.head (I.delete 'q' ('w' :< undefined)) == 'w' + , testProperty "insert" $ + \(x :: Int) (Blind xs) -> + trim (I.insert x xs) == L.take 10 (L.insert x (I.foldr (:) xs)) + , testProperty "insert laziness" $ + I.take 2 (I.insert 'q' ('w' :< undefined)) == "qw" + + , testProperty "\\\\" $ + \(Blind (xs :: Infinite Ordering)) ys -> + trim (xs I.\\ ys) == L.take 10 (I.foldr (:) xs L.\\ ys) + , testProperty "\\\\ laziness" $ + I.head (('q' :< undefined) I.\\ []) == 'q' + , testProperty "union" $ + \xs (Blind (ys :: Infinite Ordering)) -> + I.take 3 (I.union xs ys) == L.take 3 (xs `L.union` I.foldr (:) ys) + , testProperty "union laziness" $ + I.head (I.union ('q' : undefined) undefined) == 'q' + , testProperty "intersect" $ + \(Blind (xs :: Infinite Ordering)) ys -> not (null ys) ==> + I.head (I.intersect xs ys) == L.head (I.foldr (:) xs `L.intersect` ys) + , testProperty "intersect laziness" $ + I.head (I.intersect ('q' :< undefined) ('q' : undefined)) == 'q' + + , testProperty "inits" $ + \(Blind (xs :: Infinite Int)) -> + I.take 21 (I.inits xs) == L.inits (I.take 20 xs) + , testProperty "inits laziness 1" $ + L.null (I.head (I.inits undefined)) + , testProperty "inits laziness 2" $ + I.take 2 (I.inits ('q' :< undefined)) == ["", "q"] + , testProperty "inits1" $ + \(Blind (xs :: Infinite Int)) -> + map NE.toList (trim (I.inits1 xs)) == L.tail (L.inits (trim xs)) + , testProperty "tails" $ + \(Blind (xs :: Infinite Int)) -> + map trim (trim (I.tails xs)) === map (L.take 10) (L.take 10 (L.tails (I.take 20 xs))) + , testProperty "tails laziness" $ + I.head (I.head (I.tails ('q' :< undefined))) == 'q' + + , testProperty "lookup" $ + \(xs :: [(Int, Word)]) y zs -> + let pairs = NE.fromList (xs ++ (y : zs)) in + Just (I.lookup (fst y) (I.cycle pairs)) == L.lookup (fst y) (NE.toList pairs) + , testProperty "lookup laziness" $ + I.lookup True ((True, 'q') :< undefined) == 'q' + , testProperty "find" $ + \(xs :: [(Int, Word)]) y zs -> + let pairs = NE.fromList (xs ++ (y : zs)) in + Just (I.find ((== snd y) . snd) (I.cycle pairs)) == L.find ((== snd y) . snd) (NE.toList pairs) + , testProperty "find laziness" $ + I.find odd (1 :< undefined) == (1 :: Int) + + , testProperty "filter" $ + \(applyFun -> f :: Int -> Bool) xs (Blind ys) -> + let us = L.filter f xs in + us == I.take (length us) (I.filter f (I.prependList xs ys)) + , testProperty "partition" $ + \(applyFun -> f :: Int -> Bool) xs (Blind ys) -> + let (us, vs) = L.partition f xs in + let (us', vs') = I.partition f (I.prependList xs ys) in + us == I.take (length us) us' && vs == I.take (length vs) vs' + + , testProperty "!!" $ + \(Blind (xs :: Infinite Int)) n -> + xs I.!! n == I.foldr (:) xs L.!! fromIntegral n + , testProperty "tabulate" $ + \(applyFun -> f :: Word -> Char) n -> + I.tabulate f I.!! n == f n + + , testProperty "elemIndex" $ + \xs (x :: Int) (Blind ys) -> + let zs = I.prependList xs (x :< ys) in + Just (fromIntegral (I.elemIndex x zs)) == L.elemIndex x (I.foldr (:) zs) + , testProperty "elemIndices" $ + \xs (x :: Ordering) (Blind ys) -> + let zs = I.prependList xs (x :< ys) in + let is = L.elemIndices x (xs ++ [x]) in + map fromIntegral (I.take (length is) (I.elemIndices x zs)) == is + ]