streams 3.3 → 3.3.1
raw patch · 15 files changed
+2246/−2290 lines, 15 filesdep +boringsetup-changed
Dependencies added: boring
Files
- .ghci +0/−1
- .gitignore +32/−29
- .travis.yml +0/−101
- .vim.custom +31/−31
- CHANGELOG.markdown +55/−50
- LICENSE +33/−33
- README +42/−42
- Setup.lhs +7/−7
- src/Data/Stream/Future.hs +166/−164
- src/Data/Stream/Future/Skew.hs +441/−439
- src/Data/Stream/Infinite.hs +463/−449
- src/Data/Stream/Infinite/Functional/Zipper.hs +334/−330
- src/Data/Stream/Infinite/Skew.hs +348/−339
- src/Data/Stream/Supply.hs +184/−182
- streams.cabal +110/−93
− .ghci
@@ -1,1 +0,0 @@-:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
.gitignore view
@@ -1,29 +1,32 @@-dist-docs-wiki-TAGS-tags-wip-.DS_Store-.*.swp-.*.swo-*.o-*.hi-*~-*#-dist-*-cabal-dev-*.chi-*.chs.h-*.dyn_o-*.dyn_hi-.hpc-.hsenv-.cabal-sandbox/-cabal.sandbox.config-*.prof-*.aux-*.hp-*.eventlog-.stack-work/-cabal.project.local+dist +dist-newstyle +docs +wiki +TAGS +tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# +.stack-work/ +cabal-dev +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.*
− .travis.yml
@@ -1,101 +0,0 @@-# This file has been generated -- see https://github.com/hvr/multi-ghc-travis-language: c-sudo: false--cache:- directories:- - $HOME/.cabsnap- - $HOME/.cabal/packages--before_cache:- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar--matrix:- include:- - env: CABALVER=1.18 GHCVER=7.4.2- compiler: ": #GHC 7.4.2"- addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}}- - env: CABALVER=1.18 GHCVER=7.6.3- compiler: ": #GHC 7.6.3"- addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}- - env: CABALVER=1.18 GHCVER=7.8.4- compiler: ": #GHC 7.8.4"- addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}- - env: CABALVER=1.22 GHCVER=7.10.3- compiler: ": #GHC 7.10.3"- addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=8.0.1- compiler: ": #GHC 8.0.1"- addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}- - env: CABALVER=head GHCVER=head- compiler: ": #GHC head"- addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}}-- allow_failures:- - env: CABALVER=head GHCVER=head--before_install:- - unset CC- - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH--install:- - cabal --version- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"- - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];- then- zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >- $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;- fi- - travis_retry cabal update -v- - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config- - cabal install --only-dependencies --enable-tests --dry -v > installplan.txt- - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt--# check whether current requested install-plan matches cached package-db snapshot- - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;- then- echo "cabal build-cache HIT";- rm -rfv .ghc;- cp -a $HOME/.cabsnap/ghc $HOME/.ghc;- cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;- else- echo "cabal build-cache MISS";- rm -rf $HOME/.cabsnap;- mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;- cabal install -j --only-dependencies --enable-tests;- fi--# snapshot package-db on cache miss- - if [ ! -d $HOME/.cabsnap ];- then- echo "snapshotting package-db to build-cache";- mkdir $HOME/.cabsnap;- cp -a $HOME/.ghc $HOME/.cabsnap/ghc;- cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;- fi--# Here starts the actual work to be performed for the package under test;-# any command which exits with a non-zero exit code causes the build to fail.-script:- - cabal configure -v2 --enable-tests # -v2 provides useful information for debugging- - cabal build # this builds all libraries and executables (including tests/benchmarks)- - cabal sdist # tests that a source-distribution can be generated- - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;- cd dist/;- if [ -f "$SRC_TGZ" ]; then- cabal install "$SRC_TGZ";- else- echo "expected '$SRC_TGZ' not found";- exit 1;- fi--notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313streams\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"--# EOF
.vim.custom view
@@ -1,31 +1,31 @@-" Add the following to your .vimrc to automatically load this on startup--" if filereadable(".vim.custom")-" so .vim.custom-" endif--function StripTrailingWhitespace()- let myline=line(".")- let mycolumn = col(".")- silent %s/ *$//- call cursor(myline, mycolumn)-endfunction--" enable syntax highlighting-syntax on--" search for the tags file anywhere between here and /-set tags=TAGS;/--" highlight tabs and trailing spaces-set listchars=tab:‗‗,trail:‗-set list--" f2 runs hasktags-map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>--" strip trailing whitespace before saving-" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()--" rebuild hasktags after saving-au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"+" Add the following to your .vimrc to automatically load this on startup + +" if filereadable(".vim.custom") +" so .vim.custom +" endif + +function StripTrailingWhitespace() + let myline=line(".") + let mycolumn = col(".") + silent %s/ *$// + call cursor(myline, mycolumn) +endfunction + +" enable syntax highlighting +syntax on + +" search for the tags file anywhere between here and / +set tags=TAGS;/ + +" highlight tabs and trailing spaces +set listchars=tab:‗‗,trail:‗ +set list + +" f2 runs hasktags +map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR> + +" strip trailing whitespace before saving +" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() + +" rebuild hasktags after saving +au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
CHANGELOG.markdown view
@@ -1,50 +1,55 @@-3.3-----* Removed a number of redundant parts of the API. If a method you were using has been removed, consider the classes available. No functionality was lost.-* Better support for GHC 7.10, the `Foldable (length, null)` members are now defined directly leading to asymptotic improvements and helping to further shrink the API.-* Added `prepend` and `concat` functions to `Data.Stream.Infinite`-* Allow `comonad-5`--3.2.2-------* Bug fix in `Data.Stream.Infinite.Skew` and removed `fromList`.--3.2.1-------* Add support for `semigroupoids` 5 and GHC 7.10--3.2-----* Switched to `tabulate` and `index` from `adjunctions`. Note: this reversed the argument order to `index`.-* Proper upper bounds on dependencies.--3.1.1-------* Marked modules appropriately Trustworthy--3.0.1-------* Removed intra-package dependency bounds for my packages-* Build system improvements-* IRC Buildbot notification--3.0-----* Version sync with the rest of my packages--0.7----* "Data.Stream.NonEmpty" renamed to "Data.List.NonEmpty" and pushed upstream into the semigroups package.--0.6.3-------* Removed a redundant UNPACK pragma--0.5.1-------* Data.Stream.Supply added--Since 0.1:------------* A number of strictness issues with 'NonEmpty' were fixed-* More documentation+3.3.1 [2022.11.30] +------------------ +* Add `Boring` and `Absurd` instances for infinite streams. +* Add a `head :: Stream a -> a` function to `Data.Stream.Infinite`. + +3.3 +--- +* Removed a number of redundant parts of the API. If a method you were using has been removed, consider the classes available. No functionality was lost. +* Better support for GHC 7.10, the `Foldable (length, null)` members are now defined directly leading to asymptotic improvements and helping to further shrink the API. +* Added `prepend` and `concat` functions to `Data.Stream.Infinite` +* Allow `comonad-5` + +3.2.2 +----- +* Bug fix in `Data.Stream.Infinite.Skew` and removed `fromList`. + +3.2.1 +----- +* Add support for `semigroupoids` 5 and GHC 7.10 + +3.2 +--- +* Switched to `tabulate` and `index` from `adjunctions`. Note: this reversed the argument order to `index`. +* Proper upper bounds on dependencies. + +3.1.1 +----- +* Marked modules appropriately Trustworthy + +3.0.1 +----- +* Removed intra-package dependency bounds for my packages +* Build system improvements +* IRC Buildbot notification + +3.0 +--- +* Version sync with the rest of my packages + +0.7 +-- +* "Data.Stream.NonEmpty" renamed to "Data.List.NonEmpty" and pushed upstream into the semigroups package. + +0.6.3 +----- +* Removed a redundant UNPACK pragma + +0.5.1 +----- +* Data.Stream.Supply added + +Since 0.1: +---------- +* A number of strictness issues with 'NonEmpty' were fixed +* More documentation
LICENSE view
@@ -1,33 +1,33 @@-Copyright 2011 Edward Kmett-Copyright 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen-Copyright 2007-2010 Wouter Swierstra, Bas van Dijk-Copyright 2008 Iavor S. Diatchki--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.--2. Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.--3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,-STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN-ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.+Copyright 2011 Edward Kmett +Copyright 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen +Copyright 2007-2010 Wouter Swierstra, Bas van Dijk +Copyright 2008 Iavor S. Diatchki + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE.
README view
@@ -1,42 +1,42 @@--- currently implemented--* Data.Stream.Supply data Supply a = Supply a (Supply a) (Supply a)-* Data.Stream.Branching data Stream f a = a :< f (Stream a)-* Data.Stream.NonEmpty data NonEmpty a = a :| [a] -* Data.Stream.Future data Future a = Last a | a :< Future a-* Data.Stream.Future.Skew data Future a = Last a | !(Complete a) :< Future a-* Data.Stream.Infinite data Future a = a :< Future a-* Data.Stream.Infinite.Skew data Future a = !(Complete a) :< Future a-* Data.Stream.Infinite.Functional.Zipper data Zipper a = Zipper !(Integer -> a) !Integer---- TODO: refactor the existing Functional.Zipper to have a lower bound and add a Symmetric variant--- Data.Stream.Infinite.Functional.Zipper data Zipper a = Zipper !(Integer -> a) !Integer !Integer -- can seek arbitrarily--Data.Stream.Causal data Causal a = First a | Causal a :> a -Data.Stream.Causal.Infinite data Causal a = Causal a :> a-Data.Stream.Causal.Finite data Causal a = First a | !(Causal a) :> a-Data.Stream.Causal.Skew data Causal a = First a | Causal a :> !(Complete a)-Data.Stream.Causal.Infinite.Skew data Causal a = Causal a :> !(Complete a)--Data.Stream.Future.Finite data Future a = Last a | a :< !(Future a)--Data.Stream.Zipper data Zipper a = Now !(Finite.Causal a) | !(Finite.Causal a) :| (Future a) -Data.Stream.Zipper.Symmetric data Zipper a = Now !(Causal a) | !(Causal a) :| (Future a) -Data.Stream.Zipper.Infinite data Zipper a = !(Finite.Causal a) :| Infinite.Future a-Data.Stream.Zipper.Infinite.Symmetric data Zipper a = {- #UNPACK #-} !(Infinite.Causal a) :| Infinite.Future a-Data.Stream.Zipper.Finite data Zipper a = Now !(Finite.Causal a) | !(Finite.Causal a) :| !(Finite.Future a)-Data.Stream.Zipper.Skew data Zipper a = Zipper !(Seq a) !(Seq a) !(Skew.Future a)-Data.Stream.Zipper.Skew.Symmetric data Zipper a = Zipper !(S.Causal a) !(Seq a) !(Seq a) !(Skew.Future a)-Data.Stream.Zipper.Infinite.Skew data Zipper a = Zipper !(S.Causal a) !(Seq a) !(Seq a) !(IS.Future a)-Data.Stream.Zipper.Infinite.Skew.Symmetric data Zipper a = Zipper !(IS.Causal a) !(Seq a) !(Seq a) !(IS.Future a)--Data.Stream.Infinite.Functional.Future data Future a = Future !(Integer -> a) !Integer -- increment only-Data.Stream.Infinite.Functional.Causal data Causal a = Causal !(Integer -> a) !Integer -- decrement only--Data.Sequence.Future data Future a = Future !(Int# -> a) Int# Int#-Data.Sequence.Causal data Causal a = Causal !(Int# -> a) Int# Int#-Data.Sequence.Zipper data Zipper a = Zipper !(Int# -> a) Int# Int# Int#--Data.Tensors data Tensors f a = Last a | a :- Tensors f (f a)-Data.Tensors.Infinite data Tensors f a = a :- Tensors f (f a)-Data.Tensors.Finite data Tensors f a = Last a | a :- !(Tensors f (f a))+-- currently implemented + +* Data.Stream.Supply data Supply a = Supply a (Supply a) (Supply a) +* Data.Stream.Branching data Stream f a = a :< f (Stream a) +* Data.Stream.NonEmpty data NonEmpty a = a :| [a] +* Data.Stream.Future data Future a = Last a | a :< Future a +* Data.Stream.Future.Skew data Future a = Last a | !(Complete a) :< Future a +* Data.Stream.Infinite data Future a = a :< Future a +* Data.Stream.Infinite.Skew data Future a = !(Complete a) :< Future a +* Data.Stream.Infinite.Functional.Zipper data Zipper a = Zipper !(Integer -> a) !Integer + +-- TODO: refactor the existing Functional.Zipper to have a lower bound and add a Symmetric variant +-- Data.Stream.Infinite.Functional.Zipper data Zipper a = Zipper !(Integer -> a) !Integer !Integer -- can seek arbitrarily + +Data.Stream.Causal data Causal a = First a | Causal a :> a +Data.Stream.Causal.Infinite data Causal a = Causal a :> a +Data.Stream.Causal.Finite data Causal a = First a | !(Causal a) :> a +Data.Stream.Causal.Skew data Causal a = First a | Causal a :> !(Complete a) +Data.Stream.Causal.Infinite.Skew data Causal a = Causal a :> !(Complete a) + +Data.Stream.Future.Finite data Future a = Last a | a :< !(Future a) + +Data.Stream.Zipper data Zipper a = Now !(Finite.Causal a) | !(Finite.Causal a) :| (Future a) +Data.Stream.Zipper.Symmetric data Zipper a = Now !(Causal a) | !(Causal a) :| (Future a) +Data.Stream.Zipper.Infinite data Zipper a = !(Finite.Causal a) :| Infinite.Future a +Data.Stream.Zipper.Infinite.Symmetric data Zipper a = {- #UNPACK #-} !(Infinite.Causal a) :| Infinite.Future a +Data.Stream.Zipper.Finite data Zipper a = Now !(Finite.Causal a) | !(Finite.Causal a) :| !(Finite.Future a) +Data.Stream.Zipper.Skew data Zipper a = Zipper !(Seq a) !(Seq a) !(Skew.Future a) +Data.Stream.Zipper.Skew.Symmetric data Zipper a = Zipper !(S.Causal a) !(Seq a) !(Seq a) !(Skew.Future a) +Data.Stream.Zipper.Infinite.Skew data Zipper a = Zipper !(S.Causal a) !(Seq a) !(Seq a) !(IS.Future a) +Data.Stream.Zipper.Infinite.Skew.Symmetric data Zipper a = Zipper !(IS.Causal a) !(Seq a) !(Seq a) !(IS.Future a) + +Data.Stream.Infinite.Functional.Future data Future a = Future !(Integer -> a) !Integer -- increment only +Data.Stream.Infinite.Functional.Causal data Causal a = Causal !(Integer -> a) !Integer -- decrement only + +Data.Sequence.Future data Future a = Future !(Int# -> a) Int# Int# +Data.Sequence.Causal data Causal a = Causal !(Int# -> a) Int# Int# +Data.Sequence.Zipper data Zipper a = Zipper !(Int# -> a) Int# Int# Int# + +Data.Tensors data Tensors f a = Last a | a :- Tensors f (f a) +Data.Tensors.Infinite data Tensors f a = a :- Tensors f (f a) +Data.Tensors.Finite data Tensors f a = Last a | a :- !(Tensors f (f a))
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/runhaskell-> module Main (main) where--> import Distribution.Simple--> main :: IO ()-> main = defaultMain+#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain
src/Data/Stream/Future.hs view
@@ -1,164 +1,166 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Stream.Future--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable----------------------------------------------------------------------------------module Data.Stream.Future- ( Future(..)- , tail- , length- , index- ) where--#if MIN_VERSION_base(4,8,0)-import Prelude hiding (tail)-#else-import Control.Applicative-import Prelude hiding (tail, length)-import Data.Foldable-#endif--import Control.Comonad-import Data.Functor.Alt-import Data.Functor.Extend-import Data.Traversable-import Data.Semigroup hiding (Last)-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable--#ifdef LANGUAGE_DeriveDataTypeable-import Data.Data-#endif--#if MIN_VERSION_base(4,7,0)-import GHC.Exts as Exts-#endif--infixr 5 :<--data Future a = Last a | a :< Future a deriving- ( Eq, Ord, Show, Read-#ifdef LANGUAGE_DeriveDataTypeable- , Data, Typeable-#endif- )--#if __GLASGOW_HASKELL__ < 710-length :: Future a -> Int-length = go 1- where- go !n (Last _) = n- go !n (_ :< as) = go (n + 1) as-{-# INLINE length #-}-#endif--tail :: Future a -> Maybe (Future a)-tail (Last _) = Nothing-tail (_ :< as) = Just as-{-# INLINE tail #-}--index :: Int -> Future a -> a-index n aas- | n < 0 = error "index: negative index"- | n == 0 = extract aas- | otherwise = case aas of- Last _ -> error "index: out of range"- _ :< as -> index (n - 1) as--instance Functor Future where- fmap f (a :< as) = f a :< fmap f as- fmap f (Last a) = Last (f a)- b <$ (_ :< as) = b :< (b <$ as)- b <$ _ = Last b--instance Foldable Future where- foldMap = foldMapDefault-#if __GLASGOW_HASKELL__ >= 710- length = go 1- where- go !n (Last _) = n- go !n (_ :< as) = go (n + 1) as- {-# INLINE length #-}- null _ = False-#endif--instance Traversable Future where- traverse f (Last a) = Last <$> f a- traverse f (a :< as) = (:<) <$> f a <*> traverse f as--instance Foldable1 Future--instance Traversable1 Future where- traverse1 f (Last a) = Last <$> f a- traverse1 f (a :< as) = (:<) <$> f a <.> traverse1 f as--instance Extend Future where- extended = extend--instance Comonad Future where- extract (Last a) = a- extract (a :< _) = a-- duplicate w@(_ :< as) = w :< duplicate as- duplicate w@(Last _) = Last w-- extend f w@(_ :< as) = f w :< extend f as- extend f w@(Last _) = Last (f w)--instance Apply Future where- Last f <.> Last a = Last (f a)- (f :< _) <.> Last a = Last (f a)- Last f <.> (a :< _ ) = Last (f a)- (f :< fs) <.> (a :< as) = f a :< (fs <.> as)-- Last a <. _ = Last a- (a :< _ ) <. Last _ = Last a- (a :< as) <. (_ :< bs) = a :< (as <. bs)-- _ .> Last b = Last b- Last _ .> (b :< _) = Last b- (_ :< as) .> (b :< bs) = b :< (as .> bs)--instance ComonadApply Future where- (<@>) = (<.>)--instance Alt Future where- Last a <!> bs = a :< bs- (a :< as) <!> bs = a :< (as <!> bs)--instance Semigroup (Future a) where- (<>) = (<!>)--instance Applicative Future where- pure = Last- (<*>) = (<.>)- (<* ) = (<. )- ( *>) = ( .>)--#if MIN_VERSION_base(4,7,0)-instance Exts.IsList (Future a) where- type Item (Future a) = a-- toList (Last a) = [a]- toList (a :< as) = a : Exts.toList as-- fromList [] = error "Future.fromList: empty list"- fromList (x:xs) = go x xs where- go y [] = Last y- go y (z:zs) = y :< go z zs-- fromListN _ = Exts.fromList-#endif+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Future +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- + +module Data.Stream.Future + ( Future(..) + , tail + , length + , index + ) where + +#if MIN_VERSION_base(4,8,0) +import Prelude hiding (tail) +#else +import Control.Applicative +import Prelude hiding (tail, length) +import Data.Foldable +#endif + +import Control.Comonad +import Data.Functor.Alt +import Data.Functor.Extend +import Data.Traversable +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup hiding (Last) +#endif +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable + +#ifdef LANGUAGE_DeriveDataTypeable +import Data.Data +#endif + +#if MIN_VERSION_base(4,7,0) +import GHC.Exts as Exts +#endif + +infixr 5 :< + +data Future a = Last a | a :< Future a deriving + ( Eq, Ord, Show, Read +#ifdef LANGUAGE_DeriveDataTypeable + , Data, Typeable +#endif + ) + +#if __GLASGOW_HASKELL__ < 710 +length :: Future a -> Int +length = go 1 + where + go !n (Last _) = n + go !n (_ :< as) = go (n + 1) as +{-# INLINE length #-} +#endif + +tail :: Future a -> Maybe (Future a) +tail (Last _) = Nothing +tail (_ :< as) = Just as +{-# INLINE tail #-} + +index :: Int -> Future a -> a +index n aas + | n < 0 = error "index: negative index" + | n == 0 = extract aas + | otherwise = case aas of + Last _ -> error "index: out of range" + _ :< as -> index (n - 1) as + +instance Functor Future where + fmap f (a :< as) = f a :< fmap f as + fmap f (Last a) = Last (f a) + b <$ (_ :< as) = b :< (b <$ as) + b <$ _ = Last b + +instance Foldable Future where + foldMap = foldMapDefault +#if __GLASGOW_HASKELL__ >= 710 + length = go 1 + where + go !n (Last _) = n + go !n (_ :< as) = go (n + 1) as + {-# INLINE length #-} + null _ = False +#endif + +instance Traversable Future where + traverse f (Last a) = Last <$> f a + traverse f (a :< as) = (:<) <$> f a <*> traverse f as + +instance Foldable1 Future + +instance Traversable1 Future where + traverse1 f (Last a) = Last <$> f a + traverse1 f (a :< as) = (:<) <$> f a <.> traverse1 f as + +instance Extend Future where + extended = extend + +instance Comonad Future where + extract (Last a) = a + extract (a :< _) = a + + duplicate w@(_ :< as) = w :< duplicate as + duplicate w@(Last _) = Last w + + extend f w@(_ :< as) = f w :< extend f as + extend f w@(Last _) = Last (f w) + +instance Apply Future where + Last f <.> Last a = Last (f a) + (f :< _) <.> Last a = Last (f a) + Last f <.> (a :< _ ) = Last (f a) + (f :< fs) <.> (a :< as) = f a :< (fs <.> as) + + Last a <. _ = Last a + (a :< _ ) <. Last _ = Last a + (a :< as) <. (_ :< bs) = a :< (as <. bs) + + _ .> Last b = Last b + Last _ .> (b :< _) = Last b + (_ :< as) .> (b :< bs) = b :< (as .> bs) + +instance ComonadApply Future where + (<@>) = (<.>) + +instance Alt Future where + Last a <!> bs = a :< bs + (a :< as) <!> bs = a :< (as <!> bs) + +instance Semigroup (Future a) where + (<>) = (<!>) + +instance Applicative Future where + pure = Last + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + +#if MIN_VERSION_base(4,7,0) +instance Exts.IsList (Future a) where + type Item (Future a) = a + + toList (Last a) = [a] + toList (a :< as) = a : Exts.toList as + + fromList [] = error "Future.fromList: empty list" + fromList (x:xs) = go x xs where + go y [] = Last y + go y (z:zs) = y :< go z zs + + fromListN _ = Exts.fromList +#endif
src/Data/Stream/Future/Skew.hs view
@@ -1,439 +1,441 @@-{-# LANGUAGE PatternGuards, BangPatterns, TypeFamilies #-}-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Module : Data.Stream.Future.Skew--- Copyright : (C) 2008-2015 Edward Kmett,--- (C) 2004 Dave Menendez--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ Anticausal streams implemented as non-empty skew binary random access lists------ The Applicative zips streams, but since these are potentially infinite--- this is stricter than would be desired. You almost always want----------------------------------------------------------------------------------module Data.Stream.Future.Skew- ( Future(..)- , (<|) -- O(1)- , length -- O(log n)- , tail -- O(1)- , last -- O(log n)- , uncons -- O(1)- , index -- O(log n)- , drop -- O(log n)- , dropWhile -- O(n)- , indexed- , from- , break- , span- , split -- O(log n)- , splitW -- O(log n)- , replicate -- O(log n)- , insert -- O(n)- , insertBy- , update- , adjust -- O(log n)- , toFuture- , singleton- ) where--import Control.Applicative hiding (empty)-import Control.Comonad-import Data.Functor.Alt-import Data.Functor.Extend-#if MIN_VERSION_base(4,8,0)-import Prelude hiding (tail, drop, dropWhile, last, span, repeat, replicate, break)-import Data.Foldable (toList)-#else-import Data.Foldable-import Data.Traversable (Traversable, traverse)-import Prelude hiding (null, tail, drop, dropWhile, length, foldr, last, span, repeat, replicate, break)-#endif-import Data.Semigroup hiding (Last)-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-#if MIN_VERSION_base(4,7,0)-import qualified GHC.Exts as Exts-#endif--infixr 5 :<, <|--data Complete a- = Tip a- | Bin {-# UNPACK #-} !Int a !(Complete a) !(Complete a)- deriving Show--instance Functor Complete where- fmap f (Tip a) = Tip (f a)- fmap f (Bin w a l r) = Bin w (f a) (fmap f l) (fmap f r)--instance Extend Complete where- extended = extend--instance Comonad Complete where- extend f w@Tip {} = Tip (f w)- extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r)- extract (Tip a) = a- extract (Bin _ a _ _) = a--instance Foldable Complete where- foldMap f (Tip a) = f a- foldMap f (Bin _ a l r) = f a `mappend` foldMap f l `mappend` foldMap f r- foldr f z (Tip a) = f a z- foldr f z (Bin _ a l r) = f a (foldr f (foldr f z r) l)-#if MIN_VERSION_base(4,8,0)- length Tip{} = 1- length (Bin n _ _ _) = n- null _ = False-#endif--instance Foldable1 Complete where- foldMap1 f (Tip a) = f a- foldMap1 f (Bin _ a l r) = f a <> foldMap1 f l <> foldMap1 f r--instance Traversable Complete where- traverse f (Tip a) = Tip <$> f a- traverse f (Bin n a l r) = Bin n <$> f a <*> traverse f l <*> traverse f r--instance Traversable1 Complete where- traverse1 f (Tip a) = Tip <$> f a- traverse1 f (Bin n a l r) = Bin n <$> f a <.> traverse1 f l <.> traverse1 f r--bin :: a -> Complete a -> Complete a -> Complete a-bin a l r = Bin (1 + weight l + weight r) a l r-{-# INLINE bin #-}--weight :: Complete a -> Int-weight Tip{} = 1-weight (Bin w _ _ _) = w-{-# INLINE weight #-}---- A future is a non-empty skew binary random access list of nodes.--- The last node, however, is allowed to contain fewer values.-data Future a- = Last !(Complete a)- | !(Complete a) :< Future a--- deriving Show---instance Show a => Show (Future a) where- showsPrec d as = showParen (d >= 10) $- showString "fromList " . showsPrec 11 (toList as)--instance Functor Future where- fmap f (t :< ts) = fmap f t :< fmap f ts- fmap f (Last t) = Last (fmap f t)--instance Extend Future where- extended = extend--instance Comonad Future where- extend g (Last t) = Last (extendTree g t Last)- extend g (t :< ts) = extendTree g t (:< ts) :< extend g ts- extract (a :< _) = extract a- extract (Last a) = extract a--extendTree :: (Future a -> b) -> Complete a -> (Complete a -> Future a) -> Complete b-extendTree g w@Tip{} f = Tip (g (f w))-extendTree g w@(Bin n _ l r) f = Bin n (g (f w)) (extendTree g l (:< f r)) (extendTree g r f)--instance Apply Future where- Last (Tip f) <.> as = singleton (f (extract as))- fs <.> Last (Tip a) = singleton (extract fs a)- Last (Bin _ f lf rf) <.> Last (Bin _ a la ra) = f a <| (lf :< Last rf <.> la :< Last ra )- Last (Bin _ f lf rf) <.> Bin _ a la ra :< as = f a <| (lf :< Last rf <.> la :< ra :< as)- Last (Bin _ f lf rf) <.> Tip a :< as = f a <| (lf :< Last rf <.> as )- Bin _ f lf rf :< fs <.> Last (Bin _ a la ra) = f a <| (lf :< rf :< fs <.> la :< Last ra )- Bin _ f lf rf :< fs <.> Tip a :< as = f a <| (lf :< rf :< fs <.> as )- Bin _ f lf rf :< fs <.> Bin _ a la ra :< as = f a <| (lf :< rf :< fs <.> la :< ra :< as)- Tip f :< fs <.> Tip a :< as = f a <| (fs <.> as )- Tip f :< fs <.> Bin _ a la ra :< as = f a <| (fs <.> la :< ra :< as)- Tip f :< fs <.> Last (Bin _ a la ra) = f a <| (fs <.> la :< Last ra )--instance ComonadApply Future where- (<@>) = (<.>)--instance Applicative Future where- pure a0 = go a0 (Tip a0) where- go :: a -> Complete a -> Future a- go a as | ass <- bin a as as = as :< go a ass- (<*>) = (<.>)--instance Alt Future where- as <!> bs = foldr (<|) bs as--instance Foldable Future where- foldMap f (t :< ts) = foldMap f t `mappend` foldMap f ts- foldMap f (Last t) = foldMap f t- foldr f z (t :< ts) = foldr f (foldr f z ts) t- foldr f z (Last t) = foldr f z t-#if MIN_VERSION_base(4,8,0)- length (Last t) = weight t- length (t :< ts) = weight t + length ts- null _ = False-#endif--instance Foldable1 Future where- foldMap1 f (t :< ts) = foldMap1 f t <> foldMap1 f ts- foldMap1 f (Last t) = foldMap1 f t--instance Traversable Future where- traverse f (t :< ts) = (:<) <$> traverse f t <*> traverse f ts- traverse f (Last t) = Last <$> traverse f t--instance Traversable1 Future where- traverse1 f (t :< ts) = (:<) <$> traverse1 f t <.> traverse1 f ts- traverse1 f (Last t) = Last <$> traverse1 f t---- | /O(log n)/-replicate :: Int -> a -> Future a-replicate n a- | n <= 0 = error "replicate: non-positive argument"- | otherwise = go 1 n a (Tip a) (\ _ r -> r)- where- -- invariants:- -- tb is a complete tree of i nodes all equal to b- -- 1 <= i = 2^m-1 <= j- -- k accepts r such that 0 <= r < i- go :: Int -> Int -> b -> Complete b -> (Int -> Future b -> r) -> r- go !i !j b tb k- | j >= i2p1 = go i2p1 j b (Bin i2p1 b tb tb) k'- | j >= i2 = k (j - i2) (tb :< Last tb)- | otherwise = k (j - i) (Last tb)- where- i2 = i * 2- i2p1 = i2 + 1- k' r xs- | r >= i2 = k (r - i2) (tb :< tb :< xs)- | r >= i = k (r - i) (tb :< xs)- | otherwise = k r xs-{-# INLINE replicate #-}--mapWithIndex :: (Int -> a -> b) -> Future a -> Future b-mapWithIndex f0 as0 = spine f0 0 as0- where- spine f m (Last as) = Last (tree f m as)- spine f m (a :< as) = tree f m a :< spine f (m + weight a) as- tree f m (Tip a) = Tip (f m a)- tree f m (Bin n a l r) = Bin n (f m a) (tree f (m + 1) l) (tree f (m + 1 + weight l) r)--indexed :: Future a -> Future (Int, a)-indexed = mapWithIndex (,)-{-# INLINE indexed #-}--from :: Num a => a -> Future a-from a = mapWithIndex ((+) . fromIntegral) (pure a)-{-# INLINE from #-}---- | /O(1)/-singleton :: a -> Future a-singleton a = Last (Tip a)-{-# INLINE singleton #-}--#if !(MIN_VERSION_base(4,8,0))--- | /O(log n)/.-length :: Future a -> Int-length (Last t) = weight t-length (t :< ts) = weight t + length ts-#endif---- | /O(1)/ cons-(<|) :: a -> Future a -> Future a-a <| (l :< Last r)- | weight l == weight r = Last (bin a l r)-a <| (l :< r :< as)- | weight l == weight r = bin a l r :< as-a <| as = Tip a :< as-{-# INLINE (<|) #-}---- | /O(1)/.-tail :: Future a -> Maybe (Future a)-tail (Tip{} :< ts) = Just ts-tail (Bin _ _ l r :< ts) = Just (l :< r :< ts)-tail (Last Tip{}) = Nothing-tail (Last (Bin _ _ l r)) = Just (l :< Last r)-{-# INLINE tail #-}---- | /O(log n)/.-last :: Future a -> a-last (_ :< as) = last as-last (Last as) = go as- where go (Tip a) = a- go (Bin _ _ _ r) = go r---- | /O(1)/.-uncons :: Future a -> (a, Maybe (Future a))-uncons (Last (Tip a)) = (a, Nothing)-uncons (Last (Bin _ a l r)) = (a, Just (l :< Last r))-uncons (Tip a :< as) = (a, Just as)-uncons (Bin _ a l r :< as) = (a, Just (l :< r :< as))-{-# INLINE uncons #-}---- | /O(log n)/.-index :: Int -> Future a -> a-index i (Last t)- | i < weight t = indexComplete i t- | otherwise = error "index: out of range"-index i (t :< ts)- | i < w = indexComplete i t- | otherwise = index (i - w) ts- where w = weight t--indexComplete :: Int -> Complete a -> a-indexComplete 0 (Tip a) = a-indexComplete i (Bin w a l r)- | i == 0 = a- | i <= w' = indexComplete (i-1) l- | otherwise = indexComplete (i-1-w') r- where w' = div w 2-indexComplete _ _ = error "index: index out of range"---- | /O(log n)/.-drop :: Int -> Future a -> Maybe (Future a)-drop 0 ts = Just ts-drop i (t :< ts) = case compare i w of- LT -> Just (dropComplete i t (:< ts))- EQ -> Just ts- GT -> drop (i - w) ts- where w = weight t-drop i (Last t)- | i < w = Just (dropComplete i t Last)- | otherwise = Nothing- where w = weight t--dropComplete :: Int -> Complete a -> (Complete a -> Future a) -> Future a-dropComplete 0 t f = f t-dropComplete 1 (Bin _ _ l r) f = l :< f r-dropComplete i (Bin w _ l r) f = case compare (i - 1) w' of- LT -> dropComplete (i-1) l (:< f r)- EQ -> f r- GT -> dropComplete (i-1-w') r f- where w' = div w 2-dropComplete _ _ _ = error "drop: index out of range"---- /O(n)/.-dropWhile :: (a -> Bool) -> Future a -> Maybe (Future a)-dropWhile p as- | p (extract as) = tail as >>= dropWhile p- | otherwise = Just as---- /O(n)/-span :: (a -> Bool) -> Future a -> ([a], Maybe (Future a))-span p aas = case uncons aas of- (a, Just as) | p a, (ts, fs) <- span p as -> (a:ts, fs)- (a, Nothing) | p a -> ([a], Nothing)- (_, _) -> ([], Just aas)---- /O(n)/-break :: (a -> Bool) -> Future a -> ([a], Maybe (Future a))-break p = span (not . p)---- /(O(n), O(log n))/ split at _some_ edge where function goes from False to True.--- best used with a monotonic function-split :: (a -> Bool) -> Future a -> ([a], Maybe (Future a))-split p l@(Last a)- | p (extract a) = ([], Just l)- | otherwise = splitComplete p a Last-split p (a :< as)- | p (extract as) = splitComplete p a (:< as)- | (ts, fs) <- split p as = (foldr (:) ts a, fs)---- for use when we know the split occurs within a given tree-splitComplete :: (a -> Bool) -> Complete a -> (Complete a -> Future a) -> ([a], Maybe (Future a))-splitComplete p t@(Tip a) f- | p a = ([], Just (f t))- | otherwise = ([a], Nothing)-splitComplete p t@(Bin _ a l r) f- | p a = ([], Just (f t))- | p (extract r), (ts, fs) <- splitComplete p l (:< f r) = (a:ts, fs)- | (ts, fs) <- splitComplete p r f = (a:foldr (:) ts l, fs)---- /(O(n), O(log n))/ split at _some_ edge where function goes from False to True.--- best used with a monotonic function------ > splitW p xs = (map extract &&& fmap (fmap extract)) . split p . duplicate-splitW :: (Future a -> Bool) -> Future a -> ([a], Maybe (Future a))-splitW p l@(Last a)- | p l = ([], Just l)- | otherwise = splitCompleteW p a Last-splitW p (a :< as)- | p as = splitCompleteW p a (:< as)- | (ts, fs) <- splitW p as = (foldr (:) ts a, fs)---- for use when we know the split occurs within a given tree-splitCompleteW :: (Future a -> Bool) -> Complete a -> (Complete a -> Future a) -> ([a], Maybe (Future a))-splitCompleteW p t@(Tip a) f- | w <- f t, p w = ([], Just w)- | otherwise = ([a], Nothing)-splitCompleteW p t@(Bin _ a l r) f- | w <- f t, p w = ([], Just w)- | w <- f r, p w, (ts, fs) <- splitCompleteW p l (:< w) = (a:ts, fs)- | (ts, fs) <- splitCompleteW p r f = (a:foldr (:) ts l, fs)--#if MIN_VERSION_base(4,7,0)-instance Exts.IsList (Future a) where- type Item (Future a) = a- toList = Data.Foldable.toList- fromList [] = error "fromList: empty list"- fromList (x:xs) = go x xs- where go a [] = singleton a- go a (b:bs) = a <| go b bs-#else-fromList :: [a] -> Future a-fromList [] = error "fromList: empty list"-fromList (x:xs) = go x xs- where go a [] = singleton a- go a (b:bs) = a <| go b bs-#endif--toFuture :: [a] -> Maybe (Future a)-toFuture [] = Nothing-#if MIN_VERSION_base(4,7,0)-toFuture xs = Just (Exts.fromList xs)-#else-toFuture xs = Just (fromList xs)-#endif---- /O(n)/-insert :: Ord a => a -> Future a -> Future a-insert a as = case split (a<=) as of- (_, Nothing) -> foldr (<|) (singleton a) as- (ts, Just as') -> foldr (<|) (a <| as') ts---- /O(n)/. Finds the split in O(log n), but then has to recons-insertBy :: (a -> a -> Ordering) -> a -> Future a -> Future a-insertBy cmp a as = case split (\b -> cmp a b <= EQ) as of- (_, Nothing) -> foldr (<|) (singleton a) as- (ts, Just as') -> foldr (<|) (a <| as') ts---- /O(log n)/ Change the value of the nth entry in the future-adjust :: Int -> (a -> a) -> Future a -> Future a-adjust !n f d@(Last a)- | n < weight a = Last (adjustComplete n f a)- | otherwise = d-adjust !n f (a :< as)- | n < w = adjustComplete n f a :< as- | otherwise = a :< adjust (n - w) f as- where w = weight a--adjustComplete :: Int -> (a -> a) -> Complete a -> Complete a-adjustComplete 0 f (Tip a) = Tip (f a)-adjustComplete _ _ t@Tip{} = t-adjustComplete n f (Bin m a l r)- | n == 0 = Bin m (f a) l r- | n < w = Bin m a (adjustComplete (n - 1) f l) r- | otherwise = Bin m a l (adjustComplete (n - 1 - w) f r)- where w = weight l--update :: Int -> a -> Future a -> Future a-update n = adjust n . const+{-# LANGUAGE PatternGuards, BangPatterns, TypeFamilies #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Future.Skew +-- Copyright : (C) 2008-2015 Edward Kmett, +-- (C) 2004 Dave Menendez +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- Anticausal streams implemented as non-empty skew binary random access lists +-- +-- The Applicative zips streams, but since these are potentially infinite +-- this is stricter than would be desired. You almost always want +------------------------------------------------------------------------------ + + +module Data.Stream.Future.Skew + ( Future(..) + , (<|) -- O(1) + , length -- O(log n) + , tail -- O(1) + , last -- O(log n) + , uncons -- O(1) + , index -- O(log n) + , drop -- O(log n) + , dropWhile -- O(n) + , indexed + , from + , break + , span + , split -- O(log n) + , splitW -- O(log n) + , replicate -- O(log n) + , insert -- O(n) + , insertBy + , update + , adjust -- O(log n) + , toFuture + , singleton + ) where + +import Control.Applicative hiding (empty) +import Control.Comonad +import Data.Functor.Alt +import Data.Functor.Extend +#if MIN_VERSION_base(4,8,0) +import Prelude hiding (tail, drop, dropWhile, last, span, repeat, replicate, break) +import Data.Foldable (toList) +#else +import Data.Foldable +import Data.Traversable (Traversable, traverse) +import Prelude hiding (null, tail, drop, dropWhile, length, foldr, last, span, repeat, replicate, break) +#endif +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup hiding (Last) +#endif +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +#if MIN_VERSION_base(4,7,0) +import qualified GHC.Exts as Exts +#endif + +infixr 5 :<, <| + +data Complete a + = Tip a + | Bin {-# UNPACK #-} !Int a !(Complete a) !(Complete a) + deriving Show + +instance Functor Complete where + fmap f (Tip a) = Tip (f a) + fmap f (Bin w a l r) = Bin w (f a) (fmap f l) (fmap f r) + +instance Extend Complete where + extended = extend + +instance Comonad Complete where + extend f w@Tip {} = Tip (f w) + extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r) + extract (Tip a) = a + extract (Bin _ a _ _) = a + +instance Foldable Complete where + foldMap f (Tip a) = f a + foldMap f (Bin _ a l r) = f a `mappend` foldMap f l `mappend` foldMap f r + foldr f z (Tip a) = f a z + foldr f z (Bin _ a l r) = f a (foldr f (foldr f z r) l) +#if MIN_VERSION_base(4,8,0) + length Tip{} = 1 + length (Bin n _ _ _) = n + null _ = False +#endif + +instance Foldable1 Complete where + foldMap1 f (Tip a) = f a + foldMap1 f (Bin _ a l r) = f a <> foldMap1 f l <> foldMap1 f r + +instance Traversable Complete where + traverse f (Tip a) = Tip <$> f a + traverse f (Bin n a l r) = Bin n <$> f a <*> traverse f l <*> traverse f r + +instance Traversable1 Complete where + traverse1 f (Tip a) = Tip <$> f a + traverse1 f (Bin n a l r) = Bin n <$> f a <.> traverse1 f l <.> traverse1 f r + +bin :: a -> Complete a -> Complete a -> Complete a +bin a l r = Bin (1 + weight l + weight r) a l r +{-# INLINE bin #-} + +weight :: Complete a -> Int +weight Tip{} = 1 +weight (Bin w _ _ _) = w +{-# INLINE weight #-} + +-- A future is a non-empty skew binary random access list of nodes. +-- The last node, however, is allowed to contain fewer values. +data Future a + = Last !(Complete a) + | !(Complete a) :< Future a +-- deriving Show + + +instance Show a => Show (Future a) where + showsPrec d as = showParen (d >= 10) $ + showString "fromList " . showsPrec 11 (toList as) + +instance Functor Future where + fmap f (t :< ts) = fmap f t :< fmap f ts + fmap f (Last t) = Last (fmap f t) + +instance Extend Future where + extended = extend + +instance Comonad Future where + extend g (Last t) = Last (extendTree g t Last) + extend g (t :< ts) = extendTree g t (:< ts) :< extend g ts + extract (a :< _) = extract a + extract (Last a) = extract a + +extendTree :: (Future a -> b) -> Complete a -> (Complete a -> Future a) -> Complete b +extendTree g w@Tip{} f = Tip (g (f w)) +extendTree g w@(Bin n _ l r) f = Bin n (g (f w)) (extendTree g l (:< f r)) (extendTree g r f) + +instance Apply Future where + Last (Tip f) <.> as = singleton (f (extract as)) + fs <.> Last (Tip a) = singleton (extract fs a) + Last (Bin _ f lf rf) <.> Last (Bin _ a la ra) = f a <| (lf :< Last rf <.> la :< Last ra ) + Last (Bin _ f lf rf) <.> Bin _ a la ra :< as = f a <| (lf :< Last rf <.> la :< ra :< as) + Last (Bin _ f lf rf) <.> Tip a :< as = f a <| (lf :< Last rf <.> as ) + Bin _ f lf rf :< fs <.> Last (Bin _ a la ra) = f a <| (lf :< rf :< fs <.> la :< Last ra ) + Bin _ f lf rf :< fs <.> Tip a :< as = f a <| (lf :< rf :< fs <.> as ) + Bin _ f lf rf :< fs <.> Bin _ a la ra :< as = f a <| (lf :< rf :< fs <.> la :< ra :< as) + Tip f :< fs <.> Tip a :< as = f a <| (fs <.> as ) + Tip f :< fs <.> Bin _ a la ra :< as = f a <| (fs <.> la :< ra :< as) + Tip f :< fs <.> Last (Bin _ a la ra) = f a <| (fs <.> la :< Last ra ) + +instance ComonadApply Future where + (<@>) = (<.>) + +instance Applicative Future where + pure a0 = go a0 (Tip a0) where + go :: a -> Complete a -> Future a + go a as | ass <- bin a as as = as :< go a ass + (<*>) = (<.>) + +instance Alt Future where + as <!> bs = foldr (<|) bs as + +instance Foldable Future where + foldMap f (t :< ts) = foldMap f t `mappend` foldMap f ts + foldMap f (Last t) = foldMap f t + foldr f z (t :< ts) = foldr f (foldr f z ts) t + foldr f z (Last t) = foldr f z t +#if MIN_VERSION_base(4,8,0) + length (Last t) = weight t + length (t :< ts) = weight t + length ts + null _ = False +#endif + +instance Foldable1 Future where + foldMap1 f (t :< ts) = foldMap1 f t <> foldMap1 f ts + foldMap1 f (Last t) = foldMap1 f t + +instance Traversable Future where + traverse f (t :< ts) = (:<) <$> traverse f t <*> traverse f ts + traverse f (Last t) = Last <$> traverse f t + +instance Traversable1 Future where + traverse1 f (t :< ts) = (:<) <$> traverse1 f t <.> traverse1 f ts + traverse1 f (Last t) = Last <$> traverse1 f t + +-- | /O(log n)/ +replicate :: Int -> a -> Future a +replicate n a + | n <= 0 = error "replicate: non-positive argument" + | otherwise = go 1 n a (Tip a) (\ _ r -> r) + where + -- invariants: + -- tb is a complete tree of i nodes all equal to b + -- 1 <= i = 2^m-1 <= j + -- k accepts r such that 0 <= r < i + go :: Int -> Int -> b -> Complete b -> (Int -> Future b -> r) -> r + go !i !j b tb k + | j >= i2p1 = go i2p1 j b (Bin i2p1 b tb tb) k' + | j >= i2 = k (j - i2) (tb :< Last tb) + | otherwise = k (j - i) (Last tb) + where + i2 = i * 2 + i2p1 = i2 + 1 + k' r xs + | r >= i2 = k (r - i2) (tb :< tb :< xs) + | r >= i = k (r - i) (tb :< xs) + | otherwise = k r xs +{-# INLINE replicate #-} + +mapWithIndex :: (Int -> a -> b) -> Future a -> Future b +mapWithIndex f0 as0 = spine f0 0 as0 + where + spine f m (Last as) = Last (tree f m as) + spine f m (a :< as) = tree f m a :< spine f (m + weight a) as + tree f m (Tip a) = Tip (f m a) + tree f m (Bin n a l r) = Bin n (f m a) (tree f (m + 1) l) (tree f (m + 1 + weight l) r) + +indexed :: Future a -> Future (Int, a) +indexed = mapWithIndex (,) +{-# INLINE indexed #-} + +from :: Num a => a -> Future a +from a = mapWithIndex ((+) . fromIntegral) (pure a) +{-# INLINE from #-} + +-- | /O(1)/ +singleton :: a -> Future a +singleton a = Last (Tip a) +{-# INLINE singleton #-} + +#if !(MIN_VERSION_base(4,8,0)) +-- | /O(log n)/. +length :: Future a -> Int +length (Last t) = weight t +length (t :< ts) = weight t + length ts +#endif + +-- | /O(1)/ cons +(<|) :: a -> Future a -> Future a +a <| (l :< Last r) + | weight l == weight r = Last (bin a l r) +a <| (l :< r :< as) + | weight l == weight r = bin a l r :< as +a <| as = Tip a :< as +{-# INLINE (<|) #-} + +-- | /O(1)/. +tail :: Future a -> Maybe (Future a) +tail (Tip{} :< ts) = Just ts +tail (Bin _ _ l r :< ts) = Just (l :< r :< ts) +tail (Last Tip{}) = Nothing +tail (Last (Bin _ _ l r)) = Just (l :< Last r) +{-# INLINE tail #-} + +-- | /O(log n)/. +last :: Future a -> a +last (_ :< as) = last as +last (Last as) = go as + where go (Tip a) = a + go (Bin _ _ _ r) = go r + +-- | /O(1)/. +uncons :: Future a -> (a, Maybe (Future a)) +uncons (Last (Tip a)) = (a, Nothing) +uncons (Last (Bin _ a l r)) = (a, Just (l :< Last r)) +uncons (Tip a :< as) = (a, Just as) +uncons (Bin _ a l r :< as) = (a, Just (l :< r :< as)) +{-# INLINE uncons #-} + +-- | /O(log n)/. +index :: Int -> Future a -> a +index i (Last t) + | i < weight t = indexComplete i t + | otherwise = error "index: out of range" +index i (t :< ts) + | i < w = indexComplete i t + | otherwise = index (i - w) ts + where w = weight t + +indexComplete :: Int -> Complete a -> a +indexComplete 0 (Tip a) = a +indexComplete i (Bin w a l r) + | i == 0 = a + | i <= w' = indexComplete (i-1) l + | otherwise = indexComplete (i-1-w') r + where w' = div w 2 +indexComplete _ _ = error "index: index out of range" + +-- | /O(log n)/. +drop :: Int -> Future a -> Maybe (Future a) +drop 0 ts = Just ts +drop i (t :< ts) = case compare i w of + LT -> Just (dropComplete i t (:< ts)) + EQ -> Just ts + GT -> drop (i - w) ts + where w = weight t +drop i (Last t) + | i < w = Just (dropComplete i t Last) + | otherwise = Nothing + where w = weight t + +dropComplete :: Int -> Complete a -> (Complete a -> Future a) -> Future a +dropComplete 0 t f = f t +dropComplete 1 (Bin _ _ l r) f = l :< f r +dropComplete i (Bin w _ l r) f = case compare (i - 1) w' of + LT -> dropComplete (i-1) l (:< f r) + EQ -> f r + GT -> dropComplete (i-1-w') r f + where w' = div w 2 +dropComplete _ _ _ = error "drop: index out of range" + +-- /O(n)/. +dropWhile :: (a -> Bool) -> Future a -> Maybe (Future a) +dropWhile p as + | p (extract as) = tail as >>= dropWhile p + | otherwise = Just as + +-- /O(n)/ +span :: (a -> Bool) -> Future a -> ([a], Maybe (Future a)) +span p aas = case uncons aas of + (a, Just as) | p a, (ts, fs) <- span p as -> (a:ts, fs) + (a, Nothing) | p a -> ([a], Nothing) + (_, _) -> ([], Just aas) + +-- /O(n)/ +break :: (a -> Bool) -> Future a -> ([a], Maybe (Future a)) +break p = span (not . p) + +-- /(O(n), O(log n))/ split at _some_ edge where function goes from False to True. +-- best used with a monotonic function +split :: (a -> Bool) -> Future a -> ([a], Maybe (Future a)) +split p l@(Last a) + | p (extract a) = ([], Just l) + | otherwise = splitComplete p a Last +split p (a :< as) + | p (extract as) = splitComplete p a (:< as) + | (ts, fs) <- split p as = (foldr (:) ts a, fs) + +-- for use when we know the split occurs within a given tree +splitComplete :: (a -> Bool) -> Complete a -> (Complete a -> Future a) -> ([a], Maybe (Future a)) +splitComplete p t@(Tip a) f + | p a = ([], Just (f t)) + | otherwise = ([a], Nothing) +splitComplete p t@(Bin _ a l r) f + | p a = ([], Just (f t)) + | p (extract r), (ts, fs) <- splitComplete p l (:< f r) = (a:ts, fs) + | (ts, fs) <- splitComplete p r f = (a:foldr (:) ts l, fs) + +-- /(O(n), O(log n))/ split at _some_ edge where function goes from False to True. +-- best used with a monotonic function +-- +-- > splitW p xs = (map extract &&& fmap (fmap extract)) . split p . duplicate +splitW :: (Future a -> Bool) -> Future a -> ([a], Maybe (Future a)) +splitW p l@(Last a) + | p l = ([], Just l) + | otherwise = splitCompleteW p a Last +splitW p (a :< as) + | p as = splitCompleteW p a (:< as) + | (ts, fs) <- splitW p as = (foldr (:) ts a, fs) + +-- for use when we know the split occurs within a given tree +splitCompleteW :: (Future a -> Bool) -> Complete a -> (Complete a -> Future a) -> ([a], Maybe (Future a)) +splitCompleteW p t@(Tip a) f + | w <- f t, p w = ([], Just w) + | otherwise = ([a], Nothing) +splitCompleteW p t@(Bin _ a l r) f + | w <- f t, p w = ([], Just w) + | w <- f r, p w, (ts, fs) <- splitCompleteW p l (:< w) = (a:ts, fs) + | (ts, fs) <- splitCompleteW p r f = (a:foldr (:) ts l, fs) + +#if MIN_VERSION_base(4,7,0) +instance Exts.IsList (Future a) where + type Item (Future a) = a + toList = Data.Foldable.toList + fromList [] = error "fromList: empty list" + fromList (x:xs) = go x xs + where go a [] = singleton a + go a (b:bs) = a <| go b bs +#else +fromList :: [a] -> Future a +fromList [] = error "fromList: empty list" +fromList (x:xs) = go x xs + where go a [] = singleton a + go a (b:bs) = a <| go b bs +#endif + +toFuture :: [a] -> Maybe (Future a) +toFuture [] = Nothing +#if MIN_VERSION_base(4,7,0) +toFuture xs = Just (Exts.fromList xs) +#else +toFuture xs = Just (fromList xs) +#endif + +-- /O(n)/ +insert :: Ord a => a -> Future a -> Future a +insert a as = case split (a<=) as of + (_, Nothing) -> foldr (<|) (singleton a) as + (ts, Just as') -> foldr (<|) (a <| as') ts + +-- /O(n)/. Finds the split in O(log n), but then has to recons +insertBy :: (a -> a -> Ordering) -> a -> Future a -> Future a +insertBy cmp a as = case split (\b -> cmp a b <= EQ) as of + (_, Nothing) -> foldr (<|) (singleton a) as + (ts, Just as') -> foldr (<|) (a <| as') ts + +-- /O(log n)/ Change the value of the nth entry in the future +adjust :: Int -> (a -> a) -> Future a -> Future a +adjust !n f d@(Last a) + | n < weight a = Last (adjustComplete n f a) + | otherwise = d +adjust !n f (a :< as) + | n < w = adjustComplete n f a :< as + | otherwise = a :< adjust (n - w) f as + where w = weight a + +adjustComplete :: Int -> (a -> a) -> Complete a -> Complete a +adjustComplete 0 f (Tip a) = Tip (f a) +adjustComplete _ _ t@Tip{} = t +adjustComplete n f (Bin m a l r) + | n == 0 = Bin m (f a) l r + | n < w = Bin m a (adjustComplete (n - 1) f l) r + | otherwise = Bin m a l (adjustComplete (n - 1 - w) f r) + where w = weight l + +update :: Int -> a -> Future a -> Future a +update n = adjust n . const
src/Data/Stream/Infinite.hs view
@@ -1,449 +1,463 @@-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Stream.Infinite--- Copyright : (C) 2011 Edward Kmett,--- (C) 2007-2010 Wouter Swierstra, Bas van Dijk--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable (Haskell 2010)---------------------------------------------------------------------------------module Data.Stream.Infinite (- -- * The type of streams- Stream(..)- -- * Basic functions- , tail -- :: Stream a -> Stream a- , inits -- :: Stream a -> Stream [a]- , prepend -- :: [a] -> Stream a -> Stream a- , concat -- :: Stream [a] -> Stream a- -- * Stream transformations- , intersperse -- :: a -> Stream a -> Stream- , interleave -- :: Stream a -> Stream a -> Stream a- , scanl -- :: (b -> a -> b) -> b -> Stream a -> Stream b- , scanl' -- :: (b -> a -> b) -> b -> Stream a -> Stream b- , scanl1 -- :: (a -> a -> a) -> Stream a -> Stream a- , scanl1' -- :: (a -> a -> a) -> Stream a -> Stream a- , transpose -- :: Stream (Stream a) -> Stream (Stream a)- -- * Building streams- , iterate -- :: (a -> a) -> a -> Stream a- , cycle -- :: NonEmpty a -> Stream a- , unfold -- :: (a -> (b, a)) -> a -> Stream b- -- * Extracting sublists- , take -- :: Int -> Stream a -> [a]- , drop -- :: Int -> Stream a -> Stream a- , splitAt -- :: Int -> Stream a -> ([a],Stream a)- , takeWhile -- :: (a -> Bool) -> Stream a -> [a]- , dropWhile -- :: (a -> Bool) -> Stream a -> Stream a- , span -- :: (a -> Bool) -> Stream a -> ([a], Stream a)- , break -- :: (a -> Bool) -> Stream a -> ([a], Stream a)- , filter -- :: (a -> Bool) -> Stream a -> Stream a- , partition -- :: (a -> Bool) -> Stream a -> (Stream a, Stream a)- , group -- :: (a -> Bool) -> Stream a -> Stream (NonEmpty a)- , groupBy -- :: (a -> a -> Bool) -> Stream a -> Stream (NonEmpty a)- -- * Sublist predicates- , isPrefixOf -- :: [a] -> Stream a -> Bool- -- * Indexing streams- , (!!) -- :: Int -> Stream a -> a- , elemIndex -- :: Eq a => a -> Stream a -> Int- , elemIndices -- :: Eq a => a -> Stream a -> Stream Int- , findIndex -- :: (a -> Bool) -> Stream a -> Int- , findIndices -- :: (a -> Bool) -> Stream a -> Stream Int- -- * Zipping and unzipping streams- , zip -- :: Stream a -> Stream b -> Stream (a, b)- , zipWith -- :: (a -> b -> c) -> Stream a -> Stream b -> Stream c- , unzip -- :: Functor f => f (a, b) -> (f a, f b)- -- * Functions on streams of characters- , words -- :: Stream Char -> Stream String- , unwords -- :: Stream String -> Stream Char- , lines -- :: Stream Char -> Stream String- , unlines -- :: Stream String -> Stream Char- ) where--import Prelude hiding- ( tail, map, scanr, scanr1, scanl, scanl1- , iterate, take, drop, takeWhile- , dropWhile, repeat, cycle, filter- , (!!), zip, unzip, zipWith, words- , unwords, lines, unlines, break, span- , splitAt, foldr, concat- )--#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-#endif-import Control.Comonad-import Data.Char (isSpace)-import Data.Data-import Data.Functor.Apply-import Data.Functor.Extend-import Data.Functor.Rep-#if !(MIN_VERSION_base(4,8,0))-import Data.Semigroup-import Data.Traversable-#endif-import Data.Foldable hiding (concat)-import Data.Distributive-import Data.Semigroup.Traversable-import Data.Semigroup.Foldable-import Data.List.NonEmpty (NonEmpty(..))--data Stream a = a :> Stream a deriving- ( Show-#ifdef LANGUAGE_DeriveDataTypeable- , Data, Typeable-#endif- )--infixr 5 :>--instance Functor Stream where- fmap f (a :> as) = f a :> fmap f as- b <$ _ = pure b--instance Distributive Stream where- distribute w = fmap extract w :> distribute (fmap tail w)--instance Representable Stream where- type Rep Stream = Int- tabulate f = unfold (\i -> (,) (f i) $! (i + 1)) 0- index (x :> xs) n- | n == 0 = x- | n > 0 = xs !! (n - 1)- | otherwise = error "Stream.!! negative argument"----- | Extract the sequence following the head of the stream.-tail :: Stream a -> Stream a-tail (_ :> as) = as-{-# INLINE tail #-}--instance Extend Stream where- duplicated = duplicate- extended = extend--instance Comonad Stream where- duplicate w = w :> duplicate (tail w)- extend f w = f w :> extend f (tail w)- extract (a :> _) = a--instance Apply Stream where- (f :> fs) <.> (a :> as) = f a :> (fs <.> as)- as <. _ = as- _ .> bs = bs--instance ComonadApply Stream where- (f :> fs) <@> (a :> as) = f a :> (fs <@> as)- as <@ _ = as- _ @> bs = bs--instance Applicative Stream where- pure a = as where as = a :> as- (<*>) = (<.>)- (<* ) = (<. )- ( *>) = ( .>)--instance Foldable Stream where- fold (m :> ms) = m `mappend` fold ms- foldMap f (a :> as) = f a `mappend` foldMap f as- foldr f0 _ = go f0 where go f (a :> as) = f a (go f as)-#if __GLASGOW_HASKELL__ > 710- length _ = error "infinite length"- null _ = False-#endif--instance Traversable Stream where- traverse f ~(a :> as) = (:>) <$> f a <*> traverse f as--instance Foldable1 Stream--instance Traversable1 Stream where- traverse1 f ~(a :> as) = (:>) <$> f a <.> traverse1 f as- sequence1 ~(a :> as) = (:>) <$> a <.> sequence1 as---- | The unfold function is similar to the unfold for lists. Note--- there is no base case: all streams must be infinite.-unfold :: (a -> (b, a)) -> a -> Stream b-unfold f c | (x, d) <- f c = x :> unfold f d--instance Monad Stream where- return = pure- m >>= f = unfold (\(bs :> bss) -> (extract bs, tail <$> bss)) (fmap f m)- _ >> bs = bs---- | Interleave two Streams @xs@ and @ys@, alternating elements--- from each list.------ > [x1,x2,...] `interleave` [y1,y2,...] == [x1,y1,x2,y2,...]-interleave :: Stream a -> Stream a -> Stream a-interleave ~(x :> xs) ys = x :> interleave ys xs---- | The 'inits' function takes a stream @xs@ and returns all the--- finite prefixes of @xs@.------ Note that this 'inits' is lazier then @Data.List.inits@:------ > inits _|_ = [] ::: _|_------ while for @Data.List.inits@:------ > inits _|_ = _|_-inits :: Stream a -> Stream [a]-inits xs = [] :> ((extract xs :) <$> inits (tail xs))---- | Prepend a list to a stream.-prepend :: Foldable f => f a -> Stream a -> Stream a-prepend xs ys = foldr (:>) ys xs---- | Flatten a stream of lists into a stream.-concat :: Foldable f => Stream (f a) -> Stream a-concat = foldr prepend undefined---- | @'intersperse' y xs@ creates an alternating stream of--- elements from @xs@ and @y@.-intersperse :: a -> Stream a -> Stream a-intersperse y ~(x :> xs) = x :> y :> intersperse y xs---- | 'scanl' yields a stream of successive reduced values from:------ > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]-scanl :: (a -> b -> a) -> a -> Stream b -> Stream a-scanl f z ~(x :> xs) = z :> scanl f (f z x) xs---- | 'scanl' yields a stream of successive reduced values from:------ > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]-scanl' :: (a -> b -> a) -> a -> Stream b -> Stream a-scanl' f z ~(x :> xs) = z :> (scanl' f $! f z x) xs---- | 'scanl1' is a variant of 'scanl' that has no starting value argument:------ > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]-scanl1 :: (a -> a -> a) -> Stream a -> Stream a-scanl1 f ~(x :> xs) = scanl f x xs---- | @scanl1'@ is a strict 'scanl' that has no starting value.-scanl1' :: (a -> a -> a) -> Stream a -> Stream a-scanl1' f ~(x :> xs) = scanl' f x xs---- | 'transpose' computes the transposition of a stream of streams.-transpose :: Stream (Stream a) -> Stream (Stream a)-transpose ~((x :> xs) :> yss) =- (x :> (extract <$> yss)) :> transpose (xs :> (tail <$> yss))---- | @'iterate' f x@ produces the infinite sequence--- of repeated applications of @f@ to @x@.------ > iterate f x = [x, f x, f (f x), ..]-iterate :: (a -> a) -> a -> Stream a-iterate f x = x :> iterate f (f x)---- | @'cycle' xs@ returns the infinite repetition of @xs@:------ > cycle [1,2,3] = Cons 1 (Cons 2 (Cons 3 (Cons 1 (Cons 2 ...-cycle :: NonEmpty a -> Stream a-cycle xs = ys where ys = foldr (:>) ys xs---- | @'take' n xs@ returns the first @n@ elements of @xs@.------ /Beware/: passing a negative integer as the first argument will--- cause an error.-take :: Int -> Stream a -> [a]-take n ~(x :> xs)- | n == 0 = []- | n > 0 = x : take (n - 1) xs- | otherwise = error "Stream.take: negative argument"---- | @'drop' n xs@ drops the first @n@ elements off the front of--- the sequence @xs@.------ /Beware/: passing a negative integer as the first argument will--- cause an error.-drop :: Int -> Stream a -> Stream a-drop n xs- | n == 0 = xs- | n > 0 = drop (n - 1) (tail xs)- | otherwise = error "Stream.drop: negative argument"---- | @'splitAt' n xs@ returns a pair consisting of the prefix of--- @xs@ of length @n@ and the remaining stream immediately following--- this prefix.------ /Beware/: passing a negative integer as the first argument will--- cause an error.-splitAt :: Int -> Stream a -> ([a],Stream a)-splitAt n xs- | n == 0 = ([],xs)- | n > 0, (prefix, rest) <- splitAt (n - 1) (tail xs) = (extract xs : prefix, rest)- | otherwise = error "Stream.splitAt: negative argument"---- | @'takeWhile' p xs@ returns the longest prefix of the stream--- @xs@ for which the predicate @p@ holds.-takeWhile :: (a -> Bool) -> Stream a -> [a]-takeWhile p (x :> xs)- | p x = x : takeWhile p xs- | otherwise = []---- | @'dropWhile' p xs@ returns the suffix remaining after--- @'takeWhile' p xs@.------ /Beware/: this function may diverge if every element of @xs@--- satisfies @p@, e.g. @dropWhile even (repeat 0)@ will loop.-dropWhile :: (a -> Bool) -> Stream a -> Stream a-dropWhile p ~(x :> xs)- | p x = dropWhile p xs- | otherwise = x :> xs---- | @'span' p xs@ returns the longest prefix of @xs@ that satisfies--- @p@, together with the remainder of the stream.-span :: (a -> Bool) -> Stream a -> ([a], Stream a)-span p xxs@(x :> xs)- | p x, (ts, fs) <- span p xs = (x : ts, fs)- | otherwise = ([], xxs)---- | The 'break' @p@ function is equivalent to 'span' @not . p@.-break :: (a -> Bool) -> Stream a -> ([a], Stream a)-break p = span (not . p)---- | @'filter' p xs@, removes any elements from @xs@ that do not satisfy @p@.------ /Beware/: this function may diverge if there is no element of--- @xs@ that satisfies @p@, e.g. @filter odd (repeat 0)@ will loop.-filter :: (a -> Bool) -> Stream a -> Stream a-filter p ~(x :> xs)- | p x = x :> filter p xs- | otherwise = filter p xs---- | The 'partition' function takes a predicate @p@ and a stream--- @xs@, and returns a pair of streams. The first stream corresponds--- to the elements of @xs@ for which @p@ holds; the second stream--- corresponds to the elements of @xs@ for which @p@ does not hold.------ /Beware/: One of the elements of the tuple may be undefined. For--- example, @fst (partition even (repeat 0)) == repeat 0@; on the--- other hand @snd (partition even (repeat 0))@ is undefined.-partition :: (a -> Bool) -> Stream a -> (Stream a, Stream a)-partition p ~(x :> xs)- | p x = (x :> ts, fs)- | otherwise = (ts, x :> fs)- where (ts, fs) = partition p xs---- | The 'group' function takes a stream and returns a stream of--- lists such that flattening the resulting stream is equal to the--- argument. Moreover, each sublist in the resulting stream--- contains only equal elements. For example,------ > group $ cycle "Mississippi" = "M" ::: "i" ::: "ss" ::: "i" ::: "ss" ::: "i" ::: "pp" ::: "i" ::: "M" ::: "i" ::: ...-group :: Eq a => Stream a -> Stream (NonEmpty a)-group = groupBy (==)--groupBy :: (a -> a -> Bool) -> Stream a -> Stream (NonEmpty a)-groupBy eq ~(x :> ys)- | (xs, zs) <- span (eq x) ys- = (x :| xs) :> groupBy eq zs---- | The 'isPrefix' function returns @True@ if the first argument is--- a prefix of the second.-isPrefixOf :: Eq a => [a] -> Stream a -> Bool-isPrefixOf [] _ = True-isPrefixOf (y:ys) (x :> xs)- | y == x = isPrefixOf ys xs- | otherwise = False---- | @xs !! n@ returns the element of the stream @xs@ at index--- @n@. Note that the head of the stream has index 0.------ /Beware/: passing a negative integer as the first argument will cause--- an error.-(!!) :: Stream a -> Int -> a-(!!) = index---- | The 'elemIndex' function returns the index of the first element--- in the given stream which is equal (by '==') to the query element,------ /Beware/: @'elemIndex' x xs@ will diverge if none of the elements--- of @xs@ equal @x@.-elemIndex :: Eq a => a -> Stream a -> Int-elemIndex x = findIndex (\y -> x == y)---- | The 'elemIndices' function extends 'elemIndex', by returning the--- indices of all elements equal to the query element, in ascending order.------ /Beware/: 'elemIndices' @x@ @xs@ will diverge if any suffix of--- @xs@ does not contain @x@.-elemIndices :: Eq a => a -> Stream a -> Stream Int-elemIndices x = findIndices (x==)---- | The 'findIndex' function takes a predicate and a stream and returns--- the index of the first element in the stream that satisfies the predicate,------ /Beware/: 'findIndex' @p@ @xs@ will diverge if none of the elements of--- @xs@ satisfy @p@.-findIndex :: (a -> Bool) -> Stream a -> Int-findIndex p = indexFrom 0- where- indexFrom ix (x :> xs)- | p x = ix- | otherwise = (indexFrom $! (ix + 1)) xs---- | The 'findIndices' function extends 'findIndex', by returning the--- indices of all elements satisfying the predicate, in ascending--- order.------ /Beware/: 'findIndices' @p@ @xs@ will diverge if all the elements--- of any suffix of @xs@ fails to satisfy @p@.-findIndices :: (a -> Bool) -> Stream a -> Stream Int-findIndices p = indicesFrom 0 where- indicesFrom ix (x :> xs)- | p x = ix :> ixs- | otherwise = ixs- where ixs = (indicesFrom $! (ix+1)) xs---- | The 'zip' function takes two streams and returns a list of--- corresponding pairs.-zip :: Stream a -> Stream b -> Stream (a,b)-zip ~(x :> xs) ~(y :> ys) = (x,y) :> zip xs ys---- | The 'zipWith' function generalizes 'zip'. Rather than tupling--- the functions, the elements are combined using the function--- passed as the first argument to 'zipWith'.-zipWith :: (a -> b -> c) -> Stream a -> Stream b -> Stream c-zipWith f ~(x :> xs) ~(y :> ys) = f x y :> zipWith f xs ys---- | The 'unzip' function is the inverse of the 'zip' function.-unzip :: Stream (a,b) -> (Stream a, Stream b)-unzip xs = (fst <$> xs, snd <$> xs)---- | The 'words' function breaks a stream of characters into a--- stream of words, which were delimited by white space.------ /Beware/: if the stream of characters @xs@ does not contain white--- space, accessing the tail of @words xs@ will loop.-words :: Stream Char -> Stream String-words xs | (w, ys) <- break isSpace xs = w :> words ys---- | The 'unwords' function is an inverse operation to 'words'. It--- joins words with separating spaces.-unwords :: Stream String -> Stream Char-unwords ~(x :> xs) = foldr (:>) (' ' :> unwords xs) x---- | The 'lines' function breaks a stream of characters into a list--- of strings at newline characters. The resulting strings do not--- contain newlines.------ /Beware/: if the stream of characters @xs@ does not contain--- newline characters, accessing the tail of @lines xs@ will loop.-lines :: Stream Char -> Stream String-lines xs | (l, ys) <- break (== '\n') xs = l :> lines (tail ys)---- | The 'unlines' function is an inverse operation to 'lines'. It--- joins lines, after appending a terminating newline to each.-unlines :: Stream String -> Stream Char-unlines ~(x :> xs) = foldr (:>) ('\n' :> unlines xs) x+{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Infinite +-- Copyright : (C) 2011 Edward Kmett, +-- (C) 2007-2010 Wouter Swierstra, Bas van Dijk +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable (Haskell 2010) +-- +---------------------------------------------------------------------------- +module Data.Stream.Infinite ( + -- * The type of streams + Stream(..) + -- * Basic functions + , tail -- :: Stream a -> Stream a + , inits -- :: Stream a -> Stream [a] + , prepend -- :: [a] -> Stream a -> Stream a + , concat -- :: Stream [a] -> Stream a + -- * Stream transformations + , intersperse -- :: a -> Stream a -> Stream + , interleave -- :: Stream a -> Stream a -> Stream a + , scanl -- :: (b -> a -> b) -> b -> Stream a -> Stream b + , scanl' -- :: (b -> a -> b) -> b -> Stream a -> Stream b + , scanl1 -- :: (a -> a -> a) -> Stream a -> Stream a + , scanl1' -- :: (a -> a -> a) -> Stream a -> Stream a + , transpose -- :: Stream (Stream a) -> Stream (Stream a) + -- * Building streams + , iterate -- :: (a -> a) -> a -> Stream a + , cycle -- :: NonEmpty a -> Stream a + , unfold -- :: (a -> (b, a)) -> a -> Stream b + -- * Extracting sublists + , take -- :: Int -> Stream a -> [a] + , drop -- :: Int -> Stream a -> Stream a + , splitAt -- :: Int -> Stream a -> ([a],Stream a) + , takeWhile -- :: (a -> Bool) -> Stream a -> [a] + , dropWhile -- :: (a -> Bool) -> Stream a -> Stream a + , span -- :: (a -> Bool) -> Stream a -> ([a], Stream a) + , break -- :: (a -> Bool) -> Stream a -> ([a], Stream a) + , filter -- :: (a -> Bool) -> Stream a -> Stream a + , partition -- :: (a -> Bool) -> Stream a -> (Stream a, Stream a) + , group -- :: (a -> Bool) -> Stream a -> Stream (NonEmpty a) + , groupBy -- :: (a -> a -> Bool) -> Stream a -> Stream (NonEmpty a) + -- * Sublist predicates + , isPrefixOf -- :: [a] -> Stream a -> Bool + -- * Indexing streams + , (!!) -- :: Int -> Stream a -> a + , elemIndex -- :: Eq a => a -> Stream a -> Int + , elemIndices -- :: Eq a => a -> Stream a -> Stream Int + , findIndex -- :: (a -> Bool) -> Stream a -> Int + , findIndices -- :: (a -> Bool) -> Stream a -> Stream Int + -- * Zipping and unzipping streams + , zip -- :: Stream a -> Stream b -> Stream (a, b) + , zipWith -- :: (a -> b -> c) -> Stream a -> Stream b -> Stream c + , unzip -- :: Functor f => f (a, b) -> (f a, f b) + -- * Functions on streams of characters + , words -- :: Stream Char -> Stream String + , unwords -- :: Stream String -> Stream Char + , lines -- :: Stream Char -> Stream String + , unlines -- :: Stream String -> Stream Char + ) where + +import Prelude hiding + ( tail, map, scanr, scanr1, scanl, scanl1 + , iterate, take, drop, takeWhile + , dropWhile, repeat, cycle, filter + , (!!), zip, unzip, zipWith, words + , unwords, lines, unlines, break, span + , splitAt, foldr, concat + ) + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative +#endif +import Control.Comonad +import Data.Char (isSpace) +import Data.Data +import Data.Functor.Apply +import Data.Functor.Extend +import Data.Functor.Rep +#if !(MIN_VERSION_base(4,8,0)) +import Data.Semigroup +import Data.Traversable +#endif +import Data.Foldable hiding (concat) +import Data.Distributive +import Data.Semigroup.Traversable +import Data.Semigroup.Foldable +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Boring (Boring (..), Absurd (..)) + +data Stream a = a :> Stream a deriving + ( Show +#ifdef LANGUAGE_DeriveDataTypeable + , Data, Typeable +#endif + ) + +infixr 5 :> + +instance Functor Stream where + fmap f (a :> as) = f a :> fmap f as + b <$ _ = pure b + +instance Distributive Stream where + distribute w = fmap extract w :> distribute (fmap tail w) + +instance Representable Stream where + type Rep Stream = Int + tabulate f = unfold (\i -> (,) (f i) $! (i + 1)) 0 + index (x :> xs) n + | n == 0 = x + | n > 0 = xs !! (n - 1) + | otherwise = error "Stream.!! negative argument" + +-- | Extract the first element of the stream. +head :: Stream a -> a +head (x :> _) = x + +-- | @since 3.3.1 +instance Boring a => Boring (Stream a) where + boring = pure boring + +-- | @since 3.3.1 +instance Absurd a => Absurd (Stream a) where + absurd = absurd . extract + +-- | Extract the sequence following the head of the stream. +tail :: Stream a -> Stream a +tail (_ :> as) = as +{-# INLINE tail #-} + +instance Extend Stream where + duplicated = duplicate + extended = extend + +instance Comonad Stream where + duplicate w = w :> duplicate (tail w) + extend f w = f w :> extend f (tail w) + extract (a :> _) = a + +instance Apply Stream where + (f :> fs) <.> (a :> as) = f a :> (fs <.> as) + as <. _ = as + _ .> bs = bs + +instance ComonadApply Stream where + (f :> fs) <@> (a :> as) = f a :> (fs <@> as) + as <@ _ = as + _ @> bs = bs + +instance Applicative Stream where + pure a = as where as = a :> as + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + +instance Foldable Stream where + fold (m :> ms) = m `mappend` fold ms + foldMap f (a :> as) = f a `mappend` foldMap f as + foldr f0 _ = go f0 where go f (a :> as) = f a (go f as) +#if __GLASGOW_HASKELL__ > 710 + length _ = error "infinite length" + null _ = False +#endif + +instance Traversable Stream where + traverse f ~(a :> as) = (:>) <$> f a <*> traverse f as + +instance Foldable1 Stream + +instance Traversable1 Stream where + traverse1 f ~(a :> as) = (:>) <$> f a <.> traverse1 f as + sequence1 ~(a :> as) = (:>) <$> a <.> sequence1 as + +-- | The unfold function is similar to the unfold for lists. Note +-- there is no base case: all streams must be infinite. +unfold :: (a -> (b, a)) -> a -> Stream b +unfold f c | (x, d) <- f c = x :> unfold f d + +instance Monad Stream where + m >>= f = unfold (\(bs :> bss) -> (extract bs, tail <$> bss)) (fmap f m) +#if !(MIN_VERSION_base(4,11,0)) + return = pure + _ >> bs = bs +#endif + +-- | Interleave two Streams @xs@ and @ys@, alternating elements +-- from each list. +-- +-- > [x1,x2,...] `interleave` [y1,y2,...] == [x1,y1,x2,y2,...] +interleave :: Stream a -> Stream a -> Stream a +interleave ~(x :> xs) ys = x :> interleave ys xs + +-- | The 'inits' function takes a stream @xs@ and returns all the +-- finite prefixes of @xs@. +-- +-- Note that this 'inits' is lazier then @Data.List.inits@: +-- +-- > inits _|_ = [] ::: _|_ +-- +-- while for @Data.List.inits@: +-- +-- > inits _|_ = _|_ +inits :: Stream a -> Stream [a] +inits xs = [] :> ((extract xs :) <$> inits (tail xs)) + +-- | Prepend a list to a stream. +prepend :: Foldable f => f a -> Stream a -> Stream a +prepend xs ys = foldr (:>) ys xs + +-- | Flatten a stream of lists into a stream. +concat :: Foldable f => Stream (f a) -> Stream a +concat = foldr prepend undefined + +-- | @'intersperse' y xs@ creates an alternating stream of +-- elements from @xs@ and @y@. +intersperse :: a -> Stream a -> Stream a +intersperse y ~(x :> xs) = x :> y :> intersperse y xs + +-- | 'scanl' yields a stream of successive reduced values from: +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +scanl :: (a -> b -> a) -> a -> Stream b -> Stream a +scanl f z ~(x :> xs) = z :> scanl f (f z x) xs + +-- | 'scanl' yields a stream of successive reduced values from: +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +scanl' :: (a -> b -> a) -> a -> Stream b -> Stream a +scanl' f z ~(x :> xs) = z :> (scanl' f $! f z x) xs + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1 :: (a -> a -> a) -> Stream a -> Stream a +scanl1 f ~(x :> xs) = scanl f x xs + +-- | @scanl1'@ is a strict 'scanl' that has no starting value. +scanl1' :: (a -> a -> a) -> Stream a -> Stream a +scanl1' f ~(x :> xs) = scanl' f x xs + +-- | 'transpose' computes the transposition of a stream of streams. +transpose :: Stream (Stream a) -> Stream (Stream a) +transpose ~((x :> xs) :> yss) = + (x :> (extract <$> yss)) :> transpose (xs :> (tail <$> yss)) + +-- | @'iterate' f x@ produces the infinite sequence +-- of repeated applications of @f@ to @x@. +-- +-- > iterate f x = [x, f x, f (f x), ..] +iterate :: (a -> a) -> a -> Stream a +iterate f x = x :> iterate f (f x) + +-- | @'cycle' xs@ returns the infinite repetition of @xs@: +-- +-- > cycle [1,2,3] = Cons 1 (Cons 2 (Cons 3 (Cons 1 (Cons 2 ... +cycle :: NonEmpty a -> Stream a +cycle xs = ys where ys = foldr (:>) ys xs + +-- | @'take' n xs@ returns the first @n@ elements of @xs@. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error. +take :: Int -> Stream a -> [a] +take n ~(x :> xs) + | n == 0 = [] + | n > 0 = x : take (n - 1) xs + | otherwise = error "Stream.take: negative argument" + +-- | @'drop' n xs@ drops the first @n@ elements off the front of +-- the sequence @xs@. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error. +drop :: Int -> Stream a -> Stream a +drop n xs + | n == 0 = xs + | n > 0 = drop (n - 1) (tail xs) + | otherwise = error "Stream.drop: negative argument" + +-- | @'splitAt' n xs@ returns a pair consisting of the prefix of +-- @xs@ of length @n@ and the remaining stream immediately following +-- this prefix. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error. +splitAt :: Int -> Stream a -> ([a],Stream a) +splitAt n xs + | n == 0 = ([],xs) + | n > 0, (prefix, rest) <- splitAt (n - 1) (tail xs) = (extract xs : prefix, rest) + | otherwise = error "Stream.splitAt: negative argument" + +-- | @'takeWhile' p xs@ returns the longest prefix of the stream +-- @xs@ for which the predicate @p@ holds. +takeWhile :: (a -> Bool) -> Stream a -> [a] +takeWhile p (x :> xs) + | p x = x : takeWhile p xs + | otherwise = [] + +-- | @'dropWhile' p xs@ returns the suffix remaining after +-- @'takeWhile' p xs@. +-- +-- /Beware/: this function may diverge if every element of @xs@ +-- satisfies @p@, e.g. @dropWhile even (repeat 0)@ will loop. +dropWhile :: (a -> Bool) -> Stream a -> Stream a +dropWhile p ~(x :> xs) + | p x = dropWhile p xs + | otherwise = x :> xs + +-- | @'span' p xs@ returns the longest prefix of @xs@ that satisfies +-- @p@, together with the remainder of the stream. +span :: (a -> Bool) -> Stream a -> ([a], Stream a) +span p xxs@(x :> xs) + | p x, (ts, fs) <- span p xs = (x : ts, fs) + | otherwise = ([], xxs) + +-- | The 'break' @p@ function is equivalent to 'span' @not . p@. +break :: (a -> Bool) -> Stream a -> ([a], Stream a) +break p = span (not . p) + +-- | @'filter' p xs@, removes any elements from @xs@ that do not satisfy @p@. +-- +-- /Beware/: this function may diverge if there is no element of +-- @xs@ that satisfies @p@, e.g. @filter odd (repeat 0)@ will loop. +filter :: (a -> Bool) -> Stream a -> Stream a +filter p ~(x :> xs) + | p x = x :> filter p xs + | otherwise = filter p xs + +-- | The 'partition' function takes a predicate @p@ and a stream +-- @xs@, and returns a pair of streams. The first stream corresponds +-- to the elements of @xs@ for which @p@ holds; the second stream +-- corresponds to the elements of @xs@ for which @p@ does not hold. +-- +-- /Beware/: One of the elements of the tuple may be undefined. For +-- example, @fst (partition even (repeat 0)) == repeat 0@; on the +-- other hand @snd (partition even (repeat 0))@ is undefined. +partition :: (a -> Bool) -> Stream a -> (Stream a, Stream a) +partition p ~(x :> xs) + | p x = (x :> ts, fs) + | otherwise = (ts, x :> fs) + where (ts, fs) = partition p xs + +-- | The 'group' function takes a stream and returns a stream of +-- lists such that flattening the resulting stream is equal to the +-- argument. Moreover, each sublist in the resulting stream +-- contains only equal elements. For example, +-- +-- > group $ cycle "Mississippi" = "M" ::: "i" ::: "ss" ::: "i" ::: "ss" ::: "i" ::: "pp" ::: "i" ::: "M" ::: "i" ::: ... +group :: Eq a => Stream a -> Stream (NonEmpty a) +group = groupBy (==) + +groupBy :: (a -> a -> Bool) -> Stream a -> Stream (NonEmpty a) +groupBy eq ~(x :> ys) + | (xs, zs) <- span (eq x) ys + = (x :| xs) :> groupBy eq zs + +-- | The 'isPrefix' function returns @True@ if the first argument is +-- a prefix of the second. +isPrefixOf :: Eq a => [a] -> Stream a -> Bool +isPrefixOf [] _ = True +isPrefixOf (y:ys) (x :> xs) + | y == x = isPrefixOf ys xs + | otherwise = False + +-- | @xs !! n@ returns the element of the stream @xs@ at index +-- @n@. Note that the head of the stream has index 0. +-- +-- /Beware/: passing a negative integer as the first argument will cause +-- an error. +(!!) :: Stream a -> Int -> a +(!!) = index + +-- | The 'elemIndex' function returns the index of the first element +-- in the given stream which is equal (by '==') to the query element, +-- +-- /Beware/: @'elemIndex' x xs@ will diverge if none of the elements +-- of @xs@ equal @x@. +elemIndex :: Eq a => a -> Stream a -> Int +elemIndex x = findIndex (\y -> x == y) + +-- | The 'elemIndices' function extends 'elemIndex', by returning the +-- indices of all elements equal to the query element, in ascending order. +-- +-- /Beware/: 'elemIndices' @x@ @xs@ will diverge if any suffix of +-- @xs@ does not contain @x@. +elemIndices :: Eq a => a -> Stream a -> Stream Int +elemIndices x = findIndices (x==) + +-- | The 'findIndex' function takes a predicate and a stream and returns +-- the index of the first element in the stream that satisfies the predicate, +-- +-- /Beware/: 'findIndex' @p@ @xs@ will diverge if none of the elements of +-- @xs@ satisfy @p@. +findIndex :: (a -> Bool) -> Stream a -> Int +findIndex p = indexFrom 0 + where + indexFrom ix (x :> xs) + | p x = ix + | otherwise = (indexFrom $! (ix + 1)) xs + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending +-- order. +-- +-- /Beware/: 'findIndices' @p@ @xs@ will diverge if all the elements +-- of any suffix of @xs@ fails to satisfy @p@. +findIndices :: (a -> Bool) -> Stream a -> Stream Int +findIndices p = indicesFrom 0 where + indicesFrom ix (x :> xs) + | p x = ix :> ixs + | otherwise = ixs + where ixs = (indicesFrom $! (ix+1)) xs + +-- | The 'zip' function takes two streams and returns a list of +-- corresponding pairs. +zip :: Stream a -> Stream b -> Stream (a,b) +zip ~(x :> xs) ~(y :> ys) = (x,y) :> zip xs ys + +-- | The 'zipWith' function generalizes 'zip'. Rather than tupling +-- the functions, the elements are combined using the function +-- passed as the first argument to 'zipWith'. +zipWith :: (a -> b -> c) -> Stream a -> Stream b -> Stream c +zipWith f ~(x :> xs) ~(y :> ys) = f x y :> zipWith f xs ys + +-- | The 'unzip' function is the inverse of the 'zip' function. +unzip :: Stream (a,b) -> (Stream a, Stream b) +unzip xs = (fst <$> xs, snd <$> xs) + +-- | The 'words' function breaks a stream of characters into a +-- stream of words, which were delimited by white space. +-- +-- /Beware/: if the stream of characters @xs@ does not contain white +-- space, accessing the tail of @words xs@ will loop. +words :: Stream Char -> Stream String +words xs | (w, ys) <- break isSpace xs = w :> words ys + +-- | The 'unwords' function is an inverse operation to 'words'. It +-- joins words with separating spaces. +unwords :: Stream String -> Stream Char +unwords ~(x :> xs) = foldr (:>) (' ' :> unwords xs) x + +-- | The 'lines' function breaks a stream of characters into a list +-- of strings at newline characters. The resulting strings do not +-- contain newlines. +-- +-- /Beware/: if the stream of characters @xs@ does not contain +-- newline characters, accessing the tail of @lines xs@ will loop. +lines :: Stream Char -> Stream String +lines xs | (l, ys) <- break (== '\n') xs = l :> lines (tail ys) + +-- | The 'unlines' function is an inverse operation to 'lines'. It +-- joins lines, after appending a terminating newline to each. +unlines :: Stream String -> Stream Char +unlines ~(x :> xs) = foldr (:>) ('\n' :> unlines xs) x
src/Data/Stream/Infinite/Functional/Zipper.hs view
@@ -1,330 +1,334 @@-{-# LANGUAGE CPP, PatternGuards, BangPatterns #-}-#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Stream.Infinite.Functional.Zipper--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This is an infinite bidirectional zipper------------------------------------------------------------------------------module Data.Stream.Infinite.Functional.Zipper (- -- * The type of streams- Zipper(..)- , tail -- :: Zipper a -> Zipper a- , untail -- :: Zipper a -> Zipper a- , intersperse -- :: a -> Zipper a -> Zipper a- , interleave -- :: Zipper a -> Zipper a -> Zipper a- , transpose -- :: Zipper (Zipper a) -> Zipper (Zipper a)- , take -- :: Integer -> Zipper a -> [a]- , drop -- :: Integer -> Zipper a -> Zipper a -- you can drop a negative number- , splitAt -- :: Integer -> Zipper a -> ([a],Zipper a)- , reverse -- :: Zipper a -> Zipper a- , (!!) -- :: Int -> Zipper a -> a- , unzip -- :: Functor f => f (a, b) -> (f a, f b)- , toSequence -- :: (Integer -> a) -> Zipper a- , head- , (<|)- , uncons- , takeWhile- , dropWhile- , span- , break- , isPrefixOf- , findIndex- , elemIndex- , zip- , zipWith- ) where--import Prelude hiding- ( head, tail, map, scanr, scanr1, scanl, scanl1- , iterate, take, drop, takeWhile- , dropWhile, repeat, cycle, filter- , (!!), zip, unzip, zipWith, words- , unwords, lines, unlines, break, span- , splitAt, foldr, reverse- )--import Control.Applicative-import Control.Comonad-#ifdef LANGUAGE_DeriveDataTypeable-import Data.Data-#endif-import Data.Functor.Extend-import Data.Functor.Apply-import Data.Semigroup--data Zipper a = !Integer :~ !(Integer -> a)-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif--toSequence :: (Integer -> a) -> Zipper a-toSequence = (0 :~)--reverse :: Zipper a -> Zipper a-reverse (n :~ f) = negate n :~ f . negate--infixr 0 :~--instance Functor Zipper where- fmap g (n :~ f) = n :~ g . f- b <$ _ = 0 :~ const b---- | Extract the focused element-head :: Zipper a -> a-head (n :~ f) = f n---- | Move the head of the zipper to the right-tail :: Zipper a -> Zipper a-tail (n :~ f) = n + 1 :~ f---- | Move the head of the zipper to the left-untail :: Zipper a -> Zipper a-untail (n :~ f) = n - 1 :~ f---- | Cons before the head of the zipper. The head now points to the new element-(<|) :: a -> Zipper a -> Zipper a-a <| (n :~ f) = n :~ \z -> case compare z n of- LT -> f n- EQ -> a- GT -> f (n - 1)---- | Move the head of the zipper one step to the right, returning the value we move over.-uncons :: Zipper a -> (a, Zipper a)-uncons (n :~ f) = (f n, n + 1 :~ f)--instance Extend Zipper where- duplicated (n :~ f) = n :~ (:~ f)--instance Comonad Zipper where- duplicate (n :~ f) = n :~ (:~ f)- extract (n :~ f) = f n--instance Apply Zipper where- (nf :~ f) <.> (na :~ a)- | dn <- na - nf- = nf :~ \n -> f n (a (n + dn))- as <. _ = as- _ .> bs = bs--instance ComonadApply Zipper where- (<@>) = (<.>)- (<@) = (<.)- (@>) = (.>)---instance Applicative Zipper where- pure = repeat- (<*>) = (<.>)- as <* _ = as- _ *> bs = bs--instance Monad Zipper where- return = repeat- (z :~ ma) >>= f = z :~ \ na -> case f (ma na) of- nb :~ mb -> mb (nb + na - z)--repeat :: a -> Zipper a-repeat a = 0 :~ const a---- | Interleave two Zippers @xs@ and @ys@, alternating elements--- from each list.------ > [x1,x2,...] `interleave` [y1,y2,...] == [x1,y1,x2,y2,...]--- > interleave = (<>)-interleave :: Zipper a -> Zipper a -> Zipper a-interleave = (<>)-instance Semigroup (Zipper a) where- (n :~ a) <> (m :~ b) = 0 :~ \p -> case quotRem p 2 of- (q, 0) -> a (n + q)- (q, _) -> b (m + q)---- | @'intersperse' y xs@ creates an alternating stream of--- elements from @xs@ and @y@.-intersperse :: a -> Zipper a -> Zipper a-intersperse y z = z <> repeat y---- | 'transpose' computes the transposition of a stream of streams.-transpose :: Zipper (Zipper a) -> Zipper (Zipper a)-transpose (n :~ f) = 0 :~ \z -> n :~ \n' -> let m :~ g = f n' in g (m + z)--take :: Integer -> Zipper a -> [a]-take n0 (m0 :~ f0)- | n0 < 0 = error "Zipper.take: negative argument"- | otherwise = go n0 m0 f0- where- go 0 !_ !_ = []- go n m f = f m : go (n - 1) (m + 1) f---- | @'drop' n xs@ drops the first @n@ elements off the front of--- the sequence @xs@.-drop :: Integer -> Zipper a -> Zipper a-drop m (n :~ f) = m + n :~ f---- | @'splitAt' n xs@ returns a pair consisting of the prefix of--- @xs@ of length @n@ and the remaining stream immediately following--- this prefix.------ /Beware/: passing a negative integer as the first argument will--- cause an error if you access the taken portion-splitAt :: Integer -> Zipper a -> ([a],Zipper a)-splitAt n xs = (take n xs, drop n xs)---- | @'takeWhile' p xs@ returns the longest prefix of the stream--- @xs@ for which the predicate @p@ holds.-takeWhile :: (a -> Bool) -> Zipper a -> [a]-takeWhile p0 (n0 :~ f0) = go p0 n0 f0 where- go !p !n !f- | x <- f n, p x = x : go p (n + 1) f- | otherwise = []---- | @'dropWhile' p xs@ returns the suffix remaining after--- @'takeWhile' p xs@.------ /Beware/: this function may diverge if every element of @xs@--- satisfies @p@, e.g. @dropWhile even (repeat 0)@ will loop.-dropWhile :: (a -> Bool) -> Zipper a -> Zipper a-dropWhile p xs@(_ :~ f) = findIndex' p xs :~ f---- | @'span' p xs@ returns the longest prefix of @xs@ that satisfies--- @p@, together with the remainder of the stream.-span :: (a -> Bool) -> Zipper a -> ([a], Zipper a)-span p0 (n0 :~ f0)- | (ts, n') <- go p0 n0 f0 = (ts, n' :~ f0) where- go !p !n !f- | x <- f n, p x, (ts, fs) <- go p (n + 1) f = (x:ts, fs)- | otherwise = ([], n)---- | The 'break' @p@ function is equivalent to 'span' @not . p@.-break :: (a -> Bool) -> Zipper a -> ([a], Zipper a)-break p = span (not . p)---- | The 'isPrefix' function returns @True@ if the first argument is--- a prefix of the second.-isPrefixOf :: Eq a => [a] -> Zipper a -> Bool-isPrefixOf xs0 (n0 :~ f0) = go xs0 n0 f0 where- go [] !_ !_ = True- go (y:ys) n f = y == f n && go ys (n + 1) f---- | @xs !! n@ returns the element of the stream @xs@ at index--- @n@. Note that the head of the stream has index 0.-(!!) :: Zipper a -> Integer -> a-(!!) (n :~ f) m = f (n + m)---- | The 'findIndex' function takes a predicate and a stream and returns--- the index of the first element in the stream that satisfies the predicate,------ /Beware/: 'findIndex' @p@ @xs@ will diverge if none of the elements of--- @xs@ satisfy @p@.-findIndex :: (a -> Bool) -> Zipper a -> Integer-findIndex p0 (n0 :~ f0) = go p0 n0 f0 - n0 where- go !p !n !f- | x <- f n, p x = n- | otherwise = go p (n + 1) f---- | Internal helper, used to find an index in the-findIndex' :: (a -> Bool) -> Zipper a -> Integer-findIndex' p0 (n0 :~ f0) = go p0 n0 f0 where- go !p !n !f- | x <- f n, p x = n- | otherwise = go p (n + 1) f---- | The 'elemIndex' function returns the index of the first element--- in the given stream which is equal (by '==') to the query element,------ /Beware/: @'elemIndex' x xs@ will diverge if none of the elements--- of @xs@ equal @x@.-elemIndex :: Eq a => a -> Zipper a -> Integer-elemIndex = findIndex . (==)--{---- | The 'elemIndices' function extends 'elemIndex', by returning the--- indices of all elements equal to the query element, in ascending order.------ /Beware/: 'elemIndices' @x@ @xs@ will diverge if any suffix of--- @xs@ does not contain @x@.-elemIndices :: Eq a => a -> Zipper a -> Zipper Int-elemIndices x = findIndices (x==)--}---- | The 'zip' function takes two streams and returns a list of--- corresponding pairs.------ > zip = liftA2 (,)-zip :: Zipper a -> Zipper b -> Zipper (a,b)-zip = liftA2 (,)---- | The 'zipWith' function generalizes 'zip'. Rather than tupling--- the functions, the elements are combined using the function--- passed as the first argument to 'zipWith'.------ > zipWith = liftA2-zipWith :: (a -> b -> c) -> Zipper a -> Zipper b -> Zipper c-zipWith = liftA2---- | The 'unzip' function is the inverse of the 'zip' function.-unzip :: Zipper (a,b) -> (Zipper a, Zipper b)-unzip xs = (fst <$> xs, snd <$> xs)----{----- | The 'findIndices' function extends 'findIndex', by returning the--- indices of all elements satisfying the predicate, in ascending--- order.------ /Beware/: 'findIndices' @p@ @xs@ will diverge if all the elements--- of any suffix of @xs@ fails to satisfy @p@.-findIndices :: (a -> Bool) -> Zipper a -> Zipper Int-findIndices p = indicesFrom 0 where- indicesFrom ix (x :< xs)- | p x = ix :< ixs- | otherwise = ixs- where ixs = (indicesFrom $! (ix+1)) xs----- | The 'words' function breaks a stream of characters into a--- stream of words, which were delimited by white space.------ /Beware/: if the stream of characters @xs@ does not contain white--- space, accessing the tail of @words xs@ will loop.-words :: Zipper Char -> Zipper String-words xs | (w, ys) <- break isSpace xs = w :< words ys---- | The 'unwords' function is an inverse operation to 'words'. It--- joins words with separating spaces.-unwords :: Zipper String -> Zipper Char-unwords ~(x :< xs) = foldr (:<) (' ' :< unwords xs) x---- | The 'lines' function breaks a stream of characters into a list--- of strings at newline characters. The resulting strings do not--- contain newlines.------ /Beware/: if the stream of characters @xs@ does not contain--- newline characters, accessing the tail of @lines xs@ will loop.-lines :: Zipper Char -> Zipper String-lines xs | (l, ys) <- break (== '\n') xs = l :< lines (tail ys)---- | The 'unlines' function is an inverse operation to 'lines'. It--- joins lines, after appending a terminating newline to each.-unlines :: Zipper String -> Zipper Char-unlines ~(x :< xs) = foldr (:<) ('\n' :< unlines xs) x---- | The 'fromList' converts an infinite list to a--- stream.------ /Beware/: Passing a finite list, will cause an error.-fromList :: [a] -> Zipper a-fromList (x:xs) = x :< fromList xs-fromList [] = error "Zipper.listToZipper applied to finite list"---}+{-# LANGUAGE CPP, PatternGuards, BangPatterns #-} +#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Infinite.Functional.Zipper +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- This is an infinite bidirectional zipper +---------------------------------------------------------------------------- +module Data.Stream.Infinite.Functional.Zipper ( + -- * The type of streams + Zipper(..) + , tail -- :: Zipper a -> Zipper a + , untail -- :: Zipper a -> Zipper a + , intersperse -- :: a -> Zipper a -> Zipper a + , interleave -- :: Zipper a -> Zipper a -> Zipper a + , transpose -- :: Zipper (Zipper a) -> Zipper (Zipper a) + , take -- :: Integer -> Zipper a -> [a] + , drop -- :: Integer -> Zipper a -> Zipper a -- you can drop a negative number + , splitAt -- :: Integer -> Zipper a -> ([a],Zipper a) + , reverse -- :: Zipper a -> Zipper a + , (!!) -- :: Int -> Zipper a -> a + , unzip -- :: Functor f => f (a, b) -> (f a, f b) + , toSequence -- :: (Integer -> a) -> Zipper a + , head + , (<|) + , uncons + , takeWhile + , dropWhile + , span + , break + , isPrefixOf + , findIndex + , elemIndex + , zip + , zipWith + ) where + +import Prelude hiding + ( head, tail, map, scanr, scanr1, scanl, scanl1 + , iterate, take, drop, takeWhile + , dropWhile, repeat, cycle, filter + , (!!), zip, unzip, zipWith, words + , unwords, lines, unlines, break, span + , splitAt, foldr, reverse + ) + +import Control.Applicative +import Control.Comonad +#ifdef LANGUAGE_DeriveDataTypeable +import Data.Data +#endif +import Data.Functor.Extend +import Data.Functor.Apply +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif + +data Zipper a = !Integer :~ !(Integer -> a) +#ifdef LANGUAGE_DeriveDataTypeable + deriving Typeable +#endif + +toSequence :: (Integer -> a) -> Zipper a +toSequence = (0 :~) + +reverse :: Zipper a -> Zipper a +reverse (n :~ f) = negate n :~ f . negate + +infixr 0 :~ + +instance Functor Zipper where + fmap g (n :~ f) = n :~ g . f + b <$ _ = 0 :~ const b + +-- | Extract the focused element +head :: Zipper a -> a +head (n :~ f) = f n + +-- | Move the head of the zipper to the right +tail :: Zipper a -> Zipper a +tail (n :~ f) = n + 1 :~ f + +-- | Move the head of the zipper to the left +untail :: Zipper a -> Zipper a +untail (n :~ f) = n - 1 :~ f + +-- | Cons before the head of the zipper. The head now points to the new element +(<|) :: a -> Zipper a -> Zipper a +a <| (n :~ f) = n :~ \z -> case compare z n of + LT -> f n + EQ -> a + GT -> f (n - 1) + +-- | Move the head of the zipper one step to the right, returning the value we move over. +uncons :: Zipper a -> (a, Zipper a) +uncons (n :~ f) = (f n, n + 1 :~ f) + +instance Extend Zipper where + duplicated (n :~ f) = n :~ (:~ f) + +instance Comonad Zipper where + duplicate (n :~ f) = n :~ (:~ f) + extract (n :~ f) = f n + +instance Apply Zipper where + (nf :~ f) <.> (na :~ a) + | dn <- na - nf + = nf :~ \n -> f n (a (n + dn)) + as <. _ = as + _ .> bs = bs + +instance ComonadApply Zipper where + (<@>) = (<.>) + (<@) = (<.) + (@>) = (.>) + + +instance Applicative Zipper where + pure = repeat + (<*>) = (<.>) + as <* _ = as + _ *> bs = bs + +instance Monad Zipper where +#if !(MIN_VERSION_base(4,11,0)) + return = repeat +#endif + (z :~ ma) >>= f = z :~ \ na -> case f (ma na) of + nb :~ mb -> mb (nb + na - z) + +repeat :: a -> Zipper a +repeat a = 0 :~ const a + +-- | Interleave two Zippers @xs@ and @ys@, alternating elements +-- from each list. +-- +-- > [x1,x2,...] `interleave` [y1,y2,...] == [x1,y1,x2,y2,...] +-- > interleave = (<>) +interleave :: Zipper a -> Zipper a -> Zipper a +interleave = (<>) +instance Semigroup (Zipper a) where + (n :~ a) <> (m :~ b) = 0 :~ \p -> case quotRem p 2 of + (q, 0) -> a (n + q) + (q, _) -> b (m + q) + +-- | @'intersperse' y xs@ creates an alternating stream of +-- elements from @xs@ and @y@. +intersperse :: a -> Zipper a -> Zipper a +intersperse y z = z <> repeat y + +-- | 'transpose' computes the transposition of a stream of streams. +transpose :: Zipper (Zipper a) -> Zipper (Zipper a) +transpose (n :~ f) = 0 :~ \z -> n :~ \n' -> let m :~ g = f n' in g (m + z) + +take :: Integer -> Zipper a -> [a] +take n0 (m0 :~ f0) + | n0 < 0 = error "Zipper.take: negative argument" + | otherwise = go n0 m0 f0 + where + go 0 !_ !_ = [] + go n m f = f m : go (n - 1) (m + 1) f + +-- | @'drop' n xs@ drops the first @n@ elements off the front of +-- the sequence @xs@. +drop :: Integer -> Zipper a -> Zipper a +drop m (n :~ f) = m + n :~ f + +-- | @'splitAt' n xs@ returns a pair consisting of the prefix of +-- @xs@ of length @n@ and the remaining stream immediately following +-- this prefix. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error if you access the taken portion +splitAt :: Integer -> Zipper a -> ([a],Zipper a) +splitAt n xs = (take n xs, drop n xs) + +-- | @'takeWhile' p xs@ returns the longest prefix of the stream +-- @xs@ for which the predicate @p@ holds. +takeWhile :: (a -> Bool) -> Zipper a -> [a] +takeWhile p0 (n0 :~ f0) = go p0 n0 f0 where + go !p !n !f + | x <- f n, p x = x : go p (n + 1) f + | otherwise = [] + +-- | @'dropWhile' p xs@ returns the suffix remaining after +-- @'takeWhile' p xs@. +-- +-- /Beware/: this function may diverge if every element of @xs@ +-- satisfies @p@, e.g. @dropWhile even (repeat 0)@ will loop. +dropWhile :: (a -> Bool) -> Zipper a -> Zipper a +dropWhile p xs@(_ :~ f) = findIndex' p xs :~ f + +-- | @'span' p xs@ returns the longest prefix of @xs@ that satisfies +-- @p@, together with the remainder of the stream. +span :: (a -> Bool) -> Zipper a -> ([a], Zipper a) +span p0 (n0 :~ f0) + | (ts, n') <- go p0 n0 f0 = (ts, n' :~ f0) where + go !p !n !f + | x <- f n, p x, (ts, fs) <- go p (n + 1) f = (x:ts, fs) + | otherwise = ([], n) + +-- | The 'break' @p@ function is equivalent to 'span' @not . p@. +break :: (a -> Bool) -> Zipper a -> ([a], Zipper a) +break p = span (not . p) + +-- | The 'isPrefix' function returns @True@ if the first argument is +-- a prefix of the second. +isPrefixOf :: Eq a => [a] -> Zipper a -> Bool +isPrefixOf xs0 (n0 :~ f0) = go xs0 n0 f0 where + go [] !_ !_ = True + go (y:ys) n f = y == f n && go ys (n + 1) f + +-- | @xs !! n@ returns the element of the stream @xs@ at index +-- @n@. Note that the head of the stream has index 0. +(!!) :: Zipper a -> Integer -> a +(!!) (n :~ f) m = f (n + m) + +-- | The 'findIndex' function takes a predicate and a stream and returns +-- the index of the first element in the stream that satisfies the predicate, +-- +-- /Beware/: 'findIndex' @p@ @xs@ will diverge if none of the elements of +-- @xs@ satisfy @p@. +findIndex :: (a -> Bool) -> Zipper a -> Integer +findIndex p0 (n0 :~ f0) = go p0 n0 f0 - n0 where + go !p !n !f + | x <- f n, p x = n + | otherwise = go p (n + 1) f + +-- | Internal helper, used to find an index in the +findIndex' :: (a -> Bool) -> Zipper a -> Integer +findIndex' p0 (n0 :~ f0) = go p0 n0 f0 where + go !p !n !f + | x <- f n, p x = n + | otherwise = go p (n + 1) f + +-- | The 'elemIndex' function returns the index of the first element +-- in the given stream which is equal (by '==') to the query element, +-- +-- /Beware/: @'elemIndex' x xs@ will diverge if none of the elements +-- of @xs@ equal @x@. +elemIndex :: Eq a => a -> Zipper a -> Integer +elemIndex = findIndex . (==) + +{- +-- | The 'elemIndices' function extends 'elemIndex', by returning the +-- indices of all elements equal to the query element, in ascending order. +-- +-- /Beware/: 'elemIndices' @x@ @xs@ will diverge if any suffix of +-- @xs@ does not contain @x@. +elemIndices :: Eq a => a -> Zipper a -> Zipper Int +elemIndices x = findIndices (x==) +-} + +-- | The 'zip' function takes two streams and returns a list of +-- corresponding pairs. +-- +-- > zip = liftA2 (,) +zip :: Zipper a -> Zipper b -> Zipper (a,b) +zip = liftA2 (,) + +-- | The 'zipWith' function generalizes 'zip'. Rather than tupling +-- the functions, the elements are combined using the function +-- passed as the first argument to 'zipWith'. +-- +-- > zipWith = liftA2 +zipWith :: (a -> b -> c) -> Zipper a -> Zipper b -> Zipper c +zipWith = liftA2 + +-- | The 'unzip' function is the inverse of the 'zip' function. +unzip :: Zipper (a,b) -> (Zipper a, Zipper b) +unzip xs = (fst <$> xs, snd <$> xs) + + + +{- + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending +-- order. +-- +-- /Beware/: 'findIndices' @p@ @xs@ will diverge if all the elements +-- of any suffix of @xs@ fails to satisfy @p@. +findIndices :: (a -> Bool) -> Zipper a -> Zipper Int +findIndices p = indicesFrom 0 where + indicesFrom ix (x :< xs) + | p x = ix :< ixs + | otherwise = ixs + where ixs = (indicesFrom $! (ix+1)) xs + + +-- | The 'words' function breaks a stream of characters into a +-- stream of words, which were delimited by white space. +-- +-- /Beware/: if the stream of characters @xs@ does not contain white +-- space, accessing the tail of @words xs@ will loop. +words :: Zipper Char -> Zipper String +words xs | (w, ys) <- break isSpace xs = w :< words ys + +-- | The 'unwords' function is an inverse operation to 'words'. It +-- joins words with separating spaces. +unwords :: Zipper String -> Zipper Char +unwords ~(x :< xs) = foldr (:<) (' ' :< unwords xs) x + +-- | The 'lines' function breaks a stream of characters into a list +-- of strings at newline characters. The resulting strings do not +-- contain newlines. +-- +-- /Beware/: if the stream of characters @xs@ does not contain +-- newline characters, accessing the tail of @lines xs@ will loop. +lines :: Zipper Char -> Zipper String +lines xs | (l, ys) <- break (== '\n') xs = l :< lines (tail ys) + +-- | The 'unlines' function is an inverse operation to 'lines'. It +-- joins lines, after appending a terminating newline to each. +unlines :: Zipper String -> Zipper Char +unlines ~(x :< xs) = foldr (:<) ('\n' :< unlines xs) x + +-- | The 'fromList' converts an infinite list to a +-- stream. +-- +-- /Beware/: Passing a finite list, will cause an error. +fromList :: [a] -> Zipper a +fromList (x:xs) = x :< fromList xs +fromList [] = error "Zipper.listToZipper applied to finite list" + +-}
src/Data/Stream/Infinite/Skew.hs view
@@ -1,339 +1,348 @@-{-# LANGUAGE PatternGuards, BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Stream.Infinite.Skew--- Copyright : (C) 2011 Edward Kmett,--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ Anticausal streams implemented as non-empty skew binary random access lists------ The Applicative zips streams, the monad diagonalizes----------------------------------------------------------------------------------module Data.Stream.Infinite.Skew- ( Stream- , (<|) -- O(1)- , (!!)- , tail -- O(1)- , uncons -- O(1)- , drop -- O(log n)- , dropWhile -- O(n)- , span- , break- , split- , splitW- , repeat- , insert -- O(n)- , insertBy- , adjust -- O(log n)- , update -- O(log n)- , from- , indexed- , interleave- ) where--import Control.Arrow (first)-import Control.Applicative hiding (empty)-import Control.Comonad-import Data.Distributive-import Data.Functor.Alt-import Data.Functor.Extend-import Data.Functor.Rep-import Data.Foldable-import Data.Traversable-import Data.Semigroup hiding (Last)-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Prelude hiding (null, head, tail, drop, dropWhile, length, foldr, last, span, repeat, replicate, (!!), break)--infixr 5 :<, <|--data Complete a- = Tip a- | Bin !Integer a !(Complete a) !(Complete a)- deriving Show--instance Functor Complete where- fmap f (Tip a) = Tip (f a)- fmap f (Bin w a l r) = Bin w (f a) (fmap f l) (fmap f r)--instance Extend Complete where- extended f w@Tip {} = Tip (f w)- extended f w@(Bin n _ l r) = Bin n (f w) (extended f l) (extended f r)--instance Comonad Complete where- extend f w@Tip {} = Tip (f w)- extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r)- extract (Tip a) = a- extract (Bin _ a _ _) = a--instance Foldable Complete where- foldMap f (Tip a) = f a- foldMap f (Bin _ a l r) = f a `mappend` foldMap f l `mappend` foldMap f r- foldr f z (Tip a) = f a z- foldr f z (Bin _ a l r) = f a (foldr f (foldr f z r) l)-#if __GLASGOW_HASKELL__ >= 710- length Tip{} = 1- length (Bin n _ _ _) = fromIntegral n- null _ = False-#endif--instance Foldable1 Complete where- foldMap1 f (Tip a) = f a- foldMap1 f (Bin _ a l r) = f a <> foldMap1 f l <> foldMap1 f r--instance Traversable Complete where- traverse f (Tip a) = Tip <$> f a- traverse f (Bin n a l r) = Bin n <$> f a <*> traverse f l <*> traverse f r--instance Traversable1 Complete where- traverse1 f (Tip a) = Tip <$> f a- traverse1 f (Bin n a l r) = Bin n <$> f a <.> traverse1 f l <.> traverse1 f r--bin :: a -> Complete a -> Complete a -> Complete a-bin a l r = Bin (1 + weight l + weight r) a l r-{-# INLINE bin #-}--weight :: Complete a -> Integer-weight Tip{} = 1-weight (Bin w _ _ _) = w-{-# INLINE weight #-}---- A future is a non-empty skew binary random access list of nodes.--- The last node, however, is allowed to contain fewer values.-data Stream a = !(Complete a) :< Stream a--- deriving Show--instance Show a => Show (Stream a) where- showsPrec d as = showParen (d >= 10) $- showString "fromList " . showsPrec 11 (toList as)--instance Functor Stream where- fmap f (t :< ts) = fmap f t :< fmap f ts--instance Extend Stream where- extended = extend--instance Comonad Stream where- extend g0 (t :< ts) = go g0 t (:< ts) :< extend g0 ts- where- go :: (Stream a -> b) -> Complete a -> (Complete a -> Stream a) -> Complete b- go g w@Tip{} f = Tip (g (f w))- go g w@(Bin n _ l r) f = Bin n (g (f w)) (go g l (:< f r)) (go g r f)- extract (a :< _) = extract a--instance Apply Stream where- fs <.> as = mapWithIndex (\n f -> f (as !! n)) fs- as <. _ = as- _ .> bs = bs--instance ComonadApply Stream where- (<@>) = (<.>)- (<@) = (<.)- (@>) = (.>)--instance Applicative Stream where- pure = repeat- (<*>) = (<.>)- (<* ) = (<. )- ( *>) = ( .>)--instance Alt Stream where- as <!> bs = tabulate $ \i -> case quotRem i 2 of- (q,0) -> as !! q- (q,_) -> bs !! q--instance Foldable Stream where- foldMap f (t :< ts) = foldMap f t `mappend` foldMap f ts- foldr f z (t :< ts) = foldr f (foldr f z ts) t-#if __GLASGOW_HASKELL__ >= 710- length _ = error "infinite length"- null _ = False-#endif--instance Foldable1 Stream where- foldMap1 f (t :< ts) = foldMap1 f t <> foldMap1 f ts--instance Traversable Stream where- traverse f (t :< ts) = (:<) <$> traverse f t <*> traverse f ts--instance Traversable1 Stream where- traverse1 f (t :< ts) = (:<) <$> traverse1 f t <.> traverse1 f ts--instance Distributive Stream where- distribute w = tabulate (\i -> fmap (!! i) w)--instance Representable Stream where- type Rep Stream = Integer- tabulate f = mapWithIndex (const . f) (pure ())- index (t :< ts) i- | i < 0 = error "index: negative index"- | i < w = indexComplete i t- | otherwise = index ts (i - w)- where w = weight t--instance Semigroup (Stream a) where- (<>) = (<!>)--instance Monad Stream where- return = pure- as >>= f = mapWithIndex (\i a -> f a !! i) as--interleave :: Stream a -> Stream a -> Stream a-interleave = (<!>)--repeat :: a -> Stream a-repeat b = go b (Tip b)- where- go :: a -> Complete a -> Stream a- go a as | ass <- bin a as as = as :< go a ass--mapWithIndex :: (Integer -> a -> b) -> Stream a -> Stream b-mapWithIndex f0 as0 = spine f0 0 as0- where- spine f m (a :< as) = tree f m a :< spine f (m + weight a) as- tree f m (Tip a) = Tip (f m a)- tree f m (Bin n a l r) = Bin n (f m a) (tree f (m + 1) l) (tree f (m + 1 + weight l) r)--indexed :: Stream a -> Stream (Integer, a)-indexed = mapWithIndex (,)--from :: Num a => a -> Stream a-from a = mapWithIndex ((+) . fromIntegral) (pure a)---- | /O(1)/ cons-(<|) :: a -> Stream a -> Stream a-a <| (l :< r :< as)- | weight l == weight r = bin a l r :< as-a <| as = Tip a :< as-{-# INLINE (<|) #-}---- | /O(1)/.-tail :: Stream a -> Stream a-tail (Tip{} :< ts) = ts-tail (Bin _ _ l r :< ts) = l :< r :< ts-{-# INLINE tail #-}---- | /O(1)/.-uncons :: Stream a -> (a, Stream a)-uncons (Tip a :< as) = (a, as)-uncons (Bin _ a l r :< as) = (a, l :< r :< as)-{-# INLINE uncons #-}--indexComplete :: Integer -> Complete a -> a-indexComplete 0 (Tip a) = a-indexComplete 0 (Bin _ a _ _) = a-indexComplete i (Bin w _ l r)- | i <= w' = indexComplete (i-1) l- | otherwise = indexComplete (i-1-w') r- where w' = div w 2-indexComplete _ _ = error "indexComplete"---- | /O(log n)/.-(!!) :: Stream a -> Integer -> a-(!!) = index---- | /O(log n)/.-drop :: Integer -> Stream a -> Stream a-drop 0 ts = ts-drop i (t :< ts) = case compare i w of- LT -> dropComplete i t (:< ts)- EQ -> ts- GT -> drop (i - w) ts- where w = weight t--dropComplete :: Integer -> Complete a -> (Complete a -> Stream a) -> Stream a-dropComplete 0 t f = f t-dropComplete 1 (Bin _ _ l r) f = l :< f r-dropComplete i (Bin w _ l r) f = case compare (i - 1) w' of- LT -> dropComplete (i-1) l (:< f r)- EQ -> f r- GT -> dropComplete (i-1-w') r f- where w' = div w 2-dropComplete _ _ _ = error "dropComplete"---- | /O(n)/.-dropWhile :: (a -> Bool) -> Stream a -> Stream a-dropWhile p as- | p (extract as) = dropWhile p (tail as)- | otherwise = as---- | /O(n)/-span :: (a -> Bool) -> Stream a -> ([a], Stream a)-span p as- | a <- extract as, p a = first (a:) $ span p (tail as)- | otherwise = ([], as)---- | /O(n)/-break :: (a -> Bool) -> Stream a -> ([a], Stream a)-break p = span (not . p)---- | /(O(n), O(log n))/ split at _some_ edge where function goes from False to True.--- best used with a monotonic function-split :: (a -> Bool) -> Stream a -> ([a], Stream a)-split p (a :< as)- | p (extract as) = splitComplete p a (:< as)- | (ts, fs) <- split p as = (foldr (:) ts a, fs)---- for use when we know the split occurs within a given tree-splitComplete :: (a -> Bool) -> Complete a -> (Complete a -> Stream a) -> ([a], Stream a)-splitComplete _ t@Tip{} f = ([], f t)-splitComplete p t@(Bin _ a l r) f- | p a = ([], f t)- | p (extract r), (ts, fs) <- splitComplete p l (:< f r) = (a:ts, fs)- | (ts, fs) <- splitComplete p r f = (a:foldr (:) ts l, fs)---- | /(O(n), O(log n))/ split at _some_ edge where function goes from False to True.--- best used with a monotonic function------ > splitW p xs = (map extract &&& fmap (fmap extract)) . split p . duplicate-splitW :: (Stream a -> Bool) -> Stream a -> ([a], Stream a)-splitW p (a :< as)- | p as = splitCompleteW p a (:< as)- | (ts, fs) <- splitW p as = (foldr (:) ts a, fs)---- for use when we know the split occurs within a given tree-splitCompleteW :: (Stream a -> Bool) -> Complete a -> (Complete a -> Stream a) -> ([a], Stream a)-splitCompleteW _ t@Tip{} f = ([], f t)-splitCompleteW p t@(Bin _ a l r) f- | w <- f t, p w = ([], w)- | w <- f r, p w, (ts, fs) <- splitCompleteW p l (:< w) = (a:ts, fs)- | (ts, fs) <- splitCompleteW p r f = (a:foldr (:) ts l, fs)---- | /O(n)/-insert :: Ord a => a -> Stream a -> Stream a-insert a as | (ts, as') <- split (a<=) as = foldr (<|) (a <| as') ts---- | /O(n)/. Finds the split in O(log n), but then has to recons-insertBy :: (a -> a -> Ordering) -> a -> Stream a -> Stream a-insertBy cmp a as | (ts, as') <- split (\b -> cmp a b <= EQ) as = foldr (<|) (a <| as') ts---- | /O(log n)/ Change the value of the nth entry in the future-adjust :: Integer -> (a -> a) -> Stream a -> Stream a-adjust !n f (a :< as)- | n < w = adjustComplete n f a :< as- | otherwise = a :< adjust (n - w) f as- where w = weight a--adjustComplete :: Integer -> (a -> a) -> Complete a -> Complete a-adjustComplete 0 f (Tip a) = Tip (f a)-adjustComplete _ _ t@Tip{} = t-adjustComplete n f (Bin m a l r)- | n == 0 = Bin m (f a) l r- | n <= w = Bin m a (adjustComplete (n - 1) f l) r- | otherwise = Bin m a l (adjustComplete (n - 1 - w) f r)- where w = weight l--update :: Integer -> a -> Stream a -> Stream a-update n = adjust n . const-+{-# LANGUAGE PatternGuards, BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Infinite.Skew +-- Copyright : (C) 2011 Edward Kmett, +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- Anticausal streams implemented as non-empty skew binary random access lists +-- +-- The Applicative zips streams, the monad diagonalizes +------------------------------------------------------------------------------ + + +module Data.Stream.Infinite.Skew + ( Stream + , (<|) -- O(1) + , (!!) + , tail -- O(1) + , uncons -- O(1) + , drop -- O(log n) + , dropWhile -- O(n) + , span + , break + , split + , splitW + , repeat + , insert -- O(n) + , insertBy + , adjust -- O(log n) + , update -- O(log n) + , from + , indexed + , interleave + ) where + +import Control.Arrow (first) +import Control.Applicative hiding (empty) +import Control.Comonad +import Data.Distributive +import Data.Functor.Alt +import Data.Functor.Extend +import Data.Functor.Rep +import Data.Foldable +import Data.Traversable +import Data.Semigroup hiding (Last) +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Prelude hiding (null, head, tail, drop, dropWhile, length, foldr, last, span, repeat, replicate, (!!), break) +import Data.Boring (Boring (..), Absurd (..)) + +infixr 5 :<, <| + +data Complete a + = Tip a + | Bin !Integer a !(Complete a) !(Complete a) + deriving Show + +instance Functor Complete where + fmap f (Tip a) = Tip (f a) + fmap f (Bin w a l r) = Bin w (f a) (fmap f l) (fmap f r) + +instance Extend Complete where + extended f w@Tip {} = Tip (f w) + extended f w@(Bin n _ l r) = Bin n (f w) (extended f l) (extended f r) + +instance Comonad Complete where + extend f w@Tip {} = Tip (f w) + extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r) + extract (Tip a) = a + extract (Bin _ a _ _) = a + +instance Foldable Complete where + foldMap f (Tip a) = f a + foldMap f (Bin _ a l r) = f a `mappend` foldMap f l `mappend` foldMap f r + foldr f z (Tip a) = f a z + foldr f z (Bin _ a l r) = f a (foldr f (foldr f z r) l) +#if __GLASGOW_HASKELL__ >= 710 + length Tip{} = 1 + length (Bin n _ _ _) = fromIntegral n + null _ = False +#endif + +instance Foldable1 Complete where + foldMap1 f (Tip a) = f a + foldMap1 f (Bin _ a l r) = f a <> foldMap1 f l <> foldMap1 f r + +instance Traversable Complete where + traverse f (Tip a) = Tip <$> f a + traverse f (Bin n a l r) = Bin n <$> f a <*> traverse f l <*> traverse f r + +instance Traversable1 Complete where + traverse1 f (Tip a) = Tip <$> f a + traverse1 f (Bin n a l r) = Bin n <$> f a <.> traverse1 f l <.> traverse1 f r + +bin :: a -> Complete a -> Complete a -> Complete a +bin a l r = Bin (1 + weight l + weight r) a l r +{-# INLINE bin #-} + +weight :: Complete a -> Integer +weight Tip{} = 1 +weight (Bin w _ _ _) = w +{-# INLINE weight #-} + +-- A future is a non-empty skew binary random access list of nodes. +-- The last node, however, is allowed to contain fewer values. +data Stream a = !(Complete a) :< Stream a +-- deriving Show + +instance Show a => Show (Stream a) where + showsPrec d as = showParen (d >= 10) $ + showString "fromList " . showsPrec 11 (toList as) + +instance Functor Stream where + fmap f (t :< ts) = fmap f t :< fmap f ts + +instance Extend Stream where + extended = extend + +instance Comonad Stream where + extend g0 (t :< ts) = go g0 t (:< ts) :< extend g0 ts + where + go :: (Stream a -> b) -> Complete a -> (Complete a -> Stream a) -> Complete b + go g w@Tip{} f = Tip (g (f w)) + go g w@(Bin n _ l r) f = Bin n (g (f w)) (go g l (:< f r)) (go g r f) + extract (a :< _) = extract a + +instance Apply Stream where + fs <.> as = mapWithIndex (\n f -> f (as !! n)) fs + as <. _ = as + _ .> bs = bs + +instance ComonadApply Stream where + (<@>) = (<.>) + (<@) = (<.) + (@>) = (.>) + +instance Applicative Stream where + pure = repeat + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + +instance Alt Stream where + as <!> bs = tabulate $ \i -> case quotRem i 2 of + (q,0) -> as !! q + (q,_) -> bs !! q + +instance Foldable Stream where + foldMap f (t :< ts) = foldMap f t `mappend` foldMap f ts + foldr f z (t :< ts) = foldr f (foldr f z ts) t +#if __GLASGOW_HASKELL__ >= 710 + length _ = error "infinite length" + null _ = False +#endif + +instance Foldable1 Stream where + foldMap1 f (t :< ts) = foldMap1 f t <> foldMap1 f ts + +instance Traversable Stream where + traverse f (t :< ts) = (:<) <$> traverse f t <*> traverse f ts + +instance Traversable1 Stream where + traverse1 f (t :< ts) = (:<) <$> traverse1 f t <.> traverse1 f ts + +instance Distributive Stream where + distribute w = tabulate (\i -> fmap (!! i) w) + +instance Representable Stream where + type Rep Stream = Integer + tabulate f = mapWithIndex (const . f) (pure ()) + index (t :< ts) i + | i < 0 = error "index: negative index" + | i < w = indexComplete i t + | otherwise = index ts (i - w) + where w = weight t + +-- | @since 3.3.1 +instance Boring a => Boring (Stream a) where + boring = pure boring + +-- | @since 3.3.1 +instance Absurd a => Absurd (Stream a) where + absurd = absurd . extract + +instance Semigroup (Stream a) where + (<>) = (<!>) + +instance Monad Stream where + return = pure + as >>= f = mapWithIndex (\i a -> f a !! i) as + +interleave :: Stream a -> Stream a -> Stream a +interleave = (<!>) + +repeat :: a -> Stream a +repeat b = go b (Tip b) + where + go :: a -> Complete a -> Stream a + go a as | ass <- bin a as as = as :< go a ass + +mapWithIndex :: (Integer -> a -> b) -> Stream a -> Stream b +mapWithIndex f0 as0 = spine f0 0 as0 + where + spine f m (a :< as) = tree f m a :< spine f (m + weight a) as + tree f m (Tip a) = Tip (f m a) + tree f m (Bin n a l r) = Bin n (f m a) (tree f (m + 1) l) (tree f (m + 1 + weight l) r) + +indexed :: Stream a -> Stream (Integer, a) +indexed = mapWithIndex (,) + +from :: Num a => a -> Stream a +from a = mapWithIndex ((+) . fromIntegral) (pure a) + +-- | /O(1)/ cons +(<|) :: a -> Stream a -> Stream a +a <| (l :< r :< as) + | weight l == weight r = bin a l r :< as +a <| as = Tip a :< as +{-# INLINE (<|) #-} + +-- | /O(1)/. +tail :: Stream a -> Stream a +tail (Tip{} :< ts) = ts +tail (Bin _ _ l r :< ts) = l :< r :< ts +{-# INLINE tail #-} + +-- | /O(1)/. +uncons :: Stream a -> (a, Stream a) +uncons (Tip a :< as) = (a, as) +uncons (Bin _ a l r :< as) = (a, l :< r :< as) +{-# INLINE uncons #-} + +indexComplete :: Integer -> Complete a -> a +indexComplete 0 (Tip a) = a +indexComplete 0 (Bin _ a _ _) = a +indexComplete i (Bin w _ l r) + | i <= w' = indexComplete (i-1) l + | otherwise = indexComplete (i-1-w') r + where w' = div w 2 +indexComplete _ _ = error "indexComplete" + +-- | /O(log n)/. +(!!) :: Stream a -> Integer -> a +(!!) = index + +-- | /O(log n)/. +drop :: Integer -> Stream a -> Stream a +drop 0 ts = ts +drop i (t :< ts) = case compare i w of + LT -> dropComplete i t (:< ts) + EQ -> ts + GT -> drop (i - w) ts + where w = weight t + +dropComplete :: Integer -> Complete a -> (Complete a -> Stream a) -> Stream a +dropComplete 0 t f = f t +dropComplete 1 (Bin _ _ l r) f = l :< f r +dropComplete i (Bin w _ l r) f = case compare (i - 1) w' of + LT -> dropComplete (i-1) l (:< f r) + EQ -> f r + GT -> dropComplete (i-1-w') r f + where w' = div w 2 +dropComplete _ _ _ = error "dropComplete" + +-- | /O(n)/. +dropWhile :: (a -> Bool) -> Stream a -> Stream a +dropWhile p as + | p (extract as) = dropWhile p (tail as) + | otherwise = as + +-- | /O(n)/ +span :: (a -> Bool) -> Stream a -> ([a], Stream a) +span p as + | a <- extract as, p a = first (a:) $ span p (tail as) + | otherwise = ([], as) + +-- | /O(n)/ +break :: (a -> Bool) -> Stream a -> ([a], Stream a) +break p = span (not . p) + +-- | /(O(n), O(log n))/ split at _some_ edge where function goes from False to True. +-- best used with a monotonic function +split :: (a -> Bool) -> Stream a -> ([a], Stream a) +split p (a :< as) + | p (extract as) = splitComplete p a (:< as) + | (ts, fs) <- split p as = (foldr (:) ts a, fs) + +-- for use when we know the split occurs within a given tree +splitComplete :: (a -> Bool) -> Complete a -> (Complete a -> Stream a) -> ([a], Stream a) +splitComplete _ t@Tip{} f = ([], f t) +splitComplete p t@(Bin _ a l r) f + | p a = ([], f t) + | p (extract r), (ts, fs) <- splitComplete p l (:< f r) = (a:ts, fs) + | (ts, fs) <- splitComplete p r f = (a:foldr (:) ts l, fs) + +-- | /(O(n), O(log n))/ split at _some_ edge where function goes from False to True. +-- best used with a monotonic function +-- +-- > splitW p xs = (map extract &&& fmap (fmap extract)) . split p . duplicate +splitW :: (Stream a -> Bool) -> Stream a -> ([a], Stream a) +splitW p (a :< as) + | p as = splitCompleteW p a (:< as) + | (ts, fs) <- splitW p as = (foldr (:) ts a, fs) + +-- for use when we know the split occurs within a given tree +splitCompleteW :: (Stream a -> Bool) -> Complete a -> (Complete a -> Stream a) -> ([a], Stream a) +splitCompleteW _ t@Tip{} f = ([], f t) +splitCompleteW p t@(Bin _ a l r) f + | w <- f t, p w = ([], w) + | w <- f r, p w, (ts, fs) <- splitCompleteW p l (:< w) = (a:ts, fs) + | (ts, fs) <- splitCompleteW p r f = (a:foldr (:) ts l, fs) + +-- | /O(n)/ +insert :: Ord a => a -> Stream a -> Stream a +insert a as | (ts, as') <- split (a<=) as = foldr (<|) (a <| as') ts + +-- | /O(n)/. Finds the split in O(log n), but then has to recons +insertBy :: (a -> a -> Ordering) -> a -> Stream a -> Stream a +insertBy cmp a as | (ts, as') <- split (\b -> cmp a b <= EQ) as = foldr (<|) (a <| as') ts + +-- | /O(log n)/ Change the value of the nth entry in the future +adjust :: Integer -> (a -> a) -> Stream a -> Stream a +adjust !n f (a :< as) + | n < w = adjustComplete n f a :< as + | otherwise = a :< adjust (n - w) f as + where w = weight a + +adjustComplete :: Integer -> (a -> a) -> Complete a -> Complete a +adjustComplete 0 f (Tip a) = Tip (f a) +adjustComplete _ _ t@Tip{} = t +adjustComplete n f (Bin m a l r) + | n == 0 = Bin m (f a) l r + | n <= w = Bin m a (adjustComplete (n - 1) f l) r + | otherwise = Bin m a l (adjustComplete (n - 1 - w) f r) + where w = weight l + +update :: Integer -> a -> Stream a -> Stream a +update n = adjust n . const +
src/Data/Stream/Supply.hs view
@@ -1,182 +1,184 @@-{-# LANGUAGE CPP, FlexibleContexts #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Stream.Supply--- Copyright : (C) 2008-2011 Edward Kmett,--- (C) 2008 Iavor S. Diatchki--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This library can be used to generate values (for example, new names)--- without the need to thread state. This means that functions that--- need to generate new values only need a supply object as an argument,--- and they do not need to return a new supply object as a result.--- This decreases the number of data-dependencies in a program, which--- makes it easier to exploit parallelism.------ The technique for generating new values is based on the paper--- ''On Generating Unique Names'' by Lennart Augustsson, Mikael Rittri,--- and Dan Synek.------------------------------------------------------------------------------module Data.Stream.Supply- ( Supply- , newSupply- , newEnumSupply- , newNumSupply- , newDupableSupply- , newDupableEnumSupply- , newDupableNumSupply- , leftSupply- , rightSupply- , split- , splits- , splitSkew- , split2- , split3- , split4- ) where--#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-#endif-import Control.Comonad-import Data.Functor.Apply-import Data.Functor.Extend-import Data.Functor.Rep-import Data.IORef(newIORef, atomicModifyIORef)-#if !(MIN_VERSION_base(4,8,0))-import Data.Foldable-import Data.Traversable-#endif-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import System.IO.Unsafe (unsafeInterleaveIO)-import Data.Stream.Infinite-import qualified Data.Stream.Infinite.Skew as Skew--#ifdef LANGUAGE_DeriveDataTypeable-import Data.Data-#endif--#if __GLASGOW_HASKELL__ >= 608-import GHC.IO(unsafeDupableInterleaveIO)-#else-unsafeDupableInterleaveIO :: IO a -> IO a-unsafeDupableInterleaveIO = unsafeInterleaveIO-#endif--data Supply a = Supply a (Supply a) (Supply a) deriving- ( Show, Read, Eq, Ord-#ifdef LANGUAGE_DeriveDataTypeable- , Data, Typeable-#endif- )--instance Functor Supply where- fmap f (Supply a l r) = Supply (f a) (fmap f l) (fmap f r)- a <$ _ = pure a--instance Extend Supply where- extended f s@(Supply _ l r) = Supply (f s) (extended f l) (extended f r)- duplicated s@(Supply _ l r) = Supply s (duplicated l) (duplicated r)--instance Comonad Supply where- extend f s@(Supply _ l r) = Supply (f s) (extend f l) (extend f r)- duplicate s@(Supply _ l r) = Supply s (duplicate l) (duplicate r)- extract (Supply a _ _) = a--instance Apply Supply where- Supply f fl fr <.> Supply a al ar = Supply (f a) (fl <.> al) (fr <.> ar)- a <. _ = a- _ .> a = a--instance Applicative Supply where- pure a = as where as = Supply a as as- Supply f fl fr <*> Supply a al ar = Supply (f a) (fl <*> al) (fr <*> ar)- a <* _ = a- _ *> a = a--instance Foldable Supply where- foldMap f (Supply a l r) = f a `mappend` foldMap f l `mappend` foldMap f r--instance Foldable1 Supply where- foldMap1 f (Supply a l r) = f a <> foldMap1 f l <> foldMap1 f r--instance Traversable Supply where- traverse f (Supply a l r) = Supply <$> f a <*> traverse f l <*> traverse f r--instance Traversable1 Supply where- traverse1 f (Supply a l r) = Supply <$> f a <.> traverse1 f l <.> traverse1 f r--leftSupply :: Supply a -> Supply a-leftSupply (Supply _ l _) = l--rightSupply :: Supply a -> Supply a-rightSupply (Supply _ _ r) = r---- unfoldsW :: (Comonad w, Functor f) => (w a -> (b, f a)) -> w a -> StreamT f w b-newSupply :: (a -> a) -> a -> IO (Supply a)-newSupply f x = gen =<< newIORef x- where gen r = unsafeInterleaveIO $- Supply <$> unsafeInterleaveIO (atomicModifyIORef r update)- <*> gen r- <*> gen r- update a = b `seq` (b, a) where b = f a-{-# INLINE newSupply #-}--newDupableSupply :: (a -> a) -> a -> IO (Supply a)-newDupableSupply f x = gen =<< newIORef x- where gen r = unsafeDupableInterleaveIO $- Supply <$> unsafeDupableInterleaveIO (atomicModifyIORef r update)- <*> gen r- <*> gen r- update a = b `seq` (b, a) where b = f a-{-# INLINE newDupableSupply #-}--newEnumSupply :: Enum a => IO (Supply a)-newEnumSupply = newSupply succ (toEnum 0)-{-# SPECIALIZE newEnumSupply :: IO (Supply Int) #-}--newNumSupply :: Num a => IO (Supply a)-newNumSupply = newSupply (1+) 0-{-# SPECIALIZE newNumSupply :: IO (Supply Int) #-}--newDupableEnumSupply :: Enum a => IO (Supply a)-newDupableEnumSupply = newSupply succ (toEnum 0)-{-# SPECIALIZE newEnumSupply :: IO (Supply Int) #-}--newDupableNumSupply :: Num a => IO (Supply a)-newDupableNumSupply = newSupply (1+) 0-{-# SPECIALIZE newNumSupply :: IO (Supply Int) #-}--split :: Supply a -> Stream (Supply a)-split (Supply _ l r) = l :> split r--splits :: Integral b => Supply a -> b -> Supply a-splits (Supply _ l r) n = case n `quotRem` 2 of- (0,0) -> leftSupply l- (q,-1) -> splits (rightSupply l) q- (q,0) -> splits (leftSupply r) q- (q,1) -> splits (rightSupply r) q- (_,_) -> error "quotRem: impossible result"-{-# SPECIALIZE splits :: Supply a -> Int -> Supply a #-}-{-# SPECIALIZE splits :: Supply a -> Integer -> Supply a #-}--splitSkew :: Supply a -> Skew.Stream (Supply a)-splitSkew = tabulate . splits--split2 :: Supply a -> (Supply a, Supply a)-split2 (Supply _ l r) = (l, r)--split3 :: Supply a -> (Supply a, Supply a, Supply a)-split3 (Supply _ a (Supply _ b c)) = (a, b, c)--split4 :: Supply a -> (Supply a, Supply a, Supply a, Supply a)-split4 (Supply _ (Supply _ a b) (Supply _ c d)) = (a, b, c, d)+{-# LANGUAGE CPP, FlexibleContexts #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Supply +-- Copyright : (C) 2008-2011 Edward Kmett, +-- (C) 2008 Iavor S. Diatchki +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- This library can be used to generate values (for example, new names) +-- without the need to thread state. This means that functions that +-- need to generate new values only need a supply object as an argument, +-- and they do not need to return a new supply object as a result. +-- This decreases the number of data-dependencies in a program, which +-- makes it easier to exploit parallelism. +-- +-- The technique for generating new values is based on the paper +-- ''On Generating Unique Names'' by Lennart Augustsson, Mikael Rittri, +-- and Dan Synek. +---------------------------------------------------------------------------- +module Data.Stream.Supply + ( Supply + , newSupply + , newEnumSupply + , newNumSupply + , newDupableSupply + , newDupableEnumSupply + , newDupableNumSupply + , leftSupply + , rightSupply + , split + , splits + , splitSkew + , split2 + , split3 + , split4 + ) where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative +#endif +import Control.Comonad +import Data.Functor.Apply +import Data.Functor.Extend +import Data.Functor.Rep +import Data.IORef(newIORef, atomicModifyIORef) +#if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable +import Data.Traversable +#endif +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import System.IO.Unsafe (unsafeInterleaveIO) +import Data.Stream.Infinite +import qualified Data.Stream.Infinite.Skew as Skew + +#ifdef LANGUAGE_DeriveDataTypeable +import Data.Data +#endif + +#if __GLASGOW_HASKELL__ >= 608 +import GHC.IO(unsafeDupableInterleaveIO) +#else +unsafeDupableInterleaveIO :: IO a -> IO a +unsafeDupableInterleaveIO = unsafeInterleaveIO +#endif + +data Supply a = Supply a (Supply a) (Supply a) deriving + ( Show, Read, Eq, Ord +#ifdef LANGUAGE_DeriveDataTypeable + , Data, Typeable +#endif + ) + +instance Functor Supply where + fmap f (Supply a l r) = Supply (f a) (fmap f l) (fmap f r) + a <$ _ = pure a + +instance Extend Supply where + extended f s@(Supply _ l r) = Supply (f s) (extended f l) (extended f r) + duplicated s@(Supply _ l r) = Supply s (duplicated l) (duplicated r) + +instance Comonad Supply where + extend f s@(Supply _ l r) = Supply (f s) (extend f l) (extend f r) + duplicate s@(Supply _ l r) = Supply s (duplicate l) (duplicate r) + extract (Supply a _ _) = a + +instance Apply Supply where + Supply f fl fr <.> Supply a al ar = Supply (f a) (fl <.> al) (fr <.> ar) + a <. _ = a + _ .> a = a + +instance Applicative Supply where + pure a = as where as = Supply a as as + Supply f fl fr <*> Supply a al ar = Supply (f a) (fl <*> al) (fr <*> ar) + a <* _ = a + _ *> a = a + +instance Foldable Supply where + foldMap f (Supply a l r) = f a `mappend` foldMap f l `mappend` foldMap f r + +instance Foldable1 Supply where + foldMap1 f (Supply a l r) = f a <> foldMap1 f l <> foldMap1 f r + +instance Traversable Supply where + traverse f (Supply a l r) = Supply <$> f a <*> traverse f l <*> traverse f r + +instance Traversable1 Supply where + traverse1 f (Supply a l r) = Supply <$> f a <.> traverse1 f l <.> traverse1 f r + +leftSupply :: Supply a -> Supply a +leftSupply (Supply _ l _) = l + +rightSupply :: Supply a -> Supply a +rightSupply (Supply _ _ r) = r + +-- unfoldsW :: (Comonad w, Functor f) => (w a -> (b, f a)) -> w a -> StreamT f w b +newSupply :: (a -> a) -> a -> IO (Supply a) +newSupply f x = gen =<< newIORef x + where gen r = unsafeInterleaveIO $ + Supply <$> unsafeInterleaveIO (atomicModifyIORef r update) + <*> gen r + <*> gen r + update a = b `seq` (b, a) where b = f a +{-# INLINE newSupply #-} + +newDupableSupply :: (a -> a) -> a -> IO (Supply a) +newDupableSupply f x = gen =<< newIORef x + where gen r = unsafeDupableInterleaveIO $ + Supply <$> unsafeDupableInterleaveIO (atomicModifyIORef r update) + <*> gen r + <*> gen r + update a = b `seq` (b, a) where b = f a +{-# INLINE newDupableSupply #-} + +newEnumSupply :: Enum a => IO (Supply a) +newEnumSupply = newSupply succ (toEnum 0) +{-# SPECIALIZE newEnumSupply :: IO (Supply Int) #-} + +newNumSupply :: Num a => IO (Supply a) +newNumSupply = newSupply (1+) 0 +{-# SPECIALIZE newNumSupply :: IO (Supply Int) #-} + +newDupableEnumSupply :: Enum a => IO (Supply a) +newDupableEnumSupply = newSupply succ (toEnum 0) +{-# SPECIALIZE newEnumSupply :: IO (Supply Int) #-} + +newDupableNumSupply :: Num a => IO (Supply a) +newDupableNumSupply = newSupply (1+) 0 +{-# SPECIALIZE newNumSupply :: IO (Supply Int) #-} + +split :: Supply a -> Stream (Supply a) +split (Supply _ l r) = l :> split r + +splits :: Integral b => Supply a -> b -> Supply a +splits (Supply _ l r) n = case n `quotRem` 2 of + (0,0) -> leftSupply l + (q,-1) -> splits (rightSupply l) q + (q,0) -> splits (leftSupply r) q + (q,1) -> splits (rightSupply r) q + (_,_) -> error "quotRem: impossible result" +{-# SPECIALIZE splits :: Supply a -> Int -> Supply a #-} +{-# SPECIALIZE splits :: Supply a -> Integer -> Supply a #-} + +splitSkew :: Supply a -> Skew.Stream (Supply a) +splitSkew = tabulate . splits + +split2 :: Supply a -> (Supply a, Supply a) +split2 (Supply _ l r) = (l, r) + +split3 :: Supply a -> (Supply a, Supply a, Supply a) +split3 (Supply _ a (Supply _ b c)) = (a, b, c) + +split4 :: Supply a -> (Supply a, Supply a, Supply a, Supply a) +split4 (Supply _ (Supply _ a b) (Supply _ c d)) = (a, b, c, d)
streams.cabal view
@@ -1,93 +1,110 @@-name: streams-category: Control, Comonads-version: 3.3-license: BSD3-cabal-version: >= 1.6-license-file: LICENSE-author: Edward A. Kmett-maintainer: Edward A. Kmett <ekmett@gmail.com>-stability: provisional-homepage: http://github.com/ekmett/streams-homepage: http://github.com/ekmett/streams/issues-copyright: Copyright 2011-2013 Edward Kmett- Copyright 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen- Copyright 2007-2010 Wouter Swierstra, Bas van Dijk- Copyright 2008 Iavor S. Diatchki-synopsis: Various Haskell 2010 stream comonads-build-type: Simple-extra-source-files:- CHANGELOG.markdown- README- .ghci- .gitignore- .travis.yml- .vim.custom-description:- Various Haskell 2010 stream comonads.- * "Data.Stream.Future" provides a coinductive anti-causal stream, or non-empty 'ZipList'. The comonad provides access to only the- tail of the stream. Like a conventional 'ZipList', this is /not/ a monad.- .- > data Future a = Last a | a :< Future a- .- * "Data.Stream.Future.Skew" provides a non-empty skew-binary random-access-list with the semantics of @Data.Stream.Future@. As with- "Data.Stream.Future" this stream is not a 'Monad', since the 'Applicative' instance zips streams of potentially differing lengths.- The random-access-list structure provides a number of operations logarithmic access time, but makes 'Data.Stream.Future.Skew.cons'- less productive. Where applicable "Data.Stream.Infinite.Skew" may be more efficient, due to a lazier and more efficient 'Applicative'- instance.- .- >- .- * "Data.Stream.Infinite" provides a coinductive infinite anti-causal stream. The 'Comonad' provides access to the tail of the- stream and the 'Applicative' zips streams together. Unlike 'Future', infinite stream form a 'Monad'. The monad diagonalizes- the 'Stream', which is consistent with the behavior of the 'Applicative', and the view of a 'Stream' as a isomorphic to the reader- monad from the natural numbers. Being infinite in length, there is no 'Alternative' instance.- .- > data Stream a = a :< Stream a- .- * "Data.Stream.Infinite.Skew" provides an infinite skew-binary random-access-list with the semantics of "Data.Stream.Infinite"- Since every stream is infinite, the 'Applicative' instance can be considerably less strict than the corresponding instance for- "Data.Stream.Future.Skew" and performs asymptotically better.- .- >- .- * "Data.Stream.Infinite.Functional.Zipper" provides a bi-infinite sequence, represented as a pure function with an accumulating- parameter added to optimize moving the current focus.- .- > data Zipper a = !Integer :~ (Integer -> a)- .- * "Data.Stream.Supply" provides a comonadic supply of unique values, which are- generated impurely as the tree is explored.--source-repository head- type: git- location: git://github.com/ekmett/streams.git--library- other-extensions:- PatternGuards- BangPatterns-- build-depends:- base >= 4 && < 5,- adjunctions >= 4.0.1 && < 5,- comonad >= 4 && < 6,- distributive >= 0.2.1 && < 1,- semigroupoids >= 4 && < 6,- semigroups >= 0.8.3.1 && < 1-- extensions: CPP- if impl(ghc)- cpp-options: -DLANGUAGE_DeriveDataTypeable- extensions: FlexibleContexts, DeriveDataTypeable-- exposed-modules:- Data.Stream.Future- Data.Stream.Future.Skew- Data.Stream.Infinite- Data.Stream.Infinite.Skew- Data.Stream.Infinite.Functional.Zipper- Data.Stream.Supply-- hs-source-dirs: src- ghc-options: -Wall-+name: streams +category: Control, Comonads +version: 3.3.1 +license: BSD3 +cabal-version: >= 1.10 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett <ekmett@gmail.com> +stability: provisional +homepage: http://github.com/ekmett/streams +bug-reports: http://github.com/ekmett/streams/issues +copyright: Copyright 2011-2013 Edward Kmett + Copyright 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen + Copyright 2007-2010 Wouter Swierstra, Bas van Dijk + Copyright 2008 Iavor S. Diatchki +synopsis: Various Haskell 2010 stream comonads +build-type: Simple +extra-source-files: + CHANGELOG.markdown + README + .gitignore + .vim.custom +tested-with: GHC == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.2 +description: + Various Haskell 2010 stream comonads. + * "Data.Stream.Future" provides a coinductive anti-causal stream, or non-empty 'ZipList'. The comonad provides access to only the + tail of the stream. Like a conventional 'ZipList', this is /not/ a monad. + . + > data Future a = Last a | a :< Future a + . + * "Data.Stream.Future.Skew" provides a non-empty skew-binary random-access-list with the semantics of @Data.Stream.Future@. As with + "Data.Stream.Future" this stream is not a 'Monad', since the 'Applicative' instance zips streams of potentially differing lengths. + The random-access-list structure provides a number of operations logarithmic access time, but makes 'Data.Stream.Future.Skew.cons' + less productive. Where applicable "Data.Stream.Infinite.Skew" may be more efficient, due to a lazier and more efficient 'Applicative' + instance. + . + > + . + * "Data.Stream.Infinite" provides a coinductive infinite anti-causal stream. The 'Comonad' provides access to the tail of the + stream and the 'Applicative' zips streams together. Unlike 'Future', infinite stream form a 'Monad'. The monad diagonalizes + the 'Stream', which is consistent with the behavior of the 'Applicative', and the view of a 'Stream' as a isomorphic to the reader + monad from the natural numbers. Being infinite in length, there is no 'Alternative' instance. + . + > data Stream a = a :< Stream a + . + * "Data.Stream.Infinite.Skew" provides an infinite skew-binary random-access-list with the semantics of "Data.Stream.Infinite" + Since every stream is infinite, the 'Applicative' instance can be considerably less strict than the corresponding instance for + "Data.Stream.Future.Skew" and performs asymptotically better. + . + > + . + * "Data.Stream.Infinite.Functional.Zipper" provides a bi-infinite sequence, represented as a pure function with an accumulating + parameter added to optimize moving the current focus. + . + > data Zipper a = !Integer :~ (Integer -> a) + . + * "Data.Stream.Supply" provides a comonadic supply of unique values, which are + generated impurely as the tree is explored. + +source-repository head + type: git + location: git://github.com/ekmett/streams.git + +library + other-extensions: + PatternGuards + BangPatterns + + build-depends: + base >= 4 && < 5, + adjunctions >= 4.0.1 && < 5, + boring >= 0.2 && < 0.3, + comonad >= 4 && < 6, + distributive >= 0.2.1 && < 1, + semigroupoids >= 4 && < 6 + + if impl(ghc < 8.0) + build-depends: + semigroups >= 0.8.3.1 && < 1 + + default-extensions: CPP + if impl(ghc) + cpp-options: -DLANGUAGE_DeriveDataTypeable + default-extensions: FlexibleContexts, DeriveDataTypeable + + exposed-modules: + Data.Stream.Future + Data.Stream.Future.Skew + Data.Stream.Infinite + Data.Stream.Infinite.Skew + Data.Stream.Infinite.Functional.Zipper + Data.Stream.Supply + + hs-source-dirs: src + ghc-options: -Wall + if impl(ghc >= 7.10) + ghc-options: -fno-warn-trustworthy-safe + default-language: Haskell2010 +