├── fourmolu.yaml ├── src └── Data │ └── List │ ├── Infinite │ ├── Internal.hs │ ├── Set.hs │ └── Zip.hs │ └── Infinite.hs ├── .github └── workflows │ ├── i386-ci.yml │ └── haskell-ci.yml ├── CHANGELOG.md ├── LICENSE ├── infinite-list.cabal ├── README.md └── test ├── Fusion.hs └── Properties.hs /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | function-arrows: leading 3 | comma-style: leading 4 | import-export-style: diff-friendly 5 | indent-wheres: true 6 | record-brace-space: true 7 | newlines-between-decls: 1 8 | haddock-style: single-line 9 | respectful: true 10 | fixities: [] 11 | single-constraint-parens: never 12 | -------------------------------------------------------------------------------- /src/Data/List/Infinite/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | -- | 4 | -- Copyright: (c) 2022 Bodigrim 5 | -- License: BSD3 6 | module Data.List.Infinite.Internal ( 7 | Infinite (..), 8 | build, 9 | ) where 10 | 11 | -- | Type of infinite lists. 12 | -- 13 | -- In terms of recursion schemes, 'Infinite' @a@ is a fix point of the base functor @(a,)@, 14 | -- 'Data.List.Infinite.foldr' is a catamorphism and 'Data.List.Infinite.unfoldr' is an anamorphism. 15 | data Infinite a = a :< Infinite a 16 | 17 | infixr 5 :< 18 | 19 | build :: forall a. (forall b. (a -> b -> b) -> b) -> Infinite a 20 | build g = g (:<) 21 | {-# INLINE [1] build #-} 22 | -------------------------------------------------------------------------------- /.github/workflows/i386-ci.yml: -------------------------------------------------------------------------------- 1 | name: i386-ci 2 | on: 3 | - push 4 | - pull_request 5 | 6 | defaults: 7 | run: 8 | shell: bash 9 | 10 | jobs: 11 | i386: 12 | runs-on: ubuntu-latest 13 | container: 14 | image: i386/ubuntu:bionic 15 | steps: 16 | - name: Install 17 | run: | 18 | apt-get update -y 19 | apt-get install -y autoconf build-essential zlib1g-dev libgmp-dev curl libncurses5 libtinfo5 libncurses5-dev libtinfo-dev 20 | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_INSTALL_NO_STACK=1 sh 21 | - uses: actions/checkout@v1 22 | - name: Test 23 | run: | 24 | source ~/.ghcup/env 25 | cabal update 26 | cabal test 27 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.1.3 2 | 3 | * Add `mapAccumL'`. 4 | * Make `scanl'` stricter by forcing the initial element. 5 | Cf. https://github.com/haskell/core-libraries-committee/issues/335 6 | 7 | # 0.1.2 8 | 9 | * Add `heteroZip` and `heteroZipWith`. 10 | * Add `traverse_` and `for_`. 11 | * Add `nubOrd` and `nubOrdBy`. 12 | * Add `instance MonadFix`. 13 | 14 | # 0.1.1 15 | 16 | * Add `mapMaybe` and `catMaybes`. 17 | * Add `mapEither` and `partitionEithers`. 18 | * Decrease operator precedence for `(...)` and `(....)`. 19 | * Add fusion rules for `genericTake`. 20 | * Remove harmful fusion rules for `drop` and `dropWhile`. 21 | Cf. https://gitlab.haskell.org/ghc/ghc/-/issues/23021. 22 | * Fix `instance Monad Infinite` on 32-bit machines. 23 | It was violating monad laws once the index exceeds 2^32. 24 | 25 | # 0.1 26 | 27 | * Initial release. 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Bodigrim 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Bodigrim nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Data/List/Infinite/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | -- | 5 | -- Copyright: (c) 2024 Bodigrim 6 | -- License: BSD3 7 | module Data.List.Infinite.Set ( 8 | Set, 9 | empty, 10 | member, 11 | insert, 12 | ) where 13 | 14 | -- | Okasaki red-black tree. 15 | data Set a 16 | = Empty 17 | | Red !(Set a) !a !(Set a) 18 | | Black !(Set a) !a !(Set a) 19 | 20 | empty :: Set a 21 | empty = Empty 22 | 23 | member :: (a -> a -> Ordering) -> a -> Set a -> Bool 24 | member cmp = member' 25 | where 26 | member' !x = go 27 | where 28 | go = \case 29 | Empty -> False 30 | Red left center right -> whereToGo left center right 31 | Black left center right -> whereToGo left center right 32 | 33 | whereToGo left center right = case x `cmp` center of 34 | LT -> go left 35 | EQ -> True 36 | GT -> go right 37 | {-# INLINE member #-} 38 | 39 | insert :: (a -> a -> Ordering) -> a -> Set a -> Set a 40 | insert cmp = insert' 41 | where 42 | insert' !x = blacken . go 43 | where 44 | go node = case node of 45 | Empty -> Red Empty x Empty 46 | Red left center right -> case x `cmp` center of 47 | LT -> Red (go left) center right 48 | EQ -> node 49 | GT -> Red left center (go right) 50 | Black left center right -> case x `cmp` center of 51 | LT -> balanceLeft (go left) center right 52 | EQ -> node 53 | GT -> balanceRight left center (go right) 54 | 55 | blacken node = case node of 56 | Empty -> Empty 57 | Red left center right -> Black left center right 58 | Black {} -> node 59 | {-# INLINE insert #-} 60 | 61 | balanceLeft :: Set a -> a -> Set a -> Set a 62 | balanceLeft (Red (Red a b c) d e) f g = 63 | Red (Black a b c) d (Black e f g) 64 | balanceLeft (Red a b (Red c d e)) f g = 65 | Red (Black a b c) d (Black e f g) 66 | balanceLeft left center right = 67 | Black left center right 68 | {-# INLINE balanceLeft #-} 69 | 70 | balanceRight :: Set a -> a -> Set a -> Set a 71 | balanceRight a b (Red (Red c d e) f g) = 72 | Red (Black a b c) d (Black e f g) 73 | balanceRight a b (Red c d (Red e f g)) = 74 | Red (Black a b c) d (Black e f g) 75 | balanceRight left center right = 76 | Black left center right 77 | {-# INLINE balanceRight #-} 78 | -------------------------------------------------------------------------------- /infinite-list.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: infinite-list 3 | version: 0.1.3 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | maintainer: andrew.lelechenko@gmail.com 7 | author: Bodigrim 8 | tested-with: 9 | ghc ==8.2.2 ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.4 10 | ghc ==8.10.7 ghc ==9.0.2 ghc ==9.2.8 ghc ==9.4.8 ghc ==9.6.7 11 | ghc ==9.8.4 ghc ==9.10.3 ghc ==9.12.2 ghc ==9.14.1 12 | 13 | homepage: https://github.com/Bodigrim/infinite-list 14 | synopsis: Infinite lists 15 | description: 16 | Modern lightweight library for infinite lists with fusion: 17 | . 18 | * API similar to "Data.List". 19 | * No dependencies other than `base`. 20 | * Top performance, driven by fusion. 21 | * Avoid dangerous instances like `Foldable`. 22 | * Use `NonEmpty` where applicable. 23 | * Use `Word` for indices. 24 | * Be lazy, but not too lazy. 25 | . 26 | @ 27 | {\-# LANGUAGE PostfixOperators #-\} 28 | import Data.List.Infinite (Infinite(..), (...), (....)) 29 | import qualified Data.List.Infinite as Inf 30 | @ 31 | 32 | category: Data 33 | build-type: Simple 34 | extra-doc-files: 35 | CHANGELOG.md 36 | README.md 37 | 38 | source-repository head 39 | type: git 40 | location: https://github.com/Bodigrim/infinite-list 41 | 42 | library 43 | exposed-modules: Data.List.Infinite 44 | hs-source-dirs: src 45 | other-modules: 46 | Data.List.Infinite.Internal 47 | Data.List.Infinite.Set 48 | Data.List.Infinite.Zip 49 | 50 | default-language: Haskell2010 51 | ghc-options: -Wall 52 | build-depends: base >=4.10 && <5 53 | 54 | test-suite infinite-properties 55 | type: exitcode-stdio-1.0 56 | main-is: Properties.hs 57 | hs-source-dirs: test 58 | default-language: Haskell2010 59 | ghc-options: -Wall 60 | build-depends: 61 | base, 62 | containers, 63 | infinite-list, 64 | QuickCheck, 65 | tasty, 66 | tasty-quickcheck 67 | 68 | test-suite infinite-properties-O0 69 | type: exitcode-stdio-1.0 70 | main-is: Properties.hs 71 | hs-source-dirs: test 72 | default-language: Haskell2010 73 | ghc-options: -Wall -O0 74 | build-depends: 75 | base, 76 | containers, 77 | infinite-list, 78 | QuickCheck, 79 | tasty, 80 | tasty-quickcheck 81 | 82 | test-suite infinite-fusion 83 | type: exitcode-stdio-1.0 84 | main-is: Fusion.hs 85 | hs-source-dirs: test 86 | default-language: Haskell2010 87 | ghc-options: -Wall 88 | build-depends: 89 | base, 90 | infinite-list, 91 | tasty, 92 | tasty-inspection-testing, 93 | tasty-expected-failure 94 | 95 | if impl(ghc <9.2) 96 | buildable: False 97 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # infinite-list [![Hackage](http://img.shields.io/hackage/v/infinite-list.svg)](https://hackage.haskell.org/package/infinite-list) [![Stackage LTS](http://stackage.org/package/infinite-list/badge/lts)](http://stackage.org/lts/package/infinite-list) [![Stackage Nightly](http://stackage.org/package/infinite-list/badge/nightly)](http://stackage.org/nightly/package/infinite-list) 2 | 3 | Modern lightweight library for infinite lists with fusion: 4 | 5 | * API similar to `Data.List`. 6 | * No dependencies other than `base`. 7 | * Top performance, driven by fusion. 8 | * Avoid dangerous instances like `Foldable`. 9 | * Use `NonEmpty` where applicable. 10 | * Use `Word` for indices. 11 | * Be lazy, but not too lazy. 12 | 13 | ```haskell 14 | {-# LANGUAGE PostfixOperators #-} 15 | import Data.List.Infinite (Infinite(..), (...), (....)) 16 | import qualified Data.List.Infinite as Inf 17 | ``` 18 | 19 | ## Prior art and inspiration 20 | 21 | * [`Data.Stream.Infinite`](https://hackage.haskell.org/package/streams/docs/Data-Stream-Infinite.html) from [`streams`](https://hackage.haskell.org/package/streams) package: 22 | * Large dependency footprint, e. g., `adjunctions`. 23 | * Provides dangerous instances such as `Foldable`. 24 | * No fusion framework. 25 | 26 | * [`Data.Stream`](https://hackage.haskell.org/package/Stream/docs/Data-Stream.html) from [`Stream`](https://hackage.haskell.org/package/Stream) package: 27 | * No fusion framework. 28 | * No repository or issue tracker. 29 | 30 | * [`GHC.Data.List.Infinite`](https://gitlab.haskell.org/ghc/ghc/-/blob/080fffa1015bcc0cff8ab4ad1eeb507fb7a13383/compiler/GHC/Data/List/Infinite.hs) in GHC source tree: 31 | * Limited API, only to cater for GHC internals. 32 | * Not available as a separate package outside of GHC. 33 | 34 | ## Why no `Foldable` or `Traversable`? 35 | 36 | The breakdown of members of `Foldable` is as follows: 37 | 38 | * `foldr`, `foldr1`, `foldMap`, `fold`, `toList` and `null` can be productive on infinite lists; 39 | * `foldr'`, `foldMap'` cannot, because forcing an accumulator even to a WHNF makes fold non-terminating; 40 | * `foldl`, `foldl'`, `foldl1` cannot, because no left fold can; 41 | * `length` always diverges; 42 | * `elem` either returns `True`, or does not terminate, but never returns `False`; 43 | * `maximum`, `minimum`, `sum` and `product` are unlikely to be productive, unless an underlying `instance Ord` or `instance Num` is extremely lazy. 44 | 45 | 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. 46 | 47 | 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`. We also provide `traverse_` and `for_`, but with slightly different types. 48 | 49 | ## Laziness 50 | 51 | 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`: 52 | 53 | ```haskell 54 | map :: (a -> b) -> NonEmpty a -> NonEmpty b 55 | map f ~(a :| as) = f a :| fmap f as 56 | ``` 57 | 58 | which is equivalent to 59 | 60 | ```haskell 61 | map :: (a -> b) -> NonEmpty a -> NonEmpty b 62 | map f x = (let a :| _ = x in f a) :| (let _ :| as = x in fmap f as) 63 | ``` 64 | 65 | 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. 66 | 67 | 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. 68 | 69 | ## Indexing 70 | 71 | 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`. 72 | 73 | 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. 74 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'infinite-list.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20251118 12 | # 13 | # REGENDATA ("0.19.20251118",["github","infinite-list.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | - merge_group 20 | jobs: 21 | linux: 22 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 23 | runs-on: ubuntu-24.04 24 | timeout-minutes: 25 | 60 26 | container: 27 | image: buildpack-deps:jammy 28 | continue-on-error: ${{ matrix.allow-failure }} 29 | strategy: 30 | matrix: 31 | include: 32 | - compiler: ghc-9.14.0.20251104 33 | compilerKind: ghc 34 | compilerVersion: 9.14.0.20251104 35 | setup-method: ghcup-prerelease 36 | allow-failure: false 37 | - compiler: ghc-9.12.2 38 | compilerKind: ghc 39 | compilerVersion: 9.12.2 40 | setup-method: ghcup 41 | allow-failure: false 42 | - compiler: ghc-9.10.3 43 | compilerKind: ghc 44 | compilerVersion: 9.10.3 45 | setup-method: ghcup 46 | allow-failure: false 47 | - compiler: ghc-9.8.4 48 | compilerKind: ghc 49 | compilerVersion: 9.8.4 50 | setup-method: ghcup 51 | allow-failure: false 52 | - compiler: ghc-9.6.7 53 | compilerKind: ghc 54 | compilerVersion: 9.6.7 55 | setup-method: ghcup 56 | allow-failure: false 57 | - compiler: ghc-9.4.8 58 | compilerKind: ghc 59 | compilerVersion: 9.4.8 60 | setup-method: ghcup 61 | allow-failure: false 62 | - compiler: ghc-9.2.8 63 | compilerKind: ghc 64 | compilerVersion: 9.2.8 65 | setup-method: ghcup 66 | allow-failure: false 67 | - compiler: ghc-9.0.2 68 | compilerKind: ghc 69 | compilerVersion: 9.0.2 70 | setup-method: ghcup 71 | allow-failure: false 72 | - compiler: ghc-8.10.7 73 | compilerKind: ghc 74 | compilerVersion: 8.10.7 75 | setup-method: ghcup 76 | allow-failure: false 77 | - compiler: ghc-8.8.4 78 | compilerKind: ghc 79 | compilerVersion: 8.8.4 80 | setup-method: ghcup 81 | allow-failure: false 82 | - compiler: ghc-8.6.5 83 | compilerKind: ghc 84 | compilerVersion: 8.6.5 85 | setup-method: ghcup 86 | allow-failure: false 87 | - compiler: ghc-8.4.4 88 | compilerKind: ghc 89 | compilerVersion: 8.4.4 90 | setup-method: ghcup 91 | allow-failure: false 92 | - compiler: ghc-8.2.2 93 | compilerKind: ghc 94 | compilerVersion: 8.2.2 95 | setup-method: ghcup 96 | allow-failure: false 97 | fail-fast: false 98 | steps: 99 | - name: apt-get install 100 | run: | 101 | apt-get update 102 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 103 | - name: Install GHCup 104 | run: | 105 | mkdir -p "$HOME/.ghcup/bin" 106 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 107 | chmod a+x "$HOME/.ghcup/bin/ghcup" 108 | - name: Install cabal-install 109 | run: | 110 | "$HOME/.ghcup/bin/ghcup" install cabal 3.16.0.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 111 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.16.0.0 -vnormal+nowrap" >> "$GITHUB_ENV" 112 | - name: Install GHC (GHCup) 113 | if: matrix.setup-method == 'ghcup' 114 | run: | 115 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 116 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 117 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 118 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 119 | echo "HC=$HC" >> "$GITHUB_ENV" 120 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 121 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 122 | env: 123 | HCKIND: ${{ matrix.compilerKind }} 124 | HCNAME: ${{ matrix.compiler }} 125 | HCVER: ${{ matrix.compilerVersion }} 126 | - name: Install GHC (GHCup prerelease) 127 | if: matrix.setup-method == 'ghcup-prerelease' 128 | run: | 129 | "$HOME/.ghcup/bin/ghcup" config add-release-channel prereleases 130 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 131 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 132 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 133 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 134 | echo "HC=$HC" >> "$GITHUB_ENV" 135 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 136 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 137 | env: 138 | HCKIND: ${{ matrix.compilerKind }} 139 | HCNAME: ${{ matrix.compiler }} 140 | HCVER: ${{ matrix.compilerVersion }} 141 | - name: Set PATH and environment variables 142 | run: | 143 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 144 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 145 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 146 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 147 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 148 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 149 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 150 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 151 | if [ $((HCNUMVER >= 91400)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi 152 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 153 | env: 154 | HCKIND: ${{ matrix.compilerKind }} 155 | HCNAME: ${{ matrix.compiler }} 156 | HCVER: ${{ matrix.compilerVersion }} 157 | - name: env 158 | run: | 159 | env 160 | - name: write cabal config 161 | run: | 162 | mkdir -p $CABAL_DIR 163 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 208 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 209 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 210 | rm -f cabal-plan.xz 211 | chmod a+x $HOME/.cabal/bin/cabal-plan 212 | cabal-plan --version 213 | - name: checkout 214 | uses: actions/checkout@v5 215 | with: 216 | path: source 217 | - name: initial cabal.project for sdist 218 | run: | 219 | touch cabal.project 220 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 221 | cat cabal.project 222 | - name: sdist 223 | run: | 224 | mkdir -p sdist 225 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 226 | - name: unpack 227 | run: | 228 | mkdir -p unpacked 229 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 230 | - name: generate cabal.project 231 | run: | 232 | PKGDIR_infinite_list="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/infinite-list-[0-9.]*')" 233 | echo "PKGDIR_infinite_list=${PKGDIR_infinite_list}" >> "$GITHUB_ENV" 234 | rm -f cabal.project cabal.project.local 235 | touch cabal.project 236 | touch cabal.project.local 237 | echo "packages: ${PKGDIR_infinite_list}" >> cabal.project 238 | echo "package infinite-list" >> cabal.project 239 | echo " ghc-options: -Werror=missing-methods -Werror=missing-fields" >> cabal.project 240 | if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "package infinite-list" >> cabal.project ; fi 241 | if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo " ghc-options: -Werror=unused-packages" >> cabal.project ; fi 242 | if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo "package infinite-list" >> cabal.project ; fi 243 | if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo " ghc-options: -Werror=incomplete-patterns -Werror=incomplete-uni-patterns" >> cabal.project ; fi 244 | cat >> cabal.project <> cabal.project 248 | fi 249 | $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(infinite-list)$/; }' >> cabal.project.local 250 | cat cabal.project 251 | cat cabal.project.local 252 | - name: dump install plan 253 | run: | 254 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 255 | cabal-plan 256 | - name: restore cache 257 | uses: actions/cache/restore@v4 258 | with: 259 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 260 | path: ~/.cabal/store 261 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 262 | - name: install dependencies 263 | run: | 264 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 265 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 266 | - name: build w/o tests 267 | run: | 268 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 269 | - name: build 270 | run: | 271 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 272 | - name: tests 273 | run: | 274 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 275 | - name: cabal check 276 | run: | 277 | cd ${PKGDIR_infinite_list} || false 278 | ${CABAL} -vnormal check 279 | - name: haddock 280 | run: | 281 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 282 | - name: unconstrained build 283 | run: | 284 | rm -f cabal.project.local 285 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 286 | - name: save cache 287 | if: always() 288 | uses: actions/cache/save@v4 289 | with: 290 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 291 | path: ~/.cabal/store 292 | -------------------------------------------------------------------------------- /test/Fusion.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright: (c) 2022 Bodigrim 3 | -- Licence: BSD3 4 | 5 | {-# LANGUAGE PostfixOperators #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} 8 | 9 | module Main where 10 | 11 | import Test.Tasty 12 | import Test.Tasty.ExpectedFailure 13 | import Test.Tasty.Inspection 14 | import Test.Tasty.Runners 15 | 16 | import Data.Coerce 17 | import Data.Ord 18 | import Data.List.Infinite (Infinite(..)) 19 | import qualified Data.List.Infinite as I 20 | import Data.List.NonEmpty (NonEmpty(..)) 21 | import qualified Data.List.NonEmpty as NE 22 | 23 | foldrMap :: Infinite Int -> Infinite Int 24 | foldrMap xs = I.foldr (\x acc -> fromIntegral x :< acc) (I.map fromIntegral xs :: Infinite Word) 25 | 26 | foldrConsMap :: Int -> Infinite Int -> Infinite Int 27 | foldrConsMap i xs = I.foldr (\x acc -> fromIntegral x :< acc) (fromIntegral i :< (I.map fromIntegral xs :: Infinite Word)) 28 | 29 | mapMap :: Infinite Int -> Infinite Int 30 | mapMap xs = I.map fromIntegral (I.map fromIntegral xs :: Infinite Word) 31 | 32 | mapId :: Infinite Int -> Infinite Int 33 | mapId xs = I.map id (I.map id xs) 34 | 35 | mapCoerce :: Infinite Int -> Infinite (Down Int) 36 | mapCoerce xs = I.map coerce xs 37 | 38 | headIterate :: Int -> Int 39 | headIterate x = I.head (I.iterate (+ 1) x) 40 | 41 | foldrIterate :: Int -> [Int] 42 | foldrIterate x = I.foldr (\a acc -> a : a : acc) (I.iterate (+ 1) x) 43 | 44 | foldrIterate' :: Int -> [Int] 45 | foldrIterate' x = I.foldr (\a acc -> a : a : acc) (I.iterate (+ 1) x) 46 | 47 | foldrRepeat :: Int -> [Int] 48 | foldrRepeat x = I.foldr (\a acc -> a : a : acc) (I.repeat x) 49 | 50 | headFilterIterate :: Int -> Int 51 | headFilterIterate x = I.head (I.filter (> 10) (I.iterate (+ 1) x)) 52 | 53 | filterFilter :: Infinite Int -> Infinite Int 54 | filterFilter xs = I.filter (> 10) (I.filter (> 5) xs) 55 | 56 | filterFilter' :: Infinite Int -> Infinite Int 57 | filterFilter' xs = I.filter (\x -> x > 10 && x > 5) xs 58 | 59 | foldrScanl :: Infinite Int -> Infinite Int 60 | foldrScanl xs = I.foldr (\a acc -> fromIntegral a :< acc) 61 | (I.scanl (\_acc a -> fromIntegral a) (0 :: Word) xs) 62 | 63 | foldrScanl' :: Infinite Int -> Infinite Int 64 | foldrScanl' xs = I.foldr (\a acc -> fromIntegral a :< acc) 65 | (I.scanl' (\_acc a -> fromIntegral a) (0 :: Word) xs) 66 | 67 | takeRepeat :: Int -> [Int] 68 | takeRepeat x = I.take x (I.repeat x) 69 | 70 | takeWhileIterate :: Int -> [Int] 71 | takeWhileIterate x = I.takeWhile (< 10) (I.iterate (+ 1) x) 72 | 73 | foldrCycle :: NonEmpty Int -> [Int] 74 | foldrCycle xs = I.foldr (:) (I.cycle xs) 75 | 76 | foldrWordsCycle :: [Char] -> [Char] 77 | foldrWordsCycle xs = I.foldr (\a acc -> NE.head a : acc) (I.words (I.cycle (' ' :| xs))) 78 | 79 | foldrMapAccumL :: Infinite Int -> Infinite Int 80 | foldrMapAccumL xs = I.foldr (\a acc -> fromIntegral a :< acc) 81 | (I.mapAccumL (\acc x -> (acc, fromIntegral x :: Word)) (0 :: Int) xs) 82 | 83 | mapAccumLRepeat :: Int -> Infinite Int 84 | mapAccumLRepeat n = 85 | I.mapAccumL (\acc x -> (acc, fromIntegral x)) 'q' (I.repeat (fromIntegral n :: Word)) 86 | 87 | mapAccumLRepeat' :: Int -> Infinite Int 88 | mapAccumLRepeat' n = 89 | I.mapAccumL' (\acc x -> (acc, fromIntegral x)) 'q' (I.repeat (fromIntegral n :: Word)) 90 | 91 | takeFilterIterate :: [Int] 92 | takeFilterIterate = I.take 100 $ I.filter odd $ I.iterate (+ 1) 0 93 | 94 | sumTakeFilterIterate :: Int 95 | sumTakeFilterIterate = sum $ I.take 100 $ I.filter odd $ I.iterate (+ 1) 0 96 | 97 | takeFilterCycle :: [Int] 98 | takeFilterCycle = I.take 100 $ I.filter odd $ I.cycle $ 0 :| [1..] 99 | 100 | takeFilterEllipsis3 :: [Int] 101 | takeFilterEllipsis3 = I.take 100 $ I.filter odd (0 I....) 102 | 103 | takeFilterEllipsis4 :: [Int] 104 | takeFilterEllipsis4 = I.take 100 $ I.filter odd ((0, 3) I.....) 105 | 106 | sumTakeFilterEllipsis3 :: Int 107 | sumTakeFilterEllipsis3 = sum $ I.take 100 $ I.filter odd (0 I....) 108 | 109 | sumTakeFilterEllipsis4 :: Int 110 | sumTakeFilterEllipsis4 = sum $ I.take 100 $ I.filter odd ((0, 3) I.....) 111 | 112 | 113 | takeToListFilterIterate :: [Int] 114 | takeToListFilterIterate = Prelude.take 100 $ I.toList $ I.filter odd $ I.iterate (+ 1) 0 115 | 116 | sumTakeToListFilterIterate :: Int 117 | sumTakeToListFilterIterate = sum $ Prelude.take 100 $ I.toList $ I.filter odd $ I.iterate (+ 1) 0 118 | 119 | takeToListFilterCycle :: [Int] 120 | takeToListFilterCycle = Prelude.take 100 $ I.toList $ I.filter odd $ I.cycle $ 0 :| [1..] 121 | 122 | takeToListFilterEllipsis3 :: [Int] 123 | takeToListFilterEllipsis3 = Prelude.take 100 $ I.toList $ I.filter odd (0 I....) 124 | 125 | takeToListFilterEllipsis4 :: [Int] 126 | takeToListFilterEllipsis4 = Prelude.take 100 $ I.toList $ I.filter odd ((0, 3) I.....) 127 | 128 | sumTakeToListFilterEllipsis3 :: Int 129 | sumTakeToListFilterEllipsis3 = sum $ Prelude.take 100 $ I.toList $ I.filter odd (0 I....) 130 | 131 | sumTakeToListFilterEllipsis4 :: Int 132 | sumTakeToListFilterEllipsis4 = sum $ Prelude.take 100 $ I.toList $ I.filter odd ((0, 3) I.....) 133 | 134 | 135 | headFilterMapEllipsis3 :: Int 136 | headFilterMapEllipsis3 = I.head $ I.filter odd $ I.map (+ 1) (0 I....) 137 | 138 | headFilterMapEllipsis4 :: Int 139 | headFilterMapEllipsis4 = I.head $ I.filter odd $ I.map (+ 1) ((0, 3) I.....) 140 | 141 | toListConcatRepeat :: [Int] 142 | toListConcatRepeat = I.toList $ I.concat $ I.repeat $ NE.singleton 1 143 | 144 | toListConcatMapRepeat :: [Int] 145 | toListConcatMapRepeat = I.toList $ I.concatMap NE.singleton $ I.repeat 1 146 | 147 | toListIntersperseRepeat :: [Int] 148 | toListIntersperseRepeat = I.toList $ I.intersperse 1 $ I.repeat 0 149 | 150 | toListIntercalateRepeat :: [Int] 151 | toListIntercalateRepeat = I.toList $ I.intercalate (NE.singleton 1) $ I.repeat [0] 152 | 153 | headMapZipIterate :: Bool 154 | headMapZipIterate = I.head $ I.map ((> 0) . snd) $ I.zip (I.repeat (1 :: Word)) $ I.iterate id (0 :: Int) 155 | 156 | headMapFlipZipIterate :: Bool 157 | headMapFlipZipIterate = I.head $ I.map ((> 0) . fst) $ flip I.zip (I.repeat (1 :: Word)) $ I.iterate id (0 :: Int) 158 | 159 | zeros :: Infinite Word 160 | zeros = I.repeat 0 161 | {-# NOINLINE zeros #-} 162 | 163 | zipWithRepeat1 :: Infinite Bool 164 | zipWithRepeat1 = I.zipWith (\x y -> x == fromIntegral y) (I.repeat (1 :: Int)) zeros 165 | 166 | zipWithRepeat2 :: Infinite Bool 167 | zipWithRepeat2 = I.zipWith (\x y -> y == fromIntegral x) zeros (I.repeat (1 :: Int)) 168 | 169 | zipWith3Repeat1 :: Infinite Bool 170 | zipWith3Repeat1 = I.zipWith3 (\x y z -> x == fromIntegral (y + z)) (I.repeat (1 :: Int)) zeros zeros 171 | 172 | zipWith3Repeat2 :: Infinite Bool 173 | zipWith3Repeat2 = I.zipWith3 (\x y z -> y == fromIntegral (x + z)) zeros (I.repeat (1 :: Int)) zeros 174 | 175 | zipWith3Repeat3 :: Infinite Bool 176 | zipWith3Repeat3 = I.zipWith3 (\x y z -> z == fromIntegral (x + y)) zeros zeros (I.repeat (1 :: Int)) 177 | 178 | zipWith4Repeat1 :: Infinite Bool 179 | zipWith4Repeat1 = I.zipWith4 (\x y z t -> x == fromIntegral (y + z + t)) (I.repeat (1 :: Int)) zeros zeros zeros 180 | 181 | zipWith4Repeat2 :: Infinite Bool 182 | zipWith4Repeat2 = I.zipWith4 (\x y z t -> y == fromIntegral (x + z + t)) zeros (I.repeat (1 :: Int)) zeros zeros 183 | 184 | zipWith4Repeat3 :: Infinite Bool 185 | zipWith4Repeat3 = I.zipWith4 (\x y z t -> z == fromIntegral (x + y + t)) zeros zeros (I.repeat (1 :: Int)) zeros 186 | 187 | zipWith4Repeat4 :: Infinite Bool 188 | zipWith4Repeat4 = I.zipWith4 (\x y z t -> t == fromIntegral (x + y + z)) zeros zeros zeros (I.repeat (1 :: Int)) 189 | 190 | zipWith5Repeat1 :: Infinite Bool 191 | zipWith5Repeat1 = I.zipWith5 (\x y z t u -> x == fromIntegral (y + z + t + u)) (I.repeat (1 :: Int)) zeros zeros zeros zeros 192 | 193 | zipWith5Repeat2 :: Infinite Bool 194 | zipWith5Repeat2 = I.zipWith5 (\x y z t u -> y == fromIntegral (x + z + t + u)) zeros (I.repeat (1 :: Int)) zeros zeros zeros 195 | 196 | zipWith5Repeat3 :: Infinite Bool 197 | zipWith5Repeat3 = I.zipWith5 (\x y z t u -> z == fromIntegral (x + y + t + u)) zeros zeros (I.repeat (1 :: Int)) zeros zeros 198 | 199 | zipWith5Repeat4 :: Infinite Bool 200 | zipWith5Repeat4 = I.zipWith5 (\x y z t u -> t == fromIntegral (x + y + z + u)) zeros zeros zeros (I.repeat (1 :: Int)) zeros 201 | 202 | zipWith5Repeat5 :: Infinite Bool 203 | zipWith5Repeat5 = I.zipWith5 (\x y z t u -> u == fromIntegral (x + y + z + t)) zeros zeros zeros zeros (I.repeat (1 :: Int)) 204 | 205 | zipWith6Repeat1 :: Infinite Bool 206 | 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 207 | 208 | zipWith6Repeat2 :: Infinite Bool 209 | 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 210 | 211 | zipWith6Repeat3 :: Infinite Bool 212 | 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 213 | 214 | zipWith6Repeat4 :: Infinite Bool 215 | 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 216 | 217 | zipWith6Repeat5 :: Infinite Bool 218 | 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 219 | 220 | zipWith6Repeat6 :: Infinite Bool 221 | 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)) 222 | 223 | zipWith7Repeat1 :: Infinite Bool 224 | 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 225 | 226 | zipWith7Repeat2 :: Infinite Bool 227 | 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 228 | 229 | zipWith7Repeat3 :: Infinite Bool 230 | 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 231 | 232 | zipWith7Repeat4 :: Infinite Bool 233 | 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 234 | 235 | zipWith7Repeat5 :: Infinite Bool 236 | 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 237 | 238 | zipWith7Repeat6 :: Infinite Bool 239 | 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 240 | 241 | zipWith7Repeat7 :: Infinite Bool 242 | 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)) 243 | 244 | main :: IO () 245 | main = defaultMain $ testGroup "All" 246 | [ $(inspectTest $ 'foldrMap `hasNoType` ''Word) 247 | , $(inspectTest $ 'foldrConsMap `hasNoType` ''Word) 248 | , $(inspectTest $ 'mapMap `hasNoType` ''Word) 249 | , $(inspectTest $ 'mapId `hasNoType` ''Word) 250 | , $(inspectTest $ 'mapCoerce ==- 'mapId) 251 | , $(inspectTest $ 'headIterate `hasNoType` ''Infinite) 252 | , $(inspectTest $ 'foldrIterate `hasNoType` ''Infinite) 253 | , $(inspectTest $ 'foldrIterate' `hasNoType` ''Infinite) 254 | , $(inspectTest $ 'foldrRepeat `hasNoType` ''Infinite) 255 | , $(inspectTest $ 'headFilterIterate `hasNoType` ''Infinite) 256 | , $(inspectTest $ 'filterFilter ==- 'filterFilter') 257 | , $(inspectTest $ 'foldrScanl `hasNoType` ''Word) 258 | , $(inspectTest $ 'foldrScanl' `hasNoType` ''Word) 259 | , $(inspectTest $ 'takeRepeat `hasNoType` ''Infinite) 260 | , $(inspectTest $ 'takeWhileIterate `hasNoType` ''Infinite) 261 | , $(inspectTest $ 'foldrCycle `hasNoType` ''Infinite) 262 | , $(inspectTest $ 'foldrWordsCycle `hasNoType` ''NonEmpty) 263 | , $(inspectTest $ 'mapAccumLRepeat `hasNoType` ''Word) 264 | , $(inspectTest $ 'mapAccumLRepeat' `hasNoType` ''Word) 265 | 266 | , $(inspectTest $ 'takeFilterIterate `hasNoType` ''Infinite) 267 | , $(inspectTest $ 'sumTakeFilterIterate `hasNoTypes` [''Infinite, ''[]]) 268 | , $(inspectTest $ 'takeFilterCycle `hasNoType` ''Infinite) 269 | , $(inspectTest $ 'takeFilterEllipsis3 `hasNoType` ''Infinite) 270 | , $(inspectTest $ 'takeFilterEllipsis4 `hasNoType` ''Infinite) 271 | , $(inspectTest $ 'sumTakeFilterEllipsis3 `hasNoTypes` [''Infinite, ''[]]) 272 | , $(inspectTest $ 'sumTakeFilterEllipsis4 `hasNoTypes` [''Infinite, ''[]]) 273 | 274 | , $(inspectTest $ 'takeToListFilterIterate `hasNoType` ''Infinite) 275 | , $(inspectTest $ 'sumTakeToListFilterIterate `hasNoTypes` [''Infinite, ''[]]) 276 | , $(inspectTest $ 'takeToListFilterCycle `hasNoType` ''Infinite) 277 | , $(inspectTest $ 'takeToListFilterEllipsis3 `hasNoType` ''Infinite) 278 | , $(inspectTest $ 'takeToListFilterEllipsis4 `hasNoType` ''Infinite) 279 | , $(inspectTest $ 'sumTakeToListFilterEllipsis3 `hasNoTypes` [''Infinite, ''[]]) 280 | , $(inspectTest $ 'sumTakeToListFilterEllipsis4 `hasNoTypes` [''Infinite, ''[]]) 281 | 282 | , $(inspectTest $ 'headFilterMapEllipsis3 `hasNoTypes` [''Infinite, ''[]]) 283 | , $(inspectTest $ 'headFilterMapEllipsis4 `hasNoTypes` [''Infinite, ''[]]) 284 | , $(inspectTest $ 'toListConcatRepeat `hasNoType` ''Infinite) 285 | , $(inspectTest $ 'toListConcatMapRepeat `hasNoType` ''Infinite) 286 | , $(inspectTest $ 'toListIntersperseRepeat `hasNoType` ''Infinite) 287 | , $(inspectTest $ 'toListIntercalateRepeat `hasNoType` ''Infinite) 288 | , $(inspectTest $ 'headMapZipIterate `hasNoType` ''Word) 289 | , $(inspectTest $ 'headMapFlipZipIterate `hasNoType` ''Int) 290 | 291 | , $(inspectTest $ 'zipWithRepeat1 `hasNoType` ''Int) 292 | , $(inspectTest $ 'zipWithRepeat2 `hasNoType` ''Int) 293 | , $(inspectTest $ 'zipWith3Repeat1 `hasNoType` ''Int) 294 | , $(inspectTest $ 'zipWith3Repeat2 `hasNoType` ''Int) 295 | , $(inspectTest $ 'zipWith3Repeat3 `hasNoType` ''Int) 296 | , $(inspectTest $ 'zipWith4Repeat1 `hasNoType` ''Int) 297 | , $(inspectTest $ 'zipWith4Repeat2 `hasNoType` ''Int) 298 | , $(inspectTest $ 'zipWith4Repeat3 `hasNoType` ''Int) 299 | , $(inspectTest $ 'zipWith4Repeat4 `hasNoType` ''Int) 300 | , $(inspectTest $ 'zipWith5Repeat1 `hasNoType` ''Int) 301 | , $(inspectTest $ 'zipWith5Repeat2 `hasNoType` ''Int) 302 | , $(inspectTest $ 'zipWith5Repeat3 `hasNoType` ''Int) 303 | , $(inspectTest $ 'zipWith5Repeat4 `hasNoType` ''Int) 304 | , $(inspectTest $ 'zipWith5Repeat5 `hasNoType` ''Int) 305 | , $(inspectTest $ 'zipWith6Repeat1 `hasNoType` ''Int) 306 | , $(inspectTest $ 'zipWith6Repeat2 `hasNoType` ''Int) 307 | , $(inspectTest $ 'zipWith6Repeat3 `hasNoType` ''Int) 308 | , $(inspectTest $ 'zipWith6Repeat4 `hasNoType` ''Int) 309 | , $(inspectTest $ 'zipWith6Repeat5 `hasNoType` ''Int) 310 | , $(inspectTest $ 'zipWith6Repeat6 `hasNoType` ''Int) 311 | , $(inspectTest $ 'zipWith7Repeat1 `hasNoType` ''Int) 312 | , $(inspectTest $ 'zipWith7Repeat2 `hasNoType` ''Int) 313 | , $(inspectTest $ 'zipWith7Repeat3 `hasNoType` ''Int) 314 | , $(inspectTest $ 'zipWith7Repeat4 `hasNoType` ''Int) 315 | , $(inspectTest $ 'zipWith7Repeat5 `hasNoType` ''Int) 316 | , $(inspectTest $ 'zipWith7Repeat6 `hasNoType` ''Int) 317 | , $(inspectTest $ 'zipWith7Repeat7 `hasNoType` ''Int) 318 | ] 319 | 320 | invertResult :: TestTree -> TestTree 321 | invertResult = wrapTest (fmap change) 322 | where 323 | change r 324 | | resultSuccessful r 325 | = r { resultOutcome = Failure TestFailed, resultShortDescription = "FAIL" } 326 | | otherwise 327 | = r { resultOutcome = Success, resultShortDescription = "OK", resultDescription = "" } 328 | -------------------------------------------------------------------------------- /src/Data/List/Infinite/Zip.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright: (c) 2022 Bodigrim 3 | -- License: BSD3 4 | module Data.List.Infinite.Zip ( 5 | zip, 6 | zipWith, 7 | zip3, 8 | zipWith3, 9 | zip4, 10 | zipWith4, 11 | zip5, 12 | zipWith5, 13 | zip6, 14 | zipWith6, 15 | zip7, 16 | zipWith7, 17 | ) where 18 | 19 | import Prelude (flip, (.)) 20 | 21 | import Data.List.Infinite.Internal 22 | 23 | -- | Zip two infinite lists. 24 | zip :: Infinite a -> Infinite b -> Infinite (a, b) 25 | zip = zipWith (,) 26 | {-# INLINE zip #-} 27 | 28 | -- | Zip two infinite lists with a given function. 29 | zipWith :: (a -> b -> c) -> Infinite a -> Infinite b -> Infinite c 30 | zipWith fun = go 31 | where 32 | go (a :< as) (b :< bs) = fun a b :< go as bs 33 | 34 | zipWithFB :: (elt -> lst -> lst') -> (a -> b -> elt) -> a -> b -> lst -> lst' 35 | zipWithFB = (.) . (.) 36 | 37 | {-# NOINLINE [1] zipWith #-} 38 | 39 | {-# INLINE [0] zipWithFB #-} 40 | 41 | {-# RULES 42 | "zipWith" [~1] forall f xs ys. 43 | zipWith f xs ys = 44 | build (\cons -> foldr2 (zipWithFB cons f) xs ys) 45 | "zipWithList" [1] forall f. 46 | foldr2 (zipWithFB (:<) f) = 47 | zipWith f 48 | #-} 49 | 50 | foldr2 :: (elt1 -> elt2 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> lst 51 | foldr2 cons = go 52 | where 53 | go (a :< as) (b :< bs) = cons a b (go as bs) 54 | {-# INLINE [0] foldr2 #-} 55 | 56 | foldr2_left :: (elt1 -> elt2 -> lst -> lst') -> elt1 -> (Infinite elt2 -> lst) -> Infinite elt2 -> lst' 57 | foldr2_left cons a r (b :< bs) = cons a b (r bs) 58 | 59 | {-# RULES 60 | "foldr2/1" forall (cons :: elt1 -> elt2 -> lst -> lst) (bs :: Infinite elt2) (g :: forall b. (elt1 -> b -> b) -> b). 61 | foldr2 cons (build g) bs = 62 | g (foldr2_left cons) bs 63 | "foldr2/2" forall (cons :: elt1 -> elt2 -> lst -> lst) (as :: Infinite elt1) (g :: forall b. (elt2 -> b -> b) -> b). 64 | foldr2 cons as (build g) = 65 | g (foldr2_left (flip cons)) as 66 | #-} 67 | 68 | -- | Zip three infinite lists. 69 | zip3 :: Infinite a -> Infinite b -> Infinite c -> Infinite (a, b, c) 70 | zip3 = zipWith3 (,,) 71 | {-# INLINE zip3 #-} 72 | 73 | -- | Zip three infinite lists with a given function. 74 | zipWith3 :: (a -> b -> c -> d) -> Infinite a -> Infinite b -> Infinite c -> Infinite d 75 | zipWith3 fun = go 76 | where 77 | go (a :< as) (b :< bs) (c :< cs) = fun a b c :< go as bs cs 78 | 79 | zipWith3FB :: (elt -> lst -> lst') -> (a -> b -> c -> elt) -> a -> b -> c -> lst -> lst' 80 | zipWith3FB = (.) . (.) . (.) 81 | 82 | {-# NOINLINE [1] zipWith3 #-} 83 | 84 | {-# INLINE [0] zipWith3FB #-} 85 | 86 | {-# RULES 87 | "zipWith3" [~1] forall f xs ys zs. 88 | zipWith3 f xs ys zs = 89 | build (\cons -> foldr3 (zipWith3FB cons f) xs ys zs) 90 | "zipWith3List" [1] forall f. 91 | foldr3 (zipWith3FB (:<) f) = 92 | zipWith3 f 93 | #-} 94 | 95 | foldr3 :: (elt1 -> elt2 -> elt3 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> Infinite elt3 -> lst 96 | foldr3 cons = go 97 | where 98 | go (a :< as) (b :< bs) (c :< cs) = cons a b c (go as bs cs) 99 | {-# INLINE [0] foldr3 #-} 100 | 101 | foldr3_left :: (elt1 -> elt2 -> elt3 -> lst -> lst') -> elt1 -> (Infinite elt2 -> Infinite elt3 -> lst) -> Infinite elt2 -> Infinite elt3 -> lst' 102 | foldr3_left cons a r (b :< bs) (c :< cs) = cons a b c (r bs cs) 103 | 104 | {-# RULES 105 | "foldr3/1" forall (cons :: elt1 -> elt2 -> elt3 -> lst -> lst) (bs :: Infinite elt2) (cs :: Infinite elt3) (g :: forall b. (elt1 -> b -> b) -> b). 106 | foldr3 cons (build g) bs cs = 107 | g (foldr3_left cons) bs cs 108 | "foldr3/2" forall (cons :: elt1 -> elt2 -> elt3 -> lst -> lst) (as :: Infinite elt1) (cs :: Infinite elt3) (g :: forall b. (elt2 -> b -> b) -> b). 109 | foldr3 cons as (build g) cs = 110 | g (foldr3_left (flip cons)) as cs 111 | "foldr3/3" forall (cons :: elt1 -> elt2 -> elt3 -> lst -> lst) (as :: Infinite elt1) (bs :: Infinite elt2) (g :: forall b. (elt3 -> b -> b) -> b). 112 | foldr3 cons as bs (build g) = 113 | g (foldr3_left (\c a b -> cons a b c)) as bs 114 | #-} 115 | 116 | -- | Zip four infinite lists. 117 | zip4 :: Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite (a, b, c, d) 118 | zip4 = zipWith4 (,,,) 119 | {-# INLINE zip4 #-} 120 | 121 | -- | Zip four infinite lists with a given function. 122 | zipWith4 :: (a -> b -> c -> d -> e) -> Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e 123 | zipWith4 fun = go 124 | where 125 | go (a :< as) (b :< bs) (c :< cs) (d :< ds) = fun a b c d :< go as bs cs ds 126 | 127 | zipWith4FB :: (elt -> lst -> lst') -> (a -> b -> c -> d -> elt) -> a -> b -> c -> d -> lst -> lst' 128 | zipWith4FB = (.) . (.) . (.) . (.) 129 | 130 | {-# NOINLINE [1] zipWith4 #-} 131 | 132 | {-# INLINE [0] zipWith4FB #-} 133 | 134 | {-# RULES 135 | "zipWith4" [~1] forall f xs ys zs ts. 136 | zipWith4 f xs ys zs ts = 137 | build (\cons -> foldr4 (zipWith4FB cons f) xs ys zs ts) 138 | "zipWith4List" [1] forall f. 139 | foldr4 (zipWith4FB (:<) f) = 140 | zipWith4 f 141 | #-} 142 | 143 | foldr4 :: (elt1 -> elt2 -> elt3 -> elt4 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> lst 144 | foldr4 cons = go 145 | where 146 | go (a :< as) (b :< bs) (c :< cs) (d :< ds) = cons a b c d (go as bs cs ds) 147 | {-# INLINE [0] foldr4 #-} 148 | 149 | foldr4_left :: (elt1 -> elt2 -> elt3 -> elt4 -> lst -> lst') -> elt1 -> (Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> lst) -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> lst' 150 | foldr4_left cons a r (b :< bs) (c :< cs) (d :< ds) = cons a b c d (r bs cs ds) 151 | 152 | {-# RULES 153 | "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). 154 | foldr4 cons (build g) bs cs ds = 155 | g (foldr4_left cons) bs cs ds 156 | "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). 157 | foldr4 cons as (build g) cs ds = 158 | g (foldr4_left (flip cons)) as cs ds 159 | "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). 160 | foldr4 cons as bs (build g) ds = 161 | g (foldr4_left (\c a b d -> cons a b c d)) as bs ds 162 | "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). 163 | foldr4 cons as bs cs (build g) = 164 | g (foldr4_left (\d a b c -> cons a b c d)) as bs cs 165 | #-} 166 | 167 | -- | Zip five infinite lists. 168 | zip5 :: Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite (a, b, c, d, e) 169 | zip5 = zipWith5 (,,,,) 170 | {-# INLINE zip5 #-} 171 | 172 | -- | Zip five infinite lists with a given function. 173 | zipWith5 :: (a -> b -> c -> d -> e -> f) -> Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite f 174 | zipWith5 fun = go 175 | where 176 | go (a :< as) (b :< bs) (c :< cs) (d :< ds) (e :< es) = fun a b c d e :< go as bs cs ds es 177 | 178 | zipWith5FB :: (elt -> lst -> lst') -> (a -> b -> c -> d -> e -> elt) -> a -> b -> c -> d -> e -> lst -> lst' 179 | zipWith5FB = (.) . (.) . (.) . (.) . (.) 180 | 181 | {-# NOINLINE [1] zipWith5 #-} 182 | 183 | {-# INLINE [0] zipWith5FB #-} 184 | 185 | {-# RULES 186 | "zipWith5" [~1] forall f xs ys zs ts us. 187 | zipWith5 f xs ys zs ts us = 188 | build (\cons -> foldr5 (zipWith5FB cons f) xs ys zs ts us) 189 | "zipWith5List" [1] forall f. 190 | foldr5 (zipWith5FB (:<) f) = 191 | zipWith5 f 192 | #-} 193 | 194 | foldr5 :: (elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> lst 195 | foldr5 cons = go 196 | where 197 | go (a :< as) (b :< bs) (c :< cs) (d :< ds) (e :< es) = cons a b c d e (go as bs cs ds es) 198 | {-# INLINE [0] foldr5 #-} 199 | 200 | 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' 201 | foldr5_left cons a r (b :< bs) (c :< cs) (d :< ds) (e :< es) = cons a b c d e (r bs cs ds es) 202 | 203 | {-# RULES 204 | "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). 205 | foldr5 cons (build g) bs cs ds es = 206 | g (foldr5_left cons) bs cs ds es 207 | "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). 208 | foldr5 cons as (build g) cs ds es = 209 | g (foldr5_left (flip cons)) as cs ds es 210 | "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). 211 | foldr5 cons as bs (build g) ds es = 212 | g (foldr5_left (\c a b d e -> cons a b c d e)) as bs ds es 213 | "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). 214 | foldr5 cons as bs cs (build g) es = 215 | g (foldr5_left (\d a b c e -> cons a b c d e)) as bs cs es 216 | "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). 217 | foldr5 cons as bs cs ds (build g) = 218 | g (foldr5_left (\e a b c d -> cons a b c d e)) as bs cs ds 219 | #-} 220 | 221 | -- | Zip six infinite lists. 222 | zip6 :: Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite f -> Infinite (a, b, c, d, e, f) 223 | zip6 = zipWith6 (,,,,,) 224 | {-# INLINE zip6 #-} 225 | 226 | -- | Zip six infinite lists with a given function. 227 | zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite f -> Infinite g 228 | zipWith6 fun = go 229 | where 230 | 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 231 | 232 | zipWith6FB :: (elt -> lst -> lst') -> (a -> b -> c -> d -> e -> f -> elt) -> a -> b -> c -> d -> e -> f -> lst -> lst' 233 | zipWith6FB = (.) . (.) . (.) . (.) . (.) . (.) 234 | 235 | {-# NOINLINE [1] zipWith6 #-} 236 | 237 | {-# INLINE [0] zipWith6FB #-} 238 | 239 | {-# RULES 240 | "zipWith6" [~1] forall f xs ys zs ts us vs. 241 | zipWith6 f xs ys zs ts us vs = 242 | build (\cons -> foldr6 (zipWith6FB cons f) xs ys zs ts us vs) 243 | "zipWith6List" [1] forall f. 244 | foldr6 (zipWith6FB (:<) f) = 245 | zipWith6 f 246 | #-} 247 | 248 | foldr6 :: (elt1 -> elt2 -> elt3 -> elt4 -> elt5 -> elt6 -> lst -> lst) -> Infinite elt1 -> Infinite elt2 -> Infinite elt3 -> Infinite elt4 -> Infinite elt5 -> Infinite elt6 -> lst 249 | foldr6 cons = go 250 | where 251 | 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) 252 | {-# INLINE [0] foldr6 #-} 253 | 254 | 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' 255 | 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) 256 | 257 | {-# RULES 258 | "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). 259 | foldr6 cons (build g) bs cs ds es fs = 260 | g (foldr6_left cons) bs cs ds es fs 261 | "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). 262 | foldr6 cons as (build g) cs ds es fs = 263 | g (foldr6_left (flip cons)) as cs ds es fs 264 | "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). 265 | foldr6 cons as bs (build g) ds es fs = 266 | g (foldr6_left (\c a b d e f -> cons a b c d e f)) as bs ds es fs 267 | "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). 268 | foldr6 cons as bs cs (build g) es fs = 269 | g (foldr6_left (\d a b c e f -> cons a b c d e f)) as bs cs es fs 270 | "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). 271 | foldr6 cons as bs cs ds (build g) fs = 272 | g (foldr6_left (\e a b c d f -> cons a b c d e f)) as bs cs ds fs 273 | "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). 274 | foldr6 cons as bs cs ds es (build g) = 275 | g (foldr6_left (\f a b c d e -> cons a b c d e f)) as bs cs ds es 276 | #-} 277 | 278 | -- | Zip seven infinite lists. 279 | zip7 :: Infinite a -> Infinite b -> Infinite c -> Infinite d -> Infinite e -> Infinite f -> Infinite g -> Infinite (a, b, c, d, e, f, g) 280 | zip7 = zipWith7 (,,,,,,) 281 | {-# INLINE zip7 #-} 282 | 283 | -- | Zip seven infinite lists with a given function. 284 | 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 285 | zipWith7 fun = go 286 | where 287 | 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 288 | 289 | zipWith7FB :: (elt -> lst -> lst') -> (a -> b -> c -> d -> e -> f -> g -> elt) -> a -> b -> c -> d -> e -> f -> g -> lst -> lst' 290 | zipWith7FB = (.) . (.) . (.) . (.) . (.) . (.) . (.) 291 | 292 | {-# NOINLINE [1] zipWith7 #-} 293 | 294 | {-# INLINE [0] zipWith7FB #-} 295 | 296 | {-# RULES 297 | "zipWith7" [~1] forall f xs ys zs ts us vs ws. 298 | zipWith7 f xs ys zs ts us vs ws = 299 | build (\cons -> foldr7 (zipWith7FB cons f) xs ys zs ts us vs ws) 300 | "zipWith7List" [1] forall f. 301 | foldr7 (zipWith7FB (:<) f) = 302 | zipWith7 f 303 | #-} 304 | 305 | 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 306 | foldr7 cons = go 307 | where 308 | 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) 309 | {-# INLINE [0] foldr7 #-} 310 | 311 | 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' 312 | 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) 313 | 314 | {-# RULES 315 | "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). 316 | foldr7 cons (build g) bs cs ds es fs gs = 317 | g (foldr7_left cons) bs cs ds es fs gs 318 | "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). 319 | foldr7 cons as (build g) cs ds es fs gs = 320 | g (foldr7_left (flip cons)) as cs ds es fs gs 321 | "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). 322 | foldr7 cons as bs (build g) ds es fs gs = 323 | g (foldr7_left (\c a b d e f g' -> cons a b c d e f g')) as bs ds es fs gs 324 | "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). 325 | foldr7 cons as bs cs (build g) es fs gs = 326 | g (foldr7_left (\d a b c e f g' -> cons a b c d e f g')) as bs cs es fs gs 327 | "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). 328 | foldr7 cons as bs cs ds (build g) fs gs = 329 | g (foldr7_left (\e a b c d f g' -> cons a b c d e f g')) as bs cs ds fs gs 330 | "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). 331 | foldr7 cons as bs cs ds es (build g) gs = 332 | g (foldr7_left (\f a b c d e g' -> cons a b c d e f g')) as bs cs ds es gs 333 | "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). 334 | foldr7 cons as bs cs ds es fs (build g) = 335 | g (foldr7_left (\g' a b c d e f -> cons a b c d e f g')) as bs cs ds es fs 336 | #-} 337 | -------------------------------------------------------------------------------- /test/Properties.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright: (c) 2022 Bodigrim 3 | -- Licence: BSD3 4 | 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE PostfixOperators #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TupleSections #-} 9 | {-# LANGUAGE ViewPatterns #-} 10 | 11 | {-# OPTIONS_GHC -Wno-orphans #-} 12 | {-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} 13 | {-# OPTIONS_GHC -Wno-x-partial #-} 14 | 15 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 16 | {-# HLINT ignore "Use <$>" #-} 17 | {-# HLINT ignore "Monad law, left identity" #-} 18 | {-# HLINT ignore "Monad law, right identity" #-} 19 | 20 | module Main where 21 | 22 | import Test.QuickCheck.Function 23 | import Test.Tasty 24 | import Test.Tasty.QuickCheck as QC 25 | 26 | import Control.Applicative 27 | import Control.Exception 28 | import Control.Monad 29 | import Control.Monad.Fix (mfix) 30 | import Data.Bifunctor 31 | import Data.Bits 32 | import Data.Either 33 | import qualified Data.List as L 34 | import Data.List.Infinite (Infinite(..)) 35 | import qualified Data.List.Infinite as I 36 | import Data.List.NonEmpty (NonEmpty(..)) 37 | import qualified Data.List.NonEmpty as NE 38 | import Data.Map.Strict (Map) 39 | import qualified Data.Map.Strict as Map 40 | import Data.Maybe 41 | import Data.Word (Word32) 42 | import Numeric.Natural 43 | import Prelude hiding (Applicative(..)) 44 | 45 | instance Arbitrary a => Arbitrary (Infinite a) where 46 | arbitrary = (:<) <$> arbitrary <*> arbitrary 47 | shrink = const [] 48 | 49 | #if !MIN_VERSION_QuickCheck(2,17,0) 50 | instance Arbitrary a => Arbitrary (NonEmpty a) where 51 | arbitrary = (:|) <$> arbitrary <*> arbitrary 52 | #endif 53 | 54 | trim :: Infinite a -> [a] 55 | trim = I.take 10 56 | 57 | trim1 :: Infinite a -> [a] 58 | trim1 = I.take 11 59 | 60 | mapMapFusion :: Infinite Int -> Infinite Int 61 | mapMapFusion xs = I.map fromIntegral (I.map fromIntegral xs :: Infinite Word) 62 | 63 | mapEither :: (a -> Either b c) -> [a] -> ([b], [c]) 64 | mapEither f = foldr (either (first . (:)) (second . (:)) . f) ([], []) 65 | 66 | main :: IO () 67 | main = defaultMain $ testGroup "All" 68 | [ testProperty "head" $ 69 | \(Blind (xs :: Infinite Int)) -> 70 | I.head xs === L.head (trim xs) 71 | , testProperty "tail" $ 72 | \(Blind (xs :: Infinite Int)) -> 73 | trim (I.tail xs) === L.tail (trim1 xs) 74 | , testProperty "uncons" $ 75 | \(Blind (xs :: Infinite Int)) -> 76 | Just (fmap trim (I.uncons xs)) === L.uncons (trim1 xs) 77 | 78 | , testProperty "map" $ 79 | \(applyFun -> (f :: Int -> Word)) (Blind (xs :: Infinite Int)) -> 80 | trim (I.map f xs) === L.map f (trim xs) 81 | 82 | , testProperty "fmap" $ 83 | \(applyFun -> (f :: Int -> Int)) (Blind (xs :: Infinite Int)) -> 84 | trim (fmap f xs) === fmap f (trim xs) 85 | , testProperty "<$" $ 86 | \(x :: Word) (Blind (xs :: Infinite Int)) -> 87 | trim (x <$ xs) === trim (fmap (const x) xs) 88 | 89 | , testProperty "pure" $ 90 | \(applyFun -> (f :: Int -> Word)) (x :: Int) -> 91 | trim (pure f <*> pure x) === trim (pure (f x)) 92 | , testProperty "*>" $ 93 | \(Blind (xs :: Infinite Int)) (Blind (ys :: Infinite Word)) -> 94 | trim (xs *> ys) === trim ((id <$ xs) <*> ys) 95 | , testProperty "<*" $ 96 | \(Blind (xs :: Infinite Int)) (Blind (ys :: Infinite Word)) -> 97 | trim (xs <* ys) === trim (liftA2 const xs ys) 98 | 99 | , testProperty ">>= 1" $ 100 | \x ((I.cycle .) . applyFun -> (k :: Int -> Infinite Word)) -> 101 | trim (return x >>= k) === trim (k x) 102 | , testProperty ">>= 2" $ 103 | \(Blind (xs :: Infinite Int)) -> 104 | trim (xs >>= return) === trim xs 105 | , testProperty ">>= 3" $ 106 | \(Blind xs) ((I.cycle .) . applyFun -> (k :: Int -> Infinite Word)) ((I.cycle .) . applyFun -> (h :: Word -> Infinite Char)) -> 107 | trim (xs >>= (k >=> h)) === trim ((xs >>= k) >>= h) 108 | , testProperty ">>" $ 109 | \(Blind (xs :: Infinite Int)) (Blind (ys :: Infinite Word)) -> 110 | trim (xs >> ys) === trim ys 111 | 112 | , testProperty "concat" $ 113 | \(Blind (xs :: Infinite (NonEmpty Int))) -> 114 | trim (I.concat xs) === L.take 10 (L.concatMap NE.toList (I.toList xs)) 115 | , testProperty "concatMap" $ 116 | \(applyFun -> (f :: Int -> NonEmpty Word)) (Blind xs) -> 117 | trim (I.concatMap f xs) === L.take 10 (L.concatMap (NE.toList . f) (I.toList xs)) 118 | 119 | , testProperty "intersperse" $ 120 | \(x :: Int) (Blind xs) -> 121 | I.take 19 (I.intersperse x xs) === L.intersperse x (trim xs) 122 | , testProperty "intersperse laziness 1" $ once $ 123 | I.head (I.intersperse undefined ('q' :< undefined)) === 'q' 124 | , testProperty "intersperse laziness 2" $ once $ 125 | I.take 2 (I.intersperse 'w' ('q' :< undefined)) === "qw" 126 | 127 | , testProperty "intercalate" $ 128 | \(x :: NonEmpty Int) (Blind xs) -> 129 | I.take (sum (map length (trim xs)) + 9 * length x) (I.intercalate x xs) === L.intercalate (NE.toList x) (trim xs) 130 | , testProperty "intercalate laziness 1" $ once $ 131 | I.take 3 (I.intercalate undefined ("foo" :< undefined)) === "foo" 132 | , testProperty "intercalate laziness 2" $ once $ 133 | I.take 6 (I.intercalate (NE.fromList "bar") ("foo" :< undefined)) === "foobar" 134 | 135 | , testProperty "interleave 1" $ 136 | \(Blind (xs :: Infinite Int)) (Blind ys) -> 137 | trim (I.map snd (I.filter fst (I.zip (I.cycle (True :| [False])) (I.interleave xs ys)))) === trim xs 138 | , testProperty "interleave 2" $ 139 | \(Blind (xs :: Infinite Int)) (Blind ys) -> 140 | trim (I.map snd (I.filter fst (I.zip (I.cycle (False :| [True])) (I.interleave xs ys)))) === trim ys 141 | , testProperty "interleave laziness" $ once $ 142 | I.head (I.interleave ('a' :< undefined) undefined) === 'a' 143 | 144 | , testProperty "transpose []" $ 145 | \(fmap getBlind -> (xss :: [Infinite Int])) -> not (null xss) ==> 146 | trim (I.transpose xss) === L.transpose (map trim xss) 147 | , testProperty "transpose NE" $ 148 | \(fmap getBlind -> (xss :: NonEmpty (Infinite Int))) -> 149 | NE.fromList (trim (I.transpose xss)) === NE.transpose (NE.map (NE.fromList . trim) xss) 150 | , testProperty "transpose laziness 1" $ once $ 151 | I.head (I.transpose ['a' :< undefined, 'b' :< undefined]) === "ab" 152 | , testProperty "transpose laziness 2" $ once $ 153 | I.head (I.transpose (('a' :< undefined) :| ['b' :< undefined])) === 'a' :| "b" 154 | 155 | , testProperty "subsequences" $ 156 | \(Blind (xs :: Infinite Int)) -> 157 | I.take 16 (I.subsequences xs) === L.subsequences (I.take 4 xs) 158 | , testProperty "subsequences laziness 1" $ once $ 159 | I.head (I.subsequences undefined) === "" 160 | , testProperty "subsequences laziness 2" $ once $ 161 | I.take 2 (I.subsequences ('q' :< undefined)) === ["", "q"] 162 | 163 | , testProperty "permutations" $ 164 | \(Blind (xs :: Infinite Int)) -> 165 | map (I.take 4) (I.take 24 (I.permutations xs)) === L.permutations (I.take 4 xs) 166 | , testProperty "permutations laziness" $ once $ 167 | I.take 6 (I.map (I.take 3) (I.permutations ('q' :< 'w' :< 'e' :< undefined))) === ["qwe","wqe","ewq","weq","eqw","qew"] 168 | 169 | , testProperty "... Bool" $ 170 | \(x :: Bool) -> 171 | trim (x I....) === L.take 10 (L.cycle [x..]) 172 | , testProperty "... Int" $ 173 | \(x :: Int) -> 174 | trim (x I....) === L.take 10 (L.cycle [x..]) 175 | , testProperty "... Int maxBound" $ 176 | \(NonNegative (x' :: Int)) -> let x = maxBound - x' in 177 | trim (x I....) === L.take 10 (L.cycle [x..]) 178 | , testProperty "... Word" $ 179 | \(x :: Word) -> 180 | trim (x I....) === L.take 10 (L.cycle [x..]) 181 | , testProperty "... Word maxBound" $ 182 | \(NonNegative (x' :: Word)) -> let x = maxBound - x' in 183 | trim (x I....) === L.take 10 (L.cycle [x..]) 184 | , testProperty "... Integer" $ 185 | \(x :: Integer) -> 186 | trim (x I....) === L.take 10 (L.cycle [x..]) 187 | , testProperty "... Natural" $ 188 | \(NonNegative (x' :: Integer)) -> let x = fromInteger x' :: Natural in 189 | trim (x I....) === L.take 10 (L.cycle [x..]) 190 | 191 | , testProperty ".... Bool" $ 192 | \(x :: Bool) y -> 193 | trim ((x, y) I.....) === L.take 10 (L.cycle [x, y..]) 194 | , testProperty ".... Int" $ 195 | \(x :: Int) y -> 196 | trim ((x, y) I.....) === L.take 10 (L.cycle [x, y..]) .&&. 197 | trim ((maxBound + x, y) I.....) === L.take 10 (L.cycle [maxBound + x, y..]) .&&. 198 | trim ((x, maxBound + y) I.....) === L.take 10 (L.cycle [x, maxBound + y..]) .&&. 199 | trim ((maxBound + x, maxBound + y) I.....) === L.take 10 (L.cycle [maxBound + x, maxBound + y..]) 200 | , testProperty ".... Word" $ 201 | \(x :: Word) y -> 202 | trim ((x, y) I.....) === L.take 10 (L.cycle [x, y..]) .&&. 203 | trim ((maxBound + x, y) I.....) === L.take 10 (L.cycle [maxBound + x, y..]) .&&. 204 | trim ((x, maxBound + y) I.....) === L.take 10 (L.cycle [x, maxBound + y..]) .&&. 205 | trim ((maxBound + x, maxBound + y) I.....) === L.take 10 (L.cycle [maxBound + x, maxBound + y..]) 206 | , testProperty ".... Integer" $ 207 | \(x :: Integer) y -> 208 | trim ((x, y) I.....) === L.take 10 (L.cycle [x, y..]) 209 | , testProperty ".... Natural" $ 210 | \(NonNegative (x' :: Integer)) (NonNegative (y' :: Integer)) -> 211 | let x = fromInteger x' :: Natural in let y = fromInteger y' in 212 | trim ((x, y) I.....) === L.take 10 (L.cycle [x, y..]) 213 | 214 | , testProperty "toList" $ 215 | \(Blind (xs :: Infinite Int)) -> 216 | L.take 10 (I.toList xs) === trim xs 217 | 218 | , testProperty "scanl" $ 219 | \(curry . applyFun -> (f :: Word -> Int -> Word)) s (Blind xs) -> 220 | trim1 (I.scanl f s xs) === L.scanl f s (trim xs) 221 | , testProperty "scanl laziness 1" $ once $ 222 | I.head (I.scanl undefined 'q' undefined) === 'q' 223 | , testProperty "scanl laziness 2" $ once $ 224 | I.head (I.tail (I.scanl (const (const 'q')) undefined (I.repeat 'z'))) === 'q' 225 | 226 | , testProperty "scanl'" $ 227 | \(curry . applyFun -> (f :: Word -> Int -> Word)) s (Blind xs) -> 228 | trim1 (I.scanl' f s xs) === L.scanl' f s (trim xs) 229 | , testProperty "scanl' laziness 1" $ once $ 230 | I.head (I.scanl' undefined 'q' undefined) === 'q' 231 | , testProperty "scanl' laziness 2" $ once $ ioProperty $ do 232 | x <- try $ evaluate $ I.scanl' (const (const 'q')) undefined (I.repeat 'z') 233 | pure $ case x of 234 | Left (_ :: SomeException) -> True 235 | _ -> False 236 | 237 | , testProperty "scanl1" $ 238 | \(curry . applyFun -> (f :: Int -> Int -> Int)) (Blind xs) -> 239 | trim (I.scanl1 f xs) === L.scanl1 f (trim xs) 240 | , testProperty "scanl1 laziness 1" $ once $ 241 | I.head (I.scanl1 undefined ('q' :< undefined)) === 'q' 242 | , testProperty "scanl1 laziness 2" $ once $ 243 | I.head (I.tail (I.scanl1 (const (const 'q')) (undefined :< I.repeat 'z'))) === 'q' 244 | 245 | , testProperty "mapAccumL" $ 246 | \(curry . applyFun -> (f :: Bool -> Int -> (Bool, Word))) (Blind xs) -> 247 | trim (I.mapAccumL f False xs) === snd (L.mapAccumL f False (trim xs)) 248 | , testProperty "mapAccumL laziness" $ once $ 249 | I.head (I.mapAccumL (\_ x -> (undefined, x)) undefined ('q' :< undefined)) === 'q' 250 | 251 | , testProperty "mapAccumL'" $ 252 | \(curry . applyFun -> (f :: Bool -> Int -> (Bool, Word))) (Blind xs) -> 253 | trim (I.mapAccumL' f False xs) === snd (L.mapAccumL f False (trim xs)) 254 | 255 | , testProperty "iterate" $ 256 | \(applyFun -> (f :: Int -> Int)) s -> 257 | trim (I.iterate f s) === L.take 10 (L.iterate f s) 258 | , testProperty "iterate laziness 1" $ once $ 259 | I.head (I.iterate undefined 'q') === 'q' 260 | , testProperty "iterate laziness 2" $ once $ 261 | I.head (I.tail (I.iterate (\c -> if c == 'r' then undefined else 'r') 'q')) === 'r' 262 | , testProperty "iterate laziness 3" $ once $ 263 | I.iterate (const 'q') undefined `seq` () === () 264 | 265 | , testProperty "iterate'" $ 266 | \(applyFun -> (f :: Int -> Int)) s -> 267 | trim (I.iterate' f s) === L.take 10 (L.iterate f s) 268 | , testProperty "iterate' laziness 1" $ once $ 269 | I.head (I.iterate' undefined 'q') === 'q' 270 | , testProperty "iterate' laziness 2" $ once $ 271 | I.head (I.tail (I.iterate' (\c -> if c == 'r' then undefined else 'r') 'q')) === 'r' 272 | , testProperty "iterate' laziness 3" $ once $ ioProperty $ do 273 | xs <- try $ evaluate $ I.iterate' (const 'q') undefined 274 | pure $ case xs of 275 | Left (_ :: SomeException) -> True 276 | _ -> False 277 | 278 | , testProperty "repeat" $ 279 | \(s :: Int) -> 280 | trim (I.repeat s) === L.replicate 10 s 281 | 282 | , testProperty "cycle" $ 283 | \(xs :: NonEmpty Int) -> 284 | trim (I.cycle xs) === L.take 10 (L.cycle (NE.toList xs)) 285 | , testProperty "cycle laziness" $ once $ 286 | I.head (I.cycle ('q' :| undefined)) === 'q' 287 | 288 | , testProperty "unfoldr" $ 289 | \(applyFun -> (f :: Word -> (Int, Word))) s -> 290 | trim (I.unfoldr f s) === L.take 10 (L.unfoldr (Just . f) s) 291 | , testProperty "unfoldr laziness" $ once $ 292 | I.head (I.unfoldr (, undefined) 'q') === 'q' 293 | 294 | , testProperty "take" $ 295 | \n (Blind (xs :: Infinite Int)) -> 296 | L.take 10 (I.take n xs) === L.take n (trim xs) 297 | , testProperty "take laziness 1" $ once $ 298 | I.take 0 undefined === "" 299 | , testProperty "take laziness 2" $ once $ 300 | I.take 1 ('q' :< undefined) === "q" 301 | , testProperty "drop" $ 302 | \n (Blind (xs :: Infinite Int)) -> 303 | trim (I.drop n xs) === L.drop n (I.take (max n 0 + 10) xs) 304 | , testProperty "drop laziness" $ once $ 305 | I.head (I.drop 0 ('q' :< undefined)) === 'q' 306 | , testProperty "splitAt" $ 307 | \n (Blind (xs :: Infinite Int)) -> 308 | bimap (L.take 10) trim (I.splitAt n xs) === 309 | first (L.take 10) (L.splitAt n (I.take (max n 0 + 10) xs)) 310 | , testProperty "splitAt laziness 1" $ once $ 311 | fst (I.splitAt 0 undefined) === "" 312 | , testProperty "splitAt laziness 2" $ once $ 313 | fst (I.splitAt 1 ('q' :< undefined)) === "q" 314 | 315 | , testProperty "takeWhile" $ 316 | \(applyFun -> (f :: Ordering -> Bool)) (Blind xs) -> 317 | L.take 10 (L.takeWhile f (I.foldr (:) xs)) === 318 | L.take 10 (I.takeWhile f xs) 319 | , testProperty "takeWhile laziness 1" $ once $ 320 | L.null (I.takeWhile (const False) ('q' :< undefined)) 321 | , testProperty "takeWhile laziness 2" $ once $ 322 | L.head (I.takeWhile (const True) ('q' :< undefined)) === 'q' 323 | , testProperty "fst . span" $ 324 | \(applyFun -> (f :: Ordering -> Bool)) (Blind xs) -> 325 | let ys = L.take 10 (fst (I.span f xs)) in 326 | L.take 10 (L.takeWhile f (I.take (length ys + 10) xs)) === 327 | L.take 10 (fst (I.span f xs)) 328 | , testProperty "fst . break" $ 329 | \(applyFun -> (f :: Ordering -> Bool)) (Blind xs) -> 330 | let ys = L.take 10 (fst (I.break f xs)) in 331 | L.take 10 (L.takeWhile (not . f) (I.take (length ys + 10) xs)) === 332 | L.take 10 (fst (I.break f xs)) 333 | , testProperty "dropWhile" $ 334 | \(applyFun -> (f :: Ordering -> Bool)) (Blind xs) -> 335 | trim (L.foldr (:<) (I.dropWhile f xs) (I.takeWhile f xs)) === trim xs 336 | , testProperty "snd . span" $ 337 | \(applyFun -> (f :: Ordering -> Bool)) (Blind xs) -> 338 | trim (L.foldr (:<) (snd (I.span f xs)) (I.takeWhile f xs)) === trim xs 339 | , testProperty "snd . break" $ 340 | \(applyFun -> (f :: Ordering -> Bool)) (Blind xs) -> 341 | trim (L.foldr (:<) (snd (I.break f xs)) (I.takeWhile (not . f) xs)) === trim xs 342 | , testProperty "span laziness" $ once $ 343 | L.head (fst (I.span (/= '\n') ('q' :< undefined))) === 'q' 344 | , testProperty "break laziness" $ once $ 345 | L.head (fst (I.break (== '\n') ('q' :< undefined))) === 'q' 346 | 347 | , testProperty "stripPrefix" $ 348 | \(xs :: [Int]) (Blind (ys :: Infinite Int)) -> 349 | fmap trim (I.stripPrefix xs ys) === fmap (L.take 10) (L.stripPrefix xs (I.take (length xs + 10) ys)) 350 | , testProperty "stripPrefix laziness 1" $ once $ 351 | isNothing (I.stripPrefix ('q' : undefined) ('w' :< undefined)) 352 | , testProperty "stripPrefix laziness 2" $ once $ 353 | isJust (I.stripPrefix "foo" ('f' :< 'o' :< 'o' :< undefined)) 354 | , testProperty "isPrefixOf" $ 355 | \(xs :: [Int]) (Blind (ys :: Infinite Int)) -> 356 | I.isPrefixOf xs ys === L.isPrefixOf xs (I.take (length xs + 10) ys) 357 | , testProperty "isPrefixOf laziness 1" $ once $ 358 | I.isPrefixOf "" undefined 359 | , testProperty "isPrefixOf laziness 2" $ once $ 360 | not (I.isPrefixOf ('q' : undefined) ('w' :< undefined)) 361 | , testProperty "isPrefixOf laziness 3" $ once $ 362 | I.isPrefixOf "foo" ('f' :< 'o' :< 'o' :< undefined) 363 | 364 | , testProperty "zip" $ 365 | \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) -> 366 | trim (I.zip xs1 xs2) === L.zip (trim xs1) (trim xs2) 367 | , testProperty "zip3" $ 368 | \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) (Blind (xs3 :: Infinite Bool)) -> 369 | trim (I.zip3 xs1 xs2 xs3) === L.zip3 (trim xs1) (trim xs2) (trim xs3) 370 | , testProperty "zip4" $ 371 | \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) (Blind (xs3 :: Infinite Bool)) (Blind (xs4 :: Infinite Char)) -> 372 | trim (I.zip4 xs1 xs2 xs3 xs4) === L.zip4 (trim xs1) (trim xs2) (trim xs3) (trim xs4) 373 | , testProperty "zip5" $ 374 | \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) (Blind (xs3 :: Infinite Bool)) (Blind (xs4 :: Infinite Char)) (Blind (xs5 :: Infinite Ordering)) -> 375 | trim (I.zip5 xs1 xs2 xs3 xs4 xs5) === L.zip5 (trim xs1) (trim xs2) (trim xs3) (trim xs4) (trim xs5) 376 | , testProperty "zip6" $ 377 | \(Blind (xs1 :: Infinite Int)) (Blind (xs2 :: Infinite Word)) (Blind (xs3 :: Infinite Bool)) (Blind (xs4 :: Infinite Char)) (Blind (xs5 :: Infinite Ordering)) (Blind (xs6 :: Infinite String)) -> 378 | trim (I.zip6 xs1 xs2 xs3 xs4 xs5 xs6) === L.zip6 (trim xs1) (trim xs2) (trim xs3) (trim xs4) (trim xs5) (trim xs6) 379 | , testProperty "zip7" $ 380 | \(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)) -> 381 | 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) 382 | 383 | , testProperty "heteroZip" $ 384 | \(Blind (xs1 :: Infinite Int)) (xs2 :: Map Word Word) -> 385 | I.heteroZip xs1 xs2 === Map.fromList (L.zipWith (\x1 (k, x2) -> (k, (x1, x2))) (I.toList xs1) (Map.toList xs2)) 386 | , testProperty "heteroZipWith" $ 387 | \(curry . applyFun -> (f :: Int -> Word -> Char)) (Blind (xs1 :: Infinite Int)) (xs2 :: Map Word Word) -> 388 | I.heteroZipWith f xs1 xs2 === Map.fromList (L.zipWith (\x1 (k, x2) -> (k, f x1 x2)) (I.toList xs1) (Map.toList xs2)) 389 | 390 | , testProperty "heteroZip laziness" $ 391 | \(Blind (xs1 :: Infinite Int)) (xs2 :: Map Word Word) -> 392 | let xs1' = I.take (Map.size xs2) xs1 `I.prependList` undefined 393 | in I.heteroZip xs1' xs2 === Map.fromList (L.zipWith (\x1 (k, x2) -> (k, (x1, x2))) (I.toList xs1) (Map.toList xs2)) 394 | , testProperty "heteroZipWith laziness" $ 395 | \(curry . applyFun -> (f :: Int -> Word -> Char)) (Blind (xs1 :: Infinite Int)) (xs2 :: Map Word Word) -> 396 | let xs1' = I.take (Map.size xs2) xs1 `I.prependList` undefined 397 | in I.heteroZipWith f xs1' xs2 === Map.fromList (L.zipWith (\x1 (k, x2) -> (k, f x1 x2)) (I.toList xs1) (Map.toList xs2)) 398 | 399 | , testProperty "unzip" $ 400 | \(Blind (xs :: Infinite (Int, Word))) -> 401 | bimap trim trim (I.unzip xs) === L.unzip (trim xs) 402 | , testProperty "unzip3" $ 403 | \(Blind (xs :: Infinite (Int, Word, Bool))) -> 404 | (\(xs1, xs2, xs3) -> (trim xs1, trim xs2, trim xs3)) (I.unzip3 xs) === L.unzip3 (trim xs) 405 | , testProperty "unzip4" $ 406 | \(Blind (xs :: Infinite (Int, Word, Bool, Char))) -> 407 | (\(xs1, xs2, xs3, xs4) -> (trim xs1, trim xs2, trim xs3, trim xs4)) (I.unzip4 xs) === L.unzip4 (trim xs) 408 | , testProperty "unzip5" $ 409 | \(Blind (xs :: Infinite (Int, Word, Bool, Char, Ordering))) -> 410 | (\(xs1, xs2, xs3, xs4, xs5) -> (trim xs1, trim xs2, trim xs3, trim xs4, trim xs5)) (I.unzip5 xs) === L.unzip5 (trim xs) 411 | , testProperty "unzip6" $ 412 | \(Blind (xs :: Infinite (Int, Word, Bool, Char, Ordering, String))) -> 413 | (\(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) 414 | , testProperty "unzip7" $ 415 | \(Blind (xs :: Infinite (Int, Word, Bool, Char, Ordering, String, Integer))) -> 416 | (\(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) 417 | 418 | , testProperty "lines" $ 419 | \(Blind (xs :: Infinite Char)) -> 420 | I.take 3 (I.lines xs) === L.take 3 (L.lines (I.foldr (:) xs)) 421 | , testProperty "lines laziness 1" $ once $ 422 | L.head (I.head (I.lines ('q' :< undefined))) === 'q' 423 | , testProperty "lines laziness 2" $ once $ 424 | L.null (I.head (I.lines ('\n' :< undefined))) 425 | , testProperty "words" $ 426 | \(Blind (xs :: Infinite Char)) -> 427 | I.take 3 (I.map NE.toList (I.words xs)) === L.take 3 (L.words (I.foldr (:) xs)) 428 | , testProperty "words laziness" $ once $ 429 | NE.head (I.head (I.words ('q' :< undefined))) === 'q' 430 | , testProperty "unlines" $ 431 | \(Blind (xs :: Infinite [Char])) -> 432 | trim (I.unlines xs) === L.take 10 (L.unlines (trim xs)) 433 | , testProperty "unlines laziness" $ once $ 434 | I.take 2 (I.unlines ("q" :< undefined)) === "q\n" 435 | , testProperty "unwords" $ 436 | \(Blind (xs :: Infinite (NonEmpty Char))) -> 437 | trim (I.unwords xs) === L.take 10 (L.unwords (L.map NE.toList (I.foldr (:) xs))) 438 | , testProperty "unwords laziness" $ once $ 439 | I.take 2 (I.unwords (('q' :| []) :< undefined)) === "q " 440 | , testProperty "unlines . lines" $ 441 | \(Blind (xs :: Infinite Char)) -> 442 | I.take 100 xs === I.take 100 (I.unlines (I.lines xs)) 443 | 444 | , testProperty "group" $ 445 | \(Blind (ys :: Infinite Ordering)) -> 446 | trim (I.group ys) === L.take 10 (NE.group (I.foldr (:) ys)) 447 | , testProperty "groupBy" $ 448 | \(curry . applyFun -> (f :: Ordering -> Ordering -> Bool)) (Blind ys) -> 449 | all (\x -> not $ all (f x) [minBound..maxBound]) [minBound..maxBound] ==> 450 | trim (I.groupBy f ys) === L.take 10 (NE.groupBy f (I.foldr (:) ys)) 451 | , testProperty "group laziness" $ once $ 452 | NE.head (I.head (I.group ('q' :< undefined))) === 'q' 453 | , testProperty "nub" $ 454 | \(Blind (ys :: Infinite (Large Int))) -> 455 | fmap getLarge (I.take 3 (I.nub ys)) === fmap getLarge (L.take 3 (L.nub (I.foldr (:) ys))) 456 | , testProperty "nub laziness" $ once $ 457 | I.head (I.nub ('q' :< undefined)) === 'q' 458 | , testProperty "nubOrd" $ 459 | \(Blind (ys :: Infinite (Large Int))) -> 460 | fmap getLarge (I.take 3 (I.nubOrd ys)) === fmap getLarge (L.take 3 (L.nub (I.foldr (:) ys))) 461 | , testProperty "nubOrd laziness" $ once $ 462 | I.head (I.nubOrd ('q' :< undefined)) === 'q' 463 | 464 | , testProperty "delete" $ 465 | \(x :: Ordering) (Blind xs) -> 466 | trim (I.delete x xs) === L.take 10 (L.delete x (I.foldr (:) xs)) 467 | , testProperty "delete laziness" $ once $ 468 | I.head (I.delete 'q' ('w' :< undefined)) === 'w' 469 | , testProperty "insert" $ 470 | \(x :: Int) (Blind xs) -> 471 | trim (I.insert x xs) === L.take 10 (L.insert x (I.foldr (:) xs)) 472 | , testProperty "insert laziness" $ once $ 473 | I.take 2 (I.insert 'q' ('w' :< undefined)) === "qw" 474 | 475 | , testProperty "\\\\" $ 476 | \(Blind (xs :: Infinite Ordering)) ys -> 477 | trim (xs I.\\ ys) === L.take 10 (I.foldr (:) xs L.\\ ys) 478 | , testProperty "\\\\ laziness" $ once $ 479 | I.head (('q' :< undefined) I.\\ []) === 'q' 480 | , testProperty "union" $ 481 | \xs (Blind (ys :: Infinite Ordering)) -> 482 | I.take 3 (I.union xs ys) === L.take 3 (xs `L.union` I.foldr (:) ys) 483 | , testProperty "union laziness" $ once $ 484 | I.head (I.union ('q' : undefined) undefined) === 'q' 485 | , testProperty "intersect" $ 486 | \(Blind (xs :: Infinite Ordering)) ys -> not (null ys) ==> 487 | I.head (I.intersect xs ys) === L.head (I.foldr (:) xs `L.intersect` ys) 488 | , testProperty "intersect laziness" $ once $ 489 | I.head (I.intersect ('q' :< undefined) ('q' : undefined)) === 'q' 490 | 491 | , testProperty "inits" $ 492 | \(Blind (xs :: Infinite Int)) -> 493 | I.take 21 (I.inits xs) === L.inits (I.take 20 xs) 494 | , testProperty "inits laziness 1" $ once $ 495 | L.null (I.head (I.inits undefined)) 496 | , testProperty "inits laziness 2" $ once $ 497 | I.take 2 (I.inits ('q' :< undefined)) === ["", "q"] 498 | , testProperty "inits1" $ 499 | \(Blind (xs :: Infinite Int)) -> 500 | map NE.toList (trim (I.inits1 xs)) === L.tail (L.inits (trim xs)) 501 | , testProperty "tails" $ 502 | \(Blind (xs :: Infinite Int)) -> 503 | map trim (trim (I.tails xs)) === map (L.take 10) (L.take 10 (L.tails (I.take 20 xs))) 504 | , testProperty "tails laziness" $ once $ 505 | I.head (I.head (I.tails ('q' :< undefined))) === 'q' 506 | 507 | , testProperty "lookup" $ 508 | \(xs :: [(Int, Word)]) y zs -> 509 | let pairs = NE.fromList (xs ++ (y : zs)) in 510 | Just (I.lookup (fst y) (I.cycle pairs)) === L.lookup (fst y) (NE.toList pairs) 511 | , testProperty "lookup laziness" $ once $ 512 | I.lookup True ((True, 'q') :< undefined) === 'q' 513 | , testProperty "find" $ 514 | \(xs :: [(Int, Word)]) y zs -> 515 | let pairs = NE.fromList (xs ++ (y : zs)) in 516 | Just (I.find ((== snd y) . snd) (I.cycle pairs)) === L.find ((== snd y) . snd) (NE.toList pairs) 517 | , testProperty "find laziness" $ once $ 518 | I.find odd (1 :< undefined) === (1 :: Int) 519 | 520 | , testProperty "filter" $ 521 | \(applyFun -> (f :: Int -> Bool)) xs (Blind ys) -> 522 | let us = L.filter f xs in 523 | us === I.take (length us) (I.filter f (I.prependList xs ys)) 524 | , testProperty "mapMaybe" $ 525 | \(applyFun -> (f :: Int -> Maybe Word)) xs (Blind ys) -> 526 | let us = mapMaybe f xs in 527 | us === I.take (length us) (I.mapMaybe f (I.prependList xs ys)) 528 | , testProperty "catMaybes" $ 529 | \(xs :: [Maybe Word]) (Blind ys) -> 530 | let us = catMaybes xs in 531 | us === I.take (length us) (I.catMaybes (I.prependList xs ys)) 532 | , testProperty "partition" $ 533 | \(applyFun -> (f :: Int -> Bool)) xs (Blind ys) -> 534 | let (us, vs) = L.partition f xs in 535 | let (us', vs') = I.partition f (I.prependList xs ys) in 536 | us === I.take (length us) us' .&&. vs === I.take (length vs) vs' 537 | , testProperty "mapEither" $ 538 | \(applyFun -> (f :: Int -> Either Word Char)) xs (Blind ys) -> 539 | let (us, vs) = mapEither f xs in 540 | let (us', vs') = I.mapEither f (I.prependList xs ys) in 541 | us === I.take (length us) us' .&&. vs === I.take (length vs) vs' 542 | , testProperty "partitionEithers" $ 543 | \(xs :: [Either Word Char]) (Blind ys) -> 544 | let (us, vs) = partitionEithers xs in 545 | let (us', vs') = I.partitionEithers (I.prependList xs ys) in 546 | us === I.take (length us) us' .&&. vs === I.take (length vs) vs' 547 | 548 | , testProperty "!!" $ 549 | \(Blind (xs :: Infinite Int)) n -> 550 | xs I.!! n === I.foldr (:) xs L.!! fromIntegral n 551 | , testProperty "tabulate" $ 552 | \(applyFun -> (f :: Word -> Char)) n -> 553 | I.tabulate f I.!! n === f n 554 | 555 | , testProperty "elemIndex" $ 556 | \xs (x :: Int) (Blind ys) -> 557 | let zs = I.prependList xs (x :< ys) in 558 | Just (fromIntegral (I.elemIndex x zs)) === L.elemIndex x (I.foldr (:) zs) 559 | , testProperty "elemIndices" $ 560 | \xs (x :: Ordering) (Blind ys) -> 561 | let zs = I.prependList xs (x :< ys) in 562 | let is = L.elemIndices x (xs ++ [x]) in 563 | map fromIntegral (I.take (length is) (I.elemIndices x zs)) === is 564 | 565 | , testProperty "for_" $ once $ 566 | I.for_ (0 I....) (\x -> if x > 10 then Left x else Right ()) === Left (11 :: Int) 567 | 568 | , testProperty ">>= 32bit" $ once $ 569 | let ix = maxBound :: Word32 in 570 | finiteBitSize (0 :: Word) /= 32 || 571 | I.head (I.tail (I.genericDrop ix (I.repeat () >>= const (False :< I.repeat True)))) 572 | , testProperty "mfix" $ once $ 573 | (L.take 5 $ fmap (L.take 5) $ mfix $ \fib -> L.map (\n -> 1 : n : L.zipWith (+) fib (L.drop 1 fib)) [2..]) === 574 | (I.take 5 $ fmap (I.take 5) $ mfix $ \fib -> I.map (\n -> 1 :< n :< I.zipWith (+) fib (I.drop 1 fib)) ((2 :: Int) I....)) 575 | ] 576 | -------------------------------------------------------------------------------- /src/Data/List/Infinite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# OPTIONS_GHC -Wno-orphans #-} 7 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 8 | 9 | {-# HLINT ignore "Redundant lambda" #-} 10 | {-# HLINT ignore "Avoid restricted function" #-} 11 | 12 | -- | 13 | -- Copyright: (c) 2022 Bodigrim 14 | -- License: BSD3 15 | -- 16 | -- Modern lightweight library for infinite lists with fusion: 17 | -- 18 | -- * API similar to "Data.List". 19 | -- * No dependencies other than @base@. 20 | -- * Top performance, driven by fusion. 21 | -- * Avoid dangerous instances like `Data.Foldable.Foldable`. 22 | -- * Use `NonEmpty` where applicable. 23 | -- * Use `Word` for indices. 24 | -- * Be lazy, but not too lazy. 25 | -- 26 | -- @ 27 | -- {\-# LANGUAGE PostfixOperators #-\} 28 | -- import Data.List.Infinite (Infinite(..), (...), (....)) 29 | -- import qualified Data.List.Infinite as Inf 30 | -- @ 31 | module Data.List.Infinite ( 32 | -- * Construction 33 | Infinite (..), 34 | 35 | -- * Elimination 36 | head, 37 | tail, 38 | uncons, 39 | toList, 40 | foldr, 41 | 42 | -- * Traversals 43 | map, 44 | scanl, 45 | scanl', 46 | scanl1, 47 | mapAccumL, 48 | mapAccumL', 49 | traverse_, 50 | for_, 51 | 52 | -- * Transformations 53 | concat, 54 | concatMap, 55 | intersperse, 56 | intercalate, 57 | interleave, 58 | transpose, 59 | subsequences, 60 | subsequences1, 61 | permutations, 62 | 63 | -- * Building 64 | (...), 65 | (....), 66 | iterate, 67 | iterate', 68 | unfoldr, 69 | tabulate, 70 | repeat, 71 | cycle, 72 | 73 | -- * Sublists 74 | prependList, 75 | take, 76 | drop, 77 | splitAt, 78 | takeWhile, 79 | dropWhile, 80 | span, 81 | break, 82 | group, 83 | inits, 84 | inits1, 85 | tails, 86 | isPrefixOf, 87 | stripPrefix, 88 | 89 | -- * Searching 90 | filter, 91 | lookup, 92 | find, 93 | mapMaybe, 94 | catMaybes, 95 | partition, 96 | mapEither, 97 | partitionEithers, 98 | 99 | -- * Indexing 100 | (!!), 101 | elemIndex, 102 | elemIndices, 103 | findIndex, 104 | findIndices, 105 | 106 | -- * Zipping 107 | zip, 108 | zipWith, 109 | zip3, 110 | zipWith3, 111 | zip4, 112 | zipWith4, 113 | zip5, 114 | zipWith5, 115 | zip6, 116 | zipWith6, 117 | zip7, 118 | zipWith7, 119 | heteroZip, 120 | heteroZipWith, 121 | unzip, 122 | unzip3, 123 | unzip4, 124 | unzip5, 125 | unzip6, 126 | unzip7, 127 | 128 | -- * Functions on strings 129 | lines, 130 | words, 131 | unlines, 132 | unwords, 133 | 134 | -- * Set operations 135 | nub, 136 | nubOrd, 137 | delete, 138 | (\\), 139 | union, 140 | intersect, 141 | 142 | -- * Ordered lists 143 | insert, 144 | 145 | -- * Generalized functions 146 | nubBy, 147 | nubOrdBy, 148 | deleteBy, 149 | deleteFirstsBy, 150 | unionBy, 151 | intersectBy, 152 | groupBy, 153 | insertBy, 154 | genericTake, 155 | genericDrop, 156 | genericSplitAt, 157 | ) where 158 | 159 | import Control.Applicative (Applicative (..)) 160 | import Control.Arrow (first, second) 161 | import Control.Exception (assert) 162 | import Control.Monad (Monad (..)) 163 | import Control.Monad.Fix (MonadFix (..)) 164 | import Data.Bits ((.&.)) 165 | import Data.Char (Char, isSpace) 166 | import Data.Coerce (coerce) 167 | import Data.Either (Either, either) 168 | import Data.Eq (Eq, (/=), (==)) 169 | import qualified Data.Foldable as F 170 | import Data.Function (fix, ($)) 171 | import Data.Functor (Functor (..)) 172 | import qualified Data.List as List 173 | import Data.List.NonEmpty (NonEmpty (..)) 174 | import qualified Data.List.NonEmpty as NE 175 | import Data.Maybe (maybe) 176 | import Data.Ord (Ord, Ordering (..), compare, (<), (<=), (>), (>=)) 177 | import qualified Data.Traversable as Traversable 178 | import Data.Void (Void) 179 | import GHC.Exts (oneShot) 180 | import qualified GHC.Exts 181 | import Numeric.Natural (Natural) 182 | import Prelude (Bool (..), Enum, Int, Integer, Integral, Maybe (..), Traversable, Word, const, enumFrom, enumFromThen, flip, fromIntegral, id, maxBound, minBound, not, otherwise, seq, snd, uncurry, (&&), (+), (-), (.), (||)) 183 | 184 | import Data.List.Infinite.Internal 185 | import qualified Data.List.Infinite.Set as Set 186 | import Data.List.Infinite.Zip 187 | 188 | -- | Right-associative fold of an infinite list, necessarily lazy in the accumulator. 189 | -- Any unconditional attempt to force the accumulator even 190 | -- to the weak head normal form (WHNF) 191 | -- will hang the computation. E. g., the following definition isn't productive: 192 | -- 193 | -- > import Data.List.NonEmpty (NonEmpty(..)) 194 | -- > toNonEmpty = foldr (\a (x :| xs) -> a :| x : xs) :: Infinite a -> NonEmpty a 195 | -- 196 | -- One should use lazy patterns, e. g., 197 | -- 198 | -- > toNonEmpty = foldr (\a ~(x :| xs) -> a :| x : xs) 199 | -- 200 | -- This is a catamorphism on infinite lists. 201 | foldr :: (a -> b -> b) -> Infinite a -> b 202 | foldr f = go 203 | where 204 | go (x :< xs) = f x (go xs) 205 | {-# INLINE [0] foldr #-} 206 | 207 | {-# RULES 208 | "foldr/build" forall cons (g :: forall b. (a -> b -> b) -> b). 209 | foldr cons (build g) = 210 | g cons 211 | "foldr/cons/build" forall cons x (g :: forall b. (a -> b -> b) -> b). 212 | foldr cons (x :< build g) = 213 | cons x (g cons) 214 | #-} 215 | 216 | -- | Paramorphism on infinite lists. 217 | para :: forall a b. (a -> Infinite a -> b -> b) -> Infinite a -> b 218 | para f = go 219 | where 220 | go :: Infinite a -> b 221 | go (x :< xs) = f x xs (go xs) 222 | 223 | -- | Convert to a list. Use 'Data.List.Infinite.cycle' to go in the opposite direction. 224 | toList :: Infinite a -> [a] 225 | toList = foldr (:) 226 | {-# NOINLINE [0] toList #-} 227 | 228 | {-# RULES 229 | "toList" [~1] forall xs. 230 | toList xs = 231 | GHC.Exts.build (\cons -> const (foldr cons xs)) 232 | #-} 233 | 234 | -- | Generate an infinite progression, starting from a given element, 235 | -- similar to @[x..]@. 236 | -- For better user experience consider enabling @{\-# LANGUAGE PostfixOperators #-\}@: 237 | -- 238 | -- >>> :set -XPostfixOperators 239 | -- >>> Data.List.Infinite.take 10 (0...) 240 | -- [0,1,2,3,4,5,6,7,8,9] 241 | -- 242 | -- Beware that for finite types '(...)' applies 'Data.List.Infinite.cycle' 243 | -- atop of @[x..]@: 244 | -- 245 | -- >>> :set -XPostfixOperators 246 | -- >>> Data.List.Infinite.take 10 (EQ...) 247 | -- [EQ,GT,EQ,GT,EQ,GT,EQ,GT,EQ,GT] 248 | -- 249 | -- Remember that 'Int' is a finite type as well. One is unlikely to hit this 250 | -- on a 64-bit architecture, but on a 32-bit machine it's fairly possible to traverse 251 | -- @((0 :: 'Int') ...)@ far enough to encounter @0@ again. 252 | (...) :: Enum a => a -> Infinite a 253 | (...) = unsafeCycle . enumFrom 254 | {-# INLINE [0] (...) #-} 255 | 256 | infix 0 ... 257 | 258 | {-# RULES 259 | "ellipsis3Int" (...) = ellipsis3Int 260 | "ellipsis3Word" (...) = ellipsis3Word 261 | "ellipsis3Integer" (...) = ellipsis3Integer 262 | "ellipsis3Natural" (...) = ellipsis3Natural 263 | #-} 264 | 265 | ellipsis3Int :: Int -> Infinite Int 266 | ellipsis3Int from = iterate' (\n -> if n == maxBound then from else n + 1) from 267 | {-# INLINE ellipsis3Int #-} 268 | 269 | ellipsis3Word :: Word -> Infinite Word 270 | ellipsis3Word from = iterate' (\n -> if n == maxBound then from else n + 1) from 271 | {-# INLINE ellipsis3Word #-} 272 | 273 | ellipsis3Integer :: Integer -> Infinite Integer 274 | ellipsis3Integer = iterate' (+ 1) 275 | {-# INLINE ellipsis3Integer #-} 276 | 277 | ellipsis3Natural :: Natural -> Infinite Natural 278 | ellipsis3Natural = iterate' (+ 1) 279 | {-# INLINE ellipsis3Natural #-} 280 | 281 | -- | Generate an infinite arithmetic progression, starting from given elements, 282 | -- similar to @[x,y..]@. 283 | -- For better user experience consider enabling @{\-# LANGUAGE PostfixOperators #-\}@: 284 | -- 285 | -- >>> :set -XPostfixOperators 286 | -- >>> Data.List.Infinite.take 10 ((1,3)....) 287 | -- [1,3,5,7,9,11,13,15,17,19] 288 | -- 289 | -- Beware that for finite types '(....)' applies 'Data.List.Infinite.cycle' 290 | -- atop of @[x,y..]@: 291 | -- 292 | -- >>> :set -XPostfixOperators 293 | -- >>> Data.List.Infinite.take 10 ((EQ,GT)....) 294 | -- [EQ,GT,EQ,GT,EQ,GT,EQ,GT,EQ,GT] 295 | -- 296 | -- Remember that 'Int' is a finite type as well: for a sufficiently large 297 | -- step of progression @y - x@ one may observe @((x :: Int, y)....)@ cycling back 298 | -- to emit @x@ fairly soon. 299 | (....) :: Enum a => (a, a) -> Infinite a 300 | (....) = unsafeCycle . uncurry enumFromThen 301 | {-# INLINE [0] (....) #-} 302 | 303 | infix 0 .... 304 | 305 | {-# RULES 306 | "ellipsis4Int" (....) = ellipsis4Int 307 | "ellipsis4Word" (....) = ellipsis4Word 308 | "ellipsis4Integer" (....) = ellipsis4Integer 309 | "ellipsis4Natural" (....) = ellipsis4Natural 310 | #-} 311 | 312 | ellipsis4Int :: (Int, Int) -> Infinite Int 313 | ellipsis4Int (from, thn) 314 | | from <= thn = 315 | let d = thn - from 316 | in iterate' (\n -> if n > maxBound - d then from else n + d) from 317 | | otherwise = 318 | let d = from - thn 319 | in iterate' (\n -> if n < minBound + d then from else n - d) from 320 | {-# INLINE ellipsis4Int #-} 321 | 322 | ellipsis4Word :: (Word, Word) -> Infinite Word 323 | ellipsis4Word (from, thn) 324 | | from <= thn = 325 | let d = thn - from 326 | in iterate' (\n -> if n > maxBound - d then from else n + d) from 327 | | otherwise = 328 | let d = from - thn 329 | in iterate' (\n -> if n < d then from else n - d) from 330 | {-# INLINE ellipsis4Word #-} 331 | 332 | ellipsis4Integer :: (Integer, Integer) -> Infinite Integer 333 | ellipsis4Integer (from, thn) = iterate' (+ (thn - from)) from 334 | {-# INLINE ellipsis4Integer #-} 335 | 336 | ellipsis4Natural :: (Natural, Natural) -> Infinite Natural 337 | ellipsis4Natural (from, thn) 338 | | from <= thn = 339 | iterate' (+ (thn - from)) from 340 | | otherwise = 341 | let d = from - thn 342 | in iterate' (\n -> if n < d then from else n - d) from 343 | {-# INLINE ellipsis4Natural #-} 344 | 345 | -- | Just a pointwise 'Data.List.Infinite.map'. 346 | instance Functor Infinite where 347 | fmap = map 348 | (<$) = const . repeat 349 | 350 | -- | This instance operates pointwise, similar to 'Control.Applicative.ZipList'. 351 | instance Applicative Infinite where 352 | pure = repeat 353 | (f :< fs) <*> (x :< xs) = f x :< (fs <*> xs) 354 | (<*) = const 355 | (*>) = const id 356 | liftA2 = zipWith 357 | 358 | -- | 'Control.Applicative.ZipList' cannot be made a lawful 'Monad', 359 | -- but 'Infinite', being a 360 | -- [@Representable@](https://hackage.haskell.org/package/adjunctions/docs/Data-Functor-Rep.html#t:Representable), 361 | -- can. Namely, 'Control.Monad.join' 362 | -- picks up a diagonal of an infinite matrix of 'Infinite' ('Infinite' @a@). 363 | -- Bear in mind that this instance gets slow 364 | -- very soon because of linear indexing, so it is not recommended to be used 365 | -- in practice. 366 | instance Monad Infinite where 367 | xs >>= f = zipWith (\(!n) -> head . genericDrop n . f) ((...) (0 :: Natural)) xs 368 | -- To put it simply, (xs >>= f) !! n = f (xs !! n) !! n 369 | {-# INLINE (>>=) #-} 370 | (>>) = (*>) 371 | 372 | -- | @since 0.1.2 373 | instance MonadFix Infinite where 374 | mfix f = map (\(!n) -> fix $ head . genericDrop n . f) ((...) (0 :: Natural)) 375 | 376 | -- To put it simply, mfix f !! n = fix ((!! n) . f) 377 | -- 378 | -- How to derive it? As in Section 1.4 of Erkok's thesis, 379 | -- we can start by putting mfix f = fix (>>= f). 380 | -- 381 | -- mfix f !! n 382 | -- = fix (>>= f) !! n 383 | -- = [by definition of fix, fix g = g (fix g)] 384 | -- = (fix (>>= f) >>= f) !! n 385 | -- = [by the choice of >>= above, (xs >>= g) !! n = g (xs !! n) !! n] 386 | -- = f (fix (>>= f) !! n) !! n 387 | -- = ((!! n) . f) (fix (>>= f) !! n) 388 | -- = [restoring mfix from fix] 389 | -- = ((!! n) . f) (mfix f !! n) 390 | -- 391 | -- Then mfix f !! n = fix ((!! n) . f). 392 | 393 | -- | Get the first elements of an infinite list. 394 | head :: Infinite a -> a 395 | head (x :< _) = x 396 | {-# NOINLINE [1] head #-} 397 | 398 | {-# RULES 399 | "head/build" forall (g :: forall b. (a -> b -> b) -> b). 400 | head (build g) = 401 | g const 402 | #-} 403 | 404 | -- | Get the elements of an infinite list after the first one. 405 | tail :: Infinite a -> Infinite a 406 | tail (_ :< xs) = xs 407 | 408 | -- | Split an infinite list into its 'Data.List.Infinite.head' and 'Data.List.Infinite.tail'. 409 | uncons :: Infinite a -> (a, Infinite a) 410 | uncons (x :< xs) = (x, xs) 411 | 412 | -- | Apply a function to every element of an infinite list. 413 | map :: (a -> b) -> Infinite a -> Infinite b 414 | map = foldr . ((:<) .) 415 | 416 | mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst 417 | mapFB = (.) 418 | 419 | {-# NOINLINE [0] map #-} 420 | 421 | {-# INLINE [0] mapFB #-} 422 | 423 | {-# RULES 424 | "map" [~1] forall f xs. 425 | map f xs = 426 | build (\cons -> foldr (mapFB cons f) xs) 427 | "mapList" [1] forall f. 428 | foldr (mapFB (:<) f) = 429 | map f 430 | "mapFB" forall cons f g. 431 | mapFB (mapFB cons f) g = 432 | mapFB cons (f . g) 433 | "map/coerce" [1] 434 | map coerce = 435 | coerce 436 | #-} 437 | 438 | -- | Flatten out an infinite list of non-empty lists. 439 | -- 440 | -- The peculiar type with 'NonEmpty' is to guarantee that 'Data.List.Infinite.concat' 441 | -- is productive and results in an infinite list. Otherwise the 442 | -- concatenation of infinitely many @[a]@ could still be a finite list. 443 | concat :: Infinite (NonEmpty a) -> Infinite a 444 | concat = foldr (\(x :| xs) acc -> x :< (xs `prependList` acc)) 445 | {-# NOINLINE [1] concat #-} 446 | 447 | {-# RULES 448 | "concat" forall xs. 449 | concat xs = 450 | build (\cons -> foldr (flip (F.foldr cons)) xs) 451 | #-} 452 | 453 | -- | First 'Data.List.Infinite.map' every element, then 'Data.List.Infinite.concat'. 454 | -- 455 | -- The peculiar type with 'NonEmpty' is to guarantee that 'Data.List.Infinite.concatMap' 456 | -- is productive and results in an infinite list. Otherwise the 457 | -- concatenation of infinitely many @[b]@ could still be a finite list. 458 | concatMap :: (a -> NonEmpty b) -> Infinite a -> Infinite b 459 | concatMap f = foldr (\a acc -> let (x :| xs) = f a in x :< (xs `prependList` acc)) 460 | {-# NOINLINE [1] concatMap #-} 461 | 462 | {-# RULES 463 | "concatMap" forall f xs. 464 | concatMap f xs = 465 | build (\cons -> foldr (flip (F.foldr cons) . f) xs) 466 | #-} 467 | 468 | -- | Interleave two infinite lists. 469 | interleave :: Infinite a -> Infinite a -> Infinite a 470 | interleave (x :< xs) ys = x :< interleave ys xs 471 | 472 | -- | Insert an element between adjacent elements of an infinite list. 473 | intersperse :: a -> Infinite a -> Infinite a 474 | intersperse a = foldr (\x -> (x :<) . (a :<)) 475 | {-# NOINLINE [1] intersperse #-} 476 | 477 | {-# RULES 478 | "intersperse" forall a xs. 479 | intersperse a xs = 480 | build (\cons -> foldr (\x -> cons x . cons a) xs) 481 | #-} 482 | 483 | -- | Insert a non-empty list between adjacent elements of an infinite list, 484 | -- and subsequently flatten it out. 485 | -- 486 | -- The peculiar type with 'NonEmpty' is to guarantee that 'Data.List.Infinite.intercalate' 487 | -- is productive and results in an infinite list. If separator is an empty list, 488 | -- concatenation of infinitely many @[a]@ could still be a finite list. 489 | intercalate :: NonEmpty a -> Infinite [a] -> Infinite a 490 | intercalate ~(a :| as) = foldr (\xs -> prependList xs . (a :<) . prependList as) 491 | {-# NOINLINE [1] intercalate #-} 492 | 493 | {-# RULES 494 | "intercalate" forall as xss. 495 | intercalate as xss = 496 | build (\cons -> foldr (\xs acc -> F.foldr cons (F.foldr cons acc as) xs) xss) 497 | #-} 498 | 499 | -- | Transpose rows and columns of an argument. 500 | -- 501 | -- This is actually @distribute@ from 502 | -- [@Distributive@](https://hackage.haskell.org/package/distributive/docs/Data-Distributive.html#t:Distributive) 503 | -- type class in disguise. 504 | transpose :: Functor f => f (Infinite a) -> Infinite (f a) 505 | transpose xss = fmap head xss :< transpose (fmap tail xss) 506 | 507 | -- | Generate an infinite list of all finite subsequences of the argument. 508 | -- 509 | -- >>> take 8 (subsequences (0...)) 510 | -- [[],[0],[1],[0,1],[2],[0,2],[1,2],[0,1,2]] 511 | subsequences :: Infinite a -> Infinite [a] 512 | subsequences = ([] :<) . map NE.toList . subsequences1 513 | 514 | -- | Generate an infinite list of all non-empty finite subsequences of the argument. 515 | -- 516 | -- >>> take 7 (subsequences1 (0...)) 517 | -- [0 :| [],1 :| [],0 :| [1],2 :| [],0 :| [2],1 :| [2],0 :| [1,2]] 518 | subsequences1 :: Infinite a -> Infinite (NonEmpty a) 519 | subsequences1 = foldr go 520 | where 521 | go :: a -> Infinite (NonEmpty a) -> Infinite (NonEmpty a) 522 | go x sxs = (x :| []) :< foldr f sxs 523 | where 524 | f ys r = ys :< (x `NE.cons` ys) :< r 525 | 526 | -- | Generate an infinite list of all finite 527 | -- (such that only finite number of elements change their positions) 528 | -- permutations of the argument. 529 | -- 530 | -- >>> take 6 (fmap (take 3) (permutations (0...))) 531 | -- [[0,1,2],[1,0,2],[2,1,0],[1,2,0],[2,0,1],[0,2,1]] 532 | permutations :: Infinite a -> Infinite (Infinite a) 533 | permutations xs0 = xs0 :< perms xs0 [] 534 | where 535 | perms :: forall a. Infinite a -> [a] -> Infinite (Infinite a) 536 | perms (t :< ts) is = List.foldr interleaveList (perms ts (t : is)) (List.permutations is) 537 | where 538 | interleaveList :: [a] -> Infinite (Infinite a) -> Infinite (Infinite a) 539 | interleaveList = (snd .) . interleaveList' id 540 | 541 | interleaveList' :: (Infinite a -> b) -> [a] -> Infinite b -> (Infinite a, Infinite b) 542 | interleaveList' _ [] r = (ts, r) 543 | interleaveList' f (y : ys) r = (y :< us, f (t :< y :< us) :< zs) 544 | where 545 | (us, zs) = interleaveList' (f . (y :<)) ys r 546 | 547 | -- | Fold an infinite list from the left and return a list of successive reductions, 548 | -- starting from the initial accumulator: 549 | -- 550 | -- > scanl f acc (x1 :< x2 :< ...) = acc :< f acc x1 :< f (f acc x1) x2 :< ... 551 | scanl :: (b -> a -> b) -> b -> Infinite a -> Infinite b 552 | scanl f z0 = (z0 :<) . flip (foldr (\x acc z -> let fzx = f z x in fzx :< acc fzx)) z0 553 | 554 | scanlFB :: (elt' -> elt -> elt') -> (elt' -> lst -> lst) -> elt -> (elt' -> lst) -> elt' -> lst 555 | scanlFB f cons = \elt g -> oneShot (\x -> let elt' = f x elt in elt' `cons` g elt') 556 | 557 | {-# NOINLINE [1] scanl #-} 558 | 559 | {-# INLINE [0] scanlFB #-} 560 | 561 | {-# RULES 562 | "scanl" [~1] forall f a bs. 563 | scanl f a bs = 564 | build (\cons -> a `cons` foldr (scanlFB f cons) bs a) 565 | "scanlList" [1] forall f (a :: a) bs. 566 | foldr (scanlFB f (:<)) bs a = 567 | tail (scanl f a bs) 568 | #-} 569 | 570 | -- | Same as 'Data.List.Infinite.scanl', but strict in accumulator. 571 | scanl' :: (b -> a -> b) -> b -> Infinite a -> Infinite b 572 | scanl' f !z0 = (z0 :<) . flip (foldr (\x acc z -> let !fzx = f z x in fzx :< acc fzx)) z0 573 | 574 | scanlFB' :: (elt' -> elt -> elt') -> (elt' -> lst -> lst) -> elt -> (elt' -> lst) -> elt' -> lst 575 | scanlFB' f cons = \elt g -> oneShot (\x -> let !elt' = f x elt in elt' `cons` g elt') 576 | 577 | {-# NOINLINE [1] scanl' #-} 578 | 579 | {-# INLINE [0] scanlFB' #-} 580 | 581 | {-# RULES 582 | "scanl'" [~1] forall f a bs. 583 | scanl' f a bs = 584 | build (\cons -> a `seq` a `cons` foldr (scanlFB' f cons) bs a) 585 | "scanlList'" [1] forall f (a :: a) bs. 586 | foldr (scanlFB' f (:<)) bs a = 587 | tail (scanl' f a bs) 588 | #-} 589 | 590 | -- | Fold an infinite list from the left and return a list of successive reductions, 591 | -- starting from the first element: 592 | -- 593 | -- > scanl1 f (x0 :< x1 :< x2 :< ...) = x0 :< f x0 x1 :< f (f x0 x1) x2 :< ... 594 | scanl1 :: (a -> a -> a) -> Infinite a -> Infinite a 595 | scanl1 f (x :< xs) = scanl f x xs 596 | 597 | -- | Fold an infinite list from the left and return a list of successive reductions, 598 | -- keeping accumulator in a state: 599 | -- 600 | -- > mapAccumL f acc0 (x1 :< x2 :< ...) = 601 | -- > let (acc1, y1) = f acc0 x1 in 602 | -- > let (acc2, y2) = f acc1 x2 in 603 | -- > ... 604 | -- > y1 :< y2 :< ... 605 | -- 606 | -- If you are looking how to traverse with a state, look no further. 607 | mapAccumL :: (acc -> x -> (acc, y)) -> acc -> Infinite x -> Infinite y 608 | mapAccumL f = flip (foldr (\x acc s -> let (s', y) = f s x in y :< acc s')) 609 | 610 | mapAccumLFB :: (acc -> x -> (acc, y)) -> x -> (acc -> Infinite y) -> acc -> Infinite y 611 | mapAccumLFB f = \x r -> oneShot (\s -> let (s', y) = f s x in y :< r s') 612 | 613 | {-# NOINLINE [1] mapAccumL #-} 614 | 615 | {-# INLINE [0] mapAccumLFB #-} 616 | 617 | {-# RULES 618 | "mapAccumL" [~1] forall f s xs. 619 | mapAccumL f s xs = 620 | foldr (mapAccumLFB f) xs s 621 | "mapAccumLList" [1] forall f s xs. 622 | foldr (mapAccumLFB f) xs s = 623 | mapAccumL f s xs 624 | #-} 625 | 626 | -- | Same as 'mapAccumL', but strict in accumulator. 627 | -- 628 | -- @since 0.1.3 629 | mapAccumL' :: (acc -> x -> (acc, y)) -> acc -> Infinite x -> Infinite y 630 | mapAccumL' f = flip (foldr (\x acc !s -> let (s', y) = f s x in y :< acc s')) 631 | 632 | mapAccumL'FB :: (acc -> x -> (acc, y)) -> x -> (acc -> Infinite y) -> acc -> Infinite y 633 | mapAccumL'FB f = \x r -> oneShot (\(!s) -> let (s', y) = f s x in y :< r s') 634 | 635 | {-# NOINLINE [1] mapAccumL' #-} 636 | 637 | {-# INLINE [0] mapAccumL'FB #-} 638 | 639 | {-# RULES 640 | "mapAccumL'" [~1] forall f s xs. 641 | mapAccumL' f s xs = 642 | foldr (mapAccumL'FB f) xs s 643 | "mapAccumL'List" [1] forall f s xs. 644 | foldr (mapAccumL'FB f) xs s = 645 | mapAccumL' f s xs 646 | #-} 647 | 648 | -- | Generate an infinite list of repeated applications. 649 | iterate :: (a -> a) -> a -> Infinite a 650 | iterate f = go 651 | where 652 | go x = x :< go (f x) 653 | 654 | iterateFB :: (elt -> lst -> lst) -> (elt -> elt) -> elt -> lst 655 | iterateFB cons f = go 656 | where 657 | go x = x `cons` go (f x) 658 | 659 | {-# NOINLINE [1] iterate #-} 660 | 661 | {-# INLINE [0] iterateFB #-} 662 | 663 | {-# RULES 664 | "iterate" [~1] forall f x. iterate f x = build (\cons -> iterateFB cons f x) 665 | "iterateFB" [1] iterateFB (:<) = iterate 666 | #-} 667 | 668 | -- | Same as 'Data.List.Infinite.iterate', but strict in accumulator. 669 | iterate' :: (a -> a) -> a -> Infinite a 670 | iterate' f = go 671 | where 672 | go !x = x :< go (f x) 673 | 674 | iterateFB' :: (elt -> lst -> lst) -> (elt -> elt) -> elt -> lst 675 | iterateFB' cons f = go 676 | where 677 | go !x = x `cons` go (f x) 678 | 679 | {-# NOINLINE [1] iterate' #-} 680 | 681 | {-# INLINE [0] iterateFB' #-} 682 | 683 | {-# RULES 684 | "iterate'" [~1] forall f x. iterate' f x = build (\cons -> iterateFB' cons f x) 685 | "iterateFB'" [1] iterateFB' (:<) = iterate' 686 | #-} 687 | 688 | -- | Repeat the same element ad infinitum. 689 | repeat :: a -> Infinite a 690 | repeat x = go 691 | where 692 | go = x :< go 693 | 694 | repeatFB :: (elt -> lst -> lst) -> elt -> lst 695 | repeatFB cons x = go 696 | where 697 | go = x `cons` go 698 | 699 | {-# NOINLINE [1] repeat #-} 700 | 701 | {-# INLINE [0] repeatFB #-} 702 | 703 | {-# RULES 704 | "repeat" [~1] forall x. repeat x = build (`repeatFB` x) 705 | "repeatFB" [1] repeatFB (:<) = repeat 706 | #-} 707 | 708 | -- | Repeat a non-empty list ad infinitum. 709 | -- If you were looking for something like @fromList :: [a] -> Infinite a@, 710 | -- look no further. 711 | -- 712 | -- It would be less annoying to take @[a]@ instead of 'NonEmpty' @a@, 713 | -- but we strive to avoid partial functions. 714 | cycle :: NonEmpty a -> Infinite a 715 | cycle (x :| xs) = unsafeCycle (x : xs) 716 | {-# INLINE cycle #-} 717 | 718 | unsafeCycle :: [a] -> Infinite a 719 | unsafeCycle xs = go 720 | where 721 | go = xs `prependList` go 722 | 723 | unsafeCycleFB :: (elt -> lst -> lst) -> [elt] -> lst 724 | unsafeCycleFB cons xs = go 725 | where 726 | go = F.foldr cons go xs 727 | 728 | {-# NOINLINE [1] unsafeCycle #-} 729 | 730 | {-# INLINE [0] unsafeCycleFB #-} 731 | 732 | {-# RULES 733 | "unsafeCycle" [~1] forall x. unsafeCycle x = build (`unsafeCycleFB` x) 734 | "unsafeCycleFB" [1] unsafeCycleFB (:<) = unsafeCycle 735 | #-} 736 | 737 | -- | Build an infinite list from a seed value. 738 | -- 739 | -- This is an anamorphism on infinite lists. 740 | unfoldr :: (b -> (a, b)) -> b -> Infinite a 741 | unfoldr f = go 742 | where 743 | go b = let (a, b') = f b in a :< go b' 744 | {-# INLINE unfoldr #-} 745 | 746 | -- | Generate an infinite list of @f@ 0, @f@ 1, @f@ 2... 747 | -- 748 | -- 'tabulate' and '(Data.List.Infinite.!!)' witness that 'Infinite' is 749 | -- [@Representable@](https://hackage.haskell.org/package/adjunctions/docs/Data-Functor-Rep.html#t:Representable). 750 | tabulate :: (Word -> a) -> Infinite a 751 | tabulate f = unfoldr (\n -> (f n, n + 1)) 0 752 | {-# INLINE tabulate #-} 753 | 754 | -- | Take a prefix of given length. 755 | take :: Int -> Infinite a -> [a] 756 | take = GHC.Exts.inline genericTake 757 | {-# INLINE [1] take #-} 758 | 759 | {-# INLINE [1] genericTake #-} 760 | 761 | {-# INLINE [0] genericTakeFB #-} 762 | 763 | {-# RULES 764 | "take" 765 | take = 766 | genericTake 767 | "genericTake" [~1] forall n xs. 768 | genericTake n xs = 769 | GHC.Exts.build 770 | ( \cons nil -> 771 | if n >= 1 772 | then foldr (genericTakeFB cons nil) xs n 773 | else nil 774 | ) 775 | "genericTakeList" [1] forall n xs. 776 | foldr (genericTakeFB (:) []) xs n = 777 | genericTake n xs 778 | #-} 779 | 780 | -- | Take a prefix of given length. 781 | genericTake :: Integral i => i -> Infinite a -> [a] 782 | genericTake n 783 | | n < 1 = const [] 784 | | otherwise = flip (foldr (\hd f m -> hd : (if m <= 1 then [] else f (m - 1)))) n 785 | 786 | genericTakeFB :: Integral i => (elt -> lst -> lst) -> lst -> elt -> (i -> lst) -> i -> lst 787 | genericTakeFB cons nil x xs = \m -> if m <= 1 then x `cons` nil else x `cons` xs (m - 1) 788 | 789 | -- | Drop a prefix of given length. 790 | drop :: Int -> Infinite a -> Infinite a 791 | drop = GHC.Exts.inline genericDrop 792 | 793 | -- | Drop a prefix of given length. 794 | genericDrop :: Integral i => i -> Infinite a -> Infinite a 795 | genericDrop = flip (para (\hd tl f m -> if m < 1 then hd :< tl else f (m - 1))) 796 | {-# INLINEABLE genericDrop #-} 797 | 798 | -- | Split an infinite list into a prefix of given length and the rest. 799 | splitAt :: Int -> Infinite a -> ([a], Infinite a) 800 | splitAt = GHC.Exts.inline genericSplitAt 801 | 802 | -- | Split an infinite list into a prefix of given length and the rest. 803 | genericSplitAt :: Integral i => i -> Infinite a -> ([a], Infinite a) 804 | genericSplitAt n 805 | | n < 1 = ([],) 806 | | otherwise = flip (para (\hd tl f m -> if m <= 1 then ([hd], tl) else first (hd :) (f (m - 1)))) n 807 | {-# INLINEABLE genericSplitAt #-} 808 | 809 | -- | Take the longest prefix satisfying a predicate. 810 | takeWhile :: (a -> Bool) -> Infinite a -> [a] 811 | takeWhile p = foldr (\x xs -> if p x then x : xs else []) 812 | 813 | takeWhileFB :: (elt -> Bool) -> (elt -> lst -> lst) -> lst -> elt -> lst -> lst 814 | takeWhileFB p cons nil = \x r -> if p x then x `cons` r else nil 815 | 816 | {-# NOINLINE [1] takeWhile #-} 817 | 818 | {-# INLINE [0] takeWhileFB #-} 819 | 820 | {-# RULES 821 | "takeWhile" [~1] forall p xs. 822 | takeWhile p xs = 823 | GHC.Exts.build (\cons nil -> foldr (takeWhileFB p cons nil) xs) 824 | "takeWhileList" [1] forall p. 825 | foldr (takeWhileFB p (:) []) = 826 | takeWhile p 827 | #-} 828 | 829 | -- | Drop the longest prefix satisfying a predicate. 830 | -- 831 | -- This function isn't productive 832 | -- (e. g., 'Data.List.Infinite.head' '.' 'Data.List.Infinite.dropWhile' @f@ won't terminate), 833 | -- if all elements of the input list satisfy the predicate. 834 | dropWhile :: (a -> Bool) -> Infinite a -> Infinite a 835 | dropWhile p = para (\x xs -> if p x then id else const (x :< xs)) 836 | 837 | -- | Split an infinite list into the longest prefix satisfying a predicate and the rest. 838 | -- 839 | -- This function isn't productive in the second component of the tuple 840 | -- (e. g., 'Data.List.Infinite.head' '.' 'snd' '.' 'Data.List.Infinite.span' @f@ won't terminate), 841 | -- if all elements of the input list satisfy the predicate. 842 | span :: (a -> Bool) -> Infinite a -> ([a], Infinite a) 843 | span p = para (\x xs -> if p x then first (x :) else const ([], x :< xs)) 844 | 845 | -- | Split an infinite list into the longest prefix /not/ satisfying a predicate and the rest. 846 | -- 847 | -- This function isn't productive in the second component of the tuple 848 | -- (e. g., 'Data.List.Infinite.head' '.' 'snd' '.' 'Data.List.Infinite.break' @f@ won't terminate), 849 | -- if no elements of the input list satisfy the predicate. 850 | break :: (a -> Bool) -> Infinite a -> ([a], Infinite a) 851 | break = span . (not .) 852 | 853 | -- | If a list is a prefix of an infinite list, strip it and return the rest. 854 | -- Otherwise return 'Nothing'. 855 | stripPrefix :: Eq a => [a] -> Infinite a -> Maybe (Infinite a) 856 | stripPrefix [] = Just 857 | stripPrefix (p : ps) = flip (para alg) (p :| ps) 858 | where 859 | alg x xs acc (y :| ys) 860 | | x == y = maybe (Just xs) acc (NE.nonEmpty ys) 861 | | otherwise = Nothing 862 | 863 | -- | Group consecutive equal elements. 864 | group :: Eq a => Infinite a -> Infinite (NonEmpty a) 865 | group = groupBy (==) 866 | 867 | -- | Overloaded version of 'Data.List.Infinite.group'. 868 | groupBy :: (a -> a -> Bool) -> Infinite a -> Infinite (NonEmpty a) 869 | -- Quite surprisingly, 'groupBy' is not a simple catamorphism. 870 | -- Since @f@ is not guaranteed to be transitive, it's a full-blown 871 | -- histomorphism, at which point a manual recursion becomes much more readable. 872 | groupBy f = go 873 | where 874 | go (x :< xs) = (x :| ys) :< go zs 875 | where 876 | (ys, zs) = span (f x) xs 877 | 878 | -- | Generate all prefixes of an infinite list. 879 | -- 880 | -- >>> :set -XPostfixOperators 881 | -- >>> Data.List.Infinite.take 5 $ Data.List.Infinite.inits (0...) 882 | -- [[],[0],[0,1],[0,1,2],[0,1,2,3]] 883 | -- 884 | -- If you need reversed prefixes, they can be generated cheaper using 'scanl'': 885 | -- 886 | -- >>> :set -XPostfixOperators 887 | -- >>> Data.List.Infinite.take 5 $ Data.List.Infinite.scanl' (flip (:)) [] (0...) 888 | -- [[],[0],[1,0],[2,1,0],[3,2,1,0]] 889 | inits :: Infinite a -> Infinite [a] 890 | inits = 891 | map (\(SnocBuilder _ front rear) -> front List.++ List.reverse rear) 892 | . scanl' 893 | (\(SnocBuilder count front rear) x -> snocBuilder (count + 1) front (x : rear)) 894 | (SnocBuilder 0 [] []) 895 | 896 | data SnocBuilder a = SnocBuilder 897 | { _count :: !Word 898 | , _front :: [a] 899 | , _rear :: [a] 900 | } 901 | 902 | snocBuilder :: Word -> [a] -> [a] -> SnocBuilder a 903 | snocBuilder count front rear 904 | | count < 8 || (count .&. (count + 1)) /= 0 = 905 | SnocBuilder count front rear 906 | | otherwise = 907 | SnocBuilder count (front List.++ List.reverse rear) [] 908 | {-# INLINE snocBuilder #-} 909 | 910 | -- | Generate all non-empty prefixes of an infinite list. 911 | inits1 :: Infinite a -> Infinite (NonEmpty a) 912 | inits1 (x :< xs) = map (x :|) (inits xs) 913 | 914 | -- | Generate all suffixes of an infinite list. 915 | tails :: Infinite a -> Infinite (Infinite a) 916 | tails = foldr (\x xss@(~(xs :< _)) -> (x :< xs) :< xss) 917 | 918 | -- | Check whether a list is a prefix of an infinite list. 919 | isPrefixOf :: Eq a => [a] -> Infinite a -> Bool 920 | isPrefixOf [] = const True 921 | isPrefixOf (p : ps) = flip (foldr alg) (p :| ps) 922 | where 923 | alg x acc (y :| ys) = x == y && maybe True acc (NE.nonEmpty ys) 924 | 925 | -- | Find the first pair, whose first component is equal to the first argument, 926 | -- and return the second component. 927 | -- If there is nothing to be found, this function will hang indefinitely. 928 | lookup :: Eq a => a -> Infinite (a, b) -> b 929 | lookup a = foldr (\(a', b) b' -> if a == a' then b else b') 930 | 931 | -- | Find the first element, satisfying a predicate. 932 | -- If there is nothing to be found, this function will hang indefinitely. 933 | find :: (a -> Bool) -> Infinite a -> a 934 | find f = foldr (\a a' -> if f a then a else a') 935 | 936 | -- | Filter an infinite list, removing elements which does not satisfy a predicate. 937 | -- 938 | -- This function isn't productive 939 | -- (e. g., 'Data.List.Infinite.head' '.' 'Data.List.Infinite.filter' @f@ won't terminate), 940 | -- if no elements of the input list satisfy the predicate. 941 | -- 942 | -- A common objection is that since it could happen that no elements of the input 943 | -- satisfy the predicate, the return type should be @[a]@ instead of 'Infinite' @a@. 944 | -- This would not however make 'Data.List.Infinite.filter' any more productive. 945 | -- Note that such hypothetical 'Data.List.Infinite.filter' could not ever 946 | -- generate @[]@ constructor, only @(:)@, so 947 | -- we would just have a more lax type gaining nothing instead. Same reasoning applies 948 | -- to other filtering \/ partitioning \/ searching functions. 949 | filter :: (a -> Bool) -> Infinite a -> Infinite a 950 | filter f = foldr (\a -> if f a then (a :<) else id) 951 | 952 | filterFB :: (elt -> lst -> lst) -> (elt -> Bool) -> elt -> lst -> lst 953 | filterFB cons f x r 954 | | f x = x `cons` r 955 | | otherwise = r 956 | 957 | {-# NOINLINE [1] filter #-} 958 | 959 | {-# INLINE [0] filterFB #-} 960 | 961 | {-# RULES 962 | "filter" [~1] forall f xs. 963 | filter f xs = 964 | build (\cons -> foldr (filterFB cons f) xs) 965 | "filterList" [1] forall f. 966 | foldr (filterFB (:<) f) = 967 | filter f 968 | "filterFB" forall cons f g. 969 | filterFB (filterFB cons f) g = 970 | filterFB cons (\x -> f x && g x) 971 | #-} 972 | 973 | -- | Split an infinite list into two infinite lists: the first one contains elements, 974 | -- satisfying a predicate, and the second one the rest. 975 | -- 976 | -- This function isn't productive in the first component of the tuple 977 | -- (e. g., 'Data.List.Infinite.head' '.' 'Data.Tuple.fst' '.' 'Data.List.Infinite.partition' @f@ won't terminate), 978 | -- if no elements of the input list satisfy the predicate. 979 | -- Same for the second component, 980 | -- if all elements of the input list satisfy the predicate. 981 | partition :: (a -> Bool) -> Infinite a -> (Infinite a, Infinite a) 982 | partition f = foldr (\a -> if f a then first (a :<) else second (a :<)) 983 | 984 | -- | Return /n/-th element of an infinite list. 985 | -- On contrary to @Data.List.@'List.!!', this function takes 'Word' instead of 'Int' 986 | -- to avoid 'Prelude.error' on negative arguments. 987 | -- 988 | -- If you are concerned that unsigned indices may accidentally underflow, 989 | -- compile with [@-fno-ignore-asserts@](https://downloads.haskell.org/ghc/latest/docs/users_guide/using-optimisation.html#ghc-flag--fignore-asserts): 990 | -- there is an assert checking that the index does not exceed 991 | -- 'fromIntegral' ('maxBound' :: 'Int'). 992 | -- 993 | -- This is actually @index@ from 994 | -- [@Representable@](https://hackage.haskell.org/package/adjunctions/docs/Data-Functor-Rep.html#t:Representable) 995 | -- type class in disguise. 996 | (!!) :: Infinite a -> Word -> a 997 | (!!) xs n = 998 | assert (n <= fromIntegral (maxBound :: Int)) $ 999 | foldr (\x acc m -> if m == 0 then x else acc (m - 1)) xs n 1000 | 1001 | infixl 9 !! 1002 | 1003 | -- | Return an index of the first element, equal to a given. 1004 | -- If there is nothing to be found, this function will hang indefinitely. 1005 | elemIndex :: Eq a => a -> Infinite a -> Word 1006 | elemIndex = findIndex . (==) 1007 | 1008 | -- | Return indices of all elements, equal to a given. 1009 | -- 1010 | -- This function isn't productive 1011 | -- (e. g., 'Data.List.Infinite.head' '.' 'Data.List.Infinite.elemIndices' @f@ won't terminate), 1012 | -- if no elements of the input list are equal the given one. 1013 | elemIndices :: Eq a => a -> Infinite a -> Infinite Word 1014 | elemIndices = findIndices . (==) 1015 | 1016 | -- | Return an index of the first element, satisfying a predicate. 1017 | -- If there is nothing to be found, this function will hang indefinitely. 1018 | findIndex :: (a -> Bool) -> Infinite a -> Word 1019 | findIndex f = flip (foldr (\x acc !m -> if f x then m else acc (m + 1))) 0 1020 | 1021 | -- | Return indices of all elements, satisfying a predicate. 1022 | -- 1023 | -- This function isn't productive 1024 | -- (e. g., 'Data.List.Infinite.head' '.'' 'Data.List.Infinite.findIndices' @f@ won't terminate), 1025 | -- if no elements of the input list satisfy the predicate. 1026 | findIndices :: (a -> Bool) -> Infinite a -> Infinite Word 1027 | findIndices f = flip (foldr (\x acc !m -> (if f x then (m :<) else id) (acc (m + 1)))) 0 1028 | 1029 | -- | Zip an 'Infinite' with any 'Traversable', maintaining the shape of the 1030 | -- latter. 1031 | -- 1032 | -- >>> import Data.Functor.Compose (Compose(..)) 1033 | -- >>> heteroZip (0...) (Compose [Just 10, Nothing, Just 20]) 1034 | -- Compose [Just (0,10),Nothing,Just (1,20)] 1035 | -- 1036 | -- @since 0.1.2 1037 | heteroZip :: Traversable t => Infinite a -> t b -> t (a, b) 1038 | heteroZip = heteroZipWith (,) 1039 | 1040 | -- | Use a given function to zip an 'Infinite' with any 'Traversable', 1041 | -- maintaining the shape of the latter. 1042 | -- 1043 | -- >>> import Data.Functor.Compose (Compose(..)) 1044 | -- >>> heteroZipWith (+) (0...) (Compose [Just 10, Nothing, Just 20]) 1045 | -- Compose [Just 10,Nothing,Just 21] 1046 | -- 1047 | -- @since 0.1.2 1048 | heteroZipWith :: Traversable t => (a -> b -> c) -> Infinite a -> t b -> t c 1049 | heteroZipWith f = (snd .) . Traversable.mapAccumL (\(x :< xs) b -> (xs, f x b)) 1050 | 1051 | -- | Unzip an infinite list of tuples. 1052 | unzip :: Infinite (a, b) -> (Infinite a, Infinite b) 1053 | unzip = foldr (\(a, b) ~(as, bs) -> (a :< as, b :< bs)) 1054 | {-# INLINE unzip #-} 1055 | 1056 | -- | Unzip an infinite list of triples. 1057 | unzip3 :: Infinite (a, b, c) -> (Infinite a, Infinite b, Infinite c) 1058 | unzip3 = foldr (\(a, b, c) ~(as, bs, cs) -> (a :< as, b :< bs, c :< cs)) 1059 | {-# INLINE unzip3 #-} 1060 | 1061 | -- | Unzip an infinite list of quadruples. 1062 | unzip4 :: Infinite (a, b, c, d) -> (Infinite a, Infinite b, Infinite c, Infinite d) 1063 | unzip4 = foldr (\(a, b, c, d) ~(as, bs, cs, ds) -> (a :< as, b :< bs, c :< cs, d :< ds)) 1064 | {-# INLINE unzip4 #-} 1065 | 1066 | -- | Unzip an infinite list of quintuples. 1067 | unzip5 :: Infinite (a, b, c, d, e) -> (Infinite a, Infinite b, Infinite c, Infinite d, Infinite e) 1068 | unzip5 = foldr (\(a, b, c, d, e) ~(as, bs, cs, ds, es) -> (a :< as, b :< bs, c :< cs, d :< ds, e :< es)) 1069 | {-# INLINE unzip5 #-} 1070 | 1071 | -- | Unzip an infinite list of sextuples. 1072 | unzip6 :: Infinite (a, b, c, d, e, f) -> (Infinite a, Infinite b, Infinite c, Infinite d, Infinite e, Infinite f) 1073 | 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)) 1074 | {-# INLINE unzip6 #-} 1075 | 1076 | -- | Unzip an infinite list of septuples. 1077 | unzip7 :: Infinite (a, b, c, d, e, f, g) -> (Infinite a, Infinite b, Infinite c, Infinite d, Infinite e, Infinite f, Infinite g) 1078 | 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)) 1079 | {-# INLINE unzip7 #-} 1080 | 1081 | -- | Split an infinite string into lines, by @\\n@. Empty lines are preserved. 1082 | -- 1083 | -- In contrast to their counterparts from "Data.List", it holds that 1084 | -- 'Data.List.Infinite.unlines' @.@ 'Data.List.Infinite.lines' @=@ 'id'. 1085 | lines :: Infinite Char -> Infinite [Char] 1086 | lines = foldr go 1087 | where 1088 | go '\n' xs = [] :< xs 1089 | go c ~(x :< xs) = (c : x) :< xs 1090 | 1091 | -- | Concatenate lines together with @\\n@. 1092 | -- 1093 | -- In contrast to their counterparts from "Data.List", it holds that 1094 | -- 'Data.List.Infinite.unlines' @.@ 'Data.List.Infinite.lines' @=@ 'id'. 1095 | unlines :: Infinite [Char] -> Infinite Char 1096 | unlines = foldr (\l xs -> l `prependList` ('\n' :< xs)) 1097 | 1098 | -- | Split an infinite string into words, by any 'isSpace' symbol. 1099 | -- Leading spaces are removed and, as underlined by the return type, 1100 | -- repeated spaces are treated as a single delimiter. 1101 | words :: Infinite Char -> Infinite (NonEmpty Char) 1102 | -- This is fundamentally a zygomorphism with 'isSpace' . 'head' as the small algebra. 1103 | -- But manual implementation via catamorphism requires twice less calls of 'isSpace'. 1104 | words = uncurry repack . foldr go 1105 | where 1106 | repack zs acc = maybe acc (:< acc) (NE.nonEmpty zs) 1107 | 1108 | go x ~(zs, acc) = (zs', acc') 1109 | where 1110 | s = isSpace x 1111 | zs' = if s then [] else x : zs 1112 | acc' = if s then repack zs acc else acc 1113 | 1114 | wordsFB :: (NonEmpty Char -> lst -> lst) -> Infinite Char -> lst 1115 | wordsFB cons = uncurry repack . foldr go 1116 | where 1117 | repack zs acc = maybe acc (`cons` acc) (NE.nonEmpty zs) 1118 | 1119 | go x ~(zs, acc) = (zs', acc') 1120 | where 1121 | s = isSpace x 1122 | zs' = if s then [] else x : zs 1123 | acc' = if s then repack zs acc else acc 1124 | 1125 | {-# NOINLINE [1] words #-} 1126 | 1127 | {-# INLINE [0] wordsFB #-} 1128 | 1129 | {-# RULES 1130 | "words" [~1] forall s. words s = build (`wordsFB` s) 1131 | "wordsList" [1] wordsFB (:<) = words 1132 | #-} 1133 | 1134 | -- | Concatenate words together with a space. 1135 | -- 1136 | -- The function is meant to be a counterpart of with 'Data.List.Infinite.words'. 1137 | -- If you need to concatenate together 'Infinite' @[@'Char'@]@, 1138 | -- use 'Data.List.Infinite.intercalate' @(@'pure' @' ')@. 1139 | unwords :: Infinite (NonEmpty Char) -> Infinite Char 1140 | unwords = foldr (\(l :| ls) acc -> l :< ls `prependList` (' ' :< acc)) 1141 | 1142 | unwordsFB :: (Char -> lst -> lst) -> Infinite (NonEmpty Char) -> lst 1143 | unwordsFB cons = foldr (\(l :| ls) acc -> l `cons` List.foldr cons (' ' `cons` acc) ls) 1144 | 1145 | {-# NOINLINE [1] unwords #-} 1146 | 1147 | {-# INLINE [0] unwordsFB #-} 1148 | 1149 | {-# RULES 1150 | "unwords" [~1] forall s. unwords s = build (`unwordsFB` s) 1151 | "unwordsList" [1] unwordsFB (:<) = unwords 1152 | #-} 1153 | 1154 | -- | Remove duplicate from a list, keeping only the first occurrence of each element. 1155 | -- Because of a very weak constraint on @a@, this operation takes /O/(/n/²) time. 1156 | -- Consider using 'nubOrd' instead. 1157 | nub :: Eq a => Infinite a -> Infinite a 1158 | nub = nubBy (==) 1159 | 1160 | -- | Overloaded version of 'Data.List.Infinite.nub'. 1161 | -- Consider using 'nubOrdBy' instead. 1162 | nubBy :: (a -> a -> Bool) -> Infinite a -> Infinite a 1163 | nubBy eq = flip (foldr (\x acc seen -> if List.any (`eq` x) seen then acc seen else x :< acc (x : seen))) [] 1164 | 1165 | -- | Same as 'nub', but asymptotically faster, taking only /O/(/n/ log /n/) time. 1166 | -- 1167 | -- @since 0.1.2 1168 | nubOrd :: Ord a => Infinite a -> Infinite a 1169 | nubOrd = nubOrdBy compare 1170 | 1171 | -- | Overloaded version of 'Data.List.Infinite.nubOrd'. 1172 | -- 1173 | -- @since 0.1.2 1174 | nubOrdBy :: (a -> a -> Ordering) -> Infinite a -> Infinite a 1175 | nubOrdBy cmp = flip (foldr (\x acc seen -> if Set.member cmp x seen then acc seen else x :< acc (Set.insert cmp x seen))) Set.empty 1176 | 1177 | -- | Remove all occurrences of an element from an infinite list. 1178 | delete :: Eq a => a -> Infinite a -> Infinite a 1179 | delete = deleteBy (==) 1180 | 1181 | -- | Overloaded version of 'Data.List.Infinite.delete'. 1182 | deleteBy :: (a -> b -> Bool) -> a -> Infinite b -> Infinite b 1183 | deleteBy eq x = para (\y ys acc -> if eq x y then ys else y :< acc) 1184 | 1185 | -- | Take an infinite list and remove the first occurrence of every element 1186 | -- of a finite list. 1187 | (\\) :: Eq a => Infinite a -> [a] -> Infinite a 1188 | (\\) = deleteFirstsBy (==) 1189 | 1190 | -- | Overloaded version of '(Data.List.Infinite.\\)'. 1191 | deleteFirstsBy :: (a -> b -> Bool) -> Infinite b -> [a] -> Infinite b 1192 | deleteFirstsBy eq = List.foldl (flip (deleteBy eq)) 1193 | 1194 | -- | Union of a finite and an infinite list. It contains the finite list 1195 | -- as a prefix and afterwards all non-duplicate elements of the infinite list, 1196 | -- which are not members of the finite list. 1197 | union :: Eq a => [a] -> Infinite a -> Infinite a 1198 | union = unionBy (==) 1199 | 1200 | -- | Overloaded version of 'Data.List.Infinite.union'. 1201 | unionBy :: (a -> a -> Bool) -> [a] -> Infinite a -> Infinite a 1202 | unionBy eq xs ys = xs `prependList` List.foldl (flip (deleteBy eq)) (nubBy eq ys) xs 1203 | 1204 | -- | Insert an element at the first position where it is less than or equal 1205 | -- to the next one. If the input was sorted, the output remains sorted as well. 1206 | insert :: Ord a => a -> Infinite a -> Infinite a 1207 | insert = insertBy compare 1208 | 1209 | -- | Overloaded version of 'Data.List.Infinite.insert'. 1210 | insertBy :: (a -> a -> Ordering) -> a -> Infinite a -> Infinite a 1211 | insertBy cmp x = para (\y ys acc -> case cmp x y of GT -> y :< acc; _ -> x :< y :< ys) 1212 | 1213 | -- | Return all elements of an infinite list, which are simultaneously 1214 | -- members of a finite list. 1215 | intersect :: Eq a => Infinite a -> [a] -> Infinite a 1216 | intersect = intersectBy (==) 1217 | 1218 | -- | Overloaded version of 'Data.List.Infinite.intersect'. 1219 | intersectBy :: (a -> b -> Bool) -> Infinite a -> [b] -> Infinite a 1220 | intersectBy eq xs ys = filter (\x -> List.any (eq x) ys) xs 1221 | 1222 | -- | Prepend a list to an infinite list. 1223 | prependList :: [a] -> Infinite a -> Infinite a 1224 | prependList = flip (F.foldr (:<)) 1225 | 1226 | -- | Apply a function to every element of an infinite list and collect 'Just' results. 1227 | -- 1228 | -- This function isn't productive 1229 | -- (e. g., 'Data.List.Infinite.head' '.' 'mapMaybe' @f@ won't terminate), 1230 | -- if no elements of the input list result in 'Just'. 1231 | -- 1232 | -- @since 0.1.1 1233 | mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b 1234 | mapMaybe = foldr . (maybe id (:<) .) 1235 | 1236 | -- | Keep only 'Just' elements. 1237 | -- 1238 | -- This function isn't productive 1239 | -- (e. g., 'Data.List.Infinite.head' '.' 'catMaybes' won't terminate), 1240 | -- if no elements of the input list are 'Just'. 1241 | -- 1242 | -- @since 0.1.1 1243 | catMaybes :: Infinite (Maybe a) -> Infinite a 1244 | catMaybes = foldr (maybe id (:<)) 1245 | 1246 | -- | Apply a function to every element of an infinite list and 1247 | -- separate 'Data.Either.Left' and 'Data.Either.Right' results. 1248 | -- 1249 | -- This function isn't productive 1250 | -- (e. g., 'Data.List.Infinite.head' '.' 'Data.Tuple.fst' '.' 'mapEither' @f@ won't terminate), 1251 | -- if no elements of the input list result in 'Data.Either.Left' or 'Data.Either.Right'. 1252 | -- 1253 | -- @since 0.1.1 1254 | mapEither :: (a -> Either b c) -> Infinite a -> (Infinite b, Infinite c) 1255 | mapEither = foldr . (either (first . (:<)) (second . (:<)) .) 1256 | 1257 | -- | Separate 'Data.Either.Left' and 'Data.Either.Right' elements. 1258 | -- 1259 | -- This function isn't productive 1260 | -- (e. g., 'Data.List.Infinite.head' '.' 'Data.Tuple.fst' '.' 'partitionEithers' won't terminate), 1261 | -- if no elements of the input list are 'Data.Either.Left' or 'Data.Either.Right'. 1262 | -- 1263 | -- @since 0.1.1 1264 | partitionEithers :: Infinite (Either a b) -> (Infinite a, Infinite b) 1265 | partitionEithers = foldr (either (first . (:<)) (second . (:<))) 1266 | 1267 | -- | Map each element to an action, evaluate these actions from left to right 1268 | -- and ignore the results. Note that the return type is 'Void' instead of usual @()@. 1269 | -- 1270 | -- >>> traverse_ print (0...) -- hit Ctrl+C to terminate 1271 | -- 0 1272 | -- 1 1273 | -- 2Interrupted 1274 | -- 1275 | -- 'traverse_' could be productive for some short-circuiting @f@: 1276 | -- 1277 | -- >>> traverse_ (\x -> if x > 10 then Left x else Right ()) (0...) 1278 | -- Left 11 1279 | -- 1280 | -- @since 0.1.2 1281 | traverse_ :: Applicative f => (a -> f ()) -> Infinite a -> f Void 1282 | traverse_ = foldr . ((*>) .) 1283 | 1284 | -- | Flipped 'traverse_'. 1285 | -- 1286 | -- @since 0.1.2 1287 | for_ :: Applicative f => Infinite a -> (a -> f ()) -> f Void 1288 | for_ = flip traverse_ 1289 | --------------------------------------------------------------------------------