streams 3.3.1 → 3.3.2
raw patch · 13 files changed
+2257/−2246 lines, 13 filesdep ~semigroupoidssetup-changed
Dependency ranges changed: semigroupoids
Files
- .gitignore +32/−32
- .vim.custom +31/−31
- CHANGELOG.markdown +59/−55
- LICENSE +33/−33
- README +42/−42
- Setup.lhs +7/−7
- src/Data/Stream/Future.hs +167/−166
- src/Data/Stream/Future/Skew.hs +441/−441
- src/Data/Stream/Infinite.hs +467/−463
- src/Data/Stream/Infinite/Functional/Zipper.hs +336/−334
- src/Data/Stream/Infinite/Skew.hs +348/−348
- src/Data/Stream/Supply.hs +184/−184
- streams.cabal +110/−110
.gitignore view
@@ -1,32 +1,32 @@-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.* +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.*
.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,55 +1,59 @@-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 +3.3.2 [2023.03.12]+------------------+* Support building with `semigroupoids-6`.++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,166 +1,167 @@-{-# 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 +{-# 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 where+ foldMap1 = foldMap1Default++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,441 +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 -#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 +{-# 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,463 +1,467 @@-{-# 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 +{-# 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+ , head -- :: Stream a -> a+ , 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+ ( 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, 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.Traversable+#endif+import Data.Foldable hiding (concat)+import Data.Distributive+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+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 where+ foldMap1 f (a :> as) = f a <> foldMap1 f as++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,334 +1,336 @@-{-# 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" - --} +{-# 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+ )++#if !(MIN_VERSION_base(4,18,0))+import Control.Applicative+#endif+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,348 +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) -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 - +{-# 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,184 +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 -#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) +{-# 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,110 +1,110 @@-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 - +name: streams+category: Control, Comonads+version: 3.3.2+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 && < 7++ 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+