diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,8 +1,140 @@ # Changelog +## 0.3.1 (May 2026) + +* Fixed `Path.fromString` truncation when unicode chars are present. +* Fixed `DirIO.followSymlinks` option not working correctly on macOS. + +## 0.3.0 (Sep 2025) + +See [0.2.2-0.3.0 API Changelog](/core/docs/ApiChangelogs/0.2.2-0.3.0.txt) for a +full list of deprecations, additions, and changes to the function signatures. + +### Enhancements + +* Added APIs for prompt cleanup of resources, allowing guaranteed + cleanup as an alternative to GC-based cleanup. +* Added operations for fair nesting of inner and outer streams for + exploring them equally, generally useful but especially useful for logic + programming use cases. +* Introduced `Streamly.Data.Scanl` with a new `Scanl` type. Scans can + split a stream into multiple streams, process them independently, and + merge the results. The `Fold` type is now split into `Fold` and `Scanl`. +* Added `RingArray` module for high-performance, unboxed circular buffers. +* Added `Streamly.FileSystem.Path` module with a `Path` type for flexibly typed + file system paths. +* Added `Streamly.FileSystem.DirIO` and `Streamly.FileSystem.FileIO` to replace + the deprecated `Streamly.FileSystem.Dir` and `Streamly.FileSystem.File`. The + new modules use Streamly’s native `Path` type instead of `FilePath`. `DirIO` + APIs take a `ReadOptions` argument, and its directory read APIs do not follow + symlinks by default. +* Removed `Storable` constraint from: + - `Streamly.Data.Stream.isInfixOf` + - `Streamly.Data.Array.writeLastN` + +### Deprecations + +Following APIs/modules are deprecated and renamed or replaced with new +APIs. + +* `Streamly.FileSystem.Dir`, `Streamly.FileSystem.File` have been replaced by + new modules. +* Renamed `writeN`-like APIs to `createOf`-like in Array modules. +* Renamed `new`-like APIs to `emptyOf`-like in Array modules. +* In the Fold module renamed `indexGeneric`, `lengthGeneric`, and `foldlM1'` to + `genericIndex`, `genericLength`, and `foldl1M'` respectively. + +### Internal API Changes + +* In `Streamly.Internal.Data.Parser`, constructors `Partial`, `Continue`, and + `Done` are deprecated and replaced with `SPartial`, `SContinue`, and `SDone`. + Migration steps: + * In parser step functions: + - `Partial n` -> `SPartial (1-n)` + - `Continue n` -> `SContinue (1-n)` + - `Done n` -> `SDone (1-n)` + - `Error` -> `SError` + * Extract function now returns `Parser.Final` (instead of `Parser.Step`): + - `Continue n` -> `FContinue (-n)` + - `Done n` -> `FDone (-n)` + - `Partial n` -> `FContinue (-n)` + - `Error` -> `FError` + * If `n` is used for decision-making, the logic must be updated accordingly. + See docs for details. +* Internal (mut)array functions now use explicit IO callbacks instead of lifted + callbacks. +* Removed `Storable` constraint from several ring buffer functions. +* Added `Streamly.Internal.Data.IORef` module exposing `IORef` and related + functions. + +## 0.2.2 (Jan 2024) + +* Add fixities `infixr 5` for `cons` and `consM` functions. +* Fix a bug in Array `Eq` instance when the type is a sum type with + differently sized constructors. +* lpackArraysChunksOf, compact, writeChunksWith, putChunksWith now take the + buffer size in number of array elements instead of bytes. + +## 0.2.1 (Dec 2023) + +* Make the serialization of the unit constructor deterministic. +* Expose `pinnedSerialize` & `deserialize` via `Streamly.Data.Array`. + +## 0.2.0 (Nov 2023) + +See [0.1.0-0.2.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/core/docs/ApiChangelogs/0.1.0-0.2.0.txt) +for a full list of API changes in this release. Only a few significant +changes are mentioned here. + +### Breaking Changes + +* `ParserK` in `Streamly.Data.ParserK` is not implicitly specialized + to arrays anymore. To adapt to the new code, change `ParserK a m + b` to `ParserK (Array a) m b` where the `Array` type comes from + `Streamly.Data.Array`. This change also affected the signatures of + `parseChunks` and `parseBreakChunks`. +* Changed the signature of 'Streamly.Data.Stream.handle' to make the + exception handler monadic. +* Behavior change: Exceptions are now rethrown promptly in `bracketIO`. + +### Enhancements + +* __Serialization__: Added a `Streamly.Data.MutByteArray` module with a + `Serialize` type class for fast binary serialization. The Data.Array + module supplies the `serialize` and `deserialize` operations for arrays. +* __Unpinned Arrays__: Unboxed arrays are now created unpinned by default, + they were created pinned earlier. During IO operations, unpinned arrays + are automatically copied to pinned memory. When arrays are directly + passed to IO operations programmers can choose to create them pinned to + avoid a copy. To create pinned arrays, use the internal APIs with the + `pinned*` prefix. +* StreamK now supports native exception handling routines (handle, bracketIO). + Earlier we had to convert it to the `Stream` type for exception handling. + +### Deprecations + +See [0.1.0-0.2.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/core/docs/ApiChangelogs/0.1.0-0.2.0.txt) +for a full list of deprecations. + +### Internal API Changes + +* Fold constructor has changed, added a `final` field to support + finalization and cleanup of a chain of folds. The `extract` field is + now used only for mapping the fold internal state to fold result for + scanning purposes. If your fold does not require cleanup you can just use + your existing `extract` function as `final` as well to adapt to this change. +* Many low level internal modules have been removed, they are entirely + exported from higher level internal modules. If you were importing any + of the missing low level modules then import the higher level modules instead. +* Internal module changes: + * Streamly.Internal.Serialize.FromBytes -> Streamly.Internal.Data.Binary.Parser + * Streamly.Internal.Serialize.ToBytes -> Streamly.Internal.Data.Binary.Stream + * Streamly.Internal.Data.Unbox is now exported via Streamly.Internal.Data.Serialize + * Streamly.Internal.Data.IORef.Unboxed is now exported via Streamly.Internal.Data.Serialize + ## 0.1.0 (March 2023) -Also see [streamly-core-0.1.0 API Changelog](/core/docs/ApiChangelogs/0.1.0.txt) or +Also see [streamly-core-0.1.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/core/docs/ApiChangelogs/0.1.0.txt) or https://hackage.haskell.org/package/streamly-core-0.1.0/docs/docs/ApiChangelogs/0.1.0.txt `streamly` package is split into two packages, (1) `streamly-core` that diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -279,3 +279,44 @@ 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. + +------------------------------------------------------------------------------- +th-utilities-0.2.5.0 (https://hackage.haskell.org/package/th-utilities) +------------------------------------------------------------------------------- +Copyright (c) 2016 FP Complete Corporation. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +------------------------------------------------------------------------------- +th-abstraction-0.5.0.0 (https://hackage.haskell.org/package/th-abstraction) +------------------------------------------------------------------------------- +Copyright (c) 2017-2020 Eric Mertens + +Permission to use, copy, modify, and/or distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright notice +and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,11 +1,11 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.71 for streamly-core 0.1.0. +# Generated by GNU Autoconf 2.72 for streamly-core 0.3.1. # # Report bugs to . # # -# Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation, +# Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, # Inc. # # @@ -17,7 +17,6 @@ # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh -as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh @@ -26,12 +25,13 @@ # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST -else $as_nop - case `(set -o) 2>/dev/null` in #( +else case e in #( + e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; +esac ;; esac fi @@ -103,7 +103,7 @@ ;; esac -# We did not find ourselves, most probably we were run as `sh COMMAND' +# We did not find ourselves, most probably we were run as 'sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 @@ -133,15 +133,14 @@ esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. +# out after a failed 'exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="as_nop=: -if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 + as_bourne_compatible="if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: @@ -149,12 +148,13 @@ # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST -else \$as_nop - case \`(set -o) 2>/dev/null\` in #( +else case e in #( + e) case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; +esac ;; esac fi " @@ -172,8 +172,9 @@ if ( set x; as_fn_ret_success y && test x = \"\$1\" ) then : -else \$as_nop - exitcode=1; echo positional parameters were not saved. +else case e in #( + e) exitcode=1; echo positional parameters were not saved. ;; +esac fi test x\$exitcode = x0 || exit 1 blah=\$(echo \$(echo blah)) @@ -186,14 +187,15 @@ if (eval "$as_required") 2>/dev/null then : as_have_required=yes -else $as_nop - as_have_required=no +else case e in #( + e) as_have_required=no ;; +esac fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : -else $as_nop - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +else case e in #( + e) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do @@ -226,12 +228,13 @@ if $as_found then : -else $as_nop - if { test -f "$SHELL" || test -f "$SHELL.exe"; } && +else case e in #( + e) if { test -f "$SHELL" || test -f "$SHELL.exe"; } && as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$SHELL as_have_required=yes -fi +fi ;; +esac fi @@ -253,7 +256,7 @@ esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. +# out after a failed 'exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi @@ -273,7 +276,8 @@ $0: under such a shell if you do have one." fi exit 1 -fi +fi ;; +esac fi fi SHELL=${CONFIG_SHELL-/bin/sh} @@ -312,14 +316,6 @@ as_fn_set_status $1 exit $1 } # as_fn_exit -# as_fn_nop -# --------- -# Do nothing but, unlike ":", preserve the value of $?. -as_fn_nop () -{ - return $? -} -as_nop=as_fn_nop # as_fn_mkdir_p # ------------- @@ -388,11 +384,12 @@ { eval $1+=\$2 }' -else $as_nop - as_fn_append () +else case e in #( + e) as_fn_append () { eval $1=\$$1\$2 - } + } ;; +esac fi # as_fn_append # as_fn_arith ARG... @@ -406,21 +403,14 @@ { as_val=$(( $* )) }' -else $as_nop - as_fn_arith () +else case e in #( + e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` - } + } ;; +esac fi # as_fn_arith -# as_fn_nop -# --------- -# Do nothing but, unlike ":", preserve the value of $?. -as_fn_nop () -{ - return $? -} -as_nop=as_fn_nop # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- @@ -494,6 +484,8 @@ /[$]LINENO/= ' <$as_myself | sed ' + t clear + :clear s/[$]LINENO.*/&-/ t lineno b @@ -542,7 +534,6 @@ as_echo='printf %s\n' as_echo_n='printf %s' - rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file @@ -554,9 +545,9 @@ if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. + # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. + # In both cases, we have to default to 'cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then @@ -581,10 +572,12 @@ as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" +as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" +as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" +as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" +as_tr_sh="eval sed '$as_sed_sh'" # deprecated test -n "$DJDIR" || exec 7<&0 /dev/null && - as_fn_error $? "invalid feature name: \`$ac_useropt'" + as_fn_error $? "invalid feature name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -842,7 +835,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: \`$ac_useropt'" + as_fn_error $? "invalid feature name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1055,7 +1048,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: \`$ac_useropt'" + as_fn_error $? "invalid package name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1071,7 +1064,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: \`$ac_useropt'" + as_fn_error $? "invalid package name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1101,8 +1094,8 @@ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" + -*) as_fn_error $? "unrecognized option: '$ac_option' +Try '$0 --help' for more information" ;; *=*) @@ -1110,7 +1103,7 @@ # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + as_fn_error $? "invalid variable name: '$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; @@ -1160,7 +1153,7 @@ as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done -# There might be people who depend on the old broken behavior: `$host' +# There might be people who depend on the old broken behavior: '$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias @@ -1228,7 +1221,7 @@ test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_msg="sources are in $srcdir, but 'cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` @@ -1256,7 +1249,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures streamly-core 0.1.0 to adapt to many kinds of systems. +'configure' configures streamly-core 0.3.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1270,11 +1263,11 @@ --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages + -q, --quiet, --silent do not print 'checking ...' messages --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' + -C, --config-cache alias for '--cache-file=config.cache' -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or \`..'] + --srcdir=DIR find the sources in DIR [configure dir or '..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX @@ -1282,10 +1275,10 @@ --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] -By default, \`make install' will install all the files in -\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify -an installation prefix other than \`$ac_default_prefix' using \`--prefix', -for instance \`--prefix=\$HOME'. +By default, 'make install' will install all the files in +'$ac_default_prefix/bin', '$ac_default_prefix/lib' etc. You can specify +an installation prefix other than '$ac_default_prefix' using '--prefix', +for instance '--prefix=\$HOME'. For better control, use the options below. @@ -1318,7 +1311,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of streamly-core 0.1.0:";; + short | recursive ) echo "Configuration of streamly-core 0.3.1:";; esac cat <<\_ACEOF @@ -1336,7 +1329,7 @@ CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory -Use these variables to override the choices made by `configure' or to help +Use these variables to override the choices made by 'configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to . @@ -1404,10 +1397,10 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -streamly-core configure 0.1.0 -generated by GNU Autoconf 2.71 +streamly-core configure 0.3.1 +generated by GNU Autoconf 2.72 -Copyright (C) 2021 Free Software Foundation, Inc. +Copyright (C) 2023 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF @@ -1446,11 +1439,12 @@ } && test -s conftest.$ac_objext then : ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 +else case e in #( + e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_retval=1 + ac_retval=1 ;; +esac fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval @@ -1469,8 +1463,8 @@ if eval test \${$3+y} then : printf %s "(cached) " >&6 -else $as_nop - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else case e in #( + e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> @@ -1478,10 +1472,12 @@ if ac_fn_c_try_compile "$LINENO" then : eval "$3=yes" -else $as_nop - eval "$3=no" +else case e in #( + e) eval "$3=no" ;; +esac fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; +esac fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -1521,11 +1517,12 @@ } then : ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 +else case e in #( + e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_retval=1 + ac_retval=1 ;; +esac fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would @@ -1548,15 +1545,15 @@ if eval test \${$3+y} then : printf %s "(cached) " >&6 -else $as_nop - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else case e in #( + e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Define $2 to an innocuous variant, in case declares $2. For example, HP-UX 11i declares gettimeofday. */ #define $2 innocuous_$2 /* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $2 (); below. */ + which can conflict with char $2 (void); below. */ #include #undef $2 @@ -1567,7 +1564,7 @@ #ifdef __cplusplus extern "C" #endif -char $2 (); +char $2 (void); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ @@ -1586,11 +1583,13 @@ if ac_fn_c_try_link "$LINENO" then : eval "$3=yes" -else $as_nop - eval "$3=no" +else case e in #( + e) eval "$3=no" ;; +esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext + conftest$ac_exeext conftest.$ac_ext ;; +esac fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -1622,8 +1621,8 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by streamly-core $as_me 0.1.0, which was -generated by GNU Autoconf 2.71. Invocation command line was +It was created by streamly-core $as_me 0.3.1, which was +generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw @@ -1869,10 +1868,10 @@ printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ - || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} + || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } +See 'config.log' for more details" "$LINENO" 5; } fi done @@ -1908,9 +1907,7 @@ /* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ struct buf { int x; }; struct buf * (*rcsopen) (struct buf *, struct stat *, int); -static char *e (p, i) - char **p; - int i; +static char *e (char **p, int i) { return p[i]; } @@ -1924,6 +1921,21 @@ return s; } +/* C89 style stringification. */ +#define noexpand_stringify(a) #a +const char *stringified = noexpand_stringify(arbitrary+token=sequence); + +/* C89 style token pasting. Exercises some of the corner cases that + e.g. old MSVC gets wrong, but not very hard. */ +#define noexpand_concat(a,b) a##b +#define expand_concat(a,b) noexpand_concat(a,b) +extern int vA; +extern int vbee; +#define aye A +#define bee B +int *pvA = &expand_concat(v,aye); +int *pvbee = &noexpand_concat(v,bee); + /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not \xHH hex character constants. These do not provoke an error unfortunately, instead are silently treated @@ -1951,16 +1963,19 @@ # Test code for whether the C compiler supports C99 (global declarations) ac_c_conftest_c99_globals=' -// Does the compiler advertise C99 conformance? +/* Does the compiler advertise C99 conformance? */ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L # error "Compiler does not advertise C99 conformance" #endif +// See if C++-style comments work. + #include extern int puts (const char *); extern int printf (const char *, ...); extern int dprintf (int, const char *, ...); extern void *malloc (size_t); +extern void free (void *); // Check varargs macros. These examples are taken from C99 6.10.3.5. // dprintf is used instead of fprintf to avoid needing to declare @@ -2010,7 +2025,6 @@ static inline int test_restrict (ccp restrict text) { - // See if C++-style comments work. // Iterate through items via the restricted pointer. // Also check for declarations in for loops. for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) @@ -2076,6 +2090,8 @@ ia->datasize = 10; for (int i = 0; i < ia->datasize; ++i) ia->data[i] = i * 1.234; + // Work around memory leak warnings. + free (ia); // Check named initializers. struct named_init ni = { @@ -2097,7 +2113,7 @@ # Test code for whether the C compiler supports C11 (global declarations) ac_c_conftest_c11_globals=' -// Does the compiler advertise C11 conformance? +/* Does the compiler advertise C11 conformance? */ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L # error "Compiler does not advertise C11 conformance" #endif @@ -2220,12 +2236,12 @@ eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&5 +printf "%s\n" "$as_me: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was not set in the previous run" >&5 +printf "%s\n" "$as_me: error: '$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) @@ -2234,18 +2250,18 @@ ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' has changed since the previous run:" >&5 +printf "%s\n" "$as_me: error: '$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&5 +printf "%s\n" "$as_me: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;} - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: '$ac_old_val'" >&5 +printf "%s\n" "$as_me: former value: '$ac_old_val'" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: '$ac_new_val'" >&5 +printf "%s\n" "$as_me: current value: '$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. @@ -2261,11 +2277,11 @@ fi done if $ac_cache_corrupted; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file' + as_fn_error $? "run '${MAKE-make} distclean' and/or 'rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## @@ -2312,8 +2328,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2335,7 +2351,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2357,8 +2374,8 @@ if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_CC"; then +else case e in #( + e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2380,7 +2397,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then @@ -2415,8 +2433,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2438,7 +2456,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2460,8 +2479,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no @@ -2500,7 +2519,8 @@ ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" fi fi -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2524,8 +2544,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2547,7 +2567,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2573,8 +2594,8 @@ if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_CC"; then +else case e in #( + e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2596,7 +2617,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then @@ -2634,8 +2656,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2657,7 +2679,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2679,8 +2702,8 @@ if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_CC"; then +else case e in #( + e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2702,7 +2725,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then @@ -2731,10 +2755,10 @@ fi -test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH -See \`config.log' for more details" "$LINENO" 5; } +See 'config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 @@ -2806,8 +2830,8 @@ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : - # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. -# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' + # Autoconf-2.13 could set the ac_cv_exeext variable to 'no'. +# So ignore a value of 'no', otherwise this would lead to 'EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. @@ -2827,7 +2851,7 @@ ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not - # safe: cross compilers may not add the suffix if given an `-o' + # safe: cross compilers may not add the suffix if given an '-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. @@ -2838,8 +2862,9 @@ done test "$ac_cv_exeext" = no && ac_cv_exeext= -else $as_nop - ac_file='' +else case e in #( + e) ac_file='' ;; +esac fi if test -z "$ac_file" then : @@ -2848,13 +2873,14 @@ printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -printf "%s\n" "yes" >&6; } +See 'config.log' for more details" "$LINENO" 5; } +else case e in #( + e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } ;; +esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 printf %s "checking for C compiler default output file name... " >&6; } @@ -2878,10 +2904,10 @@ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : - # If both `conftest.exe' and `conftest' are `present' (well, observable) -# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will -# work properly (i.e., refer to `conftest.exe'), while it won't with -# `rm'. + # If both 'conftest.exe' and 'conftest' are 'present' (well, observable) +# catch 'conftest.exe'. For instance with Cygwin, 'ls conftest' will +# work properly (i.e., refer to 'conftest.exe'), while it won't with +# 'rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in @@ -2891,11 +2917,12 @@ * ) break;; esac done -else $as_nop - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +else case e in #( + e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details" "$LINENO" 5; } +See 'config.log' for more details" "$LINENO" 5; } ;; +esac fi rm -f conftest conftest$ac_cv_exeext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 @@ -2911,6 +2938,8 @@ main (void) { FILE *f = fopen ("conftest.out", "w"); + if (!f) + return 1; return ferror (f) || fclose (f) != 0; ; @@ -2950,26 +2979,27 @@ if test "$cross_compiling" = maybe; then cross_compiling=yes else - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "cannot run C compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details" "$LINENO" 5; } +If you meant to cross compile, use '--host'. +See 'config.log' for more details" "$LINENO" 5; } fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 printf "%s\n" "$cross_compiling" >&6; } -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +rm -f conftest.$ac_ext conftest$ac_cv_exeext \ + conftest.o conftest.obj conftest.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 printf %s "checking for suffix of object files... " >&6; } if test ${ac_cv_objext+y} then : printf %s "(cached) " >&6 -else $as_nop - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else case e in #( + e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -3001,16 +3031,18 @@ break;; esac done -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 +else case e in #( + e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile -See \`config.log' for more details" "$LINENO" 5; } +See 'config.log' for more details" "$LINENO" 5; } ;; +esac fi -rm -f conftest.$ac_cv_objext conftest.$ac_ext +rm -f conftest.$ac_cv_objext conftest.$ac_ext ;; +esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 printf "%s\n" "$ac_cv_objext" >&6; } @@ -3021,8 +3053,8 @@ if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 -else $as_nop - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else case e in #( + e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -3039,12 +3071,14 @@ if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes -else $as_nop - ac_compiler_gnu=no +else case e in #( + e) ac_compiler_gnu=no ;; +esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu - + ;; +esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } @@ -3062,8 +3096,8 @@ if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 -else $as_nop - ac_save_c_werror_flag=$ac_c_werror_flag +else case e in #( + e) ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" @@ -3081,8 +3115,8 @@ if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes -else $as_nop - CFLAGS="" +else case e in #( + e) CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -3097,8 +3131,8 @@ if ac_fn_c_try_compile "$LINENO" then : -else $as_nop - ac_c_werror_flag=$ac_save_c_werror_flag +else case e in #( + e) ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -3115,12 +3149,15 @@ then : ac_cv_prog_cc_g=yes fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; +esac fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; +esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - ac_c_werror_flag=$ac_save_c_werror_flag + ac_c_werror_flag=$ac_save_c_werror_flag ;; +esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } @@ -3147,8 +3184,8 @@ if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 -else $as_nop - ac_cv_prog_cc_c11=no +else case e in #( + e) ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -3165,25 +3202,28 @@ test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext -CC=$ac_save_CC +CC=$ac_save_CC ;; +esac fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } -else $as_nop - if test "x$ac_cv_prog_cc_c11" = x +else case e in #( + e) if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 +else case e in #( + e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } - CC="$CC $ac_cv_prog_cc_c11" + CC="$CC $ac_cv_prog_cc_c11" ;; +esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 - ac_prog_cc_stdc=c11 + ac_prog_cc_stdc=c11 ;; +esac fi fi if test x$ac_prog_cc_stdc = xno @@ -3193,8 +3233,8 @@ if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 -else $as_nop - ac_cv_prog_cc_c99=no +else case e in #( + e) ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -3211,25 +3251,28 @@ test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext -CC=$ac_save_CC +CC=$ac_save_CC ;; +esac fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } -else $as_nop - if test "x$ac_cv_prog_cc_c99" = x +else case e in #( + e) if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 +else case e in #( + e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } - CC="$CC $ac_cv_prog_cc_c99" + CC="$CC $ac_cv_prog_cc_c99" ;; +esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 - ac_prog_cc_stdc=c99 + ac_prog_cc_stdc=c99 ;; +esac fi fi if test x$ac_prog_cc_stdc = xno @@ -3239,8 +3282,8 @@ if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 -else $as_nop - ac_cv_prog_cc_c89=no +else case e in #( + e) ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -3257,25 +3300,28 @@ test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext -CC=$ac_save_CC +CC=$ac_save_CC ;; +esac fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } -else $as_nop - if test "x$ac_cv_prog_cc_c89" = x +else case e in #( + e) if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +else case e in #( + e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } - CC="$CC $ac_cv_prog_cc_c89" + CC="$CC $ac_cv_prog_cc_c89" ;; +esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 - ac_prog_cc_stdc=c89 + ac_prog_cc_stdc=c89 ;; +esac fi fi @@ -3343,8 +3389,8 @@ # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # -# `ac_cv_env_foo' variables (set or unset) will be overridden when -# loading this file, other *unset* `ac_cv_foo' will be assigned the +# 'ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* 'ac_cv_foo' will be assigned the # following values. _ACEOF @@ -3374,14 +3420,14 @@ (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes: double-quote + # 'set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) - # `set' quotes correctly as required by POSIX, so do not add quotes. + # 'set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | @@ -3471,7 +3517,6 @@ # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh -as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh @@ -3480,12 +3525,13 @@ # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST -else $as_nop - case `(set -o) 2>/dev/null` in #( +else case e in #( + e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; +esac ;; esac fi @@ -3557,7 +3603,7 @@ ;; esac -# We did not find ourselves, most probably we were run as `sh COMMAND' +# We did not find ourselves, most probably we were run as 'sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 @@ -3586,7 +3632,6 @@ } # as_fn_error - # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. @@ -3626,11 +3671,12 @@ { eval $1+=\$2 }' -else $as_nop - as_fn_append () +else case e in #( + e) as_fn_append () { eval $1=\$$1\$2 - } + } ;; +esac fi # as_fn_append # as_fn_arith ARG... @@ -3644,11 +3690,12 @@ { as_val=$(( $* )) }' -else $as_nop - as_fn_arith () +else case e in #( + e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` - } + } ;; +esac fi # as_fn_arith @@ -3731,9 +3778,9 @@ if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. + # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. + # In both cases, we have to default to 'cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then @@ -3814,10 +3861,12 @@ as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" +as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" +as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" +as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" +as_tr_sh="eval sed '$as_sed_sh'" # deprecated exec 6>&1 @@ -3832,8 +3881,8 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by streamly-core $as_me 0.1.0, which was -generated by GNU Autoconf 2.71. Invocation command line was +This file was extended by streamly-core $as_me 0.3.1, which was +generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS @@ -3860,7 +3909,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ -\`$as_me' instantiates files and other configuration actions +'$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. @@ -3888,11 +3937,11 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -streamly-core config.status 0.1.0 -configured by $0, generated by GNU Autoconf 2.71, +streamly-core config.status 0.3.1 +configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" -Copyright (C) 2021 Free Software Foundation, Inc. +Copyright (C) 2023 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -3943,8 +3992,8 @@ ac_need_defaults=false;; --he | --h) # Conflict between --help and --header - as_fn_error $? "ambiguous option: \`$1' -Try \`$0 --help' for more information.";; + as_fn_error $? "ambiguous option: '$1' +Try '$0 --help' for more information.";; --help | --hel | -h ) printf "%s\n" "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ @@ -3952,8 +4001,8 @@ ac_cs_silent=: ;; # This is an error. - -*) as_fn_error $? "unrecognized option: \`$1' -Try \`$0 --help' for more information." ;; + -*) as_fn_error $? "unrecognized option: '$1' +Try '$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; @@ -4003,7 +4052,7 @@ case $ac_config_target in "src/config.h") CONFIG_HEADERS="$CONFIG_HEADERS src/config.h" ;; - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + *) as_fn_error $? "invalid argument: '$ac_config_target'" "$LINENO" 5;; esac done @@ -4021,7 +4070,7 @@ # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to `$tmp'. +# after its creation but before its name has been assigned to '$tmp'. $debug || { tmp= ac_tmp= @@ -4045,13 +4094,13 @@ # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. -# This happens for instance with `./config.status Makefile'. +# This happens for instance with './config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF -# Transform confdefs.h into an awk script `defines.awk', embedded as +# Transform confdefs.h into an awk script 'defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. @@ -4161,7 +4210,7 @@ esac case $ac_mode$ac_tag in :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :L* | :C*:*) as_fn_error $? "invalid tag '$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac @@ -4183,19 +4232,19 @@ -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain `:'. + # because $ac_f cannot contain ':'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + as_fn_error 1 "cannot find input file: '$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done - # Let's still pretend it is `configure' which instantiates (i.e., don't + # Let's still pretend it is 'configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -3,7 +3,7 @@ # See https://www.gnu.org/software/autoconf/manual/autoconf.html for help on # the macros used in this file. -AC_INIT([streamly-core], [0.1.0], [streamly@composewell.com], [streamly-core], [https://streamly.composewell.com]) +AC_INIT([streamly-core], [0.3.1], [streamly@composewell.com], [streamly-core], [https://streamly.composewell.com]) # To suppress "WARNING: unrecognized options: --with-compiler" AC_ARG_WITH([compiler], [GHC]) diff --git a/docs/ApiChangelogs/0.1.0-0.2.0.txt b/docs/ApiChangelogs/0.1.0-0.2.0.txt new file mode 100644 --- /dev/null +++ b/docs/ApiChangelogs/0.1.0-0.2.0.txt @@ -0,0 +1,1471 @@ +--------------------------------- +API Annotations +--------------------------------- + +[A] : Added +[R] : Removed +[C] : Changed +[O] : Old definition +[N] : New definition +[D] : Deprecated + +--------------------------------- +API diff +--------------------------------- + +[C] Streamly.Unicode.Parser + [A] double :: Monad m => Parser Char m Double +[C] Streamly.FileSystem.Handle + [A] readWith :: MonadIO m => Int -> Handle -> Stream m Word8 + [A] readChunksWith :: MonadIO m => Int -> Handle -> Stream m (Array Word8) +[C] Streamly.FileSystem.Dir + [C] readEither + [O] readEither :: MonadIO m => FilePath -> Stream m (Either FilePath FilePath) + [N] readEither :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Either FilePath FilePath) + [C] read + [O] read :: MonadIO m => FilePath -> Stream m FilePath + [N] read :: (MonadIO m, MonadCatch m) => FilePath -> Stream m FilePath +[C] Streamly.Data.Unfold + [A] class Enum a => Enumerable a + [A] second :: b -> Unfold m (a, b) c -> Unfold m a c + [A] first :: a -> Unfold m (a, b) c -> Unfold m b c + [A] enumerateFromTo :: (Enumerable a, Monad m) => Unfold m (a, a) a + [A] enumerateFromThenTo :: (Enumerable a, Monad m) => Unfold m (a, a, a) a + [A] enumerateFromThen :: (Enumerable a, Monad m) => Unfold m (a, a) a + [A] enumerateFrom :: (Enumerable a, Monad m) => Unfold m a a +[C] Streamly.Data.StreamK + [C] parseChunks + [O] parseChunks :: (Monad m, Unbox a) => ParserK a m b -> StreamK m (Array a) -> m (Either ParseError b) + [N] parseChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [C] parseBreakChunks + [O] parseBreakChunks :: (Monad m, Unbox a) => ParserK a m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [N] parseBreakChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] parseBreak :: forall m a b. Monad m => ParserK a m b -> StreamK m a -> m (Either ParseError b, StreamK m a) + [A] parse :: Monad m => ParserK a m b -> StreamK m a -> m (Either ParseError b) + [A] handle :: (MonadCatch m, Exception e) => (e -> m (StreamK m a)) -> StreamK m a -> StreamK m a + [A] bracketIO :: (MonadIO m, MonadCatch m) => IO b -> (b -> IO c) -> (b -> StreamK m a) -> StreamK m a +[C] Streamly.Data.Stream + [A] wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] splitOn :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [C] handle + [O] handle :: (MonadCatch m, Exception e) => (e -> Stream m a) -> Stream m a -> Stream m a + [N] handle :: (MonadCatch m, Exception e) => (e -> m (Stream m a)) -> Stream m a -> Stream m a + [A] groupsOf :: Monad m => Int -> Fold m a b -> Stream m a -> Stream m b +[C] Streamly.Data.ParserK + [D] fromParser :: (MonadIO m, Unbox a) => Parser a m b -> ParserK (Array a) m b + [D] fromFold :: (MonadIO m, Unbox a) => Fold m a b -> ParserK (Array a) m b + [A] adaptCG :: Monad m => Parser a m b -> ParserK (Array a) m b + [A] adaptC :: (Monad m, Unbox a) => Parser a m b -> ParserK (Array a) m b + [A] adapt :: Monad m => Parser a m b -> ParserK a m b +[C] Streamly.Data.Parser + [A] groupByRollingEither :: Monad m => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (Either b c) + [A] groupByRolling :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser a m b +[A] Streamly.Data.MutByteArray + [A] class Unbox a + [A] class Serialize a + [A] SerializeConfig + [A] MutByteArray + [A] unpin :: MutByteArray -> IO MutByteArray + [A] sizeOf :: (Unbox a, SizeOfRep (Rep a)) => Proxy a -> Int + [A] serializeAt :: Serialize a => Int -> MutByteArray -> a -> IO Int + [A] pokeAt :: (Unbox a, Generic a, PokeRep (Rep a)) => Int -> MutByteArray -> a -> IO () + [A] pinnedNew :: Int -> IO MutByteArray + [A] pin :: MutByteArray -> IO MutByteArray + [A] peekAt :: (Unbox a, Generic a, PeekRep (Rep a)) => Int -> MutByteArray -> IO a + [A] new :: Int -> IO MutByteArray + [A] isPinned :: MutByteArray -> Bool + [A] inlineSerializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig + [A] inlineDeserializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig + [A] inlineAddSizeTo :: Maybe Inline -> SerializeConfig -> SerializeConfig + [A] deserializeAt :: Serialize a => Int -> MutByteArray -> Int -> IO (Int, a) + [A] deriveUnbox :: Q [Dec] -> Q [Dec] + [A] deriveSerializeWith :: (SerializeConfig -> SerializeConfig) -> Q [Dec] -> Q [Dec] + [A] deriveSerialize :: Q [Dec] -> Q [Dec] + [A] addSizeTo :: Serialize a => Int -> a -> Int +[C] Streamly.Data.MutArray.Generic + [A] write :: MonadIO m => Fold m a (MutArray a) + [A] readRev :: MonadIO m => MutArray a -> Stream m a + [A] read :: MonadIO m => MutArray a -> Stream m a + [A] putIndexUnsafe :: forall m a. MonadIO m => Int -> MutArray a -> a -> m () + [A] modifyIndexUnsafe :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] length :: MutArray a -> Int + [A] getIndexUnsafe :: MonadIO m => Int -> MutArray a -> m a + [C] getIndex + [O] getIndex :: MonadIO m => Int -> MutArray a -> m a + [N] getIndex :: MonadIO m => Int -> MutArray a -> m (Maybe a) + [A] fromListN :: MonadIO m => Int -> [a] -> m (MutArray a) + [A] fromList :: MonadIO m => [a] -> m (MutArray a) +[C] Streamly.Data.MutArray + [A] unpin :: MutArray a -> IO (MutArray a) + [A] readRev :: forall m a. (MonadIO m, Unbox a) => MutArray a -> Stream m a + [A] read :: forall m a. (MonadIO m, Unbox a) => MutArray a -> Stream m a + [A] putIndexUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () + [D] pokeByteIndex :: Unbox a => Int -> MutByteArray -> a -> IO () + [A] pokeAt :: (Unbox a, Generic a, PokeRep (Rep a)) => Int -> MutByteArray -> a -> IO () + [A] pinnedNew :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] pin :: MutArray a -> IO (MutArray a) + [D] peekByteIndex :: Unbox a => Int -> MutByteArray -> IO a + [A] peekAt :: (Unbox a, Generic a, PeekRep (Rep a)) => Int -> MutByteArray -> IO a + [D] newPinned :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] modifyIndexUnsafe :: forall m a b. (MonadIO m, Unbox a) => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] modifyIndex :: forall m a b. (MonadIO m, Unbox a) => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] modify :: forall m a. (MonadIO m, Unbox a) => MutArray a -> (a -> a) -> m () + [A] isPinned :: MutArray a -> Bool + [A] getIndexUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [C] getIndex + [O] getIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [N] getIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (Maybe a) +[C] Streamly.Data.Array.Generic + [A] toList :: Array a -> [a] + [A] getIndex :: Int -> Array a -> Maybe a +[C] Streamly.Data.Array + [A] unpin :: Array a -> IO (Array a) + [D] pokeByteIndex :: Unbox a => Int -> MutByteArray -> a -> IO () + [A] pokeAt :: (Unbox a, Generic a, PokeRep (Rep a)) => Int -> MutByteArray -> a -> IO () + [A] pin :: Array a -> IO (Array a) + [D] peekByteIndex :: Unbox a => Int -> MutByteArray -> IO a + [A] peekAt :: (Unbox a, Generic a, PeekRep (Rep a)) => Int -> MutByteArray -> IO a + [A] isPinned :: Array a -> Bool +[C] Streamly.Console.Stdio + +--------------------------------- +Internal API diff +--------------------------------- + +[C] Streamly.Internal.Unicode.Stream + [C] writeCharUtf8' + [O] writeCharUtf8' :: Monad m => Fold m Word8 Char + [N] writeCharUtf8' :: Monad m => Parser Word8 m Char +[C] Streamly.Internal.Unicode.Parser + [A] number :: Monad m => Parser Char m (Integer, Int) + [A] mkDouble :: Integer -> Int -> Double + [A] doubleParser :: Monad m => Parser Char m (Int, Int) + [C] double + [O] double :: Parser Char m Double + [N] double :: Monad m => Parser Char m Double +[R] Streamly.Internal.Serialize.ToBytes +[R] Streamly.Internal.Serialize.FromBytes +[C] Streamly.Internal.FileSystem.File + [A] writeAppendWith :: (MonadIO m, MonadCatch m) => Int -> FilePath -> Stream m Word8 -> m () + [A] writeAppendChunks :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array a) -> m () + [A] writeAppendArray :: FilePath -> Array a -> IO () + [A] writeAppend :: (MonadIO m, MonadCatch m) => FilePath -> Stream m Word8 -> m () + [R] appendWith :: (MonadIO m, MonadCatch m) => Int -> FilePath -> Stream m Word8 -> m () + [R] appendChunks :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array a) -> m () + [R] appendArray :: FilePath -> Array a -> IO () + [R] append :: (MonadIO m, MonadCatch m) => FilePath -> Stream m Word8 -> m () +[C] Streamly.Internal.FileSystem.Dir + [C] reader + [O] reader :: MonadIO m => Unfold m FilePath FilePath + [N] reader :: (MonadIO m, MonadCatch m) => Unfold m FilePath FilePath + [C] readFiles + [O] readFiles :: MonadIO m => FilePath -> Stream m FilePath + [N] readFiles :: (MonadIO m, MonadCatch m) => FilePath -> Stream m FilePath + [C] readEitherPaths + [O] readEitherPaths :: MonadIO m => FilePath -> Stream m (Either FilePath FilePath) + [N] readEitherPaths :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Either FilePath FilePath) + [C] readEither + [O] readEither :: MonadIO m => FilePath -> Stream m (Either FilePath FilePath) + [N] readEither :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Either FilePath FilePath) + [C] readDirs + [O] readDirs :: MonadIO m => FilePath -> Stream m FilePath + [N] readDirs :: (MonadIO m, MonadCatch m) => FilePath -> Stream m FilePath + [C] read + [O] read :: MonadIO m => FilePath -> Stream m FilePath + [N] read :: (MonadIO m, MonadCatch m) => FilePath -> Stream m FilePath + [C] fileReader + [O] fileReader :: MonadIO m => Unfold m FilePath FilePath + [N] fileReader :: (MonadIO m, MonadCatch m) => Unfold m FilePath FilePath + [C] eitherReaderPaths + [O] eitherReaderPaths :: MonadIO m => Unfold m FilePath (Either FilePath FilePath) + [N] eitherReaderPaths :: (MonadIO m, MonadCatch m) => Unfold m FilePath (Either FilePath FilePath) + [C] eitherReader + [O] eitherReader :: MonadIO m => Unfold m FilePath (Either FilePath FilePath) + [N] eitherReader :: (MonadIO m, MonadCatch m) => Unfold m FilePath (Either FilePath FilePath) + [C] dirReader + [O] dirReader :: MonadIO m => Unfold m FilePath FilePath + [N] dirReader :: (MonadIO m, MonadCatch m) => Unfold m FilePath FilePath +[R] Streamly.Internal.Data.Unfold.Type +[R] Streamly.Internal.Data.Unfold.Enumeration +[C] Streamly.Internal.Data.Unfold + [C] Unfold + [A] Unfold :: (s -> m (Step s b)) -> (a -> m s) -> Unfold m a b + [A] takeWhileMWithInput :: Monad m => (a -> b -> m Bool) -> Unfold m a b -> Unfold m a b + [A] manyInterleave :: Monad m => Unfold m a b -> Unfold m c a -> Unfold m c b + [A] enumerateFromStepIntegral :: (Monad m, Integral a) => Unfold m (a, a) a + [A] crossApplySnd :: Unfold m a b -> Unfold m a c -> Unfold m a c + [A] crossApplyFst :: Unfold m a b -> Unfold m a c -> Unfold m a b + [A] concatMap :: Monad m => (b -> Unfold m a c) -> Unfold m a b -> Unfold m a c +[R] Streamly.Internal.Data.Unboxed +[C] Streamly.Internal.Data.Time.Units + [R] Streamly.Internal.Data.Unboxed.Unbox + [A] Streamly.Internal.Data.Unbox.Unbox + [A] instance Streamly.Internal.Data.Unbox.Unbox Streamly.Internal.Data.Time.Units.NanoSecond64 + [A] instance Streamly.Internal.Data.Unbox.Unbox Streamly.Internal.Data.Time.Units.MilliSecond64 + [A] instance Streamly.Internal.Data.Unbox.Unbox Streamly.Internal.Data.Time.Units.MicroSecond64 +[R] Streamly.Internal.Data.Time.Clock.Type +[A] Streamly.Internal.Data.StreamK + [A] CrossStreamK + [A] (FixityR,6) + [A] (FixityR,6) + [A] (FixityR,6) + [A] (FixityR,5) + [A] (FixityR,5) + [A] (FixityR,6) + [A] (FixityR,5) + [A] StreamK + [A] MkStream :: (forall r. State StreamK m a -> (a -> StreamK m a -> m r) -> (a -> m r) -> m r -> m r) -> StreamK m a + [A] zipWithM :: Monad m => (a -> b -> m c) -> StreamK m a -> StreamK m b -> StreamK m c + [A] zipWith :: Monad m => (a -> b -> c) -> StreamK m a -> StreamK m b -> StreamK m c + [A] unfoldrMWith :: Monad m => (m a -> StreamK m a -> StreamK m a) -> (b -> m (Maybe (a, b))) -> b -> StreamK m a + [A] unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> StreamK m a + [A] unfoldr :: (b -> Maybe (a, b)) -> b -> StreamK m a + [A] uncons :: Applicative m => StreamK m a -> m (Maybe (a, StreamK m a)) + [A] unShare :: StreamK m a -> StreamK m a + [A] unCross :: CrossStreamK m a -> StreamK m a + [A] toStream :: Applicative m => StreamK m a -> Stream m a + [A] toList :: Monad m => StreamK m a -> m [a] + [A] the :: (Eq a, Monad m) => StreamK m a -> m (Maybe a) + [A] takeWhile :: (a -> Bool) -> StreamK m a -> StreamK m a + [A] take :: Int -> StreamK m a -> StreamK m a + [A] tail :: Applicative m => StreamK m a -> m (Maybe (StreamK m a)) + [A] sortBy :: Monad m => (a -> a -> Ordering) -> StreamK m a -> StreamK m a + [A] sequence :: Monad m => StreamK m (m a) -> StreamK m a + [A] scanlx' :: (x -> a -> x) -> x -> (x -> b) -> StreamK m a -> StreamK m b + [A] scanl' :: (b -> a -> b) -> b -> StreamK m a -> StreamK m b + [A] reverse :: StreamK m a -> StreamK m a + [A] replicateMWith :: (m a -> StreamK m a -> StreamK m a) -> Int -> m a -> StreamK m a + [A] replicateM :: Monad m => Int -> m a -> StreamK m a + [A] replicate :: Int -> a -> StreamK m a + [A] repeatMWith :: (m a -> t m a -> t m a) -> m a -> t m a + [A] repeatM :: Monad m => m a -> StreamK m a + [A] repeat :: a -> StreamK m a + [A] parseDBreak :: Monad m => Parser a m b -> StreamK m a -> m (Either ParseError b, StreamK m a) + [A] parseD :: Monad m => Parser a m b -> StreamK m a -> m (Either ParseError b) + [A] parseChunksGeneric :: Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [A] parseChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [A] parseBreakChunksGeneric :: forall m a b. Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] parseBreakChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] parseBreak :: forall m a b. Monad m => ParserK a m b -> StreamK m a -> m (Either ParseError b, StreamK m a) + [A] parse :: Monad m => ParserK a m b -> StreamK m a -> m (Either ParseError b) + [A] null :: Monad m => StreamK m a -> m Bool + [A] notElem :: (Monad m, Eq a) => a -> StreamK m a -> m Bool + [A] nilM :: Applicative m => m b -> StreamK m a + [A] nil :: StreamK m a + [A] mkStream :: (forall r. State StreamK m a -> (a -> StreamK m a -> m r) -> (a -> m r) -> m r -> m r) -> StreamK m a + [A] mkCross :: StreamK m a -> CrossStreamK m a + [A] minimumBy :: Monad m => (a -> a -> Ordering) -> StreamK m a -> m (Maybe a) + [A] minimum :: (Monad m, Ord a) => StreamK m a -> m (Maybe a) + [A] mfix :: Monad m => (m a -> StreamK m a) -> StreamK m a + [A] mergeMapWith :: (StreamK m b -> StreamK m b -> StreamK m b) -> (a -> StreamK m b) -> StreamK m a -> StreamK m b + [A] mergeIterateWith :: (StreamK m a -> StreamK m a -> StreamK m a) -> (a -> StreamK m a) -> StreamK m a -> StreamK m a + [A] mergeByM :: Monad m => (a -> a -> m Ordering) -> StreamK m a -> StreamK m a -> StreamK m a + [A] mergeBy :: (a -> a -> Ordering) -> StreamK m a -> StreamK m a -> StreamK m a + [A] maximumBy :: Monad m => (a -> a -> Ordering) -> StreamK m a -> m (Maybe a) + [A] maximum :: (Monad m, Ord a) => StreamK m a -> m (Maybe a) + [A] mapMaybe :: (a -> Maybe b) -> StreamK m a -> StreamK m b + [A] mapM_ :: Monad m => (a -> m b) -> StreamK m a -> m () + [A] mapMWith :: (m b -> StreamK m b -> StreamK m b) -> (a -> m b) -> StreamK m a -> StreamK m b + [A] mapMSerial :: Monad m => (a -> m b) -> StreamK m a -> StreamK m b + [A] mapM :: Monad m => (a -> m b) -> StreamK m a -> StreamK m b + [A] map :: (a -> b) -> StreamK m a -> StreamK m b + [A] lookup :: (Monad m, Eq a) => a -> StreamK m (a, b) -> m (Maybe b) + [A] liftInner :: (Monad m, MonadTrans t, Monad (t m)) => StreamK m a -> StreamK (t m) a + [A] last :: Monad m => StreamK m a -> m (Maybe a) + [A] iterateMWith :: Monad m => (m a -> StreamK m a -> StreamK m a) -> (a -> m a) -> m a -> StreamK m a + [A] iterateM :: Monad m => (a -> m a) -> m a -> StreamK m a + [A] iterate :: (a -> a) -> a -> StreamK m a + [A] intersperseM :: Monad m => m a -> StreamK m a -> StreamK m a + [A] intersperse :: Monad m => a -> StreamK m a -> StreamK m a + [A] interleaveMin :: StreamK m a -> StreamK m a -> StreamK m a + [A] interleaveFst :: StreamK m a -> StreamK m a -> StreamK m a + [A] interleave :: StreamK m a -> StreamK m a -> StreamK m a + [A] insertBy :: (a -> a -> Ordering) -> a -> StreamK m a -> StreamK m a + [A] init :: Applicative m => StreamK m a -> m (Maybe (StreamK m a)) + [A] hoist :: (Monad m, Monad n) => (forall x. m x -> n x) -> StreamK m a -> StreamK n a + [A] head :: Monad m => StreamK m a -> m (Maybe a) + [A] handle :: (MonadCatch m, Exception e) => (e -> m (StreamK m a)) -> StreamK m a -> StreamK m a + [A] fromYieldK :: YieldK m a -> StreamK m a + [A] fromStream :: Monad m => Stream m a -> StreamK m a + [A] fromStopK :: StopK m -> StreamK m a + [A] fromPure :: a -> StreamK m a + [A] fromList :: [a] -> StreamK m a + [A] fromIndicesMWith :: (m a -> StreamK m a -> StreamK m a) -> (Int -> m a) -> StreamK m a + [A] fromIndicesM :: Monad m => (Int -> m a) -> StreamK m a + [A] fromIndices :: (Int -> a) -> StreamK m a + [A] fromFoldableM :: (Foldable f, Monad m) => f (m a) -> StreamK m a + [A] fromFoldable :: Foldable f => f a -> StreamK m a + [A] fromEffect :: Monad m => m a -> StreamK m a + [A] foldrT :: (Monad m, Monad (s m), MonadTrans s) => (a -> s m b -> s m b) -> s m b -> StreamK m a -> s m b + [A] foldrSShared :: (a -> StreamK m b -> StreamK m b) -> StreamK m b -> StreamK m a -> StreamK m b + [A] foldrSM :: Monad m => (m a -> StreamK m b -> StreamK m b) -> StreamK m b -> StreamK m a -> StreamK m b + [A] foldrS :: (a -> StreamK m b -> StreamK m b) -> StreamK m b -> StreamK m a -> StreamK m b + [A] foldrM :: (a -> m b -> m b) -> m b -> StreamK m a -> m b + [A] foldr1 :: Monad m => (a -> a -> a) -> StreamK m a -> m (Maybe a) + [A] foldr :: Monad m => (a -> b -> b) -> b -> StreamK m a -> m b + [A] foldlx' :: forall m a b x. Monad m => (x -> a -> x) -> x -> (x -> b) -> StreamK m a -> m b + [A] foldlT :: (Monad m, Monad (s m), MonadTrans s) => (s m b -> a -> s m b) -> s m b -> StreamK m a -> s m b + [A] foldlS :: (StreamK m b -> a -> StreamK m b) -> StreamK m b -> StreamK m a -> StreamK m b + [A] foldlMx' :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> StreamK m a -> m b + [A] foldlM' :: Monad m => (b -> a -> m b) -> m b -> StreamK m a -> m b + [A] foldl' :: Monad m => (b -> a -> b) -> b -> StreamK m a -> m b + [A] foldStreamShared :: State StreamK m a -> (a -> StreamK m a -> m r) -> (a -> m r) -> m r -> StreamK m a -> m r + [A] foldStream :: State StreamK m a -> (a -> StreamK m a -> m r) -> (a -> m r) -> m r -> StreamK m a -> m r + [A] foldEither :: Monad m => Fold m a b -> StreamK m a -> m (Either (Fold m a b) (b, StreamK m a)) + [A] foldConcat :: Monad m => Producer m a b -> Fold m b c -> StreamK m a -> m (c, StreamK m a) + [A] foldBreak :: Monad m => Fold m a b -> StreamK m a -> m (b, StreamK m a) + [A] fold :: Monad m => Fold m a b -> StreamK m a -> m b + [A] findM :: Monad m => (a -> m Bool) -> StreamK m a -> m (Maybe a) + [A] findIndices :: (a -> Bool) -> StreamK m a -> StreamK m Int + [A] find :: Monad m => (a -> Bool) -> StreamK m a -> m (Maybe a) + [A] filter :: (a -> Bool) -> StreamK m a -> StreamK m a + [A] evalStateT :: Monad m => m s -> StreamK (StateT s m) a -> StreamK m a + [A] elem :: (Monad m, Eq a) => a -> StreamK m a -> m Bool + [A] dropWhile :: (a -> Bool) -> StreamK m a -> StreamK m a + [A] drop :: Int -> StreamK m a -> StreamK m a + [A] drain :: Monad m => StreamK m a -> m () + [A] deleteBy :: (a -> a -> Bool) -> a -> StreamK m a -> StreamK m a + [A] crossWith :: Monad m => (a -> b -> c) -> StreamK m a -> StreamK m b -> StreamK m c + [A] crossApplyWith :: (StreamK m b -> StreamK m b -> StreamK m b) -> StreamK m (a -> b) -> StreamK m a -> StreamK m b + [A] crossApplySnd :: StreamK m a -> StreamK m b -> StreamK m b + [A] crossApplyFst :: StreamK m a -> StreamK m b -> StreamK m a + [A] crossApply :: StreamK m (a -> b) -> StreamK m a -> StreamK m b + [A] cross :: Monad m => StreamK m a -> StreamK m b -> StreamK m (a, b) + [A] consMBy :: Monad m => (StreamK m a -> StreamK m a -> StreamK m a) -> m a -> StreamK m a -> StreamK m a + [A] consM :: Monad m => m a -> StreamK m a -> StreamK m a + [A] consK :: YieldK m a -> StreamK m a -> StreamK m a + [A] cons :: a -> StreamK m a -> StreamK m a + [A] conjoin :: Monad m => StreamK m a -> StreamK m a -> StreamK m a + [A] concatMapWith :: (StreamK m b -> StreamK m b -> StreamK m b) -> (a -> StreamK m b) -> StreamK m a -> StreamK m b + [A] concatMapEffect :: Monad m => (b -> StreamK m a) -> m b -> StreamK m a + [A] concatMap :: (a -> StreamK m b) -> StreamK m a -> StreamK m b + [A] concatIterateWith :: (StreamK m a -> StreamK m a -> StreamK m a) -> (a -> StreamK m a) -> StreamK m a -> StreamK m a + [A] concatIterateScanWith :: Monad m => (StreamK m a -> StreamK m a -> StreamK m a) -> (b -> a -> m (b, StreamK m a)) -> m b -> StreamK m a -> StreamK m a + [A] concatIterateLeftsWith :: b ~ Either a c => (StreamK m b -> StreamK m b -> StreamK m b) -> (a -> StreamK m b) -> StreamK m b -> StreamK m b + [A] concatEffect :: Monad m => m (StreamK m a) -> StreamK m a + [A] buildSM :: Monad m => ((m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) -> StreamK m a + [A] buildS :: ((a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) -> StreamK m a + [A] buildM :: Monad m => (forall r. (a -> StreamK m a -> m r) -> (a -> m r) -> m r -> m r) -> StreamK m a + [A] build :: forall m a. (forall b. (a -> b -> b) -> b -> b) -> StreamK m a + [A] bracketIO :: (MonadIO m, MonadCatch m) => IO b -> (b -> IO c) -> (b -> StreamK m a) -> StreamK m a + [A] bindWith :: (StreamK m b -> StreamK m b -> StreamK m b) -> StreamK m a -> (a -> StreamK m b) -> StreamK m b + [A] before :: Monad m => m b -> StreamK m a -> StreamK m a + [A] augmentSM :: Monad m => ((m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a + [A] augmentS :: ((a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a + [A] append :: StreamK m a -> StreamK m a -> StreamK m a + [A] any :: Monad m => (a -> Bool) -> StreamK m a -> m Bool + [A] all :: Monad m => (a -> Bool) -> StreamK m a -> m Bool + [A] (.:) :: a -> StreamK m a -> StreamK m a + [A] (!!) :: Monad m => StreamK m a -> Int -> m (Maybe a) +[R] Streamly.Internal.Data.Stream.StreamK.Type +[R] Streamly.Internal.Data.Stream.StreamK.Transformer +[R] Streamly.Internal.Data.Stream.StreamK +[R] Streamly.Internal.Data.Stream.StreamD.Type +[R] Streamly.Internal.Data.Stream.StreamD.Transformer +[R] Streamly.Internal.Data.Stream.StreamD.Transform +[R] Streamly.Internal.Data.Stream.StreamD.Top +[R] Streamly.Internal.Data.Stream.StreamD.Step +[R] Streamly.Internal.Data.Stream.StreamD.Nesting +[R] Streamly.Internal.Data.Stream.StreamD.Lift +[R] Streamly.Internal.Data.Stream.StreamD.Generate +[R] Streamly.Internal.Data.Stream.StreamD.Exception +[R] Streamly.Internal.Data.Stream.StreamD.Eliminate +[R] Streamly.Internal.Data.Stream.StreamD.Container +[D] Streamly.Internal.Data.Stream.StreamD +[R] Streamly.Internal.Data.Stream.Common +[R] Streamly.Internal.Data.Stream.Chunked +[C] Streamly.Internal.Data.Stream + [A] class Enum a => Enumerable a + [A] Stream + [A] UnStream :: (State StreamK m a -> s -> m (Step s a)) -> s -> Stream m a + [A] Step + [A] Yield :: a -> s -> Step s a + [A] Stop :: Step s a + [A] Skip :: s -> Step s a + [A] InterleaveState + [A] InterleaveSecondOnly :: s2 -> InterleaveState s1 s2 + [A] InterleaveSecond :: s1 -> s2 -> InterleaveState s1 s2 + [A] InterleaveFirstOnly :: s1 -> InterleaveState s1 s2 + [A] InterleaveFirst :: s1 -> s2 -> InterleaveState s1 s2 + [A] FoldManyPost + [A] FoldManyPostYield :: b -> FoldManyPost s fs b a -> FoldManyPost s fs b a + [A] FoldManyPostStart :: s -> FoldManyPost s fs b a + [A] FoldManyPostLoop :: s -> fs -> FoldManyPost s fs b a + [A] FoldManyPostDone :: FoldManyPost s fs b a + [A] FoldMany + [A] FoldManyYield :: b -> FoldMany s fs b a -> FoldMany s fs b a + [A] FoldManyStart :: s -> FoldMany s fs b a + [A] FoldManyLoop :: s -> fs -> FoldMany s fs b a + [A] FoldManyFirst :: fs -> s -> FoldMany s fs b a + [A] FoldManyDone :: FoldMany s fs b a + [A] CrossStream + [A] ConcatUnfoldInterleaveState + [A] ConcatUnfoldInterleaveOuter :: o -> [i] -> ConcatUnfoldInterleaveState o i + [A] ConcatUnfoldInterleaveInnerR :: [i] -> [i] -> ConcatUnfoldInterleaveState o i + [A] ConcatUnfoldInterleaveInnerL :: [i] -> [i] -> ConcatUnfoldInterleaveState o i + [A] ConcatUnfoldInterleaveInner :: o -> [i] -> ConcatUnfoldInterleaveState o i + [A] ConcatMapUState + [A] ConcatMapUOuter :: o -> ConcatMapUState o i + [A] ConcatMapUInner :: o -> i -> ConcatMapUState o i + [A] AppendState + [A] AppendSecond :: s2 -> AppendState s1 s2 + [A] AppendFirst :: s1 -> AppendState s1 s2 + [A] pattern Stream :: (State StreamK m a -> s -> m (Step s a)) -> s -> Stream m a + [A] zipWithM :: Monad m => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c + [A] zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c + [A] wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] with :: Monad m => (Stream m a -> Stream m (s, a)) -> (((s, a) -> b) -> Stream m (s, a) -> Stream m (s, a)) -> ((s, a) -> b) -> Stream m a -> Stream m a + [A] usingStateT :: Monad m => m s -> (Stream (StateT s m) a -> Stream (StateT s m) a) -> Stream m a -> Stream m a + [A] usingReaderT :: Monad m => m r -> (Stream (ReaderT r m) a -> Stream (ReaderT r m) a) -> Stream m a -> Stream m a + [A] uniqBy :: Monad m => (a -> a -> Bool) -> Stream m a -> Stream m a + [A] uniq :: (Eq a, Monad m) => Stream m a -> Stream m a + [A] unionWithStreamGenericBy :: MonadIO m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [A] unionWithStreamAscBy :: (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a + [A] unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a + [A] unfoldRoundRobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] unfoldMany :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] unfoldIterateDfs :: Monad m => Unfold m a a -> Stream m a -> Stream m a + [A] unfoldIterateBfsRev :: Monad m => Unfold m a a -> Stream m a -> Stream m a + [A] unfoldIterateBfs :: Monad m => Unfold m a a -> Stream m a -> Stream m a + [A] unfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] unfold :: Applicative m => Unfold m a b -> a -> Stream m b + [A] uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a)) + [A] unCross :: CrossStream m a -> Stream m a + [A] transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b + [A] trace_ :: Monad m => m b -> Stream m a -> Stream m a + [A] trace :: Monad m => (a -> m b) -> Stream m a -> Stream m a + [A] toStreamK :: Monad m => Stream m a -> StreamK m a + [A] toListRev :: Monad m => Stream m a -> m [a] + [A] toList :: Monad m => Stream m a -> m [a] + [A] timestamped :: MonadIO m => Stream m a -> Stream m (AbsTime, a) + [A] timestampWith :: MonadIO m => Double -> Stream m a -> Stream m (AbsTime, a) + [A] timesWith :: MonadIO m => Double -> Stream m (AbsTime, RelTime64) + [A] times :: MonadIO m => Stream m (AbsTime, RelTime64) + [A] timeout :: AbsTime -> t m () + [A] timeIndexed :: MonadIO m => Stream m a -> Stream m (RelTime64, a) + [A] timeIndexWith :: MonadIO m => Double -> Stream m a -> Stream m (RelTime64, a) + [A] the :: (Eq a, Monad m) => Stream m a -> m (Maybe a) + [A] tapOffsetEvery :: Monad m => Int -> Int -> Fold m a b -> Stream m a -> Stream m a + [A] tap :: Monad m => Fold m a b -> Stream m a -> Stream m a + [A] takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a + [A] takeWhileLast :: (a -> Bool) -> Stream m a -> Stream m a + [A] takeWhileAround :: (a -> Bool) -> Stream m a -> Stream m a + [A] takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a + [A] takeEndByM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a + [A] takeEndBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m a + [A] take :: Applicative m => Int -> Stream m a -> Stream m a + [A] tail :: Monad m => Stream m a -> m (Maybe (Stream m a)) + [A] stripSuffixUnbox :: (MonadIO m, Eq a, Unbox a) => Stream m a -> Stream m a -> m (Maybe (Stream m a)) + [A] stripSuffix :: (Monad m, Eq a) => Stream m a -> Stream m a -> m (Maybe (Stream m a)) + [A] stripPrefix :: (Monad m, Eq a) => Stream m a -> Stream m a -> m (Maybe (Stream m a)) + [A] strideFromThen :: Monad m => Int -> Int -> Stream m a -> Stream m a + [A] splitOnSuffixSeqAny :: [Array a] -> Fold m a b -> Stream m a -> Stream m b + [A] splitOnSuffixSeq :: forall m a b. (MonadIO m, Storable a, Unbox a, Enum a, Eq a) => Bool -> Array a -> Fold m a b -> Stream m a -> Stream m b + [A] splitOnSeq :: forall m a b. (MonadIO m, Storable a, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Stream m a -> Stream m b + [A] splitOnPrefix :: (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] splitOnAny :: [Array a] -> Fold m a b -> Stream m a -> Stream m b + [A] splitOn :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] splitInnerBySuffix :: (Monad m, Eq (f a), Monoid (f a)) => (f a -> m (f a, Maybe (f a))) -> (f a -> f a -> m (f a)) -> Stream m (f a) -> Stream m (f a) + [A] splitInnerBy :: Monad m => (f a -> m (f a, Maybe (f a))) -> (f a -> f a -> m (f a)) -> Stream m (f a) -> Stream m (f a) + [A] slicesBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) + [A] sliceOnSuffix :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) + [A] sequence :: Monad m => Stream m (m a) -> Stream m a + [A] scanlx' :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b + [A] scanlMx' :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b + [A] scanlMAfter' :: Monad m => (b -> a -> m b) -> m b -> (b -> m b) -> Stream m a -> Stream m b + [A] scanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b + [A] scanlM :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b + [A] scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a + [A] scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a + [A] scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a + [A] scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a + [A] scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b + [A] scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b + [A] scanMaybe :: Monad m => Fold m a (Maybe b) -> Stream m a -> Stream m b + [A] scanMany :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] scan :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] runStateT :: Monad m => m s -> Stream (StateT s m) a -> Stream m (s, a) + [A] runReaderT :: Monad m => m s -> Stream (ReaderT s m) a -> Stream m a + [A] runInnerWithState :: Monad m => (forall b. s -> t m b -> m (b, s)) -> m s -> Stream (t m) a -> Stream m (s, a) + [A] runInnerWith :: Monad m => (forall b. t m b -> m b) -> Stream (t m) a -> Stream m a + [A] roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] rollingMapM :: Monad m => (Maybe a -> a -> m b) -> Stream m a -> Stream m b + [A] rollingMap2 :: Monad m => (a -> a -> b) -> Stream m a -> Stream m b + [A] rollingMap :: Monad m => (Maybe a -> a -> b) -> Stream m a -> Stream m b + [A] reverseUnbox :: (MonadIO m, Unbox a) => Stream m a -> Stream m a + [A] reverse :: Monad m => Stream m a -> Stream m a + [A] replicateM :: Monad m => Int -> m a -> Stream m a + [A] replicate :: Monad m => Int -> a -> Stream m a + [A] repeated :: Stream m a -> Stream m a + [A] repeatM :: Monad m => m a -> Stream m a + [A] repeat :: Monad m => a -> Stream m a + [A] relTimesWith :: MonadIO m => Double -> Stream m RelTime64 + [A] relTimes :: MonadIO m => Stream m RelTime64 + [A] refoldMany :: Monad m => Refold m x a b -> m x -> Stream m a -> Stream m b + [A] refoldIterateM :: Monad m => Refold m b a b -> m b -> Stream m a -> Stream m b + [A] reduceIterateBfs :: Monad m => (a -> a -> m a) -> Stream m a -> m (Maybe a) + [A] reassembleBy :: Fold m a b -> (a -> a -> Int) -> Stream m a -> Stream m b + [A] prune :: (a -> Bool) -> Stream m a -> Stream m a + [A] prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b + [A] prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b + [A] postscanlx' :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b + [A] postscanlMx' :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b + [A] postscanlMAfter' :: Monad m => (b -> a -> m b) -> m b -> (b -> m b) -> Stream m a -> Stream m b + [A] postscanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b + [A] postscanlM :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b + [A] postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a + [A] postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a + [A] postscan :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] parseSequence :: Stream m (Parser a m b) -> Stream m a -> Stream m b + [A] parseManyTill :: Parser a m b -> Parser a m x -> Stream m a -> Stream m b + [A] parseManyD :: Monad m => Parser a m b -> Stream m a -> Stream m (Either ParseError b) + [A] parseMany :: Monad m => Parser a m b -> Stream m a -> Stream m (Either ParseError b) + [A] parseIterateD :: Monad m => (b -> Parser a m b) -> b -> Stream m a -> Stream m (Either ParseError b) + [A] parseIterate :: Monad m => (b -> Parser a m b) -> b -> Stream m a -> Stream m (Either ParseError b) + [A] parseD :: Monad m => Parser a m b -> Stream m a -> m (Either ParseError b) + [A] parseBreakD :: Monad m => Parser a m b -> Stream m a -> m (Either ParseError b, Stream m a) + [A] parseBreak :: Monad m => Parser a m b -> Stream m a -> m (Either ParseError b, Stream m a) + [A] parse :: Monad m => Parser a m b -> Stream m a -> m (Either ParseError b) + [A] onException :: MonadCatch m => m b -> Stream m a -> Stream m a + [A] null :: Monad m => Stream m a -> m Bool + [A] nub :: (Monad m, Ord a) => Stream m a -> Stream m a + [A] notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool + [A] nilM :: Applicative m => m b -> Stream m a + [A] nil :: Applicative m => Stream m a + [A] morphInner :: Monad n => (forall x. m x -> n x) -> Stream m a -> Stream n a + [A] mkCross :: Stream m a -> CrossStream m a + [A] minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a) + [A] minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a) + [A] mergeMinBy :: (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] mergeFstBy :: (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] mergeByM :: Monad m => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] mergeBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a) + [A] maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a) + [A] mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b + [A] mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b + [A] mapM_ :: Monad m => (a -> m b) -> Stream m a -> m () + [A] mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b + [A] map :: Monad m => (a -> b) -> Stream m a -> Stream m b + [A] lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b) + [A] liftInnerWith :: Monad (t m) => (forall b. m b -> t m b) -> Stream m a -> Stream (t m) a + [A] liftInner :: (Monad m, MonadTrans t, Monad (t m)) => Stream m a -> Stream (t m) a + [A] last :: Monad m => Stream m a -> m (Maybe a) + [A] joinOuterGeneric :: MonadIO m => (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (Maybe a, Maybe b) + [A] joinOuterAscBy :: (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (Maybe a, Maybe b) + [A] joinOuter :: (Ord k, MonadIO m) => Stream m (k, a) -> Stream m (k, b) -> Stream m (k, Maybe a, Maybe b) + [A] joinLeftGeneric :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) + [A] joinLeftAscBy :: (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) + [A] joinLeft :: (Ord k, Monad m) => Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, Maybe b) + [A] joinInnerGeneric :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, b) + [A] joinInnerAscBy :: (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, b) + [A] joinInner :: (Monad m, Ord k) => Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, b) + [A] iterateM :: Monad m => (a -> m a) -> m a -> Stream m a + [A] iterate :: Monad m => (a -> a) -> a -> Stream m a + [A] isSuffixOfUnbox :: (MonadIO m, Eq a, Unbox a) => Stream m a -> Stream m a -> m Bool + [A] isSuffixOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool + [A] isSubsequenceOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool + [A] isPrefixOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool + [A] isInfixOf :: (MonadIO m, Eq a, Enum a, Storable a, Unbox a) => Stream m a -> Stream m a -> m Bool + [A] intersperseM_ :: Monad m => m b -> Stream m a -> Stream m a + [A] intersperseMWith :: Int -> m a -> Stream m a -> Stream m a + [A] intersperseMSuffix_ :: Monad m => m b -> Stream m a -> Stream m a + [A] intersperseMSuffixWith :: forall m a. Monad m => Int -> m a -> Stream m a -> Stream m a + [A] intersperseMSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a + [A] intersperseMPrefix_ :: Monad m => m b -> Stream m a -> Stream m a + [A] intersperseM :: Monad m => m a -> Stream m a -> Stream m a + [A] intersperse :: Monad m => a -> Stream m a -> Stream m a + [A] intersectBySorted :: Monad m => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] interposeSuffixM :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c + [A] interposeSuffix :: Monad m => c -> Unfold m b c -> Stream m b -> Stream m c + [A] interposeM :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c + [A] interpose :: Monad m => c -> Unfold m b c -> Stream m b -> Stream m c + [A] interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] interleaveFstSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] interleaveFst :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] interleave :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] intercalateSuffix :: Monad m => Unfold m b c -> b -> Stream m b -> Stream m c + [A] intercalate :: Monad m => Unfold m b c -> b -> Stream m b -> Stream m c + [A] insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a + [A] indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a) + [A] indexed :: Monad m => Stream m a -> Stream m (Int, a) + [A] headElse :: Monad m => a -> Stream m a -> m a + [A] head :: Monad m => Stream m a -> m (Maybe a) + [A] handle :: (MonadCatch m, Exception e) => (e -> m (Stream m a)) -> Stream m a -> Stream m a + [A] groupsWhile :: Monad m => (a -> a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] groupsRollingBy :: Monad m => (a -> a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] groupsOf :: Monad m => Int -> Fold m a b -> Stream m a -> Stream m b + [A] gintercalateSuffix :: Monad m => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c + [A] gintercalate :: Monad m => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c + [A] ghandle :: (MonadCatch m, Exception e) => (e -> Stream m a -> m (Stream m a)) -> Stream m a -> Stream m a + [A] generateM :: Monad m => Int -> (Int -> m a) -> Stream m a + [A] generate :: Monad m => Int -> (Int -> a) -> Stream m a + [A] generalizeInner :: Monad m => Stream Identity a -> Stream m a + [A] gbracket_ :: Monad m => m c -> (c -> m d) -> (c -> e -> Stream m b -> m (Stream m b)) -> (forall s. m s -> m (Either e s)) -> (c -> Stream m b) -> Stream m b + [A] gbracket :: MonadIO m => IO c -> (c -> IO d1) -> (c -> e -> Stream m b -> IO (Stream m b)) -> (c -> IO d2) -> (forall s. m s -> m (Either e s)) -> (c -> Stream m b) -> Stream m b + [A] fromStreamK :: Applicative m => StreamK m a -> Stream m a + [A] fromPure :: Applicative m => a -> Stream m a + [A] fromPtrN :: (Monad m, Storable a) => Int -> Ptr a -> Stream m a + [A] fromPtr :: forall m a. (Monad m, Storable a) => Ptr a -> Stream m a + [A] fromListM :: Monad m => [m a] -> Stream m a + [A] fromList :: Applicative m => [a] -> Stream m a + [A] fromIndicesM :: Monad m => (Int -> m a) -> Stream m a + [A] fromIndices :: Monad m => (Int -> a) -> Stream m a + [A] fromFoldableM :: (Monad m, Foldable f) => f (m a) -> Stream m a + [A] fromFoldable :: (Monad m, Foldable f) => f a -> Stream m a + [A] fromEffect :: Applicative m => m a -> Stream m a + [A] fromByteStr# :: Monad m => Addr# -> Stream m Word8 + [A] foldrT :: (Monad m, Monad (t m), MonadTrans t) => (a -> t m b -> t m b) -> t m b -> Stream m a -> t m b + [A] foldrS :: Monad m => (a -> Stream m b -> Stream m b) -> Stream m b -> Stream m a -> Stream m b + [A] foldrMx :: Monad m => (a -> m x -> m x) -> m x -> (m x -> m b) -> Stream m a -> m b + [A] foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b + [A] foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a) + [A] foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b + [A] foldlx' :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> m b + [A] foldlT :: (Monad m, Monad (s m), MonadTrans s) => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b + [A] foldlS :: Monad m => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b + [A] foldlMx' :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> m b + [A] foldlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> m b + [A] foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b + [A] foldSequence :: Stream m (Fold m a b) -> Stream m a -> Stream m b + [A] foldManyPost :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] foldMany :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] foldIterateM :: Monad m => (b -> m (Fold m a b)) -> m b -> Stream m a -> Stream m b + [A] foldIterateBfs :: Fold m a (Either a a) -> Stream m a -> m (Maybe a) + [A] foldEither :: Monad m => Fold m a b -> Stream m a -> m (Either (Fold m a b) (b, Stream m a)) + [A] foldBreak :: Monad m => Fold m a b -> Stream m a -> m (b, Stream m a) + [A] foldAddLazy :: Monad m => Fold m a b -> Stream m a -> Fold m a b + [A] foldAdd :: Monad m => Fold m a b -> Stream m a -> m (Fold m a b) + [A] fold :: Monad m => Fold m a b -> Stream m a -> m b + [A] findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a) + [A] findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int + [A] find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a) + [A] finallyUnsafe :: MonadCatch m => m b -> Stream m a -> Stream m a + [A] finallyIO :: (MonadIO m, MonadCatch m) => IO b -> Stream m a -> Stream m a + [A] filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a + [A] filterInStreamGenericBy :: Monad m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [A] filterInStreamAscBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a + [A] evalStateT :: Monad m => m s -> Stream (StateT s m) a -> Stream m a + [A] eqBy :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool + [A] enumerateTo :: (Monad m, Bounded a, Enumerable a) => a -> Stream m a + [A] enumerateFromToSmall :: (Monad m, Enum a) => a -> a -> Stream m a + [A] enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a + [A] enumerateFromToFractional :: (Monad m, Fractional a, Ord a) => a -> a -> Stream m a + [A] enumerateFromTo :: (Enumerable a, Monad m) => a -> a -> Stream m a + [A] enumerateFromThenToSmall :: (Monad m, Enum a) => a -> a -> a -> Stream m a + [A] enumerateFromThenToIntegral :: (Monad m, Integral a) => a -> a -> a -> Stream m a + [A] enumerateFromThenToFractional :: (Monad m, Fractional a, Ord a) => a -> a -> a -> Stream m a + [A] enumerateFromThenTo :: (Enumerable a, Monad m) => a -> a -> a -> Stream m a + [A] enumerateFromThenSmallBounded :: (Monad m, Enumerable a, Bounded a) => a -> a -> Stream m a + [A] enumerateFromThenNum :: (Monad m, Num a) => a -> a -> Stream m a + [A] enumerateFromThenIntegral :: (Monad m, Integral a, Bounded a) => a -> a -> Stream m a + [A] enumerateFromThenFractional :: (Monad m, Fractional a) => a -> a -> Stream m a + [A] enumerateFromThen :: (Enumerable a, Monad m) => a -> a -> Stream m a + [A] enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a + [A] enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a + [A] enumerateFromNum :: (Monad m, Num a) => a -> Stream m a + [A] enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a + [A] enumerateFromFractional :: (Monad m, Fractional a) => a -> Stream m a + [A] enumerateFromBounded :: (Monad m, Enumerable a, Bounded a) => a -> Stream m a + [A] enumerateFrom :: (Enumerable a, Monad m) => a -> Stream m a + [A] enumerate :: (Monad m, Bounded a, Enumerable a) => Stream m a + [A] elemIndices :: (Monad m, Eq a) => a -> Stream m a -> Stream m Int + [A] elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool + [A] durations :: Double -> t m RelTime64 + [A] dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a + [A] dropWhileLast :: (a -> Bool) -> Stream m a -> Stream m a + [A] dropWhileAround :: (a -> Bool) -> Stream m a -> Stream m a + [A] dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a + [A] dropSuffix :: Stream m a -> Stream m a -> Stream m a + [A] dropPrefix :: Stream m a -> Stream m a -> Stream m a + [A] dropLast :: Int -> Stream m a -> Stream m a + [A] dropInfix :: Stream m a -> Stream m a -> Stream m a + [A] drop :: Monad m => Int -> Stream m a -> Stream m a + [A] drain :: Monad m => Stream m a -> m () + [A] deleteInStreamGenericBy :: Monad m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [A] deleteInStreamAscBy :: (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a + [A] delayPre :: MonadIO m => Double -> Stream m a -> Stream m a + [A] delayPost :: MonadIO m => Double -> Stream m a -> Stream m a + [A] delay :: MonadIO m => Double -> Stream m a -> Stream m a + [A] crossWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c + [A] crossApplySnd :: Functor f => Stream f a -> Stream f b -> Stream f b + [A] crossApplyFst :: Functor f => Stream f a -> Stream f b -> Stream f a + [A] crossApply :: Functor f => Stream f (a -> b) -> Stream f a -> Stream f b + [A] cross :: Monad m => Stream m a -> Stream m b -> Stream m (a, b) + [A] consM :: Applicative m => m a -> Stream m a -> Stream m a + [A] cons :: Applicative m => a -> Stream m a -> Stream m a + [A] concatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b + [A] concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b + [A] concatIterateScan :: Monad m => (b -> a -> m b) -> (b -> m (Maybe (b, Stream m a))) -> b -> Stream m a + [A] concatIterateDfs :: Monad m => (a -> Maybe (Stream m a)) -> Stream m a -> Stream m a + [A] concatIterateBfsRev :: Monad m => (a -> Maybe (Stream m a)) -> Stream m a -> Stream m a + [A] concatIterateBfs :: Monad m => (a -> Maybe (Stream m a)) -> Stream m a -> Stream m a + [A] concatEffect :: Monad m => m (Stream m a) -> Stream m a + [A] concat :: Monad m => Stream m (Stream m a) -> Stream m a + [A] cmpBy :: Monad m => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering + [A] catRights :: Monad m => Stream m (Either a b) -> Stream m b + [A] catMaybes :: Monad m => Stream m (Maybe a) -> Stream m a + [A] catLefts :: Monad m => Stream m (Either a b) -> Stream m a + [A] catEithers :: Monad m => Stream m (Either a a) -> Stream m a + [A] bracketUnsafe :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a + [A] bracketIO3 :: (MonadIO m, MonadCatch m) => IO b -> (b -> IO c) -> (b -> IO d) -> (b -> IO e) -> (b -> Stream m a) -> Stream m a + [A] bracketIO :: (MonadIO m, MonadCatch m) => IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a + [A] before :: Monad m => m b -> Stream m a -> Stream m a + [A] append :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] any :: Monad m => (a -> Bool) -> Stream m a -> m Bool + [A] all :: Monad m => (a -> Bool) -> Stream m a -> m Bool + [A] afterUnsafe :: Monad m => m b -> Stream m a -> Stream m a + [A] afterIO :: MonadIO m => IO b -> Stream m a -> Stream m a + [A] absTimesWith :: MonadIO m => Double -> Stream m AbsTime + [A] absTimes :: MonadIO m => Stream m AbsTime + [A] (!!) :: Monad m => Stream m a -> Int -> m (Maybe a) +[R] Streamly.Internal.Data.Ring.Unboxed +[A] Streamly.Internal.Data.Ring.Generic + [A] Ring + [A] [ringMax] :: Ring a -> !Int + [A] [ringHead] :: Ring a -> !Int + [A] [ringArr] :: Ring a -> MutArray a + [A] Ring :: MutArray a -> !Int -> !Int -> Ring a + [A] writeLastN :: MonadIO m => Int -> Fold m a (Ring a) + [A] unsafeInsertRingWith :: Ring a -> a -> IO Int + [A] toStreamWith :: Int -> Ring a -> Stream m a + [A] toMutArray :: MonadIO m => Int -> Int -> Ring a -> m (MutArray a) + [A] seek :: MonadIO m => Int -> Ring a -> m (Ring a) + [A] createRing :: MonadIO m => Int -> m (Ring a) + [A] copyToMutArray :: MonadIO m => Int -> Int -> Ring a -> m (MutArray a) +[C] Streamly.Internal.Data.Ring + [C] Ring + [A] [ringStart] :: Ring a -> {-# UNPACK #-} !ForeignPtr a + [R] [ringMax] :: Ring a -> !Int + [R] [ringHead] :: Ring a -> !Int + [A] [ringBound] :: Ring a -> {-# UNPACK #-} !Ptr a + [R] [ringArr] :: Ring a -> MutArray a + [C] Ring + [O] Ring :: MutArray a -> !Int -> !Int -> Ring a + [N] Ring :: {-# UNPACK #-} !ForeignPtr a -> {-# UNPACK #-} !Ptr a -> Ring a + [A] GHC.Show.Show + [A] instance (GHC.Show.Show a, GHC.Show.Show b, GHC.Show.Show c, GHC.Show.Show d) => GHC.Show.Show (Streamly.Internal.Data.Ring.Tuple4' a b c d) + [A] writeN :: Int -> Fold m a (Ring a) + [R] writeLastN :: MonadIO m => Int -> Fold m a (Ring a) + [R] unsafeInsertRingWith :: Ring a -> a -> IO Int + [A] unsafeInsert :: Storable a => Ring a -> Ptr a -> a -> IO (Ptr a) + [A] unsafeFoldRingNM :: forall m a b. (MonadIO m, Storable a) => Int -> Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b + [A] unsafeFoldRingM :: forall m a b. (MonadIO m, Storable a) => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b + [A] unsafeFoldRingFullM :: forall m a b. (MonadIO m, Storable a) => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b + [A] unsafeFoldRing :: forall a b. Storable a => Ptr a -> (b -> a -> b) -> b -> Ring a -> b + [A] unsafeEqArrayN :: Ring a -> Ptr a -> Array a -> Int -> Bool + [A] unsafeEqArray :: Ring a -> Ptr a -> Array a -> Bool + [R] toStreamWith :: Int -> Ring a -> Stream m a + [R] toMutArray :: MonadIO m => Int -> Int -> Ring a -> m (MutArray a) + [A] startOf :: Ring a -> Ptr a + [A] slidingWindowWith :: forall m a b. (MonadIO m, Storable a, Unbox a) => Int -> Fold m ((a, Maybe a), m (MutArray a)) b -> Fold m a b + [A] slidingWindow :: forall m a b. (MonadIO m, Storable a, Unbox a) => Int -> Fold m (a, Maybe a) b -> Fold m a b + [A] slide :: Ring a -> a -> m (Ring a) + [R] seek :: MonadIO m => Int -> Ring a -> m (Ring a) + [A] ringsOf :: Int -> Stream m a -> Stream m (MutArray a) + [A] readRev :: Unfold m (MutArray a) a + [A] read :: forall m a. (MonadIO m, Storable a) => Unfold m (Ring a, Ptr a, Int) a + [A] putIndex :: Ring a -> Int -> a -> m () + [A] newRing :: Int -> m (Ring a) + [A] new :: forall a. Storable a => Int -> IO (Ring a, Ptr a) + [A] moveBy :: forall a. Storable a => Int -> Ring a -> Ptr a -> Ptr a + [A] modifyIndex :: Ring a -> Int -> (a -> (a, b)) -> m b + [A] length :: Ring a -> Int + [A] getIndexUnsafe :: Ring a -> Int -> m a + [A] getIndexRev :: Ring a -> Int -> m a + [A] getIndex :: Ring a -> Int -> m a + [A] fromArray :: MutArray a -> Ring a + [R] createRing :: MonadIO m => Int -> m (Ring a) + [A] castUnsafe :: Ring a -> Ring b + [A] cast :: forall a b. Storable b => Ring a -> Maybe (Ring b) + [A] bytesFree :: Ring a -> Int + [A] byteLength :: Ring a -> Int + [A] byteCapacity :: Ring a -> Int + [A] asBytes :: Ring a -> Ring Word8 + [A] advance :: forall a. Storable a => Ring a -> Ptr a -> Ptr a +[R] Streamly.Internal.Data.Producer.Type +[R] Streamly.Internal.Data.Producer.Source +[C] Streamly.Internal.Data.Producer + [A] Source + [A] unread :: [b] -> Source a b -> Source a b + [A] translate :: Functor m => (a -> c) -> (c -> a) -> Producer m c b -> Producer m a b + [A] source :: Maybe a -> Source a b + [A] producer :: Monad m => Producer m a b -> Producer m (Source a b) b + [A] parseManyD :: Monad m => Parser a m b -> Producer m (Source x a) a -> Producer m (Source x a) (Either ParseError b) + [A] parseMany :: Monad m => Parser a m b -> Producer m (Source x a) a -> Producer m (Source x a) (Either ParseError b) + [A] parse :: Monad m => Parser a m b -> Producer m (Source s a) a -> Source s a -> m (Either ParseError b, Source s a) + [A] lmap :: (a -> a) -> Producer m a b -> Producer m a b + [A] isEmpty :: Source a b -> Bool +[R] Streamly.Internal.Data.Pipe.Type +[C] Streamly.Internal.Data.Pipe + [A] Step + [A] Yield :: a -> s -> Step s a + [A] Continue :: s -> Step s a + [A] PipeState + [A] Produce :: s2 -> PipeState s1 s2 + [A] Consume :: s1 -> PipeState s1 s2 + [C] Pipe + [A] Pipe :: (s1 -> a -> m (Step (PipeState s1 s2) b)) -> (s2 -> m (Step (PipeState s1 s2) b)) -> s1 -> Pipe m a b +[A] Streamly.Internal.Data.ParserK + [A] Step + [A] Partial :: !Int -> (Input a -> m (Step a m r)) -> Step a m r + [A] Error :: !Int -> String -> Step a m r + [A] Done :: !Int -> r -> Step a m r + [A] Continue :: !Int -> (Input a -> m (Step a m r)) -> Step a m r + [A] ParseResult + [A] Success :: !Int -> !b -> ParseResult b + [A] Failure :: !Int -> !String -> ParseResult b + [A] Input + [A] None :: Input a + [A] Chunk :: a -> Input a + [A] ParserK + [A] [runParser] :: ParserK a m b -> forall r. (ParseResult b -> Int -> Input a -> m (Step a m r)) -> Int -> Int -> Input a -> m (Step a m r) + [A] MkParser :: (forall r. (ParseResult b -> Int -> Input a -> m (Step a m r)) -> Int -> Int -> Input a -> m (Step a m r)) -> ParserK a m b + [A] fromPure :: b -> ParserK a m b + [A] fromEffect :: Monad m => m b -> ParserK a m b + [A] die :: String -> ParserK a m b + [A] adaptCG :: Monad m => Parser a m b -> ParserK (Array a) m b + [A] adaptC :: (Monad m, Unbox a) => Parser a m b -> ParserK (Array a) m b + [A] adapt :: Monad m => Parser a m b -> ParserK a m b +[R] Streamly.Internal.Data.Parser.ParserK.Type +[R] Streamly.Internal.Data.Parser.ParserD.Type +[R] Streamly.Internal.Data.Parser.ParserD.Tee +[R] Streamly.Internal.Data.Parser.ParserD +[C] Streamly.Internal.Data.Parser + [A] Step + [A] Partial :: !Int -> !s -> Step s b + [A] Error :: !String -> Step s b + [A] Done :: !Int -> !b -> Step s b + [A] Continue :: !Int -> !s -> Step s b + [A] Parser + [A] Parser :: (s -> a -> m (Step s b)) -> m (Initial s b) -> (s -> m (Step s b)) -> Parser a m b + [A] Initial + [A] IPartial :: !s -> Initial s b + [A] IError :: !String -> Initial s b + [A] IDone :: !b -> Initial s b + [A] GHC.Show.Show + [A] instance (GHC.Show.Show a, GHC.Show.Show b) => GHC.Show.Show (Streamly.Internal.Data.Parser.Tuple'Fused a b) + [A] ParseError + [A] ParseError :: String -> ParseError + [A] zipWithM :: Monad m => (a -> b -> m c) -> Stream m a -> Fold m c x -> Parser b m x + [A] zip :: Monad m => Stream m a -> Fold m (a, b) x -> Parser b m x + [A] wordWithQuotes :: (Monad m, Eq a) => Bool -> (a -> a -> Maybe a) -> a -> (a -> Maybe a) -> (a -> Bool) -> Fold m a b -> Parser a m b + [A] wordProcessQuotes :: (Monad m, Eq a) => a -> (a -> Maybe a) -> (a -> Bool) -> Fold m a b -> Parser a m b + [A] wordKeepQuotes :: (Monad m, Eq a) => a -> (a -> Maybe a) -> (a -> Bool) -> Fold m a b -> Parser a m b + [A] wordFramedBy :: Monad m => (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser a m b + [A] wordBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b + [A] toFold :: Monad m => Parser a m b -> Fold m a b + [A] takeWhileP :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b + [A] takeWhile1 :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b + [A] takeWhile :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b + [A] takeStartBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b + [A] takeStartBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b + [A] takeP :: Monad m => Int -> Parser a m b -> Parser a m b + [A] takeGE :: Monad m => Int -> Fold m a b -> Parser a m b + [A] takeFramedBy_ :: Monad m => (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser a m b + [A] takeFramedByGeneric :: Monad m => Maybe (a -> Bool) -> Maybe (a -> Bool) -> Maybe (a -> Bool) -> Fold m a b -> Parser a m b + [A] takeFramedByEsc_ :: Monad m => (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser a m b + [A] takeEndBy_ :: (a -> Bool) -> Parser a m b -> Parser a m b + [A] takeEndByEsc :: Monad m => (a -> Bool) -> (a -> Bool) -> Parser a m b -> Parser a m b + [A] takeEndBy :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b + [A] takeEitherSepBy :: (a -> Bool) -> Fold m (Either a b) c -> Parser a m c + [A] takeEQ :: Monad m => Int -> Fold m a b -> Parser a m b + [A] takeBetween :: Monad m => Int -> Int -> Fold m a b -> Parser a m b + [A] subsequenceBy :: (a -> a -> Bool) -> Stream m a -> Parser a m () + [A] streamEqBy :: Monad m => (a -> a -> Bool) -> Stream m a -> Parser a m () + [A] split_ :: Monad m => Parser x m a -> Parser x m b -> Parser x m b + [A] splitWith :: Monad m => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c + [A] splitSome :: Monad m => Parser a m b -> Fold m b c -> Parser a m c + [A] splitManyPost :: Monad m => Parser a m b -> Fold m b c -> Parser a m c + [A] splitMany :: Monad m => Parser a m b -> Fold m b c -> Parser a m c + [A] spanByRolling :: Monad m => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (b, c) + [A] spanBy :: Monad m => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (b, c) + [A] span :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (b, c) + [A] some :: Monad m => Parser a m b -> Fold m b c -> Parser a m c + [A] sequence :: Monad m => Stream m (Parser a m b) -> Fold m b c -> Parser a m c + [A] sepByAll :: Monad m => Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c + [A] sepBy1 :: Monad m => Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c + [A] sepBy :: Monad m => Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c + [A] satisfy :: Monad m => (a -> Bool) -> Parser a m a + [A] sampleFromthen :: Monad m => Int -> Int -> Fold m a b -> Parser a m b + [A] roundRobin :: t (Parser a m b) -> Fold m b c -> Parser a m c + [A] rmapM :: Monad m => (b -> m c) -> Parser a m b -> Parser a m c + [A] retryMaxTotal :: Int -> Parser a m b -> Fold m b c -> Parser a m c + [A] retryMaxSuccessive :: Int -> Parser a m b -> Fold m b c -> Parser a m c + [A] retry :: Parser a m b -> Parser a m b + [A] postscan :: Fold m a b -> Parser b m c -> Parser a m c + [A] peek :: Monad m => Parser a m a + [A] oneOf :: (Monad m, Eq a, Foldable f) => f a -> Parser a m a + [A] oneNotEq :: (Monad m, Eq a) => a -> Parser a m a + [A] oneEq :: (Monad m, Eq a) => a -> Parser a m a + [A] one :: Monad m => Parser a m a + [A] noneOf :: (Monad m, Eq a, Foldable f) => f a -> Parser a m a + [A] noErrorUnsafeSplit_ :: Monad m => Parser x m a -> Parser x m b -> Parser x m b + [A] noErrorUnsafeSplitWith :: Monad m => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c + [A] noErrorUnsafeConcatMap :: Monad m => (b -> Parser a m c) -> Parser a m b -> Parser a m c + [A] maybe :: Monad m => (a -> Maybe b) -> Parser a m b + [A] manyTillP :: Parser a m b -> Parser a m x -> Parser b m c -> Parser a m c + [A] manyTill :: Monad m => Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c + [A] manyThen :: Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c + [A] manyP :: Parser a m b -> Parser b m c -> Parser a m c + [A] many :: Monad m => Parser a m b -> Fold m b c -> Parser a m c + [A] makeIndexFilter :: (Fold m (s, a) b -> Parser a m b) -> (((s, a) -> Bool) -> Fold m (s, a) b -> Fold m (s, a) b) -> ((s, a) -> Bool) -> Fold m a b -> Parser a m b + [A] lookAhead :: Monad m => Parser a m b -> Parser a m b + [A] lmapM :: Monad m => (a -> m b) -> Parser b m r -> Parser a m r + [A] lmap :: (a -> b) -> Parser b m r -> Parser a m r + [A] listEqBy :: Monad m => (a -> a -> Bool) -> [a] -> Parser a m [a] + [A] listEq :: (Monad m, Eq a) => [a] -> Parser a m [a] + [A] indexed :: forall m a b. Monad m => Fold m (Int, a) b -> Parser a m b + [A] groupByRollingEither :: Monad m => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (Either b c) + [A] groupByRolling :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser a m b + [A] groupBy :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser a m b + [A] fromPure :: Monad m => b -> Parser a m b + [A] fromFoldMaybe :: Monad m => String -> Fold m a (Maybe b) -> Parser a m b + [A] fromFold :: Monad m => Fold m a b -> Parser a m b + [A] fromEffect :: Monad m => m b -> Parser a m b + [A] filter :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b + [A] extractStep :: Monad m => (s -> m (Step s1 b)) -> Step s b -> m (Step s1 b) + [A] eof :: Monad m => Parser a m () + [A] either :: Monad m => (a -> Either String b) -> Parser a m b + [A] dropWhile :: Monad m => (a -> Bool) -> Parser a m () + [A] dieM :: Monad m => m String -> Parser a m b + [A] die :: Monad m => String -> Parser a m b + [A] deintercalateAll :: Monad m => Parser a m x -> Parser a m y -> Fold m (Either x y) z -> Parser a m z + [A] deintercalate1 :: Monad m => Parser a m x -> Parser a m y -> Fold m (Either x y) z -> Parser a m z + [A] deintercalate :: Monad m => Parser a m x -> Parser a m y -> Fold m (Either x y) z -> Parser a m z + [A] countBetween :: Int -> Int -> Parser a m b -> Fold m b c -> Parser a m c + [A] count :: Int -> Parser a m b -> Fold m b c -> Parser a m c + [A] concatMap :: Monad m => (b -> Parser a m c) -> Parser a m b -> Parser a m c + [A] blockWithQuotes :: (Monad m, Eq a) => (a -> Bool) -> (a -> Bool) -> a -> a -> Fold m a b -> Parser a m b + [A] bimapOverrideCount :: Int -> (s -> s1) -> (b -> b1) -> Step s b -> Step s1 b1 + [A] alt :: Monad m => Parser x m a -> Parser x m a -> Parser x m a +[A] Streamly.Internal.Data.MutByteArray + [A] class Unbox a + [A] class SizeOfRep (f :: Type -> Type) + [A] class Serialize a + [A] TypeOfType + [A] UnitType :: Name -> TypeOfType + [A] TheType :: SimpleDataCon -> TypeOfType + [A] MultiType :: [SimpleDataCon] -> TypeOfType + [A] SimpleDataCon + [A] SimpleDataCon :: Name -> [Field] -> SimpleDataCon + [A] SerializeConfig + [A] [cfgRecordSyntaxWithHeader] :: SerializeConfig -> Bool + [A] [cfgInlineSize] :: SerializeConfig -> Maybe Inline + [A] [cfgInlineSerialize] :: SerializeConfig -> Maybe Inline + [A] [cfgInlineDeserialize] :: SerializeConfig -> Maybe Inline + [A] [cfgConstructorTagAsString] :: SerializeConfig -> Bool + [A] SerializeConfig :: Maybe Inline -> Maybe Inline -> Maybe Inline -> Bool -> Bool -> SerializeConfig + [A] PinnedState + [A] Unpinned :: PinnedState + [A] Pinned :: PinnedState + [A] MutByteArray + [A] MutByteArray :: MutableByteArray# RealWorld -> MutByteArray + [A] DataType + [A] [dtTvs] :: DataType -> [Name] + [A] [dtName] :: DataType -> Name + [A] [dtCxt] :: DataType -> Cxt + [A] [dtCons] :: DataType -> [DataCon] + [A] DataType :: Name -> [Name] -> Cxt -> [DataCon] -> DataType + [A] DataCon + [A] [dcTvs] :: DataCon -> [Name] + [A] [dcName] :: DataCon -> Name + [A] [dcFields] :: DataCon -> [(Maybe Name, Type)] + [A] [dcCxt] :: DataCon -> Cxt + [A] DataCon :: Name -> [Name] -> Cxt -> [(Maybe Name, Type)] -> DataCon + [A] BoundedPtr + [A] BoundedPtr :: MutByteArray -> Int -> Int -> BoundedPtr + [A] Streamly.Internal.Data.Serialize.Type.Serialize + [A] instance Streamly.Internal.Data.Serialize.Type.Serialize Streamly.Internal.Data.MutByteArray.LiftedInteger + [A] instance Streamly.Internal.Data.Serialize.Type.Serialize GHC.Num.Integer.Integer + [A] instance Streamly.Internal.Data.Serialize.Type.Serialize a => Streamly.Internal.Data.Serialize.Type.Serialize (GHC.Maybe.Maybe a) + [A] instance Streamly.Internal.Data.Serialize.Type.Serialize (Data.Proxy.Proxy a) + [A] instance (Streamly.Internal.Data.Serialize.Type.Serialize a, Streamly.Internal.Data.Serialize.Type.Serialize b) => Streamly.Internal.Data.Serialize.Type.Serialize (Data.Either.Either a b) + [A] Peeker + [A] Peeker :: Builder BoundedPtr IO a -> Peeker a + [A] type Field = (Maybe Name, Type) + [A] xorCmp :: [Word8] -> Name -> Name -> Q Exp + [A] wListToString :: [Word8] -> String + [A] w8_int :: Word8 -> Int + [A] w32_int :: Word32 -> Int + [A] unpin :: MutByteArray -> IO MutByteArray + [A] typeOfType :: Type -> [DataCon] -> TypeOfType + [A] skipByte :: Peeker () + [A] sizeOfRep :: SizeOfRep f => f x -> Int + [A] sizeOfMutableByteArray :: MutByteArray -> IO Int + [A] sizeOf :: (Unbox a, SizeOfRep (Rep a)) => Proxy a -> Int + [A] simplifyDataCon :: DataCon -> SimpleDataCon + [A] serializeW8List :: Name -> Name -> [Word8] -> Q Exp + [A] serializeConfig :: SerializeConfig + [A] serializeAt :: Serialize a => Int -> MutByteArray -> a -> IO Int + [A] runPeeker :: Peeker a -> BoundedPtr -> IO a + [A] reifyDataType :: Name -> Q DataType + [A] readUnsafe :: Unbox a => Peeker a + [A] read :: Unbox a => Peeker a + [A] putSliceUnsafe :: MonadIO m => MutByteArray -> Int -> MutByteArray -> Int -> Int -> m () + [A] pokeRep :: PokeRep f => f a -> BoundedPtr -> IO BoundedPtr + [A] pokeBoundedPtrUnsafe :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr + [A] pokeBoundedPtr :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr + [A] pokeAt :: (Unbox a, Generic a, PokeRep (Rep a)) => Int -> MutByteArray -> a -> IO () + [A] pinnedNewAlignedBytes :: Int -> Int -> IO MutByteArray + [A] pinnedNew :: Int -> IO MutByteArray + [A] pinnedCloneSliceUnsafe :: MonadIO m => Int -> Int -> MutByteArray -> m MutByteArray + [A] pin :: MutByteArray -> IO MutByteArray + [A] peekRep :: PeekRep f => Peeker (f x) + [A] peekAt :: (Unbox a, Generic a, PeekRep (Rep a)) => Int -> MutByteArray -> IO a + [A] openConstructor :: Name -> Int -> Q Pat + [A] nil :: MutByteArray + [A] newBytesAs :: PinnedState -> Int -> IO MutByteArray + [A] new :: Int -> IO MutByteArray + [A] mkSerializeExprFields :: Name -> [Field] -> Q Exp + [A] mkRecSizeOfExpr :: SimpleDataCon -> Q Exp + [A] mkRecSerializeExpr :: Name -> SimpleDataCon -> Q Exp + [A] mkRecDeserializeExpr :: Name -> Name -> Name -> SimpleDataCon -> Q Exp + [A] mkFieldName :: Int -> Name + [A] mkDeserializeKeysDec :: Name -> Name -> SimpleDataCon -> Q [Dec] + [A] mkDeserializeExprOne :: Name -> SimpleDataCon -> Q Exp + [A] matchConstructor :: Name -> Int -> Q Exp -> Q Match + [A] makeN :: Int -> Name + [A] makeI :: Int -> Name + [A] makeA :: Int -> Name + [A] litProxy :: Unbox a => Proxy a -> Q Exp + [A] litIntegral :: Integral a => a -> Q Exp + [A] isUnitType :: [DataCon] -> Bool + [A] isRecordSyntax :: SimpleDataCon -> Bool + [A] isPinned :: MutByteArray -> Bool + [A] int_w8 :: Int -> Word8 + [A] int_w32 :: Int -> Word32 + [A] inlineSerializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig + [A] inlineDeserializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig + [A] inlineAddSizeTo :: Maybe Inline -> SerializeConfig -> SerializeConfig + [A] getMutableByteArray# :: MutByteArray -> MutableByteArray# RealWorld + [A] genericSizeOf :: forall a. SizeOfRep (Rep a) => Proxy a -> Int + [A] genericPokeByteIndex :: (Generic a, PokeRep (Rep a)) => MutByteArray -> Int -> a -> IO () + [A] genericPeekByteIndex :: (Generic a, PeekRep (Rep a)) => MutByteArray -> Int -> IO a + [A] errorUnsupported :: String -> a + [A] errorUnimplemented :: a + [A] encodeRecordFields :: Bool -> SerializeConfig -> SerializeConfig + [A] encodeConstrNames :: Bool -> SerializeConfig -> SerializeConfig + [A] deserializeAt :: Serialize a => Int -> MutByteArray -> Int -> IO (Int, a) + [A] deriveUnbox :: Q [Dec] -> Q [Dec] + [A] deriveSerializeWith :: (SerializeConfig -> SerializeConfig) -> Q [Dec] -> Q [Dec] + [A] deriveSerialize :: Q [Dec] -> Q [Dec] + [A] conUpdateFuncDec :: Name -> [Field] -> Q [Dec] + [A] cloneSliceUnsafeAs :: MonadIO m => PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray + [A] cloneSliceUnsafe :: MonadIO m => Int -> Int -> MutByteArray -> m MutByteArray + [A] c2w :: Char -> Word8 + [A] asPtrUnsafe :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b + [A] addSizeTo :: Serialize a => Int -> a -> Int + [A] _x :: Name + [A] _val :: Name + [A] _tag :: Name + [A] _initialOffset :: Name + [A] _endOffset :: Name + [A] _arr :: Name + [A] _acc :: Name +[A] Streamly.Internal.Data.MutArray.Stream + [A] SpliceState + [A] SpliceYielding :: arr -> SpliceState s arr -> SpliceState s arr + [A] SpliceInitial :: s -> SpliceState s arr + [A] SpliceFinish :: SpliceState s arr + [A] SpliceBuffering :: s -> arr -> SpliceState s arr + [A] writeChunks :: (MonadIO m, Unbox a) => Int -> Fold m a (StreamK n (MutArray a)) + [A] splitOn :: (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> Stream m (MutArray a) + [A] pinnedChunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (MutArray a) + [A] packArraysChunksOf :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] lpackArraysChunksOf :: (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () + [A] fromArrayStreamK :: (Unbox a, MonadIO m) => StreamK m (MutArray a) -> m (MutArray a) + [A] flattenArraysRev :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a + [A] flattenArrays :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a + [A] compactLE :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (Either ParseError (MutArray a)) + [A] compactGE :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] compactEQ :: Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] compact :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] chunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (MutArray a) +[A] Streamly.Internal.Data.MutArray.Generic + [A] MutArray + [A] [arrTrueLen] :: MutArray a -> {-# UNPACK #-} !Int + [A] [arrStart] :: MutArray a -> {-# UNPACK #-} !Int + [A] [arrLen] :: MutArray a -> {-# UNPACK #-} !Int + [A] [arrContents#] :: MutArray a -> MutableArray# RealWorld a + [A] MutArray :: MutableArray# RealWorld a -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> MutArray a + [A] writeWith :: MonadIO m => Int -> Fold m a (MutArray a) + [A] writeNUnsafe :: MonadIO m => Int -> Fold m a (MutArray a) + [A] writeN :: MonadIO m => Int -> Fold m a (MutArray a) + [A] write :: MonadIO m => Fold m a (MutArray a) + [A] uninit :: MonadIO m => MutArray a -> Int -> m (MutArray a) + [A] toStreamK :: MonadIO m => MutArray a -> StreamK m a + [A] toList :: MonadIO m => MutArray a -> m [a] + [A] strip :: MonadIO m => (a -> Bool) -> MutArray a -> m (MutArray a) + [A] snocWith :: MonadIO m => (Int -> Int) -> MutArray a -> a -> m (MutArray a) + [A] snocUnsafe :: MonadIO m => MutArray a -> a -> m (MutArray a) + [A] snoc :: MonadIO m => MutArray a -> a -> m (MutArray a) + [A] realloc :: MonadIO m => Int -> MutArray a -> m (MutArray a) + [A] reader :: MonadIO m => Unfold m (MutArray a) a + [A] readRev :: MonadIO m => MutArray a -> Stream m a + [A] read :: MonadIO m => MutArray a -> Stream m a + [A] putSliceUnsafe :: MonadIO m => MutArray a -> Int -> MutArray a -> Int -> Int -> m () + [A] putIndices :: MonadIO m => MutArray a -> Fold m (Int, a) () + [A] putIndexUnsafe :: forall m a. MonadIO m => Int -> MutArray a -> a -> m () + [A] putIndex :: MonadIO m => Int -> MutArray a -> a -> m () + [A] producerWith :: Monad m => (forall b. IO b -> m b) -> Producer m (MutArray a) a + [A] producer :: MonadIO m => Producer m (MutArray a) a + [A] nil :: MonadIO m => m (MutArray a) + [A] new :: MonadIO m => Int -> m (MutArray a) + [A] modifyIndexUnsafe :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] modifyIndex :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] length :: MutArray a -> Int + [A] getSliceUnsafe :: Int -> Int -> MutArray a -> MutArray a + [A] getSlice :: Int -> Int -> MutArray a -> MutArray a + [A] getIndexUnsafeWith :: MonadIO m => MutableArray# RealWorld a -> Int -> m a + [A] getIndexUnsafe :: MonadIO m => Int -> MutArray a -> m a + [A] getIndex :: MonadIO m => Int -> MutArray a -> m (Maybe a) + [A] fromStreamN :: MonadIO m => Int -> Stream m a -> m (MutArray a) + [A] fromStream :: MonadIO m => Stream m a -> m (MutArray a) + [A] fromPureStream :: MonadIO m => Stream Identity a -> m (MutArray a) + [A] fromListN :: MonadIO m => Int -> [a] -> m (MutArray a) + [A] fromList :: MonadIO m => [a] -> m (MutArray a) + [A] eq :: (MonadIO m, Eq a) => MutArray a -> MutArray a -> m Bool + [A] cmp :: (MonadIO m, Ord a) => MutArray a -> MutArray a -> m Ordering + [A] clone :: MonadIO m => MutArray a -> m (MutArray a) + [A] chunksOf :: forall m a. MonadIO m => Int -> Stream m a -> Stream m (MutArray a) +[A] Streamly.Internal.Data.MutArray + [A] MutByteArray + [A] MutArray + [A] [arrStart] :: MutArray a -> {-# UNPACK #-} !Int + [A] [arrEnd] :: MutArray a -> {-# UNPACK #-} !Int + [A] [arrContents] :: MutArray a -> {-# UNPACK #-} !MutByteArray + [A] [arrBound] :: MutArray a -> {-# UNPACK #-} !Int + [A] MutArray :: {-# UNPACK #-} !MutByteArray -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> MutArray a + [A] IORef + [A] ArrayUnsafe + [A] ArrayUnsafe :: {-# UNPACK #-} !MutByteArray -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> ArrayUnsafe a + [A] writeWith :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] writeRevN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] writeNWithUnsafe :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [A] writeNWith :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [A] writeNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] writeIORef :: Unbox a => IORef a -> a -> IO () + [A] writeChunks :: (MonadIO m, Unbox a) => Int -> Fold m a (StreamK n (MutArray a)) + [A] writeAppendWith :: forall m a. (MonadIO m, Unbox a) => (Int -> Int) -> m (MutArray a) -> Fold m a (MutArray a) + [A] writeAppendNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [A] writeAppendN :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [A] writeAppend :: forall m a. (MonadIO m, Unbox a) => m (MutArray a) -> Fold m a (MutArray a) + [A] write :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [A] unsafeSwapIndices :: forall m a. (MonadIO m, Unbox a) => Int -> Int -> MutArray a -> m () + [A] unpin :: MutArray a -> IO (MutArray a) + [A] toStreamKWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> MutArray a -> StreamK m a + [A] toStreamKRevWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> MutArray a -> StreamK m a + [A] toStreamKRev :: forall m a. (MonadIO m, Unbox a) => MutArray a -> StreamK m a + [A] toStreamK :: forall m a. (MonadIO m, Unbox a) => MutArray a -> StreamK m a + [A] toStreamDWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> MutArray a -> Stream m a + [A] toStreamDRevWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> MutArray a -> Stream m a + [A] toList :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m [a] + [A] swapIndices :: forall m a. (MonadIO m, Unbox a) => Int -> Int -> MutArray a -> m () + [A] strip :: forall a m. (Unbox a, MonadIO m) => (a -> Bool) -> MutArray a -> m (MutArray a) + [A] splitOn :: (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> Stream m (MutArray a) + [A] splitAt :: forall a. Unbox a => Int -> MutArray a -> (MutArray a, MutArray a) + [A] spliceWith :: forall m a. (MonadIO m, Unbox a) => (Int -> Int -> Int) -> MutArray a -> MutArray a -> m (MutArray a) + [A] spliceUnsafe :: MonadIO m => MutArray a -> MutArray a -> m (MutArray a) + [A] spliceExp :: (MonadIO m, Unbox a) => MutArray a -> MutArray a -> m (MutArray a) + [A] spliceCopy :: forall m a. MonadIO m => MutArray a -> MutArray a -> m (MutArray a) + [A] splice :: (MonadIO m, Unbox a) => MutArray a -> MutArray a -> m (MutArray a) + [A] snocWith :: forall m a. (MonadIO m, Unbox a) => (Int -> Int) -> MutArray a -> a -> m (MutArray a) + [A] snocUnsafe :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) + [A] snocMay :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (Maybe (MutArray a)) + [A] snocLinear :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) + [A] snoc :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) + [A] shuffleBy :: (a -> a -> m Bool) -> MutArray a -> MutArray a -> m () + [A] roundUpToPower2 :: Int -> Int + [A] rightSize :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m (MutArray a) + [A] reverse :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m () + [A] resizeExp :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [A] resize :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [A] realloc :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [A] readerRevWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> Unfold m (MutArray a) a + [A] readerRev :: forall m a. (MonadIO m, Unbox a) => Unfold m (MutArray a) a + [A] reader :: forall m a. (MonadIO m, Unbox a) => Unfold m (MutArray a) a + [A] readRev :: forall m a. (MonadIO m, Unbox a) => MutArray a -> Stream m a + [A] readIORef :: Unbox a => IORef a -> IO a + [A] read :: forall m a. (MonadIO m, Unbox a) => MutArray a -> Stream m a + [A] putIndices :: forall m a. (MonadIO m, Unbox a) => MutArray a -> Fold m (Int, a) () + [A] putIndexUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () + [A] putIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () + [A] producerWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> Producer m (MutArray a) a + [A] producer :: forall m a. (MonadIO m, Unbox a) => Producer m (MutArray a) a + [A] pollIntIORef :: (MonadIO m, Unbox a) => IORef a -> Stream m a + [A] pinnedWriteNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] pinnedWriteNAligned :: forall m a. (MonadIO m, Unbox a) => Int -> Int -> Fold m a (MutArray a) + [A] pinnedWriteN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] pinnedWrite :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [A] pinnedNewBytes :: MonadIO m => Int -> m (MutArray a) + [A] pinnedNewAligned :: (MonadIO m, Unbox a) => Int -> Int -> m (MutArray a) + [A] pinnedNew :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] pinnedFromListN :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) + [A] pinnedFromList :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) + [A] pinnedClone :: MonadIO m => MutArray a -> m (MutArray a) + [A] pinnedChunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (MutArray a) + [A] pin :: MutArray a -> IO (MutArray a) + [A] permute :: MutArray a -> m Bool + [A] partitionBy :: forall m a. (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) + [A] nil :: MutArray a + [A] newIORef :: forall a. Unbox a => a -> IO (IORef a) + [A] newArrayWith :: forall m a. (MonadIO m, Unbox a) => (Int -> Int -> m MutByteArray) -> Int -> Int -> m (MutArray a) + [A] new :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] modifyIndices :: forall m a. (MonadIO m, Unbox a) => MutArray a -> (Int -> a -> a) -> Fold m Int () + [A] modifyIndexUnsafe :: forall m a b. (MonadIO m, Unbox a) => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] modifyIndex :: forall m a b. (MonadIO m, Unbox a) => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] modifyIORef' :: Unbox a => IORef a -> (a -> a) -> IO () + [A] modify :: forall m a. (MonadIO m, Unbox a) => MutArray a -> (a -> a) -> m () + [A] mergeBy :: Int -> (MutArray a -> MutArray a -> m ()) -> MutArray a -> m () + [A] memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () + [A] memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool + [A] length :: forall a. Unbox a => MutArray a -> Int + [A] isPinned :: MutArray a -> Bool + [A] getSlicesFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (MutArray a) + [A] getSliceUnsafe :: forall a. Unbox a => Int -> Int -> MutArray a -> MutArray a + [A] getSlice :: forall a. Unbox a => Int -> Int -> MutArray a -> MutArray a + [A] getIndicesD :: (Monad m, Unbox a) => (forall b. IO b -> m b) -> Stream m Int -> Unfold m (MutArray a) a + [A] getIndices :: (MonadIO m, Unbox a) => Stream m Int -> Unfold m (MutArray a) a + [A] getIndexUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [A] getIndexRev :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [A] getIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (Maybe a) + [A] genSlicesFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (Int, Int) + [A] fromStreamDN :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> m (MutArray a) + [A] fromStreamD :: (MonadIO m, Unbox a) => Stream m a -> m (MutArray a) + [A] fromStream :: (MonadIO m, Unbox a) => Stream m a -> m (MutArray a) + [A] fromPureStream :: (MonadIO m, Unbox a) => Stream Identity a -> m (MutArray a) + [A] fromListRevN :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) + [A] fromListRev :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) + [A] fromListN :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) + [A] fromList :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) + [A] fromArrayStreamK :: (Unbox a, MonadIO m) => StreamK m (MutArray a) -> m (MutArray a) + [A] foldr :: (MonadIO m, Unbox a) => (a -> b -> b) -> b -> MutArray a -> m b + [A] foldl' :: (MonadIO m, Unbox a) => (b -> a -> b) -> b -> MutArray a -> m b + [A] flattenArraysRev :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a + [A] flattenArrays :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a + [A] divideBy :: Int -> (MutArray a -> m (MutArray a, MutArray a)) -> MutArray a -> m () + [A] cmp :: MonadIO m => MutArray a -> MutArray a -> m Ordering + [A] clone :: MonadIO m => MutArray a -> m (MutArray a) + [A] chunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (MutArray a) + [A] castUnsafe :: MutArray a -> MutArray b + [A] cast :: forall a b. Unbox b => MutArray a -> Maybe (MutArray b) + [A] c_memchr :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) + [A] bytesFree :: MutArray a -> Int + [A] byteLength :: MutArray a -> Int + [A] byteCapacity :: MutArray a -> Int + [A] bubble :: (MonadIO m, Unbox a) => (a -> a -> Ordering) -> MutArray a -> m () + [A] breakOn :: MonadIO m => Word8 -> MutArray Word8 -> m (MutArray Word8, Maybe (MutArray Word8)) + [A] blockSize :: Int + [A] asPtrUnsafe :: MonadIO m => MutArray a -> (Ptr a -> m b) -> m b + [A] asBytes :: MutArray a -> MutArray Word8 + [A] arrayChunkBytes :: Int + [A] allocBytesToElemCount :: Unbox a => a -> Int -> Int +[C] Streamly.Internal.Data.IsMap + [A] mapTraverseWithKey :: (IsMap f, Applicative t) => (Key f -> a -> t b) -> f a -> t (f b) +[R] Streamly.Internal.Data.IORef.Unboxed +[R] Streamly.Internal.Data.Fold.Window +[R] Streamly.Internal.Data.Fold.Type +[R] Streamly.Internal.Data.Fold.Tee +[R] Streamly.Internal.Data.Fold.Step +[R] Streamly.Internal.Data.Fold.Container +[D] Streamly.Internal.Data.Fold.Chunked +[C] Streamly.Internal.Data.Fold + [A] ManyState + [C] Fold + [C] Fold + [O] Fold :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> Fold m a b + [N] Fold :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> (s -> m b) -> Fold m a b + [A] windowSumInt :: forall m a. (Monad m, Integral a) => Fold m (a, Maybe a) a + [A] windowSum :: forall m a. (Monad m, Num a) => Fold m (a, Maybe a) a + [A] windowRollingMapM :: Monad m => (Maybe a -> a -> m (Maybe b)) -> Fold m (a, Maybe a) (Maybe b) + [A] windowRollingMap :: Monad m => (Maybe a -> a -> Maybe b) -> Fold m (a, Maybe a) (Maybe b) + [A] windowRange :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe (a, a)) + [A] windowPowerSumFrac :: (Monad m, Floating a) => a -> Fold m (a, Maybe a) a + [A] windowPowerSum :: (Monad m, Num a) => Int -> Fold m (a, Maybe a) a + [A] windowMinimum :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe a) + [A] windowMean :: forall m a. (Monad m, Fractional a) => Fold m (a, Maybe a) a + [A] windowMaximum :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe a) + [A] windowLmap :: (c -> a) -> Fold m (a, Maybe a) b -> Fold m (c, Maybe c) b + [A] windowLength :: (Monad m, Num b) => Fold m (a, Maybe a) b + [A] toSet :: (Monad m, Ord a) => Fold m a (Set a) + [A] toMapIO :: (MonadIO m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (Map k b) + [A] toMap :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (Map k b) + [A] toIntSet :: Monad m => Fold m Int IntSet + [A] toContainerIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (f b) + [A] toContainer :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (f b) + [A] nubInt :: Monad m => Fold m Int (Maybe Int) + [A] nub :: (Monad m, Ord a) => Fold m a (Maybe a) + [A] mapMStep :: Applicative m => (a -> m b) -> Step s a -> m (Step s b) + [A] kvToMap :: (Monad m, Ord k) => Fold m a b -> Fold m (k, a) (Map k b) + [A] frequency :: (Monad m, Ord a) => Fold m a (Map a Int) + [A] demuxToMapIO :: (MonadIO m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) + [A] demuxToMap :: (Monad m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) + [A] demuxToContainerIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (f b) + [A] demuxToContainer :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (f b) + [A] demuxKvToMap :: (Monad m, Ord k) => (k -> m (Fold m a b)) -> Fold m (k, a) (Map k b) + [A] demuxKvToContainer :: (Monad m, IsMap f, Traversable f) => (Key f -> m (Fold m a b)) -> Fold m (Key f, a) (f b) + [A] demuxIO :: (MonadIO m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (m (Map k b), Maybe (k, b)) + [A] demuxGenericIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (m (f b), Maybe (Key f, b)) + [A] demuxGeneric :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (m (f b), Maybe (Key f, b)) + [A] demux :: (Monad m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (m (Map k b), Maybe (k, b)) + [A] cumulative :: Fold m (a, Maybe a) b -> Fold m a b + [A] countDistinctInt :: Monad m => Fold m Int Int + [A] countDistinct :: (Monad m, Ord a) => Fold m a Int + [A] classifyIO :: (MonadIO m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (m (Map k b), Maybe (k, b)) + [A] classifyGenericIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (m (f b), Maybe (Key f, b)) + [A] classifyGeneric :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (m (f b), Maybe (Key f, b)) + [A] classify :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (m (Map k b), Maybe (k, b)) + [A] chainStepM :: Applicative m => (s1 -> m s2) -> (a -> m (Step s2 b)) -> Step s1 a -> m (Step s2 b) +[C] Streamly.Internal.Data.Builder + [C] Builder + [C] Builder + [O] Builder :: (s -> m (s, a)) -> Builder s m a + [N] Builder :: (s -> m (a, s)) -> Builder s m a +[A] Streamly.Internal.Data.Binary.Stream + [A] class ToBytes a + [A] word8 :: Applicative m => Word8 -> Stream m Word8 + [A] word64le :: Monad m => Word64 -> Stream m Word8 + [A] word64host :: Monad m => Word64 -> Stream m Word8 + [A] word64be :: Monad m => Word64 -> Stream m Word8 + [A] word32le :: Monad m => Word32 -> Stream m Word8 + [A] word32be :: Monad m => Word32 -> Stream m Word8 + [A] word16le :: Monad m => Word16 -> Stream m Word8 + [A] word16be :: Monad m => Word16 -> Stream m Word8 + [A] unit :: Applicative m => Stream m Word8 + [A] toBytes :: ToBytes a => a -> Stream m Word8 + [A] ordering :: Applicative m => Ordering -> Stream m Word8 + [A] int8 :: Applicative m => Int8 -> Stream m Word8 + [A] int64le :: Monad m => Int64 -> Stream m Word8 + [A] int64be :: Monad m => Int64 -> Stream m Word8 + [A] int32le :: Monad m => Int32 -> Stream m Word8 + [A] int32be :: Monad m => Int32 -> Stream m Word8 + [A] int16le :: Monad m => Int16 -> Stream m Word8 + [A] int16be :: Monad m => Int16 -> Stream m Word8 + [A] float32le :: Monad m => Float -> Stream m Word8 + [A] float32be :: Monad m => Float -> Stream m Word8 + [A] double64le :: Monad m => Double -> Stream m Word8 + [A] double64be :: Monad m => Double -> Stream m Word8 + [A] charUtf8 :: Monad m => Char -> Stream m Word8 + [A] charLatin1 :: Applicative m => Char -> Stream m Word8 + [A] bool :: Applicative m => Bool -> Stream m Word8 +[A] Streamly.Internal.Data.Binary.Parser + [A] class FromBytes a + [A] word8 :: Monad m => Parser Word8 m Word8 + [A] word64le :: Monad m => Parser Word8 m Word64 + [A] word64host :: MonadIO m => Parser Word8 m Word64 + [A] word64be :: Monad m => Parser Word8 m Word64 + [A] word32le :: Monad m => Parser Word8 m Word32 + [A] word32be :: Monad m => Parser Word8 m Word32 + [A] word16le :: Monad m => Parser Word8 m Word16 + [A] word16be :: Monad m => Parser Word8 m Word16 + [A] unit :: Monad m => Parser Word8 m () + [A] ordering :: Monad m => Parser Word8 m Ordering + [A] int8 :: Monad m => Parser Word8 m Int8 + [A] int64le :: Monad m => Parser Word8 m Int64 + [A] int64be :: Monad m => Parser Word8 m Int64 + [A] int32le :: Monad m => Parser Word8 m Int32 + [A] int32be :: Monad m => Parser Word8 m Int32 + [A] int16le :: Monad m => Parser Word8 m Int16 + [A] int16be :: Monad m => Parser Word8 m Int16 + [A] fromBytes :: FromBytes a => Parser Word8 m a + [A] float32le :: MonadIO m => Parser Word8 m Float + [A] float32be :: MonadIO m => Parser Word8 m Float + [A] eqWord8 :: Monad m => Word8 -> Parser Word8 m Word8 + [A] double64le :: MonadIO m => Parser Word8 m Double + [A] double64be :: MonadIO m => Parser Word8 m Double + [A] charLatin1 :: Monad m => Parser Word8 m Char + [A] bool :: Monad m => Parser Word8 m Bool +[R] Streamly.Internal.Data.Array.Type +[A] Streamly.Internal.Data.Array.Stream + [A] unlines :: forall m a. (MonadIO m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [A] toArray :: (MonadIO m, Unbox a) => Stream m (Array a) -> m (Array a) + [A] splitOnSuffix :: MonadIO m => Word8 -> Stream m (Array Word8) -> Stream m (Array Word8) + [A] splitOn :: MonadIO m => Word8 -> Stream m (Array Word8) -> Stream m (Array Word8) + [A] runArrayParserDBreak :: forall m a b. (MonadIO m, Unbox a) => Parser (Array a) m b -> Stream m (Array a) -> m (Either ParseError b, Stream m (Array a)) + [A] runArrayFoldMany :: (Monad m, Unbox a) => ChunkFold m a b -> StreamK m (Array a) -> StreamK m (Either ParseError b) + [A] runArrayFoldBreak :: (MonadIO m, Unbox a) => ChunkFold m a b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] runArrayFold :: (MonadIO m, Unbox a) => ChunkFold m a b -> StreamK m (Array a) -> m (Either ParseError b) + [A] pinnedChunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (Array a) + [A] parseChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [A] parseBreakChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] parseBreak :: (MonadIO m, Unbox a) => Parser a m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] lpackArraysChunksOf :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) () -> Fold m (Array a) () + [A] interposeSuffix :: (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [A] interpose :: (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [A] intercalateSuffix :: (Monad m, Unbox a) => Array a -> Stream m (Array a) -> Stream m a + [A] foldBreakD :: forall m a b. (MonadIO m, Unbox a) => Fold m a b -> Stream m (Array a) -> m (b, Stream m (Array a)) + [A] foldBreak :: (MonadIO m, Unbox a) => Fold m a b -> StreamK m (Array a) -> m (b, StreamK m (Array a)) + [A] flattenArraysRev :: forall m a. (MonadIO m, Unbox a) => Stream m (Array a) -> Stream m a + [A] flattenArrays :: forall m a. (MonadIO m, Unbox a) => Stream m (Array a) -> Stream m a + [A] concatRev :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a + [A] concat :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a + [A] compact :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [A] chunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (Array a) + [A] bufferChunks :: (MonadIO m, Unbox a) => Stream m a -> m (StreamK m (Array a)) +[R] Streamly.Internal.Data.Array.Mut.Type +[R] Streamly.Internal.Data.Array.Mut.Stream +[R] Streamly.Internal.Data.Array.Mut +[R] Streamly.Internal.Data.Array.Generic.Mut.Type +[C] Streamly.Internal.Data.Array.Generic + [A] getIndex :: Int -> Array a -> Maybe a + [A] fromPureStream :: Stream Identity a -> Array a + [A] fromByteStr# :: Addr# -> Array Word8 + [A] chunksOf :: forall m a. MonadIO m => Int -> Stream m a -> Stream m (Array a) +[C] Streamly.Internal.Data.Array + [A] ArrayUnsafe + [A] ArrayUnsafe :: {-# UNPACK #-} !MutByteArray -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> ArrayUnsafe a + [C] Array + [A] [arrStart] :: Array a -> {-# UNPACK #-} !Int + [A] [arrEnd] :: Array a -> {-# UNPACK #-} !Int + [A] [arrContents] :: Array a -> {-# UNPACK #-} !MutByteArray + [A] Array :: {-# UNPACK #-} !MutByteArray -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> Array a + [A] writeWith :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] writeNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [R] writeNAligned :: forall m a. (MonadIO m, Unbox a) => Int -> Int -> Fold m a (Array a) + [A] unsafeMakePure :: Monad m => Fold IO a b -> Fold m a b + [A] unsafeIndexIO :: forall a. Unbox a => Int -> Array a -> IO a + [D] unsafeIndex :: forall a. Unbox a => Int -> Array a -> a + [A] unsafeFreezeWithShrink :: Unbox a => MutArray a -> Array a + [A] unpin :: Array a -> IO (Array a) + [A] toStreamKRev :: forall m a. (Monad m, Unbox a) => Array a -> StreamK m a + [A] toStreamK :: forall m a. (Monad m, Unbox a) => Array a -> StreamK m a + [A] toStreamDRev :: forall m a. (Monad m, Unbox a) => Array a -> Stream m a + [A] toStreamD :: forall m a. (Monad m, Unbox a) => Array a -> Stream m a + [A] splitAt :: Unbox a => Int -> Array a -> (Array a, Array a) + [A] splice :: (MonadIO m, Unbox a) => Array a -> Array a -> m (Array a) + [A] serialize :: Serialize a => a -> Array Word8 + [A] pinnedWriteNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] pinnedWriteNAligned :: forall m a. (MonadIO m, Unbox a) => Int -> Int -> Fold m a (Array a) + [A] pinnedWriteN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] pinnedWrite :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [A] pinnedSerialize :: Serialize a => a -> Array Word8 + [A] pinnedFromListN :: Unbox a => Int -> [a] -> Array a + [A] pinnedFromList :: Unbox a => [a] -> Array a + [A] pinnedClone :: MonadIO m => Array a -> m (Array a) + [A] pinnedChunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (Array a) + [A] pin :: Array a -> IO (Array a) + [A] nil :: Array a + [A] isPinned :: Array a -> Bool + [A] getIndexUnsafe :: forall a. Unbox a => Int -> Array a -> a + [A] fromStreamDN :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> m (Array a) + [A] fromStreamD :: forall m a. (MonadIO m, Unbox a) => Stream m a -> m (Array a) + [A] fromPureStream :: Unbox a => Stream Identity a -> Array a + [A] fromListRevN :: Unbox a => Int -> [a] -> Array a + [A] fromListRev :: Unbox a => [a] -> Array a + [A] fromByteStr# :: Addr# -> Array Word8 + [A] foldr :: Unbox a => (a -> b -> b) -> b -> Array a -> b + [A] foldl' :: forall a b. Unbox a => (b -> a -> b) -> b -> Array a -> b + [A] flattenArraysRev :: forall m a. (MonadIO m, Unbox a) => Stream m (Array a) -> Stream m a + [A] flattenArrays :: forall m a. (MonadIO m, Unbox a) => Stream m (Array a) -> Stream m a + [A] encodeAs :: forall a. Serialize a => PinnedState -> a -> Array Word8 + [A] deserialize :: Serialize a => Array Word8 -> a + [A] clone :: MonadIO m => Array a -> m (Array a) + [A] chunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (Array a) + [A] byteLength :: Array a -> Int + [A] bufferChunks :: (MonadIO m, Unbox a) => Stream m a -> m (StreamK m (Array a)) + [A] breakOn :: MonadIO m => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8)) diff --git a/docs/ApiChangelogs/0.2.0-0.2.2.txt b/docs/ApiChangelogs/0.2.0-0.2.2.txt new file mode 100644 --- /dev/null +++ b/docs/ApiChangelogs/0.2.0-0.2.2.txt @@ -0,0 +1,306 @@ +--------------------------------- +API Annotations +--------------------------------- + +[A] : Added +[R] : Removed +[C] : Changed +[O] : Old definition +[N] : New definition +[D] : Deprecated + +--------------------------------- +API diff +--------------------------------- + +[C] Streamly.Data.Stream + [A] (FixityR,5) + [A] (FixityR,5) +[C] Streamly.Data.MutArray.Generic + [A] emptyOf :: MonadIO m => Int -> m (MutArray a) + [A] createOf :: MonadIO m => Int -> Fold m a (MutArray a) + [A] create :: MonadIO m => Fold m a (MutArray a) +[C] Streamly.Data.MutArray + [A] pinnedEmptyOf :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] emptyOf :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] createOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] create :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [A] appendN :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [A] append :: forall m a. (MonadIO m, Unbox a) => m (MutArray a) -> Fold m a (MutArray a) +[C] Streamly.Data.Array.Generic + [A] createOf :: MonadIO m => Int -> Fold m a (Array a) + [A] create :: MonadIO m => Fold m a (Array a) +[C] Streamly.Data.Array + [A] class Serialize a + [A] serializeAt :: Serialize a => Int -> MutByteArray -> a -> IO Int + [A] pinnedSerialize :: Serialize a => a -> Array Word8 + [A] deserializeAt :: Serialize a => Int -> MutByteArray -> Int -> IO (Int, a) + [A] deserialize :: Serialize a => Array Word8 -> a + [A] createOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] create :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [A] addSizeTo :: Serialize a => Int -> a -> Int + +--------------------------------- +Internal API diff +--------------------------------- + +[C] Streamly.Internal.Unicode.Stream + [A] encodeUtf16le' :: Stream m Char -> Stream m Word16 + [A] decodeUtf16le' :: Stream m Word16 -> Stream m Char +[A] Streamly.Internal.FileSystem.Path + [A] class IsPath a + [A] Rel + [A] File + [A] Dir + [A] Abs + [A] Streamly.Internal.FileSystem.Path.IsPath + [A] instance Streamly.Internal.FileSystem.Path.IsPath Streamly.Internal.FileSystem.Path.Path + [A] instance Streamly.Internal.FileSystem.Path.IsPath (Streamly.Internal.FileSystem.Path.Rel Streamly.Internal.FileSystem.Path.Path) + [A] instance Streamly.Internal.FileSystem.Path.IsPath (Streamly.Internal.FileSystem.Path.Rel (Streamly.Internal.FileSystem.Path.File Streamly.Internal.FileSystem.Path.Path)) + [A] instance Streamly.Internal.FileSystem.Path.IsPath (Streamly.Internal.FileSystem.Path.Rel (Streamly.Internal.FileSystem.Path.Dir Streamly.Internal.FileSystem.Path.Path)) + [A] instance Streamly.Internal.FileSystem.Path.IsPath (Streamly.Internal.FileSystem.Path.File Streamly.Internal.FileSystem.Path.Path) + [A] instance Streamly.Internal.FileSystem.Path.IsPath (Streamly.Internal.FileSystem.Path.Dir Streamly.Internal.FileSystem.Path.Path) + [A] instance Streamly.Internal.FileSystem.Path.IsPath (Streamly.Internal.FileSystem.Path.Abs Streamly.Internal.FileSystem.Path.Path) + [A] instance Streamly.Internal.FileSystem.Path.IsPath (Streamly.Internal.FileSystem.Path.Abs (Streamly.Internal.FileSystem.Path.File Streamly.Internal.FileSystem.Path.Path)) + [A] instance Streamly.Internal.FileSystem.Path.IsPath (Streamly.Internal.FileSystem.Path.Abs (Streamly.Internal.FileSystem.Path.Dir Streamly.Internal.FileSystem.Path.Path)) + [A] GHC.Show.Show + [A] instance GHC.Show.Show Streamly.Internal.FileSystem.Path.PathException + [A] GHC.Exception.Type.Exception + [A] instance GHC.Exception.Type.Exception Streamly.Internal.FileSystem.Path.PathException + [A] GHC.Classes.Eq + [A] instance GHC.Classes.Eq Streamly.Internal.FileSystem.Path.PathException + [A] Path + [A] Path :: Array Word8 -> Path + [A] toString :: Path -> [Char] + [A] toPath :: IsPath a => a -> Path + [A] toChunk :: Path -> Array Word8 + [A] toChars :: Monad m => Path -> Stream m Char + [A] relfile :: QuasiQuoter + [A] reldir :: QuasiQuoter + [A] rel :: QuasiQuoter + [A] primarySeparator :: Char + [A] path :: QuasiQuoter + [A] mkRelFile :: String -> Q Exp + [A] mkRelDir :: String -> Q Exp + [A] mkRel :: String -> Q Exp + [A] mkPath :: String -> Q Exp + [A] mkFile :: String -> Q Exp + [A] mkDir :: String -> Q Exp + [A] mkAbsFile :: String -> Q Exp + [A] mkAbsDir :: String -> Q Exp + [A] mkAbs :: String -> Q Exp + [A] isSeparator :: Char -> Bool + [A] fromString :: MonadThrow m => [Char] -> m Path + [A] fromPathUnsafe :: IsPath a => Path -> a + [A] fromPath :: (IsPath a, MonadThrow m) => Path -> m a + [A] fromChunkUnsafe :: Array Word8 -> Path + [A] fromChunk :: MonadThrow m => Array Word8 -> m Path + [A] fromChars :: MonadThrow m => Stream Identity Char -> m Path + [A] file :: QuasiQuoter + [A] extendPath :: Path -> Path -> Path + [A] extendDir :: (IsPath (a (Dir Path)), IsPath b, IsPath (a b)) => a (Dir Path) -> Rel b -> a b + [A] dir :: QuasiQuoter + [A] adaptPath :: (MonadThrow m, IsPath a, IsPath b) => a -> m b + [A] absfile :: QuasiQuoter + [A] absdir :: QuasiQuoter + [A] abs :: QuasiQuoter +[C] Streamly.Internal.Data.Stream + [A] (FixityR,5) + [A] (FixityR,5) + [C] splitInnerBySuffix + [O] splitInnerBySuffix :: (Monad m, Eq (f a), Monoid (f a)) => (f a -> m (f a, Maybe (f a))) -> (f a -> f a -> m (f a)) -> Stream m (f a) -> Stream m (f a) + [N] splitInnerBySuffix :: Monad m => (f a -> Bool) -> (f a -> m (f a, Maybe (f a))) -> (f a -> f a -> m (f a)) -> Stream m (f a) -> Stream m (f a) + [D] sliceOnSuffix :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) + [A] indexOnSuffix :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) +[C] Streamly.Internal.Data.MutByteArray + [A] unsafePinnedAsPtr :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b + [A] unsafeAsPtr :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b + [D] nil :: MutByteArray + [A] empty :: MutByteArray + [D] asPtrUnsafe :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b +[D] Streamly.Internal.Data.MutArray.Stream + [D] writeChunks :: (MonadIO m, Unbox a) => Int -> Fold m a (StreamK n (MutArray a)) + [D] fromArrayStreamK :: (Unbox a, MonadIO m) => StreamK m (MutArray a) -> m (MutArray a) + [D] flattenArraysRev :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a + [D] flattenArrays :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a +[C] Streamly.Internal.Data.MutArray.Generic + [D] writeWith :: MonadIO m => Int -> Fold m a (MutArray a) + [D] writeNUnsafe :: MonadIO m => Int -> Fold m a (MutArray a) + [A] unsafeCreateOf :: MonadIO m => Int -> Fold m a (MutArray a) + [A] emptyOf :: MonadIO m => Int -> m (MutArray a) + [A] createWith :: MonadIO m => Int -> Fold m a (MutArray a) + [A] createOf :: MonadIO m => Int -> Fold m a (MutArray a) + [A] create :: MonadIO m => Fold m a (MutArray a) +[C] Streamly.Internal.Data.MutArray + [A] SpliceState + [A] SpliceYielding :: arr -> SpliceState s arr -> SpliceState s arr + [A] SpliceInitial :: s -> SpliceState s arr + [A] SpliceFinish :: SpliceState s arr + [A] SpliceBuffering :: s -> arr -> SpliceState s arr + [R] MutByteArray + [D] writeWith :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] writeRevN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] writeNWithUnsafe :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [D] writeNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] writeChunks :: (MonadIO m, Unbox a) => Int -> Fold m a (StreamK n (MutArray a)) + [D] writeAppendWith :: forall m a. (MonadIO m, Unbox a) => (Int -> Int) -> m (MutArray a) -> Fold m a (MutArray a) + [D] writeAppendNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [A] unsafePinnedCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] unsafePinnedAsPtr :: MonadIO m => MutArray a -> (Ptr a -> m b) -> m b + [A] unsafeCreateOfWith :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [A] unsafeCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] unsafeAsPtr :: MonadIO m => MutArray a -> (Ptr a -> m b) -> m b + [A] unsafeAppendN :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [A] toStreamWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> MutArray a -> Stream m a + [A] toStreamRevWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> MutArray a -> Stream m a + [R] toStreamDWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> MutArray a -> Stream m a + [R] toStreamDRevWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> MutArray a -> Stream m a + [A] slicerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (MutArray a) + [A] sliceIndexerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (Int, Int) + [A] revCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] resizeExp :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [D] resize :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [A] pokeSkipUnsafe :: Int -> MutArray Word8 -> MutArray Word8 + [A] pokeAppendMay :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> a -> m (Maybe (MutArray Word8)) + [A] pokeAppend :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> a -> m (MutArray Word8) + [D] pinnedWriteNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] pinnedWriteN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] pinnedWrite :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [D] pinnedNewBytes :: MonadIO m => Int -> m (MutArray a) + [A] pinnedEmptyOf :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] pinnedCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] pinnedCreate :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [A] pinnedCompactLE :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] peekUnconsUnsafe :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> m (a, MutArray Word8) + [A] peekUncons :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> m (Maybe a, MutArray Word8) + [A] peekSkipUnsafe :: Int -> MutArray Word8 -> MutArray Word8 + [A] pPinnedCompactLE :: forall m a. (MonadIO m, Unbox a) => Int -> Parser (MutArray a) m (MutArray a) + [A] pCompactLE :: forall m a. (MonadIO m, Unbox a) => Int -> Parser (MutArray a) m (MutArray a) + [D] nil :: MutArray a + [A] lPinnedCompactGE :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () + [A] lCompactGE :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () + [A] indexReaderWith :: (Monad m, Unbox a) => (forall b. IO b -> m b) -> Stream m Int -> Unfold m (MutArray a) a + [A] indexReader :: (MonadIO m, Unbox a) => Stream m Int -> Unfold m (MutArray a) a + [A] growExp :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [A] grow :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [D] getSlicesFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (MutArray a) + [R] getIndicesD :: (Monad m, Unbox a) => (forall b. IO b -> m b) -> Stream m Int -> Unfold m (MutArray a) a + [D] getIndices :: (MonadIO m, Unbox a) => Stream m Int -> Unfold m (MutArray a) a + [D] genSlicesFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (Int, Int) + [A] fromStreamN :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> m (MutArray a) + [D] fromStreamDN :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> m (MutArray a) + [D] fromStreamD :: (MonadIO m, Unbox a) => Stream m a -> m (MutArray a) + [A] fromPureStreamN :: (MonadIO m, Unbox a) => Int -> Stream Identity a -> m (MutArray a) + [A] fromPtrN :: MonadIO m => Int -> Ptr Word8 -> m (MutArray Word8) + [A] fromChunksRealloced :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> m (MutArray a) + [A] fromChunksK :: (Unbox a, MonadIO m) => StreamK m (MutArray a) -> m (MutArray a) + [A] fromByteStr# :: MonadIO m => Addr# -> m (MutArray Word8) + [D] fromArrayStreamK :: (Unbox a, MonadIO m) => StreamK m (MutArray a) -> m (MutArray a) + [D] flattenArraysRev :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a + [D] flattenArrays :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a + [A] fPinnedCompactGE :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) (MutArray a) + [A] fCompactGE :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) (MutArray a) + [A] emptyOf :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] empty :: MutArray a + [A] createWith :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] createOfWith :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [A] createOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] create :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [A] concatWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> Stream m (MutArray a) -> Stream m a + [A] concatRevWith :: forall m a. (Monad m, Unbox a) => (forall b. IO b -> m b) -> Stream m (MutArray a) -> Stream m a + [A] concatRev :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a + [A] concat :: forall m a. (MonadIO m, Unbox a) => Stream m (MutArray a) -> Stream m a + [A] compactOnByteSuffix :: MonadIO m => Word8 -> Stream m (MutArray Word8) -> Stream m (MutArray Word8) + [A] compactOnByte :: MonadIO m => Word8 -> Stream m (MutArray Word8) -> Stream m (MutArray Word8) + [A] compactLeAs :: forall m a. (MonadIO m, Unbox a) => PinnedState -> Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] compactLE :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] compactGE :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] compactEQ :: Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [D] cmp :: MonadIO m => MutArray a -> MutArray a -> m Ordering + [A] byteEq :: MonadIO m => MutArray a -> MutArray a -> m Bool + [A] byteCmp :: MonadIO m => MutArray a -> MutArray a -> m Ordering + [A] buildChunks :: (MonadIO m, Unbox a) => Int -> Fold m a (StreamK n (MutArray a)) + [D] asPtrUnsafe :: MonadIO m => MutArray a -> (Ptr a -> m b) -> m b + [A] appendWith :: forall m a. (MonadIO m, Unbox a) => (Int -> Int) -> m (MutArray a) -> Fold m a (MutArray a) + [A] appendN :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [A] append :: forall m a. (MonadIO m, Unbox a) => m (MutArray a) -> Fold m a (MutArray a) +[D] Streamly.Internal.Data.Array.Stream + [C] interposeSuffix + [O] interposeSuffix :: (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [N] interposeSuffix :: forall m a. (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [D] flattenArraysRev :: forall m a. (MonadIO m, Unbox a) => Stream m (Array a) -> Stream m a + [D] flattenArrays :: forall m a. (MonadIO m, Unbox a) => Stream m (Array a) -> Stream m a + [C] concatRev + [O] concatRev :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a + [N] concatRev :: forall m a. (Monad m, Unbox a) => Stream m (Array a) -> Stream m a + [D] bufferChunks :: (MonadIO m, Unbox a) => Stream m a -> m (StreamK m (Array a)) +[C] Streamly.Internal.Data.Array.Generic + [A] createOf :: MonadIO m => Int -> Fold m a (Array a) + [A] create :: MonadIO m => Fold m a (Array a) +[C] Streamly.Internal.Data.Array + [R] ArrayUnsafe + [D] writeWith :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [D] writeNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] unsafePinnedCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] unsafePinnedAsPtr :: MonadIO m => Array a -> (Ptr a -> m b) -> m b + [A] unsafeCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [D] toStreamDRev :: forall m a. (Monad m, Unbox a) => Array a -> Stream m a + [D] toStreamD :: forall m a. (Monad m, Unbox a) => Array a -> Stream m a + [C] splice + [O] splice :: (MonadIO m, Unbox a) => Array a -> Array a -> m (Array a) + [N] splice :: MonadIO m => Array a -> Array a -> m (Array a) + [A] slicerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (Array a) (Array a) + [A] sliceIndexerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (Array a) (Int, Int) + [D] pinnedWriteNUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [D] pinnedWriteNAligned :: forall m a. (MonadIO m, Unbox a) => Int -> Int -> Fold m a (Array a) + [D] pinnedWriteN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [D] pinnedWrite :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [A] pinnedCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] pinnedCreate :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [A] pinnedCompactLE :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [A] parseBreakChunksK :: forall m a b. (MonadIO m, Unbox a) => Parser a m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [D] nil :: Array a + [A] lPinnedCompactGE :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) () -> Fold m (Array a) () + [A] lCompactGE :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) () -> Fold m (Array a) () + [A] interposeSuffix :: forall m a. (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [A] interpose :: (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [A] intercalateSuffix :: (Monad m, Unbox a) => Array a -> Stream m (Array a) -> Stream m a + [A] indexReaderFromThenTo :: Unfold m (Int, Int, Int, Array a) a + [A] indexReader :: (Monad m, Unbox a) => Stream m Int -> Unfold m (Array a) a + [A] indexFinder :: (a -> Bool) -> Unfold Identity (Array a) Int + [D] getSlicesFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (Array a) (Array a) + [R] getIndicesFromThenTo :: Unfold m (Int, Int, Int, Array a) a + [D] getIndices :: (Monad m, Unbox a) => Stream m Int -> Unfold m (Array a) a + [D] genSlicesFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (Array a) (Int, Int) + [D] fromStreamDN :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> m (Array a) + [D] fromStreamD :: forall m a. (MonadIO m, Unbox a) => Stream m a -> m (Array a) + [A] fromPureStreamN :: Unbox a => Int -> Stream Identity a -> Array a + [A] fromPtrN :: Int -> Ptr Word8 -> Array Word8 + [A] fromChunksK :: (MonadIO m, Unbox a) => StreamK m (Array a) -> m (Array a) + [A] fromChunks :: (MonadIO m, Unbox a) => Stream m (Array a) -> m (Array a) + [A] fromByteStr :: Ptr Word8 -> Array Word8 + [A] foldChunks :: (MonadIO m, Unbox a) => Fold m a b -> Stream m (Array a) -> m b + [A] foldBreakChunksK :: forall m a b. (MonadIO m, Unbox a) => Fold m a b -> StreamK m (Array a) -> m (b, StreamK m (Array a)) + [A] foldBreakChunks :: forall m a b. (MonadIO m, Unbox a) => Fold m a b -> Stream m (Array a) -> m (b, Stream m (Array a)) + [D] flattenArraysRev :: forall m a. (MonadIO m, Unbox a) => Stream m (Array a) -> Stream m a + [D] flattenArrays :: forall m a. (MonadIO m, Unbox a) => Stream m (Array a) -> Stream m a + [C] findIndicesOf + [O] findIndicesOf :: (a -> Bool) -> Unfold Identity (Array a) Int + [N] findIndicesOf :: (a -> Bool) -> Array a -> Stream Identity Int + [A] fPinnedCompactGE :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) (Array a) + [A] fCompactGE :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) (Array a) + [A] empty :: Array a + [A] createWith :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] createOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] create :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [A] concatRev :: forall m a. (Monad m, Unbox a) => Stream m (Array a) -> Stream m a + [A] concat :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a + [A] compactOnByteSuffix :: MonadIO m => Word8 -> Stream m (Array Word8) -> Stream m (Array Word8) + [A] compactOnByte :: MonadIO m => Word8 -> Stream m (Array Word8) -> Stream m (Array Word8) + [A] compactLE :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [A] compactGE :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [A] byteEq :: Array a -> Array a -> Bool + [A] byteCmp :: Array a -> Array a -> Ordering + [A] buildChunks :: (MonadIO m, Unbox a) => Stream m a -> m (StreamK m (Array a)) + [D] bufferChunks :: (MonadIO m, Unbox a) => Stream m a -> m (StreamK m (Array a)) + [D] asPtrUnsafe :: MonadIO m => Array a -> (Ptr a -> m b) -> m b diff --git a/docs/ApiChangelogs/0.2.2-0.3.0.txt b/docs/ApiChangelogs/0.2.2-0.3.0.txt new file mode 100644 --- /dev/null +++ b/docs/ApiChangelogs/0.2.2-0.3.0.txt @@ -0,0 +1,1889 @@ +--------------------------------- +API Annotations +--------------------------------- + +[A] : Added +[R] : Removed +[C] : Changed +[O] : Old definition +[N] : New definition +[D] : Deprecated + +--------------------------------- +API diff +--------------------------------- + +[C] Streamly.Unicode.Stream + [A] encodeUtf16le' :: Monad m => Stream m Char -> Stream m Word16 + [A] encodeUtf16le :: Monad m => Stream m Char -> Stream m Word16 + [A] decodeUtf16le' :: Monad m => Stream m Word16 -> Stream m Char + [A] decodeUtf16le :: Monad m => Stream m Word16 -> Stream m Char +[A] Streamly.FileSystem.Path + [A] EqCfg + [A] type Path = PosixPath + [A] type OsWord = Word8 + [A] validatePath :: MonadThrow m => Array OsWord -> m () + [A] unsafeJoin :: Path -> Path -> Path + [A] toString :: Path -> [Char] + [A] toArray :: Path -> Array OsWord + [A] takeFileName :: Path -> Maybe Path + [A] takeFileBase :: Path -> Maybe Path + [A] takeExtension :: Path -> Maybe Path + [A] takeDirectory :: Path -> Maybe Path + [A] splitRoot :: Path -> Maybe (Path, Maybe Path) + [A] splitPath :: Monad m => Path -> Stream m Path + [A] splitFile :: Path -> Maybe (Maybe Path, Path) + [A] splitExtension :: Path -> Maybe (Path, Path) + [A] pathE :: String -> Q Exp + [A] path :: QuasiQuoter + [A] joinStr :: Path -> [Char] -> Path + [A] join :: Path -> Path -> Path + [A] isUnrooted :: Path -> Bool + [A] isRooted :: Path -> Bool + [A] ignoreTrailingSeparators :: Bool -> EqCfg -> EqCfg + [A] ignoreCase :: Bool -> EqCfg -> EqCfg + [A] fromString_ :: [Char] -> Path + [A] fromString :: MonadThrow m => [Char] -> m Path + [A] fromArray :: MonadThrow m => Array OsWord -> m Path + [A] eqPath :: (EqCfg -> EqCfg) -> Path -> Path -> Bool + [A] dropExtension :: Path -> Path + [A] allowRelativeEquality :: Bool -> EqCfg -> EqCfg +[C] Streamly.FileSystem.Handle + [C] writeChunks + [O] writeChunks :: MonadIO m => Handle -> Fold m (Array a) () + [N] writeChunks :: forall m (a :: Type). MonadIO m => Handle -> Fold m (Array a) () + [C] putChunk + [O] putChunk :: MonadIO m => Handle -> Array a -> m () + [N] putChunk :: forall m (a :: Type). MonadIO m => Handle -> Array a -> m () +[A] Streamly.FileSystem.FileIO + [A] writeWith :: (MonadIO m, MonadCatch m) => Int -> Path -> Fold m Word8 () + [A] writeChunks :: (MonadIO m, MonadCatch m) => Path -> Fold m (Array a) () + [A] write :: (MonadIO m, MonadCatch m) => Path -> Fold m Word8 () + [A] withFile :: (MonadIO m, MonadCatch m) => Path -> IOMode -> (Handle -> Stream m a) -> Stream m a + [A] readChunksWith :: (MonadIO m, MonadCatch m) => Int -> Path -> Stream m (Array Word8) + [A] readChunks :: (MonadIO m, MonadCatch m) => Path -> Stream m (Array Word8) + [A] read :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 +[D] Streamly.FileSystem.File + [C] writeChunks + [O] writeChunks :: (MonadIO m, MonadCatch m) => FilePath -> Fold m (Array a) () + [N] writeChunks :: forall m (a :: Type). (MonadIO m, MonadCatch m) => FilePath -> Fold m (Array a) () +[A] Streamly.FileSystem.DirIO + [A] ReadOptions + [A] readEither :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Path -> Stream m (Either Path Path) + [A] read :: (MonadIO m, MonadCatch m) => Path -> Stream m Path + [A] ignoreSymlinkLoops :: Bool -> ReadOptions -> ReadOptions + [A] ignoreMissing :: Bool -> ReadOptions -> ReadOptions + [A] ignoreInaccessible :: Bool -> ReadOptions -> ReadOptions + [A] followSymlinks :: Bool -> ReadOptions -> ReadOptions +[D] Streamly.FileSystem.Dir +[C] Streamly.Data.Unfold + [A] unfoldEach :: Monad m => Unfold m b c -> Unfold m a b -> Unfold m a c + [D] many :: Monad m => Unfold m b c -> Unfold m a b -> Unfold m a c + [A] carry :: Functor m => Unfold m a b -> Unfold m a (a, b) +[C] Streamly.Data.StreamK + [A] toParserK :: Monad m => Parser a m b -> ParserK a m b + [A] toList :: Monad m => StreamK m a -> m [a] + [A] parsePos :: Monad m => ParserK a m b -> StreamK m a -> m (Either ParseErrorPos b) + [D] parseChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [A] parseBreakPos :: forall m a b. Monad m => ParserK a m b -> StreamK m a -> m (Either ParseErrorPos b, StreamK m a) + [D] parseBreakChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] filter :: (a -> Bool) -> StreamK m a -> StreamK m a + [A] fairConcatMap :: (a -> StreamK m b) -> StreamK m a -> StreamK m b + [A] fairConcatForM :: Monad m => StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b + [A] fairConcatFor :: StreamK m a -> (a -> StreamK m b) -> StreamK m b + [A] concatMap :: (a -> StreamK m b) -> StreamK m a -> StreamK m b + [A] concatForM :: Monad m => StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b + [A] concatFor :: StreamK m a -> (a -> StreamK m b) -> StreamK m b + [A] bfsConcatMap :: (a -> StreamK m b) -> StreamK m a -> StreamK m b + [A] bfsConcatForM :: Monad m => StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b + [A] bfsConcatFor :: StreamK m a -> (a -> StreamK m b) -> StreamK m b +[C] Streamly.Data.Stream + [A] unionBy :: MonadIO m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [D] unfoldMany :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] unfoldEachSepBySeq :: Monad m => b -> Unfold m b c -> Stream m b -> Stream m c + [A] unfoldEachEndBySeq :: Monad m => b -> Unfold m b c -> Stream m b -> Stream m c + [A] unfoldEach :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] splitSepBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] splitSepBySeq_ :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Stream m a -> Stream m b + [D] splitOn :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] splitEndBySeq_ :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Stream m a -> Stream m b + [A] splitEndBySeq :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Stream m a -> Stream m b + [A] scanl :: Monad m => Scanl m a b -> Stream m a -> Stream m b + [D] scanMaybe :: Monad m => Fold m a (Maybe b) -> Stream m a -> Stream m b + [D] scan :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] postscanl :: Monad m => Scanl m a b -> Stream m a -> Stream m b + [D] postscan :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] parsePos :: Monad m => Parser a m b -> Stream m a -> m (Either ParseErrorPos b) + [A] parseBreakPos :: Monad m => Parser a m b -> Stream m a -> m (Either ParseErrorPos b, Stream m a) + [A] parseBreak :: Monad m => Parser a m b -> Stream m a -> m (Either ParseError b, Stream m a) + [A] isInfixOf :: (MonadIO m, Eq a, Enum a, Unbox a) => Stream m a -> Stream m a -> m Bool + [D] intercalateSuffix :: Monad m => Unfold m b c -> b -> Stream m b -> Stream m c + [D] intercalate :: Monad m => Unfold m b c -> b -> Stream m b -> Stream m c + [A] finallyIO'' :: (MonadIO m, MonadCatch m) => AcquireIO -> IO b -> Stream m a -> Stream m a + [A] finallyIO' :: MonadIO m => AcquireIO -> IO b -> Stream m a -> Stream m a + [A] fairUnfoldEach :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] fairCross :: Monad m => Stream m a -> Stream m b -> Stream m (a, b) + [A] fairConcatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b + [A] fairConcatForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b + [A] fairConcatFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b + [A] cross :: Monad m => Stream m a -> Stream m b -> Stream m (a, b) + [A] concatForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b + [A] concatFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b + [D] chunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (Array a) + [A] bracketIO'' :: (MonadIO m, MonadCatch m) => AcquireIO -> IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a + [A] bracketIO' :: MonadIO m => AcquireIO -> IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a + [A] bfsUnfoldEach :: Monad m => Unfold m a b -> Stream m a -> Stream m b +[A] Streamly.Data.Scanl + [A] Scanl + [A] unzip :: Monad m => Scanl m a x -> Scanl m b y -> Scanl m (a, b) (x, y) + [A] uniqBy :: Monad m => (a -> a -> Bool) -> Scanl m a (Maybe a) + [A] topBy :: (MonadIO m, Unbox a) => (a -> a -> Ordering) -> Int -> Scanl m a (MutArray a) + [A] toSet :: (Monad m, Ord a) => Scanl m a (Set a) + [A] toListRev :: Monad m => Scanl m a [a] + [A] toList :: Monad m => Scanl m a [a] + [A] toIntSet :: Monad m => Scanl m Int IntSet + [A] the :: (Monad m, Eq a) => Scanl m a (Maybe a) + [A] teeWith :: Monad m => (b -> c -> d) -> Scanl m a b -> Scanl m a c -> Scanl m a d + [A] tee :: Monad m => Scanl m a b -> Scanl m a c -> Scanl m a (b, c) + [A] takeEndBy_ :: Monad m => (a -> Bool) -> Scanl m a b -> Scanl m a b + [A] takeEndBy :: Monad m => (a -> Bool) -> Scanl m a b -> Scanl m a b + [A] take :: Monad m => Int -> Scanl m a b -> Scanl m a b + [A] sum :: (Monad m, Num a) => Scanl m a a + [A] sconcat :: (Monad m, Semigroup a) => a -> Scanl m a a + [A] scanl :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c + [A] rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Scanl m a Int64 + [A] rollingHash :: (Monad m, Enum a) => Scanl m a Int64 + [A] rmapM :: Monad m => (b -> m c) -> Scanl m a b -> Scanl m a c + [A] product :: (Monad m, Num a, Eq a) => Scanl m a a + [A] postscanlMaybe :: Monad m => Scanl m a (Maybe b) -> Scanl m b c -> Scanl m a c + [A] postscanl :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c + [A] partition :: Monad m => Scanl m b x -> Scanl m c x -> Scanl m (Either b c) x + [A] nubInt :: Monad m => Scanl m Int (Maybe Int) + [A] nub :: (Monad m, Ord a) => Scanl m a (Maybe a) + [A] morphInner :: (forall x. m x -> n x) -> Scanl m a b -> Scanl n a b + [A] mkScanr :: Monad m => (a -> b -> b) -> b -> Scanl m a b + [A] mkScanlM :: Monad m => (b -> a -> m b) -> m b -> Scanl m a b + [A] mkScanl1M :: Monad m => (a -> a -> m a) -> Scanl m a (Maybe a) + [A] mkScanl1 :: Monad m => (a -> a -> a) -> Scanl m a (Maybe a) + [A] mkScanl :: Monad m => (b -> a -> b) -> b -> Scanl m a b + [A] minimumBy :: Monad m => (a -> a -> Ordering) -> Scanl m a (Maybe a) + [A] minimum :: (Monad m, Ord a) => Scanl m a (Maybe a) + [A] mean :: (Monad m, Fractional a) => Scanl m a a + [A] mconcat :: (Monad m, Monoid a) => Scanl m a a + [A] maximumBy :: Monad m => (a -> a -> Ordering) -> Scanl m a (Maybe a) + [A] maximum :: (Monad m, Ord a) => Scanl m a (Maybe a) + [A] mapMaybe :: Monad m => (a -> Maybe b) -> Scanl m b r -> Scanl m a r + [A] lmapM :: Monad m => (a -> m b) -> Scanl m b r -> Scanl m a r + [A] lmap :: (a -> b) -> Scanl m b r -> Scanl m a r + [A] length :: Monad m => Scanl m a Int + [A] latest :: Monad m => Scanl m a (Maybe a) + [A] foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Scanl m a b + [A] foldMap :: (Monad m, Monoid b) => (a -> b) -> Scanl m a b + [A] findIndices :: Monad m => (a -> Bool) -> Scanl m a (Maybe Int) + [A] filterM :: Monad m => (a -> m Bool) -> Scanl m a r -> Scanl m a r + [A] filter :: Monad m => (a -> Bool) -> Scanl m a r -> Scanl m a r + [A] elemIndices :: (Monad m, Eq a) => a -> Scanl m a (Maybe Int) + [A] drain :: Monad m => Scanl m a () + [A] distribute :: Monad m => [Scanl m a b] -> Scanl m a [b] + [A] demuxIO :: (MonadIO m, Ord k) => (a -> k) -> (k -> m (Maybe (Scanl m a b))) -> Scanl m a (Maybe (k, b)) + [A] demux :: (Monad m, Ord k) => (a -> k) -> (k -> m (Maybe (Scanl m a b))) -> Scanl m a (Maybe (k, b)) + [A] deleteBy :: Monad m => (a -> a -> Bool) -> a -> Scanl m a (Maybe a) + [A] countDistinctInt :: Monad m => Scanl m Int Int + [A] countDistinct :: (Monad m, Ord a) => Scanl m a Int + [A] classifyIO :: (MonadIO m, Ord k) => (a -> k) -> Scanl m a b -> Scanl m a (Maybe (k, b)) + [A] classify :: (MonadIO m, Ord k) => (a -> k) -> Scanl m a b -> Scanl m a (Maybe (k, b)) + [A] catRights :: Monad m => Scanl m b c -> Scanl m (Either a b) c + [A] catMaybes :: Monad m => Scanl m a b -> Scanl m (Maybe a) b + [A] catLefts :: Monad m => Scanl m a c -> Scanl m (Either a b) c + [A] catEithers :: Scanl m a b -> Scanl m (Either a a) b +[A] Streamly.Data.RingArray + [A] RingArray + [A] unsafeGetIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> m a + [A] unsafeGetHead :: (MonadIO m, Unbox a) => RingArray a -> m a + [A] toMutArray :: (MonadIO m, Unbox a) => RingArray a -> m (MutArray a) + [A] toList :: (MonadIO m, Unbox a) => RingArray a -> m [a] + [A] scanRingsOf :: forall m a. (MonadIO m, Unbox a) => Int -> Scanl m a (RingArray a) + [A] ringsOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (RingArray a) + [A] replace_ :: forall m a. (MonadIO m, Unbox a) => RingArray a -> a -> m (RingArray a) + [A] replace :: forall m a. (MonadIO m, Unbox a) => RingArray a -> a -> m (RingArray a, a) + [A] readerRev :: forall m a. (MonadIO m, Unbox a) => Unfold m (RingArray a) a + [A] reader :: forall m a. (MonadIO m, Unbox a) => Unfold m (RingArray a) a + [A] readRev :: forall m a. (MonadIO m, Unbox a) => RingArray a -> Stream m a + [A] read :: forall m a. (MonadIO m, Unbox a) => RingArray a -> Stream m a + [A] putIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> a -> m () + [A] moveReverse :: forall a. Unbox a => RingArray a -> RingArray a + [A] moveForward :: forall a. Unbox a => RingArray a -> RingArray a + [A] modifyIndex :: Int -> RingArray a -> (a -> (a, b)) -> m b + [A] length :: forall a. Unbox a => RingArray a -> Int + [A] insert :: RingArray a -> a -> m (RingArray a) + [A] getIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> m (Maybe a) + [A] fold :: forall m a b. (MonadIO m, Unbox a) => Fold m a b -> RingArray a -> m b + [A] eqArrayN :: RingArray a -> Array a -> Int -> IO Bool + [A] eqArray :: RingArray a -> Array a -> IO Bool + [A] createOfLast :: (Unbox a, MonadIO m) => Int -> Fold m a (RingArray a) + [A] castMutArrayWith :: forall a. Unbox a => Int -> MutArray a -> Maybe (RingArray a) + [A] castMutArray :: forall a. Unbox a => MutArray a -> Maybe (RingArray a) + [A] cast :: forall a b. Unbox b => RingArray a -> Maybe (RingArray b) + [A] byteLength :: RingArray a -> Int + [A] asMutArray :: RingArray a -> (MutArray a, Int) + [A] asBytes :: RingArray a -> RingArray Word8 +[C] Streamly.Data.ParserK + [D] adaptCG :: Monad m => Parser a m b -> ParserK (Array a) m b + [D] adaptC :: (Monad m, Unbox a) => Parser a m b -> ParserK (Array a) m b + [D] adapt :: Monad m => Parser a m b -> ParserK a m b +[C] Streamly.Data.Parser + [A] ParseErrorPos + [A] ParseErrorPos :: Int -> String -> ParseErrorPos + [A] ParseError + [A] ParseError :: String -> ParseError +[C] Streamly.Data.MutByteArray + [D] pinnedNew :: Int -> IO MutByteArray +[C] Streamly.Data.MutArray.Generic + [D] writeN :: MonadIO m => Int -> Fold m a (MutArray a) + [D] write :: MonadIO m => Fold m a (MutArray a) + [A] unsafePutIndex :: forall m a. MonadIO m => Int -> MutArray a -> a -> m () + [A] unsafeModifyIndex :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] unsafeGetIndex :: MonadIO m => Int -> MutArray a -> m a + [D] putIndexUnsafe :: forall m a. MonadIO m => Int -> MutArray a -> a -> m () + [D] new :: MonadIO m => Int -> m (MutArray a) + [D] modifyIndexUnsafe :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b + [D] getIndexUnsafe :: MonadIO m => Int -> MutArray a -> m a + [A] chunksOf :: forall m a. MonadIO m => Int -> Stream m a -> Stream m (MutArray a) +[C] Streamly.Data.MutArray + [D] writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] writeAppendN :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [D] writeAppend :: forall m a. (MonadIO m, Unbox a) => m (MutArray a) -> Fold m a (MutArray a) + [D] write :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [A] unsafePutIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () + [A] unsafeModifyIndex :: forall m a b. (MonadIO m, Unbox a) => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] unsafeGetIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [D] putIndexUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () + [D] pinnedNew :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) + [D] pinnedEmptyOf :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [D] new :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [D] modifyIndexUnsafe :: forall m a b. (MonadIO m, Unbox a) => Int -> MutArray a -> (a -> (a, b)) -> m b + [D] getIndexUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [A] emptyOf' :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] chunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (MutArray a) + [D] appendN :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [A] append2 :: (MonadIO m, Unbox a) => MutArray a -> Fold m a (MutArray a) + [D] append :: forall m a. (MonadIO m, Unbox a) => m (MutArray a) -> Fold m a (MutArray a) +[C] Streamly.Data.Fold + [A] takeEndBySeq_ :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Fold m a b + [A] takeEndBySeq :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Fold m a b + [A] scanl :: Monad m => Scanl m a b -> Fold m b c -> Fold m a c + [D] scanMaybe :: Monad m => Fold m a (Maybe b) -> Fold m b c -> Fold m a c + [D] scan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c + [A] postscanl :: Monad m => Scanl m a b -> Fold m b c -> Fold m a c + [D] postscan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c + [A] foldtM' :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> Fold m a b + [D] foldlM1' :: Monad m => (a -> a -> m a) -> Fold m a (Maybe a) + [A] foldl1M' :: Monad m => (a -> a -> m a) -> Fold m a (Maybe a) + [A] demuxerToMapIO :: (MonadIO m, Ord k) => (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Fold m a (Map k b) + [A] demuxerToMap :: (Monad m, Ord k) => (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Fold m a (Map k b) + [D] demuxToMapIO :: (MonadIO m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) + [D] demuxToMap :: (Monad m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) + [D] demuxIO :: (MonadIO m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (m (Map k b), Maybe (k, b)) + [D] demux :: (Monad m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (m (Map k b), Maybe (k, b)) + [D] classifyIO :: (MonadIO m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (m (Map k b), Maybe (k, b)) + [D] classify :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (m (Map k b), Maybe (k, b)) +[C] Streamly.Data.Array.Generic + [D] writeN :: MonadIO m => Int -> Fold m a (Array a) + [D] write :: MonadIO m => Fold m a (Array a) + [A] toParserK :: Monad m => Parser a m b -> ParserK (Array a) m b + [A] parsePos :: Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseErrorPos b) + [A] parseBreakPos :: forall m a b. Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseErrorPos b, StreamK m (Array a)) + [A] parseBreak :: forall m a b. Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] parse :: Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [A] chunksOf :: forall m a. MonadIO m => Int -> Stream m a -> Stream m (Array a) +[C] Streamly.Data.Array + [D] writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [D] writeLastN :: (Unbox a, MonadIO m) => Int -> Fold m a (Array a) + [D] write :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [A] toParserK :: (Monad m, Unbox a) => Parser a m b -> ParserK (Array a) m b + [A] serialize' :: Serialize a => a -> Array Word8 + [D] pinnedSerialize :: Serialize a => a -> Array Word8 + [A] parsePos :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseErrorPos b) + [A] parseBreakPos :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseErrorPos b, StreamK m (Array a)) + [A] parseBreak :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] parse :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [C] deserialize + [O] deserialize :: Serialize a => Array Word8 -> a + [N] deserialize :: Serialize a => Array Word8 -> (a, Array Word8) + [A] createOfLast :: (Unbox a, MonadIO m) => Int -> Fold m a (Array a) + [A] chunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (Array a) +[A] Streamly.Control.Exception + [A] AcquireIO + [A] withAcquireIO :: (MonadIO m, MonadMask m) => (AcquireIO -> m a) -> m a + [A] register :: AcquireIO -> IO () -> IO () + [A] hook :: AcquireIO -> IO () -> IO (IO ()) + [A] acquire :: AcquireIO -> IO b -> (b -> IO c) -> IO (b, IO ()) +[C] Streamly.Console.Stdio + [A] readChunks :: MonadIO m => Stream m (Array Word8) + [A] readChars :: MonadIO m => Stream m Char + [A] read :: MonadIO m => Stream m Word8 + [A] putChunks :: MonadIO m => Stream m (Array Word8) -> m () + +--------------------------------- +Internal API diff +--------------------------------- + +[C] Streamly.Internal.Unicode.Stream + [A] swapByteOrder :: Word16 -> Word16 + [A] mkEvenW8Chunks :: Monad m => Stream m (Array Word8) -> Stream m (Array Word8) + [C] encodeUtf16le' + [O] encodeUtf16le' :: Stream m Char -> Stream m Word16 + [N] encodeUtf16le' :: Monad m => Stream m Char -> Stream m Word16 + [A] encodeUtf16le :: Monad m => Stream m Char -> Stream m Word16 + [C] decodeUtf16le' + [O] decodeUtf16le' :: Stream m Word16 -> Stream m Char + [N] decodeUtf16le' :: Monad m => Stream m Word16 -> Stream m Char + [A] decodeUtf16le :: Monad m => Stream m Word16 -> Stream m Char +[A] Streamly.Internal.FileSystem.WindowsPath.SegNode + [A] Streamly.Internal.Data.Path.IsPath + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath (Streamly.Internal.FileSystem.WindowsPath.Seg.Unrooted (Streamly.Internal.FileSystem.WindowsPath.Node.File Streamly.Internal.FileSystem.WindowsPath.WindowsPath)) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath (Streamly.Internal.FileSystem.WindowsPath.Seg.Unrooted (Streamly.Internal.FileSystem.WindowsPath.Node.Dir Streamly.Internal.FileSystem.WindowsPath.WindowsPath)) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath (Streamly.Internal.FileSystem.WindowsPath.Seg.Rooted (Streamly.Internal.FileSystem.WindowsPath.Node.File Streamly.Internal.FileSystem.WindowsPath.WindowsPath)) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath (Streamly.Internal.FileSystem.WindowsPath.Seg.Rooted (Streamly.Internal.FileSystem.WindowsPath.Node.Dir Streamly.Internal.FileSystem.WindowsPath.WindowsPath)) + [A] urfileE :: String -> Q Exp + [A] urfile :: QuasiQuoter + [A] urdirE :: String -> Q Exp + [A] urdir :: QuasiQuoter + [A] rtfileE :: String -> Q Exp + [A] rtfile :: QuasiQuoter + [A] rtdirE :: String -> Q Exp + [A] rtdir :: QuasiQuoter + [A] join :: (IsPath WindowsPath (a (Dir WindowsPath)), IsPath WindowsPath (b WindowsPath), IsPath WindowsPath (a (b WindowsPath))) => a (Dir WindowsPath) -> Unrooted (b WindowsPath) -> a (b WindowsPath) +[A] Streamly.Internal.FileSystem.WindowsPath.Seg + [A] class IsSeg a + [A] Streamly.Internal.FileSystem.WindowsPath.Seg.IsSeg + [A] instance Streamly.Internal.FileSystem.WindowsPath.Seg.IsSeg (Streamly.Internal.FileSystem.WindowsPath.Seg.Unrooted a) + [A] instance Streamly.Internal.FileSystem.WindowsPath.Seg.IsSeg (Streamly.Internal.FileSystem.WindowsPath.Seg.Rooted a) + [A] Streamly.Internal.Data.Path.IsPath + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath (Streamly.Internal.FileSystem.WindowsPath.Seg.Unrooted Streamly.Internal.FileSystem.WindowsPath.WindowsPath) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath (Streamly.Internal.FileSystem.WindowsPath.Seg.Rooted Streamly.Internal.FileSystem.WindowsPath.WindowsPath) + [A] Unrooted + [A] Unrooted :: a -> Unrooted a + [A] Rooted + [A] Rooted :: a -> Rooted a + [A] urE :: String -> Q Exp + [A] ur :: QuasiQuoter + [A] rtE :: String -> Q Exp + [A] rt :: QuasiQuoter + [A] join :: (IsSeg (a WindowsPath), IsPath WindowsPath (a WindowsPath)) => a WindowsPath -> Unrooted WindowsPath -> a WindowsPath +[A] Streamly.Internal.FileSystem.WindowsPath.Node + [A] class IsNode a + [A] Streamly.Internal.FileSystem.WindowsPath.Node.IsNode + [A] instance Streamly.Internal.FileSystem.WindowsPath.Node.IsNode (Streamly.Internal.FileSystem.WindowsPath.Node.File a) + [A] instance Streamly.Internal.FileSystem.WindowsPath.Node.IsNode (Streamly.Internal.FileSystem.WindowsPath.Node.Dir a) + [A] Streamly.Internal.Data.Path.IsPath + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath (Streamly.Internal.FileSystem.WindowsPath.Node.File Streamly.Internal.FileSystem.WindowsPath.WindowsPath) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath (Streamly.Internal.FileSystem.WindowsPath.Node.Dir Streamly.Internal.FileSystem.WindowsPath.WindowsPath) + [A] File + [A] File :: a -> File a + [A] Dir + [A] Dir :: a -> Dir a + [A] join :: (IsPath WindowsPath (a WindowsPath), IsNode (a WindowsPath)) => Dir WindowsPath -> a WindowsPath -> a WindowsPath + [A] fileE :: String -> Q Exp + [A] file :: QuasiQuoter + [A] dirE :: String -> Q Exp + [A] dir :: QuasiQuoter +[A] Streamly.Internal.FileSystem.WindowsPath + [A] class IsPath a b + [A] EqCfg + [A] Streamly.Internal.Data.Path.IsPath + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath Streamly.Internal.FileSystem.WindowsPath.WindowsPath + [A] WindowsPath + [A] WindowsPath :: Array Word16 -> WindowsPath + [A] wordToChar :: Word16 -> Char + [A] validatePath' :: MonadThrow m => Array Word16 -> m () + [A] validatePath :: MonadThrow m => Array Word16 -> m () + [A] unsafeJoinPaths :: [WindowsPath] -> WindowsPath + [A] unsafeJoin :: WindowsPath -> WindowsPath -> WindowsPath + [A] unsafeFromString :: [Char] -> WindowsPath + [A] unsafeFromPath :: IsPath a b => a -> b + [A] unsafeFromArray :: Array Word16 -> WindowsPath + [A] toString_ :: WindowsPath -> [Char] + [A] toString :: WindowsPath -> [Char] + [A] toPath :: IsPath a b => b -> a + [A] toChars_ :: Monad m => WindowsPath -> Stream m Char + [A] toChars :: Monad m => WindowsPath -> Stream m Char + [A] toArray :: WindowsPath -> Array Word16 + [A] takeFileName :: WindowsPath -> Maybe WindowsPath + [A] takeFileBase :: WindowsPath -> Maybe WindowsPath + [A] takeExtension :: WindowsPath -> Maybe WindowsPath + [A] takeDirectory :: WindowsPath -> Maybe WindowsPath + [A] splitRoot :: WindowsPath -> Maybe (WindowsPath, Maybe WindowsPath) + [A] splitPath_ :: Monad m => WindowsPath -> Stream m WindowsPath + [A] splitPath :: Monad m => WindowsPath -> Stream m WindowsPath + [A] splitLast :: WindowsPath -> (Maybe WindowsPath, WindowsPath) + [A] splitFirst :: WindowsPath -> (WindowsPath, Maybe WindowsPath) + [A] splitFile :: WindowsPath -> Maybe (Maybe WindowsPath, WindowsPath) + [A] splitExtension :: WindowsPath -> Maybe (WindowsPath, WindowsPath) + [A] showArray :: WindowsPath -> [Char] + [A] separator :: Word16 + [A] replaceExtension :: WindowsPath -> WindowsPath -> WindowsPath + [A] readArray :: [Char] -> WindowsPath + [A] pathE :: String -> Q Exp + [A] path :: QuasiQuoter + [A] normalize :: EqCfg -> WindowsPath -> WindowsPath + [A] joinStr :: WindowsPath -> [Char] -> WindowsPath + [A] joinDir :: WindowsPath -> WindowsPath -> WindowsPath + [A] join :: WindowsPath -> WindowsPath -> WindowsPath + [A] isValidPath' :: Array Word16 -> Bool + [A] isValidPath :: Array Word16 -> Bool + [A] isUnrooted :: WindowsPath -> Bool + [A] isSeparator :: Word16 -> Bool + [A] isRooted :: WindowsPath -> Bool + [A] ignoreTrailingSeparators :: Bool -> EqCfg -> EqCfg + [A] ignoreCase :: Bool -> EqCfg -> EqCfg + [A] hasTrailingSeparator :: WindowsPath -> Bool + [A] fromString_ :: [Char] -> WindowsPath + [A] fromString :: MonadThrow m => [Char] -> m WindowsPath + [A] fromPath :: (IsPath a b, MonadThrow m) => a -> m b + [A] fromChars :: MonadThrow m => Stream Identity Char -> m WindowsPath + [A] fromArray :: MonadThrow m => Array Word16 -> m WindowsPath + [A] extSeparator :: Word16 + [A] eqPathBytes :: WindowsPath -> WindowsPath -> Bool + [A] eqPath :: (EqCfg -> EqCfg) -> WindowsPath -> WindowsPath -> Bool + [A] encodeString :: [Char] -> Array Word16 + [A] dropTrailingSeparators :: WindowsPath -> WindowsPath + [A] dropExtension :: WindowsPath -> WindowsPath + [A] charToWord :: Char -> Word16 + [A] asCWString :: WindowsPath -> (CWString -> IO a) -> IO a + [A] allowRelativeEquality :: Bool -> EqCfg -> EqCfg + [A] addTrailingSeparator :: WindowsPath -> WindowsPath + [A] addExtension :: WindowsPath -> WindowsPath -> WindowsPath + [A] adapt :: (MonadThrow m, IsPath WindowsPath a, IsPath WindowsPath b) => a -> m b +[A] Streamly.Internal.FileSystem.Windows.ReadDir +[A] Streamly.Internal.FileSystem.Windows.File +[A] Streamly.Internal.FileSystem.PosixPath.SegNode + [A] Streamly.Internal.Data.Path.IsPath + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.PosixPath.PosixPath (Streamly.Internal.FileSystem.PosixPath.Seg.Unrooted (Streamly.Internal.FileSystem.PosixPath.Node.File Streamly.Internal.FileSystem.PosixPath.PosixPath)) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.PosixPath.PosixPath (Streamly.Internal.FileSystem.PosixPath.Seg.Unrooted (Streamly.Internal.FileSystem.PosixPath.Node.Dir Streamly.Internal.FileSystem.PosixPath.PosixPath)) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.PosixPath.PosixPath (Streamly.Internal.FileSystem.PosixPath.Seg.Rooted (Streamly.Internal.FileSystem.PosixPath.Node.File Streamly.Internal.FileSystem.PosixPath.PosixPath)) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.PosixPath.PosixPath (Streamly.Internal.FileSystem.PosixPath.Seg.Rooted (Streamly.Internal.FileSystem.PosixPath.Node.Dir Streamly.Internal.FileSystem.PosixPath.PosixPath)) + [A] urfileE :: String -> Q Exp + [A] urfile :: QuasiQuoter + [A] urdirE :: String -> Q Exp + [A] urdir :: QuasiQuoter + [A] rtfileE :: String -> Q Exp + [A] rtfile :: QuasiQuoter + [A] rtdirE :: String -> Q Exp + [A] rtdir :: QuasiQuoter + [A] join :: (IsPath PosixPath (a (Dir PosixPath)), IsPath PosixPath (b PosixPath), IsPath PosixPath (a (b PosixPath))) => a (Dir PosixPath) -> Unrooted (b PosixPath) -> a (b PosixPath) +[A] Streamly.Internal.FileSystem.PosixPath.Seg + [A] class IsSeg a + [A] Streamly.Internal.FileSystem.PosixPath.Seg.IsSeg + [A] instance Streamly.Internal.FileSystem.PosixPath.Seg.IsSeg (Streamly.Internal.FileSystem.PosixPath.Seg.Unrooted a) + [A] instance Streamly.Internal.FileSystem.PosixPath.Seg.IsSeg (Streamly.Internal.FileSystem.PosixPath.Seg.Rooted a) + [A] Streamly.Internal.Data.Path.IsPath + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.PosixPath.PosixPath (Streamly.Internal.FileSystem.PosixPath.Seg.Unrooted Streamly.Internal.FileSystem.PosixPath.PosixPath) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.PosixPath.PosixPath (Streamly.Internal.FileSystem.PosixPath.Seg.Rooted Streamly.Internal.FileSystem.PosixPath.PosixPath) + [A] Unrooted + [A] Unrooted :: a -> Unrooted a + [A] Rooted + [A] Rooted :: a -> Rooted a + [A] urE :: String -> Q Exp + [A] ur :: QuasiQuoter + [A] rtE :: String -> Q Exp + [A] rt :: QuasiQuoter + [A] join :: (IsSeg (a PosixPath), IsPath PosixPath (a PosixPath)) => a PosixPath -> Unrooted PosixPath -> a PosixPath +[A] Streamly.Internal.FileSystem.PosixPath.Node + [A] class IsNode a + [A] Streamly.Internal.FileSystem.PosixPath.Node.IsNode + [A] instance Streamly.Internal.FileSystem.PosixPath.Node.IsNode (Streamly.Internal.FileSystem.PosixPath.Node.File a) + [A] instance Streamly.Internal.FileSystem.PosixPath.Node.IsNode (Streamly.Internal.FileSystem.PosixPath.Node.Dir a) + [A] Streamly.Internal.Data.Path.IsPath + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.PosixPath.PosixPath (Streamly.Internal.FileSystem.PosixPath.Node.File Streamly.Internal.FileSystem.PosixPath.PosixPath) + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.PosixPath.PosixPath (Streamly.Internal.FileSystem.PosixPath.Node.Dir Streamly.Internal.FileSystem.PosixPath.PosixPath) + [A] File + [A] File :: a -> File a + [A] Dir + [A] Dir :: a -> Dir a + [A] join :: (IsPath PosixPath (a PosixPath), IsNode (a PosixPath)) => Dir PosixPath -> a PosixPath -> a PosixPath + [A] fileE :: String -> Q Exp + [A] file :: QuasiQuoter + [A] dirE :: String -> Q Exp + [A] dir :: QuasiQuoter +[A] Streamly.Internal.FileSystem.PosixPath + [A] class IsPath a b + [A] EqCfg + [A] Streamly.Internal.Data.Path.IsPath + [A] instance Streamly.Internal.Data.Path.IsPath Streamly.Internal.FileSystem.PosixPath.PosixPath Streamly.Internal.FileSystem.PosixPath.PosixPath + [A] PosixPath + [A] PosixPath :: Array Word8 -> PosixPath + [A] wordToChar :: Word8 -> Char + [A] validatePath :: MonadThrow m => Array Word8 -> m () + [A] unsafeJoinPaths :: [PosixPath] -> PosixPath + [A] unsafeJoin :: PosixPath -> PosixPath -> PosixPath + [A] unsafeFromString :: [Char] -> PosixPath + [A] unsafeFromPath :: IsPath a b => a -> b + [A] unsafeFromArray :: Array Word8 -> PosixPath + [A] toString_ :: PosixPath -> [Char] + [A] toString :: PosixPath -> [Char] + [A] toPath :: IsPath a b => b -> a + [A] toChars_ :: Monad m => PosixPath -> Stream m Char + [A] toChars :: Monad m => PosixPath -> Stream m Char + [A] toArray :: PosixPath -> Array Word8 + [A] takeFileName :: PosixPath -> Maybe PosixPath + [A] takeFileBase :: PosixPath -> Maybe PosixPath + [A] takeExtension :: PosixPath -> Maybe PosixPath + [A] takeDirectory :: PosixPath -> Maybe PosixPath + [A] splitRoot :: PosixPath -> Maybe (PosixPath, Maybe PosixPath) + [A] splitPath_ :: Monad m => PosixPath -> Stream m PosixPath + [A] splitPath :: Monad m => PosixPath -> Stream m PosixPath + [A] splitLast :: PosixPath -> (Maybe PosixPath, PosixPath) + [A] splitFirst :: PosixPath -> (PosixPath, Maybe PosixPath) + [A] splitFile :: PosixPath -> Maybe (Maybe PosixPath, PosixPath) + [A] splitExtension :: PosixPath -> Maybe (PosixPath, PosixPath) + [A] showArray :: PosixPath -> [Char] + [A] separator :: Word8 + [A] replaceExtension :: PosixPath -> PosixPath -> PosixPath + [A] readArray :: [Char] -> PosixPath + [A] pathE :: String -> Q Exp + [A] path :: QuasiQuoter + [A] normalize :: EqCfg -> PosixPath -> PosixPath + [A] joinStr :: PosixPath -> [Char] -> PosixPath + [A] joinDir :: PosixPath -> PosixPath -> PosixPath + [A] joinCStr' :: PosixPath -> CString -> IO PosixPath + [A] joinCStr :: PosixPath -> CString -> IO PosixPath + [A] join :: PosixPath -> PosixPath -> PosixPath + [A] isValidPath :: Array Word8 -> Bool + [A] isUnrooted :: PosixPath -> Bool + [A] isSeparator :: Word8 -> Bool + [A] isRooted :: PosixPath -> Bool + [A] ignoreTrailingSeparators :: Bool -> EqCfg -> EqCfg + [A] ignoreCase :: Bool -> EqCfg -> EqCfg + [A] hasTrailingSeparator :: PosixPath -> Bool + [A] fromString_ :: [Char] -> PosixPath + [A] fromString :: MonadThrow m => [Char] -> m PosixPath + [A] fromPath :: (IsPath a b, MonadThrow m) => a -> m b + [A] fromChars :: MonadThrow m => Stream Identity Char -> m PosixPath + [A] fromArray :: MonadThrow m => Array Word8 -> m PosixPath + [A] extSeparator :: Word8 + [A] eqPathBytes :: PosixPath -> PosixPath -> Bool + [A] eqPath :: (EqCfg -> EqCfg) -> PosixPath -> PosixPath -> Bool + [A] encodeString :: [Char] -> Array Word8 + [A] dropTrailingSeparators :: PosixPath -> PosixPath + [A] dropExtension :: PosixPath -> PosixPath + [A] charToWord :: Char -> Word8 + [A] asCString :: PosixPath -> (CString -> IO a) -> IO a + [A] allowRelativeEquality :: Bool -> EqCfg -> EqCfg + [A] addTrailingSeparator :: PosixPath -> PosixPath + [A] addExtension :: PosixPath -> PosixPath -> PosixPath + [A] adapt :: (MonadThrow m, IsPath PosixPath a, IsPath PosixPath b) => a -> m b +[A] Streamly.Internal.FileSystem.Posix.ReadDir + [A] DirStream + [A] DirStream :: Ptr CDir -> DirStream + [A] reader :: (MonadIO m, MonadCatch m) => Unfold m Path Path + [A] readScanWith_ :: Scanl m (Path, CString) a -> (ReadOptions -> ReadOptions) -> Path -> Stream m a + [A] readScanWith :: Scanl m (Path, CString, Ptr CDirent) a -> (ReadOptions -> ReadOptions) -> Path -> Stream m a + [A] readPlusScanWith :: Scanl m (Path, CString, Ptr CStat) a -> (ReadOptions -> ReadOptions) -> Path -> Stream m a + [A] readEitherChunks :: MonadIO m => (ReadOptions -> ReadOptions) -> [PosixPath] -> Stream m (Either [PosixPath] [PosixPath]) + [A] readEitherByteChunksAt :: MonadIO m => (ReadOptions -> ReadOptions) -> (PosixPath, [PosixPath]) -> Stream m (Either (PosixPath, [PosixPath]) (Array Word8)) + [A] readEitherByteChunks :: MonadIO m => (ReadOptions -> ReadOptions) -> [PosixPath] -> Stream m (Either [PosixPath] (Array Word8)) + [A] readDirStreamEither :: (ReadOptions -> ReadOptions) -> (PosixPath, DirStream) -> IO (Maybe (Either PosixPath PosixPath)) + [A] openDirStreamCString :: CString -> IO DirStream + [A] openDirStream :: PosixPath -> IO DirStream + [A] eitherReader :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Unfold m Path (Either Path Path) + [A] closeDirStream :: DirStream -> IO () +[A] Streamly.Internal.FileSystem.Posix.File + [A] () + [A] OpenFlags + [A] OpenFlags :: CInt -> OpenFlags + [A] withFile :: PosixPath -> IOMode -> (Handle -> IO r) -> IO r + [A] withBinaryFile :: PosixPath -> IOMode -> (Handle -> IO r) -> IO r + [A] setUx :: FileMode -> FileMode + [A] setUw :: FileMode -> FileMode + [A] setUr :: FileMode -> FileMode + [A] setTrunc :: Bool -> OpenFlags -> OpenFlags + [A] setSync :: Bool -> OpenFlags -> OpenFlags + [A] setSuid :: FileMode -> FileMode + [A] setSticky :: FileMode -> FileMode + [A] setSgid :: FileMode -> FileMode + [A] setOx :: FileMode -> FileMode + [A] setOw :: FileMode -> FileMode + [A] setOr :: FileMode -> FileMode + [A] setNonBlock :: Bool -> OpenFlags -> OpenFlags + [A] setNoFollow :: Bool -> OpenFlags -> OpenFlags + [A] setNoCtty :: Bool -> OpenFlags -> OpenFlags + [A] setGx :: FileMode -> FileMode + [A] setGw :: FileMode -> FileMode + [A] setGr :: FileMode -> FileMode + [A] setExcl :: Bool -> OpenFlags -> OpenFlags + [A] setDirectory :: Bool -> OpenFlags -> OpenFlags + [A] setCloExec :: Bool -> OpenFlags -> OpenFlags + [A] setAppend :: Bool -> OpenFlags -> OpenFlags + [A] openFile :: PosixPath -> IOMode -> IO Handle + [A] openBinaryFile :: PosixPath -> IOMode -> IO Handle + [A] openAt :: Maybe Fd -> PosixPath -> OpenFlags -> Maybe FileMode -> IO Fd + [A] defaultOpenFlags :: OpenFlags + [A] defaultCreateMode :: FileMode + [A] clrUx :: FileMode -> FileMode + [A] clrUw :: FileMode -> FileMode + [A] clrUr :: FileMode -> FileMode + [A] clrSuid :: FileMode -> FileMode + [A] clrSticky :: FileMode -> FileMode + [A] clrSgid :: FileMode -> FileMode + [A] clrOx :: FileMode -> FileMode + [A] clrOw :: FileMode -> FileMode + [A] clrOr :: FileMode -> FileMode + [A] clrGx :: FileMode -> FileMode + [A] clrGw :: FileMode -> FileMode + [A] clrGr :: FileMode -> FileMode + [A] close :: Fd -> IO () +[A] Streamly.Internal.FileSystem.Posix.Errno + [A] throwErrnoPathIfRetry :: (a -> Bool) -> String -> PosixPath -> IO a -> IO a + [A] throwErrnoPathIfNullRetry :: String -> PosixPath -> IO (Ptr a) -> IO (Ptr a) + [A] throwErrnoPathIfMinus1Retry :: (Eq a, Num a) => String -> PosixPath -> IO a -> IO a + [A] throwErrnoPath :: String -> PosixPath -> IO a +[A] Streamly.Internal.FileSystem.Path.SegNode +[A] Streamly.Internal.FileSystem.Path.Seg +[A] Streamly.Internal.FileSystem.Path.Node +[C] Streamly.Internal.FileSystem.Path + [C] IsPath + [O] class IsPath a + [N] class IsPath a b + [R] Rel + [R] File + [A] EqCfg + [R] Dir + [R] Abs + [R] Streamly.Internal.FileSystem.Path.IsPath + [R] GHC.Show.Show + [R] GHC.Exception.Type.Exception + [R] GHC.Classes.Eq + [R] Path + [A] type Path = PosixPath + [A] type OsWord = Word8 + [A] type OsCString = CString + [A] wordToChar :: OsWord -> Char + [A] validatePath :: MonadThrow m => Array OsWord -> m () + [A] unsafeJoinPaths :: [Path] -> Path + [A] unsafeJoin :: Path -> Path -> Path + [A] unsafeFromString :: [Char] -> Path + [A] unsafeFromPath :: IsPath a b => a -> b + [A] unsafeFromArray :: Array OsWord -> Path + [A] toString_ :: Path -> [Char] + [C] toPath + [O] toPath :: IsPath a => a -> Path + [N] toPath :: IsPath a b => b -> a + [R] toChunk :: Path -> Array Word8 + [A] toChars_ :: Monad m => Path -> Stream m Char + [A] toArray :: Path -> Array OsWord + [A] takeFileName :: Path -> Maybe Path + [A] takeFileBase :: Path -> Maybe Path + [A] takeExtension :: Path -> Maybe Path + [A] takeDirectory :: Path -> Maybe Path + [A] splitRoot :: Path -> Maybe (Path, Maybe Path) + [A] splitPath_ :: Monad m => Path -> Stream m Path + [A] splitPath :: Monad m => Path -> Stream m Path + [A] splitLast :: Path -> (Maybe Path, Path) + [A] splitFirst :: Path -> (Path, Maybe Path) + [A] splitFile :: Path -> Maybe (Maybe Path, Path) + [A] splitExtension :: Path -> Maybe (Path, Path) + [A] showArray :: Path -> [Char] + [A] separator :: OsWord + [A] replaceExtension :: Path -> Path -> Path + [R] relfile :: QuasiQuoter + [R] reldir :: QuasiQuoter + [R] rel :: QuasiQuoter + [A] readArray :: [Char] -> Path + [R] primarySeparator :: Char + [A] pathE :: String -> Q Exp + [A] normalize :: EqCfg -> Path -> Path + [R] mkRelFile :: String -> Q Exp + [R] mkRelDir :: String -> Q Exp + [R] mkRel :: String -> Q Exp + [R] mkPath :: String -> Q Exp + [R] mkFile :: String -> Q Exp + [R] mkDir :: String -> Q Exp + [R] mkAbsFile :: String -> Q Exp + [R] mkAbsDir :: String -> Q Exp + [R] mkAbs :: String -> Q Exp + [A] joinStr :: Path -> [Char] -> Path + [A] joinDir :: Path -> Path -> Path + [A] joinCStr' :: Path -> CString -> IO Path + [A] joinCStr :: Path -> CString -> IO Path + [A] join :: Path -> Path -> Path + [A] isValidPath :: Array OsWord -> Bool + [A] isUnrooted :: Path -> Bool + [C] isSeparator + [O] isSeparator :: Char -> Bool + [N] isSeparator :: OsWord -> Bool + [A] isRooted :: Path -> Bool + [A] ignoreTrailingSeparators :: Bool -> EqCfg -> EqCfg + [A] ignoreCase :: Bool -> EqCfg -> EqCfg + [A] hasTrailingSeparator :: Path -> Bool + [A] fromString_ :: [Char] -> Path + [R] fromPathUnsafe :: IsPath a => Path -> a + [C] fromPath + [O] fromPath :: (IsPath a, MonadThrow m) => Path -> m a + [N] fromPath :: (IsPath a b, MonadThrow m) => a -> m b + [R] fromChunkUnsafe :: Array Word8 -> Path + [R] fromChunk :: MonadThrow m => Array Word8 -> m Path + [A] fromArray :: MonadThrow m => Array OsWord -> m Path + [R] file :: QuasiQuoter + [R] extendPath :: Path -> Path -> Path + [R] extendDir :: (IsPath (a (Dir Path)), IsPath b, IsPath (a b)) => a (Dir Path) -> Rel b -> a b + [A] extSeparator :: OsWord + [A] eqPathBytes :: Path -> Path -> Bool + [A] eqPath :: (EqCfg -> EqCfg) -> Path -> Path -> Bool + [A] encodeString :: [Char] -> Array OsWord + [A] dropTrailingSeparators :: Path -> Path + [A] dropExtension :: Path -> Path + [R] dir :: QuasiQuoter + [A] charToWord :: Char -> OsWord + [A] asOsCString :: Path -> (OsCString -> IO a) -> IO a + [A] allowRelativeEquality :: Bool -> EqCfg -> EqCfg + [A] addTrailingSeparator :: Path -> Path + [A] addExtension :: Path -> Path -> Path + [R] adaptPath :: (MonadThrow m, IsPath a, IsPath b) => a -> m b + [A] adapt :: (MonadThrow m, IsPath Path a, IsPath Path b) => a -> m b + [R] absfile :: QuasiQuoter + [R] absdir :: QuasiQuoter + [R] abs :: QuasiQuoter +[C] Streamly.Internal.FileSystem.Handle + [C] writeChunks + [O] writeChunks :: MonadIO m => Handle -> Fold m (Array a) () + [N] writeChunks :: forall m (a :: Type). MonadIO m => Handle -> Fold m (Array a) () + [C] putChunks + [O] putChunks :: MonadIO m => Handle -> Stream m (Array a) -> m () + [N] putChunks :: forall m (a :: Type). MonadIO m => Handle -> Stream m (Array a) -> m () + [C] putChunk + [O] putChunk :: MonadIO m => Handle -> Array a -> m () + [N] putChunk :: forall m (a :: Type). MonadIO m => Handle -> Array a -> m () + [C] chunkWriter + [O] chunkWriter :: MonadIO m => Refold m Handle (Array a) () + [N] chunkWriter :: forall m (a :: Type). MonadIO m => Refold m Handle (Array a) () +[A] Streamly.Internal.FileSystem.FileIO + [A] writeWith :: (MonadIO m, MonadCatch m) => Int -> Path -> Fold m Word8 () + [A] writeChunks :: (MonadIO m, MonadCatch m) => Path -> Fold m (Array a) () + [A] writeAppendWith :: (MonadIO m, MonadCatch m) => Int -> Path -> Stream m Word8 -> m () + [A] writeAppendChunks :: (MonadIO m, MonadCatch m) => Path -> Stream m (Array a) -> m () + [A] writeAppendArray :: Path -> Array a -> IO () + [A] writeAppend :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 -> m () + [A] write :: (MonadIO m, MonadCatch m) => Path -> Fold m Word8 () + [A] withFile :: (MonadIO m, MonadCatch m) => Path -> IOMode -> (Handle -> Stream m a) -> Stream m a + [A] readerWith :: (MonadIO m, MonadCatch m) => Unfold m (Int, Path) Word8 + [A] reader :: (MonadIO m, MonadCatch m) => Unfold m Path Word8 + [A] readChunksWith :: (MonadIO m, MonadCatch m) => Int -> Path -> Stream m (Array Word8) + [A] readChunks :: (MonadIO m, MonadCatch m) => Path -> Stream m (Array Word8) + [A] read :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 + [A] putChunk :: Path -> Array a -> IO () + [A] fromChunks :: (MonadIO m, MonadCatch m) => Path -> Stream m (Array a) -> m () + [A] fromBytesWith :: (MonadIO m, MonadCatch m) => Int -> Path -> Stream m Word8 -> m () + [A] fromBytes :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 -> m () + [A] chunkReaderWith :: (MonadIO m, MonadCatch m) => Unfold m (Int, Path) (Array Word8) + [A] chunkReaderFromToWith :: (MonadIO m, MonadCatch m) => Unfold m (Int, Int, Int, Path) (Array Word8) + [A] chunkReader :: (MonadIO m, MonadCatch m) => Unfold m Path (Array Word8) +[A] Streamly.Internal.FileSystem.File.Common + [A] withFile :: Bool -> (Path -> IOMode -> IO Handle) -> Path -> IOMode -> (Handle -> IO r) -> IO r + [A] openFile :: Bool -> (Path -> IOMode -> IO Handle) -> Path -> IOMode -> IO Handle +[D] Streamly.Internal.FileSystem.File + [C] writeChunks + [O] writeChunks :: (MonadIO m, MonadCatch m) => FilePath -> Fold m (Array a) () + [N] writeChunks :: forall m (a :: Type). (MonadIO m, MonadCatch m) => FilePath -> Fold m (Array a) () + [C] writeAppendChunks + [O] writeAppendChunks :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array a) -> m () + [N] writeAppendChunks :: forall m (a :: Type). (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array a) -> m () + [C] writeAppendArray + [O] writeAppendArray :: FilePath -> Array a -> IO () + [N] writeAppendArray :: forall (a :: Type). FilePath -> Array a -> IO () + [C] putChunk + [O] putChunk :: FilePath -> Array a -> IO () + [N] putChunk :: forall (a :: Type). FilePath -> Array a -> IO () + [C] fromChunks + [O] fromChunks :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array a) -> m () + [N] fromChunks :: forall m (a :: Type). (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array a) -> m () +[A] Streamly.Internal.FileSystem.DirIO + [A] ReadOptions + [A] [_ignoreENOENT] :: ReadOptions -> Bool + [A] [_ignoreELOOP] :: ReadOptions -> Bool + [A] [_ignoreEACCESS] :: ReadOptions -> Bool + [A] [_followSymlinks] :: ReadOptions -> Bool + [A] ReadOptions :: Bool -> Bool -> Bool -> Bool -> ReadOptions + [A] reader :: (MonadIO m, MonadCatch m) => Unfold m Path Path + [A] readFiles :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Path -> Stream m Path + [A] readEitherPaths :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Path -> Stream m (Either Path Path) + [A] readEitherChunks :: MonadIO m => (ReadOptions -> ReadOptions) -> [PosixPath] -> Stream m (Either [PosixPath] [PosixPath]) + [A] readEither :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Path -> Stream m (Either Path Path) + [A] readDirs :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Path -> Stream m Path + [A] read :: (MonadIO m, MonadCatch m) => Path -> Stream m Path + [A] ignoreSymlinkLoops :: Bool -> ReadOptions -> ReadOptions + [A] ignoreMissing :: Bool -> ReadOptions -> ReadOptions + [A] ignoreInaccessible :: Bool -> ReadOptions -> ReadOptions + [A] followSymlinks :: Bool -> ReadOptions -> ReadOptions + [A] fileReader :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Unfold m Path Path + [A] eitherReaderPaths :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Unfold m Path (Either Path Path) + [A] eitherReader :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Unfold m Path (Either Path Path) + [A] dirReader :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> Unfold m Path Path + [A] defaultReadOptions :: ReadOptions +[D] Streamly.Internal.FileSystem.Dir +[C] Streamly.Internal.Data.Unfold + [A] zipRepeat :: Functor m => Unfold m a b -> Unfold m (c, a) (c, b) + [A] zipArrowWithM :: Monad m => (b -> c -> m d) -> Unfold m a1 b -> Unfold m a2 c -> Unfold m (a1, a2) d + [A] zipArrowWith :: Monad m => (b -> c -> d) -> Unfold m a1 b -> Unfold m a2 c -> Unfold m (a1, a2) d + [A] unfoldEachInterleave :: Monad m => Unfold m a b -> Unfold m c a -> Unfold m c b + [A] unfoldEach :: Monad m => Unfold m b c -> Unfold m a b -> Unfold m a c + [A] supply :: a -> Unfold m a b -> Unfold m () b + [A] scanlMany :: Monad m => Scanl m b c -> Unfold m a b -> Unfold m a c + [A] scanl :: Monad m => Scanl m b c -> Unfold m a b -> Unfold m a c + [D] scanMany :: Monad m => Fold m b c -> Unfold m a b -> Unfold m a c + [D] scan :: Monad m => Fold m b c -> Unfold m a b -> Unfold m a c + [A] repeat :: Applicative m => Unfold m a a + [D] mapM2 :: Monad m => (a -> b -> m c) -> Unfold m a b -> Unfold m a c + [D] map2 :: Functor m => (a -> b -> c) -> Unfold m a b -> Unfold m a c + [D] manyInterleave :: Monad m => Unfold m a b -> Unfold m c a -> Unfold m c b + [D] many2 :: Monad m => Unfold m (a, b) c -> Unfold m a b -> Unfold m a c + [D] many :: Monad m => Unfold m b c -> Unfold m a b -> Unfold m a c + [R] joinInnerGeneric :: Monad m => (b -> c -> Bool) -> Unfold m a b -> Unfold m a c -> Unfold m a (b, c) + [A] interleave :: Monad m => Unfold m a c -> Unfold m b c -> Unfold m (a, b) c + [A] innerJoin :: Monad m => (b -> c -> Bool) -> Unfold m a b -> Unfold m a c -> Unfold m a (b, c) + [A] fromTuple :: Applicative m => Unfold m (a, a) a + [A] fairCrossWithM :: Monad m => (b -> c -> m d) -> Unfold m a b -> Unfold m a c -> Unfold m a d + [A] fairCrossWith :: Monad m => (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d + [A] fairCross :: Monad m => Unfold m a b -> Unfold m a c -> Unfold m a (b, c) + [A] carry :: Functor m => Unfold m a b -> Unfold m a (a, b) + [D] both :: a -> Unfold m a b -> Unfold m Void b +[C] Streamly.Internal.Data.StreamK + [R] CrossStreamK + [A] Nested + [A] [unNested] :: Nested m a -> StreamK m a + [A] Nested :: StreamK m a -> Nested m a + [A] FairNested + [A] [unFairNested] :: FairNested m a -> StreamK m a + [A] FairNested :: StreamK m a -> FairNested m a + [A] toParserK :: Monad m => Parser a m b -> ParserK a m b + [A] tailNonEmpty :: StreamK m a -> StreamK m a + [A] sortOn :: (Monad m, Ord b) => (a -> b) -> StreamK m a -> StreamK m a + [A] parsePos :: Monad m => ParserK a m b -> StreamK m a -> m (Either ParseErrorPos b) + [C] parseDBreak + [O] parseDBreak :: Monad m => Parser a m b -> StreamK m a -> m (Either ParseError b, StreamK m a) + [N] parseDBreak :: Monad m => Parser a m b -> StreamK m a -> m (Either ParseErrorPos b, StreamK m a) + [C] parseD + [O] parseD :: Monad m => Parser a m b -> StreamK m a -> m (Either ParseError b) + [N] parseD :: Monad m => Parser a m b -> StreamK m a -> m (Either ParseErrorPos b) + [D] parseChunksGeneric :: Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [D] parseChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [A] parseBreakPos :: forall m a b. Monad m => ParserK a m b -> StreamK m a -> m (Either ParseErrorPos b, StreamK m a) + [D] parseBreakChunksGeneric :: forall m a b. Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [D] parseBreakChunks :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] morphInner :: (Monad m, Monad n) => (forall x. m x -> n x) -> StreamK m a -> StreamK n a + [D] mkCross :: StreamK m a -> Nested m a + [A] mapMAccum :: (s -> a -> m (s, b)) -> m s -> StreamK m a -> StreamK m b + [A] localReaderT :: (r -> r) -> StreamK (ReaderT r m) a -> StreamK (ReaderT r m) a + [A] interleaveSepBy :: StreamK m a -> StreamK m a -> StreamK m a + [D] interleaveMin :: StreamK m a -> StreamK m a -> StreamK m a + [D] interleaveFst :: StreamK m a -> StreamK m a -> StreamK m a + [A] interleaveEndBy' :: StreamK m a -> StreamK m a -> StreamK m a + [A] initNonEmpty :: Stream m a -> Stream m a + [D] hoist :: (Monad m, Monad n) => (forall x. m x -> n x) -> StreamK m a -> StreamK n a + [A] headNonEmpty :: Monad m => StreamK m a -> m a + [A] fairConcatMap :: (a -> StreamK m b) -> StreamK m a -> StreamK m b + [A] fairConcatForM :: Monad m => StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b + [A] fairConcatFor :: StreamK m a -> (a -> StreamK m b) -> StreamK m b + [A] concatMapMAccum :: (StreamK m b -> StreamK m b -> StreamK m b) -> (s -> a -> m (s, StreamK m b)) -> m s -> StreamK m a -> StreamK m b + [A] concatForWithM :: Monad m => (StreamK m b -> StreamK m b -> StreamK m b) -> StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b + [A] concatForWith :: (StreamK m b -> StreamK m b -> StreamK m b) -> StreamK m a -> (a -> StreamK m b) -> StreamK m b + [A] concatForM :: Monad m => StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b + [A] concatFor :: StreamK m a -> (a -> StreamK m b) -> StreamK m b + [D] bindWith :: (StreamK m b -> StreamK m b -> StreamK m b) -> StreamK m a -> (a -> StreamK m b) -> StreamK m b + [A] bfsConcatMap :: (a -> StreamK m b) -> StreamK m a -> StreamK m b + [A] bfsConcatForM :: Monad m => StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b + [A] bfsConcatFor :: StreamK m a -> (a -> StreamK m b) -> StreamK m b +[C] Streamly.Internal.Data.Stream + [A] FairUnfoldState + [A] FairUnfoldNext :: o -> ([i] -> [i]) -> [i] -> FairUnfoldState o i + [A] FairUnfoldInit :: o -> ([i] -> [i]) -> FairUnfoldState o i + [A] FairUnfoldDrain :: ([i] -> [i]) -> [i] -> FairUnfoldState o i + [R] CrossStream + [A] Nested + [A] [unNested] :: Nested m a -> Stream m a + [A] Nested :: Stream m a -> Nested m a + [A] withReaderT :: Monad m => (r2 -> r1) -> Stream (ReaderT r1 m) a -> Stream (ReaderT r2 m) a + [A] withAcquireIO' :: AcquireIO -> (AcquireIO -> Stream m a) -> Stream m a + [A] withAcquireIO :: (MonadIO m, MonadCatch m) => (AcquireIO -> Stream m a) -> Stream m a + [C] usingStateT + [O] usingStateT :: Monad m => m s -> (Stream (StateT s m) a -> Stream (StateT s m) a) -> Stream m a -> Stream m a + [N] usingStateT :: Monad m => m s -> (Stream (StateT s m) a -> Stream (StateT s m) b) -> Stream m a -> Stream m b + [R] unionWithStreamGenericBy :: MonadIO m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [R] unionWithStreamAscBy :: (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] unionBy :: MonadIO m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [A] unfoldSched :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [D] unfoldRoundRobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [D] unfoldMany :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [D] unfoldIterateDfs :: Monad m => Unfold m a a -> Stream m a -> Stream m a + [D] unfoldIterateBfsRev :: Monad m => Unfold m a a -> Stream m a -> Stream m a + [D] unfoldIterateBfs :: Monad m => Unfold m a a -> Stream m a -> Stream m a + [A] unfoldIterate :: Monad m => Unfold m a a -> Stream m a -> Stream m a + [D] unfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] unfoldEachSepBySeq :: Monad m => b -> Unfold m b c -> Stream m b -> Stream m c + [A] unfoldEachSepByM :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c + [A] unfoldEachSepBy :: Monad m => c -> Unfold m b c -> Stream m b -> Stream m c + [A] unfoldEachFoldBy :: Fold m b c -> Unfold m a b -> Stream m a -> Stream m c + [A] unfoldEachEndBySeq :: Monad m => b -> Unfold m b c -> Stream m b -> Stream m c + [A] unfoldEachEndByM :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c + [A] unfoldEachEndBy :: Monad m => c -> Unfold m b c -> Stream m b -> Stream m c + [A] unfoldEach :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] unfoldCross :: Monad m => Unfold m (a, b) c -> Stream m a -> Stream m b -> Stream m c + [C] unCross + [O] unCross :: CrossStream m a -> Stream m a + [N] unCross :: Nested m a -> Stream m a + [R] transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b + [A] takeEndBy_ :: Monad m => (a -> Bool) -> Stream m a -> Stream m a + [A] takeEndBySeq_ :: forall m a. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Stream m a -> Stream m a + [A] takeEndBySeq :: forall m a. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Stream m a -> Stream m a + [A] tailNonEmpty :: Monad m => Stream m a -> Stream m a + [D] strideFromThen :: Monad m => Int -> Int -> Stream m a -> Stream m a + [A] splitSepBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] splitSepBySeq_ :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Stream m a -> Stream m b + [A] splitSepBySeqOneOf :: [Array a] -> Fold m a b -> Stream m a -> Stream m b + [R] splitOnSuffixSeqAny :: [Array a] -> Fold m a b -> Stream m a -> Stream m b + [C] splitOnSuffixSeq + [O] splitOnSuffixSeq :: forall m a b. (MonadIO m, Storable a, Unbox a, Enum a, Eq a) => Bool -> Array a -> Fold m a b -> Stream m a -> Stream m b + [N] splitOnSuffixSeq :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Bool -> Array a -> Fold m a b -> Stream m a -> Stream m b + [D] splitOnSeq :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Stream m a -> Stream m b + [R] splitOnPrefix :: (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [R] splitOnAny :: [Array a] -> Fold m a b -> Stream m a -> Stream m b + [D] splitOn :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] splitEndBySeq_ :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Stream m a -> Stream m b + [A] splitEndBySeqOneOf :: [Array a] -> Fold m a b -> Stream m a -> Stream m b + [A] splitEndBySeq :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Stream m a -> Stream m b + [A] splitBeginBy_ :: (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b + [A] splitAt :: String -> Int -> [a] -> ([a], [a]) + [A] sortedUnionBy :: (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] sortedIntersectBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] sortedDeleteFirstsBy :: (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [R] slicesBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) + [A] schedMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b + [A] schedMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b + [A] schedForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b + [A] schedFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b + [A] scanr :: Monad m => Scanr m a b -> Stream m a -> Stream m b + [A] scanlMany :: Monad m => Scanl m a b -> Stream m a -> Stream m b + [A] scanlBy :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b + [C] scanl + [O] scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b + [N] scanl :: Monad m => Scanl m a b -> Stream m a -> Stream m b + [D] scanMaybe :: Monad m => Fold m a (Maybe b) -> Stream m a -> Stream m b + [D] scanMany :: Monad m => Fold m a b -> Stream m a -> Stream m b + [D] scan :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] sampleFromThen :: Monad m => Int -> Int -> Stream m a -> Stream m a + [D] reduceIterateBfs :: Monad m => (a -> a -> m a) -> Stream m a -> m (Maybe a) + [A] postscanlMaybe :: Monad m => Scanl m a (Maybe b) -> Stream m a -> Stream m b + [A] postscanlBy :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a + [C] postscanl + [O] postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a + [N] postscanl :: Monad m => Scanl m a b -> Stream m a -> Stream m b + [D] postscan :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] pipe :: Monad m => Pipe m a b -> Stream m a -> Stream m b + [A] parsePos :: Monad m => Parser a m b -> Stream m a -> m (Either ParseErrorPos b) + [A] parseManyPos :: Monad m => Parser a m b -> Stream m a -> Stream m (Either ParseErrorPos b) + [D] parseManyD :: Monad m => Parser a m b -> Stream m a -> Stream m (Either ParseError b) + [A] parseIteratePos :: Monad m => (b -> Parser a m b) -> b -> Stream m a -> Stream m (Either ParseErrorPos b) + [D] parseIterateD :: Monad m => (b -> Parser a m b) -> b -> Stream m a -> Stream m (Either ParseError b) + [D] parseD :: Monad m => Parser a m b -> Stream m a -> m (Either ParseError b) + [A] parseBreakPos :: Monad m => Parser a m b -> Stream m a -> m (Either ParseErrorPos b, Stream m a) + [D] parseBreakD :: Monad m => Parser a m b -> Stream m a -> m (Either ParseError b, Stream m a) + [A] outerSortedJoin :: (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (Maybe a, Maybe b) + [A] outerOrdJoin :: (Ord k, MonadIO m) => Stream m (k, a) -> Stream m (k, b) -> Stream m (k, Maybe a, Maybe b) + [A] outerJoin :: MonadIO m => (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (Maybe a, Maybe b) + [A] ordNub :: (Monad m, Ord a) => Stream m a -> Stream m a + [R] nub :: (Monad m, Ord a) => Stream m a -> Stream m a + [D] mkCross :: Stream m a -> Nested m a + [A] loopBy :: Monad m => Unfold m x b -> x -> Stream m a -> Stream m (a, b) + [A] loop :: Monad m => Stream m b -> Stream m a -> Stream m (a, b) + [A] localReaderT :: Monad m => (r -> r) -> Stream (ReaderT r m) a -> Stream (ReaderT r m) a + [A] leftSortedJoin :: (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) + [A] leftOrdJoin :: (Ord k, Monad m) => Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, Maybe b) + [A] leftJoin :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) + [R] joinOuterGeneric :: MonadIO m => (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (Maybe a, Maybe b) + [R] joinOuterAscBy :: (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (Maybe a, Maybe b) + [R] joinOuter :: (Ord k, MonadIO m) => Stream m (k, a) -> Stream m (k, b) -> Stream m (k, Maybe a, Maybe b) + [R] joinLeftGeneric :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) + [R] joinLeftAscBy :: (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) + [R] joinLeft :: (Ord k, Monad m) => Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, Maybe b) + [R] joinInnerGeneric :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, b) + [R] joinInnerAscBy :: (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, b) + [R] joinInner :: (Monad m, Ord k) => Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, b) + [C] isInfixOf + [O] isInfixOf :: (MonadIO m, Eq a, Enum a, Storable a, Unbox a) => Stream m a -> Stream m a -> m Bool + [N] isInfixOf :: (MonadIO m, Eq a, Enum a, Unbox a) => Stream m a -> Stream m a -> m Bool + [R] intersperseMWith :: Int -> m a -> Stream m a -> Stream m a + [D] intersperseMSuffix_ :: Monad m => m b -> Stream m a -> Stream m a + [D] intersperseMSuffixWith :: forall m a. Monad m => Int -> m a -> Stream m a -> Stream m a + [D] intersperseMSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a + [D] intersperseMPrefix_ :: Monad m => m b -> Stream m a -> Stream m a + [A] intersperseEveryM :: Int -> m a -> Stream m a -> Stream m a + [A] intersperseEndByM_ :: Monad m => m b -> Stream m a -> Stream m a + [A] intersperseEndByM :: forall m a. Monad m => m a -> Stream m a -> Stream m a + [A] intersperseEndByEveryM :: forall m a. Monad m => Int -> m a -> Stream m a -> Stream m a + [A] intersperseBeginByM_ :: Monad m => m b -> Stream m a -> Stream m a + [R] intersectBySorted :: Monad m => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] intersectBy :: Monad m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [D] interposeSuffixM :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c + [D] interposeSuffix :: Monad m => c -> Unfold m b c -> Stream m b -> Stream m c + [D] interposeM :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c + [D] interpose :: Monad m => c -> Unfold m b c -> Stream m b -> Stream m c + [A] interleaveSepBy' :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] interleaveSepBy :: Monad m => Stream m a -> Stream m a -> Stream m a + [D] interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a + [D] interleaveFstSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a + [D] interleaveFst :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] interleaveEndBy' :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] interleaveEndBy :: Monad m => Stream m a -> Stream m a -> Stream m a + [A] interleaveBeginBy :: Stream m a -> Stream m a -> Stream m a + [D] intercalateSuffix :: Monad m => Unfold m b c -> b -> Stream m b -> Stream m c + [A] intercalateSepBy :: Monad m => Unfold m b c -> Stream m b -> Unfold m a c -> Stream m a -> Stream m c + [A] intercalateEndBy :: Monad m => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c + [D] intercalate :: Monad m => Unfold m b c -> b -> Stream m b -> Stream m c + [A] innerSortedJoin :: (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, b) + [A] innerOrdJoin :: (Monad m, Ord k) => Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, b) + [A] innerJoin :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, b) + [A] initNonEmpty :: Monad m => Stream m a -> Stream m a + [A] init :: Monad m => Stream m a -> m (Maybe (Stream m a)) + [D] indexOnSuffix :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) + [A] indexEndBy_ :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) + [A] indexEndBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) + [D] gintercalateSuffix :: Monad m => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c + [D] gintercalate :: Monad m => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c + [A] fromW16CString# :: Monad m => Addr# -> Stream m Word16 + [A] fromCString# :: Monad m => Addr# -> Stream m Word8 + [D] fromByteStr# :: Monad m => Addr# -> Stream m Word8 + [A] foldManySepBy :: Fold m a b -> Fold m a b -> Stream m a -> Stream m b + [R] foldIterateBfs :: Fold m a (Either a a) -> Stream m a -> m (Maybe a) + [A] finallyIO'' :: (MonadIO m, MonadCatch m) => AcquireIO -> IO b -> Stream m a -> Stream m a + [A] finallyIO' :: MonadIO m => AcquireIO -> IO b -> Stream m a -> Stream m a + [R] filterInStreamGenericBy :: Monad m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [R] filterInStreamAscBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] fairUnfoldSched :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] fairUnfoldEach :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] fairSchedMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b + [A] fairSchedMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b + [A] fairSchedForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b + [A] fairSchedFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b + [A] fairCrossWithM :: Monad m => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c + [A] fairCrossWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c + [A] fairCross :: Monad m => Stream m a -> Stream m b -> Stream m (a, b) + [A] fairConcatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b + [A] fairConcatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b + [A] fairConcatForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b + [A] fairConcatFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b + [R] deleteInStreamGenericBy :: Monad m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [R] deleteInStreamAscBy :: (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] deleteFirstsBy :: Monad m => (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a + [D] concatIterateDfs :: Monad m => (a -> Maybe (Stream m a)) -> Stream m a -> Stream m a + [D] concatIterateBfsRev :: Monad m => (a -> Maybe (Stream m a)) -> Stream m a -> Stream m a + [D] concatIterateBfs :: Monad m => (a -> Maybe (Stream m a)) -> Stream m a -> Stream m a + [A] concatIterate :: Monad m => (a -> Maybe (Stream m a)) -> Stream m a -> Stream m a + [A] concatForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b + [A] concatFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b + [A] bracketIO'' :: (MonadIO m, MonadCatch m) => AcquireIO -> IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a + [A] bracketIO' :: MonadIO m => AcquireIO -> IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a + [A] bfsUnfoldIterate :: Monad m => Unfold m a a -> Stream m a -> Stream m a + [A] bfsUnfoldEach :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] bfsReduceIterate :: Monad m => (a -> a -> m a) -> Stream m a -> m (Maybe a) + [A] bfsFoldIterate :: Fold m a (Either a a) -> Stream m a -> m (Maybe a) + [A] bfsConcatIterate :: Monad m => (a -> Maybe (Stream m a)) -> Stream m a -> Stream m a + [A] altBfsUnfoldIterate :: Monad m => Unfold m a a -> Stream m a -> Stream m a + [A] altBfsUnfoldEach :: Monad m => Unfold m a b -> Stream m a -> Stream m b + [A] altBfsConcatIterate :: Monad m => (a -> Maybe (Stream m a)) -> Stream m a -> Stream m a +[A] Streamly.Internal.Data.Scanr + [A] Scanr + [A] Scanr :: (s -> a -> m (Step s b)) -> s -> Scanr m a b + [A] GHC.Base.Functor + [A] instance GHC.Base.Functor m => GHC.Base.Functor (Streamly.Internal.Data.Scanr.Scanr m a) + [A] GHC.Base.Applicative + [A] instance GHC.Base.Monad m => GHC.Base.Applicative (Streamly.Internal.Data.Scanr.Scanr m a) + [A] Control.Category.Category + [A] instance GHC.Base.Monad m => Control.Category.Category (Streamly.Internal.Data.Scanr.Scanr m) + [A] Control.Arrow.Arrow + [A] instance GHC.Base.Monad m => Control.Arrow.Arrow (Streamly.Internal.Data.Scanr.Scanr m) + [A] teeWithMay :: Monad m => (Maybe b -> Maybe c -> d) -> Scanr m a b -> Scanr m a c -> Scanr m a d + [A] teeWith :: Monad m => (b -> c -> d) -> Scanr m a b -> Scanr m a c -> Scanr m a d + [A] tee :: Monad m => Scanr m a b -> Scanr m a c -> Scanr m a (b, c) + [A] sum :: (Monad m, Num a) => Scanr m a a + [A] length :: Monad m => Scanr m a Int + [A] identity :: Monad m => Scanr m a a + [A] functionM :: Monad m => (a -> m b) -> Scanr m a b + [A] function :: Monad m => (a -> b) -> Scanr m a b + [A] filterM :: Monad m => (a -> m Bool) -> Scanr m a a + [A] filter :: Monad m => (a -> Bool) -> Scanr m a a + [A] compose :: Monad m => Scanr m b c -> Scanr m a b -> Scanr m a c +[A] Streamly.Internal.Data.Scanl + [A] Step + [A] Partial :: !s -> Step s b + [A] Done :: !b -> Step s b + [A] Scanl + [A] Scanl :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> (s -> m b) -> Scanl m a b + [A] Incr + [A] Replace :: !a -> !a -> Incr a + [A] Insert :: !a -> Incr a + [A] zipStreamWithM :: (a -> b -> m c) -> Stream m a -> Scanl m c x -> Scanl m b x + [A] zipStream :: Monad m => Stream m a -> Scanl m (a, b) x -> Scanl m b x + [A] with :: (Scanl m (s, a) b -> Scanl m a b) -> (((s, a) -> c) -> Scanl m (s, a) b -> Scanl m (s, a) b) -> ((s, a) -> c) -> Scanl m a b -> Scanl m a b + [A] windowRange :: forall m a. (MonadIO m, Unbox a, Ord a) => Int -> Scanl m a (Maybe (a, a)) + [A] windowMinimum :: (MonadIO m, Unbox a, Ord a) => Int -> Scanl m a (Maybe a) + [A] windowMaximum :: (MonadIO m, Unbox a, Ord a) => Int -> Scanl m a (Maybe a) + [A] unzipWithM :: Monad m => (a -> m (b, c)) -> Scanl m b x -> Scanl m c y -> Scanl m a (x, y) + [A] unzipWith :: Monad m => (a -> (b, c)) -> Scanl m b x -> Scanl m c y -> Scanl m a (x, y) + [A] unzip :: Monad m => Scanl m a x -> Scanl m b y -> Scanl m (a, b) (x, y) + [A] uniqBy :: Monad m => (a -> a -> Bool) -> Scanl m a (Maybe a) + [A] uniq :: (Monad m, Eq a) => Scanl m a (Maybe a) + [A] unfoldMany :: Monad m => Unfold m a b -> Scanl m b c -> Scanl m a c + [A] topBy :: (MonadIO m, Unbox a) => (a -> a -> Ordering) -> Int -> Scanl m a (MutArray a) + [A] top :: (MonadIO m, Unbox a, Ord a) => Int -> Scanl m a (MutArray a) + [A] toStreamRev :: (Monad m, Monad n) => Scanl m a (Stream n a) + [A] toStreamKRev :: Monad m => Scanl m a (StreamK n a) + [A] toStreamK :: Monad m => Scanl m a (StreamK n a) + [A] toStream :: (Monad m, Monad n) => Scanl m a (Stream n a) + [A] toSet :: (Monad m, Ord a) => Scanl m a (Set a) + [A] toListRev :: Monad m => Scanl m a [a] + [A] toList :: Monad m => Scanl m a [a] + [A] toIntSet :: Monad m => Scanl m Int IntSet + [A] the :: (Monad m, Eq a) => Scanl m a (Maybe a) + [A] teeWith :: Monad m => (b -> c -> d) -> Scanl m a b -> Scanl m a c -> Scanl m a d + [A] tee :: Monad m => Scanl m a b -> Scanl m a c -> Scanl m a (b, c) + [A] takingEndBy_ :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) + [A] takingEndByM_ :: Monad m => (a -> m Bool) -> Scanl m a (Maybe a) + [A] takingEndByM :: Monad m => (a -> m Bool) -> Scanl m a (Maybe a) + [A] takingEndBy :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) + [A] taking :: Monad m => Int -> Scanl m a (Maybe a) + [A] takeEndBy_ :: Monad m => (a -> Bool) -> Scanl m a b -> Scanl m a b + [A] takeEndBy :: Monad m => (a -> Bool) -> Scanl m a b -> Scanl m a b + [A] take :: Monad m => Int -> Scanl m a b -> Scanl m a b + [A] sum :: (Monad m, Num a) => Scanl m a a + [A] sconcat :: (Monad m, Semigroup a) => a -> Scanl m a a + [A] scanlMany :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c + [A] scanl :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c + [A] sampleFromthen :: Monad m => Int -> Int -> Scanl m a b -> Scanl m a b + [A] rollingMapM :: Monad m => (Maybe a -> a -> m b) -> Scanl m a b + [A] rollingMap :: Monad m => (Maybe a -> a -> b) -> Scanl m a b + [A] rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Scanl m a Int64 + [A] rollingHashFirstN :: (Monad m, Enum a) => Int -> Scanl m a Int64 + [A] rollingHash :: (Monad m, Enum a) => Scanl m a Int64 + [A] rmapM :: Monad m => (b -> m c) -> Scanl m a b -> Scanl m a c + [A] repeated :: Scanl m a (Maybe a) + [A] rangeBy :: Monad m => (a -> a -> Ordering) -> Scanl m a (Maybe (a, a)) + [A] range :: (Monad m, Ord a) => Scanl m a (Maybe (a, a)) + [A] prune :: (a -> Bool) -> Scanl m a (Maybe a) + [A] product :: (Monad m, Num a, Eq a) => Scanl m a a + [A] postscanlMaybe :: Monad m => Scanl m a (Maybe b) -> Scanl m b c -> Scanl m a c + [A] postscanl :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c + [A] pipe :: Monad m => Pipe m a b -> Scanl m b c -> Scanl m a c + [A] partitionByM :: Monad m => (a -> m (Either b c)) -> Scanl m b x -> Scanl m c x -> Scanl m a x + [A] partitionBy :: Monad m => (a -> Either b c) -> Scanl m b x -> Scanl m c x -> Scanl m a x + [A] partition :: Monad m => Scanl m b x -> Scanl m c x -> Scanl m (Either b c) x + [A] nubInt :: Monad m => Scanl m Int (Maybe Int) + [A] nub :: (Monad m, Ord a) => Scanl m a (Maybe a) + [A] morphInner :: (forall x. m x -> n x) -> Scanl m a b -> Scanl n a b + [A] mkScantM :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> Scanl m a b + [A] mkScant :: Monad m => (s -> a -> Step s b) -> Step s b -> (s -> b) -> Scanl m a b + [A] mkScanrM :: Monad m => (a -> b -> m b) -> m b -> Scanl m a b + [A] mkScanr :: Monad m => (a -> b -> b) -> b -> Scanl m a b + [A] mkScanlM :: Monad m => (b -> a -> m b) -> m b -> Scanl m a b + [A] mkScanl1M :: Monad m => (a -> a -> m a) -> Scanl m a (Maybe a) + [A] mkScanl1 :: Monad m => (a -> a -> a) -> Scanl m a (Maybe a) + [A] mkScanl :: Monad m => (b -> a -> b) -> b -> Scanl m a b + [A] minimumBy :: Monad m => (a -> a -> Ordering) -> Scanl m a (Maybe a) + [A] minimum :: (Monad m, Ord a) => Scanl m a (Maybe a) + [A] mean :: (Monad m, Fractional a) => Scanl m a a + [A] mconcat :: (Monad m, Monoid a) => Scanl m a a + [A] maximumBy :: Monad m => (a -> a -> Ordering) -> Scanl m a (Maybe a) + [A] maximum :: (Monad m, Ord a) => Scanl m a (Maybe a) + [A] mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Scanl m b r -> Scanl m a r + [A] mapMaybe :: Monad m => (a -> Maybe b) -> Scanl m b r -> Scanl m a r + [A] mapMStep :: Applicative m => (a -> m b) -> Step s a -> m (Step s b) + [A] lmapM :: Monad m => (a -> m b) -> Scanl m b r -> Scanl m a r + [A] lmap :: (a -> b) -> Scanl m b r -> Scanl m a r + [A] length :: Monad m => Scanl m a Int + [A] latest :: Monad m => Scanl m a (Maybe a) + [A] indexingWith :: Monad m => Int -> (Int -> Int) -> Scanl m a (Maybe (Int, a)) + [A] indexingRev :: Monad m => Int -> Scanl m a (Maybe (Int, a)) + [A] indexing :: Monad m => Scanl m a (Maybe (Int, a)) + [A] indexed :: Monad m => Scanl m (Int, a) b -> Scanl m a b + [A] incrSumInt :: forall m a. (Monad m, Integral a) => Scanl m (Incr a) a + [A] incrSum :: forall m a. (Monad m, Num a) => Scanl m (Incr a) a + [A] incrScanWith :: forall m a b. (MonadIO m, Unbox a) => Int -> Scanl m (Incr a, RingArray a) b -> Scanl m a b + [A] incrScan :: forall m a b. (MonadIO m, Unbox a) => Int -> Scanl m (Incr a) b -> Scanl m a b + [A] incrRollingMapM :: Monad m => (Maybe a -> a -> m (Maybe b)) -> Scanl m (Incr a) (Maybe b) + [A] incrRollingMap :: Monad m => (Maybe a -> a -> Maybe b) -> Scanl m (Incr a) (Maybe b) + [A] incrPowerSumFrac :: (Monad m, Floating a) => a -> Scanl m (Incr a) a + [A] incrPowerSum :: (Monad m, Num a) => Int -> Scanl m (Incr a) a + [A] incrMean :: forall m a. (Monad m, Fractional a) => Scanl m (Incr a) a + [A] incrCount :: (Monad m, Num b) => Scanl m (Incr a) b + [A] genericLength :: (Monad m, Num b) => Scanl m a b + [A] generalizeInner :: Monad m => Scanl Identity a b -> Scanl m a b + [A] functionM :: Monad m => (a -> m (Maybe b)) -> Scanl m a (Maybe b) + [A] fromRefold :: Refold m c a b -> c -> Scanl m a b + [A] foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Scanl m a b + [A] foldMap :: (Monad m, Monoid b) => (a -> b) -> Scanl m a b + [A] findIndices :: Monad m => (a -> Bool) -> Scanl m a (Maybe Int) + [A] filtering :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) + [A] filterM :: Monad m => (a -> m Bool) -> Scanl m a r -> Scanl m a r + [A] filter :: Monad m => (a -> Bool) -> Scanl m a r -> Scanl m a r + [A] elemIndices :: (Monad m, Eq a) => a -> Scanl m a (Maybe Int) + [A] droppingWhileM :: Monad m => (a -> m Bool) -> Scanl m a (Maybe a) + [A] droppingWhile :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) + [A] dropping :: Monad m => Int -> Scanl m a (Maybe a) + [A] drainN :: Monad m => Int -> Scanl m a () + [A] drainMapM :: Monad m => (a -> m b) -> Scanl m a () + [A] drain :: Monad m => Scanl m a () + [A] distribute :: Monad m => [Scanl m a b] -> Scanl m a [b] + [A] demuxIO :: (MonadIO m, Ord k) => (a -> k) -> (k -> m (Maybe (Scanl m a b))) -> Scanl m a (Maybe (k, b)) + [A] demuxGenericIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> (Key f -> m (Maybe (Scanl m a b))) -> Scanl m a (m (f b), Maybe (Key f, b)) + [A] demuxGeneric :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> (Key f -> m (Maybe (Scanl m a b))) -> Scanl m a (m (f b), Maybe (Key f, b)) + [A] demux :: (Monad m, Ord k) => (a -> k) -> (k -> m (Maybe (Scanl m a b))) -> Scanl m a (Maybe (k, b)) + [A] deleteBy :: Monad m => (a -> a -> Bool) -> a -> Scanl m a (Maybe a) + [A] defaultSalt :: Int64 + [A] cumulativeScan :: Scanl m (Incr a) b -> Scanl m a b + [A] countDistinctInt :: Monad m => Scanl m Int Int + [A] countDistinct :: (Monad m, Ord a) => Scanl m a Int + [A] constM :: Applicative m => m b -> Scanl m a b + [A] const :: Applicative m => b -> Scanl m a b + [A] classifyIO :: (MonadIO m, Ord k) => (a -> k) -> Scanl m a b -> Scanl m a (Maybe (k, b)) + [A] classifyGenericIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Scanl m a b -> Scanl m a (m (f b), Maybe (Key f, b)) + [A] classifyGeneric :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Scanl m a b -> Scanl m a (m (f b), Maybe (Key f, b)) + [A] classify :: (MonadIO m, Ord k) => (a -> k) -> Scanl m a b -> Scanl m a (Maybe (k, b)) + [A] chainStepM :: Applicative m => (s1 -> m s2) -> (a -> m (Step s2 b)) -> Step s1 a -> m (Step s2 b) + [A] catRights :: Monad m => Scanl m b c -> Scanl m (Either a b) c + [A] catMaybes :: Monad m => Scanl m a b -> Scanl m (Maybe a) b + [A] catLefts :: Monad m => Scanl m a c -> Scanl m (Either a b) c + [A] catEithers :: Scanl m a b -> Scanl m (Either a a) b + [A] bottomBy :: (MonadIO m, Unbox a) => (a -> a -> Ordering) -> Int -> Scanl m a (MutArray a) + [A] bottom :: (MonadIO m, Unbox a, Ord a) => Int -> Scanl m a (MutArray a) +[A] Streamly.Internal.Data.RingArray.Generic + [A] RingArray + [A] [ringMax] :: RingArray a -> !Int + [A] [ringHead] :: RingArray a -> !Int + [A] [ringArr] :: RingArray a -> MutArray a + [A] RingArray :: MutArray a -> !Int -> !Int -> RingArray a + [A] unsafeInsertRingWith :: RingArray a -> a -> IO Int + [A] toStreamWith :: Int -> RingArray a -> Stream m a + [A] toMutArray :: MonadIO m => Int -> Int -> RingArray a -> m (MutArray a) + [A] seek :: MonadIO m => Int -> RingArray a -> m (RingArray a) + [A] emptyOf :: MonadIO m => Int -> m (RingArray a) + [A] createOf :: MonadIO m => Int -> Fold m a (RingArray a) + [A] copyToMutArray :: MonadIO m => Int -> Int -> RingArray a -> m (MutArray a) +[A] Streamly.Internal.Data.RingArray + [A] RingArray + [A] [ringSize] :: RingArray a -> {-# UNPACK #-} !Int + [A] [ringHead] :: RingArray a -> {-# UNPACK #-} !Int + [A] [ringContents] :: RingArray a -> {-# UNPACK #-} !MutByteArray + [A] RingArray :: {-# UNPACK #-} !MutByteArray -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> RingArray a + [A] unsafeGetIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> m a + [A] unsafeGetHead :: (MonadIO m, Unbox a) => RingArray a -> m a + [A] unsafeCastMutArrayWith :: forall a. Unbox a => Int -> MutArray a -> RingArray a + [A] unsafeCastMutArray :: forall a. Unbox a => MutArray a -> RingArray a + [A] unsafeCast :: RingArray a -> RingArray b + [A] toMutArray :: (MonadIO m, Unbox a) => RingArray a -> m (MutArray a) + [A] toList :: (MonadIO m, Unbox a) => RingArray a -> m [a] + [A] showRing :: (Unbox a, Show a) => RingArray a -> IO String + [A] scanRingsOf :: forall m a. (MonadIO m, Unbox a) => Int -> Scanl m a (RingArray a) + [A] scanFoldRingsBy :: forall m a b. (MonadIO m, Unbox a) => Fold m a b -> Int -> Scanl m a b + [A] scanCustomFoldRingsBy :: forall m a b. (MonadIO m, Unbox a) => (RingArray a -> m b) -> Int -> Scanl m a b + [A] ringsOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (RingArray a) + [A] replace_ :: forall m a. (MonadIO m, Unbox a) => RingArray a -> a -> m (RingArray a) + [A] replace :: forall m a. (MonadIO m, Unbox a) => RingArray a -> a -> m (RingArray a, a) + [A] readerRev :: forall m a. (MonadIO m, Unbox a) => Unfold m (RingArray a) a + [A] reader :: forall m a. (MonadIO m, Unbox a) => Unfold m (RingArray a) a + [A] readRev :: forall m a. (MonadIO m, Unbox a) => RingArray a -> Stream m a + [A] read :: forall m a. (MonadIO m, Unbox a) => RingArray a -> Stream m a + [A] putIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> a -> m () + [A] moveReverse :: forall a. Unbox a => RingArray a -> RingArray a + [A] moveForward :: forall a. Unbox a => RingArray a -> RingArray a + [A] moveBy :: forall a. Unbox a => Int -> RingArray a -> RingArray a + [A] modifyIndex :: Int -> RingArray a -> (a -> (a, b)) -> m b + [A] length :: forall a. Unbox a => RingArray a -> Int + [A] insert :: RingArray a -> a -> m (RingArray a) + [A] getIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> m (Maybe a) + [A] foldlM' :: forall m a b. (MonadIO m, Unbox a) => (b -> a -> m b) -> b -> RingArray a -> m b + [A] fold :: forall m a b. (MonadIO m, Unbox a) => Fold m a b -> RingArray a -> m b + [A] eqArrayN :: RingArray a -> Array a -> Int -> IO Bool + [A] eqArray :: RingArray a -> Array a -> IO Bool + [A] createOfLast :: (Unbox a, MonadIO m) => Int -> Fold m a (RingArray a) + [A] castMutArrayWith :: forall a. Unbox a => Int -> MutArray a -> Maybe (RingArray a) + [A] castMutArray :: forall a. Unbox a => MutArray a -> Maybe (RingArray a) + [A] cast :: forall a b. Unbox b => RingArray a -> Maybe (RingArray b) + [A] byteLength :: RingArray a -> Int + [A] asMutArray_ :: RingArray a -> MutArray a + [A] asMutArray :: RingArray a -> (MutArray a, Int) + [A] asBytes :: RingArray a -> RingArray Word8 +[R] Streamly.Internal.Data.Ring.Generic +[R] Streamly.Internal.Data.Ring +[C] Streamly.Internal.Data.Producer + [C] parse + [O] parse :: Monad m => Parser a m b -> Producer m (Source s a) a -> Source s a -> m (Either ParseError b, Source s a) + [N] parse :: Monad m => Parser a m b -> Producer m (Source s a) a -> Source s a -> m (Either ParseErrorPos b, Source s a) +[C] Streamly.Internal.Data.Pipe + [C] Step + [A] YieldP :: ps -> b -> Step cs ps b + [A] YieldC :: cs -> b -> Step cs ps b + [R] Yield :: a -> s -> Step s a + [A] Stop :: Step cs ps b + [A] SkipP :: ps -> Step cs ps b + [A] SkipC :: cs -> Step cs ps b + [R] Continue :: s -> Step s a + [R] PipeState + [C] Pipe + [C] Pipe + [O] Pipe :: (s1 -> a -> m (Step (PipeState s1 s2) b)) -> (s2 -> m (Step (PipeState s1 s2) b)) -> s1 -> Pipe m a b + [N] Pipe :: (cs -> a -> m (Step cs ps b)) -> (ps -> m (Step cs ps b)) -> cs -> Pipe m a b + [R] zipWith :: Monad m => (a -> b -> c) -> Pipe m i a -> Pipe m i b -> Pipe m i c + [A] teeMerge :: Monad m => Pipe m a b -> Pipe m a b -> Pipe m a b + [R] tee :: Monad m => Pipe m a b -> Pipe m a b -> Pipe m a b + [A] scanFold :: Monad m => Fold m a b -> Pipe m a b + [A] identity :: Monad m => Pipe m a a + [A] fromStream :: Monad m => Stream m a -> Pipe m () a + [A] fromScanr :: Monad m => Scanr m a b -> Pipe m a b + [A] fromFold :: Monad m => Fold m a b -> Pipe m a b + [A] filterM :: Monad m => (a -> m Bool) -> Pipe m a a + [A] filter :: Monad m => (a -> Bool) -> Pipe m a a +[A] Streamly.Internal.Data.Path + [A] class IsPath a b + [A] GHC.Show.Show + [A] instance GHC.Show.Show Streamly.Internal.Data.Path.PathException + [A] GHC.Exception.Type.Exception + [A] instance GHC.Exception.Type.Exception Streamly.Internal.Data.Path.PathException + [A] GHC.Classes.Eq + [A] instance GHC.Classes.Eq Streamly.Internal.Data.Path.PathException + [A] PathException + [A] InvalidPath :: String -> PathException + [A] unsafeFromPath :: IsPath a b => a -> b + [A] toPath :: IsPath a b => b -> a + [A] fromPath :: (IsPath a b, MonadThrow m) => a -> m b +[C] Streamly.Internal.Data.ParserK + [C] Step + [C] Partial + [O] Partial :: !Int -> (Input a -> m (Step a m r)) -> Step a m r + [N] Partial :: !Int -> StepParser a m r -> Step a m r + [C] Continue + [O] Continue :: !Int -> (Input a -> m (Step a m r)) -> Step a m r + [N] Continue :: !Int -> StepParser a m r -> Step a m r + [C] ParserK + [C] [runParser] + [O] [runParser] :: ParserK a m b -> forall r. (ParseResult b -> Int -> Input a -> m (Step a m r)) -> Int -> Int -> Input a -> m (Step a m r) + [N] [runParser] :: ParserK a m b -> forall r. (ParseResult b -> Int -> StepParser a m r) -> Int -> Int -> StepParser a m r + [C] MkParser + [O] MkParser :: (forall r. (ParseResult b -> Int -> Input a -> m (Step a m r)) -> Int -> Int -> Input a -> m (Step a m r)) -> ParserK a m b + [N] MkParser :: (forall r. (ParseResult b -> Int -> StepParser a m r) -> Int -> Int -> StepParser a m r) -> ParserK a m b + [A] toParserK :: Monad m => Parser a m b -> ParserK a m b + [A] toParser :: Monad m => ParserK a m b -> Parser a m b + [A] parserDone :: Applicative m => ParseResult b -> Int -> Input a -> m (Step a m b) + [A] chainr1 :: ParserK b IO a -> ParserK b IO (a -> a -> a) -> ParserK b IO a + [A] chainr :: ParserK b IO a -> ParserK b IO (a -> a -> a) -> a -> ParserK b IO a + [A] chainl1 :: ParserK b IO a -> ParserK b IO (a -> a -> a) -> ParserK b IO a + [A] chainl :: ParserK b IO a -> ParserK b IO (a -> a -> a) -> a -> ParserK b IO a + [D] adaptCG :: Monad m => Parser a m b -> ParserK (Array a) m b + [D] adaptC :: (Monad m, Unbox a) => Parser a m b -> ParserK (Array a) m b + [D] adapt :: Monad m => Parser a m b -> ParserK a m b +[C] Streamly.Internal.Data.Parser + [C] Step + [A] SPartial :: !Int -> !s -> Step s b + [A] SError :: !String -> Step s b + [A] SDone :: !Int -> !b -> Step s b + [A] SContinue :: !Int -> !s -> Step s b + [R] Partial :: !Int -> !s -> Step s b + [R] Error :: !String -> Step s b + [R] Done :: !Int -> !b -> Step s b + [R] Continue :: !Int -> !s -> Step s b + [C] Parser + [C] Parser + [O] Parser :: (s -> a -> m (Step s b)) -> m (Initial s b) -> (s -> m (Step s b)) -> Parser a m b + [N] Parser :: (s -> a -> m (Step s b)) -> m (Initial s b) -> (s -> m (Final s b)) -> Parser a m b + [A] ParseErrorPos + [A] ParseErrorPos :: Int -> String -> ParseErrorPos + [A] Final + [A] FError :: !String -> Final s b + [A] FDone :: !Int -> !b -> Final s b + [A] FContinue :: !Int -> !s -> Final s b + [C] ParseError + [D] takeStartBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b + [D] takeStartBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b + [C] takeEndBy_ + [O] takeEndBy_ :: (a -> Bool) -> Parser a m b -> Parser a m b + [N] takeEndBy_ :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b + [A] takeBeginBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b + [A] takeBeginBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b + [A] mapCount :: (Int -> Int) -> Step s b -> Step s b + [A] localReaderT :: (r -> r) -> Parser a (ReaderT r m) b -> Parser a (ReaderT r m) b + [R] extractStep :: Monad m => (s -> m (Step s1 b)) -> Step s b -> m (Step s1 b) + [A] bimapMorphOverrideCount :: Int -> (s -> s1) -> (b -> b1) -> Final s b -> Step s1 b1 +[C] Streamly.Internal.Data.MutByteArray + [A] unsafePutSlice :: MonadIO m => MutByteArray -> Int -> MutByteArray -> Int -> Int -> m () + [A] unsafePutPtrN :: MonadIO m => Ptr Word8 -> MutByteArray -> Int -> Int -> m () + [A] unsafePinnedCloneSlice :: MonadIO m => Int -> Int -> MutByteArray -> m MutByteArray + [A] unsafeCloneSliceAs :: MonadIO m => PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray + [A] unsafeCloneSlice :: MonadIO m => Int -> Int -> MutByteArray -> m MutByteArray + [A] unsafeByteCmp :: MutByteArray -> Int -> MutByteArray -> Int -> Int -> IO Int + [C] unsafeAsPtr + [O] unsafeAsPtr :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b + [N] unsafeAsPtr :: MonadIO m => MutByteArray -> (Ptr a -> IO b) -> m b + [A] touch :: MutByteArray -> IO () + [D] sizeOfMutableByteArray :: MutByteArray -> IO Int + [A] reallocSliceAs :: PinnedState -> Int -> MutByteArray -> Int -> Int -> IO MutByteArray + [D] putSliceUnsafe :: MonadIO m => MutByteArray -> Int -> MutByteArray -> Int -> Int -> m () + [D] pinnedNewAlignedBytes :: Int -> Int -> IO MutByteArray + [D] pinnedNew :: Int -> IO MutByteArray + [D] pinnedCloneSliceUnsafe :: MonadIO m => Int -> Int -> MutByteArray -> m MutByteArray + [D] newBytesAs :: PinnedState -> Int -> IO MutByteArray + [A] newAs :: PinnedState -> Int -> IO MutByteArray + [A] new' :: Int -> IO MutByteArray + [A] length :: MutByteArray -> IO Int + [A] largeObjectThreshold :: Int + [D] getMutableByteArray# :: MutByteArray -> MutableByteArray# RealWorld + [A] getMutByteArray# :: MutByteArray -> MutableByteArray# RealWorld + [D] cloneSliceUnsafeAs :: MonadIO m => PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray + [D] cloneSliceUnsafe :: MonadIO m => Int -> Int -> MutByteArray -> m MutByteArray + [A] blockSize :: Int +[C] Streamly.Internal.Data.MutArray.Generic + [C] MutArray + [R] [arrTrueLen] :: MutArray a -> {-# UNPACK #-} !Int + [R] [arrLen] :: MutArray a -> {-# UNPACK #-} !Int + [A] [arrEnd] :: MutArray a -> {-# UNPACK #-} !Int + [A] [arrBound] :: MutArray a -> {-# UNPACK #-} !Int + [D] writeN :: MonadIO m => Int -> Fold m a (MutArray a) + [D] write :: MonadIO m => Fold m a (MutArray a) + [A] unsafeSnoc :: MonadIO m => MutArray a -> a -> m (MutArray a) + [A] unsafeSliceOffLen :: Int -> Int -> MutArray a -> MutArray a + [A] unsafePutSlice :: MonadIO m => MutArray a -> Int -> MutArray a -> Int -> Int -> m () + [A] unsafePutIndex :: forall m a. MonadIO m => Int -> MutArray a -> a -> m () + [A] unsafeModifyIndex :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] unsafeGetIndexWith :: MonadIO m => MutableArray# RealWorld a -> Int -> m a + [A] unsafeGetIndex :: MonadIO m => Int -> MutArray a -> m a + [D] strip :: MonadIO m => (a -> Bool) -> MutArray a -> m (MutArray a) + [D] snocUnsafe :: MonadIO m => MutArray a -> a -> m (MutArray a) + [A] sliceOffLen :: Int -> Int -> MutArray a -> MutArray a + [D] putSliceUnsafe :: MonadIO m => MutArray a -> Int -> MutArray a -> Int -> Int -> m () + [D] putIndexUnsafe :: forall m a. MonadIO m => Int -> MutArray a -> a -> m () + [D] new :: MonadIO m => Int -> m (MutArray a) + [D] modifyIndexUnsafe :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] initializeOfFilledUpto :: MonadIO m => Int -> Int -> a -> m (MutArray a) + [D] getSliceUnsafe :: Int -> Int -> MutArray a -> MutArray a + [D] getSlice :: Int -> Int -> MutArray a -> MutArray a + [D] getIndexUnsafeWith :: MonadIO m => MutableArray# RealWorld a -> Int -> m a + [D] getIndexUnsafe :: MonadIO m => Int -> MutArray a -> m a + [A] dropAround :: MonadIO m => (a -> Bool) -> MutArray a -> m (MutArray a) +[C] Streamly.Internal.Data.MutArray + [R] IORef + [D] writeNWith :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [D] writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] writeIORef :: Unbox a => IORef a -> a -> IO () + [D] writeAppendN :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [D] writeAppend :: forall m a. (MonadIO m, Unbox a) => m (MutArray a) -> Fold m a (MutArray a) + [D] write :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [A] vacate :: MutArray a -> MutArray a + [A] unsafeSplice :: MonadIO m => MutArray a -> MutArray a -> m (MutArray a) + [A] unsafeSnoc :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) + [A] unsafeSliceOffLen :: forall a. Unbox a => Int -> Int -> MutArray a -> MutArray a + [A] unsafePutIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () + [A] unsafePokeSkip :: Int -> MutArray Word8 -> MutArray Word8 + [D] unsafePinnedCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] unsafePeekSkip :: Int -> MutArray Word8 -> MutArray Word8 + [A] unsafePeek :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> m (a, MutArray Word8) + [A] unsafeModifyIndex :: forall m a b. (MonadIO m, Unbox a) => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] unsafeGetIndexRev :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [A] unsafeGetIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [A] unsafeCreateWithPtr' :: MonadIO m => Int -> (Ptr Word8 -> IO Int) -> m (MutArray Word8) + [A] unsafeCreateWithOf :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [R] unsafeCreateOfWith :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [A] unsafeCreateOf' :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] unsafeCast :: MutArray a -> MutArray b + [A] unsafeBreakAt :: forall a. Unbox a => Int -> MutArray a -> (MutArray a, MutArray a) + [C] unsafeAsPtr + [O] unsafeAsPtr :: MonadIO m => MutArray a -> (Ptr a -> m b) -> m b + [N] unsafeAsPtr :: MonadIO m => MutArray a -> (Ptr a -> Int -> IO b) -> m b + [A] unsafeAppendPtrN :: MonadIO m => MutArray Word8 -> Ptr Word8 -> Int -> m (MutArray Word8) + [D] unsafeAppendN :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [A] unsafeAppendMax :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> Fold m a (MutArray a) + [A] toMutByteArray :: MutArray a -> (MutByteArray, Int, Int) + [D] strip :: forall a m. (Unbox a, MonadIO m) => (a -> Bool) -> MutArray a -> m (MutArray a) + [A] splitterFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (MutArray a) + [D] splitOn :: (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> Stream m (MutArray a) + [A] splitEndBy_ :: (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> Stream m (MutArray a) + [A] splitEndBy :: (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> Stream m (MutArray a) + [D] splitAt :: forall a. Unbox a => Int -> MutArray a -> (MutArray a, MutArray a) + [D] spliceUnsafe :: MonadIO m => MutArray a -> MutArray a -> m (MutArray a) + [D] snocUnsafe :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) + [D] snocLinear :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) + [A] snocGrowBy :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m (MutArray a) + [D] slicerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (MutArray a) + [A] sliceOffLen :: forall a. Unbox a => Int -> Int -> MutArray a -> MutArray a + [D] sliceIndexerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (Int, Int) + [A] serializePtrN :: MutArray Word8 -> Ptr a -> Int -> m (MutArray Word8) + [A] serialize :: forall m a. (MonadIO m, Serialize a) => MutArray Word8 -> a -> m (MutArray Word8) + [A] scanCompactMin' :: forall m a. (MonadIO m, Unbox a) => Int -> Scanl m (MutArray a) (Maybe (MutArray a)) + [A] scanCompactMin :: forall m a. (MonadIO m, Unbox a) => Int -> Scanl m (MutArray a) (Maybe (MutArray a)) + [A] revDropWhile :: forall a m. (Unbox a, MonadIO m) => (a -> Bool) -> MutArray a -> m (MutArray a) + [A] revBreakEndBy_ :: (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) + [A] revBreakEndBy :: (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) + [A] reallocBytesWith :: forall m a. (MonadIO m, Unbox a) => String -> (Int -> Int) -> Int -> MutArray a -> m (MutArray a) + [A] reallocBytes :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [D] realloc :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [D] readIORef :: Unbox a => IORef a -> IO a + [A] rangeBy :: (a -> a -> Ordering) -> MutArray a -> IO (Maybe (a, a)) + [D] putIndexUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () + [D] pollIntIORef :: (MonadIO m, Unbox a) => IORef a -> Stream m a + [D] pokeSkipUnsafe :: Int -> MutArray Word8 -> MutArray Word8 + [A] pokeMay :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> a -> m (Maybe (MutArray Word8)) + [D] pokeAppendMay :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> a -> m (Maybe (MutArray Word8)) + [D] pokeAppend :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> a -> m (MutArray Word8) + [A] poke :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> a -> m (MutArray Word8) + [D] pinnedNewAligned :: (MonadIO m, Unbox a) => Int -> Int -> m (MutArray a) + [D] pinnedNew :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) + [D] pinnedFromListN :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) + [D] pinnedFromList :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) + [D] pinnedEmptyOf :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [D] pinnedCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] pinnedCreate :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [D] pinnedCompactLE :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [D] pinnedClone :: MonadIO m => MutArray a -> m (MutArray a) + [D] pinnedChunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (MutArray a) + [D] peekUnconsUnsafe :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> m (a, MutArray Word8) + [D] peekUncons :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> m (Maybe a, MutArray Word8) + [D] peekSkipUnsafe :: Int -> MutArray Word8 -> MutArray Word8 + [A] peek :: forall m a. (MonadIO m, Unbox a) => MutArray Word8 -> m (Maybe a, MutArray Word8) + [D] pPinnedCompactLE :: forall m a. (MonadIO m, Unbox a) => Int -> Parser (MutArray a) m (MutArray a) + [D] pCompactLE :: forall m a. (MonadIO m, Unbox a) => Int -> Parser (MutArray a) m (MutArray a) + [D] newIORef :: forall a. Unbox a => a -> IO (IORef a) + [D] newArrayWith :: forall m a. (MonadIO m, Unbox a) => (Int -> Int -> IO MutByteArray) -> Int -> Int -> m (MutArray a) + [D] new :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [D] modifyIndexUnsafe :: forall m a b. (MonadIO m, Unbox a) => Int -> MutArray a -> (a -> (a, b)) -> m b + [D] modifyIORef' :: Unbox a => IORef a -> (a -> a) -> IO () + [D] lPinnedCompactGE :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () + [D] lCompactGE :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () + [A] isPower2 :: Int -> Bool + [A] indexerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (MutArray a) (Int, Int) + [A] growTo :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [A] growBy :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [D] grow :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) + [D] getSliceUnsafe :: forall a. Unbox a => Int -> Int -> MutArray a -> MutArray a + [D] getSlice :: forall a. Unbox a => Int -> Int -> MutArray a -> MutArray a + [D] getIndexUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [A] fromW16CString# :: MonadIO m => Addr# -> m (MutArray Word16) + [A] fromMutByteArray :: MonadIO m => MutByteArray -> Int -> Int -> m (MutArray a) + [A] fromListN' :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) + [A] fromList' :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) + [A] fromCString# :: MonadIO m => Addr# -> m (MutArray Word8) + [D] fromByteStr# :: MonadIO m => Addr# -> m (MutArray Word8) + [A] free :: forall a. Unbox a => MutArray a -> Int + [A] foldRev :: (MonadIO m, Unbox a) => Fold m a b -> MutArray a -> m b + [A] fold :: (MonadIO m, Unbox a) => Fold m a b -> MutArray a -> m b + [D] fPinnedCompactGE :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) (MutArray a) + [D] fCompactGE :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) (MutArray a) + [A] emptyWithAligned :: forall m a. (MonadIO m, Unbox a) => (Int -> Int -> IO MutByteArray) -> Int -> Int -> m (MutArray a) + [A] emptyOf' :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] dropWhile :: forall a m. (Unbox a, MonadIO m) => (a -> Bool) -> MutArray a -> m (MutArray a) + [A] dropAround :: forall a m. (Unbox a, MonadIO m) => (a -> Bool) -> MutArray a -> m (MutArray a) + [A] deserializePtrN :: MutArray Word8 -> (Ptr a -> Int -> m b) -> m (a, MutArray Word8) + [A] deserialize :: (MonadIO m, Serialize a) => MutArray Word8 -> m (a, MutArray Word8) + [A] createWithOf :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [D] createWith :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [D] createOfWith :: forall m a. (MonadIO m, Unbox a) => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) + [A] createOfLast :: (Unbox a, MonadIO m) => Int -> Fold m a (MutArray a) + [A] createOf' :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] createMinOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) + [A] createCompactMin' :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) (MutArray a) + [A] createCompactMin :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m (MutArray a) (MutArray a) + [A] createCompactMax' :: forall m a. (MonadIO m, Unbox a) => Int -> Parser (MutArray a) m (MutArray a) + [A] createCompactMax :: forall m a. (MonadIO m, Unbox a) => Int -> Parser (MutArray a) m (MutArray a) + [A] create' :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) + [A] compactSepByByte_ :: MonadIO m => Word8 -> Stream m (MutArray Word8) -> Stream m (MutArray Word8) + [D] compactOnByteSuffix :: MonadIO m => Word8 -> Stream m (MutArray Word8) -> Stream m (MutArray Word8) + [D] compactOnByte :: MonadIO m => Word8 -> Stream m (MutArray Word8) -> Stream m (MutArray Word8) + [A] compactMin :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] compactMax' :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] compactMax :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [D] compactLE :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [D] compactGE :: (MonadIO m, Unbox a) => Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] compactExact :: Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] compactEndByLn_ :: MonadIO m => Stream m (MutArray Word8) -> Stream m (MutArray Word8) + [A] compactEndByByte_ :: MonadIO m => Word8 -> Stream m (MutArray Word8) -> Stream m (MutArray Word8) + [R] compactEQ :: Int -> Stream m (MutArray a) -> Stream m (MutArray a) + [A] clone' :: MonadIO m => MutArray a -> m (MutArray a) + [A] chunksOf' :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (MutArray a) + [A] chunksEndByLn' :: MonadIO m => Stream m Word8 -> Stream m (MutArray Word8) + [A] chunksEndByLn :: MonadIO m => Stream m Word8 -> Stream m (MutArray Word8) + [A] chunksEndBy' :: forall m a. (MonadIO m, Unbox a) => (a -> Bool) -> Stream m a -> Stream m (MutArray a) + [A] chunksEndBy :: forall m a. (MonadIO m, Unbox a) => (a -> Bool) -> Stream m a -> Stream m (MutArray a) + [D] castUnsafe :: MutArray a -> MutArray b + [A] capacity :: forall a. Unbox a => MutArray a -> Int + [D] breakOn :: MonadIO m => Word8 -> MutArray Word8 -> m (MutArray Word8, Maybe (MutArray Word8)) + [A] breakEndBy_ :: (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) + [A] breakEndByWord8_ :: MonadIO m => Word8 -> MutArray Word8 -> m (MutArray Word8, Maybe (MutArray Word8)) + [A] breakEndBy :: (MonadIO m, Unbox a) => (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) + [A] breakAt :: forall a. Unbox a => Int -> MutArray a -> (MutArray a, MutArray a) + [A] asCWString :: MutArray a -> (CWString -> IO b) -> IO b + [A] asCString :: MutArray a -> (CString -> IO b) -> IO b + [A] appendStreamN :: (MonadIO m, Unbox a) => Int -> MutArray a -> Stream m a -> m (MutArray a) + [A] appendStream :: (MonadIO m, Unbox a) => MutArray a -> Stream m a -> m (MutArray a) + [A] appendPtrN :: MonadIO m => MutArray Word8 -> Ptr Word8 -> Int -> m (MutArray Word8) + [D] appendN :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -> Fold m a (MutArray a) + [A] appendMax :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> Fold m a (MutArray a) + [A] appendGrowBy :: (MonadIO m, Unbox a) => Int -> MutArray a -> Fold m a (MutArray a) + [A] appendCString# :: MonadIO m => MutArray Word8 -> Addr# -> m (MutArray Word8) + [A] appendCString :: MonadIO m => MutArray Word8 -> Ptr a -> m (MutArray Word8) + [A] append2 :: (MonadIO m, Unbox a) => MutArray a -> Fold m a (MutArray a) + [D] append :: forall m a. (MonadIO m, Unbox a) => m (MutArray a) -> Fold m a (MutArray a) +[A] Streamly.Internal.Data.IORef + [A] IORef + [A] writeIORef :: Unbox a => IORef a -> a -> IO () + [A] readIORef :: Unbox a => IORef a -> IO a + [A] pollIORefInt :: MonadIO m => IORef Int -> Stream m Int + [A] pollGenericIORef :: (MonadIO m, Unbox a) => IORef a -> Stream m a + [A] newIORef :: forall a. Unbox a => a -> IO (IORef a) + [A] modifyIORef' :: Unbox a => IORef a -> (a -> a) -> IO () +[C] Streamly.Internal.Data.Fold + [C] windowRange + [O] windowRange :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe (a, a)) + [N] windowRange :: forall m a. (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (Maybe (a, a)) + [C] windowMinimum + [O] windowMinimum :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe a) + [N] windowMinimum :: (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (Maybe a) + [C] windowMaximum + [O] windowMaximum :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe a) + [N] windowMaximum :: (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (Maybe a) + [R] transform :: Monad m => Pipe m a b -> Fold m b c -> Fold m a c + [C] toContainerIO + [O] toContainerIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (f b) + [N] toContainerIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> Fold m a b -> Fold m a (f b) + [C] toContainer + [O] toContainer :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (f b) + [N] toContainer :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> Fold m a b -> Fold m a (f b) + [C] takeEndBySeq_ + [O] takeEndBySeq_ :: forall m a b. (MonadIO m, Storable a, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Fold m a b + [N] takeEndBySeq_ :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Fold m a b + [C] takeEndBySeq + [O] takeEndBySeq :: forall m a b. (MonadIO m, Storable a, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Fold m a b + [N] takeEndBySeq :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => Array a -> Fold m a b -> Fold m a b + [A] scanlMany :: Monad m => Scanl m a b -> Fold m b c -> Fold m a c + [A] scanl :: Monad m => Scanl m a b -> Fold m b c -> Fold m a c + [D] scanMaybe :: Monad m => Fold m a (Maybe b) -> Fold m b c -> Fold m a c + [D] scanMany :: Monad m => Fold m a b -> Fold m b c -> Fold m a c + [D] scan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c + [A] rollingMap :: Monad m => (Maybe a -> a -> b) -> Fold m a b + [A] rangeBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe (a, a)) + [A] range :: (Monad m, Ord a) => Fold m a (Maybe (a, a)) + [A] postscanlMaybe :: Monad m => Scanl m a (Maybe b) -> Fold m b c -> Fold m a c + [A] postscanl :: Monad m => Scanl m a b -> Fold m b c -> Fold m a c + [D] postscan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c + [A] pipe :: Monad m => Pipe m a b -> Fold m b c -> Fold m a c + [A] onException :: MonadCatch m => m x -> Fold m a b -> Fold m a b + [R] lengthGeneric :: (Monad m, Num b) => Fold m a b + [D] indexingWith :: Monad m => Int -> (Int -> Int) -> Fold m a (Maybe (Int, a)) + [D] indexingRev :: Monad m => Int -> Fold m a (Maybe (Int, a)) + [D] indexing :: Monad m => Fold m a (Maybe (Int, a)) + [R] indexGeneric :: (Integral i, Monad m) => i -> Fold m a (Maybe a) + [A] ifThen :: Monad m => m Bool -> Fold m a b -> Fold m a b -> Fold m a b + [A] genericLength :: (Monad m, Num b) => Fold m a b + [A] genericIndex :: (Integral i, Monad m) => i -> Fold m a (Maybe a) + [A] fromScanl :: Scanl m a b -> Fold m a b + [D] foldlM1' :: Monad m => (a -> a -> m a) -> Fold m a (Maybe a) + [A] foldl1M' :: Monad m => (a -> a -> m a) -> Fold m a (Maybe a) + [A] finallyIO :: (MonadIO m, MonadCatch m) => IO b -> Fold m a b -> Fold m a b + [A] finalM :: Monad m => Fold m a b -> m b + [D] extractM :: Monad m => Fold m a b -> m b + [A] distributeScan :: Monad m => m [Fold m a b] -> Scanl m a [b] + [A] demuxerToMapIO :: (MonadIO m, Ord k) => (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Fold m a (Map k b) + [A] demuxerToMap :: (Monad m, Ord k) => (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Fold m a (Map k b) + [A] demuxerToContainerIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> (Key f -> m (Maybe (Fold m a b))) -> Fold m a (f b) + [A] demuxerToContainer :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> (Key f -> m (Maybe (Fold m a b))) -> Fold m a (f b) + [D] demuxToMapIO :: (MonadIO m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) + [D] demuxToMap :: (Monad m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) + [D] demuxToContainerIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (f b) + [D] demuxToContainer :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (f b) + [A] demuxScanIO :: (MonadIO m, Ord k) => (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Scanl m a (Maybe (k, b)) + [A] demuxScanGenericIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> (Key f -> m (Maybe (Fold m a b))) -> Scanl m a (m (f b), Maybe (Key f, b)) + [A] demuxScanGeneric :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> (Key f -> m (Maybe (Fold m a b))) -> Scanl m a (m (f b), Maybe (Key f, b)) + [A] demuxScan :: (Monad m, Ord k) => (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Scanl m a (Maybe (k, b)) + [C] demuxKvToMap + [O] demuxKvToMap :: (Monad m, Ord k) => (k -> m (Fold m a b)) -> Fold m (k, a) (Map k b) + [N] demuxKvToMap :: (Monad m, Ord k) => (k -> m (Maybe (Fold m a b))) -> Fold m (k, a) (Map k b) + [C] demuxKvToContainer + [O] demuxKvToContainer :: (Monad m, IsMap f, Traversable f) => (Key f -> m (Fold m a b)) -> Fold m (Key f, a) (f b) + [N] demuxKvToContainer :: (Monad m, IsMap f, Traversable f) => (Key f -> m (Maybe (Fold m a b))) -> Fold m (Key f, a) (f b) + [D] demuxIO :: (MonadIO m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (m (Map k b), Maybe (k, b)) + [D] demuxGenericIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (m (f b), Maybe (Key f, b)) + [D] demuxGeneric :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (m (f b), Maybe (Key f, b)) + [D] demux :: (Monad m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (m (Map k b), Maybe (k, b)) + [A] classifyScanIO :: (MonadIO m, Ord k) => (a -> k) -> Fold m a b -> Scanl m a (Maybe (k, b)) + [A] classifyScanGenericIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Scanl m a (m (f b), Maybe (Key f, b)) + [A] classifyScanGeneric :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Scanl m a (m (f b), Maybe (Key f, b)) + [A] classifyScan :: (MonadIO m, Ord k) => (a -> k) -> Fold m a b -> Scanl m a (Maybe (k, b)) + [D] classifyIO :: (MonadIO m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (m (Map k b), Maybe (k, b)) + [D] classifyGenericIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (m (f b), Maybe (Key f, b)) + [D] classifyGeneric :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (m (f b), Maybe (Key f, b)) + [D] classify :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (m (Map k b), Maybe (k, b)) + [A] bracketIO :: (MonadIO m, MonadCatch m) => IO x -> (x -> IO c) -> (x -> Fold m a b) -> Fold m a b + [A] before :: Monad m => m x -> Fold m a b -> Fold m a b +[A] Streamly.Internal.Data.CString + [A] splicePtrN :: MutByteArray -> Ptr Word8 -> Int -> IO Int + [A] spliceCString :: MutByteArray -> CString -> IO Int + [A] splice :: MutByteArray -> MutByteArray -> IO Int + [A] putCString :: MutByteArray -> Int -> CString -> IO Int + [A] length :: MutByteArray -> IO Int +[C] Streamly.Internal.Data.Array.Generic + [C] Array + [R] [arrLen] :: Array a -> {-# UNPACK #-} !Int + [A] [arrEnd] :: Array a -> {-# UNPACK #-} !Int + [R] GHC.Show.Show + [R] GHC.Read.Read + [R] GHC.Classes.Ord + [R] GHC.Classes.Eq + [R] writeWith :: MonadIO m => Int -> Fold m a (Array a) + [D] writeN :: MonadIO m => Int -> Fold m a (Array a) + [R] writeLastN :: MonadIO m => Int -> Fold m a (Array a) + [D] write :: MonadIO m => Fold m a (Array a) + [A] unsafeThaw :: Array a -> MutArray a + [A] unsafeSliceOffLen :: Int -> Int -> Array a -> Array a + [A] unsafeGetIndex :: Int -> Array a -> a + [A] unsafeFreeze :: MutArray a -> Array a + [A] toParserK :: Monad m => Parser a m b -> ParserK (Array a) m b + [D] strip :: (a -> Bool) -> Array a -> Array a + [A] parsePos :: Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseErrorPos b) + [A] parseBreakPos :: forall m a b. Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseErrorPos b, StreamK m (Array a)) + [A] parseBreak :: forall m a b. Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] parse :: Monad m => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [D] getSliceUnsafe :: Int -> Int -> Array a -> Array a + [D] getIndexUnsafe :: Int -> Array a -> a + [A] fromCString# :: MonadIO m => Addr# -> m (Array Word8) + [D] fromByteStr# :: Addr# -> Array Word8 + [A] dropAround :: (a -> Bool) -> Array a -> Array a + [A] createWith :: MonadIO m => Int -> Fold m a (Array a) + [A] createOfLast :: MonadIO m => Int -> Fold m a (Array a) +[C] Streamly.Internal.Data.Array + [D] writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [D] writeLastN :: (Unbox a, MonadIO m) => Int -> Fold m a (Array a) + [D] write :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [A] unsnoc :: Unbox a => Array a -> Maybe (Array a, a) + [A] unsafeSliceOffLen :: forall a. Unbox a => Int -> Int -> Array a -> Array a + [A] unsafeReader :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a + [D] unsafePinnedCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [C] unsafePinnedAsPtr + [O] unsafePinnedAsPtr :: MonadIO m => Array a -> (Ptr a -> m b) -> m b + [N] unsafePinnedAsPtr :: MonadIO m => Array a -> (Ptr a -> Int -> IO b) -> m b + [D] unsafeIndexIO :: forall a. Unbox a => Int -> Array a -> IO a + [A] unsafeGetIndexRevIO :: forall a. Unbox a => Int -> Array a -> IO a + [A] unsafeGetIndexRev :: forall a. Unbox a => Int -> Array a -> a + [A] unsafeGetIndexIO :: forall a. Unbox a => Int -> Array a -> IO a + [A] unsafeGetIndex :: forall a. Unbox a => Int -> Array a -> a + [A] unsafeFromForeignPtr :: MonadIO m => ForeignPtr Word8 -> Int -> m (Array Word8) + [A] unsafeCreateOf' :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] unsafeCast :: Array a -> Array b + [A] unsafeBreakAt :: Unbox a => Int -> Array a -> (Array a, Array a) + [A] unsafeAsForeignPtr :: MonadIO m => Array a -> (ForeignPtr a -> Int -> IO b) -> m b + [A] uncons :: Unbox a => Array a -> Maybe (a, Array a) + [A] toParserK :: (Monad m, Unbox a) => Parser a m b -> ParserK (Array a) m b + [A] tail :: Unbox a => Array a -> Array a + [A] splitterFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (Array a) (Array a) + [D] splitOn :: (Monad m, Unbox a) => (a -> Bool) -> Array a -> Stream m (Array a) + [A] splitEndBy_ :: (Monad m, Unbox a) => (a -> Bool) -> Array a -> Stream m (Array a) + [A] splitEndBy :: (MonadIO m, Unbox a) => (a -> Bool) -> Array a -> Stream m (Array a) + [D] splitAt :: Unbox a => Int -> Array a -> (Array a, Array a) + [D] slicerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (Array a) (Array a) + [D] sliceIndexerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (Array a) (Int, Int) + [A] serialize' :: Serialize a => a -> Array Word8 + [A] scanCompactMin' :: forall m a. (MonadIO m, Unbox a) => Int -> Scanl m (Array a) (Maybe (Array a)) + [A] scanCompactMin :: forall m a. (MonadIO m, Unbox a) => Int -> Scanl m (Array a) (Maybe (Array a)) + [A] revDropWhile :: Unbox a => (a -> Bool) -> Array a -> Array a + [A] revBreakEndBy_ :: Unbox a => (a -> Bool) -> Array a -> (Array a, Array a) + [A] revBreakEndBy :: Unbox a => (a -> Bool) -> Array a -> (Array a, Array a) + [D] readerUnsafe :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a + [D] pinnedSerialize :: Serialize a => a -> Array Word8 + [D] pinnedFromListN :: Unbox a => Int -> [a] -> Array a + [D] pinnedFromList :: Unbox a => [a] -> Array a + [D] pinnedCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [D] pinnedCreate :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [D] pinnedCompactLE :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [R] pinnedClone :: MonadIO m => Array a -> m (Array a) + [D] pinnedChunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (Array a) + [A] parsePos :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseErrorPos b) + [A] parseBreakPos :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseErrorPos b, StreamK m (Array a)) + [R] parseBreakChunksK :: forall m a b. (MonadIO m, Unbox a) => Parser a m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] parseBreak :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] parse :: (Monad m, Unbox a) => ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) + [A] listEq :: (Unbox a, Ord a) => [a] -> Array a -> Bool + [A] listCmp :: (Unbox a, Ord a) => [a] -> Array a -> Ordering + [D] lPinnedCompactGE :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) () -> Fold m (Array a) () + [D] lCompactGE :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) () -> Fold m (Array a) () + [D] interposeSuffix :: forall m a. (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [D] interpose :: (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [D] intercalateSuffix :: (Monad m, Unbox a) => Array a -> Stream m (Array a) -> Stream m a + [A] init :: Unbox a => Array a -> Array a + [A] indexerFromLen :: forall m a. (Monad m, Unbox a) => Int -> Int -> Unfold m (Array a) (Int, Int) + [A] head :: Unbox a => Array a -> Maybe a + [D] getSliceUnsafe :: forall a. Unbox a => Int -> Int -> Array a -> Array a + [D] getIndexUnsafe :: forall a. Unbox a => Int -> Array a -> a + [A] fromW16CString# :: MonadIO m => Addr# -> m (Array Word16) + [A] fromW16CString :: MonadIO m => Ptr Word8 -> m (Array Word16) + [C] fromPtrN + [O] fromPtrN :: Int -> Ptr Word8 -> Array Word8 + [N] fromPtrN :: MonadIO m => Int -> Ptr Word8 -> m (Array Word8) + [A] fromListN' :: Unbox a => Int -> [a] -> Array a + [A] fromList' :: Unbox a => [a] -> Array a + [A] fromCString# :: MonadIO m => Addr# -> m (Array Word8) + [A] fromCString :: MonadIO m => Ptr Word8 -> m (Array Word8) + [D] fromByteStr# :: Addr# -> Array Word8 + [D] fromByteStr :: Ptr Word8 -> Array Word8 + [A] foldRev :: Unbox a => Fold Identity a b -> Array a -> b + [A] foldM :: (Monad m, Unbox a) => Fold m a b -> Array a -> m b + [D] foldBreakChunksK :: forall m a b. (MonadIO m, Unbox a) => Fold m a b -> StreamK m (Array a) -> m (b, StreamK m (Array a)) + [A] foldBreak :: forall m a b. (MonadIO m, Unbox a) => Fold m a b -> StreamK m (Array a) -> m (b, StreamK m (Array a)) + [D] fold :: (Monad m, Unbox a) => Fold m a b -> Array a -> m b + [D] fPinnedCompactGE :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) (Array a) + [D] fCompactGE :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) (Array a) + [A] dropWhile :: Unbox a => (a -> Bool) -> Array a -> Array a + [A] dropAround :: Unbox a => (a -> Bool) -> Array a -> Array a + [C] deserialize + [O] deserialize :: Serialize a => Array Word8 -> a + [N] deserialize :: Serialize a => Array Word8 -> (a, Array Word8) + [A] createOfLast :: (Unbox a, MonadIO m) => Int -> Fold m a (Array a) + [A] createOf' :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] createCompactMin' :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) (Array a) + [A] createCompactMin :: (MonadIO m, Unbox a) => Int -> Fold m (Array a) (Array a) + [A] create' :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [A] concatSepBy :: (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [A] concatEndBySeq :: (Monad m, Unbox a) => Array a -> Stream m (Array a) -> Stream m a + [A] concatEndBy :: forall m a. (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a + [A] compactSepByByte_ :: MonadIO m => Word8 -> Stream m (Array Word8) -> Stream m (Array Word8) + [D] compactOnByteSuffix :: MonadIO m => Word8 -> Stream m (Array Word8) -> Stream m (Array Word8) + [D] compactOnByte :: MonadIO m => Word8 -> Stream m (Array Word8) -> Stream m (Array Word8) + [A] compactMin :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [A] compactMax' :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [A] compactMax :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [D] compactLE :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [D] compactGE :: (MonadIO m, Unbox a) => Int -> Stream m (Array a) -> Stream m (Array a) + [A] compactEndByLn_ :: MonadIO m => Stream m (Array Word8) -> Stream m (Array Word8) + [A] compactEndByByte_ :: MonadIO m => Word8 -> Stream m (Array Word8) -> Stream m (Array Word8) + [R] clone :: MonadIO m => Array a -> m (Array a) + [A] chunksOf' :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (Array a) + [A] chunksEndByLn' :: MonadIO m => Stream m Word8 -> Stream m (Array Word8) + [A] chunksEndByLn :: MonadIO m => Stream m Word8 -> Stream m (Array Word8) + [A] chunksEndBy' :: forall m a. (MonadIO m, Unbox a) => (a -> Bool) -> Stream m a -> Stream m (Array a) + [A] chunksEndBy :: forall m a. (MonadIO m, Unbox a) => (a -> Bool) -> Stream m a -> Stream m (Array a) + [D] castUnsafe :: Array a -> Array b + [D] breakOn :: MonadIO m => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8)) + [A] breakEndBy_ :: Unbox a => (a -> Bool) -> Array a -> (Array a, Array a) + [A] breakEndByWord8_ :: MonadIO m => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8)) + [A] breakEndBy :: Unbox a => (a -> Bool) -> Array a -> (Array a, Array a) + [A] breakAt :: Unbox a => Int -> Array a -> (Array a, Array a) + [A] asCWString :: Array a -> (CWString -> IO b) -> IO b +[C] Streamly.Internal.Control.Exception + [A] Priority + [A] Priority2 :: Priority + [A] Priority1 :: Priority + [A] GHC.Show.Show + [A] instance GHC.Show.Show Streamly.Internal.Control.Exception.Priority + [A] AcquireIO + [A] AcquireIO :: (forall b c. Priority -> IO b -> (b -> IO c) -> IO (b, IO ())) -> AcquireIO + [A] withAcquireIO :: (MonadIO m, MonadMask m) => (AcquireIO -> m a) -> m a + [A] releaser :: MonadIO m => IORef (a, IntMap (IO b), IntMap (IO b)) -> m () + [A] registerWith :: Priority -> AcquireIO -> IO () -> IO () + [A] register :: AcquireIO -> IO () -> IO () + [A] hook :: AcquireIO -> IO () -> IO (IO ()) + [A] allocator :: MonadIO m => IORef (Int, IntMap (IO ()), IntMap (IO ())) -> Priority -> IO a -> (a -> IO b) -> m (a, m ()) + [A] acquire_ :: AcquireIO -> IO b -> (b -> IO c) -> IO b + [A] acquireWith :: Priority -> AcquireIO -> IO b -> (b -> IO c) -> IO (b, IO ()) + [A] acquire :: AcquireIO -> IO b -> (b -> IO c) -> IO (b, IO ()) diff --git a/docs/Changelog.md b/docs/Changelog.md --- a/docs/Changelog.md +++ b/docs/Changelog.md @@ -1,8 +1,140 @@ # Changelog +## 0.3.1 (May 2026) + +* Fixed `Path.fromString` truncation when unicode chars are present. +* Fixed `DirIO.followSymlinks` option not working correctly on macOS. + +## 0.3.0 (Sep 2025) + +See [0.2.2-0.3.0 API Changelog](/core/docs/ApiChangelogs/0.2.2-0.3.0.txt) for a +full list of deprecations, additions, and changes to the function signatures. + +### Enhancements + +* Added APIs for prompt cleanup of resources, allowing guaranteed + cleanup as an alternative to GC-based cleanup. +* Added operations for fair nesting of inner and outer streams for + exploring them equally, generally useful but especially useful for logic + programming use cases. +* Introduced `Streamly.Data.Scanl` with a new `Scanl` type. Scans can + split a stream into multiple streams, process them independently, and + merge the results. The `Fold` type is now split into `Fold` and `Scanl`. +* Added `RingArray` module for high-performance, unboxed circular buffers. +* Added `Streamly.FileSystem.Path` module with a `Path` type for flexibly typed + file system paths. +* Added `Streamly.FileSystem.DirIO` and `Streamly.FileSystem.FileIO` to replace + the deprecated `Streamly.FileSystem.Dir` and `Streamly.FileSystem.File`. The + new modules use Streamly’s native `Path` type instead of `FilePath`. `DirIO` + APIs take a `ReadOptions` argument, and its directory read APIs do not follow + symlinks by default. +* Removed `Storable` constraint from: + - `Streamly.Data.Stream.isInfixOf` + - `Streamly.Data.Array.writeLastN` + +### Deprecations + +Following APIs/modules are deprecated and renamed or replaced with new +APIs. + +* `Streamly.FileSystem.Dir`, `Streamly.FileSystem.File` have been replaced by + new modules. +* Renamed `writeN`-like APIs to `createOf`-like in Array modules. +* Renamed `new`-like APIs to `emptyOf`-like in Array modules. +* In the Fold module renamed `indexGeneric`, `lengthGeneric`, and `foldlM1'` to + `genericIndex`, `genericLength`, and `foldl1M'` respectively. + +### Internal API Changes + +* In `Streamly.Internal.Data.Parser`, constructors `Partial`, `Continue`, and + `Done` are deprecated and replaced with `SPartial`, `SContinue`, and `SDone`. + Migration steps: + * In parser step functions: + - `Partial n` -> `SPartial (1-n)` + - `Continue n` -> `SContinue (1-n)` + - `Done n` -> `SDone (1-n)` + - `Error` -> `SError` + * Extract function now returns `Parser.Final` (instead of `Parser.Step`): + - `Continue n` -> `FContinue (-n)` + - `Done n` -> `FDone (-n)` + - `Partial n` -> `FContinue (-n)` + - `Error` -> `FError` + * If `n` is used for decision-making, the logic must be updated accordingly. + See docs for details. +* Internal (mut)array functions now use explicit IO callbacks instead of lifted + callbacks. +* Removed `Storable` constraint from several ring buffer functions. +* Added `Streamly.Internal.Data.IORef` module exposing `IORef` and related + functions. + +## 0.2.2 (Jan 2024) + +* Add fixities `infixr 5` for `cons` and `consM` functions. +* Fix a bug in Array `Eq` instance when the type is a sum type with + differently sized constructors. +* lpackArraysChunksOf, compact, writeChunksWith, putChunksWith now take the + buffer size in number of array elements instead of bytes. + +## 0.2.1 (Dec 2023) + +* Make the serialization of the unit constructor deterministic. +* Expose `pinnedSerialize` & `deserialize` via `Streamly.Data.Array`. + +## 0.2.0 (Nov 2023) + +See [0.1.0-0.2.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/core/docs/ApiChangelogs/0.1.0-0.2.0.txt) +for a full list of API changes in this release. Only a few significant +changes are mentioned here. + +### Breaking Changes + +* `ParserK` in `Streamly.Data.ParserK` is not implicitly specialized + to arrays anymore. To adapt to the new code, change `ParserK a m + b` to `ParserK (Array a) m b` where the `Array` type comes from + `Streamly.Data.Array`. This change also affected the signatures of + `parseChunks` and `parseBreakChunks`. +* Changed the signature of 'Streamly.Data.Stream.handle' to make the + exception handler monadic. +* Behavior change: Exceptions are now rethrown promptly in `bracketIO`. + +### Enhancements + +* __Serialization__: Added a `Streamly.Data.MutByteArray` module with a + `Serialize` type class for fast binary serialization. The Data.Array + module supplies the `serialize` and `deserialize` operations for arrays. +* __Unpinned Arrays__: Unboxed arrays are now created unpinned by default, + they were created pinned earlier. During IO operations, unpinned arrays + are automatically copied to pinned memory. When arrays are directly + passed to IO operations programmers can choose to create them pinned to + avoid a copy. To create pinned arrays, use the internal APIs with the + `pinned*` prefix. +* StreamK now supports native exception handling routines (handle, bracketIO). + Earlier we had to convert it to the `Stream` type for exception handling. + +### Deprecations + +See [0.1.0-0.2.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/core/docs/ApiChangelogs/0.1.0-0.2.0.txt) +for a full list of deprecations. + +### Internal API Changes + +* Fold constructor has changed, added a `final` field to support + finalization and cleanup of a chain of folds. The `extract` field is + now used only for mapping the fold internal state to fold result for + scanning purposes. If your fold does not require cleanup you can just use + your existing `extract` function as `final` as well to adapt to this change. +* Many low level internal modules have been removed, they are entirely + exported from higher level internal modules. If you were importing any + of the missing low level modules then import the higher level modules instead. +* Internal module changes: + * Streamly.Internal.Serialize.FromBytes -> Streamly.Internal.Data.Binary.Parser + * Streamly.Internal.Serialize.ToBytes -> Streamly.Internal.Data.Binary.Stream + * Streamly.Internal.Data.Unbox is now exported via Streamly.Internal.Data.Serialize + * Streamly.Internal.Data.IORef.Unboxed is now exported via Streamly.Internal.Data.Serialize + ## 0.1.0 (March 2023) -Also see [streamly-core-0.1.0 API Changelog](/core/docs/ApiChangelogs/0.1.0.txt) or +Also see [streamly-core-0.1.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/core/docs/ApiChangelogs/0.1.0.txt) or https://hackage.haskell.org/package/streamly-core-0.1.0/docs/docs/ApiChangelogs/0.1.0.txt `streamly` package is split into two packages, (1) `streamly-core` that diff --git a/docs/Readme.md b/docs/Readme.md --- a/docs/Readme.md +++ b/docs/Readme.md @@ -1,1 +1,2 @@ -Please refer to the "streamly" package for tutorials and other documentation. +Please refer to the [streamly](/docs/User/Tutorials/using-streamly.md) +package for tutorials and other documentation. diff --git a/src/DocTestDataArray.hs b/src/DocTestDataArray.hs deleted file mode 100644 --- a/src/DocTestDataArray.hs +++ /dev/null @@ -1,14 +0,0 @@ -{- $setup ->>> :m ->>> :set -XFlexibleContexts ->>> import Data.Function ((&)) ->>> import Data.Functor.Identity (Identity(..)) ->>> import System.IO.Unsafe (unsafePerformIO) - ->>> import Streamly.Data.Array (Array) ->>> import Streamly.Data.Stream (Stream) - ->>> import qualified Streamly.Data.Array as Array ->>> import qualified Streamly.Data.Fold as Fold ->>> import qualified Streamly.Data.Stream as Stream --} diff --git a/src/DocTestDataFold.hs b/src/DocTestDataFold.hs deleted file mode 100644 --- a/src/DocTestDataFold.hs +++ /dev/null @@ -1,28 +0,0 @@ -{- $setup ->>> :m ->>> :set -XFlexibleContexts ->>> import Control.Monad (void) ->>> import qualified Data.Foldable as Foldable ->>> import Data.Function ((&)) ->>> import Data.Functor.Identity (Identity, runIdentity) ->>> import Data.IORef (newIORef, readIORef, writeIORef) ->>> import Data.Maybe (fromJust, isJust) ->>> import Data.Monoid (Endo(..), Last(..), Sum(..)) - ->>> import Streamly.Data.Array (Array) ->>> import Streamly.Data.Fold (Fold, Tee(..)) ->>> import Streamly.Data.Stream (Stream) - ->>> import qualified Streamly.Data.Array as Array ->>> import qualified Streamly.Data.Fold as Fold ->>> import qualified Streamly.Data.MutArray as MutArray ->>> import qualified Streamly.Data.Parser as Parser ->>> import qualified Streamly.Data.Stream as Stream ->>> import qualified Streamly.Data.StreamK as StreamK ->>> import qualified Streamly.Data.Unfold as Unfold - -For APIs that have not been released yet. - ->>> import qualified Streamly.Internal.Data.Fold as Fold ->>> import qualified Streamly.Internal.Data.Fold.Window as FoldW --} diff --git a/src/DocTestDataMutArray.hs b/src/DocTestDataMutArray.hs deleted file mode 100644 --- a/src/DocTestDataMutArray.hs +++ /dev/null @@ -1,10 +0,0 @@ -{- $setup ->>> :m ->>> import qualified Streamly.Data.Fold as Fold ->>> import qualified Streamly.Data.MutArray as MutArray ->>> import qualified Streamly.Data.Stream as Stream - -For APIs that have not been released yet. - ->>> import Streamly.Internal.Data.Array.Mut as MutArray --} diff --git a/src/DocTestDataMutArrayGeneric.hs b/src/DocTestDataMutArrayGeneric.hs deleted file mode 100644 --- a/src/DocTestDataMutArrayGeneric.hs +++ /dev/null @@ -1,10 +0,0 @@ -{- $setup ->>> :m ->>> import qualified Streamly.Data.Fold as Fold ->>> import qualified Streamly.Data.MutArray.Generic as MutArray ->>> import qualified Streamly.Data.Stream as Stream - -For APIs that have not been released yet. - ->>> import Streamly.Internal.Data.Array.Generic.Mut.Type as MutArray --} diff --git a/src/DocTestDataParser.hs b/src/DocTestDataParser.hs deleted file mode 100644 --- a/src/DocTestDataParser.hs +++ /dev/null @@ -1,20 +0,0 @@ -{- $setup ->>> :m ->>> import Control.Applicative ((<|>)) ->>> import Data.Bifunctor (second) ->>> import Data.Char (isSpace) ->>> import qualified Data.Foldable as Foldable ->>> import qualified Data.Maybe as Maybe - ->>> import Streamly.Data.Fold (Fold) ->>> import Streamly.Data.Parser (Parser) - ->>> import qualified Streamly.Data.Fold as Fold ->>> import qualified Streamly.Data.Parser as Parser ->>> import qualified Streamly.Data.Stream as Stream - -For APIs that have not been released yet. - ->>> import qualified Streamly.Internal.Data.Fold as Fold ->>> import qualified Streamly.Internal.Data.Parser as Parser --} diff --git a/src/DocTestDataStream.hs b/src/DocTestDataStream.hs deleted file mode 100644 --- a/src/DocTestDataStream.hs +++ /dev/null @@ -1,37 +0,0 @@ -{- $setup - ->>> :m ->>> import Control.Concurrent (threadDelay) ->>> import Control.Monad (void) ->>> import Control.Monad.IO.Class (MonadIO (liftIO)) ->>> import Control.Monad.Trans.Class (lift) ->>> import Control.Monad.Trans.Identity (runIdentityT) ->>> import Data.Either (fromLeft, fromRight, isLeft, isRight, either) ->>> import Data.Maybe (fromJust, isJust) ->>> import Data.Function (fix, (&)) ->>> import Data.Functor.Identity (runIdentity) ->>> import Data.IORef ->>> import Data.Semigroup (cycle1) ->>> import GHC.Exts (Ptr (Ptr)) ->>> import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) - ->>> hSetBuffering stdout LineBuffering ->>> effect n = print n >> return n - ->>> import Streamly.Data.Stream (Stream) ->>> import qualified Streamly.Data.Array as Array ->>> import qualified Streamly.Data.Fold as Fold ->>> import qualified Streamly.Data.Stream as Stream ->>> import qualified Streamly.Data.Unfold as Unfold ->>> import qualified Streamly.Data.Parser as Parser ->>> import qualified Streamly.FileSystem.Dir as Dir - -For APIs that have not been released yet. - ->>> import qualified Streamly.Internal.Data.Fold as Fold ->>> import qualified Streamly.Internal.Data.Fold.Window as Window ->>> import qualified Streamly.Internal.Data.Parser as Parser ->>> import qualified Streamly.Internal.Data.Stream as Stream ->>> import qualified Streamly.Internal.Data.Unfold as Unfold ->>> import qualified Streamly.Internal.FileSystem.Dir as Dir --} diff --git a/src/DocTestDataStreamK.hs b/src/DocTestDataStreamK.hs deleted file mode 100644 --- a/src/DocTestDataStreamK.hs +++ /dev/null @@ -1,20 +0,0 @@ -{- $setup - ->>> :m ->>> import Data.Function (fix, (&)) ->>> import Data.Semigroup (cycle1) - ->>> effect n = print n >> return n - ->>> import Streamly.Data.StreamK (StreamK) ->>> import qualified Streamly.Data.Fold as Fold ->>> import qualified Streamly.Data.Parser as Parser ->>> import qualified Streamly.Data.Stream as Stream ->>> import qualified Streamly.Data.StreamK as StreamK ->>> import qualified Streamly.FileSystem.Dir as Dir - -For APIs that have not been released yet. - ->>> import qualified Streamly.Internal.Data.Stream.StreamK as StreamK ->>> import qualified Streamly.Internal.FileSystem.Dir as Dir --} diff --git a/src/DocTestDataUnfold.hs b/src/DocTestDataUnfold.hs deleted file mode 100644 --- a/src/DocTestDataUnfold.hs +++ /dev/null @@ -1,12 +0,0 @@ -{- $setup - ->>> :m ->>> import Streamly.Data.Unfold (Unfold) ->>> import qualified Streamly.Data.Fold as Fold ->>> import qualified Streamly.Data.Stream as Stream ->>> import qualified Streamly.Data.Unfold as Unfold - -For APIs that have not been released yet. - ->>> import qualified Streamly.Internal.Data.Unfold as Unfold --} diff --git a/src/Streamly/Console/Stdio.hs b/src/Streamly/Console/Stdio.hs --- a/src/Streamly/Console/Stdio.hs +++ b/src/Streamly/Console/Stdio.hs @@ -7,14 +7,37 @@ -- Stability : released -- Portability : GHC -- --- Combinators to work with standard input, output and error streams. +-- Combinators to work with standard input, output, and error streams. This +-- module supports reading and writing binary data or UTF-8 encoded text only. +-- However, it is possible to use specific encoders and decoders to implement +-- other encodings. -- +-- These streaming APIs use the stdin and stdout handles for reading from and +-- writing to the console. The reads and writes are buffered, meaning each +-- stream has its own buffer. Be cautious when switching between these APIs and +-- handle-based APIs (e.g., readChars, getLine), between different stream APIs +-- (e.g., readChars, readChunks), or even between different calls to the same +-- API (e.g., readChars, readChars). If you switch from one stream to another, +-- you should drain the first stream completely if you care about preserving +-- any buffered data. +-- -- See also: "Streamly.Internal.Console.Stdio" +-- XXX put examples of repeatM getLine from stream module +-- XXX put examples of using parseBreak or foldBreak. + module Streamly.Console.Stdio ( + -- * Streams (stdin) + read + , readChars + , readChunks + + -- * Streams (srdout) + , putChunks + -- * Unfolds (stdin) - reader + , reader , chunkReader -- * Write (stdout) @@ -24,33 +47,8 @@ -- * Write (stderr) , writeErr , writeErrChunks - - -- * Deprecated - , read - , readChunks ) where -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Word (Word8) -import Streamly.Internal.Data.Array.Type (Array) -import Streamly.Internal.Data.Unfold (Unfold) - -import Streamly.Internal.Console.Stdio hiding (read, readChunks) import Prelude hiding (read) - --- Same as 'reader' --- --- @since 0.8.0 -{-# DEPRECATED read "Please use 'reader' instead" #-} -{-# INLINE read #-} -read :: MonadIO m => Unfold m () Word8 -read = reader - --- Same as 'chunkReader' --- --- @since 0.8.0 -{-# DEPRECATED readChunks "Please use 'chunkReader' instead" #-} -{-# INLINE readChunks #-} -readChunks :: MonadIO m => Unfold m () (Array Word8) -readChunks = chunkReader +import Streamly.Internal.Console.Stdio diff --git a/src/Streamly/Control/Exception.hs b/src/Streamly/Control/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Control/Exception.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Control.Exception +-- Copyright : (c) 2025 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- Exception handling and resource managment operations complementing +-- the "Control.Exception" module in base package. + +module Streamly.Control.Exception + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + -- + -- * Resource Management + -- | Exception safe, thread safe resource managment operations, similar to + -- but more powerful than the @bracket@ and @finally@ operations available + -- in the base package. + -- + -- These operations support allocation and free only in the IO monad, + -- hence the IO suffix. + -- + AcquireIO + , withAcquireIO + , acquire + , register + , hook + ) +where + +import Streamly.Internal.Control.Exception + +#include "DocTestControlException.hs" diff --git a/src/Streamly/Data/Array.hs b/src/Streamly/Data/Array.hs --- a/src/Streamly/Data/Array.hs +++ b/src/Streamly/Data/Array.hs @@ -29,59 +29,88 @@ -- $overview -- * The Array Type - A.Array + Array + -- * Pinning & Unpinning + -- | Arrays are created unpinned by default unless pinned versions of + -- creation APIs are used. Look for APIs with @pinned@ prefix in + -- "Streamly.Internal.Data.Array" for some unreleased pinned creation APIs. + -- If an array is to be sent to the OS without any further modification + -- then it should be created pinned in the first place instead of pinning + -- it later. Pinning an unpinned array has a copy overhead. OS interfacing + -- APIs create a pinned array directly or convert an unpinned array to + -- pinned array before sending it to the OS. + , pin + , unpin + , isPinned + -- * Construction -- | When performance matters, the fastest way to generate an array is - -- 'writeN'. 'IsList' and 'IsString' instances can be + -- 'createOf'. 'IsList' and 'IsString' instances can be -- used to conveniently construct arrays from literal values. -- 'OverloadedLists' extension or 'fromList' can be used to construct an -- array from a list literal. Similarly, 'OverloadedStrings' extension or -- 'fromList' can be used to construct an array from a string literal. - -- Pure List APIs - , A.fromListN - , A.fromList + -- ** From Stream + , createOf + , create + , createOfLast -- drop old (ring buffer) - -- Monadic APIs - , A.writeN -- drop new - , A.write -- full buffer - , writeLastN -- drop old (ring buffer) + -- ** From List + , fromListN + , fromList - -- * Conversion + -- * To List -- 'GHC.Exts.toList' from "GHC.Exts" can be used to convert an array to a -- list. - , A.toList + , toList + -- * To Stream + , read + , readRev + -- * Unfolds - , A.reader - , A.readerRev + , reader + , readerRev + -- * Stream of Arrays + , chunksOf + , toParserK + , parse + , parseBreak + , parsePos + , parseBreakPos + -- * Casting , cast , asBytes -- * Random Access - , A.length + , length -- , (!!) - , A.getIndex + , getIndex - -- * Unbox Type Class + -- * Serialization + , serialize' + , deserialize + + -- * Re-exports , Unbox (..) + , Serialize(..) -- * Deprecated - , read - , readRev + , pinnedSerialize + , writeN -- drop new + , write -- full buffer + , writeLastN ) where -#include "inline.hs" - -import Streamly.Internal.Data.Unfold (Unfold) -import Streamly.Internal.Data.Array as A hiding (read, readRev) +import Streamly.Internal.Data.Array +import Streamly.Internal.Data.MutByteArray (Unbox(..), Serialize(..)) -import Streamly.Internal.Data.Unboxed (Unbox (..)) -import Prelude hiding (read) +import Prelude hiding (read, length) #include "DocTestDataArray.hs" @@ -97,7 +126,7 @@ -- -- Convert array to stream, and fold the stream: -- --- >>> fold f arr = Stream.unfold Array.reader arr & Stream.fold f +-- >>> fold f arr = Array.read arr & Stream.fold f -- >>> fold Fold.sum (Array.fromList [1,2,3::Int]) -- 6 -- @@ -105,18 +134,17 @@ -- -- Convert array to stream, transform, and fold back to array: -- --- >>> amap f arr = Stream.unfold Array.reader arr & fmap f & Stream.fold Array.write +-- >>> amap f arr = Array.read arr & fmap f & Stream.fold (Array.createOf (Array.length arr)) -- >>> amap (+1) (Array.fromList [1,2,3::Int]) -- fromList [2,3,4] -- -- == Pinned and Unpinned Arrays -- --- The array type can use both pinned and unpinned memory under the hood. --- Currently the array creation APIs create arrays in pinned memory but it will --- change to unpinned in future releases. The change should not affect users --- functionally unless they are directly accessing the internal memory of the --- array via internal APIs. As of now unpinned arrays can be created using --- unreleased APIs. +-- The array type can use both pinned and unpinned memory under the hood. The +-- default array creation operations create unpinned arrays. IO operations +-- automatically copy an array to pinned memory if the array passed to it is +-- unpinned. Programmers can use appropriate pinned array generation APIs to +-- reduce the copying if it happens. -- -- Unpinned arrays have the advantage of allowing automatic defragmentation of -- the memory by GC. Whereas pinned arrays have the advantage of not requiring @@ -127,42 +155,26 @@ -- -- == Creating Arrays from Non-IO Streams -- --- Array creation folds require 'MonadIO' because they need to sequence effects --- in IO streams. To operate on streams in pure Monads like 'Identity' you can --- morph it to IO monad as follows: +-- Array creation folds require 'MonadIO' otherwise the compiler may +-- incorrectly share the array memory thinking it is pure. -- --- The 'MonadIO' based folds can be morphed to 'Identity' stream folds: +-- See the 'fromPureStream' unreleased API to generate an array from an +-- Identity stream safely without using MonadIO constraint. -- --- >>> purely = Fold.morphInner (Identity . unsafePerformIO) --- >>> Stream.fold (purely Array.write) $ Stream.fromList [1,2,3::Int] --- Identity fromList [1,2,3] +-- >>> fromPureStream = Stream.fold Array.create . Stream.generalizeInner -- --- Since it is a pure stream we can use 'unsafePerformIO' to extract the result --- of fold from IO. +-- >>> stream = Stream.fromList [1,2,3] :: Stream Identity Int +-- >>> fromPureStream stream +-- fromList [1,2,3] -- --- Alternatively, 'Identity' streams can be generalized to IO streams: +-- == Performance Considerations -- --- >>> pure = Stream.fromList [1,2,3] :: Stream Identity Int --- >>> generally = Stream.morphInner (return . runIdentity) --- >>> Stream.fold Array.write (generally pure :: Stream IO Int) --- fromList [1,2,3] +-- If you are consuming an array piecemeal (uncons, unsnoc) or by slicing, +-- immutable Array type may be a tiny bit better than MutArray because it uses +-- a smaller constructor size. -- -- == Programming Tips -- -- This module is designed to be imported qualified: -- -- >>> import qualified Streamly.Data.Array as Array - --- | Same as 'reader' --- -{-# DEPRECATED read "Please use 'reader' instead" #-} -{-# INLINE_NORMAL read #-} -read :: (Monad m, Unbox a) => Unfold m (Array a) a -read = reader - --- | Same as 'readerRev' --- -{-# DEPRECATED readRev "Please use 'readerRev' instead" #-} -{-# INLINE_NORMAL readRev #-} -readRev :: (Monad m, Unbox a) => Unfold m (Array a) a -readRev = readerRev diff --git a/src/Streamly/Data/Array/Generic.hs b/src/Streamly/Data/Array/Generic.hs --- a/src/Streamly/Data/Array/Generic.hs +++ b/src/Streamly/Data/Array/Generic.hs @@ -15,29 +15,45 @@ ( Array -- * Construction - , A.fromListN - , A.fromList + , fromListN + , fromList -- MonadicAPIs - , A.writeN - , A.write + , createOf + , create + -- * Conversion + , toList + -- * Streams - , A.read - , A.readRev + , read + , readRev -- * Unfolds - , A.reader + , reader + -- , A.readerRev + -- * Stream of Arrays + , chunksOf + , toParserK + , parse + , parseBreak + , parsePos + , parseBreakPos + -- * Random Access - , A.length + , length + , getIndex -- -- * Folding Arrays -- , A.streamFold -- , A.fold + + -- * Deprecated + , writeN + , write ) where -import Streamly.Internal.Data.Array.Generic (Array) - -import qualified Streamly.Internal.Data.Array.Generic as A +import Streamly.Internal.Data.Array.Generic +import Prelude hiding (length, read) diff --git a/src/Streamly/Data/Fold.hs b/src/Streamly/Data/Fold.hs --- a/src/Streamly/Data/Fold.hs +++ b/src/Streamly/Data/Fold.hs @@ -7,9 +7,163 @@ -- Stability : released -- Portability : GHC -- --- Fast, composable stream consumers with ability to terminate, supporting --- stream fusion. +-- The 'Fold' type represents a consumer of a sequence of values, the +-- corresponding dual type is 'Streamly.Data.Stream.Stream' which represents a +-- producer. Both types can perform equivalent transformations on a stream. But +-- only 'Fold' can be used to compose multiple consumers and only 'Stream' can +-- be used to compose multiple producers. -- +-- The 'Fold' type represents stream consumers as state machines, that fuse +-- together when composed statically, eliminating function calls or +-- intermediate constructor allocations. Stream fusion helps generate tight, +-- efficient loops similar to the code generated by low-level languages like C. +-- Folds are suitable for high-performance looping operations. +-- +-- Operations in this module are designed to be composed statically rather than +-- dynamically. They are inlined to enable static fusion. More importantly, +-- they are not designed to be used recursively. Recursive use will break +-- fusion and will lead to quadratic performance slowdown. For dynamic or +-- recursive composition use the continuation passing style (CPS) operations +-- from the "Streamly.Data.ParserK" module. 'Fold' and +-- 'Streamly.Data.ParserK.ParserK' types are interconvertible via the +-- 'Streamly.Data.Parser.Parser' type. +-- +-- == Using Folds +-- +-- This module provides elementary folds and fold combinators that can be used +-- to consume a stream of data and reduce it to a final value, or transform it +-- in a stateful manner using scans. A data stream can be reduced into a stream +-- of folded data elements by folding segments of the stream. Fold combinators +-- can be used to compose multiple folds in parallel or to create a pipeline of +-- folds such that the next fold consumes the result of the previous fold. To +-- run these folds on a stream see 'Streamly.Data.Stream.fold', +-- 'Streamly.Data.Stream.scan', 'Streamly.Data.Stream.postscan', +-- 'Streamly.Data.Stream.scanMaybe', 'Streamly.Data.Stream.foldMany' and other +-- operations accepting 'Fold' type as argument "Streamly.Data.Stream". +-- +-- == Reducing a Stream +-- +-- A 'Fold' is a consumer of a stream of values. A fold driver (such as +-- 'Streamly.Data.Stream.fold') initializes the fold @accumulator@, runs the +-- fold @step@ function in a loop, processing the input stream one element at a +-- time and accumulating the result. The loop continues until the fold +-- terminates, at which point the accumulated result is returned. +-- +-- For example, a 'sum' Fold represents a stream consumer that adds the values +-- in the input stream: +-- +-- >>> Stream.fold Fold.sum $ Stream.fromList [1..100] +-- 5050 +-- +-- Conceptually, a 'Fold' is a data type that mimics a strict left fold +-- ('Data.List.foldl'). The above example is similar to a left fold using +-- @(+)@ as the step and @0@ as the initial value of the accumulator: +-- +-- >>> Data.List.foldl' (+) 0 [1..100] +-- 5050 +-- +-- 'Fold's have an early termination capability e.g. the 'one' fold terminates +-- after consuming one element: +-- +-- >>> Stream.fold Fold.one $ Stream.fromList [1..] +-- Just 1 +-- +-- The above example is similar to the following right fold: +-- +-- >>> Prelude.foldr (\x _ -> Just x) Nothing [1..] +-- Just 1 +-- +-- 'Fold's can be combined together using combinators. For example, to create a +-- fold that sums first two elements in a stream: +-- +-- >>> sumTwo = Fold.take 2 Fold.sum +-- >>> Stream.fold sumTwo $ Stream.fromList [1..100] +-- 3 +-- +-- == Parallel Composition +-- +-- Folds can be combined to run in parallel on the same input. For example, to +-- compute the average of numbers in a stream without going through the stream +-- twice: +-- +-- >>> avg = Fold.teeWith (/) Fold.sum (fmap fromIntegral Fold.length) +-- >>> Stream.fold avg $ Stream.fromList [1.0..100.0] +-- 50.5 +-- +-- Folds can be combined so as to partition the input stream over multiple +-- folds. For example, to count even and odd numbers in a stream: +-- +-- >>> split n = if even n then Left n else Right n +-- >>> stream = fmap split $ Stream.fromList [1..100] +-- >>> countEven = fmap (("Even " ++) . show) Fold.length +-- >>> countOdd = fmap (("Odd " ++) . show) Fold.length +-- >>> f = Fold.partition countEven countOdd +-- >>> Stream.fold f stream +-- ("Even 50","Odd 50") +-- +-- == Sequential Composition +-- +-- Terminating folds can be combined to parse the stream serially such that the +-- first fold consumes the input until it terminates and the second fold +-- consumes the rest of the input until it terminates: +-- +-- >>> f = Fold.splitWith (,) (Fold.take 8 Fold.toList) (Fold.takeEndBy (== '\n') Fold.toList) +-- >>> Stream.fold f $ Stream.fromList "header: hello\n" +-- ("header: ","hello\n") +-- +-- == Splitting a Stream +-- +-- A 'Fold' can be applied repeatedly on a stream to transform it to a stream +-- of fold results. To split a stream on newlines: +-- +-- >>> f = Fold.takeEndBy (== '\n') Fold.toList +-- >>> Stream.fold Fold.toList $ Stream.foldMany f $ Stream.fromList "Hello there!\nHow are you\n" +-- ["Hello there!\n","How are you\n"] +-- +-- Similarly, we can split the input of a fold too: +-- +-- >>> Stream.fold (Fold.many f Fold.toList) $ Stream.fromList "Hello there!\nHow are you\n" +-- ["Hello there!\n","How are you\n"] +-- +-- == Folds vs. Streams +-- +-- We can often use streams or folds to achieve the same goal. However, streams +-- are required for composition of producers (e.g. +-- 'Data.Stream.append' or 'Data.Stream.mergeBy') whereas folds are +-- required for composition of consumers (e.g. 'splitWith', 'partition' +-- or 'teeWith'). +-- +-- Streams are producers, transformations on streams happen on the output side: +-- +-- >>> :{ +-- f stream = +-- Stream.filter odd stream +-- & fmap (+1) +-- & Stream.fold Fold.sum +-- :} +-- +-- >>> f $ Stream.fromList [1..100 :: Int] +-- 2550 +-- +-- Folds are stream consumers with an input stream and an output value, stream +-- transformations on folds happen on the input side: +-- +-- >>> :{ +-- f = +-- Fold.filter odd +-- $ Fold.lmap (+1) +-- $ Fold.sum +-- :} +-- +-- >>> Stream.fold f $ Stream.fromList [1..100 :: Int] +-- 2550 +-- +-- Notice the similiarity in the definition of @f@ in both cases, the only +-- difference is the composition by @&@ vs @$@ and the use @lmap@ vs @map@, the +-- difference is due to output vs input side transformations. +-- +-- == Experimental APIs +-- -- Please refer to "Streamly.Internal.Data.Fold" for more functions that have -- not yet been released. @@ -21,25 +175,38 @@ -- -- $setup - -- * Overview - -- $overview - - -- * Running A Fold - drive - -- XXX Should we have a stream returning function in fold module? - -- , breakStream - -- * Fold Type - , Fold -- (..) + Fold -- (..) , Tee (..) + -- * Running A Fold + -- | 'Streamly.Data.Strem.fold' and 'drive' are the basic fold runners. + -- Folds can also be used a incremental builders. The 'addOne' and + -- 'addStream' combinators can be used to incrementally build any type of + -- structure using a fold, including arrays or a stream of arrays. + + , drive + -- XXX should rename to "extract". can use "Fold.drive Stream.nil" instead, + -- for now. + -- , extractM + -- , reduce + , addOne + -- , snocl + -- XXX Can we use something like concatEffect to implement snocM? + -- , snocM + -- , snoclM + , addStream + , duplicate + -- , isClosed + -- * Constructors , foldl' , foldlM' , foldl1' - , foldlM1' + , foldl1M' , foldr' + , foldtM' -- * Folds -- ** Accumulators @@ -72,10 +239,6 @@ , toListRev , toSet , toIntSet - , toMap - , toMapIO - , demuxToMap - , demuxToMapIO , topBy -- ** Non-Empty Accumulators @@ -97,10 +260,6 @@ , uniqBy , nub , nubInt - , classify - , classifyIO - , demux - , demuxIO -- ** Terminating Folds , one @@ -122,35 +281,12 @@ , and , or - -- * Incremental builders - -- | Mutable arrays ("Streamly.Data.MutArray") are basic builders. You can - -- use the 'Streamly.Data.MutArray.snoc' or - -- 'Streamly.Data.MutArray.writeAppend' operations to incrementally build - -- mutable arrays. The 'addOne' and 'addStream' combinators can be used to - -- incrementally build any type of structure using a fold, including arrays - -- or a stream of arrays. - -- - -- Use pinned arrays if you are going to use the data for IO. - - -- XXX should rename to "extract". can use "Fold.drive Stream.nil" instead, - -- for now. - -- , extractM - -- , reduce - , addOne - -- , snocl - -- XXX Can we use something like concatEffect to implement snocM? - -- , snocM - -- , snoclM - , addStream - , duplicate - -- , isClosed - - -- * Combinators - -- | Combinators are modifiers of folds. In the type @Fold m a b@, @a@ is - -- the input type and @b@ is the output type. Transformations can be + -- * Transformations + -- | Transformations are modifiers of folds. In the type @Fold m a b@, @a@ + -- is the input type and @b@ is the output type. Transformations can be -- applied either on the input side (contravariant) or on the output side - -- (covariant). Therefore, combinators are of one of the following general - -- shapes: + -- (covariant). Therefore, transformations have one of the following + -- general shapes: -- -- * @... -> Fold m a b -> Fold m c b@ (input transformation) -- * @... -> Fold m a b -> Fold m a c@ (output transformation) @@ -173,10 +309,7 @@ , lmap , lmapM - -- ** Scanning and Filtering - , scan - , postscan - , scanMaybe + -- ** Filtering , filter , filterM @@ -189,12 +322,36 @@ -- ** Trimming , take - -- , takeInterval , takeEndBy , takeEndBy_ + , takeEndBySeq + , takeEndBySeq_ - -- ** Serial Append + -- ** Key-value Collectors + , toMap + , toMapIO + + {- + -- ** Key-value Scanners + , classifyScan + , classifyScanIO + -} + + -- ** Transforming the Monad + , morphInner + + -- * Combinators + -- | Transformations that combine two or more folds. + + -- ** Scanning + , scanl + , postscanl + -- , postscanlMaybe + + -- ** Splitting , splitWith + , many + , groupsOf -- ** Parallel Distribution -- | For applicative composition using distribution see @@ -219,18 +376,25 @@ -- ** Unzipping , unzip - -- ** Splitting - , many - , groupsOf - -- , intervalsOf + -- * Dynamic Combinators + -- | The fold to be used is generated dynamically based on the input or + -- based on the output of the previous fold. + -- ** Key-value Collectors + , demuxerToMap + , demuxerToMapIO + + {- + -- ** Key-value Scanners + , demuxScan + , demuxScanIO + -} + -- ** Nesting , concatMap - -- * Transforming the Monad - , morphInner - -- * Deprecated + , foldlM1' , chunksOf , foldr , drainBy @@ -241,136 +405,29 @@ , variance , stdDev , serialWith + , classify + , classifyIO + , demux + , demuxIO + , demuxToMap + , demuxToMapIO + , scan + , postscan + , scanMaybe ) where import Prelude - hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr, - foldl, map, mapM_, sequence, all, any, sum, product, elem, - notElem, maximum, minimum, head, last, tail, length, null, - reverse, iterate, init, and, or, lookup, foldr1, (!!), - scanl, scanl1, replicate, concatMap, mconcat, foldMap, unzip, + hiding (Foldable(..), filter, drop, dropWhile, take, takeWhile, zipWith, + map, mapM_, sequence, all, any, + notElem, head, last, tail, + reverse, iterate, init, and, or, lookup, (!!), + scanl, scanl1, replicate, concatMap, mconcat, unzip, span, splitAt, break, mapM, maybe) import Streamly.Internal.Data.Fold -import Streamly.Internal.Data.Fold.Container #include "DocTestDataFold.hs" - --- $overview --- --- A 'Fold' is a consumer of a stream of values. A fold driver (such as --- 'Streamly.Data.Stream.fold') initializes the fold @accumulator@, runs the --- fold @step@ function in a loop, processing the input stream one element at a --- time and accumulating the result. The loop continues until the fold --- terminates, at which point the accumulated result is returned. --- --- For example, a 'sum' Fold represents a stream consumer that adds the values --- in the input stream: --- --- >>> Stream.fold Fold.sum $ Stream.fromList [1..100] --- 5050 --- --- Conceptually, a 'Fold' is a data type that mimics a strict left fold --- ('Data.List.foldl'). The above example is similar to a left fold using --- @(+)@ as the step and @0@ as the initial value of the accumulator: --- --- >>> Data.List.foldl' (+) 0 [1..100] --- 5050 --- --- 'Fold's have an early termination capability e.g. the 'one' fold terminates --- after consuming one element: --- --- >>> Stream.fold Fold.one $ Stream.fromList [1..] --- Just 1 --- --- The above example is similar to the following right fold: --- --- >>> Prelude.foldr (\x _ -> Just x) Nothing [1..] --- Just 1 --- --- 'Fold's can be combined together using combinators. For example, to create a --- fold that sums first two elements in a stream: --- --- >>> sumTwo = Fold.take 2 Fold.sum --- >>> Stream.fold sumTwo $ Stream.fromList [1..100] --- 3 --- --- Folds can be combined to run in parallel on the same input. For example, to --- compute the average of numbers in a stream without going through the stream --- twice: --- --- >>> avg = Fold.teeWith (/) Fold.sum (fmap fromIntegral Fold.length) --- >>> Stream.fold avg $ Stream.fromList [1.0..100.0] --- 50.5 --- --- Folds can be combined so as to partition the input stream over multiple --- folds. For example, to count even and odd numbers in a stream: --- --- >>> split n = if even n then Left n else Right n --- >>> stream = fmap split $ Stream.fromList [1..100] --- >>> countEven = fmap (("Even " ++) . show) Fold.length --- >>> countOdd = fmap (("Odd " ++) . show) Fold.length --- >>> f = Fold.partition countEven countOdd --- >>> Stream.fold f stream --- ("Even 50","Odd 50") --- --- Terminating folds can be combined to parse the stream serially such that the --- first fold consumes the input until it terminates and the second fold --- consumes the rest of the input until it terminates: --- --- >>> f = Fold.splitWith (,) (Fold.take 8 Fold.toList) (Fold.takeEndBy (== '\n') Fold.toList) --- >>> Stream.fold f $ Stream.fromList "header: hello\n" --- ("header: ","hello\n") --- --- A 'Fold' can be applied repeatedly on a stream to transform it to a stream --- of fold results. To split a stream on newlines: --- --- >>> f = Fold.takeEndBy (== '\n') Fold.toList --- >>> Stream.fold Fold.toList $ Stream.foldMany f $ Stream.fromList "Hello there!\nHow are you\n" --- ["Hello there!\n","How are you\n"] --- --- Similarly, we can split the input of a fold too: --- --- >>> Stream.fold (Fold.many f Fold.toList) $ Stream.fromList "Hello there!\nHow are you\n" --- ["Hello there!\n","How are you\n"] --- --- = Folds vs. Streams --- --- We can often use streams or folds to achieve the same goal. However, streams --- are more efficient in composition of producers (e.g. --- 'Data.Stream.append' or 'Data.Stream.mergeBy') whereas folds are --- more efficient in composition of consumers (e.g. 'splitWith', 'partition' --- or 'teeWith'). --- --- Streams are producers, transformations on streams happen on the output side: --- --- >>> :{ --- f stream = --- Stream.filter odd stream --- & fmap (+1) --- & Stream.fold Fold.sum --- :} --- --- >>> f $ Stream.fromList [1..100 :: Int] --- 2550 --- --- Folds are stream consumers with an input stream and an output value, stream --- transformations on folds happen on the input side: --- --- >>> :{ --- f = --- Fold.filter odd --- $ Fold.lmap (+1) --- $ Fold.sum --- :} --- --- >>> Stream.fold f $ Stream.fromList [1..100 :: Int] --- 2550 --- --- Notice the similiarity in the definition of @f@ in both cases, the only --- difference is the composition by @&@ vs @$@ and the use @lmap@ vs @map@, the --- difference is due to output vs input side transformations. -------------------------------------------------------------------------------- -- Deprecated diff --git a/src/Streamly/Data/MutArray.hs b/src/Streamly/Data/MutArray.hs --- a/src/Streamly/Data/MutArray.hs +++ b/src/Streamly/Data/MutArray.hs @@ -12,7 +12,7 @@ -- contents of a mutable array can be modified in-place. For general -- documentation, please refer to the original module. -- --- Please refer to "Streamly.Internal.Data.Array.Mut" for functions that have +-- Please refer to "Streamly.Internal.Data.MutArray" for functions that have -- not yet been released. -- -- For mutable arrays that work on boxed types, not requiring the 'Unbox' @@ -32,36 +32,55 @@ -- * Construction -- Uninitialized Arrays - , new - , newPinned + , emptyOf + , emptyOf' -- From containers , fromListN , fromList - , writeN -- drop new - , write -- full buffer - -- writeLastN + , createOf + , create + -- createOfLast + -- * Pinning & Unpinning + , pin + , unpin + , isPinned + -- * Appending elements , snoc -- * Appending streams - , writeAppendN - , writeAppend + , appendN + , append2 -- * Inplace mutation , putIndex + , unsafePutIndex + , modifyIndex + , unsafeModifyIndex + , modify -- * Random access , getIndex + , unsafeGetIndex -- * Conversion , toList + -- * Streams + , read + , readRev + -- * Unfolds , reader , readerRev + -- * Stream of Arrays + -- | Also see the "Streamly.Data.Stream.Prelude" module in the "streamly" + -- package for chunking of a stream with timeout. + , chunksOf + -- * Casting , cast , asBytes @@ -69,13 +88,33 @@ -- * Size , length - -- * Unbox Type Class + -- * Re-exports , Unbox (..) + + -- * Deprecated + , pinnedEmptyOf + , newPinned + , new + , pinnedNew + , writeN + , write + , writeAppendN + , writeAppend + , putIndexUnsafe + , modifyIndexUnsafe + , getIndexUnsafe + , append ) where import Prelude hiding (length, read) -import Streamly.Internal.Data.Array.Mut -import Streamly.Internal.Data.Unboxed (Unbox (..)) +import Streamly.Internal.Data.MutArray +import Streamly.Internal.Data.Unbox (Unbox (..)) +import Control.Monad.IO.Class (MonadIO) #include "DocTestDataMutArray.hs" + +{-# DEPRECATED newPinned "Please use emptyOf' instead." #-} +{-# INLINE newPinned #-} +newPinned :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) +newPinned = emptyOf' diff --git a/src/Streamly/Data/MutArray/Generic.hs b/src/Streamly/Data/MutArray/Generic.hs --- a/src/Streamly/Data/MutArray/Generic.hs +++ b/src/Streamly/Data/MutArray/Generic.hs @@ -23,27 +23,54 @@ MutArray -- * Construction - , writeN + , emptyOf + , fromListN + , fromList + , createOf + , create -- * Appending elements - , new , snoc + -- * Inplace mutation + , putIndex + , unsafePutIndex + , modifyIndex + , unsafeModifyIndex + -- , modify + + -- * Random reads + , getIndex + , unsafeGetIndex + -- * Conversion , toList + -- * Streams + , read + , readRev + -- * Unfolds , reader + -- , readerRev - -- * Random reads - , getIndex + -- * Stream of Arrays + , chunksOf - -- * Inplace mutation - , putIndex - , modifyIndex + -- * Size + , length + + -- * Deprecated + , new + , writeN + , write + , modifyIndexUnsafe + , putIndexUnsafe + , getIndexUnsafe ) where -import Streamly.Internal.Data.Array.Generic.Mut.Type +import Streamly.Internal.Data.MutArray.Generic +import Prelude hiding (read, length) #include "DocTestDataMutArrayGeneric.hs" diff --git a/src/Streamly/Data/MutByteArray.hs b/src/Streamly/Data/MutByteArray.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/MutByteArray.hs @@ -0,0 +1,131 @@ +-- | +-- Module : Streamly.Data.MutByteArray +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- This module implements a low level byte Array type 'MutByteArray', along +-- with type classes 'Unbox' and 'Serialize' for fast binary serialization and +-- deserialization of Haskell values. Serialization, deserialization +-- performance is similar to, and in some cases many times better than the +-- store package. Conceptually, the 'Serialize' type class works in the same +-- way as store. +-- +-- == Fast serialization with schema +-- +-- Serialize instances are configurable to use constructor names (see +-- 'Streamly.Internal.Data.MutByteArray.encodeConstrNames'), record field names (see +-- 'Streamly.Internal.Data.MutByteArray.encodeRecordFields') instead of binary +-- encoded values. This is an experimental feature which allows JSON like +-- properties with faster speed. For example, you can change the order of +-- constructors or record fields without affecting serialized value. +-- +-- == Serialization with Array and MutArray +-- +-- Higher level unboxed array modules "Streamly.Data.Array" and +-- "Streamly.Data.MutArray" are built on top of this module. Unboxed arrays are +-- essentially serialized Haskell values. Array modules provide higher level +-- serialization routines like 'Streamly.Internal.Data.Array.pinnedSerialize' +-- and 'Streamly.Internal.Data.Array.deserialize' in the +-- "Streamly.Internal.Data.Array" module. +-- +-- == Mutable Byte Array +-- +-- 'MutByteArray' is a primitive mutable array in the IO monad. 'Unbox' and +-- 'Serialize' type classes use this primitive array to serialize data to and +-- deserialize it from. This array is used to build higher level unboxed +-- array types 'Streamly.Data.MutArray.MutArray' and 'Streamly.Data.Array.Array'. +-- +-- == Using with FFI +-- +-- For using an array with "safe" FFI functions or OS interfaces the array must +-- be pinned using 'pin' and then the array pointer can be accessed using +-- 'unsafeAsPtr'. +-- +-- For using with "unsafe" FFI functions, the array can remain unpinned. The +-- safe way to do that is to directly pass the underlying 'MutableByteArray# +-- RealWorld' (using 'getMutByteArray#') to the FFI function wherever a pointer +-- to the array is required, it translates to the memory address of the payload +-- of the array. +-- +-- For more details, see the FFI section in the GHC user guide. Here is a +-- relevant excerpt from the GHC manual: +-- +-- GHC, since version 8.4, guarantees that garbage collection will never occur +-- during an unsafe call, even in the bytecode interpreter, and further +-- guarantees that unsafe calls will be performed in the calling thread. Making +-- it safe to pass heap-allocated objects to unsafe functions. + +-- == Serialization using Unbox +-- +-- The 'Unbox' type class is simple and used to serialize non-recursive fixed +-- size data types. This type class is primarily used to implement unboxed +-- arrays. Unboxed arrays are just a sequence of serialized fixed length +-- Haskell data types. Instances of this type class can be derived using +-- 'Generic' or template haskell based deriving functions provided in this +-- module. +-- +-- Writing a data type to an array using the array creation routines in +-- "Streamly.Data.Array" or "Streamly.Data.MutArray" (e.g. @writeN@ or +-- @fromListN@), serializes the type to the array. Similarly, reading the data +-- type from the array deserializes it. You can also serialize and deserialize +-- directly to and from a 'MutByteArray', using the type class methods. +-- +-- == Serialization using Serialize +-- +-- The 'Serialize' type class is a superset of the 'Unbox' type class, it can +-- serialize variable length data types as well e.g. Haskell lists. Use +-- 'deriveSerialize' to derive the instances of the type class automatically +-- and then use the type class methods to serialize and deserialize to and from +-- a 'MutByteArray'. +-- +-- See 'Streamly.Internal.Data.Array.pinnedSerialize' and +-- 'Streamly.Internal.Data.Array.deserialize' for 'Array' type based +-- serialization. +-- +-- == Comparing serialized values +-- +-- When using the `Unbox` type class the same value may result in differing +-- serialized bytes because of unused uninitialized data in case of sum types. +-- Therefore, byte comparison of serialized values is not reliable. +-- +-- However, the 'Serialize' type class guarantees that the serialized values +-- are always exactly the same and byte comparison of serialized is reliable. +-- +module Streamly.Data.MutByteArray + ( + + -- * Mutable Byte Array + -- | The standard way to read from or write to a 'MutByteArray' is by using + -- the 'Unbox' or 'Serialize' type class methods. + MutByteArray + , isPinned + , pin + , unpin + , new + , pinnedNew + + -- * Unbox + , Unbox(..) + , deriveUnbox + + -- * Serialize + , Serialize(..) + + -- ** Instance Config + , SerializeConfig + , inlineAddSizeTo + , inlineSerializeAt + , inlineDeserializeAt + + -- ** Instance Deriving + , deriveSerialize + , deriveSerializeWith + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Streamly.Internal.Data.MutByteArray diff --git a/src/Streamly/Data/Parser.hs b/src/Streamly/Data/Parser.hs --- a/src/Streamly/Data/Parser.hs +++ b/src/Streamly/Data/Parser.hs @@ -7,13 +7,174 @@ -- Stability : pre-release -- Portability : GHC -- --- Fast, composable stream consumers with ability to terminate, backtrack and --- fail, supporting stream fusion. Parsers are a natural extension of --- "Streamly.Data.Fold". Parsers and folds can be interconverted. +-- Parsers are more powerful but less general than 'Streamly.Data.Fold.Fold's: -- --- Please refer to "Streamly.Internal.Data.Parser" for functions that have --- not yet been released. +-- * folds cannot fail but parsers can fail and backtrack. +-- * folds can be composed as a Tee but parsers cannot. +-- * folds can be converted to parsers. -- +-- Streamly parsers support all operations offered by popular Haskell parser +-- libraries. Unlike other parser libraries, (1) streamly parsers can operate +-- on any Haskell type as input - not just bytes, (2) natively support +-- streaming, (3) and are faster. +-- +-- == High Performance by Static Parser Fusion +-- +-- Like folds, parsers are designed to utilize stream fusion, compiling to +-- efficient low-level code comparable to the speed of C. Parsers are suitable +-- for high-performance parsing of streams. +-- +-- Operations in this module are designed to be composed statically rather than +-- dynamically. They are inlined to enable static fusion. More importantly, +-- they are not designed to be used recursively. Recursive use will break +-- fusion and lead to quadratic performance slowdown. For dynamic and +-- recursive compositions use the continuation passing style (CPS) operations +-- from the "Streamly.Data.ParserK" module. 'Parser' and +-- 'Streamly.Data.ParserK.ParserK' types are interconvertible. +-- +-- == How to parse a stream? +-- +-- Parser combinators can be used to create a pipeline of parsers such +-- that the next parser consumes the result of the previous parser. +-- Such a composed pipeline of parsers can then be driven by one of many parser +-- drivers available in the Stream and Array modules. +-- +-- Use Streamly.Data.Stream.'Streamly.Data.Stream.parse' or +-- Streamly.Data.Stream.'Streamly.Data.Stream.parseBreak' to run a parser on an +-- input stream and return the parsed result. +-- +-- Use Streamly.Data.Stream.'Streamly.Data.Stream.parseMany' or +-- Streamly.Data.Stream.'Streamly.Data.Stream.parseIterate' to transform an +-- input data stream to an output stream of parsed data elements using a +-- parser. +-- +-- == Parser vs ParserK +-- +-- There are two functionally equivalent parsing modules, +-- "Streamly.Data.Parser" (this module) and "Streamly.Data.ParserK". The latter +-- is a CPS based wrapper over the former, and can be used for parsing in +-- general. "Streamly.Data.Parser" enables stream fusion and where possible it should be +-- preferred over "Streamly.Data.ParserK" for high performance stream parsing +-- use cases. However, there are a few cases where this module is not +-- suitable and ParserK should be used instead. As a thumb rule, when recursion +-- or heavy nesting is needed use ParserK. +-- +-- === Parser: suitable for non-recursive static fusion +-- +-- The 'Parser' type is suitable only for non-recursive static fusion. It could +-- be problematic for recursive definitions. To enable static fusion, parser +-- combinators use strict pattern matching on arguments of type Parser. This +-- leads to infinte loop when a parser is defined recursively, due to strict +-- evaluation of the recursive call. For example, the following implementation +-- loops infinitely because of the recursive use of parser @p@ in the @*>@ +-- combinator: +-- +-- >>> import Streamly.Data.Parser (Parser) +-- >>> import qualified Streamly.Data.Fold as Fold +-- >>> import qualified Streamly.Data.Parser as Parser +-- >>> import qualified Streamly.Data.Stream as Stream +-- >>> import Control.Applicative ((<|>)) +-- +-- >>> :{ +-- >>> p, p1, p2 :: Monad m => Parser Char m String +-- >>> p1 = Parser.satisfy (== '(') *> p +-- >>> p2 = Parser.fromFold Fold.toList +-- >>> p = p1 <|> p2 +-- >>> :} +-- +-- Another limitation of Parser type quadratic performance slowdown when too +-- many nested compositions are used. Especially Applicative, Monad, +-- Alternative instances, and sequenced parsing operations (e.g. nested 'one', +-- and 'splitWith') exhibit quadratic slowdown (O(n^2) complexity) when +-- combined @n@ times, roughly 8 or less sequenced parsers usually work fine. +-- READ THE DOCS OF APPLICATIVE, MONAD AND ALTERNATIVE INSTANCES. +-- +-- === ParserK: suitable for recursive definitions +-- +-- ParserK is suitable for recursive definitions: +-- +-- >>> import Streamly.Data.ParserK (ParserK) +-- >>> import Streamly.Data.StreamK (toParserK) +-- >>> import qualified Streamly.Data.StreamK as StreamK +-- +-- >>> :{ +-- >>> p, p1, p2 :: Monad m => ParserK Char m String +-- >>> p1 = toParserK (Parser.satisfy (== '(')) *> p +-- >>> p2 = toParserK (Parser.fromFold Fold.toList) +-- >>> p = p1 <|> p2 +-- >>> :} +-- +-- >>> StreamK.parse p $ StreamK.fromStream $ Stream.fromList "hello" +-- Right "hello" +-- +-- For this reason Applicative, Alternative or Monad compositions with +-- recursion cannot be used with the 'Parser' type. Alternative type class based +-- operations like 'asum' and Alternative based generic parser combinators use +-- recursion. Similarly, Applicative type class based operations like +-- 'Prelude.sequence' use recursion. Custom implementations of many such +-- operations are provided in this module (e.g. 'some', 'many'), and those +-- should be used instead. +-- +-- == Parsers Galore! +-- +-- Streamly provides all the parsing functionality provided by popular parsing +-- libraries, and much more with higher performance. +-- This module provides most of the elementary parsers and parser combinators. +-- Additionally, +-- +-- * all the folds from the "Streamly.Data.Fold" module can be converted to +-- parsers using 'fromFold'. +-- * "Streamly.Unicode.Parser" module provides Char stream parsers. +-- * all the combinators from the +-- +-- package can be used with streamly ParserK. +-- * See "Streamly.Internal.Data.Parser" for many more unreleased but useful APIs. +-- +-- == Generic Parser Combinators +-- +-- With 'Streamly.Data.ParserK.ParserK' you can use the 'Applicative' and +-- 'Control.Applicative.Alternative' type class based generic parser +-- combinators from the +-- +-- library or similar. However, if available, we recommend that you use the +-- equivalent functionality from this module where performance and streaming +-- behavior matters. +-- Firstly, the combinators in this module are faster due to stream fusion. +-- Secondly, these are streaming in nature as the results can be passed +-- directly to other stream consumers (folds or parsers). The Alternative type +-- class based parsers would end up buffering all the results in lists before +-- they can be consumed. +-- +-- == Error Reporting +-- +-- There are two types of parser drivers available, @parse@ and @parseBreak@ +-- drivers do not track stream position, whereas @parsePos@ and @parseBreakPos@ +-- drivers track and report stream position information with slightly more +-- performance overhead. +-- +-- When an error occurs the stream position is reported, in case of byte streams +-- or unboxed array streams this is the byte position, in case of generic +-- element parsers or generic array parsers this is the element position in the +-- stream. +-- +-- These parsers do not report a case specific error context (e.g. line number +-- or column). If you need line number or column information you can read the +-- stream again (if it is immutable) and this count the lines to translate the +-- reported byte position to line number and column. More elaborate support for +-- building arbitrary and custom error context information is planned to be +-- added in future. +-- +-- == Monad Transformer Stack +-- +-- 'MonadTrans' instance is not provided. If the 'Parser' type is the top most +-- layer (which should be the case almost always) you can just use 'fromEffect' +-- to execute the lower layer monad effects. +-- +-- == Experimental APIs +-- +-- Please refer to "Streamly.Internal.Data.Parser" for functions that have not +-- yet been released. +-- module Streamly.Data.Parser ( -- * Setup @@ -22,16 +183,15 @@ -- -- $setup - -- * Overview - -- $overview - -- * Parser Type Parser + , ParseError(..) + , ParseErrorPos(..) -- -- * Downgrade to Fold -- , toFold - -- * Parsers + -- * Elementary Parsers -- ** From Folds , fromFold @@ -44,7 +204,7 @@ , peek , eof - -- ** Element parsers + -- ** Single Elements -- All of these can be expressed in terms of either , one @@ -61,15 +221,15 @@ , listEqBy , listEq - -- * Combinators + -- * Transformations -- Mapping on output -- , rmapM - -- ** Mapping on input + -- ** Map on input , lmap , lmapM - -- * Map on output + -- ** Map on output , rmapM -- ** Filtering @@ -78,6 +238,7 @@ -- ** Look Ahead , lookAhead + -- * Tokenizing Combinators -- ** Tokenize by length -- , takeBetween , takeEQ @@ -96,8 +257,8 @@ -- ** Grouping , groupBy - -- , groupByRolling - -- , groupByRollingEither + , groupByRolling + , groupByRollingEither -- ** Framing -- , wordFramedBy @@ -108,12 +269,12 @@ -- -- * Alternative -- , alt - -- ** Splitting + -- * Splitting , many , some , manyTill - -- ** De-interleaving + -- * De-interleaving , deintercalate ) @@ -123,55 +284,3 @@ import Prelude hiding (dropWhile, takeWhile, filter) #include "DocTestDataParser.hs" - --- $overview --- --- Several combinators in this module can be many times faster than CPS based --- parsers because of stream fusion. For example, --- 'Streamly.Internal.Data.Parser.many' combinator in this module is much --- faster than the 'Control.Applicative.many' combinator of --- 'Control.Applicative.Alternative' type class used by CPS based parsers. --- --- The use of 'Alternative' type class, in parsers has another drawback. --- Alternative based parsers use plain Haskell lists to collect the results. In --- a strict Monad like IO, the results are necessarily buffered before they can --- be consumed. This may not perform optimally in streaming applications --- processing large amounts of data. Equivalent combinators in this module can --- consume the results of parsing using a 'Fold' or another parser, thus --- providing a scalable and composable consumer. --- --- Note that these parsers do not report the error context (e.g. line number or --- column). This may be supported in future. --- --- mtl instances are not provided. If the 'Parser' type is the top most layer --- (which should be the case almost always) you can just use 'fromEffect' to --- execute the lower layer monad effects. --- --- == Performance Notes --- --- The 'Parser' type represents a stream consumer by composing state as data --- which enables stream fusion. Stream fusion generates a tight loop without --- any constructor allocations between the stages, providing C like performance --- for the loop. Stream fusion works when multiple functions are combined in a --- pipeline statically. Therefore, the operations in this module must be --- inlined and must not be used recursively to allow for stream fusion. Note --- that operations like 'sequence', and 'asum' that compose pasrers using --- recursion should be avoided with these parsers. You can use these with the --- 'ParserK' module instead. --- --- Using the 'Parser' type, parsing operations like 'one', 'splitWith' etc. --- degrade quadratically (O(n^2)) when combined many times. If you need to --- combine these operations, say more than 8 times in a single loop, then you --- should consider using the continuation style parser type 'ParserK' instead. --- Also, if you need to use these operations in a recursive loop you should use --- 'ParserK' instead. --- --- The 'ParserK' type represents a stream consumer by composing function calls, --- therefore, a function call overhead is incurred at each composition. It is --- quite fast in general but may be a few times slower than a fused parser. --- However, it allows for scalable dynamic composition especially parsers can --- be used in recursive calls. Using the 'ParserK' type operations like --- 'splitWith' provide linear (O(n)) performance with respect to the number of --- compositions.. --- --- 'Parser' and 'ParserK' types can be interconverted. diff --git a/src/Streamly/Data/ParserK.hs b/src/Streamly/Data/ParserK.hs --- a/src/Streamly/Data/ParserK.hs +++ b/src/Streamly/Data/ParserK.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Data.ParserK -- Copyright : (c) 2023 Composewell Technologies @@ -6,39 +7,150 @@ -- Stability : pre-release -- Portability : GHC -- --- Parsers using Continuation Passing Style (CPS). See notes in --- "Streamly.Data.Parser" module to know when to use this module. +-- See the general notes about parsing in the "Streamly.Data.Parser" module. +-- This (ParserK) module implements a Continuation Passing Style (CPS) wrapper +-- over the fused "Streamly.Data.Parser" module. It is a faster CPS parser than +-- attoparsec. -- --- To run a 'ParserK' use 'Streamly.Data.StreamK.parseChunks'. +-- The 'ParserK' type represents a stream-consumer as a composition of function +-- calls, therefore, a function call overhead is incurred at each composition. +-- It is reasonably fast in general but may be a few times slower than the +-- fused 'Streamly.Data.Parser.Parser' type. However, unlike fused parsers, it +-- allows for scalable dynamic composition, especially, 'ParserK' can be used +-- in recursive calls. Operations like 'splitWith' on 'ParserK' type have +-- linear (O(n)) performance with respect to the number of compositions. -- +-- 'ParserK' is preferred over the fused 'Streamly.Data.Parser.Parser' when +-- extensive applicative, alternative and monadic composition is required, or +-- when recursive or dynamic composition of parsers is required. 'ParserK' also +-- allows efficient parsing of a stream of byte arrays, it can also break the +-- input stream into a parse result and the remaining stream so that the stream +-- can be parsed independently in segments. +-- +-- == How to parse a stream? +-- +-- All the fused parsers from the "Streamly.Data.Parser" module can be +-- converted to the CPS ParserK, for use with different types of parser +-- drivers, using +-- the @toParserK@ combinators - +-- Streamly.Data.Array.'Streamly.Data.Array.toParserK', +-- Streamly.Data.StreamK.'Streamly.Data.StreamK.toParserK', and +-- Streamly.Data.Array.Generic.'Streamly.Data.Array.Generic.toParserK' +-- +-- To parse a stream of unboxed arrays, use +-- Streamly.Data.Array.'Streamly.Data.Array.parse' for running the parser, this +-- is the preferred and most efficient way to parse chunked input. The +-- Streamly.Data.Array.'Streamly.Data.Array.parseBreak' function returns the +-- remaining stream as well along with the parse result. +-- +-- To parse a stream of boxed arrays, use +-- Streamly.Data.Array.Generic.'Streamly.Data.Array.Generic.parse' or +-- Streamly.Data.Array.Generic.'Streamly.Data.Array.Generic.parseBreak' to run +-- the parser. +-- +-- To parse a stream of individual elements, use +-- Streamly.Data.StreamK.'Streamly.Data.StreamK.parse' and +-- Streamly.Data.StreamK.'Streamly.Data.StreamK.parseBreak' to run the parser. +-- +-- == Applicative Composition +-- +-- Applicative parsers are simpler but we cannot use lookbehind as we can in +-- the monadic parsers. +-- +-- If we have to parse "9a" or "a9" but not "99" or "aa" we can use the +-- following Applicative, backtracking parser: +-- +-- >>> -- parse p1 : p2 : [] +-- >>> token p1 p2 = ((:) <$> p1 <*> ((:) <$> p2 <*> pure [])) +-- >>> :{ +-- backtracking :: Monad m => ParserK Char m String +-- backtracking = StreamK.toParserK $ +-- token (Parser.satisfy isDigit) (Parser.satisfy isAlpha) -- e.g. "9a" +-- <|> +-- token (Parser.satisfy isAlpha) (Parser.satisfy isDigit) -- e.g. "a9" +-- :} +-- +-- == Monadic Composition +-- +-- Monad composition can be used to implement lookbehind parsers, we can dynamically +-- compose new parsers based on the results of the previously parsed values. +-- +-- In the previous example, we know that if the first parse resulted in a digit +-- at the first place then the second parse is going to fail. However, we +-- waste that information and parse the first character again in the second +-- parse only to know that it is not an alphabetic char. By using lookbehind +-- in a 'Monad' composition we can make dynamic decisions based on previously +-- parsed information and avoid redundant work: +-- +-- >>> data DigitOrAlpha = Digit Char | Alpha Char +-- +-- >>> :{ +-- lookbehind :: Monad m => ParserK Char m String +-- lookbehind = do +-- x1 <- StreamK.toParserK $ +-- Digit <$> Parser.satisfy isDigit +-- <|> Alpha <$> Parser.satisfy isAlpha +-- -- Note: the parse depends on what we parsed already +-- x2 <- StreamK.toParserK $ +-- case x1 of +-- Digit _ -> Parser.satisfy isAlpha +-- Alpha _ -> Parser.satisfy isDigit +-- return $ case x1 of +-- Digit x -> [x,x2] +-- Alpha x -> [x,x2] +-- :} +-- +-- == Experimental APIs +-- +-- Please refer to "Streamly.Internal.Data.ParserK" for functions that have +-- not yet been released. +-- module Streamly.Data.ParserK ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + -- * Parser Type ParserK -- * Parsers - -- ** Conversions - , fromFold - , fromParser - -- , toParser - -- ** Without Input + -- -- ** Without Input , fromPure , fromEffect , die + + -- * Deprecated + , fromFold + , fromParser + , adapt + , adaptC + , adaptCG ) where import Control.Monad.IO.Class (MonadIO) import Streamly.Internal.Data.Fold (Fold) -import Streamly.Internal.Data.Unboxed (Unbox) -import qualified Streamly.Internal.Data.Parser.ParserD as ParserD +import Streamly.Internal.Data.Unbox (Unbox) +import Streamly.Internal.Data.Array (Array) +import qualified Streamly.Internal.Data.Parser as ParserD +import qualified Streamly.Internal.Data.Array as Array -import Streamly.Internal.Data.Parser.ParserK.Type +import Streamly.Internal.Data.ParserK --- | Convert a 'Fold' to a 'ParserK'. --- +#include "DocTestDataParserK.hs" + +{-# DEPRECATED fromFold "Please use \"Array.toParserK . Parser.fromFold\" instead." #-} {-# INLINE fromFold #-} -fromFold :: (MonadIO m, Unbox a) => Fold m a b -> ParserK a m b -fromFold = fromParser . ParserD.fromFold +fromFold :: (MonadIO m, Unbox a) => Fold m a b -> ParserK (Array a) m b +fromFold = Array.toParserK . ParserD.fromFold + +{-# DEPRECATED fromParser "Please use \"Array.toParserK\" instead." #-} +{-# INLINE fromParser #-} +fromParser :: + (MonadIO m, Unbox a) => ParserD.Parser a m b -> ParserK (Array a) m b +fromParser = Array.toParserK diff --git a/src/Streamly/Data/RingArray.hs b/src/Streamly/Data/RingArray.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/RingArray.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.RingArray +-- Copyright : (c) 2025 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- This module provides APIs to create and use unboxed, mutable ring arrays of +-- fixed size. Ring arrays are useful to keep a circular buffer or a sliding +-- window of elements. +-- +-- RingArrays are of fixed size but there is a way to expand the size of the +-- ring, you can copy the ring to a MutArray, expand the MutArray and the cast +-- it back to RingArray. +-- +-- This module is designed to be imported qualified: +-- +-- >>> import qualified Streamly.Data.RingArray as Ring +-- +-- Please refer to "Streamly.Internal.Data.RingArray" for functions that have +-- not yet been released. +-- + +module Streamly.Data.RingArray + ( RingArray + + -- * Construction + , createOfLast + , castMutArray -- XXX this is unsafeFreeze in Array module + , castMutArrayWith + -- , unsafeCastMutArray + -- , unsafeCastMutArrayWith + + -- * Moving the Head + , moveForward + , moveReverse + -- , moveBy + + -- * In-place Mutation + , insert + , replace + , replace_ + , putIndex + , modifyIndex + + -- * Random Access + , getIndex + , unsafeGetIndex + , unsafeGetHead + + -- * Conversion + , toList + , toMutArray + + -- * Streams + , read + , readRev + + -- * Unfolds + , reader + , readerRev + + -- * Size + , length + , byteLength + + -- * Casting + , cast + -- , unsafeCast + , asBytes + , asMutArray + -- , asMutArray_ + + -- * Folds + -- , foldlM' + , fold + + -- * Stream of Rings + , ringsOf + , scanRingsOf + + -- * Fast Byte Comparisons + , eqArray + , eqArrayN + + ) where + +import Streamly.Internal.Data.RingArray +import Prelude hiding (read, length) diff --git a/src/Streamly/Data/Scanl.hs b/src/Streamly/Data/Scanl.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Scanl.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.Scanl +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- + +module Streamly.Data.Scanl + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Scanl Type + + Scanl -- (..) + + -- * Constructors + , mkScanl + , mkScanlM + , mkScanl1 + , mkScanl1M + , mkScanr + + -- * Scans + -- ** Accumulators + -- | Scans that never terminate, these scans are much like strict left + -- folds. 'mconcat' is the fundamental accumulator. All other accumulators + -- can be expressed in terms of 'mconcat' using a suitable Monoid. Instead + -- of writing scans we could write Monoids and turn them into scans. + + -- Monoids + , sconcat + , mconcat + , foldMap + , foldMapM + + -- Reducers + , drain + -- , drainMapM + , length + , countDistinct + , countDistinctInt + -- , frequency + , sum + , product + , mean + , rollingHash + , rollingHashWithSalt + + -- Collectors + , toList + , toListRev + , toSet + , toIntSet + , topBy + + -- ** Non-Empty Accumulators + -- | Accumulators that do not have a default value, therefore, return + -- 'Nothing' on an empty stream. + , latest + , maximumBy + , maximum + , minimumBy + , minimum + + -- ** Filtering Scanners + -- | Accumulators that are usually run as a scan using the 'potscanlMaybe' + -- combinator. + , findIndices + , elemIndices + , deleteBy + -- , uniq + , uniqBy + , nub + , nubInt + + -- ** Terminating Scans + -- , satisfy + -- , maybe + + , the + + -- * Transformations + -- | Transformations are modifiers of scans. In the type @Scan m a b@, @a@ + -- is the input type and @b@ is the output type. Transformations can be + -- applied either on the input side (contravariant) or on the output side + -- (covariant). Therefore, transformations have one of the following + -- general shapes: + -- + -- * @... -> Scanl m a b -> Scanl m c b@ (input transformation) + -- * @... -> Scanl m a b -> Scanl m a c@ (output transformation) + -- + -- The input side transformations are more interesting for scans. Most of + -- the following sections describe the input transformation operations on a + -- scan. When an operation makes sense on both input and output side we use + -- the prefix @l@ (for left) for input side operations and the prefix @r@ + -- (for right) for output side operations. + + -- ** Mapping on output + -- | The 'Functor' instance of a scan maps on the output of the scan: + -- + -- >>> Stream.toList $ Stream.scanl (fmap show Scanl.sum) (Stream.enumerateFromTo 1 10) + -- ["0","1","3","6","10","15","21","28","36","45","55"] + -- + , rmapM + + -- ** Mapping on Input + , lmap + , lmapM + + -- ** Filtering + , filter + , filterM + + -- -- ** Mapping Filters + , mapMaybe + , catMaybes + , catLefts + , catRights + , catEithers + + -- ** Trimming + , take + , takeEndBy + , takeEndBy_ + + -- ** Key-value Scanners + , classify + , classifyIO + + -- ** Transforming the Monad + , morphInner + + -- * Combinators + -- | Transformations that combine two or more scans. + + -- ** Scanning + , scanl + , postscanl + , postscanlMaybe + + -- ** Parallel Distribution + -- | The 'Applicative' instance distributes the input to both scans. + + , teeWith + --, teeWithFst + --, teeWithMin + , tee + , distribute + + -- ** Partitioning + -- | Direct items in the input stream to different scans using a binary + -- scan selector. + + , partition + --, partitionByM + --, partitionByFstM + --, partitionByMinM + --, partitionBy + + -- ** Unzipping + , unzip + + -- * Dynamic Combinators + -- | The scan to be used is generated dynamically based on the input. + + -- ** Key-value Scanners + , demux + , demuxIO + ) +where + +import Prelude + hiding (Foldable(..), filter, drop, dropWhile, take, takeWhile, zipWith, + map, mapM_, sequence, all, any, + notElem, head, last, tail, + reverse, iterate, init, and, or, lookup, (!!), + scanl, scanl1, replicate, concatMap, mconcat, unzip, + span, splitAt, break, mapM, maybe) + +import Streamly.Internal.Data.Scanl + +#include "DocTestDataScanl.hs" diff --git a/src/Streamly/Data/Stream.hs b/src/Streamly/Data/Stream.hs --- a/src/Streamly/Data/Stream.hs +++ b/src/Streamly/Data/Stream.hs @@ -8,18 +8,130 @@ -- Stability : released -- Portability : GHC -- --- Fast, composable stream producers with ability to terminate, supporting --- stream fusion. +-- The 'Stream' type represents a producer of a sequence of values. Its dual, +-- 'Streamly.Data.Fold.Fold', represents a consumer. While both types support +-- similar transformations, the key difference is that only 'Stream' can +-- compose multiple producers, and only 'Fold' can compose multiple consumers. -- --- Please refer to "Streamly.Internal.Data.Stream" for more functions that have --- not yet been released. +-- == Console Echo Example -- --- For continuation passing style (CPS) stream type, please refer to --- the "Streamly.Data.StreamK" module. +-- To get you started, here is an example of a program which reads lines from +-- console and writes them back to the console. -- --- Checkout the --- repository for many more real world examples of stream programming. +-- >>> import Data.Function ((&)) +-- >>> :{ +-- echo = +-- Stream.repeatM getLine -- Stream IO String +-- & Stream.mapM putStrLn -- Stream IO () +-- & Stream.fold Fold.drain -- IO () +-- :} +-- +-- This is a simple example of a declarative representation of an imperative +-- loop using streaming combinators. +-- In this example, 'repeatM' generates an infinite stream of 'String's by +-- repeatedly performing the 'getLine' IO action. 'mapM' then applies +-- 'putStrLn' on each element in the stream converting it to stream of '()'. +-- Finally, 'Streamly.Data.Fold.drain' 'fold's the stream to IO discarding the +-- () values, thus producing only effects. +-- +-- This gives you an idea about how we can program declaratively by +-- representing loops using streams. Compare this declarative loopless approach +-- with an imperative approach using a @while@ loop for writing the same +-- program. In this module, you can find all "Data.List"-like functions and +-- many more powerful combinators to perform common programming tasks. +-- +-- == Static Stream Fusion +-- +-- The 'Stream' type represents streams as state machines. When composed +-- statically, these state machines fuse together at compile time, eliminating +-- intermediate data structures and function calls. This results in the +-- generation of tight, efficient loops comparable to those written in +-- low-level languages like C. For instance, in the earlier example, operations +-- like 'repeatM' and 'mapM' are written as separate fragments but fuse into a +-- single, optimized loop. +-- +-- The primary goal of the 'Stream' type is to build highly efficient streams +-- via compile-time fusion of modular loop fragments. However, this technique +-- comes with trade-offs and should be used with care. Stream /construction/ +-- operations such as 'cons', 'append', 'interleave', 'mergeBy', and 'zipWith' +-- work extremely well at a small scale. But at a large scale, their +-- performance degrades due to O(n^2) complexity, where @n@ is the number of +-- compositions. +-- +-- Therefore, it's best to generate a fused stream in one go, if possible. +-- While using a small number of composition operations is absolutely fine, +-- avoid using large number of composition operations. For example, do not try +-- to construct a fused 'Stream' by using `cons` rescursively. However, you can +-- use 'Streamly.Data.StreamK.cons' and any other construction operations on +-- the CPS 'StreamK' type without any problem. The CPS construction operations +-- have linear (O(n)) performance characteristics and scale much better, though +-- they are not as efficient as fused streams due to function call overhead at +-- each step. +-- +-- When used correctly, the fused 'Stream' type can be 10x to 100x faster +-- than CPS-based streams, depending on the use case. +-- +-- __Rule of Thumb:__ Use the fused 'Stream' type when the number of +-- compositions is small and they are static or compile-time. Use the CPS-based +-- 'StreamK' type when the number of compositions is large or potentially +-- infinite, and they are dynamic or composed at runtime. Both types are fully +-- interconvertible, allowing you to choose the best tool for each part of your +-- pipeline. +-- +-- == Better and Effectful Lists +-- +-- This module offers operations analogous to standard Haskell lists from the +-- @base@ package. Streams can be viewed as a generalization of lists — +-- providing all the functionality of standard lists, plus additional +-- capabilities such as effectful operations and improved performance through +-- stream fusion. They can easily replace lists in most contexts, and go +-- beyond where lists fall short. +-- +-- For instance, a common limitation of lists is the inability to perform IO +-- actions (e.g., printing) at arbitrary points during processing. Streams +-- naturally support such effectful operations. +-- +-- As discussed in the fusion section above, while the 'Stream' type is not +-- consable and appendable at scale, the 'StreamK' type is consable and +-- appendable at scale. +-- +-- == Non-determinism and List Transformers +-- +-- Streamly does not provide a 'ListT' like Monad instance but it provides all +-- the equivalent functionality and more. We do not provide a Monad instance +-- for streams, as there are many possible ways to define the bind operation. +-- Instead, we offer bind-style operations such as 'concatFor', 'concatForM', +-- and their variants (e.g. fair interleaving and breadth-first nesting). These +-- can be used for convenient ListT-style stream composition. Additionally, we +-- provide applicative-style cross product operations like 'cross' and its +-- variants which are many times faster than the monad style operations. +-- +-- == Logic Programming +-- +-- Streamly does not provide a 'LogicT'-style Monad instance, but it offers all +-- the equivalent functionality—and more. Operations like 'fairCross' and +-- 'fairConcatFor' nest outer and inner streams fairly, ensuring that no stream +-- is starved when exploring cross products. +-- +-- This enables balanced exploration across all dimensions in backtracking +-- problems, while also supporting infinite streams. It effectively replaces the +-- core functionality of 'LogicT' from the @logict@ package, with significantly +-- better performance. In particular, it avoids the quadratic slowdown seen with +-- @observeMany@, and the applicative 'fairCross' runs many times faster, +-- achieving loop nesting performance comparable to C. +-- == Additional Resources +-- +-- The combinators in this module support /serial/ composition of streams. +-- For /concurrent/ composition of streams, refer to +-- "Streamly.Data.Stream.Prelude" in the @streamly@ package. +-- +-- For more, yet unreleased functions, try: "Streamly.Internal.Data.Stream". +-- +-- For real-world examples, visit: +-- . +-- + module Streamly.Data.Stream ( -- * Setup @@ -37,15 +149,19 @@ -- * Construction -- | Functions ending in the general shape @b -> Stream m a@. -- - -- See also: "Streamly.Internal.Data.Stream.Generate" for - -- @Pre-release@ functions. + -- Useful Idioms: + -- + -- >>> fromIndices f = fmap f $ Stream.enumerateFrom 0 + -- >>> fromIndicesM f = Stream.mapM f $ Stream.enumerateFrom 0 + -- >>> fromListM = Stream.sequence . Stream.fromList + -- >>> fromFoldable = StreamK.toStream . StreamK.fromFoldable + -- >>> fromFoldableM = Stream.sequence . fromFoldable -- ** Primitives - -- | Primitives to construct a stream from pure values or monadic actions. - -- All other stream construction and generation combinators described later - -- can be expressed in terms of these primitives. However, the special - -- versions provided in this module can be much more efficient in most - -- cases. Users can create custom combinators using these primitives. + -- | These primitives are meant to statically fuse a small number of stream + -- elements. The 'Stream' type is never constructed at large scale using + -- these primitives. Use 'StreamK' if you need to construct a stream from + -- primitives. , nil , nilM , cons @@ -57,38 +173,38 @@ , unfoldr , unfoldrM - -- ** From Values - -- | Generate a monadic stream from a seed value or values. + -- ** Singleton , fromPure , fromEffect + + -- ** Iteration + -- | Generate a monadic stream from a seed value or values. + -- + , iterate + , iterateM , repeat , repeatM , replicate , replicateM - -- Note: Using enumeration functions e.g. 'Prelude.enumFromThen' turns out - -- to be slightly faster than the idioms like @[from, then..]@. - -- -- ** Enumeration - -- | We can use the 'Enum' type class to enumerate a type producing a list - -- and then convert it to a stream: + -- | 'Enumerable' type class is to streams as 'Enum' is to lists. Enum + -- provides functions to generate a list, Enumerable provides similar + -- functions to generate a stream instead. -- - -- @ - -- 'fromList' $ 'Prelude.enumFromThen' from then - -- @ + -- It is much more efficient to use 'Enumerable' directly than enumerating + -- to a list and converting it to stream. The following works but is not + -- particularly efficient: -- - -- However, this is not particularly efficient. - -- The 'Enumerable' type class provides corresponding functions that - -- generate a stream instead of a list, efficiently. + -- >>> f from next = Stream.fromList $ Prelude.enumFromThen from next + -- + -- Note: For lists, using enumeration functions e.g. 'Prelude.enumFromThen' + -- turns out to be slightly faster than the idioms like @[from, then..]@. , Enumerable (..) , enumerate , enumerateTo - -- ** Iteration - , iterate - , iterateM - -- ** From Containers -- | Convert an input structure, container or source into a stream. All of -- these can be expressed in terms of primitives. @@ -103,8 +219,6 @@ -- | Functions ending in the general shape @Stream m a -> m b@ or @Stream m -- a -> m (b, Stream m a)@ -- - -- See also: "Streamly.Internal.Data.Stream.Eliminate" for @Pre-release@ - -- functions. -- EXPLANATION: In imperative terms a fold can be considered as a loop over the stream -- that reduces the stream to a single value. @@ -192,7 +306,9 @@ -- ** Parsing , parse - -- , parseBreak + , parseBreak + , parsePos + , parseBreakPos -- ** Lazy Right Folds -- | Consuming a stream to build a right associated expression, suitable @@ -203,12 +319,57 @@ -- operations like mapping a function over the stream. , foldrM , foldr + -- foldr1 -- ** Specific Folds - -- | Usually you can use the folds in "Streamly.Data.Fold". However, some - -- folds that may be commonly used or may have an edge in performance in - -- some cases are provided here. - -- , drain + -- | Streams are folded using folds in "Streamly.Data.Fold". Here are some + -- idioms and equivalents of Data.List APIs using folds: + -- + -- >>> foldlM' f a = Stream.fold (Fold.foldlM' f a) + -- >>> foldl1' f = Stream.fold (Fold.foldl1' f) + -- >>> foldl' f a = Stream.fold (Fold.foldl' f a) + -- >>> drain = Stream.fold Fold.drain + -- >>> mapM_ f = Stream.fold (Fold.drainMapM f) + -- >>> length = Stream.fold Fold.length + -- >>> genericLength = Stream.fold Fold.genericLength + -- >>> head = Stream.fold Fold.one + -- >>> last = Stream.fold Fold.latest + -- >>> null = Stream.fold Fold.null + -- >>> and = Stream.fold Fold.and + -- >>> or = Stream.fold Fold.or + -- >>> any p = Stream.fold (Fold.any p) + -- >>> all p = Stream.fold (Fold.all p) + -- >>> sum = Stream.fold Fold.sum + -- >>> product = Stream.fold Fold.product + -- >>> maximum = Stream.fold Fold.maximum + -- >>> maximumBy cmp = Stream.fold (Fold.maximumBy cmp) + -- >>> minimum = Stream.fold Fold.minimum + -- >>> minimumBy cmp = Stream.fold (Fold.minimumBy cmp) + -- >>> elem x = Stream.fold (Fold.elem x) + -- >>> notElem x = Stream.fold (Fold.notElem x) + -- >>> lookup x = Stream.fold (Fold.lookup x) + -- >>> find p = Stream.fold (Fold.find p) + -- >>> (!?) i = Stream.fold (Fold.index i) + -- >>> genericIndex i = Stream.fold (Fold.genericIndex i) + -- >>> elemIndex x = Stream.fold (Fold.elemIndex x) + -- >>> findIndex p = Stream.fold (Fold.findIndex p) + -- + -- Some equivalents of Data.List APIs from the Stream module: + -- + -- >>> head = fmap (fmap fst) . Stream.uncons + -- >>> tail = fmap (fmap snd) . Stream.uncons + -- >>> tail = Stream.tail -- unreleased API + -- >>> init = Stream.init -- unreleased API + -- + -- A Stream based toList fold implementation is provided below because it + -- has a better performance compared to the fold. + + -- Functions in Data.List, missing here: + -- unsnoc = Stream.parseBreak (Parser.init Fold.toList) + -- genericTake + -- genericDrop + -- genericSplitAt + -- genericReplicate , toList -- * Mapping @@ -236,8 +397,6 @@ -- * Scanning -- | Stateful one-to-one transformations. -- - -- See also: "Streamly.Internal.Data.Stream.Transform" for - -- @Pre-release@ functions. {- -- ** Left scans @@ -252,10 +411,27 @@ , scanl1M' -} - -- ** Scanning By 'Fold' - , scan - , postscan + -- ** Scanning By 'Scanl' + -- | Useful idioms: + -- + -- >>> scanl' f z = Stream.scanl (Scanl.mkScanl f z) + -- >>> scanlM' f z = Stream.scanl (Scanl.mkScanlM f z) + -- >>> postscanl' f z = Stream.postscanl (Scanl.mkScanl f z) + -- >>> postscanlM' f z = Stream.postscanl (Scanl.mkScanlM f z) + -- >>> scanl1' f = Stream.catMaybes . Stream.scanl (Scanl.mkScanl1 f) + -- >>> scanl1M' f = Stream.catMaybes . Stream.scanl (Scanl.mkScanl1M f) + , scanl + , postscanl -- XXX postscan1 can be implemented using Monoids or Refolds. + -- The following scans from Data.List are not provided. + -- XXX scanl + -- XXX scanl1 + -- XXX scanr + -- XXX scanr1 + -- XXX mapAccumL + -- XXX mapAccumR + -- XXX inits + -- XXX tails -- ** Specific scans -- Indexing can be considered as a special type of zipping where we zip a @@ -264,6 +440,8 @@ -- * Insertion -- | Add elements to the stream. + -- + -- >>> insert = Stream.insertBy compare -- Inserting elements is a special case of interleaving/merging streams. , insertBy @@ -294,17 +472,33 @@ , catEithers -- ** Stateful Filters - -- | 'scanMaybe' is the most general stateful filtering operation. The + + -- XXX Should use scanr instead of scanlMaybe for filtering. + + -- 'scanMaybe' is the most general stateful filtering operation. The -- filtering folds (folds returning a 'Maybe' type) in -- "Streamly.Internal.Data.Fold" can be used along with 'scanMaybe' to -- perform stateful filtering operations in general. - , scanMaybe + -- + -- Idioms and equivalents of Data.List APIs: + -- + -- >>> deleteBy cmp x = Stream.scanMaybe (Fold.deleteBy cmp x) + -- >>> deleteBy = Stream.deleteBy -- unreleased API + -- >>> delete = deleteBy (==) + -- >>> findIndices p = Stream.scanMaybe (Fold.findIndices p) + -- >>> elemIndices a = findIndices (== a) + -- >>> uniq = Stream.scanMaybe (Fold.uniqBy (==)) + -- >>> partition p = Stream.fold (Fold.partition Fold.toList Fold.toList) . fmap (if p then Left else Right) + -- >>> takeLast n s = Stream.fromEffect $ fmap Array.read $ Array.createOfLast n s + -- , scanlMaybe , take , takeWhile , takeWhileM , drop , dropWhile , dropWhileM + -- XXX write to an array in reverse and then read in reverse + -- > dropWhileEnd = reverse . dropWhile p . reverse -- XXX These are available as scans in folds. We need to check the -- performance though. If these are common and we need convenient stream @@ -326,34 +520,42 @@ -- , elemIndices -- * Combining Two Streams + -- | Note that these operations are suitable for statically fusing a few + -- streams, they have a quadratic O(n^2) time complexity wrt to the number + -- of streams. If you want to compose many streams dynamically using binary + -- combining operations see the corresponding operations in + -- "Streamly.Data.StreamK". + -- + -- When fusing more than two streams it is more efficient if the binary + -- operations are composed as a balanced tree rather than a right + -- associative or left associative one e.g.: + -- + -- >>> s1 = Stream.fromList [1,2] `Stream.append` Stream.fromList [3,4] + -- >>> s2 = Stream.fromList [4,5] `Stream.append` Stream.fromList [6,7] + -- >>> s = s1 `Stream.append` s2 + -- ** Appending + -- | Equivalent of Data.List append: + -- + -- >>> (++) = Stream.append , append -- ** Interleaving - -- | When interleaving more than two streams you may want to interleave - -- them pairwise creating a balanced binary merge tree. , interleave -- ** Merging - -- | When merging more than two streams you may want to merging them - -- pairwise creating a balanced binary merge tree. - -- - -- Merging of @n@ streams can be performed by combining the streams pair - -- wise using 'mergeMapWith' to give O(n * log n) time complexity. If used - -- with 'concatMapWith' it will have O(n^2) performance. - , mergeBy , mergeByM -- ** Zipping - -- | When zipping more than two streams you may want to zip them - -- pairwise creating a balanced binary tree. + -- | Idioms and equivalents of Data.List APIs: -- - -- Zipping of @n@ streams can be performed by combining the streams pair - -- wise using 'mergeMapWith' with O(n * log n) time complexity. If used - -- with 'concatMapWith' it will have O(n^2) performance. + -- >>> zip = Stream.zipWith (,) + -- >>> unzip = Stream.fold (Fold.unzip Fold.toList Fold.toList) , zipWith , zipWithM + -- XXX zipWith3,4,5,6,7 + -- XXX unzip3,4,5,6,7 -- , ZipStream (..) -- ** Cross Product @@ -364,86 +566,189 @@ -- transformed stream at the end we can have a flipped version called -- "crossMap" or "nestWith". , crossWith - -- , cross + , cross + -- , fairCrossWith + , fairCross -- , joinInner -- , CrossStream (..) -- * Unfold Each - , unfoldMany - , intercalate - , intercalateSuffix + -- Idioms and equivalents of Data.List APIs: + -- + -- >>> cycle = Stream.unfoldEach Unfold.fromList . Stream.repeat + -- >>> unlines = Stream.unfoldEachEndBy '\n' + -- >>> unwords = Stream.unfoldEachSepBy ' ' + -- >>> unlines = Stream.unfoldEachEndBySeq "\n" Unfold.fromList + -- >>> unwords = Stream.unfoldEachSepBySeq " " Unfold.fromList + -- + , unfoldEach + , bfsUnfoldEach + , fairUnfoldEach + , unfoldEachSepBySeq + , unfoldEachEndBySeq -- * Stream of streams - -- | Stream operations like map and filter represent loop processing in + -- | Stream operations like map and filter represent loops in -- imperative programming terms. Similarly, the imperative concept of -- nested loops are represented by streams of streams. The 'concatMap' -- operation represents nested looping. - -- A 'concatMap' operation loops over the input stream and then for each - -- element of the input stream generates another stream and then loops over - -- that inner stream as well producing effects and generating a single - -- output stream. -- - -- One dimension loops are just a special case of nested loops. For - -- example, 'concatMap' can degenerate to a simple map operation: + -- A 'concatMap' operation loops over the input stream (outer loop), + -- generating a stream from each element of the stream. Then it loops over + -- each element of the generated streams (inner loop), collecting them in a + -- single output stream. -- - -- > map f m = S.concatMap (\x -> S.fromPure (f x)) m + -- One dimension loops are just a special case of nested loops. For + -- example map and filter can be expressed using concatMap: -- - -- Similarly, 'concatMap' can perform filtering by mapping an element to a - -- 'nil' stream: + -- >>> map f = Stream.concatMap (Stream.fromPure . f) + -- >>> filter p = Stream.concatMap (\x -> if p x then Stream.fromPure x else Stream.nil) -- - -- > filter p m = S.concatMap (\x -> if p x then S.fromPure x else S.nil) m + -- Idioms and equivalents of Data.List APIs: -- + -- >>> concat = Stream.concatMap id + -- >>> cycle = Stream.concatMap Stream.fromList . Stream.repeat , concatEffect , concatMap , concatMapM + -- , bfsConcatMap + , fairConcatMap + , concatFor + -- , bfsConcatFor + , fairConcatFor + + , concatForM + -- , bfsConcatForM + , fairConcatForM + -- * Repeated Fold - , foldMany -- XXX Rename to foldRepeat + -- | Idioms and equivalents of Data.List APIs: + -- + -- >>> groupsOf n = Stream.foldMany (Fold.take n Fold.toList) + -- >>> groupBy eq = Stream.groupsWhile eq Fold.toList + -- >>> groupBy eq = Stream.parseMany (Parser.groupBy eq Fold.toList) + -- >>> groupsByRolling eq = Stream.parseMany (Parser.groupByRolling eq Fold.toList) + -- >>> groups = groupBy (==) + , foldMany + , groupsOf , parseMany - , Array.chunksOf + -- * Splitting + -- | Idioms and equivalents of Data.List APIs: + -- + -- >>> splitEndBy p f = Stream.foldMany (Fold.takeEndBy p f) + -- >>> splitEndBy_ p f = Stream.foldMany (Fold.takeEndBy_ p f) + -- >>> lines = splitEndBy_ (== '\n') + -- >>> words = Stream.wordsBy isSpace + -- >>> splitAt n = Stream.fold (Fold.splitAt n Fold.toList Fold.toList) + -- >>> span p = Parser.splitWith (,) (Parser.takeWhile p Fold.toList) (Parser.fromFold Fold.toList) + -- >>> break p = span (not . p) + , splitSepBy_ + , splitSepBySeq_ + , splitEndBySeq + , splitEndBySeq_ + , wordsBy + + -- XXX Should use scanr instead + -- >>> nub = Stream.fold Fold.toList . Stream.scanMaybe Fold.nub + -- * Buffered Operations -- | Operations that require buffering of the stream. -- Reverse is essentially a left fold followed by an unfold. + -- + -- Idioms and equivalents of Data.List APIs: + -- + -- >>> nub = Stream.ordNub -- unreleased API + -- >>> sortBy = StreamK.sortBy + -- >>> sortOn f = StreamK.sortOn -- unreleased API + -- >>> deleteFirstsBy = Stream.deleteFirstsBy -- unreleased + -- >>> (\\) = Stream.deleteFirstsBy (==) -- unreleased + -- >>> intersectBy = Stream.intersectBy -- unreleased + -- >>> intersect = Stream.intersectBy (==) -- unreleased + -- >>> unionBy = Stream.unionBy -- unreleased + -- >>> union = Stream.unionBy (==) -- unreleased + -- , reverse + , unionBy + -- XXX transpose: write the streams to arrays and then stream transposed. + -- XXX subsequences + -- XXX permutations + -- , nub + -- , ordNub + -- , nubBy -- * Multi-Stream folds -- | Operations that consume multiple streams at the same time. , eqBy , cmpBy , isPrefixOf + , isInfixOf + -- , isSuffixOf + -- , isSuffixOfUnbox , isSubsequenceOf -- trimming sequences , stripPrefix + -- , stripSuffix + -- , stripSuffixUnbox -- Exceptions and resource management depend on the "exceptions" package -- XXX We can have IO Stream operations not depending on "exceptions" -- in Exception.Base -- * Exceptions - -- | Most of these combinators inhibit stream fusion, therefore, when + -- | __Scope__: Note that the stream exception handling routines + -- (catch and handle) observe exceptions only in the stream segment (i.e. + -- functions with the 'Stream' type) of the pipeline and not in the + -- consumer segments (i.e. functions with 'Fold' or 'Parser' types). For + -- example, if we are folding or parsing a stream - any exceptions in the + -- fold or parser code won't be observed by the stream exception handlers. + -- + -- Exceptions in the fold code can be handled using similar exception + -- handling routines found in the "Streamly.Data.Fold" module. To observe + -- exceptions in the entire pipeline, you can wrap the stream elimination + -- effect itself in a monad level exception handler (e.g. @Stream.fold + -- Fold.drain `catch` ...@). + -- + -- Most of these combinators inhibit stream fusion, therefore, when -- possible, they should be called in an outer loop to mitigate the cost. -- For example, instead of calling them on a stream of chars call them on a -- stream of arrays before flattening it to a stream of chars. -- - -- See also: "Streamly.Internal.Data.Stream.Exception" for - -- @Pre-release@ functions. - , onException , handle -- * Resource Management -- | 'bracket' is the most general resource management operation, all other - -- operations can be expressed using it. These functions have IO suffix - -- because the allocation and cleanup functions are IO actions. For - -- generalized allocation and cleanup functions see the functions without - -- the IO suffix in the "streamly" package. + -- resource management operations can be expressed using it. These + -- functions have IO suffix because the allocation and cleanup functions + -- are IO actions. For generalized allocation and cleanup functions, see + -- the functions without the IO suffix in the @streamly@ package. + -- + -- __Scope__: Note that these operations bracket only the stream-segment in + -- a pipeline, they do not cover the stream-consumer (e.g. folds). This + -- means that if an exception occurs in the consumer of the stream (e.g. in a + -- fold or parser driven by the stream) then the exception won't be + -- observed by the stream resource handlers, in such cases the resource + -- stream cleanup handler runs when the stream is garbage collected. + -- + -- To observe exceptions in the entire pipline, put a monad level resource + -- bracket around the stream elimination effect (e.g. around @(Stream.fold + -- Fold.sum)@). + -- + -- See also the "Streamly.Control.Exception" module for general + -- resource management operations in non-stream as well as stream code. , before , afterIO , finallyIO + , finallyIO' + , finallyIO'' , bracketIO + -- XXX Expose the Control.Exception module as well. + , bracketIO' + , bracketIO'' , bracketIO3 -- * Transforming Inner Monad @@ -453,129 +758,33 @@ , runReaderT , runStateT - -- -- * Stream Types - -- $serial - -- , Interleave - -- , Zip + -- * Deprecated + , scan + , scanMaybe + , postscan + , splitOn + , unfoldMany + , intercalate + , intercalateSuffix + , chunksOf ) where -import qualified Streamly.Internal.Data.Array.Type as Array -import Streamly.Internal.Data.Stream.StreamD +import Streamly.Internal.Data.Stream import Prelude hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr, - foldl, map, mapM, mapM_, sequence, all, any, sum, product, elem, - notElem, maximum, minimum, head, last, tail, length, null, - reverse, iterate, init, and, or, lookup, foldr1, (!!), - scanl, scanl1, repeat, replicate, concatMap, span) + mapM, scanl, sequence, reverse, iterate, foldr1, repeat, replicate, + concatMap) +import Streamly.Internal.Data.Unbox (Unbox(..)) +import Control.Monad.IO.Class (MonadIO(..)) + +import qualified Streamly.Internal.Data.Array.Type as Array + #include "DocTestDataStream.hs" --- $overview --- --- Streamly is a framework for modular data flow based programming and --- declarative concurrency. Powerful stream fusion framework in streamly --- allows high performance combinatorial programming even when using byte level --- streams. Streamly API is similar to Haskell lists. --- --- == Console Echo Example --- --- In the following example, 'repeatM' generates an infinite stream of 'String' --- by repeatedly performing the 'getLine' IO action. 'mapM' then applies --- 'putStrLn' on each element in the stream converting it to stream of '()'. --- Finally, 'drain' folds the stream to IO discarding the () values, thus --- producing only effects. --- --- >>> import Data.Function ((&)) --- --- >>> :{ --- echo = --- Stream.repeatM getLine -- Stream IO String --- & Stream.mapM putStrLn -- Stream IO () --- & Stream.fold Fold.drain -- IO () --- :} --- --- This is a console echo program. It is an example of a declarative loop --- written using streaming combinators. Compare it with an imperative @while@ --- loop. --- --- Hopefully, this gives you an idea how we can program declaratively by --- representing loops using streams. In this module, you can find all --- "Data.List" like functions and many more powerful combinators to perform --- common programming tasks. --- --- == Stream Fusion --- --- The fused 'Stream' type employs stream fusion for C-like performance when --- looping over data. It represents a stream source or transformation by --- defining a state machine with explicit state, and a step function working on --- the state. A typical stream operation consumes elements from the previous --- state machine in the pipeline, transforms them and yields new values for the --- next stage to consume. The stream operations are modular and represent a --- single task, they have no knowledge of previous or next operation on the --- elements. --- --- A typical stream pipeline consists of a stream producer, several stream --- transformation operations and a stream consumer. All these operations taken --- together form a closed loop processing the stream elements. Elements are --- transferred between stages using a boxed data constructor. However, all the --- stages of the pipeline are fused together by GHC, eliminating the --- intermediate constructors, and thus forming a tight C like loop without any --- boxed data being used in the loop. --- --- Stream fusion works effectively when: --- --- * the stream pipeline is composed statically (known at compile time) --- * all the operations forming the loop are inlined --- * the loop is not recursively defined, recursion breaks inlining --- --- If these conditions cannot be met, the CPS style stream type 'StreamK' may --- turn out to be a better choice than the fused stream type 'Stream'. --- --- == Stream vs StreamK --- --- The fused stream model avoids constructor allocations or function call --- overheads. However, the stream is represented as a state machine and to --- generate elements it has to navigate the decision tree of the state machine. --- Moreover, the state machine is cranked for each element in the stream. This --- performs extremely well when the number of states are limited. The state --- machine starts getting expensive as the number of states increase. For --- example, generating a million element stream from a list requires a single --- state and is very efficient. However, using fused 'cons' to generate a --- million element stream would be a disaster. --- --- A typical worst case scenario for fused stream model is a large number of --- `cons` or `append` operations. A few static `cons` or `append` operations --- are very fast and much faster than a CPS style stream. However, if we --- construct a large stream using `cons` it introduces as many states in the --- state machine as the number of elements. If we compose the `cons` as a --- binary tree it will take @n * log n@ time to navigate the tree, and @n * n@ --- if it is a right associative composition. --- --- For quadratic cases of fused stream, after a certain threshold the CPS --- stream would perform much better and exhibit linear performance behavior. --- Operations like 'cons' or 'append'; are typically recursively called to --- construct a lazy infinite stream. For such use cases the CPS style 'StreamK' --- type is provided. CPS streams do not have a state machine that needs to be --- cranked for each element, past state has no effect on the future element --- processing. However, it incurs a function call overhead for each operation --- for each element, which could be very large overhead compared to fused state --- machines even if it has many states and cranks it for each element. But in --- some cases scales tip in favor of the CPS stream. In those cases even though --- CPS has a large constant overhead, it has a linear performance rather than --- quadratic. --- --- As a general guideline, if you have to use 'cons' or 'append' or operations --- of similar nature, at a large scale, then 'StreamK' should be used. When you --- need to compose the stream dynamically or recursively, then 'StreamK' should --- be used. Typically you would use a dynamically generated 'StreamK' with --- chunks of data which can then be processed by statically fused stream --- pipeline operations. --- --- 'Stream' and 'StreamK' types can be interconverted. See --- "Streamly.Data.StreamK" module for conversion operations. --- --- == Useful Idioms --- --- >>> fromListM = Stream.sequence . Stream.fromList --- >>> fromIndices f = fmap f $ Stream.enumerateFrom 0 +{-# DEPRECATED chunksOf "Please use chunksOf from the Array module instead." #-} +{-# INLINE chunksOf #-} +chunksOf :: forall m a. (MonadIO m, Unbox a) + => Int -> Stream m a -> Stream m (Array.Array a) +chunksOf = Array.chunksOf diff --git a/src/Streamly/Data/Stream/Zip.hs b/src/Streamly/Data/Stream/Zip.hs deleted file mode 100644 --- a/src/Streamly/Data/Stream/Zip.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | --- Module : Streamly.Data.Stream.Zip --- Copyright : (c) 2017 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : released --- Portability : GHC --- -module Streamly.Data.Stream.Zip - ( - ZipStream (..) - ) -where - -import Streamly.Internal.Data.Stream.Zip diff --git a/src/Streamly/Data/StreamK.hs b/src/Streamly/Data/StreamK.hs --- a/src/Streamly/Data/StreamK.hs +++ b/src/Streamly/Data/StreamK.hs @@ -8,12 +8,57 @@ -- Stability : released -- Portability : GHC -- --- Streams using Continuation Passing Style (CPS). See the @Stream vs StreamK@ --- section in the "Streamly.Data.Stream" module to know when to use this --- module. +-- Streams represented as chains of function calls using Continuation Passing +-- Style (CPS), suitable for dynamically and recursively composing potentially +-- large number of streams. The 'K' in 'StreamK' stands for Kontinuation. -- --- Please refer to "Streamly.Internal.Data.Stream.StreamK" for more functions --- that have not yet been released. +-- In addition to the combinators in this module, you can use operations from +-- "Streamly.Data.Stream" for StreamK as well by converting StreamK to Stream +-- ('toStream'), and vice-versa ('fromStream'). Please refer to +-- "Streamly.Internal.Data.StreamK" for more functions that have not yet been +-- released. +-- +-- For documentation see the corresponding combinators in +-- "Streamly.Data.Stream". Documentation has been omitted in this module unless +-- there is a difference worth mentioning or if the combinator does not exist +-- in "Streamly.Data.Stream". +-- +-- == Fused vs CPS Streams +-- +-- Unlike the statically fused operations in "Streamly.Data.Stream", StreamK +-- operations are less efficient, involving a function call overhead for each +-- element, but they exhibit linear O(n) time complexity wrt to the number of +-- stream compositions. Therefore, they are suitable for dynamically composing +-- streams e.g. appending potentially infinite streams in recursive loops. +-- While fused streams can be used efficiently to process elements as small as +-- a single byte, CPS streams are typically used on bigger chunks of data to +-- avoid the larger overhead per element. +-- +-- = Overview +-- +-- StreamK can be constructed like lists, except that they use 'nil' instead of +-- '[]' and 'cons' instead of ':'. +-- +-- >>> import Streamly.Data.StreamK (StreamK, cons, consM, nil) +-- +-- `cons` constructs a stream from pure values: +-- +-- >>> stream = 1 `cons` 2 `cons` nil :: StreamK IO Int +-- +-- Operations from "Streamly.Data.Stream" can be used for StreamK as well by +-- converting StreamK to Stream ('toStream'), and vice-versa ('fromStream'). +-- +-- >>> Stream.fold Fold.toList $ StreamK.toStream stream -- IO [Int] +-- [1,2] +-- +-- Stream can also be constructed from effects not just pure values: +-- +-- >>> effect n = print n >> return n +-- >>> stream = effect 1 `consM` effect 2 `consM` nil +-- >>> Stream.fold Fold.toList $ StreamK.toStream stream +-- 1 +-- 2 +-- [1,2] -- Notes: -- @@ -36,14 +81,21 @@ -- -- $setup - -- * Overview - -- $overview - -- * Type StreamK + -- -- * Nested + -- -- | List transformers and logic programming monads. + -- , Nested(..) -- need to decide on mtl instances + -- , FairNested(..) -- bind is not associative + -- * Construction -- ** Primitives + -- | Primitives to construct a stream from pure values or monadic actions. + -- All other stream construction and generation combinators described later + -- can be expressed in terms of these primitives. However, the special + -- versions provided in this module can be much more efficient in some + -- cases. Users can create custom combinators using these primitives. , nil , nilM , cons @@ -54,12 +106,17 @@ , fromEffect -- ** From Stream + -- | Please note that 'Stream' type does not observe any exceptions from + -- the consumer of the stream whereas 'StreamK' does. , fromStream , toStream -- ** From Containers , fromFoldable + -- ** To Containers + , toList + -- * Elimination -- ** Primitives @@ -70,16 +127,24 @@ -- , foldBreak -- ** Parsing - -- , parseBreak - , parseBreakChunks - , parseChunks + , toParserK + , parse + , parseBreak + , parsePos + , parseBreakPos -- * Transformation , mapM , dropWhile , take + , filter -- * Combining Two Streams + -- | Unlike the operations in "Streamly.Data.Stream", these operations can + -- be used to dynamically compose large number of streams e.g. using the + -- 'concatMapWith' and 'mergeMapWith' operations. They have a linear O(n) + -- time complexity wrt to the number of streams being composed. + -- ** Appending , append @@ -103,51 +168,50 @@ -- , CrossStreamK (..) -- * Stream of streams + -- | Some useful idioms: + -- + -- >>> concatFoldableWith f = Prelude.foldr f StreamK.nil + -- >>> concatMapFoldableWith f g = Prelude.foldr (f . g) StreamK.nil + -- >>> concatForFoldableWith f xs g = Prelude.foldr (f . g) StreamK.nil xs + -- , concatEffect - -- , concatMap + , concatMap + , bfsConcatMap + , fairConcatMap , concatMapWith + + , concatFor + , bfsConcatFor + , fairConcatFor + + , concatForM + , bfsConcatForM + , fairConcatForM + , mergeMapWith -- * Buffered Operations , reverse , sortBy + + -- * Exceptions + -- | Please note that 'Stream' type does not observe any exceptions from + -- the consumer of the stream whereas 'StreamK' does. + , handle + + -- * Resource Management + -- | Please note that 'Stream' type does not observe any exceptions from + -- the consumer of the stream whereas 'StreamK' does. + , bracketIO + + -- * Deprecated + , parseBreakChunks + , parseChunks ) where -import Streamly.Internal.Data.Stream.StreamK -import Prelude hiding (reverse, zipWith, mapM, dropWhile, take) +import Streamly.Internal.Data.StreamK +import Prelude hiding + (reverse, zipWith, mapM, dropWhile, take, filter, concatMap) #include "DocTestDataStreamK.hs" - --- $overview --- --- Continuation passing style (CPS) stream implementation. The 'K' in 'StreamK' --- stands for Kontinuation. --- --- StreamK can be constructed like lists, except that they use 'nil' instead of --- '[]' and 'cons' instead of ':'. --- --- `cons` adds a pure value at the head of the stream: --- --- >>> import Streamly.Data.StreamK (StreamK, cons, consM, nil) --- >>> stream = 1 `cons` 2 `cons` nil :: StreamK IO Int --- --- You can use operations from "Streamly.Data.Stream" for StreamK as well by --- converting StreamK to Stream ('toStream'), and vice-versa ('fromStream'). --- --- >>> Stream.fold Fold.toList $ StreamK.toStream stream -- IO [Int] --- [1,2] --- --- `consM` adds an effect at the head of the stream: --- --- >>> stream = effect 1 `consM` effect 2 `consM` nil --- >>> Stream.fold Fold.toList $ StreamK.toStream stream --- 1 --- 2 --- [1,2] --- --- == Exception Handling --- --- There are no native exception handling operations in the StreamK module, --- please convert to 'Stream' type and use exception handling operations from --- "Streamly.Data.Stream". diff --git a/src/Streamly/Data/Unfold.hs b/src/Streamly/Data/Unfold.hs --- a/src/Streamly/Data/Unfold.hs +++ b/src/Streamly/Data/Unfold.hs @@ -11,7 +11,7 @@ -- Fast, composable stream producers with ability to terminate, supporting -- nested stream fusion. Nested stream operations like -- 'Streamly.Data.Stream.concatMap' in the "Streamly.Data.Stream" module do not --- fuse, however, the 'Streamly.Data.Stream.unfoldMany' operation, using the +-- fuse, however, the 'Streamly.Data.Stream.unfoldEach' operation, using the -- 'Unfold' type, is a fully fusible alternative to -- 'Streamly.Data.Stream.concatMap'. -- @@ -53,6 +53,9 @@ , replicateM , iterateM + -- ** Enumeration + , Enumerable (..) + -- ** From Containers , fromList , fromListM @@ -62,6 +65,9 @@ -- ** Mapping on Input , lmap , lmapM + , first + , second + , carry -- ** Mapping on Output , mapM @@ -83,6 +89,9 @@ , crossWith -- ** Nesting + , unfoldEach + + -- * Deprecated , many ) diff --git a/src/Streamly/FileSystem/Dir.hs b/src/Streamly/FileSystem/Dir.hs --- a/src/Streamly/FileSystem/Dir.hs +++ b/src/Streamly/FileSystem/Dir.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.FileSystem.Dir -- Copyright : (c) 2018 Composewell Technologies @@ -12,6 +13,7 @@ -- something else. module Streamly.FileSystem.Dir +{-# DEPRECATED "Please use \"Streamly.FileSystem.DirIO\" instead." #-} ( -- * Streams read diff --git a/src/Streamly/FileSystem/DirIO.hs b/src/Streamly/FileSystem/DirIO.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/FileSystem/DirIO.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Streamly.FileSystem.DirIO +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : pre-release +-- Portability : GHC +-- +-- High performance and streaming APIs for reading directories. +-- +-- File system paths are specified using the 'Streamly.FileSystem.Path.Path' +-- type. If you want to convert between 'String' or 'FilePath' and 'Path' use +-- 'Streamly.FileSystem.Path.fromString_', 'Streamly.FileSystem.Path.toString' +-- from the "Streamly.FileSystem.Path" module.. +-- +-- >>> import qualified Streamly.FileSystem.DirIO as Dir +-- + +module Streamly.FileSystem.DirIO + ( + -- * Configuration +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + -- | Only the default ReadOptions are supported for Windows. Please use "id" + -- as the configuration modifier. + ReadOptions +#else + ReadOptions + , followSymlinks + , ignoreMissing + , ignoreSymlinkLoops + , ignoreInaccessible +#endif + -- * Streams + , read + , readEither + ) +where + +import Streamly.Internal.FileSystem.DirIO +import Prelude hiding (read) diff --git a/src/Streamly/FileSystem/File.hs b/src/Streamly/FileSystem/File.hs --- a/src/Streamly/FileSystem/File.hs +++ b/src/Streamly/FileSystem/File.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.FileSystem.File -- Copyright : (c) 2019 Composewell Technologies @@ -19,9 +21,10 @@ -- the handle based APIs as there is no possibility of a file descriptor -- leakage. -- --- >>> import qualified Streamly.FileSystem.File as File +-- >> import qualified Streamly.FileSystem.File as File -- module Streamly.FileSystem.File +{-# DEPRECATED "Please use \"Streamly.FileSystem.FileIO\" instead." #-} ( -- * Streaming IO -- | Stream data to or from a file or device sequentially. When reading, diff --git a/src/Streamly/FileSystem/FileIO.hs b/src/Streamly/FileSystem/FileIO.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/FileSystem/FileIO.hs @@ -0,0 +1,67 @@ +-- | +-- Module : Streamly.FileSystem.FileIO +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : pre-release +-- Portability : GHC +-- +-- Read and write streams and arrays to and from files specified by their paths +-- in the file system. These APIs open the file handle, perform the requested +-- operation and close the handle. These are higher level and safer compared to +-- the handle based APIs as there is no possibility of a file descriptor +-- leakage. +-- +-- Files are always opened in: +-- +-- * __Binary mode__ — encoding, decoding, and newline translation should be +-- handled explicitly by the streaming APIs. +-- * __Unbuffered mode__ — buffering can be managed explicitly via streaming +-- APIs. +-- +-- File system paths are specified using the 'Streamly.FileSystem.Path.Path' +-- type. If you want to convert between 'String' or 'FilePath' and 'Path' use +-- 'Streamly.FileSystem.Path.fromString_', 'Streamly.FileSystem.Path.toString' +-- from the "Streamly.FileSystem.Path" module.. +-- +-- >> import qualified Streamly.FileSystem.FileIO as File +-- +module Streamly.FileSystem.FileIO + ( + -- * Streaming IO + -- | Stream data to or from a file or device sequentially. When reading, + -- the stream is lazy and generated on-demand as the consumer consumes it. + -- Read IO requests to the IO device are performed in chunks limited to a + -- maximum size of 32KiB, this is referred to as @defaultChunkSize@ in the + -- documentation. One IO request may or may not read the full + -- chunk. If the whole stream is not consumed, it is possible that we may + -- read slightly more from the IO device than what the consumer needed. + -- When writing, unless specified otherwise in the API, writes are + -- collected into chunks of @defaultChunkSize@ before they are written to + -- the IO device. + + -- Streaming APIs work for all kind of devices, seekable or non-seekable; + -- including disks, files, memory devices, terminals, pipes, sockets and + -- fifos. While random access APIs work only for files or devices that have + -- random access or seek capability for example disks, memory devices. + -- Devices like terminals, pipes, sockets and fifos do not have random + -- access capability. + + -- ** File IO Using Handle + withFile + + -- ** Streams + , read + , readChunksWith + , readChunks + + -- ** Folds + , write + , writeWith + , writeChunks + ) +where + +import Streamly.Internal.FileSystem.FileIO +import Prelude hiding (read) diff --git a/src/Streamly/FileSystem/Handle.hs b/src/Streamly/FileSystem/Handle.hs --- a/src/Streamly/FileSystem/Handle.hs +++ b/src/Streamly/FileSystem/Handle.hs @@ -1,4 +1,4 @@ -#include "inline.hs" +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.FileSystem.Handle @@ -14,7 +14,11 @@ -- Read and write byte streams and array streams to and from file handles -- ('Handle'). -- --- The 'TextEncoding', 'NewLineMode', and 'Buffering' options of the underlying +-- Please set NoBuffering mode on the handle as buffering is explicitly +-- controlled by the streaming API and double buffering can sometimes cause +-- unexpected results. +-- +-- Also note that the 'TextEncoding', 'NewLineMode' options of the underlying -- GHC 'Handle' are ignored by these APIs. Please use "Streamly.Unicode.Stream" -- module for encoding and decoding a byte stream, use stream splitting -- operations in "Streamly.Data.Stream" to create a stream of lines or to split @@ -40,6 +44,12 @@ -- module Streamly.FileSystem.Handle ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + -- * Singleton IO -- | Read or write a single buffer. getChunk @@ -75,13 +85,13 @@ -- position of the file handle. The stream ends as soon as EOF is -- encountered. - -- -- *** Streams - -- , read - -- , readWith - -- , readChunks - -- , readChunksWith + -- *** Streams + , read + , readWith + , readChunks + , readChunksWith - -- -- *** Unfolds + -- *** Unfolds , reader , readerWith , chunkReader @@ -98,34 +108,14 @@ , writeChunks -- * Deprecated - , read , readWithBufferOf - , readChunks , readChunksWithBufferOf , writeChunksWithBufferOf , writeWithBufferOf ) where -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Word (Word8) -import Streamly.Internal.Data.Array.Type (Array) -import Streamly.Internal.Data.Unfold.Type (Unfold) -import System.IO (Handle) - -import Streamly.Internal.FileSystem.Handle hiding (read, readChunks) +import Streamly.Internal.FileSystem.Handle import Prelude hiding (read) --- | Same as 'reader' --- -{-# DEPRECATED read "Please use 'reader' instead" #-} -{-# INLINE read #-} -read :: MonadIO m => Unfold m Handle Word8 -read = reader - --- | Same as 'chunkReader' --- -{-# DEPRECATED readChunks "Please use 'chunkReader' instead" #-} -{-# INLINE readChunks #-} -readChunks :: MonadIO m => Unfold m Handle (Array Word8) -readChunks = chunkReader +#include "DocTestFileSystemHandle.hs" diff --git a/src/Streamly/FileSystem/Path.hs b/src/Streamly/FileSystem/Path.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/FileSystem/Path.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.FileSystem.Path +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- File system paths that are extensible, high-performance and preserve the OS +-- and filesystem encoding. +-- +-- The 'Path' type is built on top of Streamly's 'Array' type, leveraging all +-- its operations — including support for both pinned and unpinned +-- representations. The API integrates with streams, prioritizes safety, +-- flexibility, and performance. It supports configurable equality for +-- cross-platform compatibility and user-defined path matching. It is designed +-- for extensibility and fine-grained type safety as well. For type-safe +-- adaptations, see the "Streamly.Internal.FileSystem.Path.*" modules. +-- +-- 'Path' is interconvertible with the 'OsPath' type from the @filepath@ +-- package at zero runtime cost. While the API is mostly compatible with that +-- of the @filepath@ package, some differences exist due to a slightly +-- different design philosophy focused on better safety. +-- +-- = Rooted vs Unrooted Paths +-- +-- To ensure the safety of the path append operation, we distinguish between +-- rooted paths and free path segments or unrooted paths. A path that starts +-- from an explicit or implicit file system root is called a rooted path or an +-- anchored path. For example, @\/usr\/bin@ is a rooted path with @/@ as an +-- explicit root directory. Similarly, @.\/bin@ is a rooted path with the +-- current directoy \".\" as an implicit root. A path that is not rooted is +-- called an unrooted path or unanchored path; for example, @local\/bin@ is an +-- unrooted path. +-- +-- This distinction ensures the safety of the path append operation. You can +-- append only an unrooted path to another path, it does not make sense to +-- append a rooted path to another path. The default append operation in the +-- Path module checks for this and fails if the operation is invalid. +-- +-- Rooted vs unrooted distinction is a stricter form of relative vs absolute +-- path distinction. In this model, for better safety, paths relative to the +-- current directory are also treated in the same way as absolute paths, from +-- the perspective of a path append operation. This is because the meaning of +-- current directory is context dependent and dynamic, therefore, appending it +-- to another path is not allowed. Only unrooted path segments (e.g. +-- @local/bin@) can be appended to any other path using safe operations. +-- +-- = File vs. Directory Paths +-- +-- By default, a path with a trailing separator (e.g. @local/@) is implicitly +-- considered a directory path. However, the absence of a trailing separator +-- does not indicate whether the path is a file or a directory — it could be +-- either. Therefore, when using the @Path@ type, the append operation allows +-- appending to paths even if they lack a trailing separator. +-- +-- = Compatibility with the filepath package +-- +-- Any path type can be converted to the 'FilePath' type from the @filepath@ +-- package by using the 'toString' operation. Operations to convert to and from +-- the 'OsPath' type at zero cost are provided in the @streamly-filepath@ +-- package. Zero-cost interconversion is possible because the 'Path' type uses +-- an underlying representation which is compatible with the 'OsPath' type. +-- +-- = Path Creation Quasiquoter +-- +-- The 'path' quasiquoter is useful in creating valid paths that are checked +-- during the compile time. + +module Streamly.FileSystem.Path + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Type + Path + , OsWord + + -- * Construction + , validatePath + , fromArray + , fromString + , fromString_ + + -- * Statically Verified String Literals + -- | Quasiquoters. + , path + + -- * Statically Verified Strings + -- | Template Haskell expression splices. + , pathE + + -- * Elimination + , toArray + -- , toChars -- need fromChars as well + , toString + -- , asOsCString + + -- * Path Info + , isRooted + , isUnrooted + + -- * Joining + , unsafeJoin + , join + , joinStr + + -- * Splitting root + , splitRoot + + -- * Splitting path components + , splitPath + -- , splitPath_ + + -- * Splitting file extension + , splitExtension + , takeExtension + , dropExtension + -- , addExtension + -- , replaceExtension + + -- * Splitting file and dir + , splitFile + , takeFileName + , takeDirectory + , takeFileBase + + -- * Equality + , EqCfg + , ignoreCase + , ignoreTrailingSeparators + , allowRelativeEquality + + , eqPath + ) +where + +{- Documentation on typed paths. We can add this back into the module level + documentation when we introduce the typed paths. + +-- = Rooted Paths vs Branches +-- +-- /Flexible typing/: you can choose the level of type safety you want. 'Path' +-- is the basic path type which can represent a file, directory, absolute or +-- relative path with no restrictions. Depending on how much type safety you +-- want, you can choose appropriate type wrappers or a combination of those to +-- wrap the 'Path' type in stricter types. + +-- The "Streamly.FileSystem.Path.Seg" module provides explicit types for path +-- segments, distinguishing rooted paths from branches. Rooted paths use the +-- @Rooted Path@ type, and branches use the @Branch Path@ type. If you use the +-- generic 'Path' type, append may fail at run time if you attempt to append +-- a rooted path to another rooted path. In contrast, using the @Rooted Path@ +-- and @Branch Path@ types guarantees compile-time safety, preventing such errors. + +-- = File vs. Directory Paths +-- +-- Independent of the rooted or branch distinction, you can also make a +-- type-level distinction between file and directory nodes using the +-- "Streamly.FileSystem.Path.Node" module. The type @File Path@ represents a +-- file, whereas @Dir Path@ represents a directory. This distinction provides +-- safety against appending to file type paths — append operations are not +-- allowed on paths of type 'File'. + +-- = Flexible Typing +-- +-- You can use the 'Rooted', 'Branch', 'Dir', and 'File' types independently by +-- importing only the required modules. If you want both types of distinctions, +-- you can use them together via the "Streamly.FileSystem.Path.SegNode" module. +-- For example, @Rooted (Dir Path)@ represents a rooted path that is a +-- directory. You can append other paths only to paths that have a 'Dir' type, +-- and only a path of type 'Branch' can be appended. +-- +-- You may choose to use the basic 'Path' type or any combination of the safer +-- types. You can upgrade or downgrade the safety level by converting between +-- types using the @adapt@ operation. When converting from a less restrictive +-- type to a more restrictive one, run-time checks are performed, and the +-- conversion may fail. However, converting from a more restrictive type to a +-- less restrictive one is always allowed. +-- +-- = Extensibility +-- +-- You can define your own newtype wrappers similar to 'File' or 'Dir' to +-- provide custom restrictions if you want. +-- + +-} + +import Streamly.Internal.FileSystem.Path + +#include "DocTestFileSystemPath.hs" diff --git a/src/Streamly/FileSystem/Path/Node.hs b/src/Streamly/FileSystem/Path/Node.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/FileSystem/Path/Node.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Streamly.FileSystem.Path.Node +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- Represent 'File' or 'Dir' type path nodes explicitly as separate types for +-- the safety of path append operation. A 'Dir' path is a branching or +-- intermediate node whereas a 'File' type is a terminal or leaf node. We +-- cannot append a path to a 'File' type path. +-- +-- See the overview in the "Streamly.FileSystem.Path" module for more details. +-- +module Streamly.FileSystem.Path.Node + ( + -- * Types + File + , Dir + , IsNode + + -- * Statically Verified Path Literals + -- | Quasiquoters. + , dir + , file + + -- * Statically Verified Path Strings + -- | Template Haskell expression splices. + , dirE + , fileE + + -- * Operations + , join + ) +where + +import Streamly.Internal.FileSystem.Path.Node diff --git a/src/Streamly/FileSystem/Path/Seg.hs b/src/Streamly/FileSystem/Path/Seg.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/FileSystem/Path/Seg.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Streamly.FileSystem.Path.Seg +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- Represent 'Rooted' or 'Unrooted' type path segments explicitly as separate +-- types for the safety of path append operation. A Rooted path is an absolute +-- path or a path that is relative to the current directory with a leading dot. +-- Rooted paths cannot be appended to other paths. +-- +-- See the overview in the "Streamly.FileSystem.Path" module for more details. +-- +module Streamly.FileSystem.Path.Seg + ( + -- * Types + Rooted + , Unrooted + , IsSeg + + -- * Statically Verified Path Literals + -- | Quasiquoters. + , rt + , ur + + -- * Statically Verified Path Strings + -- | Template Haskell expression splices. + , rtE + , urE + + -- * Operations + , join + ) +where + +import Streamly.Internal.FileSystem.Path.Seg diff --git a/src/Streamly/FileSystem/Path/SegNode.hs b/src/Streamly/FileSystem/Path/SegNode.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/FileSystem/Path/SegNode.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Streamly.FileSystem.Path.SegNode +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- Use 'Rooted' or 'Unrooted' path segment type annotations as well as 'File' and +-- 'Dir' node type annotations on the same path for the safety of path append +-- operation. A Rooted path cannot be appended to other paths, and you canno +-- append a path to a 'File' type path. +-- +-- See the overview in the "Streamly.FileSystem.Path" module for more details. +-- + +module Streamly.FileSystem.Path.SegNode + ( + -- * Statically Verified Path Literals + -- | Quasiquoters. + rtdir + , urdir + , rtfile + , urfile + + -- * Statically Verified Path Strings + -- | Template Haskell expression splices. + , rtdirE + , urdirE + , rtfileE + , urfileE + + -- * Operations + , join + ) +where + +import Streamly.Internal.FileSystem.Path.SegNode diff --git a/src/Streamly/Internal/Console/Stdio.hs b/src/Streamly/Internal/Console/Stdio.hs --- a/src/Streamly/Internal/Console/Stdio.hs +++ b/src/Streamly/Internal/Console/Stdio.hs @@ -9,16 +9,25 @@ module Streamly.Internal.Console.Stdio ( - -- * Streams + -- * Singleton APIs + -- getChunk + -- , putChunk + + -- * Stream reads read - , readChars + -- , readWith -- buffer , readChunks - -- , getChunksLn - -- , getStringsWith -- get strings using the supplied decoding - -- , getStrings -- get strings of complete chars, - -- leave any partial chars for next string - -- , getStringsLn -- get lines decoded as char strings + -- , readChunksWith -- buffer + -- , readChunksLn -- chunks with line buffering -- repeatM Text.getLine + -- -- ** Encoding specific + -- , readCharsWith + -- , readStringsLnWith + + -- ** UTF-8 decoded + , readChars + -- , readStringsLn -- strings with line buffering -- repeatM getLine + -- * Unfolds , reader , chunkReader @@ -31,11 +40,18 @@ -- * Stream writes , putBytes -- Buffered (32K) - , putChars , putChunks -- Unbuffered + + -- ** Encoding specific + -- , putCharsWith , putStringsWith + -- , putStringsLnWith + + -- ** UTF-8 encoded + , putChars , putStrings , putStringsLn + -- , putChunksLn ) where @@ -47,13 +63,12 @@ import Prelude hiding (read) import Streamly.Internal.Data.Array.Type (Array(..)) -import Streamly.Internal.Data.Stream.StreamD (Stream) +import Streamly.Internal.Data.Stream (Stream) import Streamly.Internal.Data.Unfold (Unfold) import Streamly.Internal.Data.Fold (Fold) import qualified Streamly.Internal.Data.Array as Array -import qualified Streamly.Internal.Data.Stream.StreamD as Stream - (intersperseMSuffix) +import qualified Streamly.Internal.Data.Stream as Stream import qualified Streamly.Internal.Data.Unfold as Unfold import qualified Streamly.Internal.FileSystem.Handle as Handle import qualified Streamly.Internal.Unicode.Stream as Unicode @@ -194,7 +209,7 @@ -- folds as well as unfolds/streams. Non-backtracking (one-to-one, one-to-many, -- filters, reducers) transformations may be easy so we can possibly start with -- those. --- + -- | Write a stream of strings to standard output using the supplied encoding. -- Output is flushed to the device for each string. -- @@ -224,5 +239,5 @@ putStringsLn :: MonadIO m => Stream m String -> m () putStringsLn = putChunks - . Stream.intersperseMSuffix (return $ Array.fromList [10]) + . Stream.intersperseEndByM (return $ Array.fromList [10]) . Unicode.encodeStrings Unicode.encodeUtf8 diff --git a/src/Streamly/Internal/Control/Exception.hs b/src/Streamly/Internal/Control/Exception.hs --- a/src/Streamly/Internal/Control/Exception.hs +++ b/src/Streamly/Internal/Control/Exception.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Internal.Control.Exception -- Copyright : (c) 2019 Composewell Technologies @@ -10,11 +11,50 @@ -- Additional "Control.Exception" utilities. module Streamly.Internal.Control.Exception - ( verify + ( + -- * Verify + verify , verifyM + + -- * Resource Management + -- | Exception safe, thread safe resource managment operations, similar to + -- but more powerful than the @bracket@ and @finally@ operations available + -- in the base package. + -- + -- These operations support allocation and free only in the IO monad, + -- hence the IO suffix. + -- + , AcquireIO(..) + , Priority(..) + , allocator + , releaser + , withAcquireIO + , acquireWith + , acquire + , acquire_ + , registerWith + , register + , hook ) where +-- import Control.Concurrent (myThreadId) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Exception (mask_) +import Control.Monad.Catch (MonadMask) +import Data.IntMap.Strict (IntMap) +import Data.IORef (IORef, newIORef, atomicModifyIORef') + +import qualified Control.Monad.Catch as MC +import qualified Data.IntMap.Strict as Map + +#include "DocTestControlException.hs" + +------------------------------------------------------------------------------- +-- Asserts +------------------------------------------------------------------------------- + -- | Like 'assert' but is not removed by the compiler, it is always present in -- production code. -- @@ -36,3 +76,252 @@ {-# INLINE verifyM #-} verifyM :: Applicative f => Bool -> f () verifyM predicate = verify predicate (pure ()) + +------------------------------------------------------------------------------- +-- Resource management +------------------------------------------------------------------------------- + +-- XXX In a manual release mechanism of resources we always have the risk of +-- using the resource by some persisting thread even after it has been freed. +-- Ideally, we should use the GC to clean up resources because that way we do +-- not need to worry about references, we can pass around resources to other +-- threads and we get an automatic reference counting. Is it possible to use +-- compact regions to confine resource to smaller areas so that we can perform +-- a limited GC to free them? We can then just put gc sync barriers at points +-- where we want to ensure that resources are freed. + +-- | Resources with 'Priority1' are freed before 'Priority2'. Priority is +-- especially introduced to take care of the case where we need to free +-- concurrency channels, so that all the workers of the channel are cleaned up +-- before we free the resources allocated by the workers of the channel. +-- Otherwise we might free the resources and workers may be trying to use them +-- and start misbehaving. +-- +data Priority = Priority1 | Priority2 deriving Show + +-- To keep the type signatures simple and to avoid inference problems we should +-- use this newtype. We cannot pass around a foralled type without wrapping +-- it in a newtype. + +-- | @AcquireIO@ is used to acquire a resource safely such that it is +-- automatically released if not released manually. +-- +-- See 'withAcquireIO'. +-- +newtype AcquireIO = AcquireIO + (forall b c. Priority -> IO b -> (b -> IO c) -> IO (b, IO ())) + +-- | /Internal/. +allocator :: MonadIO m => + IORef (Int, IntMap (IO ()), IntMap (IO ())) + -> Priority + -> IO a + -> (a -> IO b) + -> m (a, m ()) +allocator ref pri alloc free = do + let insertResource r (i, mp1, mp2) = + case pri of + Priority1 -> + ((i + 1, Map.insert i (void $ free r) mp1, mp2), i) + Priority2 -> + ((i + 1, mp1, Map.insert i (void $ free r) mp2), i) + + (r, index) <- + liftIO $ mask_ $ do + -- tid <- myThreadId + r <- alloc + idx <- atomicModifyIORef' ref (insertResource r) + -- liftIO $ putStrLn $ "insert: " ++ show pri + -- ++ " " ++ show idx ++ " " ++ show tid + return (r, idx) + + let deleteResource (i, mp1, mp2) = + case pri of + Priority1 -> + let res = Map.lookup index mp1 + in ((i, Map.delete index mp1, mp2), res) + Priority2 -> + let res = Map.lookup index mp2 + in ((i, mp1, Map.delete index mp2), res) + + release = + -- IMPORTANT: do not use interruptible operations in this + -- critical section. Even putStrLn can make tests fail. + liftIO $ mask_ $ do + -- tid <- myThreadId + -- liftIO $ putStrLn $ "releasing index: " ++ show index + -- ++ " " ++ show tid + f <- atomicModifyIORef' ref deleteResource + -- restoring exceptions makes it non-atomic, tests fail. + -- Can use allowInterrupt in "free" if desired. + sequence_ f + return (r, release) + +-- XXX can we ensure via GC that the resources that we are freeing are all +-- dead, there are no other references to them? + +-- | We ensure that all async workers for concurrent streams are stopped +-- before we release the resources so that nobody could be using the +-- resource after they are freed. +-- +-- The only other possibility, could be user issued forkIO not being +-- tracked by us, however, that would be a programming error and any such +-- threads could misbehave if we freed the resources from under them. +-- +-- We use GC based hooks in 'Stream.bracketIO\'' so there could be async threads +-- spawned by GC, releasing resources concurrently with us. For that reason we +-- need to make sure that the "release" in the bracket end action is executed +-- only once in that case. +-- +-- /Internal/. +releaser :: MonadIO m => IORef (a, IntMap (IO b), IntMap (IO b)) -> m () +releaser ref = + liftIO $ mask_ $ do + -- Delete the map from the ref first so that anyone else (GC) + -- releasing concurrently cannot find the map. + -- liftIO $ putStrLn "cleaning up priority 1" + mp1 <- atomicModifyIORef' ref + (\(i, mp1,mp2) -> ((i, Map.empty, mp2), mp1)) + -- Note that the channel cleanup function is interruptible because + -- it has blocking points. + sequence_ mp1 + -- Now nobody would be changing mp2, we can read it safely + -- liftIO $ putStrLn "cleaning up priority 2" + mp2 <- atomicModifyIORef' ref + (\(i, mp,mp2) -> ((i, mp, Map.empty), mp2)) + sequence_ mp2 + -- XXX We can now assert that the IORef has both maps empty. + +-- | @withAcquireIO action@ runs the given @action@, providing it with a +-- an 'AcquireIO' reference called @ref@ as argument. @ref@ is used for resource +-- acquisition or hook registeration within the scope of @action@. An @acquire +-- ref alloc free@ call can be used within @action@ any number of times to +-- acquire resources that are automatically freed when the scope of @action@ +-- ends or if an exception occurs at any time. @alloc@ is a function supplied +-- by the user to allocate a resource and @free@ is supplied to free the +-- allocated resource. @acquire@ returns @(resource, release)@ -- the acquired +-- @resource@ and a @release@ action to release it. +-- +-- @acquire@ allocates a resource in an exception safe manner and sets up its +-- automatic release on exception or when the scope of @action@ ends. The +-- @release@ function returned by @acquire@ can be used to free the resource +-- manually at any time. @release@ is guaranteed to free the resource once and +-- only once even if it is called concurrently or multiple times. +-- +-- Here is an example to allocate resources that are guaranteed to be released +-- automatically, and can be released manually as well: +-- +-- >>> :{ +-- close x h = do +-- putStrLn $ "closing: " ++ x +-- hClose h +-- :} +-- +-- >>> :{ +-- action ref = +-- Stream.fromList ["file1", "file2"] +-- & Stream.mapM +-- (\x -> do +-- (h, release) <- Exception.acquire ref (openFile x ReadMode) (close x) +-- -- use h here +-- threadDelay 1000000 +-- when (x == "file1") $ do +-- putStrLn $ "Manually releasing: " ++ x +-- release +-- return x +-- ) +-- & Stream.trace print +-- & Stream.fold Fold.drain +-- :} +-- +-- >>> run = Exception.withAcquireIO action +-- +-- In the above code, you should see the \"closing:\" message for both the +-- files, and only once for each file. Even if you interrupt the program with +-- CTRL-C you should still see the \"closing:\" message for the files opened +-- before the interrupt. Make sure you create "file1" and "file2" before +-- running this code snippet. +-- +-- Cleanup is guaranteed to happen as soon as the scope of 'action' +-- finishes or if an exception occurs. +-- +-- Here is an example for just registering hooks to be called eventually: +-- +-- >>> :{ +-- action ref = +-- Stream.fromList ["file1", "file2"] +-- & Stream.mapM +-- (\x -> do +-- Exception.register ref $ putStrLn $ "saw: " ++ x +-- threadDelay 1000000 +-- return x +-- ) +-- & Stream.trace print +-- & Stream.fold Fold.drain +-- :} +-- +-- >>> run = Exception.withAcquireIO action +-- +-- In the above code, even if you interrupt the program with CTRL-C you should +-- still see the "saw:" message for the elements seen before the interrupt. +-- +-- The registered hooks are guaranteed to be invoked as soon as the scope of +-- 'action' finishes or if an exception occurs. +-- +-- This function provides functionality similar to the @bracket@ function +-- available in the base library. However, it is more powerful as any number of +-- resources can be allocated and released within the scope of 'action'. +-- +-- Exception safe, thread safe. +{-# INLINE withAcquireIO #-} +withAcquireIO :: (MonadIO m, MonadMask m) => (AcquireIO -> m a) -> m a +withAcquireIO action = do + -- Assuming 64-bit int counter will never overflow + ref <- liftIO $ newIORef (0 :: Int, Map.empty, Map.empty) + action (AcquireIO (allocator ref)) `MC.finally` releaser ref + +-- | Like 'acquire' but allows specifying a priority for releasing the +-- resource. 'Priority1' resources are released before 'Priority2'. This allows +-- us to specify a dependency between resource release. +{-# INLINE acquireWith #-} +acquireWith :: Priority -> AcquireIO -> IO b -> (b -> IO c) -> IO (b, IO ()) +acquireWith pri (AcquireIO f) = f pri + +-- | @acquire ref alloc free@ is used in bracket-style safe resource allocation +-- functions, where @alloc@ is a function supplied by the user to allocate a +-- resource and @free@ is supplied to free it. @acquire@ returns a tuple +-- @(resource, release)@ where @resource@ is the allocated resource and +-- @release@ is an action that can be called later to release the resource. +-- Both @alloc@ and @free@ are invoked with async signals masked. You can use +-- @allowInterrupt@ from base package for allowing interrupts if required. +-- +-- The @release@ action can be called multiple times or even concurrently from +-- multiple threads, but it will release the resource only once. If @release@ +-- is never called by the programmer it will be automatically called at the end +-- of the bracket scope. +-- +acquire :: AcquireIO -> IO b -> (b -> IO c) -> IO (b, IO ()) +acquire = acquireWith Priority2 + +-- | Like 'acquire' but does not return a release action. The resource is freed +-- automatically only. +acquire_ :: AcquireIO -> IO b -> (b -> IO c) -> IO b +acquire_ a b c = fmap fst $ acquire a b c + +-- | Like 'register' but specifies a 'Priority' for calling the hook. +{-# INLINE registerWith #-} +registerWith :: Priority -> AcquireIO -> IO () -> IO () +registerWith pri (AcquireIO f) g = void $ f pri (return ()) (\() -> g) + +-- | Register a hook to be executed at the end of a bracket. +register :: AcquireIO -> IO () -> IO () +register = registerWith Priority2 + +-- | Like 'register' but returns a hook release function as well. When the +-- returned hook release function is called, the hook is invoked and removed. +-- If the returned function is never called by the programmer then it is +-- automatically invoked at the end of the bracket. The hook is invoked once +-- and only once. +-- +hook :: AcquireIO -> IO () -> IO (IO()) +hook (AcquireIO f) g = fmap snd $ f Priority2 (return ()) (\() -> g) diff --git a/src/Streamly/Internal/Data/Array.hs b/src/Streamly/Internal/Data/Array.hs --- a/src/Streamly/Internal/Data/Array.hs +++ b/src/Streamly/Internal/Data/Array.hs @@ -2,572 +2,1178 @@ -- | -- Module : Streamly.Internal.Data.Array -- Copyright : (c) 2019 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Array - ( - -- * Setup - -- $setup - - -- * Design Notes - -- $design - - -- * The Array Type - Array - - -- * Construction - - -- Pure List APIs - , A.fromListN - , A.fromList - - -- Stream Folds - , fromStreamN - , fromStream - - -- Monadic Folds - , A.writeN -- drop new - , A.writeNAligned - , A.write -- full buffer - , writeLastN - - -- * Elimination - -- ** Conversion - , A.toList - - -- ** Streams - , A.read - , A.readRev - - -- ** Unfolds - , reader - , readerUnsafe - , A.readerRev - , producer -- experimental - - -- * Random Access - -- , (!!) - , getIndex - , A.unsafeIndex -- XXX Rename to getIndexUnsafe?? - , getIndexRev - , last -- XXX getIndexLast? - , getIndices - , getIndicesFromThenTo - -- , getIndicesFrom -- read from a given position to the end of file - -- , getIndicesUpto -- read from beginning up to the given position - -- , getIndicesFromTo - -- , getIndicesFromRev -- read from a given position to the beginning of file - -- , getIndicesUptoRev -- read from end to the given position in file - - -- * Size - , length - , null - - -- * Search - , binarySearch - , findIndicesOf - -- , findIndexOf - -- , find - - -- * Casting - , cast - , asBytes - , castUnsafe - , asPtrUnsafe - , asCStringUnsafe - , A.unsafeFreeze -- asImmutableUnsafe? - , A.unsafeThaw -- asMutableUnsafe? - - -- * Subarrays - , getSliceUnsafe - -- , getSlice - , genSlicesFromLen - , getSlicesFromLen - , splitOn - - -- * Streaming Operations - , streamTransform - - -- ** Folding - , streamFold - , fold - - -- * Deprecated - , A.toStream - , A.toStreamRev - ) -where - -#include "inline.hs" -#include "ArrayMacros.h" - -import Control.Exception (assert) -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Functor.Identity (Identity) -import Data.Proxy (Proxy(..)) -import Data.Word (Word8) -import Foreign.C.String (CString) -import Foreign.Ptr (castPtr) -import Foreign.Storable (Storable) -import Streamly.Internal.Data.Unboxed - ( Unbox - , peekWith - , sizeOf - ) -import Prelude hiding (length, null, last, map, (!!), read, concat) - -import Streamly.Internal.Data.Array.Mut.Type (ArrayUnsafe(..)) -import Streamly.Internal.Data.Array.Type - (Array(..), length, asPtrUnsafe) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Producer.Type (Producer(..)) -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Tuple.Strict (Tuple3Fused'(..)) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Streamly.Internal.System.IO (unsafeInlineIO) - -import qualified Streamly.Internal.Data.Array.Mut.Type as MA -import qualified Streamly.Internal.Data.Array.Mut as MA -import qualified Streamly.Internal.Data.Array.Type as A -import qualified Streamly.Internal.Data.Fold as FL -import qualified Streamly.Internal.Data.Producer.Type as Producer -import qualified Streamly.Internal.Data.Producer as Producer -import qualified Streamly.Internal.Data.Ring.Unboxed as RB -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Streamly.Internal.Data.Unfold as Unfold - -#include "DocTestDataArray.hs" - --- $design --- --- To summarize: --- --- * Arrays are finite and fixed in size --- * provide /O(1)/ access to elements --- * store only data and not functions --- * provide efficient IO interfacing --- --- 'Foldable' instance is not provided because the implementation would be much --- less efficient compared to folding via streams. 'Semigroup' and 'Monoid' --- instances should be used with care; concatenating arrays using binary --- operations can be highly inefficient. Instead, use --- 'Streamly.Internal.Data.Stream.Chunked.toArray' to concatenate N --- arrays at once. --- --- Each array is one pointer visible to the GC. Too many small arrays (e.g. --- single byte) are only as good as holding those elements in a Haskell list. --- However, small arrays can be compacted into large ones to reduce the --- overhead. To hold 32GB memory in 32k sized buffers we need 1 million arrays --- if we use one array for each chunk. This is still significant to add --- pressure to GC. - -------------------------------------------------------------------------------- --- Construction -------------------------------------------------------------------------------- - --- | Create an 'Array' from the first N elements of a stream. The array is --- allocated to size N, if the stream terminates before N elements then the --- array may hold less than N elements. --- --- /Pre-release/ -{-# INLINE fromStreamN #-} -fromStreamN :: (MonadIO m, Unbox a) => Int -> Stream m a -> m (Array a) -fromStreamN n m = do - when (n < 0) $ error "writeN: negative write count specified" - A.fromStreamDN n m - --- | Create an 'Array' from a stream. This is useful when we want to create a --- single array from a stream of unknown size. 'writeN' is at least twice --- as efficient when the size is already known. --- --- Note that if the input stream is too large memory allocation for the array --- may fail. When the stream size is not known, `chunksOf` followed by --- processing of indvidual arrays in the resulting stream should be preferred. --- --- /Pre-release/ -{-# INLINE fromStream #-} -fromStream :: (MonadIO m, Unbox a) => Stream m a -> m (Array a) -fromStream = Stream.fold A.write --- write m = A.fromStreamD $ D.fromStreamK m - -------------------------------------------------------------------------------- --- Elimination -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL producer #-} -producer :: forall m a. (Monad m, Unbox a) => Producer m (Array a) a -producer = - Producer.translate A.unsafeThaw A.unsafeFreeze - $ MA.producerWith (return . unsafeInlineIO) - --- | Unfold an array into a stream. --- -{-# INLINE_NORMAL reader #-} -reader :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a -reader = Producer.simplify producer - --- | Unfold an array into a stream, does not check the end of the array, the --- user is responsible for terminating the stream within the array bounds. For --- high performance application where the end condition can be determined by --- a terminating fold. --- --- Written in the hope that it may be faster than "read", however, in the case --- for which this was written, "read" proves to be faster even though the core --- generated with unsafeRead looks simpler. --- --- /Pre-release/ --- -{-# INLINE_NORMAL readerUnsafe #-} -readerUnsafe :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a -readerUnsafe = Unfold step inject - where - - inject (Array contents start end) = - return (ArrayUnsafe contents end start) - - {-# INLINE_LATE step #-} - step (ArrayUnsafe contents end p) = do - -- unsafeInlineIO allows us to run this in Identity monad for pure - -- toList/foldr case which makes them much faster due to not - -- accumulating the list and fusing better with the pure consumers. - -- - -- This should be safe as the array contents are guaranteed to be - -- evaluated/written to before we peek at them. - let !x = unsafeInlineIO $ peekWith contents p - let !p1 = INDEX_NEXT(p,a) - return $ D.Yield x (ArrayUnsafe contents end p1) - --- | --- --- >>> import qualified Streamly.Internal.Data.Array.Type as Array --- >>> null arr = Array.byteLength arr == 0 --- --- /Pre-release/ -{-# INLINE null #-} -null :: Array a -> Bool -null arr = A.byteLength arr == 0 - --- | Like 'getIndex' but indexes the array in reverse from the end. --- --- /Pre-release/ -{-# INLINE getIndexRev #-} -getIndexRev :: forall a. Unbox a => Int -> Array a -> Maybe a -getIndexRev i arr = - unsafeInlineIO - $ do - let elemPtr = RINDEX_OF(arrEnd arr, i, a) - if i >= 0 && elemPtr >= arrStart arr - then Just <$> peekWith (arrContents arr) elemPtr - else return Nothing - --- | --- --- >>> import qualified Streamly.Internal.Data.Array as Array --- >>> last arr = Array.getIndexRev arr 0 --- --- /Pre-release/ -{-# INLINE last #-} -last :: Unbox a => Array a -> Maybe a -last = getIndexRev 0 - -------------------------------------------------------------------------------- --- Folds with Array as the container -------------------------------------------------------------------------------- - --- | @writeLastN n@ folds a maximum of @n@ elements from the end of the input --- stream to an 'Array'. --- -{-# INLINE writeLastN #-} -writeLastN :: - (Storable a, Unbox a, MonadIO m) => Int -> Fold m a (Array a) -writeLastN n - | n <= 0 = fmap (const mempty) FL.drain - | otherwise = A.unsafeFreeze <$> Fold step initial done - - where - - step (Tuple3Fused' rb rh i) a = do - rh1 <- liftIO $ RB.unsafeInsert rb rh a - return $ FL.Partial $ Tuple3Fused' rb rh1 (i + 1) - - initial = - let f (a, b) = FL.Partial $ Tuple3Fused' a b (0 :: Int) - in fmap f $ liftIO $ RB.new n - - done (Tuple3Fused' rb rh i) = do - arr <- liftIO $ MA.newPinned n - foldFunc i rh snoc' arr rb - - -- XXX We should write a read unfold for ring. - snoc' b a = liftIO $ MA.snocUnsafe b a - - foldFunc i - | i < n = RB.unsafeFoldRingM - | otherwise = RB.unsafeFoldRingFullM - -------------------------------------------------------------------------------- --- Random Access -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- --- Searching -------------------------------------------------------------------------------- - --- | Given a sorted array, perform a binary search to find the given element. --- Returns the index of the element if found. --- --- /Unimplemented/ -{-# INLINE binarySearch #-} -binarySearch :: a -> Array a -> Maybe Int -binarySearch = undefined - --- find/findIndex etc can potentially be implemented more efficiently on arrays --- compared to streams by using SIMD instructions. --- We can also return a bit array instead. - --- | Perform a linear search to find all the indices where a given element is --- present in an array. --- --- /Unimplemented/ -findIndicesOf :: (a -> Bool) -> Unfold Identity (Array a) Int -findIndicesOf = undefined - -{- -findIndexOf :: (a -> Bool) -> Array a -> Maybe Int -findIndexOf p = Unfold.fold Fold.one . Stream.unfold (findIndicesOf p) - -find :: (a -> Bool) -> Array a -> Bool -find = Unfold.fold Fold.null . Stream.unfold (findIndicesOf p) --} - -------------------------------------------------------------------------------- --- Folds -------------------------------------------------------------------------------- - --- XXX We can potentially use SIMD instructions on arrays to fold faster. - -------------------------------------------------------------------------------- --- Slice -------------------------------------------------------------------------------- - --- | /O(1)/ Slice an array in constant time. --- --- Caution: The bounds of the slice are not checked. --- --- /Unsafe/ --- --- /Pre-release/ -{-# INLINE getSliceUnsafe #-} -getSliceUnsafe :: - forall a. Unbox a - => Int -- ^ starting index - -> Int -- ^ length of the slice - -> Array a - -> Array a -getSliceUnsafe index len (Array contents start e) = - let size = SIZE_OF(a) - start1 = start + (index * size) - end1 = start1 + (len * size) - in assert (end1 <= e) (Array contents start1 end1) - --- | Split the array into a stream of slices using a predicate. The element --- matching the predicate is dropped. --- --- /Pre-release/ -{-# INLINE splitOn #-} -splitOn :: (Monad m, Unbox a) => - (a -> Bool) -> Array a -> Stream m (Array a) -splitOn predicate arr = - fmap (\(i, len) -> getSliceUnsafe i len arr) - $ D.sliceOnSuffix predicate (A.toStreamD arr) - -{-# INLINE genSlicesFromLen #-} -genSlicesFromLen :: forall m a. (Monad m, Unbox a) - => Int -- ^ from index - -> Int -- ^ length of the slice - -> Unfold m (Array a) (Int, Int) -genSlicesFromLen from len = - Unfold.lmap A.unsafeThaw (MA.genSlicesFromLen from len) - --- | Generate a stream of slices of specified length from an array, starting --- from the supplied array index. The last slice may be shorter than the --- requested length. --- --- /Pre-release// -{-# INLINE getSlicesFromLen #-} -getSlicesFromLen :: forall m a. (Monad m, Unbox a) - => Int -- ^ from index - -> Int -- ^ length of the slice - -> Unfold m (Array a) (Array a) -getSlicesFromLen from len = - fmap A.unsafeFreeze - $ Unfold.lmap A.unsafeThaw (MA.getSlicesFromLen from len) - -------------------------------------------------------------------------------- --- Random reads and writes -------------------------------------------------------------------------------- - --- XXX Change this to a partial function instead of a Maybe type? And use --- MA.getIndex instead. --- --- | /O(1)/ Lookup the element at the given index. Index starts from 0. --- -{-# INLINE getIndex #-} -getIndex :: forall a. Unbox a => Int -> Array a -> Maybe a -getIndex i arr = - unsafeInlineIO - $ do - let elemPtr = INDEX_OF(arrStart arr, i, a) - if i >= 0 && INDEX_VALID(elemPtr, arrEnd arr, a) - then Just <$> peekWith (arrContents arr) elemPtr - else return Nothing - --- | Given a stream of array indices, read the elements on those indices from --- the supplied Array. An exception is thrown if an index is out of bounds. --- --- This is the most general operation. We can implement other operations in --- terms of this: --- --- @ --- read = --- let u = lmap (\arr -> (0, length arr - 1)) Unfold.enumerateFromTo --- in Unfold.lmap f (getIndices arr) --- --- readRev = --- let i = length arr - 1 --- in Unfold.lmap f (getIndicesFromThenTo i (i - 1) 0) --- @ --- --- /Pre-release/ -{-# INLINE getIndices #-} -getIndices :: (Monad m, Unbox a) => Stream m Int -> Unfold m (Array a) a -getIndices m = - let unf = MA.getIndicesD (return . unsafeInlineIO) m - in Unfold.lmap A.unsafeThaw unf - --- | Unfolds @(from, then, to, array)@ generating a finite stream whose first --- element is the array value from the index @from@ and the successive elements --- are from the indices in increments of @then@ up to @to@. Index enumeration --- can occur downwards or upwards depending on whether @then@ comes before or --- after @from@. --- --- @ --- getIndicesFromThenTo = --- let f (from, next, to, arr) = --- (Stream.enumerateFromThenTo from next to, arr) --- in Unfold.lmap f getIndices --- @ --- --- /Unimplemented/ -{-# INLINE getIndicesFromThenTo #-} -getIndicesFromThenTo :: Unfold m (Int, Int, Int, Array a) a -getIndicesFromThenTo = undefined - -------------------------------------------------------------------------------- --- Transform via stream operations -------------------------------------------------------------------------------- - --- for non-length changing operations we can use the original length for --- allocation. If we can predict the length then we can use the prediction for --- new allocation. Otherwise we can use a hint and adjust dynamically. - -{- --- | Transform an array into another array using a pipe transformation --- operation. --- -{-# INLINE runPipe #-} -runPipe :: (MonadIO m, Unbox a, Unbox b) - => Pipe m a b -> Array a -> m (Array b) -runPipe f arr = P.runPipe (toArrayMinChunk (length arr)) $ f (A.read arr) --} - --- XXX For transformations that cannot change the number of elements e.g. "map" --- we can use a predetermined array length. --- --- | Transform an array into another array using a stream transformation --- operation. --- --- /Pre-release/ -{-# INLINE streamTransform #-} -streamTransform :: forall m a b. (MonadIO m, Unbox a, Unbox b) - => (Stream m a -> Stream m b) -> Array a -> m (Array b) -streamTransform f arr = - Stream.fold (A.writeWith (length arr)) $ f (A.read arr) - -------------------------------------------------------------------------------- --- Casts -------------------------------------------------------------------------------- - --- | Cast an array having elements of type @a@ into an array having elements of --- type @b@. The array size must be a multiple of the size of type @b@ --- otherwise accessing the last element of the array may result into a crash or --- a random value. --- --- /Pre-release/ --- -castUnsafe :: -#ifdef DEVBUILD - Unbox b => -#endif - Array a -> Array b -castUnsafe (Array contents start end) = - Array contents start end - --- | Cast an @Array a@ into an @Array Word8@. --- --- -asBytes :: Array a -> Array Word8 -asBytes = castUnsafe - --- | Cast an array having elements of type @a@ into an array having elements of --- type @b@. The length of the array should be a multiple of the size of the --- target element otherwise 'Nothing' is returned. --- --- -cast :: forall a b. (Unbox b) => Array a -> Maybe (Array b) -cast arr = - let len = A.byteLength arr - r = len `mod` SIZE_OF(b) - in if r /= 0 - then Nothing - else Just $ castUnsafe arr - --- | Convert an array of any type into a null terminated CString Ptr. --- --- /Unsafe/ --- --- /O(n) Time: (creates a copy of the array)/ --- --- /Pre-release/ --- -asCStringUnsafe :: Array a -> (CString -> IO b) -> IO b -asCStringUnsafe arr act = do - -- XXX Ensure a pinned allocation here. - let arr1 = asBytes arr <> A.fromList [0] - asPtrUnsafe arr1 $ \ptr -> act (castPtr ptr) - -------------------------------------------------------------------------------- --- Folds -------------------------------------------------------------------------------- - --- XXX We can directly use toStreamD and D.fold here. - --- | Fold an array using a 'Fold'. --- --- /Pre-release/ -{-# INLINE fold #-} -fold :: forall m a b. (Monad m, Unbox a) => Fold m a b -> Array a -> m b -fold f arr = Stream.fold f (A.read arr) - --- | Fold an array using a stream fold operation. --- --- /Pre-release/ -{-# INLINE streamFold #-} -streamFold :: (Monad m, Unbox a) => (Stream m a -> m b) -> Array a -> m b -streamFold f arr = f (A.read arr) +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Array + ( + -- * Setup + -- $setup + + -- * Design Notes + -- $design + + -- * The Array Type + module Streamly.Internal.Data.Array.Type + + -- * Construction + -- Monadic Folds + , createOfLast + + -- * Random Access + -- , getIndicesFrom -- read from a given position to the end of file + -- , getIndicesUpto -- read from beginning up to the given position + -- , getIndicesFromTo + -- , getIndicesFromRev -- read from a given position to the beginning of file + -- , getIndicesUptoRev -- read from end to the given position in file + , indexReader + , indexReaderFromThenTo + + -- * Search + , binarySearch + , findIndicesOf + -- getIndicesOf + , indexFinder -- see splitOn + -- , findIndexOf + -- , find + + -- * Casting + , cast + , asBytes + , unsafeCast + , asCStringUnsafe -- XXX asCString + , asCWString + + -- * Subarrays + -- , sliceOffLen + , indexerFromLen + , splitterFromLen + + -- * Streaming Operations + , streamTransform + + -- * Folding + , streamFold + , foldM + , foldRev + + -- * Stream of Arrays + , concatSepBy + , concatEndBy + , concatEndBySeq + + , compactMax + , compactMax' + , compactSepByByte_ + , compactEndByByte_ + , compactEndByLn_ + + -- * Parsing Stream of Arrays + , foldBreakChunks -- Uses Stream, bad perf on break + , foldChunks + , foldBreak + -- , parseBreakChunksK -- XXX uses Parser. parseBreak is better? + , toParserK + , parseBreak + , parseBreakPos + , parse + , parsePos + + -- * Serialization + , encodeAs + , serialize + , serialize' + , deserialize + + -- * Deprecated + , slicerFromLen + , sliceIndexerFromLen + , castUnsafe + , getSliceUnsafe + , pinnedSerialize + , genSlicesFromLen + , getSlicesFromLen + , getIndices + , writeLastN + , interpose + , interposeSuffix + , intercalateSuffix + , compactLE + , pinnedCompactLE + , compactOnByte + , compactOnByteSuffix + , splitOn + , fold + , foldBreakChunksK + ) +where + +#include "assert.hs" +#include "deprecation.h" +#include "inline.hs" +#include "ArrayMacros.h" + +import Control.Monad.IO.Class (MonadIO(..)) +-- import Data.Bifunctor (first) +-- import Data.Either (fromRight) +import Data.Functor.Identity (Identity(..)) +import Data.Proxy (Proxy(..)) +import Data.Word (Word8) +import Foreign.C.String (CString, CWString) +import GHC.Types (SPEC(..)) +import Streamly.Internal.Data.Unbox (Unbox(..)) +import Prelude hiding (length, null, last, map, (!!), read, concat) + +import Streamly.Internal.Data.MutByteArray.Type (PinnedState(..), MutByteArray) +import Streamly.Internal.Data.Serialize.Type (Serialize) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Parser (ParseError(..), ParseErrorPos(..)) +import Streamly.Internal.Data.ParserK.Type + (ParserK, ParseResult(..), Input(..), Step(..)) +import Streamly.Internal.Data.Stream (Stream(..)) +import Streamly.Internal.Data.StreamK.Type (StreamK) +import Streamly.Internal.Data.SVar.Type (adaptState, defState) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.System.IO (unsafeInlineIO) + +import qualified Streamly.Internal.Data.Fold.Type as Fold +import qualified Streamly.Internal.Data.Serialize.Type as Serialize +import qualified Streamly.Internal.Data.MutByteArray.Type as MBA +import qualified Streamly.Internal.Data.MutArray as MA +import qualified Streamly.Internal.Data.RingArray as RB +import qualified Streamly.Internal.Data.ParserDrivers as Drivers +import qualified Streamly.Internal.Data.Parser.Type as ParserD +import qualified Streamly.Internal.Data.ParserK.Type as ParserK +import qualified Streamly.Internal.Data.Stream as D +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.StreamK.Type as StreamK +import qualified Streamly.Internal.Data.Unfold as Unfold + +import Streamly.Internal.Data.Array.Type + +#include "DocTestDataArray.hs" + +-- $design +-- +-- To summarize: +-- +-- * Arrays are finite and fixed in size +-- * provide /O(1)/ access to elements +-- * store only data and not functions +-- * provide efficient IO interfacing +-- +-- 'Foldable' instance is not provided because the implementation would be much +-- less efficient compared to folding via streams. 'Semigroup' and 'Monoid' +-- instances should be used with care; concatenating arrays using binary +-- operations can be highly inefficient. Instead, use +-- 'Streamly.Internal.Data.Stream.Chunked.toArray' to concatenate N +-- arrays at once. +-- +-- Each array is one pointer visible to the GC. Too many small arrays (e.g. +-- single byte) are only as good as holding those elements in a Haskell list. +-- However, small arrays can be compacted into large ones to reduce the +-- overhead. To hold 32GB memory in 32k sized buffers we need 1 million arrays +-- if we use one array for each chunk. This is still significant to add +-- pressure to GC. + +------------------------------------------------------------------------------- +-- Folds with Array as the container +------------------------------------------------------------------------------- + +-- NOTE: We could possible write this in terms of "MutArray.createOfLast" but +-- this causes regression. This is probably because mapping inside "Fold.ifThen" +-- is more efficient than mapping over "Fold.ifTen". +-- +-- | @createOfLast n@ folds a maximum of @n@ elements from the end of the input +-- stream to an 'Array'. +-- +{-# INLINE createOfLast #-} +createOfLast :: + (Unbox a, MonadIO m) => Int -> Fold m a (Array a) +createOfLast n = Fold.ifThen (pure (n <= 0)) (Fold.fromPure empty) lst + + where + + lst = + let f = fmap unsafeFreeze . RB.toMutArray + in Fold.rmapM f $ RB.createOfLast n + +{-# DEPRECATED writeLastN "Please use createOfLast instead." #-} +{-# INLINE writeLastN #-} +writeLastN :: (Unbox a, MonadIO m) => Int -> Fold m a (Array a) +writeLastN = createOfLast + +------------------------------------------------------------------------------- +-- Random Access +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Searching +------------------------------------------------------------------------------- + +-- | Given a sorted array, perform a binary search to find the given element. +-- Returns the index of the element if found. +-- +-- /Unimplemented/ +{-# INLINE binarySearch #-} +binarySearch :: a -> Array a -> Maybe Int +binarySearch = undefined + +-- find/findIndex etc can potentially be implemented more efficiently on arrays +-- compared to streams by using SIMD instructions. +-- We can also return a bit array instead. + +-- Can use SIMD. + +-- | Perform a linear search to find all the indices where a given element is +-- present in an array. +-- +-- /Unimplemented/ +indexFinder :: (a -> Bool) -> Unfold Identity (Array a) Int +indexFinder = undefined + +-- | +-- /Unimplemented/ +findIndicesOf :: (a -> Bool) -> Array a -> Stream Identity Int +findIndicesOf p = Stream.unfold (indexFinder p) + +{- +findIndexOf :: (a -> Bool) -> Array a -> Maybe Int +findIndexOf p = Unfold.fold Fold.one . Stream.unfold (indexFinder p) + +find :: (a -> Bool) -> Array a -> Bool +find = Unfold.fold Fold.null . Stream.unfold (indexFinder p) +-} + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +-- XXX We can potentially use SIMD instructions on arrays to fold faster. + +------------------------------------------------------------------------------- +-- Slice +------------------------------------------------------------------------------- + +getSliceUnsafe :: + forall a. Unbox a + => Int -- ^ starting index + -> Int -- ^ length of the slice + -> Array a + -> Array a +RENAME(getSliceUnsafe,unsafeSliceOffLen) + +splitOn :: (Monad m, Unbox a) => + (a -> Bool) -> Array a -> Stream m (Array a) +RENAME(splitOn,splitEndBy_) + +{-# INLINE indexerFromLen #-} +indexerFromLen, sliceIndexerFromLen :: forall m a. (Monad m, Unbox a) + => Int -- ^ from index + -> Int -- ^ length of the slice + -> Unfold m (Array a) (Int, Int) +indexerFromLen from len = + Unfold.lmap unsafeThaw (MA.indexerFromLen from len) +RENAME(sliceIndexerFromLen,indexerFromLen) + +{-# DEPRECATED genSlicesFromLen "Please use indexerFromLen instead." #-} +{-# INLINE genSlicesFromLen #-} +genSlicesFromLen :: forall m a. (Monad m, Unbox a) + => Int -- ^ from index + -> Int -- ^ length of the slice + -> Unfold m (Array a) (Int, Int) +genSlicesFromLen = indexerFromLen + +-- | Generate a stream of slices of specified length from an array, starting +-- from the supplied array index. The last slice may be shorter than the +-- requested length. +-- +-- /Pre-release// +{-# INLINE splitterFromLen #-} +splitterFromLen, slicerFromLen :: forall m a. (Monad m, Unbox a) + => Int -- ^ from index + -> Int -- ^ length of the slice + -> Unfold m (Array a) (Array a) +splitterFromLen from len = + fmap unsafeFreeze + $ Unfold.lmap unsafeThaw (MA.splitterFromLen from len) +RENAME(slicerFromLen,splitterFromLen) + +{-# DEPRECATED getSlicesFromLen "Please use splitterFromLen instead." #-} +{-# INLINE getSlicesFromLen #-} +getSlicesFromLen :: forall m a. (Monad m, Unbox a) + => Int -- ^ from index + -> Int -- ^ length of the slice + -> Unfold m (Array a) (Array a) +getSlicesFromLen = splitterFromLen + +------------------------------------------------------------------------------- +-- Random reads and writes +------------------------------------------------------------------------------- + +-- | Given a stream of array indices, read the elements on those indices from +-- the supplied Array. An exception is thrown if an index is out of bounds. +-- +-- This is the most general operation. We can implement other operations in +-- terms of this: +-- +-- @ +-- read = +-- let u = lmap (\arr -> (0, length arr - 1)) Unfold.enumerateFromTo +-- in Unfold.lmap f (indexReader arr) +-- +-- readRev = +-- let i = length arr - 1 +-- in Unfold.lmap f (indexReaderFromThenTo i (i - 1) 0) +-- @ +-- +-- /Pre-release/ +{-# INLINE indexReader #-} +indexReader :: (Monad m, Unbox a) => Stream m Int -> Unfold m (Array a) a +indexReader m = + let unf = MA.indexReaderWith (return . unsafeInlineIO) m + in Unfold.lmap unsafeThaw unf + +-- XXX DO NOT REMOVE, change the signature to use Stream instead of unfold +{-# DEPRECATED getIndices "Please use getIndices instead." #-} +{-# INLINE getIndices #-} +getIndices :: (Monad m, Unbox a) => Stream m Int -> Unfold m (Array a) a +getIndices = indexReader + +-- | Unfolds @(from, then, to, array)@ generating a finite stream whose first +-- element is the array value from the index @from@ and the successive elements +-- are from the indices in increments of @then@ up to @to@. Index enumeration +-- can occur downwards or upwards depending on whether @then@ comes before or +-- after @from@. +-- +-- @ +-- getIndicesFromThenTo = +-- let f (from, next, to, arr) = +-- (Stream.enumerateFromThenTo from next to, arr) +-- in Unfold.lmap f getIndices +-- @ +-- +-- /Unimplemented/ +{-# INLINE indexReaderFromThenTo #-} +indexReaderFromThenTo :: Unfold m (Int, Int, Int, Array a) a +indexReaderFromThenTo = undefined + +------------------------------------------------------------------------------- +-- Transform via stream operations +------------------------------------------------------------------------------- + +-- for non-length changing operations we can use the original length for +-- allocation. If we can predict the length then we can use the prediction for +-- new allocation. Otherwise we can use a hint and adjust dynamically. + +{- +-- | Transform an array into another array using a pipe transformation +-- operation. +-- +{-# INLINE runPipe #-} +runPipe :: (MonadIO m, Unbox a, Unbox b) + => Pipe m a b -> Array a -> m (Array b) +runPipe f arr = P.runPipe (toArrayMinChunk (length arr)) $ f (read arr) +-} + +-- XXX For transformations that cannot change the number of elements e.g. "map" +-- we can use a predetermined array length. +-- +-- | Transform an array into another array using a stream transformation +-- operation. +-- +-- /Pre-release/ +{-# INLINE streamTransform #-} +streamTransform :: forall m a b. (MonadIO m, Unbox a, Unbox b) + => (Stream m a -> Stream m b) -> Array a -> m (Array b) +streamTransform f arr = + Stream.fold (createWith (length arr)) $ f (read arr) + +------------------------------------------------------------------------------- +-- Casts +------------------------------------------------------------------------------- + +-- | Cast an array having elements of type @a@ into an array having elements of +-- type @b@. The array size must be a multiple of the size of type @b@ +-- otherwise accessing the last element of the array may result into a crash or +-- a random value. +-- +-- /Pre-release/ +-- +unsafeCast, castUnsafe :: +#ifdef DEVBUILD + Unbox b => +#endif + Array a -> Array b +unsafeCast (Array contents start end) = + Array contents start end +RENAME(castUnsafe,unsafeCast) + +-- | Cast an @Array a@ into an @Array Word8@. +-- +-- +asBytes :: Array a -> Array Word8 +asBytes = unsafeCast + +-- | Cast an array having elements of type @a@ into an array having elements of +-- type @b@. The length of the array should be a multiple of the size of the +-- target element otherwise 'Nothing' is returned. +-- +-- +cast :: forall a b. (Unbox b) => Array a -> Maybe (Array b) +cast arr = + let len = byteLength arr + r = len `mod` SIZE_OF(b) + in if r /= 0 + then Nothing + else Just $ unsafeCast arr + +-- | Convert an array of any element type into a null terminated CString Ptr. +-- The array is copied to pinned memory. +-- +-- /Unsafe/ +-- +-- /O(n) Time: (creates a copy of the array)/ +-- +-- /Pre-release/ +-- +asCStringUnsafe :: Array a -> (CString -> IO b) -> IO b +asCStringUnsafe arr = MA.asCString (unsafeThaw arr) + +-- | Convert an array of any element type into a null terminated CWString Ptr. +-- The array is copied to pinned memory. +-- +-- /Unsafe/ +-- +-- /O(n) Time: (creates a copy of the array)/ +-- +-- /Pre-release/ +-- +asCWString :: Array a -> (CWString -> IO b) -> IO b +asCWString arr = MA.asCWString (unsafeThaw arr) + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +-- XXX Use runIdentity for pure fold +-- XXX Rename fold to foldM, we can then use "fold" for pure folds. +-- XXX We do not need an INLINE on fold? + +-- | Fold an array using a 'Fold'. +-- +-- /Pre-release/ +{-# INLINE foldM #-} +fold, foldM :: (Monad m, Unbox a) => Fold m a b -> Array a -> m b +foldM f arr = Stream.fold f (read arr) +RENAME(fold,foldM) + +foldRev :: Unbox a => Fold.Fold Identity a b -> Array a -> b +foldRev f arr = runIdentity $ Stream.fold f (readRev arr) + +-- | Fold an array using a stream fold operation. +-- +-- /Pre-release/ +{-# INLINE streamFold #-} +streamFold :: (Monad m, Unbox a) => (Stream m a -> m b) -> Array a -> m b +streamFold f arr = f (read arr) + +-------------------------------------------------------------------------------- +-- Serialization +-------------------------------------------------------------------------------- + +{-# INLINE encodeAs #-} +encodeAs :: forall a. Serialize a => PinnedState -> a -> Array Word8 +encodeAs ps a = + unsafeInlineIO $ do + let len = Serialize.addSizeTo 0 a + mbarr <- MBA.newAs ps len + off <- Serialize.serializeAt 0 mbarr a + assertM(len == off) + pure $ Array mbarr 0 off + +-- | +-- Properties: +-- 1. Identity: @deserialize . serialize == id@ +-- 2. Encoded equivalence: @serialize a == serialize a@ +{-# INLINE serialize #-} +serialize :: Serialize a => a -> Array Word8 +serialize = encodeAs Unpinned + +-- | Serialize a Haskell type to a pinned byte array. The array is allocated +-- using pinned memory so that it can be used directly in OS APIs for writing +-- to file or sending over the network. +-- +-- Properties: +-- +-- 1. Identity: @deserialize . serialize' == id@ +-- 2. Encoded equivalence: @serialize' a == serialize' a@ +{-# INLINE serialize' #-} +pinnedSerialize, serialize' :: Serialize a => a -> Array Word8 +serialize' = encodeAs Pinned +RENAME_PRIME(pinnedSerialize,serialize) + +-- XXX We can deserialize it like MutArray, returning the remaining slice. + +-- | Decode a Haskell type from a byte array containing its serialized +-- representation. +{-# INLINE deserialize #-} +deserialize :: Serialize a => Array Word8 -> (a, Array Word8) +deserialize arr = + let (a, b) = unsafeInlineIO $ MA.deserialize (unsafeThaw arr) + in (a, unsafeFreeze b) + +------------------------------------------------------------------------------- +-- Streams of Arrays +------------------------------------------------------------------------------- + +-- TODO: efficiently compare two streams of arrays. Two streams can have chunks +-- of different sizes, we can handle that in the stream comparison abstraction. +-- This could be useful e.g. to fast compare whether two files differ. + +-- | Insert the given element between arrays and flatten. +-- +-- >>> concatSepBy x = Stream.unfoldEachSepBy x Array.reader +-- +{-# INLINE concatSepBy #-} +concatSepBy, interpose :: (Monad m, Unbox a) => + a -> Stream m (Array a) -> Stream m a +concatSepBy x = D.unfoldEachSepBy x reader + +RENAME(interpose,concatSepBy) + +data FlattenState s = + OuterLoop s + | InnerLoop s !MutByteArray !Int !Int + +-- | Insert the given element after each array and flatten. This is similar to +-- unlines. +-- +-- >>> concatEndBy x = Stream.unfoldEachEndBy x Array.reader +-- +{-# INLINE_NORMAL concatEndBy #-} +concatEndBy, interposeSuffix :: forall m a. (Monad m, Unbox a) + => a -> Stream m (Array a) -> Stream m a +-- concatEndBy x = D.unfoldEachEndBy x reader +concatEndBy sep (D.Stream step state) = D.Stream step' (OuterLoop state) + + where + + {-# INLINE_LATE step' #-} + step' gst (OuterLoop st) = do + r <- step (adaptState gst) st + return $ case r of + D.Yield Array{..} s -> + D.Skip (InnerLoop s arrContents arrStart arrEnd) + D.Skip s -> D.Skip (OuterLoop s) + D.Stop -> D.Stop + + step' _ (InnerLoop st _ p end) | p == end = + return $ D.Yield sep $ OuterLoop st + + step' _ (InnerLoop st contents p end) = do + let !x = unsafeInlineIO $ peekAt p contents + return $ D.Yield x (InnerLoop st contents (INDEX_NEXT(p,a)) end) + +RENAME(interposeSuffix,concatEndBy) + +-- | Insert the given array after each array and flatten. +-- +-- >>> concatEndBySeq x = Stream.unfoldEachEndBySeq x Array.reader +-- +{-# INLINE concatEndBySeq #-} +concatEndBySeq, intercalateSuffix :: (Monad m, Unbox a) + => Array a -> Stream m (Array a) -> Stream m a +concatEndBySeq x = D.unfoldEachEndBySeq x reader + +RENAME(intercalateSuffix,concatEndBySeq) + +-- | @compactMax n@ coalesces adjacent arrays in the input stream +-- only if the combined size would be less than or equal to n. +-- +-- Generates unpinned arrays irrespective of the pinning status of input +-- arrays. +{-# INLINE_NORMAL compactMax #-} +compactMax, compactLE :: (MonadIO m, Unbox a) + => Int -> Stream m (Array a) -> Stream m (Array a) +compactMax n stream = + D.map unsafeFreeze $ MA.compactMax n $ D.map unsafeThaw stream + +RENAME(compactLE,compactMax) + +-- | Like 'compactMax' but generates pinned arrays. +{-# INLINE_NORMAL compactMax' #-} +compactMax', pinnedCompactLE :: (MonadIO m, Unbox a) + => Int -> Stream m (Array a) -> Stream m (Array a) +compactMax' n stream = + D.map unsafeFreeze $ MA.compactMax' n $ D.map unsafeThaw stream + +{-# DEPRECATED pinnedCompactLE "Please use compactMax' instead." #-} +{-# INLINE pinnedCompactLE #-} +pinnedCompactLE = compactMax' + +-- | Split a stream of byte arrays on a given separator byte, dropping the +-- separator and coalescing all the arrays between two separators into a single +-- array. +-- +{-# INLINE compactSepByByte_ #-} +compactSepByByte_, compactOnByte + :: (MonadIO m) + => Word8 + -> Stream m (Array Word8) + -> Stream m (Array Word8) +compactSepByByte_ byte = + fmap unsafeFreeze . MA.compactSepByByte_ byte . fmap unsafeThaw + +RENAME(compactOnByte,compactSepByByte_) + +-- | Like 'compactSepByByte_', but considers the separator in suffix position +-- instead of infix position. +{-# INLINE compactEndByByte_ #-} +compactEndByByte_, compactOnByteSuffix + :: (MonadIO m) + => Word8 + -> Stream m (Array Word8) + -> Stream m (Array Word8) +compactEndByByte_ byte = + fmap unsafeFreeze . MA.compactEndByByte_ byte . fmap unsafeThaw +-- compactEndByByte_ byte = chunksEndBy_ (== byte) . concat + +RENAME(compactOnByteSuffix,compactEndByByte_) + +-- XXX On windows we should compact on "\r\n". We can just compact on '\n' and +-- drop the last byte in each array if it is '\r'. + +-- | Compact byte arrays on newline character, dropping the newline char. +{-# INLINE compactEndByLn_ #-} +compactEndByLn_ :: MonadIO m + => Stream m (Array Word8) + -> Stream m (Array Word8) +compactEndByLn_ = compactEndByByte_ 10 + +------------------------------------------------------------------------------- +-- Folding Streams of Arrays +------------------------------------------------------------------------------- + +-- XXX This should not be used for breaking a stream as the D.cons used in +-- reconstructing the stream could be very bad for performance. This can only +-- be useful in folding without breaking. +{-# INLINE_NORMAL foldBreakChunks #-} +foldBreakChunks :: forall m a b. (MonadIO m, Unbox a) => + Fold m a b -> Stream m (Array a) -> m (b, Stream m (Array a)) +foldBreakChunks (Fold fstep initial _ final) stream@(Stream step state) = do + res <- initial + case res of + Fold.Partial fs -> go SPEC state fs + Fold.Done fb -> return $! (fb, stream) + + where + + {-# INLINE go #-} + go !_ st !fs = do + r <- step defState st + case r of + Stream.Yield (Array contents start end) s -> + let fp = Tuple' end contents + in goArray SPEC s fp start fs + Stream.Skip s -> go SPEC s fs + Stream.Stop -> do + b <- final fs + return (b, D.nil) + + goArray !_ s (Tuple' end _) !cur !fs + | cur == end = do + go SPEC s fs + goArray !_ st fp@(Tuple' end contents) !cur !fs = do + x <- liftIO $ peekAt cur contents + res <- fstep fs x + let next = INDEX_NEXT(cur,a) + case res of + Fold.Done b -> do + let arr = Array contents next end + return $! (b, D.cons arr (D.Stream step st)) + Fold.Partial fs1 -> goArray SPEC st fp next fs1 + +-- This may be more robust wrt fusion compared to unfoldMany? + +-- | Fold a stream of arrays using a 'Fold'. This is equivalent to the +-- following: +-- +-- >>> foldChunks f = Stream.fold f . Stream.unfoldEach Array.reader +-- +foldChunks :: (MonadIO m, Unbox a) => Fold m a b -> Stream m (Array a) -> m b +foldChunks f s = fmap fst (foldBreakChunks f s) +-- foldStream f = Stream.fold f . Stream.unfoldEach reader + +-- | Fold a stream of arrays using a 'Fold' and return the remaining stream. +-- +-- The following alternative to this function allows composing the fold using +-- the parser Monad: +-- +-- @ +-- foldBreakStreamK f s = +-- fmap (first (fromRight undefined)) +-- $ StreamK.parseBreakChunks (ParserK.adaptC (Parser.fromFold f)) s +-- @ +-- +-- We can compare perf and remove this one or define it in terms of that. +-- +foldBreak, foldBreakChunksK :: forall m a b. (MonadIO m, Unbox a) => + Fold m a b -> StreamK m (Array a) -> m (b, StreamK m (Array a)) +{- +foldBreakChunksK f s = + fmap (first (fromRight undefined)) + $ StreamK.parseBreakChunks (ParserK.adaptC (Parser.fromFold f)) s +-} +foldBreak (Fold fstep initial _ final) stream = do + res <- initial + case res of + Fold.Partial fs -> go fs stream + Fold.Done fb -> return (fb, stream) + + where + + {-# INLINE go #-} + go !fs st = do + let stop = (, StreamK.nil) <$> final fs + single a = yieldk a StreamK.nil + yieldk (Array contents start end) r = + let fp = Tuple' end contents + in goArray fs r fp start + in StreamK.foldStream defState yieldk single stop st + + goArray !fs st (Tuple' end _) !cur + | cur == end = do + go fs st + goArray !fs st fp@(Tuple' end contents) !cur = do + x <- liftIO $ peekAt cur contents + res <- fstep fs x + let next = INDEX_NEXT(cur,a) + case res of + Fold.Done b -> do + let arr = Array contents next end + return $! (b, StreamK.cons arr st) + Fold.Partial fs1 -> goArray fs1 st fp next + +RENAME(foldBreakChunksK,foldBreak) + +{- +-- This can be generalized to any type provided it can be unfolded to a stream +-- and it can be combined using a semigroup operation. +-- +{-# INLINE_NORMAL parseBreakD #-} +parseBreakD :: + forall m a b. (MonadIO m, MonadThrow m, Unbox a) + => PRD.Parser a m b + -> D.Stream m (Array.Array a) + -> m (b, D.Stream m (Array.Array a)) +parseBreakD + (PRD.Parser pstep initial extract) stream@(D.Stream step state) = do + + res <- initial + case res of + PRD.IPartial s -> go SPEC state (List []) s + PRD.IDone b -> return (b, stream) + PRD.IError err -> throwM $ ParseError err + + where + + -- "backBuf" contains last few items in the stream that we may have to + -- backtrack to. + -- + -- XXX currently we are using a dumb list based approach for backtracking + -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. + -- That will allow us more efficient random back and forth movement. + go !_ st backBuf !pst = do + r <- step defState st + case r of + D.Yield (Array contents start end) s -> + gobuf SPEC s backBuf + (Tuple' end contents) start pst + D.Skip s -> go SPEC s backBuf pst + D.Stop -> do + b <- extract pst + return (b, D.nil) + + -- Use strictness on "cur" to keep it unboxed + gobuf !_ s backBuf (Tuple' end _) !cur !pst + | cur == end = do + go SPEC s backBuf pst + gobuf !_ s backBuf fp@(Tuple' end contents) !cur !pst = do + x <- liftIO $ peekByteIndex contents cur + pRes <- pstep pst x + let next = INDEX_NEXT(cur,a) + case pRes of + PR.Partial 0 pst1 -> + gobuf SPEC s (List []) fp next pst1 + PR.Partial n pst1 -> do + assert (n <= Prelude.length (x:getList backBuf)) (return ()) + let src0 = Prelude.take n (x:getList backBuf) + arr0 = A.fromListN n (Prelude.reverse src0) + arr1 = Array contents next end + src = arr0 <> arr1 + let !(Array cont1 start end1) = src + fp1 = Tuple' end1 cont1 + gobuf SPEC s (List []) fp1 start pst1 + PR.Continue 0 pst1 -> + gobuf SPEC s (List (x:getList backBuf)) fp next pst1 + PR.Continue n pst1 -> do + assert (n <= Prelude.length (x:getList backBuf)) (return ()) + let (src0, buf1) = splitAt n (x:getList backBuf) + arr0 = A.fromListN n (Prelude.reverse src0) + arr1 = Array contents next end + src = arr0 <> arr1 + let !(Array cont1 start end1) = src + fp1 = Tuple' end1 cont1 + gobuf SPEC s (List buf1) fp1 start pst1 + PR.Done 0 b -> do + let arr = Array contents next end + return (b, D.cons arr (D.Stream step s)) + PR.Done n b -> do + assert (n <= Prelude.length (x:getList backBuf)) (return ()) + let src0 = Prelude.take n (x:getList backBuf) + -- XXX create the array in reverse instead + arr0 = A.fromListN n (Prelude.reverse src0) + arr1 = Array contents next end + -- XXX Use StreamK to avoid adding arbitrary layers of + -- constructors every time. + str = D.cons arr0 (D.cons arr1 (D.Stream step s)) + return (b, str) + PR.SError err -> throwM $ ParseError err + +-- | Parse an array stream using the supplied 'Parser'. Returns the parse +-- result and the unconsumed stream. Throws 'ParseError' if the parse fails. +-- +-- 'parseBreak' is an alternative to this function which allows composing the +-- parser using the parser Monad. +-- +-- We can compare perf and remove this one or define it in terms of that. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL parseBreakChunksK #-} +parseBreakChunksK :: + forall m a b. (MonadIO m, Unbox a) + => Parser a m b + -> StreamK m (Array a) + -> m (Either ParseError b, StreamK m (Array a)) +parseBreakChunksK (Parser pstep initial extract) stream = do + res <- initial + case res of + IPartial s -> go s stream [] + IDone b -> return (Right b, stream) + IError err -> return (Left (ParseError err), stream) + + where + + -- "backBuf" contains last few items in the stream that we may have to + -- backtrack to. + -- + -- XXX currently we are using a dumb list based approach for backtracking + -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. + -- That will allow us more efficient random back and forth movement. + go !pst st backBuf = do + let stop = goStop pst backBuf -- (, K.nil) <$> extract pst + single a = yieldk a StreamK.nil + yieldk arr r = goArray pst backBuf r arr + in StreamK.foldStream defState yieldk single stop st + + -- Use strictness on "cur" to keep it unboxed + goArray !pst backBuf st (Array _ cur end) | cur == end = go pst st backBuf + goArray !pst backBuf st (Array contents cur end) = do + x <- liftIO $ peekAt cur contents + pRes <- pstep pst x + let next = INDEX_NEXT(cur,a) + case pRes of + Parser.SPartial 1 s -> + goArray s [] st (Array contents next end) + Parser.SPartial m s -> do + assertM(m <= 1) + let n = 1 - m + assert (n <= Prelude.length (x:backBuf)) (return ()) + let src0 = Prelude.take n (x:backBuf) + arr0 = fromListN n (Prelude.reverse src0) + arr1 = Array contents next end + src = arr0 <> arr1 + goArray s [] st src + Parser.SContinue 1 s -> + goArray s (x:backBuf) st (Array contents next end) + Parser.SContinue m s -> do + assertM(m <= 1) + let n = 1 - m + assert (n <= Prelude.length (x:backBuf)) (return ()) + let (src0, buf1) = Prelude.splitAt n (x:backBuf) + arr0 = fromListN n (Prelude.reverse src0) + arr1 = Array contents next end + src = arr0 <> arr1 + goArray s buf1 st src + Parser.SDone 1 b -> do + let arr = Array contents next end + return (Right b, StreamK.cons arr st) + Parser.SDone m b -> do + assertM(m <= 1) + let n = 1 - m + assert (n <= Prelude.length (x:backBuf)) (return ()) + let src0 = Prelude.take n (x:backBuf) + -- XXX Use fromListRevN once implemented + -- arr0 = A.fromListRevN n src0 + arr0 = fromListN n (Prelude.reverse src0) + arr1 = Array contents next end + str = StreamK.cons arr0 (StreamK.cons arr1 st) + return (Right b, str) + Parser.SError err -> do + let n = Prelude.length backBuf + arr0 = fromListN n (Prelude.reverse backBuf) + arr1 = Array contents cur end + str = StreamK.cons arr0 (StreamK.cons arr1 st) + return (Left (ParseError err), str) + + -- This is a simplified goArray + goExtract !pst backBuf (Array _ cur end) + | cur == end = goStop pst backBuf + goExtract !pst backBuf (Array contents cur end) = do + x <- liftIO $ peekAt cur contents + pRes <- pstep pst x + let next = INDEX_NEXT(cur,a) + case pRes of + Parser.SPartial 0 s -> + goExtract s [] (Array contents next end) + Parser.SPartial m s -> do + assertM(m <= 0) + let n = negate m + assert (n <= Prelude.length (x:backBuf)) (return ()) + let src0 = Prelude.take n (x:backBuf) + arr0 = fromListN n (Prelude.reverse src0) + arr1 = Array contents next end + src = arr0 <> arr1 + goExtract s [] src + Parser.SContinue 0 s -> + goExtract s backBuf (Array contents next end) + Parser.SContinue m s -> do + assertM(m <= 0) + let n = negate m + assert (n <= Prelude.length (x:backBuf)) (return ()) + let (src0, buf1) = Prelude.splitAt n (x:backBuf) + arr0 = fromListN n (Prelude.reverse src0) + arr1 = Array contents next end + src = arr0 <> arr1 + goExtract s buf1 src + Parser.SDone 0 b -> do + let arr = Array contents next end + return (Right b, StreamK.fromPure arr) + Parser.SDone m b -> do + assertM(m <= 0) + let n = negate m + assert (n <= Prelude.length backBuf) (return ()) + let src0 = Prelude.take n (x:backBuf) + -- XXX Use fromListRevN once implemented + -- arr0 = A.fromListRevN n src0 + arr0 = fromListN n (Prelude.reverse src0) + arr1 = Array contents next end + str = StreamK.cons arr0 (StreamK.fromPure arr1) + return (Right b, str) + Parser.SError err -> do + let n = Prelude.length backBuf + arr0 = fromListN n (Prelude.reverse backBuf) + arr1 = Array contents cur end + str = StreamK.cons arr0 (StreamK.fromPure arr1) + return (Left (ParseError err), str) + + -- This is a simplified goExtract + {-# INLINE goStop #-} + goStop !pst backBuf = do + pRes <- extract pst + case pRes of + Parser.SPartial _ _ -> error "Bug: parseBreak: Partial in extract" + Parser.SContinue 0 s -> + goStop s backBuf + Parser.SContinue m s -> do + assertM(m <= 0) + let n = negate m + assert (n <= Prelude.length backBuf) (return ()) + let (src0, buf1) = Prelude.splitAt n backBuf + arr = fromListN n (Prelude.reverse src0) + goExtract s buf1 arr + Parser.SDone 0 b -> + return (Right b, StreamK.nil) + Parser.SDone m b -> do + assertM(m <= 0) + let n = negate m + assert (n <= Prelude.length backBuf) (return ()) + let src0 = Prelude.take n backBuf + -- XXX Use fromListRevN once implemented + -- arr0 = A.fromListRevN n src0 + arr0 = fromListN n (Prelude.reverse src0) + return (Right b, StreamK.fromPure arr0) + Parser.SError err -> do + let n = Prelude.length backBuf + arr0 = fromListN n (Prelude.reverse backBuf) + return (Left (ParseError err), StreamK.fromPure arr0) +-} + +-- | Run a 'ParserK' over a 'StreamK' of Arrays and return the parse result and +-- the remaining Stream. +{-# INLINE parseBreak #-} +parseBreak + :: (Monad m, Unbox a) + => ParserK (Array a) m b + -> StreamK m (Array a) + -> m (Either ParseError b, StreamK m (Array a)) +parseBreak = Drivers.parseBreakChunks + +-- | Like 'parseBreak' but includes stream position information in the error +-- messages. +-- +{-# INLINE parseBreakPos #-} +parseBreakPos + :: (Monad m, Unbox a) + => ParserK (Array a) m b + -> StreamK m (Array a) + -> m (Either ParseErrorPos b, StreamK m (Array a)) +parseBreakPos = Drivers.parseBreakChunksPos + +{-# INLINE parse #-} +parse :: (Monad m, Unbox a) => + ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) +parse f = fmap fst . parseBreak f + +-- | Like 'parse' but includes stream position information in the error +-- messages. +-- +{-# INLINE parsePos #-} +parsePos :: (Monad m, Unbox a) => + ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseErrorPos b) +parsePos f = fmap fst . parseBreakPos f + +------------------------------------------------------------------------------- +-- Convert ParserD to ParserK +------------------------------------------------------------------------------- + +{-# INLINE adaptCWith #-} +adaptCWith + :: forall m a s b r. (Monad m, Unbox a) + => (s -> a -> m (ParserD.Step s b)) + -> m (ParserD.Initial s b) + -> (s -> m (ParserD.Final s b)) + -> (ParseResult b -> Int -> Input (Array a) -> m (Step (Array a) m r)) + -> Int + -> Int + -> Input (Array a) + -> m (Step (Array a) m r) +adaptCWith pstep initial extract cont !offset0 !usedCount !input = do + res <- initial + case res of + ParserD.IPartial pst -> do + case input of + Chunk arr -> parseContChunk usedCount offset0 pst arr + None -> parseContNothing usedCount pst + ParserD.IDone b -> cont (Success offset0 b) usedCount input + ParserD.IError err -> cont (Failure offset0 err) usedCount input + + where + + -- XXX We can maintain an absolute position instead of relative that will + -- help in reporting of error location in the stream. + {-# NOINLINE parseContChunk #-} + parseContChunk !count !offset !state arr@(Array contents start end) = do + if offset >= 0 + then go SPEC (start + offset * SIZE_OF(a)) state + else return $ Continue offset (parseCont count state) + + where + + {-# INLINE onDone #-} + onDone n b = + assert (n <= length arr) + (cont (Success n b) (count + n - offset) (Chunk arr)) + + {-# INLINE callParseCont #-} + callParseCont constr n pst1 = + assert (n < 0 || n >= length arr) + (return $ constr n (parseCont (count + n - offset) pst1)) + + {-# INLINE onPartial #-} + onPartial = callParseCont Partial + + {-# INLINE onContinue #-} + onContinue = callParseCont Continue + + {-# INLINE onError #-} + onError n err = + cont (Failure n err) (count + n - offset) (Chunk arr) + + {-# INLINE onBack #-} + onBack offset1 elemSize constr pst = do + let pos = offset1 - start + in if pos >= 0 + then go SPEC offset1 pst + else constr (pos `div` elemSize) pst + + -- Note: div may be expensive but the alternative is to maintain an element + -- offset in addition to a byte offset or just the element offset and use + -- multiplication to get the byte offset every time, both these options + -- turned out to be more expensive than using div. + go !_ !cur !pst | cur >= end = + onContinue ((end - start) `div` SIZE_OF(a)) pst + go !_ !cur !pst = do + let !x = unsafeInlineIO $ peekAt cur contents + pRes <- pstep pst x + let elemSize = SIZE_OF(a) + next = INDEX_NEXT(cur,a) + move n = cur + n * elemSize + curOff = (cur - start) `div` elemSize + nextOff = (next - start) `div` elemSize + case pRes of + ParserD.SDone 1 b -> + onDone nextOff b + ParserD.SDone 0 b -> + onDone curOff b + ParserD.SDone n b -> + onDone ((move n - start) `div` elemSize) b + ParserD.SPartial 1 pst1 -> + go SPEC next pst1 + ParserD.SPartial 0 pst1 -> + go SPEC cur pst1 + ParserD.SPartial n pst1 -> + onBack (move n) elemSize onPartial pst1 + ParserD.SContinue 1 pst1 -> + go SPEC next pst1 + ParserD.SContinue 0 pst1 -> + go SPEC cur pst1 + ParserD.SContinue n pst1 -> + onBack (move n) elemSize onContinue pst1 + ParserD.SError err -> + onError curOff err + + {-# NOINLINE parseContNothing #-} + parseContNothing !count !pst = do + r <- extract pst + case r of + ParserD.FDone n b -> + assert (n <= 0) (cont (Success n b) (count + n) None) + ParserD.FContinue n pst1 -> + assert (n <= 0) + (return $ Continue n (parseCont (count + n) pst1)) + ParserD.FError err -> + -- XXX It is called only when there is no input arr. So using 0 + -- as the position is correct? + cont (Failure 0 err) count None + + -- XXX Maybe we can use two separate continuations instead of using + -- Just/Nothing cases here. That may help in avoiding the parseContJust + -- function call. + {-# INLINE parseCont #-} + parseCont !cnt !pst (Chunk arr) = parseContChunk cnt 0 pst arr + parseCont !cnt !pst None = parseContNothing cnt pst + +-- | Convert a 'Parser' to 'ParserK' working on an Array stream. +-- +-- /Pre-release/ +-- +{-# INLINE_LATE toParserK #-} +toParserK :: (Monad m, Unbox a) => ParserD.Parser a m b -> ParserK (Array a) m b +toParserK (ParserD.Parser step initial extract) = + ParserK.MkParser $ adaptCWith step initial extract diff --git a/src/Streamly/Internal/Data/Array/Generic.hs b/src/Streamly/Internal/Data/Array/Generic.hs --- a/src/Streamly/Internal/Data/Array/Generic.hs +++ b/src/Streamly/Internal/Data/Array/Generic.hs @@ -4,278 +4,64 @@ -- -- License : BSD-3-Clause -- Maintainer : streamly@composewell.com --- Stability : pre-release -- Portability : GHC -- module Streamly.Internal.Data.Array.Generic - ( Array(..) - - -- * Construction - , nil - , writeN - , write - , writeWith - , writeLastN - - , fromStreamN - , fromStream - - , fromListN - , fromList - - -- * Elimination - , length - , reader - - , toList - , read - , readRev - - , foldl' - , foldr - , streamFold - , fold + ( + module Streamly.Internal.Data.Array.Generic.Type - -- * Random Access - , getIndexUnsafe - , getSliceUnsafe - , strip + -- * Parsing Stream of Arrays + , parse + , parsePos + , parseBreak + , parseBreakPos ) where -#include "inline.hs" - -import Control.Monad (replicateM) -import Control.Monad.IO.Class (MonadIO) -import GHC.Base (MutableArray#, RealWorld) -import GHC.IO (unsafePerformIO) -import Text.Read (readPrec) - -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Streamly.Internal.System.IO (unsafeInlineIO) - -import qualified Streamly.Internal.Data.Array.Generic.Mut.Type as MArray -import qualified Streamly.Internal.Data.Fold.Type as FL -import qualified Streamly.Internal.Data.Producer.Type as Producer -import qualified Streamly.Internal.Data.Producer as Producer -import qualified Streamly.Internal.Data.Ring as RB -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamD.Generate as D -import qualified Text.ParserCombinators.ReadPrec as ReadPrec - -import Prelude hiding (foldr, length, read) - -------------------------------------------------------------------------------- --- Array Data Type -------------------------------------------------------------------------------- - -data Array a = - Array - { arrContents# :: MutableArray# RealWorld a - -- ^ The internal contents of the array representing the entire array. - - , arrStart :: {-# UNPACK #-}!Int - -- ^ The starting index of this slice. - - , arrLen :: {-# UNPACK #-}!Int - -- ^ The length of this slice. - } - -unsafeFreeze :: MArray.MutArray a -> Array a -unsafeFreeze (MArray.MutArray cont# arrS arrL _) = Array cont# arrS arrL - -unsafeThaw :: Array a -> MArray.MutArray a -unsafeThaw (Array cont# arrS arrL) = MArray.MutArray cont# arrS arrL arrL - -{-# NOINLINE nil #-} -nil :: Array a -nil = unsafePerformIO $ unsafeFreeze <$> MArray.nil - -------------------------------------------------------------------------------- --- Construction - Folds -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL writeN #-} -writeN :: MonadIO m => Int -> Fold m a (Array a) -writeN = fmap unsafeFreeze <$> MArray.writeN - -{-# INLINE_NORMAL writeWith #-} -writeWith :: MonadIO m => Int -> Fold m a (Array a) -writeWith elemCount = unsafeFreeze <$> MArray.writeWith elemCount - --- | Fold the whole input to a single array. --- --- /Caution! Do not use this on infinite streams./ --- -{-# INLINE write #-} -write :: MonadIO m => Fold m a (Array a) -write = fmap unsafeFreeze MArray.write - -------------------------------------------------------------------------------- --- Construction - from streams -------------------------------------------------------------------------------- - -{-# INLINE fromStreamN #-} -fromStreamN :: MonadIO m => Int -> Stream m a -> m (Array a) -fromStreamN n = D.fold (writeN n) - -{-# INLINE fromStream #-} -fromStream :: MonadIO m => Stream m a -> m (Array a) -fromStream = D.fold write - --- XXX Consider foldr/build fusion in toList/fromList - -{-# INLINABLE fromListN #-} -fromListN :: Int -> [a] -> Array a -fromListN n xs = unsafePerformIO $ fromStreamN n $ D.fromList xs - -{-# INLINABLE fromList #-} -fromList :: [a] -> Array a -fromList xs = unsafePerformIO $ fromStream $ D.fromList xs - -------------------------------------------------------------------------------- --- Elimination - Unfolds -------------------------------------------------------------------------------- - -{-# INLINE length #-} -length :: Array a -> Int -length = arrLen - -{-# INLINE_NORMAL reader #-} -reader :: Monad m => Unfold m (Array a) a -reader = - Producer.simplify - $ Producer.translate unsafeThaw unsafeFreeze - $ MArray.producerWith (return . unsafeInlineIO) - -------------------------------------------------------------------------------- --- Elimination - to streams -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL toList #-} -toList :: Array a -> [a] -toList arr = loop 0 - - where - - len = length arr - loop i | i == len = [] - loop i = getIndexUnsafe i arr : loop (i + 1) +import Streamly.Internal.Data.Parser (ParseError(..), ParseErrorPos(..)) +import Streamly.Internal.Data.StreamK.Type (StreamK) -{-# INLINE_NORMAL read #-} -read :: Monad m => Array a -> Stream m a -read arr@Array{..} = - D.map (`getIndexUnsafe` arr) $ D.enumerateFromToIntegral 0 (arrLen - 1) +import qualified Streamly.Internal.Data.ParserDrivers as Drivers +import qualified Streamly.Internal.Data.ParserK.Type as ParserK -{-# INLINE_NORMAL readRev #-} -readRev :: Monad m => Array a -> Stream m a -readRev arr@Array{..} = - D.map (`getIndexUnsafe` arr) - $ D.enumerateFromThenToIntegral (arrLen - 1) (arrLen - 2) 0 +import Prelude hiding (Foldable(..), read) +import Streamly.Internal.Data.Array.Generic.Type ------------------------------------------------------------------------------- --- Elimination - using Folds +-- ParserK Chunked Generic ------------------------------------------------------------------------------- -{-# INLINE_NORMAL foldl' #-} -foldl' :: (b -> a -> b) -> b -> Array a -> b -foldl' f z arr = unsafePerformIO $ D.foldl' f z $ read arr - -{-# INLINE_NORMAL foldr #-} -foldr :: (a -> b -> b) -> b -> Array a -> b -foldr f z arr = unsafePerformIO $ D.foldr f z $ read arr - -{-# INLINE fold #-} -fold :: Monad m => Fold m a b -> Array a -> m b -fold f arr = D.fold f (read arr) - -{-# INLINE streamFold #-} -streamFold :: Monad m => (Stream m a -> m b) -> Array a -> m b -streamFold f arr = f (read arr) - -------------------------------------------------------------------------------- --- Random reads and writes -------------------------------------------------------------------------------- +{-# INLINE parseBreak #-} +parseBreak + :: forall m a b. Monad m + => ParserK.ParserK (Array a) m b + -> StreamK m (Array a) + -> m (Either ParseError b, StreamK m (Array a)) +parseBreak = Drivers.parseBreakChunksGeneric --- | /O(1)/ Lookup the element at the given index. Index starts from 0. Does --- not check the bounds. +-- | Like 'parseBreak' but includes stream position information in the error +-- messages. -- --- @since 0.8.0 -{-# INLINE getIndexUnsafe #-} -getIndexUnsafe :: Int -> Array a -> a -getIndexUnsafe i arr = - unsafePerformIO $ MArray.getIndexUnsafe i (unsafeThaw arr) - -{-# INLINE writeLastN #-} -writeLastN :: MonadIO m => Int -> Fold m a (Array a) -writeLastN n = FL.rmapM f (RB.writeLastN n) - - where - - f rb = do - arr <- RB.toMutArray 0 n rb - return $ unsafeFreeze arr - -{-# INLINE getSliceUnsafe #-} -getSliceUnsafe :: Int -> Int -> Array a -> Array a -getSliceUnsafe offset len (Array cont off1 _) = Array cont (off1 + offset) len - --- XXX This is not efficient as it copies the array. We should support array --- slicing so that we can just refer to the underlying array memory instead of --- copying. - --- | Truncate the array at the beginning and end as long as the predicate --- holds true. Returns a slice of the original array. -{-# INLINE strip #-} -strip :: (a -> Bool) -> Array a -> Array a -strip p arr = unsafeFreeze $ unsafePerformIO $ MArray.strip p (unsafeThaw arr) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance Eq a => Eq (Array a) where - {-# INLINE (==) #-} - arr1 == arr2 = - unsafeInlineIO $! unsafeThaw arr1 `MArray.eq` unsafeThaw arr2 - -instance Ord a => Ord (Array a) where - {-# INLINE compare #-} - compare arr1 arr2 = - unsafeInlineIO $! unsafeThaw arr1 `MArray.cmp` unsafeThaw arr2 - - -- Default definitions defined in base do not have an INLINE on them, so we - -- replicate them here with an INLINE. - {-# INLINE (<) #-} - x < y = case compare x y of { LT -> True; _ -> False } - - {-# INLINE (<=) #-} - x <= y = case compare x y of { GT -> False; _ -> True } - - {-# INLINE (>) #-} - x > y = case compare x y of { GT -> True; _ -> False } - - {-# INLINE (>=) #-} - x >= y = case compare x y of { LT -> False; _ -> True } - - -- These two default methods use '<=' rather than 'compare' - -- because the latter is often more expensive - {-# INLINE max #-} - max x y = if x <= y then y else x - - {-# INLINE min #-} - min x y = if x <= y then x else y +{-# INLINE parseBreakPos #-} +parseBreakPos + :: forall m a b. Monad m + => ParserK.ParserK (Array a) m b + -> StreamK m (Array a) + -> m (Either ParseErrorPos b, StreamK m (Array a)) +parseBreakPos = Drivers.parseBreakChunksGenericPos -instance Show a => Show (Array a) where - {-# INLINE show #-} - show arr = "fromList " ++ show (toList arr) +{-# INLINE parse #-} +parse :: + (Monad m) + => ParserK.ParserK (Array a) m b + -> StreamK m (Array a) + -> m (Either ParseError b) +parse f = fmap fst . parseBreak f -instance Read a => Read (Array a) where - {-# INLINE readPrec #-} - readPrec = do - fromListWord <- replicateM 9 ReadPrec.get - if fromListWord == "fromList " - then fromList <$> readPrec - else ReadPrec.pfail +{-# INLINE parsePos #-} +parsePos :: + (Monad m) + => ParserK.ParserK (Array a) m b + -> StreamK m (Array a) + -> m (Either ParseErrorPos b) +parsePos f = fmap fst . parseBreakPos f diff --git a/src/Streamly/Internal/Data/Array/Generic/Mut/Type.hs b/src/Streamly/Internal/Data/Array/Generic/Mut/Type.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Array/Generic/Mut/Type.hs +++ /dev/null @@ -1,796 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UnboxedTuples #-} --- | --- Module : Streamly.Internal.Data.Array.Generic.Mut.Type --- Copyright : (c) 2020 Composewell Technologies --- License : BSD3-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Array.Generic.Mut.Type -( - -- * Type - -- $arrayNotes - MutArray (..) - - -- * Constructing and Writing - -- ** Construction - , nil - - -- *** Uninitialized Arrays - , new - -- , newArrayWith - - -- *** From streams - , writeNUnsafe - , writeN - , writeWith - , write - - -- , writeRevN - -- , writeRev - - -- ** From containers - -- , fromListN - -- , fromList - -- , fromStreamDN - -- , fromStreamD - - -- * Random writes - , putIndex - , putIndexUnsafe - , putIndices - -- , putFromThenTo - -- , putFrom -- start writing at the given position - -- , putUpto -- write from beginning up to the given position - -- , putFromTo - -- , putFromRev - -- , putUptoRev - , modifyIndexUnsafe - , modifyIndex - -- , modifyIndices - -- , modify - -- , swapIndices - - -- * Growing and Shrinking - -- Arrays grow only at the end, though it is possible to grow on both sides - -- and therefore have a cons as well as snoc. But that will require two - -- bounds in the array representation. - - -- ** Reallocation - , realloc - , uninit - - -- ** Appending elements - , snocWith - , snoc - -- , snocLinear - -- , snocMay - , snocUnsafe - - -- ** Appending streams - -- , writeAppendNUnsafe - -- , writeAppendN - -- , writeAppendWith - -- , writeAppend - - -- ** Truncation - -- These are not the same as slicing the array at the beginning, they may - -- reduce the length as well as the capacity of the array. - -- , truncateWith - -- , truncate - -- , truncateExp - - -- * Eliminating and Reading - - -- ** Unfolds - , reader - -- , readerRev - , producerWith -- experimental - , producer -- experimental - - -- ** To containers - , toStreamD - , readRev - , toStreamK - -- , toStreamKRev - , toList - - -- ** Random reads - , getIndex - , getIndexUnsafe - -- , getIndices - -- , getFromThenTo - -- , getIndexRev - - -- * Size - , length - - -- * In-place Mutation Algorithms - , strip - -- , reverse - -- , permute - -- , partitionBy - -- , shuffleBy - -- , divideBy - -- , mergeBy - - -- * Folding - -- , foldl' - -- , foldr - , cmp - , eq - - -- * Arrays of arrays - -- We can add dimensionality parameter to the array type to get - -- multidimensional arrays. Multidimensional arrays would just be a - -- convenience wrapper on top of single dimensional arrays. - - -- | Operations dealing with multiple arrays, streams of arrays or - -- multidimensional array representations. - - -- ** Construct from streams - -- , chunksOf - -- , arrayStreamKFromStreamD - -- , writeChunks - - -- ** Eliminate to streams - -- , flattenArrays - -- , flattenArraysRev - -- , fromArrayStreamK - - -- ** Construct from arrays - -- get chunks without copying - , getSliceUnsafe - , getSlice - -- , getSlicesFromLenN - -- , splitAt -- XXX should be able to express using getSlice - -- , breakOn - - -- ** Appending arrays - -- , spliceCopy - -- , spliceWith - -- , splice - -- , spliceExp - , putSliceUnsafe - -- , appendSlice - -- , appendSliceFrom - - , clone - ) -where - -#include "inline.hs" -#include "assert.hs" - -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO(..)) -import GHC.Base - ( MutableArray# - , RealWorld - , copyMutableArray# - , newArray# - , readArray# - , writeArray# - ) -import GHC.IO (IO(..)) -import GHC.Int (Int(..)) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Producer.Type (Producer (..)) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) - -import qualified Streamly.Internal.Data.Fold.Type as FL -import qualified Streamly.Internal.Data.Producer as Producer -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamD.Generate as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - -import Prelude hiding (read, length) - -#include "DocTestDataMutArrayGeneric.hs" - -------------------------------------------------------------------------------- --- MutArray Data Type -------------------------------------------------------------------------------- - -data MutArray a = - MutArray - { arrContents# :: MutableArray# RealWorld a - -- ^ The internal contents of the array representing the entire array. - - , arrStart :: {-# UNPACK #-}!Int - -- ^ The starting index of this slice. - - , arrLen :: {-# UNPACK #-}!Int - -- ^ The length of this slice. - - , arrTrueLen :: {-# UNPACK #-}!Int - -- ^ This is the true length of the array. Coincidentally, this also - -- represents the first index beyond the maximum acceptable index of - -- the array. This is specific to the array contents itself and not - -- dependent on the slice. This value should not change and is shared - -- across all the slices. - } - -{-# INLINE bottomElement #-} -bottomElement :: a -bottomElement = - error - $ unwords - [ funcName - , "This is the bottom element of the array." - , "This is a place holder and should never be reached!" - ] - - where - - funcName = "Streamly.Internal.Data.Array.Generic.Mut.Type.bottomElement:" - --- XXX Would be nice if GHC can provide something like newUninitializedArray# so --- that we do not have to write undefined or error in the whole array. - --- | @new count@ allocates a zero length array that can be extended to hold --- up to 'count' items without reallocating. --- --- /Pre-release/ -{-# INLINE new #-} -new :: MonadIO m => Int -> m (MutArray a) -new n@(I# n#) = - liftIO - $ IO - $ \s# -> - case newArray# n# bottomElement s# of - (# s1#, arr# #) -> - let ma = MutArray arr# 0 0 n - in (# s1#, ma #) - --- XXX This could be pure? - --- | --- Definition: --- --- >>> nil = MutArray.new 0 -{-# INLINE nil #-} -nil :: MonadIO m => m (MutArray a) -nil = new 0 - -------------------------------------------------------------------------------- --- Random writes -------------------------------------------------------------------------------- - --- | Write the given element to the given index of the array. Does not check if --- the index is out of bounds of the array. --- --- /Pre-release/ -{-# INLINE putIndexUnsafe #-} -putIndexUnsafe :: forall m a. MonadIO m => Int -> MutArray a -> a -> m () -putIndexUnsafe i MutArray {..} x = - assert (i >= 0 && i < arrLen) - (liftIO - $ IO - $ \s# -> - case i + arrStart of - I# n# -> - let s1# = writeArray# arrContents# n# x s# - in (# s1#, () #)) - -invalidIndex :: String -> Int -> a -invalidIndex label i = - error $ label ++ ": invalid array index " ++ show i - --- | /O(1)/ Write the given element at the given index in the array. --- Performs in-place mutation of the array. --- --- >>> putIndex ix arr val = MutArray.modifyIndex ix arr (const (val, ())) --- --- /Pre-release/ -{-# INLINE putIndex #-} -putIndex :: MonadIO m => Int -> MutArray a -> a -> m () -putIndex i arr@MutArray {..} x = - if i >= 0 && i < arrLen - then putIndexUnsafe i arr x - else invalidIndex "putIndex" i - --- | Write an input stream of (index, value) pairs to an array. Throws an --- error if any index is out of bounds. --- --- /Pre-release/ -{-# INLINE putIndices #-} -putIndices :: MonadIO m - => MutArray a -> Fold m (Int, a) () -putIndices arr = FL.foldlM' step (return ()) - - where - - step () (i, x) = liftIO (putIndex i arr x) - --- | Modify a given index of an array using a modifier function without checking --- the bounds. --- --- Unsafe because it does not check the bounds of the array. --- --- /Pre-release/ -modifyIndexUnsafe :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b -modifyIndexUnsafe i MutArray {..} f = do - liftIO - $ IO - $ \s# -> - case i + arrStart of - I# n# -> - case readArray# arrContents# n# s# of - (# s1#, a #) -> - let (a1, b) = f a - s2# = writeArray# arrContents# n# a1 s1# - in (# s2#, b #) - --- | Modify a given index of an array using a modifier function. --- --- /Pre-release/ -modifyIndex :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b -modifyIndex i arr@MutArray {..} f = do - if i >= 0 && i < arrLen - then modifyIndexUnsafe i arr f - else invalidIndex "modifyIndex" i - -------------------------------------------------------------------------------- --- Resizing -------------------------------------------------------------------------------- - --- | Reallocates the array according to the new size. This is a safe function --- that always creates a new array and copies the old array into the new one. --- If the reallocated size is less than the original array it results in a --- truncated version of the original array. --- -realloc :: MonadIO m => Int -> MutArray a -> m (MutArray a) -realloc n arr = do - arr1 <- new n - let !newLen@(I# newLen#) = min n (arrLen arr) - !(I# arrS#) = arrStart arr - !(I# arr1S#) = arrStart arr1 - arrC# = arrContents# arr - arr1C# = arrContents# arr1 - liftIO - $ IO - $ \s# -> - let s1# = copyMutableArray# arrC# arrS# arr1C# arr1S# newLen# s# - in (# s1#, arr1 {arrLen = newLen, arrTrueLen = n} #) - -reallocWith :: - MonadIO m => String -> (Int -> Int) -> Int -> MutArray a -> m (MutArray a) -reallocWith label sizer reqSize arr = do - let oldSize = arrLen arr - newSize = sizer oldSize - safeSize = max newSize (oldSize + reqSize) - assert (newSize >= oldSize + reqSize || error badSize) (return ()) - realloc safeSize arr - - where - - badSize = concat - [ label - , ": new array size is less than required size " - , show reqSize - , ". Please check the sizing function passed." - ] - -------------------------------------------------------------------------------- --- Snoc -------------------------------------------------------------------------------- - --- XXX Not sure of the behavior of writeArray# if we specify an index which is --- out of bounds. This comment should be rewritten based on that. --- | Really really unsafe, appends the element into the first array, may --- cause silent data corruption or if you are lucky a segfault if the index --- is out of bounds. --- --- /Internal/ -{-# INLINE snocUnsafe #-} -snocUnsafe :: MonadIO m => MutArray a -> a -> m (MutArray a) -snocUnsafe arr@MutArray {..} a = do - assert (arrStart + arrLen < arrTrueLen) (return ()) - let arr1 = arr {arrLen = arrLen + 1} - putIndexUnsafe arrLen arr1 a - return arr1 - --- NOINLINE to move it out of the way and not pollute the instruction cache. -{-# NOINLINE snocWithRealloc #-} -snocWithRealloc :: MonadIO m => (Int -> Int) -> MutArray a -> a -> m (MutArray a) -snocWithRealloc sizer arr x = do - arr1 <- reallocWith "snocWithRealloc" sizer 1 arr - snocUnsafe arr1 x - --- | @snocWith sizer arr elem@ mutates @arr@ to append @elem@. The length of --- the array increases by 1. --- --- If there is no reserved space available in @arr@ it is reallocated to a size --- in bytes determined by the @sizer oldSize@ function, where @oldSize@ is the --- original size of the array. --- --- Note that the returned array may be a mutated version of the original array. --- --- /Pre-release/ -{-# INLINE snocWith #-} -snocWith :: MonadIO m => (Int -> Int) -> MutArray a -> a -> m (MutArray a) -snocWith sizer arr@MutArray {..} x = do - if arrStart + arrLen < arrTrueLen - then snocUnsafe arr x - else snocWithRealloc sizer arr x - --- XXX round it to next power of 2. - --- | The array is mutated to append an additional element to it. If there is no --- reserved space available in the array then it is reallocated to double the --- original size. --- --- This is useful to reduce allocations when appending unknown number of --- elements. --- --- Note that the returned array may be a mutated version of the original array. --- --- >>> snoc = MutArray.snocWith (* 2) --- --- Performs O(n * log n) copies to grow, but is liberal with memory allocation. --- --- /Pre-release/ -{-# INLINE snoc #-} -snoc :: MonadIO m => MutArray a -> a -> m (MutArray a) -snoc = snocWith (* 2) - --- | Make the uninitialized memory in the array available for use extending it --- by the supplied length beyond the current length of the array. The array may --- be reallocated. --- -{-# INLINE uninit #-} -uninit :: MonadIO m => MutArray a -> Int -> m (MutArray a) -uninit arr@MutArray{..} len = - if arrStart + arrLen + len <= arrTrueLen - then return $ arr {arrLen = arrLen + len} - else realloc (arrLen + len) arr - -------------------------------------------------------------------------------- --- Random reads -------------------------------------------------------------------------------- - --- | Return the element at the specified index without checking the bounds. --- --- Unsafe because it does not check the bounds of the array. -{-# INLINE_NORMAL getIndexUnsafe #-} -getIndexUnsafe :: MonadIO m => Int -> MutArray a -> m a -getIndexUnsafe n MutArray {..} = - liftIO - $ IO - $ \s# -> - let !(I# i#) = arrStart + n - in readArray# arrContents# i# s# - --- | /O(1)/ Lookup the element at the given index. Index starts from 0. --- -{-# INLINE getIndex #-} -getIndex :: MonadIO m => Int -> MutArray a -> m a -getIndex i arr@MutArray {..} = - if i >= 0 && i < arrLen - then getIndexUnsafe i arr - else invalidIndex "getIndex" i - -------------------------------------------------------------------------------- --- Subarrays -------------------------------------------------------------------------------- - --- XXX We can also get immutable slices. - --- | /O(1)/ Slice an array in constant time. --- --- Unsafe: The bounds of the slice are not checked. --- --- /Unsafe/ --- --- /Pre-release/ -{-# INLINE getSliceUnsafe #-} -getSliceUnsafe - :: Int -- ^ from index - -> Int -- ^ length of the slice - -> MutArray a - -> MutArray a -getSliceUnsafe index len arr@MutArray {..} = - assert (index >= 0 && len >= 0 && index + len <= arrLen) - $ arr {arrStart = arrStart + index, arrLen = len} - --- | /O(1)/ Slice an array in constant time. Throws an error if the slice --- extends out of the array bounds. --- --- /Pre-release/ -{-# INLINE getSlice #-} -getSlice - :: Int -- ^ from index - -> Int -- ^ length of the slice - -> MutArray a - -> MutArray a -getSlice index len arr@MutArray{..} = - if index >= 0 && len >= 0 && index + len <= arrLen - then arr {arrStart = arrStart + index, arrLen = len} - else error - $ "getSlice: invalid slice, index " - ++ show index ++ " length " ++ show len - -------------------------------------------------------------------------------- --- to Lists and streams -------------------------------------------------------------------------------- - --- XXX Maybe faster to create a list explicitly instead of mapM, if list fusion --- does not work well. - --- | Convert an 'Array' into a list. --- --- /Pre-release/ -{-# INLINE toList #-} -toList :: MonadIO m => MutArray a -> m [a] -toList arr@MutArray{..} = mapM (`getIndexUnsafe` arr) [0 .. (arrLen - 1)] - --- | Use the 'read' unfold instead. --- --- @toStreamD = D.unfold read@ --- --- We can try this if the unfold has any performance issues. -{-# INLINE_NORMAL toStreamD #-} -toStreamD :: MonadIO m => MutArray a -> D.Stream m a -toStreamD arr@MutArray{..} = - D.mapM (`getIndexUnsafe` arr) $ D.enumerateFromToIntegral 0 (arrLen - 1) - --- Check equivalence with StreamK.fromStream . toStreamD and remove -{-# INLINE toStreamK #-} -toStreamK :: MonadIO m => MutArray a -> K.StreamK m a -toStreamK arr@MutArray{..} = K.unfoldrM step 0 - - where - - step i - | i == arrLen = return Nothing - | otherwise = do - x <- getIndexUnsafe i arr - return $ Just (x, i + 1) - -{-# INLINE_NORMAL readRev #-} -readRev :: MonadIO m => MutArray a -> D.Stream m a -readRev arr@MutArray{..} = - D.mapM (`getIndexUnsafe` arr) - $ D.enumerateFromThenToIntegral (arrLen - 1) (arrLen - 2) 0 - -------------------------------------------------------------------------------- --- Folds -------------------------------------------------------------------------------- - --- XXX deduplicate this across unboxed array and this module? - --- | The default chunk size by which the array creation routines increase the --- size of the array when the array is grown linearly. -arrayChunkSize :: Int -arrayChunkSize = 1024 - --- | Like 'writeN' but does not check the array bounds when writing. The fold --- driver must not call the step function more than 'n' times otherwise it will --- corrupt the memory and crash. This function exists mainly because any --- conditional in the step function blocks fusion causing 10x performance --- slowdown. --- --- /Pre-release/ -{-# INLINE_NORMAL writeNUnsafe #-} -writeNUnsafe :: MonadIO m => Int -> Fold m a (MutArray a) -writeNUnsafe n = Fold step initial return - - where - - initial = FL.Partial <$> new (max n 0) - - step arr x = FL.Partial <$> snocUnsafe arr x - --- | @writeN n@ folds a maximum of @n@ elements from the input stream to an --- 'Array'. --- --- >>> writeN n = Fold.take n (MutArray.writeNUnsafe n) --- --- /Pre-release/ -{-# INLINE_NORMAL writeN #-} -writeN :: MonadIO m => Int -> Fold m a (MutArray a) -writeN n = FL.take n $ writeNUnsafe n - --- >>> f n = MutArray.writeAppendWith (* 2) (MutArray.newPinned n) --- >>> writeWith n = Fold.rmapM MutArray.rightSize (f n) --- >>> writeWith n = Fold.rmapM MutArray.fromArrayStreamK (MutArray.writeChunks n) - --- | @writeWith minCount@ folds the whole input to a single array. The array --- starts at a size big enough to hold minCount elements, the size is doubled --- every time the array needs to be grown. --- --- /Caution! Do not use this on infinite streams./ --- --- /Pre-release/ -{-# INLINE_NORMAL writeWith #-} -writeWith :: MonadIO m => Int -> Fold m a (MutArray a) --- writeWith n = FL.rmapM rightSize $ writeAppendWith (* 2) (newPinned n) -writeWith elemCount = FL.rmapM extract $ FL.foldlM' step initial - - where - - initial = do - when (elemCount < 0) $ error "writeWith: elemCount is negative" - liftIO $ new elemCount - - step arr@(MutArray _ start end bound) x - | end == bound = do - let oldSize = end - start - newSize = max (oldSize * 2) 1 - arr1 <- liftIO $ realloc newSize arr - snocUnsafe arr1 x - step arr x = snocUnsafe arr x - - -- extract = liftIO . rightSize - extract = return - --- | Fold the whole input to a single array. --- --- Same as 'writeWith' using an initial array size of 'arrayChunkSize' bytes --- rounded up to the element size. --- --- /Caution! Do not use this on infinite streams./ --- -{-# INLINE write #-} -write :: MonadIO m => Fold m a (MutArray a) -write = writeWith arrayChunkSize - -------------------------------------------------------------------------------- --- Unfolds -------------------------------------------------------------------------------- - --- | Resumable unfold of an array. --- -{-# INLINE_NORMAL producerWith #-} -producerWith :: Monad m => (forall b. IO b -> m b) -> Producer m (MutArray a) a -producerWith liftio = Producer step inject extract - - where - - {-# INLINE inject #-} - inject arr = return (arr, 0) - - {-# INLINE extract #-} - extract (arr, i) = - return $ arr {arrStart = arrStart arr + i, arrLen = arrLen arr - i} - - {-# INLINE_LATE step #-} - step (arr, i) - | assert (arrLen arr >= 0) (i == arrLen arr) = return D.Stop - step (arr, i) = do - x <- liftio $ getIndexUnsafe i arr - return $ D.Yield x (arr, i + 1) - --- | Resumable unfold of an array. --- -{-# INLINE_NORMAL producer #-} -producer :: MonadIO m => Producer m (MutArray a) a -producer = producerWith liftIO - --- | Unfold an array into a stream. --- -{-# INLINE_NORMAL reader #-} -reader :: MonadIO m => Unfold m (MutArray a) a -reader = Producer.simplify producer - --------------------------------------------------------------------------------- --- Appending arrays --------------------------------------------------------------------------------- - --- | Put a sub range of a source array into a subrange of a destination array. --- This is not safe as it does not check the bounds. -{-# INLINE putSliceUnsafe #-} -putSliceUnsafe :: MonadIO m => - MutArray a -> Int -> MutArray a -> Int -> Int -> m () -putSliceUnsafe src srcStart dst dstStart len = liftIO $ do - assertM(len <= arrLen dst) - assertM(len <= arrLen src) - let !(I# srcStart#) = srcStart + arrStart src - !(I# dstStart#) = dstStart + arrStart dst - !(I# len#) = len - let arrS# = arrContents# src - arrD# = arrContents# dst - IO $ \s# -> (# copyMutableArray# - arrS# srcStart# arrD# dstStart# len# s# - , () #) - -{-# INLINE clone #-} -clone :: MonadIO m => MutArray a -> m (MutArray a) -clone src = liftIO $ do - let len = arrLen src - dst <- new len - putSliceUnsafe src 0 dst 0 len - return dst - -------------------------------------------------------------------------------- --- Size -------------------------------------------------------------------------------- - -{-# INLINE length #-} -length :: MutArray a -> Int -length = arrLen - -------------------------------------------------------------------------------- --- Equality -------------------------------------------------------------------------------- - --- | Compare the length of the arrays. If the length is equal, compare the --- lexicographical ordering of two underlying byte arrays otherwise return the --- result of length comparison. --- --- /Pre-release/ -{-# INLINE cmp #-} -cmp :: (MonadIO m, Ord a) => MutArray a -> MutArray a -> m Ordering -cmp a1 a2 = - case compare lenA1 lenA2 of - EQ -> loop (lenA1 - 1) - x -> return x - - where - - lenA1 = length a1 - lenA2 = length a2 - - loop i - | i < 0 = return EQ - | otherwise = do - v1 <- getIndexUnsafe i a1 - v2 <- getIndexUnsafe i a2 - case compare v1 v2 of - EQ -> loop (i - 1) - x -> return x - -{-# INLINE eq #-} -eq :: (MonadIO m, Eq a) => MutArray a -> MutArray a -> m Bool -eq a1 a2 = - if lenA1 == lenA2 - then loop (lenA1 - 1) - else return False - - where - - lenA1 = length a1 - lenA2 = length a2 - - loop i - | i < 0 = return True - | otherwise = do - v1 <- getIndexUnsafe i a1 - v2 <- getIndexUnsafe i a2 - if v1 == v2 - then loop (i - 1) - else return False - -{-# INLINE strip #-} -strip :: MonadIO m => (a -> Bool) -> MutArray a -> m (MutArray a) -strip p arr = liftIO $ do - let lastIndex = length arr - 1 - indexR <- getIndexR lastIndex -- last predicate failing index - if indexR < 0 - then nil - else do - indexL <- getIndexL 0 -- first predicate failing index - if indexL == 0 && indexR == lastIndex - then return arr - else - let newLen = indexR - indexL + 1 - in return $ getSliceUnsafe indexL newLen arr - - where - - getIndexR idx - | idx < 0 = return idx - | otherwise = do - r <- getIndexUnsafe idx arr - if p r - then getIndexR (idx - 1) - else return idx - - getIndexL idx = do - r <- getIndexUnsafe idx arr - if p r - then getIndexL (idx + 1) - else return idx diff --git a/src/Streamly/Internal/Data/Array/Generic/Type.hs b/src/Streamly/Internal/Data/Array/Generic/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/Generic/Type.hs @@ -0,0 +1,495 @@ +-- | +-- Module : Streamly.Internal.Data.Array.Generic.Type +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +module Streamly.Internal.Data.Array.Generic.Type + ( Array(..) + + -- * Conversion + , unsafeFreeze + , unsafeThaw + + -- * Construction + , nil + , createOf + , create + , createWith + , createOfLast + + , fromStreamN + , fromStream + , fromPureStream + , fromCString# + + , fromListN + , fromList + + , chunksOf + + -- * Elimination + , length + , reader + + , toList + , read + , readRev + + , foldl' + , foldr + , streamFold + , fold + + -- * Random Access + , unsafeGetIndex + , getIndex + , unsafeSliceOffLen + , dropAround + + -- * Parsing Stream of Arrays + , toParserK + + -- * Deprecated + , strip + , getIndexUnsafe + , getSliceUnsafe + , writeN + , write + , fromByteStr# + ) +where + +#include "inline.hs" +#include "assert.hs" +#include "deprecation.h" + +import Control.Monad (replicateM) +import Control.Monad.IO.Class (MonadIO) +import Data.Functor.Identity (Identity(..)) +import Data.Word (Word8) +import GHC.Base (MutableArray#, RealWorld) +import GHC.Exts (Addr#) +import GHC.Types (SPEC(..)) +import GHC.IO (unsafePerformIO) +import Text.Read (readPrec) + +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.ParserK.Type + (ParserK, ParseResult(..), Input(..), Step(..)) +import Streamly.Internal.Data.Stream.Type (Stream) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.System.IO (unsafeInlineIO) + +import qualified Streamly.Internal.Data.Fold.Type as FL +import qualified Streamly.Internal.Data.MutArray.Generic as MArray +import qualified Streamly.Internal.Data.Parser.Type as ParserD +import qualified Streamly.Internal.Data.ParserK.Type as ParserK +import qualified Streamly.Internal.Data.Producer as Producer +import qualified Streamly.Internal.Data.RingArray.Generic as RB +import qualified Streamly.Internal.Data.Stream.Type as D +import qualified Streamly.Internal.Data.Stream.Generate as D +import qualified Text.ParserCombinators.ReadPrec as ReadPrec + +import Prelude hiding (Foldable(..), read) + +------------------------------------------------------------------------------- +-- Array Data Type +------------------------------------------------------------------------------- + +data Array a = + Array + { arrContents# :: MutableArray# RealWorld a + -- ^ The internal contents of the array representing the entire array. + + , arrStart :: {-# UNPACK #-}!Int + -- ^ The starting index of this slice. + + , arrEnd :: {-# UNPACK #-}!Int + -- ^ First invalid index of the array. + } + +unsafeFreeze :: MArray.MutArray a -> Array a +unsafeFreeze (MArray.MutArray cont# arrS arrE _) = Array cont# arrS arrE + +unsafeThaw :: Array a -> MArray.MutArray a +unsafeThaw (Array cont# arrS arrE) = MArray.MutArray cont# arrS arrE arrE + +{-# NOINLINE nil #-} +nil :: Array a +nil = unsafePerformIO $ unsafeFreeze <$> MArray.nil + +------------------------------------------------------------------------------- +-- Construction - Folds +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL createOf #-} +createOf :: MonadIO m => Int -> Fold m a (Array a) +createOf = fmap unsafeFreeze <$> MArray.createOf + +{-# DEPRECATED writeN "Please use createOf instead." #-} +{-# INLINE writeN #-} +writeN :: MonadIO m => Int -> Fold m a (Array a) +writeN = createOf + +{-# INLINE_NORMAL createWith #-} +createWith :: MonadIO m => Int -> Fold m a (Array a) +createWith elemCount = unsafeFreeze <$> MArray.createWith elemCount + +-- | Fold the whole input to a single array. +-- +-- /Caution! Do not use this on infinite streams./ +-- +{-# INLINE create #-} +create :: MonadIO m => Fold m a (Array a) +create = fmap unsafeFreeze MArray.create + +{-# DEPRECATED write "Please use create instead." #-} +{-# INLINE write #-} +write :: MonadIO m => Fold m a (Array a) +write = create + +fromPureStream :: Stream Identity a -> Array a +fromPureStream x = + unsafePerformIO $ fmap unsafeFreeze (MArray.fromPureStream x) +-- fromPureStream = runIdentity . D.fold (unsafeMakePure write) +-- fromPureStream = fromList . runIdentity . D.toList + +fromCString# :: MonadIO m => Addr# -> m (Array Word8) +fromCString# addr = fromStream $ D.fromCString# addr + +{-# DEPRECATED fromByteStr# "Please use 'unsafePerformIO . fromCString#' instead" #-} +fromByteStr# :: Addr# -> Array Word8 +fromByteStr# addr = fromPureStream (D.fromCString# addr) + +------------------------------------------------------------------------------- +-- Stream Ops +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL chunksOf #-} +chunksOf :: forall m a. MonadIO m + => Int -> Stream m a -> Stream m (Array a) +chunksOf n strm = fmap unsafeFreeze $ MArray.chunksOf n strm + +------------------------------------------------------------------------------- +-- Construction - from streams +------------------------------------------------------------------------------- + +{-# INLINE fromStreamN #-} +fromStreamN :: MonadIO m => Int -> Stream m a -> m (Array a) +fromStreamN n = D.fold (writeN n) + +{-# INLINE fromStream #-} +fromStream :: MonadIO m => Stream m a -> m (Array a) +fromStream = D.fold write + +-- XXX Consider foldr/build fusion in toList/fromList + +{-# INLINABLE fromListN #-} +fromListN :: Int -> [a] -> Array a +fromListN n xs = unsafePerformIO $ fromStreamN n $ D.fromList xs + +{-# INLINABLE fromList #-} +fromList :: [a] -> Array a +fromList xs = unsafePerformIO $ fromStream $ D.fromList xs + +------------------------------------------------------------------------------- +-- Elimination - Unfolds +------------------------------------------------------------------------------- + +{-# INLINE length #-} +length :: Array a -> Int +length arr = arrEnd arr - arrStart arr + +{-# INLINE_NORMAL reader #-} +reader :: Monad m => Unfold m (Array a) a +reader = + Producer.simplify + $ Producer.translate unsafeThaw unsafeFreeze + $ MArray.producerWith (return . unsafeInlineIO) + +------------------------------------------------------------------------------- +-- Elimination - to streams +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL toList #-} +toList :: Array a -> [a] +toList arr = loop 0 + + where + + len = length arr + loop i | i == len = [] + loop i = unsafeGetIndex i arr : loop (i + 1) + +{-# INLINE_NORMAL read #-} +read :: Monad m => Array a -> Stream m a +read arr = + D.map (`unsafeGetIndex` arr) $ D.enumerateFromToIntegral 0 (length arr - 1) + +{-# INLINE_NORMAL readRev #-} +readRev :: Monad m => Array a -> Stream m a +readRev arr = + D.map (`unsafeGetIndex` arr) + $ D.enumerateFromThenToIntegral (arrLen - 1) (arrLen - 2) 0 + where + arrLen = length arr + +------------------------------------------------------------------------------- +-- Elimination - using Folds +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL foldl' #-} +foldl' :: (b -> a -> b) -> b -> Array a -> b +foldl' f z arr = unsafePerformIO $ D.foldl' f z $ read arr + +{-# INLINE_NORMAL foldr #-} +foldr :: (a -> b -> b) -> b -> Array a -> b +foldr f z arr = unsafePerformIO $ D.foldr f z $ read arr + +{-# INLINE fold #-} +fold :: Monad m => Fold m a b -> Array a -> m b +fold f arr = D.fold f (read arr) + +{-# INLINE streamFold #-} +streamFold :: Monad m => (Stream m a -> m b) -> Array a -> m b +streamFold f arr = f (read arr) + +------------------------------------------------------------------------------- +-- Random reads and writes +------------------------------------------------------------------------------- + +-- | /O(1)/ Lookup the element at the given index. Index starts from 0. Does +-- not check the bounds. +-- +-- @since 0.8.0 +{-# INLINE unsafeGetIndex #-} +unsafeGetIndex, getIndexUnsafe :: Int -> Array a -> a +unsafeGetIndex i arr = + unsafePerformIO $ MArray.unsafeGetIndex i (unsafeThaw arr) + +-- | Lookup the element at the given index. Index starts from 0. +-- +{-# INLINE getIndex #-} +getIndex :: Int -> Array a -> Maybe a +getIndex i arr = + if i >= 0 && i < length arr + then Just $ unsafeGetIndex i arr + else Nothing + +-- >>> import qualified Streamly.Data.Stream as Stream +-- >>> import qualified Streamly.Data.Fold as Fold +-- >>> import qualified Streamly.Internal.Data.Array.Generic as Array +-- >>> import Data.Function ((&)) +-- >>> :{ +-- Stream.fromList [1,2,3,4,5::Int] +-- & Stream.scan (Array.createOfLast 2) +-- & Stream.fold Fold.toList +-- :} +-- [fromList [],fromList [1],fromList [1,2],fromList [2,3],fromList [3,4],fromList [4,5]] +-- +{-# INLINE createOfLast #-} +createOfLast :: MonadIO m => Int -> Fold m a (Array a) +createOfLast n = FL.rmapM f (RB.createOf n) + + where + + f rb = do + arr <- RB.copyToMutArray 0 n rb + return $ unsafeFreeze arr + +{-# INLINE unsafeSliceOffLen #-} +unsafeSliceOffLen, getSliceUnsafe + :: Int -> Int -> Array a -> Array a +unsafeSliceOffLen offset len = + unsafeFreeze . MArray.unsafeSliceOffLen offset len . unsafeThaw + +-- XXX This is not efficient as it copies the array. We should support array +-- slicing so that we can just refer to the underlying array memory instead of +-- copying. + +-- | Truncate the array at the beginning and end as long as the predicate +-- holds true. Returns a slice of the original array. +{-# INLINE dropAround #-} +dropAround, strip :: (a -> Bool) -> Array a -> Array a +dropAround p arr = + unsafeFreeze $ unsafePerformIO $ MArray.dropAround p (unsafeThaw arr) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance Eq a => Eq (Array a) where + {-# INLINE (==) #-} + arr1 == arr2 = + unsafeInlineIO $! unsafeThaw arr1 `MArray.eq` unsafeThaw arr2 + +instance Ord a => Ord (Array a) where + {-# INLINE compare #-} + compare arr1 arr2 = + unsafeInlineIO $! unsafeThaw arr1 `MArray.cmp` unsafeThaw arr2 + + -- Default definitions defined in base do not have an INLINE on them, so we + -- replicate them here with an INLINE. + {-# INLINE (<) #-} + x < y = case compare x y of { LT -> True; _ -> False } + + {-# INLINE (<=) #-} + x <= y = case compare x y of { GT -> False; _ -> True } + + {-# INLINE (>) #-} + x > y = case compare x y of { GT -> True; _ -> False } + + {-# INLINE (>=) #-} + x >= y = case compare x y of { LT -> False; _ -> True } + + -- These two default methods use '<=' rather than 'compare' + -- because the latter is often more expensive + {-# INLINE max #-} + max x y = if x <= y then y else x + + {-# INLINE min #-} + min x y = if x <= y then x else y + +instance Show a => Show (Array a) where + {-# INLINE show #-} + show arr = "fromList " ++ show (toList arr) + +instance Read a => Read (Array a) where + {-# INLINE readPrec #-} + readPrec = do + fromListWord <- replicateM 9 ReadPrec.get + if fromListWord == "fromList " + then fromList <$> readPrec + else ReadPrec.pfail + +------------------------------------------------------------------------------- +-- Backward Compatibility +------------------------------------------------------------------------------- + +RENAME(strip,dropAround) +RENAME(getSliceUnsafe,unsafeSliceOffLen) +RENAME(getIndexUnsafe,unsafeGetIndex) + +-------------------------------------------------------------------------------- +-- Convert Parser to Parserk on Generic Arrays +-------------------------------------------------------------------------------- + +{-# INLINE adaptCGWith #-} +adaptCGWith + :: forall m a s b r. (Monad m) + => (s -> a -> m (ParserD.Step s b)) + -> m (ParserD.Initial s b) + -> (s -> m (ParserD.Final s b)) + -> (ParseResult b -> Int -> Input (Array a) -> m (Step (Array a) m r)) + -> Int + -> Int + -> Input (Array a) + -> m (Step (Array a) m r) +adaptCGWith pstep initial extract cont !offset0 !usedCount !input = do + res <- initial + case res of + ParserD.IPartial pst -> do + case input of + Chunk arr -> parseContChunk usedCount offset0 pst arr + None -> parseContNothing usedCount pst + ParserD.IDone b -> cont (Success offset0 b) usedCount input + ParserD.IError err -> cont (Failure offset0 err) usedCount input + + where + + {-# NOINLINE parseContChunk #-} + parseContChunk !count !offset !state arr@(Array contents start end) = do + if offset >= 0 + then go SPEC (start + offset) state + else return $ Continue offset (parseCont count state) + + where + + {-# INLINE onDone #-} + onDone n b = + assert (n <= length arr) + (cont (Success n b) (count + n - offset) (Chunk arr)) + + {-# INLINE callParseCont #-} + callParseCont constr n pst1 = + assert (n < 0 || n >= length arr) + (return $ constr n (parseCont (count + n - offset) pst1)) + + {-# INLINE onPartial #-} + onPartial = callParseCont Partial + + {-# INLINE onContinue #-} + onContinue = callParseCont Continue + + {-# INLINE onError #-} + onError n err = + cont (Failure n err) (count + n - offset) (Chunk arr) + + {-# INLINE onBack #-} + onBack offset1 constr pst = do + let pos = offset1 - start + in if pos >= 0 + then go SPEC offset1 pst + else constr pos pst + + go !_ !cur !pst | cur >= end = + onContinue (end - start) pst + go !_ !cur !pst = do + let !x = unsafeInlineIO $ MArray.unsafeGetIndexWith contents cur + pRes <- pstep pst x + let next = cur + 1 + -- XXX Change this to moveOff and remove curOff and nextOff + move n = cur + n + curOff = cur - start + nextOff = next - start + case pRes of + ParserD.SDone 1 b -> + onDone nextOff b + ParserD.SDone 0 b -> + onDone curOff b + ParserD.SDone n b -> + onDone (move n - start) b + ParserD.SPartial 1 pst1 -> + go SPEC next pst1 + ParserD.SPartial 0 pst1 -> + go SPEC cur pst1 + ParserD.SPartial n pst1 -> + onBack (move n) onPartial pst1 + ParserD.SContinue 1 pst1 -> + go SPEC next pst1 + ParserD.SContinue 0 pst1 -> + go SPEC cur pst1 + ParserD.SContinue n pst1 -> + onBack (move n) onContinue pst1 + ParserD.SError err -> + onError curOff err + + {-# NOINLINE parseContNothing #-} + parseContNothing !count !pst = do + r <- extract pst + case r of + ParserD.FDone n b -> + assert (n <= 0) (cont (Success n b) (count + n) None) + ParserD.FContinue n pst1 -> + assert (n <= 1) + (return $ Continue n (parseCont (count + n) pst1)) + ParserD.FError err -> + -- XXX It is called only when there is no input arr. So using 0 + -- as the position is correct? + cont (Failure 0 err) count None + + {-# INLINE parseCont #-} + parseCont !cnt !pst (Chunk arr) = parseContChunk cnt 0 pst arr + parseCont !cnt !pst None = parseContNothing cnt pst + +-- | Convert a 'Parser' to 'ParserK' working on generic Array stream. +-- +-- /Pre-release/ +-- +{-# INLINE_LATE toParserK #-} +toParserK :: Monad m => ParserD.Parser a m b -> ParserK (Array a) m b +toParserK (ParserD.Parser step initial extract) = + ParserK.MkParser $ adaptCGWith step initial extract diff --git a/src/Streamly/Internal/Data/Array/Mut.hs b/src/Streamly/Internal/Data/Array/Mut.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Array/Mut.hs +++ /dev/null @@ -1,86 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Array.Mut --- Copyright : (c) 2020 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Array.Mut - ( - module Streamly.Internal.Data.Array.Mut.Type - , splitOn - , genSlicesFromLen - , getSlicesFromLen - , fromStream - ) -where - -#include "inline.hs" - -import Control.Monad.IO.Class (MonadIO(..)) -import Streamly.Internal.Data.Unboxed (Unbox) -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) - -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Unfold as Unfold - -import Prelude hiding (foldr, length, read, splitAt) -import Streamly.Internal.Data.Array.Mut.Type - --- | Split the array into a stream of slices using a predicate. The element --- matching the predicate is dropped. --- --- /Pre-release/ -{-# INLINE splitOn #-} -splitOn :: (MonadIO m, Unbox a) => - (a -> Bool) -> MutArray a -> Stream m (MutArray a) -splitOn predicate arr = - fmap (\(i, len) -> getSliceUnsafe i len arr) - $ D.sliceOnSuffix predicate (toStreamD arr) - --- | Generate a stream of array slice descriptors ((index, len)) of specified --- length from an array, starting from the supplied array index. The last slice --- may be shorter than the requested length depending on the array length. --- --- /Pre-release/ -{-# INLINE genSlicesFromLen #-} -genSlicesFromLen :: forall m a. (Monad m, Unbox a) - => Int -- ^ from index - -> Int -- ^ length of the slice - -> Unfold m (MutArray a) (Int, Int) -genSlicesFromLen from len = - let fromThenTo n = (from, from + len, n - 1) - mkSlice n i = return (i, min len (n - i)) - in Unfold.lmap length - $ Unfold.mapM2 mkSlice - $ Unfold.lmap fromThenTo Unfold.enumerateFromThenTo - --- | Generate a stream of slices of specified length from an array, starting --- from the supplied array index. The last slice may be shorter than the --- requested length depending on the array length. --- --- /Pre-release/ -{-# INLINE getSlicesFromLen #-} -getSlicesFromLen :: forall m a. (Monad m, Unbox a) - => Int -- ^ from index - -> Int -- ^ length of the slice - -> Unfold m (MutArray a) (MutArray a) -getSlicesFromLen from len = - let mkSlice arr (i, n) = return $ getSliceUnsafe i n arr - in Unfold.mapM2 mkSlice (genSlicesFromLen from len) - --- | Create an 'Array' from a stream. This is useful when we want to create a --- single array from a stream of unknown size. 'writeN' is at least twice --- as efficient when the size is already known. --- --- Note that if the input stream is too large memory allocation for the array --- may fail. When the stream size is not known, `chunksOf` followed by --- processing of indvidual arrays in the resulting stream should be preferred. --- --- /Pre-release/ -{-# INLINE fromStream #-} -fromStream :: (MonadIO m, Unbox a) => Stream m a -> m (MutArray a) -fromStream = fromStreamD --- fromStream (Stream m) = P.fold write m diff --git a/src/Streamly/Internal/Data/Array/Mut/Stream.hs b/src/Streamly/Internal/Data/Array/Mut/Stream.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Array/Mut/Stream.hs +++ /dev/null @@ -1,323 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Array.Mut.Stream --- Copyright : (c) 2019 Composewell Technologies --- License : BSD3-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Combinators to efficiently manipulate streams of mutable arrays. --- -module Streamly.Internal.Data.Array.Mut.Stream - ( - -- * Generation - chunksOf - - -- * Compaction - , packArraysChunksOf - , SpliceState (..) - , lpackArraysChunksOf - , compact - , compactLE - , compactEQ - , compactGE - ) -where - -#include "inline.hs" -#include "ArrayMacros.h" - -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (when) -import Data.Bifunctor (first) -import Data.Proxy (Proxy(..)) -import Streamly.Internal.Data.Unboxed (Unbox, sizeOf) -import Streamly.Internal.Data.Array.Mut.Type (MutArray(..)) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Parser (ParseError) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) - -import qualified Streamly.Internal.Data.Array.Mut.Type as MArray -import qualified Streamly.Internal.Data.Fold.Type as FL -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Parser.ParserD as ParserD - --- | @chunksOf n stream@ groups the elements in the input stream into arrays of --- @n@ elements each. --- --- Same as the following but may be more efficient: --- --- > chunksOf n = Stream.foldMany (MArray.writeN n) --- --- /Pre-release/ -{-# INLINE chunksOf #-} -chunksOf :: (MonadIO m, Unbox a) - => Int -> Stream m a -> Stream m (MutArray a) -chunksOf = MArray.chunksOf - -------------------------------------------------------------------------------- --- Compact -------------------------------------------------------------------------------- - -data SpliceState s arr - = SpliceInitial s - | SpliceBuffering s arr - | SpliceYielding arr (SpliceState s arr) - | SpliceFinish - --- XXX This can be removed once compactLEFold/compactLE are implemented. --- --- | This mutates the first array (if it has space) to append values from the --- second one. This would work for immutable arrays as well because an --- immutable array never has space so a new array is allocated instead of --- mutating it. --- --- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a --- maximum specified size. Note that if a single array is bigger than the --- specified size we do not split it to fit. When we coalesce multiple arrays --- if the size would exceed the specified size we do not coalesce therefore the --- actual array size may be less than the specified chunk size. --- --- @since 0.7.0 -{-# INLINE_NORMAL packArraysChunksOf #-} -packArraysChunksOf :: (MonadIO m, Unbox a) - => Int -> D.Stream m (MutArray a) -> D.Stream m (MutArray a) -packArraysChunksOf n (D.Stream step state) = - D.Stream step' (SpliceInitial state) - - where - - {-# INLINE_LATE step' #-} - step' gst (SpliceInitial st) = do - when (n <= 0) $ - -- XXX we can pass the module string from the higher level API - error $ "Streamly.Internal.Data.Array.Mut.Type.packArraysChunksOf: the size of " - ++ "arrays [" ++ show n ++ "] must be a natural number" - r <- step gst st - case r of - D.Yield arr s -> return $ - let len = MArray.byteLength arr - in if len >= n - then D.Skip (SpliceYielding arr (SpliceInitial s)) - else D.Skip (SpliceBuffering s arr) - D.Skip s -> return $ D.Skip (SpliceInitial s) - D.Stop -> return D.Stop - - step' gst (SpliceBuffering st buf) = do - r <- step gst st - case r of - D.Yield arr s -> do - let len = MArray.byteLength buf + MArray.byteLength arr - if len > n - then return $ - D.Skip (SpliceYielding buf (SpliceBuffering s arr)) - else do - buf' <- if MArray.byteCapacity buf < n - then liftIO $ MArray.realloc n buf - else return buf - buf'' <- MArray.splice buf' arr - return $ D.Skip (SpliceBuffering s buf'') - D.Skip s -> return $ D.Skip (SpliceBuffering s buf) - D.Stop -> return $ D.Skip (SpliceYielding buf SpliceFinish) - - step' _ SpliceFinish = return D.Stop - - step' _ (SpliceYielding arr next) = return $ D.Yield arr next - --- XXX Remove this once compactLEFold is implemented --- lpackArraysChunksOf = Fold.many compactLEFold --- -{-# INLINE_NORMAL lpackArraysChunksOf #-} -lpackArraysChunksOf :: (MonadIO m, Unbox a) - => Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () -lpackArraysChunksOf n (Fold step1 initial1 extract1) = - Fold step initial extract - - where - - initial = do - when (n <= 0) $ - -- XXX we can pass the module string from the higher level API - error $ "Streamly.Internal.Data.Array.Mut.Type.packArraysChunksOf: the size of " - ++ "arrays [" ++ show n ++ "] must be a natural number" - - r <- initial1 - return $ first (Tuple' Nothing) r - - extract (Tuple' Nothing r1) = extract1 r1 - extract (Tuple' (Just buf) r1) = do - r <- step1 r1 buf - case r of - FL.Partial rr -> extract1 rr - FL.Done _ -> return () - - step (Tuple' Nothing r1) arr = - let len = MArray.byteLength arr - in if len >= n - then do - r <- step1 r1 arr - case r of - FL.Done _ -> return $ FL.Done () - FL.Partial s -> do - extract1 s - res <- initial1 - return $ first (Tuple' Nothing) res - else return $ FL.Partial $ Tuple' (Just arr) r1 - - step (Tuple' (Just buf) r1) arr = do - let len = MArray.byteLength buf + MArray.byteLength arr - buf' <- if MArray.byteCapacity buf < len - then liftIO $ MArray.realloc (max n len) buf - else return buf - buf'' <- MArray.splice buf' arr - - -- XXX this is common in both the equations of step - if len >= n - then do - r <- step1 r1 buf'' - case r of - FL.Done _ -> return $ FL.Done () - FL.Partial s -> do - extract1 s - res <- initial1 - return $ first (Tuple' Nothing) res - else return $ FL.Partial $ Tuple' (Just buf'') r1 - --- XXX Same as compactLE, to be removed once that is implemented. --- --- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a --- maximum specified size in bytes. --- --- /Internal/ -{-# INLINE compact #-} -compact :: (MonadIO m, Unbox a) - => Int -> Stream m (MutArray a) -> Stream m (MutArray a) -compact = packArraysChunksOf - --- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a --- maximum specified size. Note that if a single array is bigger than the --- specified size we do not split it to fit. When we coalesce multiple arrays --- if the size would exceed the specified size we do not coalesce therefore the --- actual array size may be less than the specified chunk size. --- --- /Internal/ -{-# INLINE_NORMAL compactLEParserD #-} -compactLEParserD :: - forall m a. (MonadIO m, Unbox a) - => Int -> ParserD.Parser (MutArray a) m (MutArray a) -compactLEParserD n = ParserD.Parser step initial extract - - where - - nBytes = n * SIZE_OF(a) - - initial = - return - $ if n <= 0 - then error - $ functionPath - ++ ": the size of arrays [" - ++ show n ++ "] must be a natural number" - else ParserD.IPartial Nothing - - step Nothing arr = - return - $ let len = MArray.byteLength arr - in if len >= nBytes - then ParserD.Done 0 arr - else ParserD.Partial 0 (Just arr) - step (Just buf) arr = - let len = MArray.byteLength buf + MArray.byteLength arr - in if len > nBytes - then return $ ParserD.Done 1 buf - else do - buf1 <- - if MArray.byteCapacity buf < nBytes - then liftIO $ MArray.realloc nBytes buf - else return buf - buf2 <- MArray.splice buf1 arr - return $ ParserD.Partial 0 (Just buf2) - - extract Nothing = return $ ParserD.Done 0 MArray.nil - extract (Just buf) = return $ ParserD.Done 0 buf - - functionPath = - "Streamly.Internal.Data.Array.Mut.Stream.compactLEParserD" - --- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a --- minimum specified size. Note that if all the arrays in the stream together --- are smaller than the specified size the resulting array will be smaller than --- the specified size. When we coalesce multiple arrays if the size would exceed --- the specified size we stop coalescing further. --- --- /Internal/ -{-# INLINE_NORMAL compactGEFold #-} -compactGEFold :: - forall m a. (MonadIO m, Unbox a) - => Int -> FL.Fold m (MutArray a) (MutArray a) -compactGEFold n = Fold step initial extract - - where - - nBytes = n * SIZE_OF(a) - - initial = - return - $ if n < 0 - then error - $ functionPath - ++ ": the size of arrays [" - ++ show n ++ "] must be a natural number" - else FL.Partial Nothing - - step Nothing arr = - return - $ let len = MArray.byteLength arr - in if len >= nBytes - then FL.Done arr - else FL.Partial (Just arr) - step (Just buf) arr = do - let len = MArray.byteLength buf + MArray.byteLength arr - buf1 <- - if MArray.byteCapacity buf < len - then liftIO $ MArray.realloc (max len nBytes) buf - else return buf - buf2 <- MArray.splice buf1 arr - if len >= n - then return $ FL.Done buf2 - else return $ FL.Partial (Just buf2) - - extract Nothing = return MArray.nil - extract (Just buf) = return buf - - functionPath = - "Streamly.Internal.Data.Array.Mut.Stream.compactGEFold" - --- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a --- maximum specified size in bytes. --- --- /Internal/ -compactLE :: (MonadIO m, Unbox a) => - Int -> Stream m (MutArray a) -> Stream m (Either ParseError (MutArray a)) -compactLE n = D.parseManyD (compactLEParserD n) - --- | Like 'compactLE' but generates arrays of exactly equal to the size --- specified except for the last array in the stream which could be shorter. --- --- /Unimplemented/ -{-# INLINE compactEQ #-} -compactEQ :: -- (MonadIO m, Unbox a) => - Int -> Stream m (MutArray a) -> Stream m (MutArray a) -compactEQ _n _xs = undefined - -- IsStream.fromStreamD $ D.foldMany (compactEQFold n) (IsStream.toStreamD xs) - --- | Like 'compactLE' but generates arrays of size greater than or equal to the --- specified except for the last array in the stream which could be shorter. --- --- /Internal/ -{-# INLINE compactGE #-} -compactGE :: - (MonadIO m, Unbox a) - => Int -> Stream m (MutArray a) -> Stream m (MutArray a) -compactGE n = D.foldMany (compactGEFold n) diff --git a/src/Streamly/Internal/Data/Array/Mut/Type.hs b/src/Streamly/Internal/Data/Array/Mut/Type.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Array/Mut/Type.hs +++ /dev/null @@ -1,2356 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UnboxedTuples #-} --- | --- Module : Streamly.Internal.Data.Array.Mut.Type --- Copyright : (c) 2020 Composewell Technologies --- License : BSD3-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Pinned and unpinned mutable array for 'Unboxed' types. Fulfils the following --- goals: --- --- * Random access (array) --- * Efficient storage (unboxed) --- * Performance (unboxed access) --- * Performance - in-place operations (mutable) --- * Performance - GC (pinned, mutable) --- * interfacing with OS (pinned) --- --- Stream and Fold APIs allow easy, efficient and convenient operations on --- arrays. --- --- Mutable arrays and file system files are quite similar, they can grow and --- their content is mutable. Therefore, both have similar APIs as well. We --- strive to keep the API consistent for both. Ideally, you should be able to --- replace one with another with little changes to the code. - -module Streamly.Internal.Data.Array.Mut.Type - ( - -- * Type - -- $arrayNotes - MutArray (..) - , MutableByteArray - , touch - , pin - , unpin - - -- * Constructing and Writing - -- ** Construction - , nil - - -- *** Uninitialized Arrays - , newPinned - , newPinnedBytes - , newAlignedPinned - , new - , newArrayWith - - -- *** Initialized Arrays - , withNewArrayUnsafe - - -- *** From streams - , ArrayUnsafe (..) - , writeNWithUnsafe - , writeNWith - , writeNUnsafe - , writeN - , writeNAligned - - , writeWith - , write - - , writeRevN - -- , writeRev - - -- ** From containers - , fromListN - , fromList - , fromListRevN - , fromListRev - , fromStreamDN - , fromStreamD - - -- * Random writes - , putIndex - , putIndexUnsafe - , putIndices - -- , putFromThenTo - -- , putFrom -- start writing at the given position - -- , putUpto -- write from beginning up to the given position - -- , putFromTo - -- , putFromRev - -- , putUptoRev - , modifyIndexUnsafe - , modifyIndex - , modifyIndices - , modify - , swapIndices - , unsafeSwapIndices - - -- * Growing and Shrinking - -- Arrays grow only at the end, though it is possible to grow on both sides - -- and therefore have a cons as well as snoc. But that will require two - -- bounds in the array representation. - - -- ** Appending elements - , snocWith - , snoc - , snocLinear - , snocMay - , snocUnsafe - - -- ** Appending streams - , writeAppendNUnsafe - , writeAppendN - , writeAppendWith - , writeAppend - - -- * Eliminating and Reading - - -- ** To streams - , reader - , readerRevWith - , readerRev - - -- ** To containers - , toStreamDWith - , toStreamDRevWith - , toStreamKWith - , toStreamKRevWith - , toStreamD - , toStreamDRev - , toStreamK - , toStreamKRev - , toList - - -- experimental - , producerWith - , producer - - -- ** Random reads - , getIndex - , getIndexUnsafe - , getIndices - , getIndicesD - -- , getFromThenTo - , getIndexRev - - -- * Memory Management - , blockSize - , arrayChunkBytes - , allocBytesToElemCount - , realloc - , resize - , resizeExp - , rightSize - - -- * Size - , length - , byteLength - -- , capacity - , byteCapacity - , bytesFree - - -- * In-place Mutation Algorithms - , strip - , reverse - , permute - , partitionBy - , shuffleBy - , divideBy - , mergeBy - , bubble - - -- * Casting - , cast - , castUnsafe - , asBytes - , asPtrUnsafe - - -- * Folding - , foldl' - , foldr - , cmp - - -- * Arrays of arrays - -- We can add dimensionality parameter to the array type to get - -- multidimensional arrays. Multidimensional arrays would just be a - -- convenience wrapper on top of single dimensional arrays. - - -- | Operations dealing with multiple arrays, streams of arrays or - -- multidimensional array representations. - - -- ** Construct from streams - , chunksOf - , arrayStreamKFromStreamD - , writeChunks - - -- ** Eliminate to streams - , flattenArrays - , flattenArraysRev - , fromArrayStreamK - - -- ** Construct from arrays - -- get chunks without copying - , getSliceUnsafe - , getSlice - -- , getSlicesFromLenN - , splitAt -- XXX should be able to express using getSlice - , breakOn - - -- ** Appending arrays - , spliceCopy - , spliceWith - , splice - , spliceExp - , spliceUnsafe - , putSliceUnsafe - -- , putSlice - -- , appendSlice - -- , appendSliceFrom - - -- * Utilities - , roundUpToPower2 - , memcpy - , memcmp - , c_memchr - ) -where - -#include "assert.hs" -#include "inline.hs" -#include "ArrayMacros.h" -#include "MachDeps.h" - -import Control.Monad (when, void) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Bits (shiftR, (.|.), (.&.)) -import Data.Proxy (Proxy(..)) -import Data.Word (Word8) -import Foreign.C.Types (CSize(..), CInt(..)) -import Foreign.Ptr (plusPtr, minusPtr, nullPtr) -import Streamly.Internal.Data.Unboxed - ( MutableByteArray(..) - , Unbox - , getMutableByteArray# - , peekWith - , pokeWith - , sizeOf - , touch - ) -import GHC.Base - ( IO(..) - , Int(..) - , byteArrayContents# - , compareByteArrays# - , copyMutableByteArray# - ) -import GHC.Base (noinline) -import GHC.Exts (unsafeCoerce#) -import GHC.Ptr (Ptr(..)) - -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Producer.Type (Producer (..)) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Stream.StreamK.Type (StreamK) -import Streamly.Internal.Data.SVar.Type (adaptState, defState) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Streamly.Internal.System.IO (arrayPayloadSize, defaultChunkSize) - -import qualified Streamly.Internal.Data.Fold.Type as FL -import qualified Streamly.Internal.Data.Producer as Producer -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -import qualified Streamly.Internal.Data.Unboxed as Unboxed -import qualified Prelude - -import Prelude hiding - (length, foldr, read, unlines, splitAt, reverse, truncate) - -#include "DocTestDataMutArray.hs" - -------------------------------------------------------------------------------- --- Foreign helpers -------------------------------------------------------------------------------- - -foreign import ccall unsafe "string.h memcpy" c_memcpy - :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) - -foreign import ccall unsafe "string.h memchr" c_memchr - :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) - -foreign import ccall unsafe "string.h memcmp" c_memcmp - :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt - --- | Given an 'Unboxed' type (unused first arg) and a number of bytes, return --- how many elements of that type will completely fit in those bytes. --- -{-# INLINE bytesToElemCount #-} -bytesToElemCount :: forall a. Unbox a => a -> Int -> Int -bytesToElemCount _ n = n `div` SIZE_OF(a) - --- XXX we are converting Int to CSize -memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () -memcpy dst src len = void (c_memcpy dst src (fromIntegral len)) - --- XXX we are converting Int to CSize --- return True if the memory locations have identical contents -{-# INLINE memcmp #-} -memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool -memcmp p1 p2 len = do - r <- c_memcmp p1 p2 (fromIntegral len) - return $ r == 0 - -------------------------------------------------------------------------------- --- MutArray Data Type -------------------------------------------------------------------------------- - --- $arrayNotes --- --- We can use an 'Unboxed' constraint in the MutArray type and the constraint --- can be automatically provided to a function that pattern matches on the --- MutArray type. However, it has huge performance cost, so we do not use it. --- Investigate a GHC improvement possiblity. - --- | An unboxed mutable array. An array is created with a given length --- and capacity. Length is the number of valid elements in the array. Capacity --- is the maximum number of elements that the array can be expanded to without --- having to reallocate the memory. --- --- The elements in the array can be mutated in-place without changing the --- reference (constructor). However, the length of the array cannot be mutated --- in-place. A new array reference is generated when the length changes. When --- the length is increased (upto the maximum reserved capacity of the array), --- the array is not reallocated and the new reference uses the same underlying --- memory as the old one. --- --- Several routines in this module allow the programmer to control the capacity --- of the array. The programmer can control the trade-off between memory usage --- and performance impact due to reallocations when growing or shrinking the --- array. --- -data MutArray a = -#ifdef DEVBUILD - Unbox a => -#endif - -- The array is a range into arrContents. arrContents may be a superset of - -- the slice represented by the array. All offsets are in bytes. - MutArray - { arrContents :: {-# UNPACK #-} !MutableByteArray - , arrStart :: {-# UNPACK #-} !Int -- ^ index into arrContents - , arrEnd :: {-# UNPACK #-} !Int -- ^ index into arrContents - -- Represents the first invalid index of - -- the array. - , arrBound :: {-# UNPACK #-} !Int -- ^ first invalid index of arrContents. - } - -------------------------------------------------------------------------------- --- Pinning & Unpinning -------------------------------------------------------------------------------- - -{-# INLINE pin #-} -pin :: MutArray a -> IO (MutArray a) -pin arr@MutArray{..} = do - contents <- Unboxed.pin arrContents - return $ arr {arrContents = contents} - -{-# INLINE unpin #-} -unpin :: MutArray a -> IO (MutArray a) -unpin arr@MutArray{..} = do - contents <- Unboxed.unpin arrContents - return $ arr {arrContents = contents} - -------------------------------------------------------------------------------- --- Construction -------------------------------------------------------------------------------- - --- XXX Change the names to use "new" instead of "newArray". That way we can use --- the same names for managed file system objects as well. For unmanaged ones --- we can use open/create etc as usual. --- --- A new array is similar to "touch" creating a zero length file. An mmapped --- array would be similar to a sparse file with holes. TBD: support mmapped --- files and arrays. - --- GHC always guarantees word-aligned memory, alignment is important only when --- we need more than that. See stg_newAlignedPinnedByteArrayzh and --- allocatePinned in GHC source. - --- | @newArrayWith allocator alignment count@ allocates a new array of zero --- length and with a capacity to hold @count@ elements, using @allocator --- size alignment@ as the memory allocator function. --- --- Alignment must be greater than or equal to machine word size and a power of --- 2. --- --- Alignment is ignored if the allocator allocates unpinned memory. --- --- /Pre-release/ -{-# INLINE newArrayWith #-} -newArrayWith :: forall m a. (MonadIO m, Unbox a) - => (Int -> Int -> m MutableByteArray) -> Int -> Int -> m (MutArray a) -newArrayWith alloc alignSize count = do - let size = max (count * SIZE_OF(a)) 0 - contents <- alloc size alignSize - return $ MutArray - { arrContents = contents - , arrStart = 0 - , arrEnd = 0 - , arrBound = size - } - -nil :: -#ifdef DEVBUILD - Unbox a => -#endif - MutArray a -nil = MutArray Unboxed.nil 0 0 0 - - --- | Allocates a pinned empty array that can hold 'count' items. The memory of --- the array is uninitialized and the allocation is aligned as per the --- 'Unboxed' instance of the type. --- --- /Pre-release/ -{-# INLINE newPinnedBytes #-} -newPinnedBytes :: MonadIO m => -#ifdef DEVBUILD - Unbox a => -#endif - Int -> m (MutArray a) -newPinnedBytes bytes = do - contents <- liftIO $ Unboxed.newPinnedBytes bytes - return $ MutArray - { arrContents = contents - , arrStart = 0 - , arrEnd = 0 - , arrBound = bytes - } - --- | Like 'newArrayWith' but using an allocator is a pinned memory allocator and --- the alignment is dictated by the 'Unboxed' instance of the type. --- --- /Internal/ -{-# INLINE newAlignedPinned #-} -newAlignedPinned :: (MonadIO m, Unbox a) => Int -> Int -> m (MutArray a) -newAlignedPinned = - newArrayWith (\s a -> liftIO $ Unboxed.newAlignedPinnedBytes s a) - --- XXX can unaligned allocation be more efficient when alignment is not needed? --- --- | Allocates an empty pinned array that can hold 'count' items. The memory of --- the array is uninitialized and the allocation is aligned as per the 'Unboxed' --- instance of the type. --- -{-# INLINE newPinned #-} -newPinned :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) -newPinned = - newArrayWith - (\s _ -> liftIO $ Unboxed.newPinnedBytes s) - (error "newPinned: alignSize is not used") - --- | Allocates an empty unpinned array that can hold 'count' items. The memory --- of the array is uninitialized. --- -{-# INLINE new #-} -new :: (MonadIO m, Unbox a) => Int -> m (MutArray a) -new = - newArrayWith - (\s _ -> liftIO $ Unboxed.newUnpinnedBytes s) - (error "new: alignment is not used in unpinned arrays.") - --- XXX This should create a full length uninitialzed array so that the pointer --- can be used. - --- | Allocate a pinned MutArray of the given size and run an IO action passing --- the array start pointer. --- --- /Internal/ -{-# INLINE withNewArrayUnsafe #-} -withNewArrayUnsafe :: - (MonadIO m, Unbox a) => Int -> (Ptr a -> m ()) -> m (MutArray a) -withNewArrayUnsafe count f = do - arr <- newPinned count - asPtrUnsafe arr - $ \p -> f p >> return arr - -------------------------------------------------------------------------------- --- Random writes -------------------------------------------------------------------------------- - --- | Write the given element to the given index of the array. Does not check if --- the index is out of bounds of the array. --- --- /Pre-release/ -{-# INLINE putIndexUnsafe #-} -putIndexUnsafe :: forall m a. (MonadIO m, Unbox a) - => Int -> MutArray a -> a -> m () -putIndexUnsafe i MutArray{..} x = do - let index = INDEX_OF(arrStart, i, a) - assert (i >= 0 && INDEX_VALID(index, arrEnd, a)) (return ()) - liftIO $ pokeWith arrContents index x - -invalidIndex :: String -> Int -> a -invalidIndex label i = - error $ label ++ ": invalid array index " ++ show i - --- | /O(1)/ Write the given element at the given index in the array. --- Performs in-place mutation of the array. --- --- >>> putIndex ix arr val = MutArray.modifyIndex ix arr (const (val, ())) --- >>> f = MutArray.putIndices --- >>> putIndex ix arr val = Stream.fold (f arr) (Stream.fromPure (ix, val)) --- -{-# INLINE putIndex #-} -putIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () -putIndex i MutArray{..} x = do - let index = INDEX_OF(arrStart,i,a) - if i >= 0 && INDEX_VALID(index,arrEnd,a) - then liftIO $ pokeWith arrContents index x - else invalidIndex "putIndex" i - --- | Write an input stream of (index, value) pairs to an array. Throws an --- error if any index is out of bounds. --- --- /Pre-release/ -{-# INLINE putIndices #-} -putIndices :: forall m a. (MonadIO m, Unbox a) - => MutArray a -> Fold m (Int, a) () -putIndices arr = FL.foldlM' step (return ()) - - where - - step () (i, x) = liftIO (putIndex i arr x) - --- | Modify a given index of an array using a modifier function. --- --- /Pre-release/ -modifyIndexUnsafe :: forall m a b. (MonadIO m, Unbox a) => - Int -> MutArray a -> (a -> (a, b)) -> m b -modifyIndexUnsafe i MutArray{..} f = liftIO $ do - let index = INDEX_OF(arrStart,i,a) - assert (i >= 0 && INDEX_NEXT(index,a) <= arrEnd) (return ()) - r <- peekWith arrContents index - let (x, res) = f r - pokeWith arrContents index x - return res - --- | Modify a given index of an array using a modifier function. --- --- /Pre-release/ -modifyIndex :: forall m a b. (MonadIO m, Unbox a) => - Int -> MutArray a -> (a -> (a, b)) -> m b -modifyIndex i MutArray{..} f = do - let index = INDEX_OF(arrStart,i,a) - if i >= 0 && INDEX_VALID(index,arrEnd,a) - then liftIO $ do - r <- peekWith arrContents index - let (x, res) = f r - pokeWith arrContents index x - return res - else invalidIndex "modifyIndex" i - - --- | Modify the array indices generated by the supplied stream. --- --- /Pre-release/ -{-# INLINE modifyIndices #-} -modifyIndices :: forall m a . (MonadIO m, Unbox a) - => MutArray a -> (Int -> a -> a) -> Fold m Int () -modifyIndices arr f = FL.foldlM' step initial - - where - - initial = return () - - step () i = - let f1 x = (f i x, ()) - in modifyIndex i arr f1 - --- | Modify each element of an array using the supplied modifier function. --- --- /Pre-release/ -modify :: forall m a. (MonadIO m, Unbox a) - => MutArray a -> (a -> a) -> m () -modify MutArray{..} f = liftIO $ - go arrStart - - where - - go i = - when (INDEX_VALID(i,arrEnd,a)) $ do - r <- peekWith arrContents i - pokeWith arrContents i (f r) - go (INDEX_NEXT(i,a)) - --- XXX We could specify the number of bytes to swap instead of Proxy. Need --- to ensure that the memory does not overlap. -{-# INLINE swapArrayByteIndices #-} -swapArrayByteIndices :: - forall a. Unbox a - => Proxy a - -> MutableByteArray - -> Int - -> Int - -> IO () -swapArrayByteIndices _ arrContents i1 i2 = do - r1 <- peekWith arrContents i1 - r2 <- peekWith arrContents i2 - pokeWith arrContents i1 (r2 :: a) - pokeWith arrContents i2 (r1 :: a) - --- | Swap the elements at two indices without validating the indices. --- --- /Unsafe/: This could result in memory corruption if indices are not valid. --- --- /Pre-release/ -{-# INLINE unsafeSwapIndices #-} -unsafeSwapIndices :: forall m a. (MonadIO m, Unbox a) - => Int -> Int -> MutArray a -> m () -unsafeSwapIndices i1 i2 MutArray{..} = liftIO $ do - let t1 = INDEX_OF(arrStart,i1,a) - t2 = INDEX_OF(arrStart,i2,a) - swapArrayByteIndices (Proxy :: Proxy a) arrContents t1 t2 - --- | Swap the elements at two indices. --- --- /Pre-release/ -swapIndices :: forall m a. (MonadIO m, Unbox a) - => Int -> Int -> MutArray a -> m () -swapIndices i1 i2 MutArray{..} = liftIO $ do - let t1 = INDEX_OF(arrStart,i1,a) - t2 = INDEX_OF(arrStart,i2,a) - when (i1 < 0 || INDEX_INVALID(t1,arrEnd,a)) - $ invalidIndex "swapIndices" i1 - when (i2 < 0 || INDEX_INVALID(t2,arrEnd,a)) - $ invalidIndex "swapIndices" i2 - swapArrayByteIndices (Proxy :: Proxy a) arrContents t1 t2 - -------------------------------------------------------------------------------- --- Rounding -------------------------------------------------------------------------------- - --- XXX Should we use bitshifts in calculations or it gets optimized by the --- compiler/processor itself? --- --- | The page or block size used by the GHC allocator. Allocator allocates at --- least a block and then allocates smaller allocations from within a block. -blockSize :: Int -blockSize = 4 * 1024 - --- | Allocations larger than 'largeObjectThreshold' are in multiples of block --- size and are always pinned. The space beyond the end of a large object up to --- the end of the block is unused. -largeObjectThreshold :: Int -largeObjectThreshold = (blockSize * 8) `div` 10 - --- XXX Should be done only when we are using the GHC allocator. --- | Round up an array larger than 'largeObjectThreshold' to use the whole --- block. -{-# INLINE roundUpLargeArray #-} -roundUpLargeArray :: Int -> Int -roundUpLargeArray size = - if size >= largeObjectThreshold - then - assert - (blockSize /= 0 && ((blockSize .&. (blockSize - 1)) == 0)) - ((size + blockSize - 1) .&. negate blockSize) - else size - -{-# INLINE isPower2 #-} -isPower2 :: Int -> Bool -isPower2 n = n .&. (n - 1) == 0 - -{-# INLINE roundUpToPower2 #-} -roundUpToPower2 :: Int -> Int -roundUpToPower2 n = -#if WORD_SIZE_IN_BITS == 64 - 1 + z6 -#else - 1 + z5 -#endif - - where - - z0 = n - 1 - z1 = z0 .|. z0 `shiftR` 1 - z2 = z1 .|. z1 `shiftR` 2 - z3 = z2 .|. z2 `shiftR` 4 - z4 = z3 .|. z3 `shiftR` 8 - z5 = z4 .|. z4 `shiftR` 16 - z6 = z5 .|. z5 `shiftR` 32 - --- | @allocBytesToBytes elem allocatedBytes@ returns the array size in bytes --- such that the real allocation is less than or equal to @allocatedBytes@, --- unless @allocatedBytes@ is less than the size of one array element in which --- case it returns one element's size. --- -{-# INLINE allocBytesToBytes #-} -allocBytesToBytes :: forall a. Unbox a => a -> Int -> Int -allocBytesToBytes _ n = max (arrayPayloadSize n) (SIZE_OF(a)) - --- | Given an 'Unboxed' type (unused first arg) and real allocation size --- (including overhead), return how many elements of that type will completely --- fit in it, returns at least 1. --- -{-# INLINE allocBytesToElemCount #-} -allocBytesToElemCount :: Unbox a => a -> Int -> Int -allocBytesToElemCount x bytes = - let n = bytesToElemCount x (allocBytesToBytes x bytes) - in assert (n >= 1) n - --- | The default chunk size by which the array creation routines increase the --- size of the array when the array is grown linearly. -arrayChunkBytes :: Int -arrayChunkBytes = 1024 - -------------------------------------------------------------------------------- --- Resizing -------------------------------------------------------------------------------- - --- | Round the second argument down to multiples of the first argument. -{-# INLINE roundDownTo #-} -roundDownTo :: Int -> Int -> Int -roundDownTo elemSize size = size - (size `mod` elemSize) - --- XXX See if resizing can be implemented by reading the old array as a stream --- and then using writeN to the new array. --- --- NOTE: we are passing elemSize explicitly to avoid an Unboxed constraint. --- Since this is not inlined Unboxed consrraint leads to dictionary passing --- which complicates some inspection tests. --- -{-# NOINLINE reallocExplicit #-} -reallocExplicit :: Int -> Int -> MutArray a -> IO (MutArray a) -reallocExplicit elemSize newCapacityInBytes MutArray{..} = do - assertM(arrEnd <= arrBound) - - -- Allocate new array - let newCapMaxInBytes = roundUpLargeArray newCapacityInBytes - contents <- Unboxed.newPinnedBytes newCapMaxInBytes - let !(MutableByteArray mbarrFrom#) = arrContents - !(MutableByteArray mbarrTo#) = contents - - -- Copy old data - let oldStart = arrStart - !(I# oldStartInBytes#) = oldStart - oldSizeInBytes = arrEnd - oldStart - newCapInBytes = roundDownTo elemSize newCapMaxInBytes - !newLenInBytes@(I# newLenInBytes#) = min oldSizeInBytes newCapInBytes - assert (oldSizeInBytes `mod` elemSize == 0) (return ()) - assert (newLenInBytes >= 0) (return ()) - assert (newLenInBytes `mod` elemSize == 0) (return ()) - IO $ \s# -> (# copyMutableByteArray# mbarrFrom# oldStartInBytes# - mbarrTo# 0# newLenInBytes# s#, () #) - - return $ MutArray - { arrStart = 0 - , arrContents = contents - , arrEnd = newLenInBytes - , arrBound = newCapInBytes - } - --- | @realloc newCapacity array@ reallocates the array to the specified --- capacity in bytes. --- --- If the new size is less than the original array the array gets truncated. --- If the new size is not a multiple of array element size then it is rounded --- down to multiples of array size. If the new size is more than --- 'largeObjectThreshold' then it is rounded up to the block size (4K). --- -{-# INLINABLE realloc #-} -realloc :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) -realloc bytes arr = liftIO $ reallocExplicit (SIZE_OF(a)) bytes arr - --- | @reallocWith label capSizer minIncrBytes array@. The label is used --- in error messages and the capSizer is used to determine the capacity of the --- new array in bytes given the current byte length of the array. -reallocWith :: forall m a. (MonadIO m , Unbox a) => - String - -> (Int -> Int) - -> Int - -> MutArray a - -> m (MutArray a) -reallocWith label capSizer minIncrBytes arr = do - let oldSizeBytes = arrEnd arr - arrStart arr - newCapBytes = capSizer oldSizeBytes - newSizeBytes = oldSizeBytes + minIncrBytes - safeCapBytes = max newCapBytes newSizeBytes - assertM(safeCapBytes >= newSizeBytes || error (badSize newSizeBytes)) - - realloc safeCapBytes arr - - where - - badSize newSize = - concat - [ label - , ": new array size (in bytes) is less than required size " - , show newSize - , ". Please check the sizing function passed." - ] - --- | @resize newCapacity array@ changes the total capacity of the array so that --- it is enough to hold the specified number of elements. Nothing is done if --- the specified capacity is less than the length of the array. --- --- If the capacity is more than 'largeObjectThreshold' then it is rounded up to --- the block size (4K). --- --- /Pre-release/ -{-# INLINE resize #-} -resize :: forall m a. (MonadIO m, Unbox a) => - Int -> MutArray a -> m (MutArray a) -resize nElems arr@MutArray{..} = do - let req = SIZE_OF(a) * nElems - len = arrEnd - arrStart - if req < len - then return arr - else realloc req arr - --- | Like 'resize' but if the byte capacity is more than 'largeObjectThreshold' --- then it is rounded up to the closest power of 2. --- --- /Pre-release/ -{-# INLINE resizeExp #-} -resizeExp :: forall m a. (MonadIO m, Unbox a) => - Int -> MutArray a -> m (MutArray a) -resizeExp nElems arr@MutArray{..} = do - let req = roundUpLargeArray (SIZE_OF(a) * nElems) - req1 = - if req > largeObjectThreshold - then roundUpToPower2 req - else req - len = arrEnd - arrStart - if req1 < len - then return arr - else realloc req1 arr - --- | Resize the allocated memory to drop any reserved free space at the end of --- the array and reallocate it to reduce wastage. --- --- Up to 25% wastage is allowed to avoid reallocations. If the capacity is --- more than 'largeObjectThreshold' then free space up to the 'blockSize' is --- retained. --- --- /Pre-release/ -{-# INLINE rightSize #-} -rightSize :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m (MutArray a) -rightSize arr@MutArray{..} = do - assert (arrEnd <= arrBound) (return ()) - let start = arrStart - len = arrEnd - start - capacity = arrBound - start - target = roundUpLargeArray len - waste = arrBound - arrEnd - assert (target >= len) (return ()) - assert (len `mod` SIZE_OF(a) == 0) (return ()) - -- We trade off some wastage (25%) to avoid reallocations and copying. - if target < capacity && len < 3 * waste - then realloc target arr - else return arr - -------------------------------------------------------------------------------- --- Snoc -------------------------------------------------------------------------------- - --- XXX We can possibly use a smallMutableByteArray to hold the start, end, --- bound pointers. Using fully mutable handle will ensure that we do not have --- multiple references to the same array of different lengths lying around and --- potentially misused. In that case "snoc" need not return a new array (snoc --- :: MutArray a -> a -> m ()), it will just modify the old reference. The array --- length will be mutable. This means the length function would also be --- monadic. Mutable arrays would behave more like files that grow in that --- case. - --- | Snoc using a 'Ptr'. Low level reusable function. --- --- /Internal/ -{-# INLINE snocNewEnd #-} -snocNewEnd :: (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m (MutArray a) -snocNewEnd newEnd arr@MutArray{..} x = liftIO $ do - assert (newEnd <= arrBound) (return ()) - pokeWith arrContents arrEnd x - return $ arr {arrEnd = newEnd} - --- | Really really unsafe, appends the element into the first array, may --- cause silent data corruption or if you are lucky a segfault if the first --- array does not have enough space to append the element. --- --- /Internal/ -{-# INLINE snocUnsafe #-} -snocUnsafe :: forall m a. (MonadIO m, Unbox a) => - MutArray a -> a -> m (MutArray a) -snocUnsafe arr@MutArray{..} = snocNewEnd (INDEX_NEXT(arrEnd,a)) arr - --- | Like 'snoc' but does not reallocate when pre-allocated array capacity --- becomes full. --- --- /Internal/ -{-# INLINE snocMay #-} -snocMay :: forall m a. (MonadIO m, Unbox a) => - MutArray a -> a -> m (Maybe (MutArray a)) -snocMay arr@MutArray{..} x = liftIO $ do - let newEnd = INDEX_NEXT(arrEnd,a) - if newEnd <= arrBound - then Just <$> snocNewEnd newEnd arr x - else return Nothing - --- NOINLINE to move it out of the way and not pollute the instruction cache. -{-# NOINLINE snocWithRealloc #-} -snocWithRealloc :: forall m a. (MonadIO m, Unbox a) => - (Int -> Int) - -> MutArray a - -> a - -> m (MutArray a) -snocWithRealloc sizer arr x = do - arr1 <- liftIO $ reallocWith "snocWith" sizer (SIZE_OF(a)) arr - snocUnsafe arr1 x - --- | @snocWith sizer arr elem@ mutates @arr@ to append @elem@. The length of --- the array increases by 1. --- --- If there is no reserved space available in @arr@ it is reallocated to a size --- in bytes determined by the @sizer oldSizeBytes@ function, where --- @oldSizeBytes@ is the original size of the array in bytes. --- --- If the new array size is more than 'largeObjectThreshold' we automatically --- round it up to 'blockSize'. --- --- Note that the returned array may be a mutated version of the original array. --- --- /Pre-release/ -{-# INLINE snocWith #-} -snocWith :: forall m a. (MonadIO m, Unbox a) => - (Int -> Int) - -> MutArray a - -> a - -> m (MutArray a) -snocWith allocSize arr x = liftIO $ do - let newEnd = INDEX_NEXT(arrEnd arr,a) - if newEnd <= arrBound arr - then snocNewEnd newEnd arr x - else snocWithRealloc allocSize arr x - --- | The array is mutated to append an additional element to it. If there --- is no reserved space available in the array then it is reallocated to grow --- it by 'arrayChunkBytes' rounded up to 'blockSize' when the size becomes more --- than 'largeObjectThreshold'. --- --- Note that the returned array may be a mutated version of the original array. --- --- Performs O(n^2) copies to grow but is thrifty on memory. --- --- /Pre-release/ -{-# INLINE snocLinear #-} -snocLinear :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) -snocLinear = snocWith (+ allocBytesToBytes (undefined :: a) arrayChunkBytes) - --- | The array is mutated to append an additional element to it. If there is no --- reserved space available in the array then it is reallocated to double the --- original size. --- --- This is useful to reduce allocations when appending unknown number of --- elements. --- --- Note that the returned array may be a mutated version of the original array. --- --- >>> snoc = MutArray.snocWith (* 2) --- --- Performs O(n * log n) copies to grow, but is liberal with memory allocation. --- -{-# INLINE snoc #-} -snoc :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) -snoc = snocWith f - - where - - f oldSize = - if isPower2 oldSize - then oldSize * 2 - else roundUpToPower2 oldSize * 2 - -------------------------------------------------------------------------------- --- Random reads -------------------------------------------------------------------------------- - --- XXX Can this be deduplicated with array/foreign - --- | Return the element at the specified index without checking the bounds. --- --- Unsafe because it does not check the bounds of the array. -{-# INLINE_NORMAL getIndexUnsafe #-} -getIndexUnsafe :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a -getIndexUnsafe i MutArray{..} = do - let index = INDEX_OF(arrStart,i,a) - assert (i >= 0 && INDEX_VALID(index,arrEnd,a)) (return ()) - liftIO $ peekWith arrContents index - --- | /O(1)/ Lookup the element at the given index. Index starts from 0. --- -{-# INLINE getIndex #-} -getIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a -getIndex i MutArray{..} = do - let index = INDEX_OF(arrStart,i,a) - if i >= 0 && INDEX_VALID(index,arrEnd,a) - then liftIO $ peekWith arrContents index - else invalidIndex "getIndex" i - --- | /O(1)/ Lookup the element at the given index from the end of the array. --- Index starts from 0. --- --- Slightly faster than computing the forward index and using getIndex. --- -{-# INLINE getIndexRev #-} -getIndexRev :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a -getIndexRev i MutArray{..} = do - let index = RINDEX_OF(arrEnd,i,a) - if i >= 0 && index >= arrStart - then liftIO $ peekWith arrContents index - else invalidIndex "getIndexRev" i - -data GetIndicesState contents start end st = - GetIndicesState contents start end st - --- | Given an unfold that generates array indices, read the elements on those --- indices from the supplied MutArray. An error is thrown if an index is out of --- bounds. --- --- /Pre-release/ -{-# INLINE getIndicesD #-} -getIndicesD :: (Monad m, Unbox a) => - (forall b. IO b -> m b) -> D.Stream m Int -> Unfold m (MutArray a) a -getIndicesD liftio (D.Stream stepi sti) = Unfold step inject - - where - - inject (MutArray contents start end _) = - return $ GetIndicesState contents start end sti - - {-# INLINE_LATE step #-} - step (GetIndicesState contents start end st) = do - r <- stepi defState st - case r of - D.Yield i s -> do - x <- liftio $ getIndex i (MutArray contents start end undefined) - return $ D.Yield x (GetIndicesState contents start end s) - D.Skip s -> return $ D.Skip (GetIndicesState contents start end s) - D.Stop -> return D.Stop - -{-# INLINE getIndices #-} -getIndices :: (MonadIO m, Unbox a) => Stream m Int -> Unfold m (MutArray a) a -getIndices = getIndicesD liftIO - -------------------------------------------------------------------------------- --- Subarrays -------------------------------------------------------------------------------- - --- XXX We can also get immutable slices. - --- | /O(1)/ Slice an array in constant time. --- --- Unsafe: The bounds of the slice are not checked. --- --- /Unsafe/ --- --- /Pre-release/ -{-# INLINE getSliceUnsafe #-} -getSliceUnsafe :: forall a. Unbox a - => Int -- ^ from index - -> Int -- ^ length of the slice - -> MutArray a - -> MutArray a -getSliceUnsafe index len (MutArray contents start e _) = - let fp1 = INDEX_OF(start,index,a) - end = fp1 + (len * SIZE_OF(a)) - in assert - (index >= 0 && len >= 0 && end <= e) - -- Note: In a slice we always use bound = end so that the slice - -- user cannot overwrite elements beyond the end of the slice. - (MutArray contents fp1 end end) - --- | /O(1)/ Slice an array in constant time. Throws an error if the slice --- extends out of the array bounds. --- --- /Pre-release/ -{-# INLINE getSlice #-} -getSlice :: forall a. Unbox a => - Int -- ^ from index - -> Int -- ^ length of the slice - -> MutArray a - -> MutArray a -getSlice index len (MutArray contents start e _) = - let fp1 = INDEX_OF(start,index,a) - end = fp1 + (len * SIZE_OF(a)) - in if index >= 0 && len >= 0 && end <= e - -- Note: In a slice we always use bound = end so that the slice user - -- cannot overwrite elements beyond the end of the slice. - then MutArray contents fp1 end end - else error - $ "getSlice: invalid slice, index " - ++ show index ++ " length " ++ show len - -------------------------------------------------------------------------------- --- In-place mutation algorithms -------------------------------------------------------------------------------- - --- XXX consider the bulk update/accumulation/permutation APIs from vector. - --- | You may not need to reverse an array because you can consume it in reverse --- using 'readerRev'. To reverse large arrays you can read in reverse and write --- to another array. However, in-place reverse can be useful to take adavantage --- of cache locality and when you do not want to allocate additional memory. --- -{-# INLINE reverse #-} -reverse :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m () -reverse MutArray{..} = liftIO $ do - let l = arrStart - h = INDEX_PREV(arrEnd,a) - in swap l h - - where - - swap l h = do - when (l < h) $ do - swapArrayByteIndices (Proxy :: Proxy a) arrContents l h - swap (INDEX_NEXT(l,a)) (INDEX_PREV(h,a)) - --- | Generate the next permutation of the sequence, returns False if this is --- the last permutation. --- --- /Unimplemented/ -{-# INLINE permute #-} -permute :: MutArray a -> m Bool -permute = undefined - --- | Partition an array into two halves using a partitioning predicate. The --- first half retains values where the predicate is 'False' and the second half --- retains values where the predicate is 'True'. --- --- /Pre-release/ -{-# INLINE partitionBy #-} -partitionBy :: forall m a. (MonadIO m, Unbox a) - => (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) -partitionBy f arr@MutArray{..} = liftIO $ do - if arrStart >= arrEnd - then return (arr, arr) - else do - ptr <- go arrStart (INDEX_PREV(arrEnd,a)) - let pl = MutArray arrContents arrStart ptr ptr - pr = MutArray arrContents ptr arrEnd arrEnd - return (pl, pr) - - where - - -- Invariant low < high on entry, and on return as well - moveHigh low high = do - h <- peekWith arrContents high - if f h - then - -- Correctly classified, continue the loop - let high1 = INDEX_PREV(high,a) - in if low == high1 - then return Nothing - else moveHigh low high1 - else return (Just (high, h)) -- incorrectly classified - - -- Keep a low pointer starting at the start of the array (first partition) - -- and a high pointer starting at the end of the array (second partition). - -- Keep incrementing the low ptr and decrementing the high ptr until both - -- are wrongly classified, at that point swap the two and continue until - -- the two pointer cross each other. - -- - -- Invariants when entering this loop: - -- low <= high - -- Both low and high are valid locations within the array - go low high = do - l <- peekWith arrContents low - if f l - then - -- low is wrongly classified - if low == high - then return low - else do -- low < high - r <- moveHigh low high - case r of - Nothing -> return low - Just (high1, h) -> do -- low < high1 - pokeWith arrContents low h - pokeWith arrContents high1 l - let low1 = INDEX_NEXT(low,a) - high2 = INDEX_PREV(high1,a) - if low1 <= high2 - then go low1 high2 - else return low1 -- low1 > high2 - - else do - -- low is correctly classified - let low1 = INDEX_NEXT(low,a) - if low == high - then return low1 - else go low1 high - --- | Shuffle corresponding elements from two arrays using a shuffle function. --- If the shuffle function returns 'False' then do nothing otherwise swap the --- elements. This can be used in a bottom up fold to shuffle or reorder the --- elements. --- --- /Unimplemented/ -{-# INLINE shuffleBy #-} -shuffleBy :: (a -> a -> m Bool) -> MutArray a -> MutArray a -> m () -shuffleBy = undefined - --- XXX we can also make the folds partial by stopping at a certain level. --- --- | @divideBy level partition array@ performs a top down hierarchical --- recursive partitioning fold of items in the container using the given --- function as the partition function. Level indicates the level in the tree --- where the fold would stop. --- --- This performs a quick sort if the partition function is --- 'partitionBy (< pivot)'. --- --- /Unimplemented/ -{-# INLINABLE divideBy #-} -divideBy :: - Int -> (MutArray a -> m (MutArray a, MutArray a)) -> MutArray a -> m () -divideBy = undefined - --- | @mergeBy level merge array@ performs a pairwise bottom up fold recursively --- merging the pairs using the supplied merge function. Level indicates the --- level in the tree where the fold would stop. --- --- This performs a random shuffle if the merge function is random. If we --- stop at level 0 and repeatedly apply the function then we can do a bubble --- sort. --- --- /Unimplemented/ -mergeBy :: Int -> (MutArray a -> MutArray a -> m ()) -> MutArray a -> m () -mergeBy = undefined - -------------------------------------------------------------------------------- --- Size -------------------------------------------------------------------------------- - --- | /O(1)/ Get the byte length of the array. --- -{-# INLINE byteLength #-} -byteLength :: MutArray a -> Int -byteLength MutArray{..} = - let len = arrEnd - arrStart - in assert (len >= 0) len - --- Note: try to avoid the use of length in performance sensitive internal --- routines as it involves a costly 'div' operation. Instead use the end ptr --- in the array to check the bounds etc. --- --- | /O(1)/ Get the length of the array i.e. the number of elements in the --- array. --- --- Note that 'byteLength' is less expensive than this operation, as 'length' --- involves a costly division operation. --- -{-# INLINE length #-} -length :: forall a. Unbox a => MutArray a -> Int -length arr = - let elemSize = SIZE_OF(a) - blen = byteLength arr - in assert (blen `mod` elemSize == 0) (blen `div` elemSize) - --- | Get the total capacity of an array. An array may have space reserved --- beyond the current used length of the array. --- --- /Pre-release/ -{-# INLINE byteCapacity #-} -byteCapacity :: MutArray a -> Int -byteCapacity MutArray{..} = - let len = arrBound - arrStart - in assert (len >= 0) len - --- | The remaining capacity in the array for appending more elements without --- reallocation. --- --- /Pre-release/ -{-# INLINE bytesFree #-} -bytesFree :: MutArray a -> Int -bytesFree MutArray{..} = - let n = arrBound - arrEnd - in assert (n >= 0) n - -------------------------------------------------------------------------------- --- Streams of arrays - Creation -------------------------------------------------------------------------------- - -data GroupState s contents start end bound - = GroupStart s - | GroupBuffer s contents start end bound - | GroupYield - contents start end bound (GroupState s contents start end bound) - | GroupFinish - --- | @chunksOf n stream@ groups the input stream into a stream of --- arrays of size n. --- --- @chunksOf n = StreamD.foldMany (MutArray.writeN n)@ --- --- /Pre-release/ -{-# INLINE_NORMAL chunksOf #-} -chunksOf :: forall m a. (MonadIO m, Unbox a) - => Int -> D.Stream m a -> D.Stream m (MutArray a) --- XXX the idiomatic implementation leads to large regression in the D.reverse' --- benchmark. It seems it has difficulty producing optimized code when --- converting to StreamK. Investigate GHC optimizations. --- chunksOf n = D.foldMany (writeN n) -chunksOf n (D.Stream step state) = - D.Stream step' (GroupStart state) - - where - - {-# INLINE_LATE step' #-} - step' _ (GroupStart st) = do - when (n <= 0) $ - -- XXX we can pass the module string from the higher level API - error $ "Streamly.Internal.Data.MutArray.Mut.Type.chunksOf: " - ++ "the size of arrays [" ++ show n - ++ "] must be a natural number" - (MutArray contents start end bound :: MutArray a) <- liftIO $ newPinned n - return $ D.Skip (GroupBuffer st contents start end bound) - - step' gst (GroupBuffer st contents start end bound) = do - r <- step (adaptState gst) st - case r of - D.Yield x s -> do - liftIO $ pokeWith contents end x - let end1 = INDEX_NEXT(end,a) - return $ - if end1 >= bound - then D.Skip - (GroupYield - contents start end1 bound (GroupStart s)) - else D.Skip (GroupBuffer s contents start end1 bound) - D.Skip s -> - return $ D.Skip (GroupBuffer s contents start end bound) - D.Stop -> - return - $ D.Skip (GroupYield contents start end bound GroupFinish) - - step' _ (GroupYield contents start end bound next) = - return $ D.Yield (MutArray contents start end bound) next - - step' _ GroupFinish = return D.Stop - --- XXX buffer to a list instead? --- | Buffer the stream into arrays in memory. -{-# INLINE arrayStreamKFromStreamD #-} -arrayStreamKFromStreamD :: forall m a. (MonadIO m, Unbox a) => - D.Stream m a -> m (StreamK m (MutArray a)) -arrayStreamKFromStreamD = - let n = allocBytesToElemCount (undefined :: a) defaultChunkSize - in D.foldr K.cons K.nil . chunksOf n - -------------------------------------------------------------------------------- --- Streams of arrays - Flattening -------------------------------------------------------------------------------- - -data FlattenState s contents a = - OuterLoop s - | InnerLoop s contents !Int !Int - --- | Use the "reader" unfold instead. --- --- @flattenArrays = unfoldMany reader@ --- --- We can try this if there are any fusion issues in the unfold. --- -{-# INLINE_NORMAL flattenArrays #-} -flattenArrays :: forall m a. (MonadIO m, Unbox a) - => D.Stream m (MutArray a) -> D.Stream m a -flattenArrays (D.Stream step state) = D.Stream step' (OuterLoop state) - - where - - {-# INLINE_LATE step' #-} - step' gst (OuterLoop st) = do - r <- step (adaptState gst) st - return $ case r of - D.Yield MutArray{..} s -> - D.Skip (InnerLoop s arrContents arrStart arrEnd) - D.Skip s -> D.Skip (OuterLoop s) - D.Stop -> D.Stop - - step' _ (InnerLoop st _ p end) | assert (p <= end) (p == end) = - return $ D.Skip $ OuterLoop st - - step' _ (InnerLoop st contents p end) = do - x <- liftIO $ peekWith contents p - return $ D.Yield x (InnerLoop st contents (INDEX_NEXT(p,a)) end) - --- | Use the "readerRev" unfold instead. --- --- @flattenArrays = unfoldMany readerRev@ --- --- We can try this if there are any fusion issues in the unfold. --- -{-# INLINE_NORMAL flattenArraysRev #-} -flattenArraysRev :: forall m a. (MonadIO m, Unbox a) - => D.Stream m (MutArray a) -> D.Stream m a -flattenArraysRev (D.Stream step state) = D.Stream step' (OuterLoop state) - - where - - {-# INLINE_LATE step' #-} - step' gst (OuterLoop st) = do - r <- step (adaptState gst) st - return $ case r of - D.Yield MutArray{..} s -> - let p = INDEX_PREV(arrEnd,a) - in D.Skip (InnerLoop s arrContents p arrStart) - D.Skip s -> D.Skip (OuterLoop s) - D.Stop -> D.Stop - - step' _ (InnerLoop st _ p start) | p < start = - return $ D.Skip $ OuterLoop st - - step' _ (InnerLoop st contents p start) = do - x <- liftIO $ peekWith contents p - let cur = INDEX_PREV(p,a) - return $ D.Yield x (InnerLoop st contents cur start) - -------------------------------------------------------------------------------- --- Unfolds -------------------------------------------------------------------------------- - -data ArrayUnsafe a = ArrayUnsafe - {-# UNPACK #-} !MutableByteArray -- contents - {-# UNPACK #-} !Int -- index 1 - {-# UNPACK #-} !Int -- index 2 - -toArrayUnsafe :: MutArray a -> ArrayUnsafe a -toArrayUnsafe (MutArray contents start end _) = ArrayUnsafe contents start end - -fromArrayUnsafe :: -#ifdef DEVBUILD - Unbox a => -#endif - ArrayUnsafe a -> MutArray a -fromArrayUnsafe (ArrayUnsafe contents start end) = - MutArray contents start end end - -{-# INLINE_NORMAL producerWith #-} -producerWith :: - forall m a. (Monad m, Unbox a) - => (forall b. IO b -> m b) -> Producer m (MutArray a) a -producerWith liftio = Producer step (return . toArrayUnsafe) extract - where - - {-# INLINE_LATE step #-} - step (ArrayUnsafe _ cur end) - | assert (cur <= end) (cur == end) = return D.Stop - step (ArrayUnsafe contents cur end) = do - -- When we use a purely lazy Monad like Identity, we need to force a - -- few actions for correctness and execution order sanity. We want - -- the peek to occur right here and not lazily at some later point - -- because we want the peek to be ordered with respect to the touch. - !x <- liftio $ peekWith contents cur - return $ D.Yield x (ArrayUnsafe contents (INDEX_NEXT(cur,a)) end) - - extract = return . fromArrayUnsafe - --- | Resumable unfold of an array. --- -{-# INLINE_NORMAL producer #-} -producer :: forall m a. (MonadIO m, Unbox a) => Producer m (MutArray a) a -producer = producerWith liftIO - --- | Unfold an array into a stream. --- -{-# INLINE_NORMAL reader #-} -reader :: forall m a. (MonadIO m, Unbox a) => Unfold m (MutArray a) a -reader = Producer.simplify producer - -{-# INLINE_NORMAL readerRevWith #-} -readerRevWith :: - forall m a. (Monad m, Unbox a) - => (forall b. IO b -> m b) -> Unfold m (MutArray a) a -readerRevWith liftio = Unfold step inject - where - - inject (MutArray contents start end _) = - let p = INDEX_PREV(end,a) - in return $ ArrayUnsafe contents start p - - {-# INLINE_LATE step #-} - step (ArrayUnsafe _ start p) | p < start = return D.Stop - step (ArrayUnsafe contents start p) = do - !x <- liftio $ peekWith contents p - return $ D.Yield x (ArrayUnsafe contents start (INDEX_PREV(p,a))) - --- | Unfold an array into a stream in reverse order. --- -{-# INLINE_NORMAL readerRev #-} -readerRev :: forall m a. (MonadIO m, Unbox a) => Unfold m (MutArray a) a -readerRev = readerRevWith liftIO - -------------------------------------------------------------------------------- --- to Lists and streams -------------------------------------------------------------------------------- - -{- --- Use foldr/build fusion to fuse with list consumers --- This can be useful when using the IsList instance -{-# INLINE_LATE toListFB #-} -toListFB :: forall a b. Unbox a => (a -> b -> b) -> b -> MutArray a -> b -toListFB c n MutArray{..} = go arrStart - where - - go p | assert (p <= arrEnd) (p == arrEnd) = n - go p = - -- unsafeInlineIO allows us to run this in Identity monad for pure - -- toList/foldr case which makes them much faster due to not - -- accumulating the list and fusing better with the pure consumers. - -- - -- This should be safe as the array contents are guaranteed to be - -- evaluated/written to before we peek at them. - -- XXX - let !x = unsafeInlineIO $ do - r <- peekWith arrContents p - return r - in c x (go (PTR_NEXT(p,a))) --} - --- XXX Monadic foldr/build fusion? --- Reference: https://www.researchgate.net/publication/220676509_Monadic_augment_and_generalised_short_cut_fusion - --- | Convert a 'MutArray' into a list. --- -{-# INLINE toList #-} -toList :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m [a] -toList MutArray{..} = liftIO $ go arrStart - where - - go p | assert (p <= arrEnd) (p == arrEnd) = return [] - go p = do - x <- peekWith arrContents p - (:) x <$> go (INDEX_NEXT(p,a)) - -{-# INLINE_NORMAL toStreamDWith #-} -toStreamDWith :: - forall m a. (Monad m, Unbox a) - => (forall b. IO b -> m b) -> MutArray a -> D.Stream m a -toStreamDWith liftio MutArray{..} = D.Stream step arrStart - - where - - {-# INLINE_LATE step #-} - step _ p | assert (p <= arrEnd) (p == arrEnd) = return D.Stop - step _ p = liftio $ do - r <- peekWith arrContents p - return $ D.Yield r (INDEX_NEXT(p,a)) - --- | Use the 'reader' unfold instead. --- --- @toStreamD = D.unfold reader@ --- --- We can try this if the unfold has any performance issues. -{-# INLINE_NORMAL toStreamD #-} -toStreamD :: forall m a. (MonadIO m, Unbox a) => MutArray a -> D.Stream m a -toStreamD = toStreamDWith liftIO - -{-# INLINE toStreamKWith #-} -toStreamKWith :: - forall m a. (Monad m, Unbox a) - => (forall b. IO b -> m b) -> MutArray a -> StreamK m a -toStreamKWith liftio MutArray{..} = go arrStart - - where - - go p | assert (p <= arrEnd) (p == arrEnd) = K.nil - | otherwise = - let elemM = peekWith arrContents p - in liftio elemM `K.consM` go (INDEX_NEXT(p,a)) - -{-# INLINE toStreamK #-} -toStreamK :: forall m a. (MonadIO m, Unbox a) => MutArray a -> StreamK m a -toStreamK = toStreamKWith liftIO - -{-# INLINE_NORMAL toStreamDRevWith #-} -toStreamDRevWith :: - forall m a. (Monad m, Unbox a) - => (forall b. IO b -> m b) -> MutArray a -> D.Stream m a -toStreamDRevWith liftio MutArray{..} = - let p = INDEX_PREV(arrEnd,a) - in D.Stream step p - - where - - {-# INLINE_LATE step #-} - step _ p | p < arrStart = return D.Stop - step _ p = liftio $ do - r <- peekWith arrContents p - return $ D.Yield r (INDEX_PREV(p,a)) - --- | Use the 'readerRev' unfold instead. --- --- @toStreamDRev = D.unfold readerRev@ --- --- We can try this if the unfold has any perf issues. -{-# INLINE_NORMAL toStreamDRev #-} -toStreamDRev :: forall m a. (MonadIO m, Unbox a) => MutArray a -> D.Stream m a -toStreamDRev = toStreamDRevWith liftIO - -{-# INLINE toStreamKRevWith #-} -toStreamKRevWith :: - forall m a. (Monad m, Unbox a) - => (forall b. IO b -> m b) -> MutArray a -> StreamK m a -toStreamKRevWith liftio MutArray {..} = - let p = INDEX_PREV(arrEnd,a) - in go p - - where - - go p | p < arrStart = K.nil - | otherwise = - let elemM = peekWith arrContents p - in liftio elemM `K.consM` go (INDEX_PREV(p,a)) - -{-# INLINE toStreamKRev #-} -toStreamKRev :: forall m a. (MonadIO m, Unbox a) => MutArray a -> StreamK m a -toStreamKRev = toStreamKRevWith liftIO - -------------------------------------------------------------------------------- --- Folding -------------------------------------------------------------------------------- - --- XXX Need something like "MutArray m a" enforcing monadic action to avoid the --- possibility of such APIs. --- --- | Strict left fold of an array. -{-# INLINE_NORMAL foldl' #-} -foldl' :: (MonadIO m, Unbox a) => (b -> a -> b) -> b -> MutArray a -> m b -foldl' f z arr = D.foldl' f z $ toStreamD arr - --- | Right fold of an array. -{-# INLINE_NORMAL foldr #-} -foldr :: (MonadIO m, Unbox a) => (a -> b -> b) -> b -> MutArray a -> m b -foldr f z arr = D.foldr f z $ toStreamD arr - -------------------------------------------------------------------------------- --- Folds -------------------------------------------------------------------------------- - --- Note: Arrays may be allocated with a specific alignment at the beginning of --- the array. If you need to maintain that alignment on reallocations then you --- can resize the array manually before append, using an aligned resize --- operation. - --- XXX Keep the bound intact to not lose any free space? Perf impact? - --- | @writeAppendNUnsafe n alloc@ appends up to @n@ input items to the supplied --- array. --- --- Unsafe: Do not drive the fold beyond @n@ elements, it will lead to memory --- corruption or segfault. --- --- Any free space left in the array after appending @n@ elements is lost. --- --- /Internal/ -{-# INLINE_NORMAL writeAppendNUnsafe #-} -writeAppendNUnsafe :: forall m a. (MonadIO m, Unbox a) => - Int - -> m (MutArray a) - -> Fold m a (MutArray a) -writeAppendNUnsafe n action = - fmap fromArrayUnsafe $ FL.foldlM' step initial - - where - - initial = do - assert (n >= 0) (return ()) - arr@(MutArray _ _ end bound) <- action - let free = bound - end - needed = n * SIZE_OF(a) - -- XXX We can also reallocate if the array has too much free space, - -- otherwise we lose that space. - arr1 <- - if free < needed - then noinline reallocWith "writeAppendNUnsafeWith" (+ needed) needed arr - else return arr - return $ toArrayUnsafe arr1 - - step (ArrayUnsafe contents start end) x = do - liftIO $ pokeWith contents end x - return $ ArrayUnsafe contents start (INDEX_NEXT(end,a)) - --- | Append @n@ elements to an existing array. Any free space left in the array --- after appending @n@ elements is lost. --- --- >>> writeAppendN n initial = Fold.take n (MutArray.writeAppendNUnsafe n initial) --- -{-# INLINE_NORMAL writeAppendN #-} -writeAppendN :: forall m a. (MonadIO m, Unbox a) => - Int -> m (MutArray a) -> Fold m a (MutArray a) -writeAppendN n initial = FL.take n (writeAppendNUnsafe n initial) - --- | @writeAppendWith realloc action@ mutates the array generated by @action@ to --- append the input stream. If there is no reserved space available in the --- array it is reallocated to a size in bytes determined by @realloc oldSize@, --- where @oldSize@ is the current size of the array in bytes. --- --- Note that the returned array may be a mutated version of original array. --- --- >>> writeAppendWith sizer = Fold.foldlM' (MutArray.snocWith sizer) --- --- /Pre-release/ -{-# INLINE writeAppendWith #-} -writeAppendWith :: forall m a. (MonadIO m, Unbox a) => - (Int -> Int) -> m (MutArray a) -> Fold m a (MutArray a) -writeAppendWith sizer = FL.foldlM' (snocWith sizer) - --- | @append action@ mutates the array generated by @action@ to append the --- input stream. If there is no reserved space available in the array it is --- reallocated to double the size. --- --- Note that the returned array may be a mutated version of original array. --- --- >>> writeAppend = MutArray.writeAppendWith (* 2) --- -{-# INLINE writeAppend #-} -writeAppend :: forall m a. (MonadIO m, Unbox a) => - m (MutArray a) -> Fold m a (MutArray a) -writeAppend = writeAppendWith (* 2) - --- XXX We can carry bound as well in the state to make sure we do not lose the --- remaining capacity. Need to check perf impact. --- --- | Like 'writeNUnsafe' but takes a new array allocator @alloc size@ function --- as argument. --- --- >>> writeNWithUnsafe alloc n = MutArray.writeAppendNUnsafe (alloc n) n --- --- /Pre-release/ -{-# INLINE_NORMAL writeNWithUnsafe #-} -writeNWithUnsafe :: forall m a. (MonadIO m, Unbox a) - => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) -writeNWithUnsafe alloc n = fromArrayUnsafe <$> FL.foldlM' step initial - - where - - initial = toArrayUnsafe <$> alloc (max n 0) - - step (ArrayUnsafe contents start end) x = do - liftIO $ pokeWith contents end x - return - $ ArrayUnsafe contents start (INDEX_NEXT(end,a)) - --- | Like 'writeN' but does not check the array bounds when writing. The fold --- driver must not call the step function more than 'n' times otherwise it will --- corrupt the memory and crash. This function exists mainly because any --- conditional in the step function blocks fusion causing 10x performance --- slowdown. --- --- >>> writeNUnsafe = MutArray.writeNWithUnsafe MutArray.newPinned --- -{-# INLINE_NORMAL writeNUnsafe #-} -writeNUnsafe :: forall m a. (MonadIO m, Unbox a) - => Int -> Fold m a (MutArray a) -writeNUnsafe = writeNWithUnsafe newPinned - --- | @writeNWith alloc n@ folds a maximum of @n@ elements into an array --- allocated using the @alloc@ function. --- --- >>> writeNWith alloc n = Fold.take n (MutArray.writeNWithUnsafe alloc n) --- >>> writeNWith alloc n = MutArray.writeAppendN (alloc n) n --- -{-# INLINE_NORMAL writeNWith #-} -writeNWith :: forall m a. (MonadIO m, Unbox a) - => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) -writeNWith alloc n = FL.take n (writeNWithUnsafe alloc n) - --- | @writeN n@ folds a maximum of @n@ elements from the input stream to an --- 'MutArray'. --- --- >>> writeN = MutArray.writeNWith MutArray.newPinned --- >>> writeN n = Fold.take n (MutArray.writeNUnsafe n) --- >>> writeN n = MutArray.writeAppendN n (MutArray.newPinned n) --- -{-# INLINE_NORMAL writeN #-} -writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) -writeN = writeNWith newPinned - --- | Like writeNWithUnsafe but writes the array in reverse order. --- --- /Internal/ -{-# INLINE_NORMAL writeRevNWithUnsafe #-} -writeRevNWithUnsafe :: forall m a. (MonadIO m, Unbox a) - => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) -writeRevNWithUnsafe alloc n = fromArrayUnsafe <$> FL.foldlM' step initial - - where - - toArrayUnsafeRev (MutArray contents _ _ bound) = - ArrayUnsafe contents bound bound - - initial = toArrayUnsafeRev <$> alloc (max n 0) - - step (ArrayUnsafe contents start end) x = do - let ptr = INDEX_PREV(start,a) - liftIO $ pokeWith contents ptr x - return - $ ArrayUnsafe contents ptr end - --- | Like writeNWith but writes the array in reverse order. --- --- /Internal/ -{-# INLINE_NORMAL writeRevNWith #-} -writeRevNWith :: forall m a. (MonadIO m, Unbox a) - => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) -writeRevNWith alloc n = FL.take n (writeRevNWithUnsafe alloc n) - --- | Like writeN but writes the array in reverse order. --- --- /Pre-release/ -{-# INLINE_NORMAL writeRevN #-} -writeRevN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) -writeRevN = writeRevNWith newPinned - --- | @writeNAligned align n@ folds a maximum of @n@ elements from the input --- stream to a 'MutArray' aligned to the given size. --- --- >>> writeNAligned align = MutArray.writeNWith (MutArray.newAlignedPinned align) --- >>> writeNAligned align n = MutArray.writeAppendN n (MutArray.newAlignedPinned align n) --- --- /Pre-release/ --- -{-# INLINE_NORMAL writeNAligned #-} -writeNAligned :: forall m a. (MonadIO m, Unbox a) - => Int -> Int -> Fold m a (MutArray a) -writeNAligned align = writeNWith (newAlignedPinned align) - --- XXX Buffer to a list instead? --- --- | Buffer a stream into a stream of arrays. --- --- >>> writeChunks n = Fold.many (MutArray.writeN n) Fold.toStreamK --- --- Breaking an array into an array stream can be useful to consume a large --- array sequentially such that memory of the array is released incrementatlly. --- --- See also: 'arrayStreamKFromStreamD'. --- --- /Unimplemented/ --- -{-# INLINE_NORMAL writeChunks #-} -writeChunks :: (MonadIO m, Unbox a) => - Int -> Fold m a (StreamK n (MutArray a)) -writeChunks n = FL.many (writeN n) FL.toStreamK - --- XXX Compare writeWith with fromStreamD which uses an array of streams --- implementation. We can write this using writeChunks above if that is faster. --- If writeWith is faster then we should use that to implement --- fromStreamD. --- --- XXX The realloc based implementation needs to make one extra copy if we use --- shrinkToFit. On the other hand, the stream of arrays implementation may --- buffer the array chunk pointers in memory but it does not have to shrink as --- we know the exact size in the end. However, memory copying does not seem to --- be as expensive as the allocations. Therefore, we need to reduce the number --- of allocations instead. Also, the size of allocations matters, right sizing --- an allocation even at the cost of copying sems to help. Should be measured --- on a big stream with heavy calls to toArray to see the effect. --- --- XXX check if GHC's memory allocator is efficient enough. We can try the C --- malloc to compare against. - --- | @writeWith minCount@ folds the whole input to a single array. The array --- starts at a size big enough to hold minCount elements, the size is doubled --- every time the array needs to be grown. --- --- /Caution! Do not use this on infinite streams./ --- --- >>> f n = MutArray.writeAppendWith (* 2) (MutArray.newPinned n) --- >>> writeWith n = Fold.rmapM MutArray.rightSize (f n) --- >>> writeWith n = Fold.rmapM MutArray.fromArrayStreamK (MutArray.writeChunks n) --- --- /Pre-release/ -{-# INLINE_NORMAL writeWith #-} -writeWith :: forall m a. (MonadIO m, Unbox a) - => Int -> Fold m a (MutArray a) --- writeWith n = FL.rmapM rightSize $ writeAppendWith (* 2) (newPinned n) -writeWith elemCount = - FL.rmapM extract $ FL.foldlM' step initial - - where - - initial = do - when (elemCount < 0) $ error "writeWith: elemCount is negative" - liftIO $ newPinned elemCount - - step arr@(MutArray _ start end bound) x - | INDEX_NEXT(end,a) > bound = do - let oldSize = end - start - newSize = max (oldSize * 2) 1 - arr1 <- liftIO $ reallocExplicit (SIZE_OF(a)) newSize arr - snocUnsafe arr1 x - step arr x = snocUnsafe arr x - - extract = liftIO . rightSize - --- | Fold the whole input to a single array. --- --- Same as 'writeWith' using an initial array size of 'arrayChunkBytes' bytes --- rounded up to the element size. --- --- /Caution! Do not use this on infinite streams./ --- -{-# INLINE write #-} -write :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) -write = writeWith (allocBytesToElemCount (undefined :: a) arrayChunkBytes) - -------------------------------------------------------------------------------- --- construct from streams, known size -------------------------------------------------------------------------------- - --- | Use the 'writeN' fold instead. --- --- >>> fromStreamDN n = Stream.fold (MutArray.writeN n) --- -{-# INLINE_NORMAL fromStreamDN #-} -fromStreamDN :: forall m a. (MonadIO m, Unbox a) - => Int -> D.Stream m a -> m (MutArray a) --- fromStreamDN n = D.fold (writeN n) -fromStreamDN limit str = do - (arr :: MutArray a) <- liftIO $ newPinned limit - end <- D.foldlM' (fwrite (arrContents arr)) (return $ arrEnd arr) $ D.take limit str - return $ arr {arrEnd = end} - - where - - fwrite arrContents ptr x = do - liftIO $ pokeWith arrContents ptr x - return $ INDEX_NEXT(ptr,a) - --- | Create a 'MutArray' from the first N elements of a list. The array is --- allocated to size N, if the list terminates before N elements then the --- array may hold less than N elements. --- -{-# INLINABLE fromListN #-} -fromListN :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) -fromListN n xs = fromStreamDN n $ D.fromList xs - --- | Like fromListN but writes the array in reverse order. --- --- /Pre-release/ -{-# INLINE fromListRevN #-} -fromListRevN :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) -fromListRevN n xs = D.fold (writeRevN n) $ D.fromList xs - -------------------------------------------------------------------------------- --- convert stream to a single array -------------------------------------------------------------------------------- - -{-# INLINE arrayStreamKLength #-} -arrayStreamKLength :: (Monad m, Unbox a) => StreamK m (MutArray a) -> m Int -arrayStreamKLength as = K.foldl' (+) 0 (K.map length as) - --- | Convert an array stream to an array. Note that this requires peak memory --- that is double the size of the array stream. --- -{-# INLINE fromArrayStreamK #-} -fromArrayStreamK :: (Unbox a, MonadIO m) => - StreamK m (MutArray a) -> m (MutArray a) -fromArrayStreamK as = do - len <- arrayStreamKLength as - fromStreamDN len $ D.unfoldMany reader $ D.fromStreamK as - --- CAUTION: a very large number (millions) of arrays can degrade performance --- due to GC overhead because we need to buffer the arrays before we flatten --- all the arrays. --- --- XXX Compare if this is faster or "fold write". --- --- | We could take the approach of doubling the memory allocation on each --- overflow. This would result in more or less the same amount of copying as in --- the chunking approach. However, if we have to shrink in the end then it may --- result in an extra copy of the entire data. --- --- >>> fromStreamD = StreamD.fold MutArray.write --- -{-# INLINE fromStreamD #-} -fromStreamD :: (MonadIO m, Unbox a) => D.Stream m a -> m (MutArray a) -fromStreamD m = arrayStreamKFromStreamD m >>= fromArrayStreamK - --- | Create a 'MutArray' from a list. The list must be of finite size. --- -{-# INLINE fromList #-} -fromList :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) -fromList xs = fromStreamD $ D.fromList xs - --- XXX We are materializing the whole list first for getting the length. Check --- if the 'fromList' like chunked implementation would fare better. - --- | Like 'fromList' but writes the contents of the list in reverse order. -{-# INLINE fromListRev #-} -fromListRev :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) -fromListRev xs = fromListRevN (Prelude.length xs) xs - -------------------------------------------------------------------------------- --- Combining -------------------------------------------------------------------------------- - --- | Put a sub range of a source array into a subrange of a destination array. --- This is not safe as it does not check the bounds. -{-# INLINE putSliceUnsafe #-} -putSliceUnsafe :: MonadIO m => MutArray a -> Int -> MutArray a -> Int -> Int -> m () -putSliceUnsafe src srcStartBytes dst dstStartBytes lenBytes = liftIO $ do - assertM(lenBytes <= arrBound dst - dstStartBytes) - assertM(lenBytes <= arrEnd src - srcStartBytes) - let !(I# srcStartBytes#) = srcStartBytes - !(I# dstStartBytes#) = dstStartBytes - !(I# lenBytes#) = lenBytes - let arrS# = getMutableByteArray# (arrContents src) - arrD# = getMutableByteArray# (arrContents dst) - IO $ \s# -> (# copyMutableByteArray# - arrS# srcStartBytes# arrD# dstStartBytes# lenBytes# s# - , () #) - --- | Copy two arrays into a newly allocated array. -{-# INLINE spliceCopy #-} -spliceCopy :: forall m a. MonadIO m => -#ifdef DEVBUILD - Unbox a => -#endif - MutArray a -> MutArray a -> m (MutArray a) -spliceCopy arr1 arr2 = liftIO $ do - let start1 = arrStart arr1 - start2 = arrStart arr2 - len1 = arrEnd arr1 - start1 - len2 = arrEnd arr2 - start2 - newArrContents <- liftIO $ Unboxed.newPinnedBytes (len1 + len2) - let len = len1 + len2 - newArr = MutArray newArrContents 0 len len - putSliceUnsafe arr1 start1 newArr 0 len1 - putSliceUnsafe arr2 start2 newArr len1 len2 - return newArr - --- | Really really unsafe, appends the second array into the first array. If --- the first array does not have enough space it may cause silent data --- corruption or if you are lucky a segfault. -{-# INLINE spliceUnsafe #-} -spliceUnsafe :: MonadIO m => - MutArray a -> MutArray a -> m (MutArray a) -spliceUnsafe dst src = - liftIO $ do - let startSrc = arrStart src - srcLen = arrEnd src - startSrc - endDst = arrEnd dst - assertM(endDst + srcLen <= arrBound dst) - putSliceUnsafe src startSrc dst endDst srcLen - return $ dst {arrEnd = endDst + srcLen} - --- | @spliceWith sizer dst src@ mutates @dst@ to append @src@. If there is no --- reserved space available in @dst@ it is reallocated to a size determined by --- the @sizer dstBytes srcBytes@ function, where @dstBytes@ is the size of the --- first array and @srcBytes@ is the size of the second array, in bytes. --- --- Note that the returned array may be a mutated version of first array. --- --- /Pre-release/ -{-# INLINE spliceWith #-} -spliceWith :: forall m a. (MonadIO m, Unbox a) => - (Int -> Int -> Int) -> MutArray a -> MutArray a -> m (MutArray a) -spliceWith sizer dst@(MutArray _ start end bound) src = do -{- - let f = writeAppendWith (`sizer` byteLength src) (return dst) - in D.fold f (toStreamD src) --} - assert (end <= bound) (return ()) - let srcBytes = arrEnd src - arrStart src - - dst1 <- - if end + srcBytes >= bound - then do - let dstBytes = end - start - newSizeInBytes = sizer dstBytes srcBytes - when (newSizeInBytes < dstBytes + srcBytes) - $ error - $ "splice: newSize is less than the total size " - ++ "of arrays being appended. Please check the " - ++ "sizer function passed." - liftIO $ realloc newSizeInBytes dst - else return dst - spliceUnsafe dst1 src - --- | The first array is mutated to append the second array. If there is no --- reserved space available in the first array a new allocation of exact --- required size is done. --- --- Note that the returned array may be a mutated version of first array. --- --- >>> splice = MutArray.spliceWith (+) --- --- /Pre-release/ -{-# INLINE splice #-} -splice :: (MonadIO m, Unbox a) => MutArray a -> MutArray a -> m (MutArray a) -splice = spliceWith (+) - --- | Like 'append' but the growth of the array is exponential. Whenever a new --- allocation is required the previous array size is at least doubled. --- --- This is useful to reduce allocations when folding many arrays together. --- --- Note that the returned array may be a mutated version of first array. --- --- >>> spliceExp = MutArray.spliceWith (\l1 l2 -> max (l1 * 2) (l1 + l2)) --- --- /Pre-release/ -{-# INLINE spliceExp #-} -spliceExp :: (MonadIO m, Unbox a) => MutArray a -> MutArray a -> m (MutArray a) -spliceExp = spliceWith (\l1 l2 -> max (l1 * 2) (l1 + l2)) - -------------------------------------------------------------------------------- --- Splitting -------------------------------------------------------------------------------- - --- | Drops the separator byte -{-# INLINE breakOn #-} -breakOn :: MonadIO m - => Word8 -> MutArray Word8 -> m (MutArray Word8, Maybe (MutArray Word8)) -breakOn sep arr@MutArray{..} = asPtrUnsafe arr $ \p -> liftIO $ do - -- XXX Instead of using asPtrUnsafe (pinning memory) we can pass unlifted - -- Addr# to memchr and it should be safe (from ghc 8.4). - -- XXX We do not need memchr here, we can use a Haskell equivalent. - loc <- c_memchr p sep (fromIntegral $ byteLength arr) - let sepIndex = loc `minusPtr` p - return $ - if loc == nullPtr - then (arr, Nothing) - else - ( MutArray - { arrContents = arrContents - , arrStart = arrStart - , arrEnd = arrStart + sepIndex -- exclude the separator - , arrBound = arrStart + sepIndex - } - , Just $ MutArray - { arrContents = arrContents - , arrStart = arrStart + (sepIndex + 1) - , arrEnd = arrEnd - , arrBound = arrBound - } - ) - --- | Create two slices of an array without copying the original array. The --- specified index @i@ is the first index of the second slice. --- -splitAt :: forall a. Unbox a => Int -> MutArray a -> (MutArray a, MutArray a) -splitAt i arr@MutArray{..} = - let maxIndex = length arr - 1 - in if i < 0 - then error "sliceAt: negative array index" - else if i > maxIndex - then error $ "sliceAt: specified array index " ++ show i - ++ " is beyond the maximum index " ++ show maxIndex - else let off = i * SIZE_OF(a) - p = arrStart + off - in ( MutArray - { arrContents = arrContents - , arrStart = arrStart - , arrEnd = p - , arrBound = p - } - , MutArray - { arrContents = arrContents - , arrStart = p - , arrEnd = arrEnd - , arrBound = arrBound - } - ) - -------------------------------------------------------------------------------- --- Casting -------------------------------------------------------------------------------- - --- | Cast an array having elements of type @a@ into an array having elements of --- type @b@. The array size must be a multiple of the size of type @b@ --- otherwise accessing the last element of the array may result into a crash or --- a random value. --- --- /Pre-release/ --- -castUnsafe :: -#ifdef DEVBUILD - Unbox b => -#endif - MutArray a -> MutArray b -castUnsafe (MutArray contents start end bound) = - MutArray contents start end bound - --- | Cast an @MutArray a@ into an @MutArray Word8@. --- -asBytes :: MutArray a -> MutArray Word8 -asBytes = castUnsafe - --- | Cast an array having elements of type @a@ into an array having elements of --- type @b@. The length of the array should be a multiple of the size of the --- target element otherwise 'Nothing' is returned. --- -cast :: forall a b. Unbox b => MutArray a -> Maybe (MutArray b) -cast arr = - let len = byteLength arr - r = len `mod` SIZE_OF(b) - in if r /= 0 - then Nothing - else Just $ castUnsafe arr - --- XXX We can provide another API for "unsafe" FFI calls passing an unlifted --- pointer to the FFI call. For unsafe calls we do not need to pin the array. --- We can pass an unlifted pointer to the FFI routine to avoid GC kicking in --- before the pointer is wrapped. --- --- From the GHC manual: --- --- GHC, since version 8.4, guarantees that garbage collection will never occur --- during an unsafe call, even in the bytecode interpreter, and further --- guarantees that unsafe calls will be performed in the calling thread. Making --- it safe to pass heap-allocated objects to unsafe functions. - --- Unsafe because of direct pointer operations. The user must ensure that they --- are writing within the legal bounds of the array. Should we just name it --- asPtr, the unsafety is implicit for any pointer operations. And we are safe --- from Haskell perspective because we will be pinning the memory. - --- | Use an @MutArray a@ as @Ptr a@. This is useful when we want to pass an array --- as a pointer to some operating system call or to a "safe" FFI call. --- --- If the array is not pinned it is copied to pinned memory before passing it --- to the monadic action. --- --- /Performance Notes:/ Forces a copy if the array is not pinned. It is advised --- that the programmer keeps this in mind and creates a pinned array --- opportunistically before this operation occurs, to avoid the cost of a copy --- if possible. --- --- /Unsafe/ --- --- /Pre-release/ --- -asPtrUnsafe :: MonadIO m => MutArray a -> (Ptr a -> m b) -> m b -asPtrUnsafe arr f = do - let contents = arrContents arr - !ptr = Ptr (byteArrayContents# - (unsafeCoerce# (getMutableByteArray# contents))) - -- XXX Check if the array is pinned, if not, copy it to a pinned array - -- XXX We should probably pass to the IO action the byte length of the array - -- as well so that bounds can be checked. - r <- f (ptr `plusPtr` arrStart arr) - liftIO $ touch contents - return r - -------------------------------------------------------------------------------- --- Equality -------------------------------------------------------------------------------- - --- | Compare the length of the arrays. If the length is equal, compare the --- lexicographical ordering of two underlying byte arrays otherwise return the --- result of length comparison. --- --- /Pre-release/ -{-# INLINE cmp #-} -cmp :: MonadIO m => MutArray a -> MutArray a -> m Ordering -cmp arr1 arr2 = - liftIO - $ do - let marr1 = getMutableByteArray# (arrContents arr1) - marr2 = getMutableByteArray# (arrContents arr2) - !(I# st1#) = arrStart arr1 - !(I# st2#) = arrStart arr2 - !(I# len#) = byteLength arr1 - case compare (byteLength arr1) (byteLength arr2) of - EQ -> do - r <- liftIO $ IO $ \s# -> - let res = - I# - (compareByteArrays# - (unsafeCoerce# marr1) - st1# - (unsafeCoerce# marr2) - st2# - len#) - in (# s#, res #) - return $ compare r 0 - x -> return x - -------------------------------------------------------------------------------- --- NFData -------------------------------------------------------------------------------- - --- | Strip elements which match with predicate from both ends. --- --- /Pre-release/ -{-# INLINE strip #-} -strip :: forall a m. (Unbox a, MonadIO m) => - (a -> Bool) -> MutArray a -> m (MutArray a) -strip eq arr@MutArray{..} = liftIO $ do - st <- getStart arrStart - end <- getLast arrEnd st - return arr {arrStart = st, arrEnd = end, arrBound = end} - - where - - {- - -- XXX This should have the same perf but it does not, investigate. - getStart = do - r <- liftIO $ D.head $ D.findIndices (not . eq) $ toStreamD arr - pure $ - case r of - Nothing -> arrEnd - Just i -> PTR_INDEX(arrStart,i,a) - -} - - getStart cur = do - if cur < arrEnd - then do - r <- peekWith arrContents cur - if eq r - then getStart (INDEX_NEXT(cur,a)) - else return cur - else return cur - - getLast cur low = do - if cur > low - then do - let prev = INDEX_PREV(cur,a) - r <- peekWith arrContents prev - if eq r - then getLast prev low - else return cur - else return cur - --- | Given an array sorted in ascending order except the last element being out --- of order, use bubble sort to place the last element at the right place such --- that the array remains sorted in ascending order. --- --- /Pre-release/ -{-# INLINE bubble #-} -bubble :: (MonadIO m, Unbox a) => (a -> a -> Ordering) -> MutArray a -> m () -bubble cmp0 arr = - when (l > 1) $ do - x <- getIndexUnsafe (l - 1) arr - go x (l - 2) - - where - - l = length arr - - go x i = - if i >= 0 - then do - x1 <- getIndexUnsafe i arr - case x `cmp0` x1 of - LT -> do - putIndexUnsafe (i + 1) arr x1 - go x (i - 1) - _ -> putIndexUnsafe (i + 1) arr x - else putIndexUnsafe (i + 1) arr x diff --git a/src/Streamly/Internal/Data/Array/Stream.hs b/src/Streamly/Internal/Data/Array/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/Stream.hs @@ -0,0 +1,723 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +-- | +-- Module : Streamly.Internal.Data.Array.Stream +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- Combinators to efficiently manipulate streams of immutable arrays. +-- +-- We can either push these in the MutArray module with a "chunks" prefix or +-- keep this as a separate module and release it. +-- +module Streamly.Internal.Data.Array.Stream +{-# DEPRECATED "Please use \"Streamly.Internal.Data.Array\" instead." #-} + ( + -- * Creation + Array.chunksOf + , Array.pinnedChunksOf + , Array.bufferChunks + + -- * Flattening to elements + , Array.concat + , Array.flattenArrays + , Array.concatRev + , Array.flattenArraysRev + , Array.interpose + , Array.interposeSuffix + , Array.intercalateSuffix + , unlines + + -- * Elimination + -- ** Element Folds + -- The byte level foldBreak can work as efficiently as the chunk level. We + -- can flatten the stream to byte stream and use that. But if we want the + -- remaining stream to be a chunk stream then this could be handy. But it + -- could also be implemented using parseBreak. + , foldBreak + , foldBreakD + -- This is chunked parseBreak. A byte level parseBreak cannot work + -- efficiently. Because the stream will have to be a StreamK for + -- backtracking, StreamK at byte level would not be efficient. + -- parseBreak p = K.parseBreakChunks (ParserK.adaptC p) + , parseBreak + -- , parseBreakD + -- , foldManyChunks + -- , parseManyChunks + , K.parseBreakChunks + , K.parseChunks + + -- ** Array Folds + -- XXX Use parseBreakChunks/parseChunks instead + -- foldBreak can be implemented using parseBreak. Use StreamK. + , runArrayFold + , runArrayFoldBreak + -- , parseArr + , runArrayParserDBreak -- StreamK.parseBreakChunks + , runArrayFoldMany + + , toArray + + -- * Compaction + -- We can use something like foldManyChunks, parseManyChunks with a take + -- fold. + , lpackArraysChunksOf -- Fold.compactChunks + , compact -- rechunk, compactChunks + + -- * Splitting + -- We can use something like foldManyChunks, parseManyChunks with an + -- appropriate splitting fold. + , splitOn -- Stream.rechunkOn + , splitOnSuffix -- Stream.rechunkOnSuffix + ) +where + +#include "ArrayMacros.h" +#include "inline.hs" + +import Data.Bifunctor (second) +import Control.Exception (assert) +import Control.Monad.IO.Class (MonadIO(..)) +-- import Data.Bifunctor (first) +-- import Data.Either (fromRight) +import Data.Proxy (Proxy(..)) +import Data.Word (Word8) +import Streamly.Internal.Data.Unbox (Unbox(..)) +import Fusion.Plugin.Types (Fuse(..)) +import GHC.Exts (SpecConstrAnnotation(..)) +import GHC.Types (SPEC(..)) +import Prelude hiding (null, last, (!!), read, concat, unlines) + +import Streamly.Data.Fold (Fold) +import Streamly.Internal.Data.Array.Type (Array(..)) +import Streamly.Internal.Data.Fold.Chunked (ChunkFold(..)) +import Streamly.Internal.Data.Parser (ParseError(..)) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.StreamK (StreamK, fromStream, toStream) +import Streamly.Internal.Data.SVar.Type (adaptState, defState) + +import qualified Streamly.Internal.Data.Array as A +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.Parser as PR +import qualified Streamly.Internal.Data.Parser as PRD + (Parser(..), Initial(..)) +-- import qualified Streamly.Internal.Data.ParserK as ParserK +import qualified Streamly.Internal.Data.Stream as D +import qualified Streamly.Internal.Data.StreamK as K + +-- XXX Since these are immutable arrays MonadIO constraint can be removed from +-- most places. + +------------------------------------------------------------------------------- +-- Intersperse and append +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL unlines #-} +unlines :: forall m a. (MonadIO m, Unbox a) + => a -> D.Stream m (Array a) -> D.Stream m a +unlines = Array.interposeSuffix + +------------------------------------------------------------------------------- +-- Compact +------------------------------------------------------------------------------- + +-- XXX instead of writing two different versions of this operation, we should +-- write it as a pipe. +-- +-- XXX Confirm that immutable arrays won't be modified. +{-# INLINE_NORMAL lpackArraysChunksOf #-} +lpackArraysChunksOf :: (MonadIO m, Unbox a) + => Int -> Fold m (Array a) () -> Fold m (Array a) () +lpackArraysChunksOf = Array.lCompactGE + +-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a +-- maximum specified size in bytes. +-- +-- @since 0.7.0 +{-# INLINE compact #-} +compact :: (MonadIO m, Unbox a) + => Int -> Stream m (Array a) -> Stream m (Array a) +compact = Array.compactLE + +-- | Given a stream of arrays, splice them all together to generate a single +-- array. The stream must be /finite/. +-- +-- @since 0.7.0 +{-# INLINE toArray #-} +toArray :: (MonadIO m, Unbox a) => Stream m (Array a) -> m (Array a) +toArray = Array.fromChunks + +------------------------------------------------------------------------------- +-- Split +------------------------------------------------------------------------------- + +-- XXX Remove MonadIO constraint. +-- | Split a stream of arrays on a given separator byte, dropping the separator +-- and coalescing all the arrays between two separators into a single array. +-- +-- @since 0.7.0 +{-# INLINE splitOn #-} +splitOn + :: (MonadIO m) + => Word8 + -> Stream m (Array Word8) + -> Stream m (Array Word8) +splitOn = Array.compactOnByte + +{-# INLINE splitOnSuffix #-} +splitOnSuffix + :: (MonadIO m) + => Word8 + -> Stream m (Array Word8) + -> Stream m (Array Word8) +splitOnSuffix = Array.compactOnByteSuffix + +------------------------------------------------------------------------------- +-- Elimination - Running folds +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL foldBreakD #-} +foldBreakD :: forall m a b. (MonadIO m, Unbox a) => + Fold m a b -> D.Stream m (Array a) -> m (b, D.Stream m (Array a)) +foldBreakD = Array.foldBreakChunks + +-- | Fold an array stream using the supplied 'Fold'. Returns the fold result +-- and the unconsumed stream. +-- +-- > foldBreak f = runArrayFoldBreak (ChunkFold.fromFold f) +-- +-- Instead of using this we can adapt the fold to ParserK and use +-- parseBreakChunks instead. ParserK allows composing using Monad as well. +-- +-- @ +-- foldBreak f s = +-- fmap (first (fromRight undefined)) +-- $ K.parseBreakChunks (ParserK.adaptC (PR.fromFold f)) s +-- @ +-- +-- We can compare perf and remove this one or define it in terms of that. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL foldBreak #-} +foldBreak :: + (MonadIO m, Unbox a) + => Fold m a b + -> StreamK m (A.Array a) + -> m (b, StreamK m (A.Array a)) +foldBreak = Array.foldBreakChunksK +-- +-- foldBreak f s = fmap fromStreamD <$> foldBreakD f (toStreamD s) +-- +-- foldBreak f s = +-- fmap (first (fromRight undefined)) +-- $ K.parseBreakChunks (ParserK.adaptC (PR.fromFold f)) s +-- +-- If foldBreak performs better than runArrayFoldBreak we can use a rewrite +-- rule to rewrite runArrayFoldBreak to fold. +-- foldBreak f = runArrayFoldBreak (ChunkFold.fromFold f) + +------------------------------------------------------------------------------- +-- Elimination - running element parsers +------------------------------------------------------------------------------- + +-- When we have to take an array partially, take the last part of the array. +{-# INLINE takeArrayListRev #-} +takeArrayListRev :: forall a. Unbox a => Int -> [Array a] -> [Array a] +takeArrayListRev = go + + where + + go _ [] = [] + go n _ | n <= 0 = [] + go n (x:xs) = + let len = Array.length x + in if n > len + then x : go (n - len) xs + else if n == len + then [x] + else let !(Array contents _ end) = x + !start = end - (n * SIZE_OF(a)) + in [Array contents start end] + +-- When we have to take an array partially, take the last part of the array in +-- the first split. +{-# INLINE splitAtArrayListRev #-} +splitAtArrayListRev :: + forall a. Unbox a => Int -> [Array a] -> ([Array a],[Array a]) +splitAtArrayListRev n ls + | n <= 0 = ([], ls) + | otherwise = go n ls + where + go :: Int -> [Array a] -> ([Array a], [Array a]) + go _ [] = ([], []) + go m (x:xs) = + let len = Array.length x + (xs', xs'') = go (m - len) xs + in if m > len + then (x:xs', xs'') + else if m == len + then ([x],xs) + else let !(Array contents start end) = x + end1 = end - (m * SIZE_OF(a)) + arr2 = Array contents start end1 + arr1 = Array contents end1 end + in ([arr1], arr2:xs) + +-- GHC parser does not accept {-# ANN type [] NoSpecConstr #-}, so we need +-- to make a newtype. +{-# ANN type List NoSpecConstr #-} +newtype List a = List {getList :: [a]} + +-- | Parse an array stream using the supplied 'Parser'. Returns the parse +-- result and the unconsumed stream. Throws 'ParseError' if the parse fails. +-- +-- >> parseBreak p = K.parseBreakChunks (ParserK.adaptC p) +-- +-- This is redundant and we can just use parseBreakChunks, as ParserK can be +-- composed using Monad. The only advantage of this is that we do not need to +-- adapt. +-- +-- We can compare perf and remove this one or define it in terms of that. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL parseBreak #-} +parseBreak :: + (MonadIO m, Unbox a) + => PR.Parser a m b + -> StreamK m (A.Array a) + -> m (Either ParseError b, StreamK m (A.Array a)) +{- +parseBreak p s = + fmap fromStreamD <$> parseBreakD (PRD.fromParserK p) (toStreamD s) +-} +parseBreak p = Array.parseBreak (Array.toParserK p) + +------------------------------------------------------------------------------- +-- Elimination - Running Array Folds and parsers +------------------------------------------------------------------------------- + +-- | Note that this is not the same as using a @Parser (Array a) m b@ with the +-- regular "Streamly.Internal.Data.IsStream.parse" function. The regular parse +-- would consume the input arrays as single unit. This parser parses in the way +-- as described in the ChunkFold module. The input arrays are treated as @n@ +-- element units and can be consumed partially. The remaining elements are +-- inserted in the source stream as an array. +-- +{-# INLINE_NORMAL runArrayParserDBreak #-} +runArrayParserDBreak :: + forall m a b. (MonadIO m, Unbox a) + => PRD.Parser (Array a) m b + -> D.Stream m (Array.Array a) + -> m (Either ParseError b, D.Stream m (Array.Array a)) +runArrayParserDBreak + (PRD.Parser pstep initial extract) + stream@(D.Stream step state) = do + + res <- initial + case res of + PRD.IPartial s -> go SPEC state (List []) s + PRD.IDone b -> return (Right b, stream) + PRD.IError err -> return (Left (ParseError err), stream) + + where + + -- "backBuf" contains last few items in the stream that we may have to + -- backtrack to. + -- + -- XXX currently we are using a dumb list based approach for backtracking + -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. + -- That will allow us more efficient random back and forth movement. + go _ st backBuf !pst = do + r <- step defState st + case r of + D.Yield x s -> gobuf SPEC [x] s backBuf pst + D.Skip s -> go SPEC s backBuf pst + D.Stop -> goStop backBuf pst + + gobuf !_ [] s backBuf !pst = go SPEC s backBuf pst + gobuf !_ (x:xs) s backBuf !pst = do + pRes <- pstep pst x + case pRes of + PR.Partial 0 pst1 -> + gobuf SPEC xs s (List []) pst1 + PR.Partial n pst1 -> do + assert + (n <= sum (map Array.length (x:getList backBuf))) + (return ()) + let src0 = takeArrayListRev n (x:getList backBuf) + src = Prelude.reverse src0 ++ xs + gobuf SPEC src s (List []) pst1 + PR.Continue 0 pst1 -> + gobuf SPEC xs s (List (x:getList backBuf)) pst1 + PR.Continue n pst1 -> do + assert + (n <= sum (map Array.length (x:getList backBuf))) + (return ()) + let (src0, buf1) = splitAtArrayListRev n (x:getList backBuf) + src = Prelude.reverse src0 ++ xs + gobuf SPEC src s (List buf1) pst1 + PR.Done 0 b -> do + let str = D.append (D.fromList xs) (D.Stream step s) + return (Right b, str) + PR.Done n b -> do + assert + (n <= sum (map Array.length (x:getList backBuf))) + (return ()) + let src0 = takeArrayListRev n (x:getList backBuf) + src = Prelude.reverse src0 ++ xs + return (Right b, D.append (D.fromList src) (D.Stream step s)) + PR.SError err -> do + let src0 = x:getList backBuf + src = Prelude.reverse src0 ++ x:xs + strm = D.append (D.fromList src) (D.Stream step s) + return (Left (ParseError err), strm) + + -- This is a simplified gobuf + goExtract _ [] backBuf !pst = goStop backBuf pst + goExtract _ (x:xs) backBuf !pst = do + pRes <- pstep pst x + case pRes of + PR.Partial 0 pst1 -> + goExtract SPEC xs (List []) pst1 + PR.Partial n pst1 -> do + assert + (n <= sum (map Array.length (x:getList backBuf))) + (return ()) + let src0 = takeArrayListRev n (x:getList backBuf) + src = Prelude.reverse src0 ++ xs + goExtract SPEC src (List []) pst1 + PR.Continue 0 pst1 -> + goExtract SPEC xs (List (x:getList backBuf)) pst1 + PR.Continue n pst1 -> do + assert + (n <= sum (map Array.length (x:getList backBuf))) + (return ()) + let (src0, buf1) = splitAtArrayListRev n (x:getList backBuf) + src = Prelude.reverse src0 ++ xs + goExtract SPEC src (List buf1) pst1 + PR.Done 0 b -> + return (Right b, D.fromList xs) + PR.Done n b -> do + assert + (n <= sum (map Array.length (x:getList backBuf))) + (return ()) + let src0 = takeArrayListRev n (x:getList backBuf) + src = Prelude.reverse src0 ++ xs + return (Right b, D.fromList src) + PR.SError err -> do + let src0 = getList backBuf + src = Prelude.reverse src0 ++ x:xs + return (Left (ParseError err), D.fromList src) + + -- This is a simplified goExtract + {-# INLINE goStop #-} + goStop backBuf pst = do + pRes <- extract pst + case pRes of + PR.FContinue 0 pst1 -> + goStop backBuf pst1 + PR.FContinue n pst1 -> do + assert + (n <= sum (map Array.length (getList backBuf))) + (return ()) + let (src0, buf1) = splitAtArrayListRev n (getList backBuf) + src = Prelude.reverse src0 + goExtract SPEC src (List buf1) pst1 + PR.FDone 0 b -> return (Right b, D.nil) + PR.FDone n b -> do + assert + (n <= sum (map Array.length (getList backBuf))) + (return ()) + let src0 = takeArrayListRev n (getList backBuf) + src = Prelude.reverse src0 + return (Right b, D.fromList src) + PR.FError err -> do + let src0 = getList backBuf + src = Prelude.reverse src0 + return (Left (ParseError err), D.fromList src) + +{- +-- | Parse an array stream using the supplied 'Parser'. Returns the parse +-- result and the unconsumed stream. Throws 'ParseError' if the parse fails. +-- +-- /Internal/ +-- +{-# INLINE parseArr #-} +parseArr :: + (MonadIO m, MonadThrow m, Unbox a) + => ASF.Parser a m b + -> Stream m (A.Array a) + -> m (b, Stream m (A.Array a)) +parseArr p s = fmap fromStreamD <$> parseBreakD p (toStreamD s) +-} + +-- | Fold an array stream using the supplied array stream 'Fold'. +-- +-- /Pre-release/ +-- +{-# INLINE runArrayFold #-} +runArrayFold :: (MonadIO m, Unbox a) => + ChunkFold m a b -> StreamK m (A.Array a) -> m (Either ParseError b) +runArrayFold (ChunkFold p) s = fst <$> runArrayParserDBreak p (toStream s) + +-- | Like 'fold' but also returns the remaining stream. +-- +-- /Pre-release/ +-- +{-# INLINE runArrayFoldBreak #-} +runArrayFoldBreak :: (MonadIO m, Unbox a) => + ChunkFold m a b -> StreamK m (A.Array a) -> m (Either ParseError b, StreamK m (A.Array a)) +runArrayFoldBreak (ChunkFold p) s = + second fromStream <$> runArrayParserDBreak p (toStream s) + +{-# ANN type ParseChunksState Fuse #-} +data ParseChunksState x inpBuf st pst = + ParseChunksInit inpBuf st + | ParseChunksInitBuf inpBuf + | ParseChunksInitLeftOver inpBuf + | ParseChunksStream st inpBuf !pst + | ParseChunksStop inpBuf !pst + | ParseChunksBuf inpBuf st inpBuf !pst + | ParseChunksExtract inpBuf inpBuf !pst + | ParseChunksYield x (ParseChunksState x inpBuf st pst) + +{-# INLINE_NORMAL runArrayFoldManyD #-} +runArrayFoldManyD + :: (Monad m, Unbox a) + => ChunkFold m a b + -> D.Stream m (Array a) + -> D.Stream m (Either ParseError b) +runArrayFoldManyD + (ChunkFold (PRD.Parser pstep initial extract)) (D.Stream step state) = + + D.Stream stepOuter (ParseChunksInit [] state) + + where + + {-# INLINE_LATE stepOuter #-} + -- Buffer is empty, get the first element from the stream, initialize the + -- fold and then go to stream processing loop. + stepOuter gst (ParseChunksInit [] st) = do + r <- step (adaptState gst) st + case r of + D.Yield x s -> do + res <- initial + case res of + PRD.IPartial ps -> + return $ D.Skip $ ParseChunksBuf [x] s [] ps + PRD.IDone pb -> do + let next = ParseChunksInit [x] s + return $ D.Skip $ ParseChunksYield (Right pb) next + PRD.IError err -> do + let next = ParseChunksInitLeftOver [] + return + $ D.Skip + $ ParseChunksYield (Left (ParseError err)) next + D.Skip s -> return $ D.Skip $ ParseChunksInit [] s + D.Stop -> return D.Stop + + -- Buffer is not empty, go to buffered processing loop + stepOuter _ (ParseChunksInit src st) = do + res <- initial + case res of + PRD.IPartial ps -> + return $ D.Skip $ ParseChunksBuf src st [] ps + PRD.IDone pb -> + let next = ParseChunksInit src st + in return $ D.Skip $ ParseChunksYield (Right pb) next + PRD.IError err -> do + let next = ParseChunksInitLeftOver [] + return + $ D.Skip + $ ParseChunksYield (Left (ParseError err)) next + + -- This is a simplified ParseChunksInit + stepOuter _ (ParseChunksInitBuf src) = do + res <- initial + case res of + PRD.IPartial ps -> + return $ D.Skip $ ParseChunksExtract src [] ps + PRD.IDone pb -> + let next = ParseChunksInitBuf src + in return $ D.Skip $ ParseChunksYield (Right pb) next + PRD.IError err -> do + let next = ParseChunksInitLeftOver [] + return + $ D.Skip + $ ParseChunksYield (Left (ParseError err)) next + + -- XXX we just discard any leftover input at the end + stepOuter _ (ParseChunksInitLeftOver _) = return D.Stop + + -- Buffer is empty, process elements from the stream + stepOuter gst (ParseChunksStream st backBuf pst) = do + r <- step (adaptState gst) st + case r of + D.Yield x s -> do + pRes <- pstep pst x + case pRes of + PR.Partial 0 pst1 -> + return $ D.Skip $ ParseChunksStream s [] pst1 + PR.Partial n pst1 -> do + assert + (n <= sum (map Array.length (x:backBuf))) + (return ()) + let src0 = takeArrayListRev n (x:backBuf) + src = Prelude.reverse src0 + return $ D.Skip $ ParseChunksBuf src s [] pst1 + PR.Continue 0 pst1 -> + return $ D.Skip $ ParseChunksStream s (x:backBuf) pst1 + PR.Continue n pst1 -> do + assert + (n <= sum (map Array.length (x:backBuf))) + (return ()) + let (src0, buf1) = splitAtArrayListRev n (x:backBuf) + src = Prelude.reverse src0 + return $ D.Skip $ ParseChunksBuf src s buf1 pst1 + PR.Done 0 b -> do + return $ D.Skip $ + ParseChunksYield (Right b) (ParseChunksInit [] s) + PR.Done n b -> do + assert + (n <= sum (map Array.length (x:backBuf))) + (return ()) + let src0 = takeArrayListRev n (x:backBuf) + src = Prelude.reverse src0 + next = ParseChunksInit src s + return + $ D.Skip + $ ParseChunksYield (Right b) next + PR.SError err -> do + let next = ParseChunksInitLeftOver [] + return + $ D.Skip + $ ParseChunksYield (Left (ParseError err)) next + + D.Skip s -> return $ D.Skip $ ParseChunksStream s backBuf pst + D.Stop -> return $ D.Skip $ ParseChunksStop backBuf pst + + -- go back to stream processing mode + stepOuter _ (ParseChunksBuf [] s buf pst) = + return $ D.Skip $ ParseChunksStream s buf pst + + -- buffered processing loop + stepOuter _ (ParseChunksBuf (x:xs) s backBuf pst) = do + pRes <- pstep pst x + case pRes of + PR.Partial 0 pst1 -> + return $ D.Skip $ ParseChunksBuf xs s [] pst1 + PR.Partial n pst1 -> do + assert (n <= sum (map Array.length (x:backBuf))) (return ()) + let src0 = takeArrayListRev n (x:backBuf) + src = Prelude.reverse src0 ++ xs + return $ D.Skip $ ParseChunksBuf src s [] pst1 + PR.Continue 0 pst1 -> + return $ D.Skip $ ParseChunksBuf xs s (x:backBuf) pst1 + PR.Continue n pst1 -> do + assert (n <= sum (map Array.length (x:backBuf))) (return ()) + let (src0, buf1) = splitAtArrayListRev n (x:backBuf) + src = Prelude.reverse src0 ++ xs + return $ D.Skip $ ParseChunksBuf src s buf1 pst1 + PR.Done 0 b -> + return + $ D.Skip + $ ParseChunksYield (Right b) (ParseChunksInit xs s) + PR.Done n b -> do + assert (n <= sum (map Array.length (x:backBuf))) (return ()) + let src0 = takeArrayListRev n (x:backBuf) + src = Prelude.reverse src0 ++ xs + return + $ D.Skip + $ ParseChunksYield (Right b) (ParseChunksInit src s) + PR.SError err -> do + let next = ParseChunksInitLeftOver [] + return + $ D.Skip + $ ParseChunksYield (Left (ParseError err)) next + + -- This is a simplified ParseChunksBuf + stepOuter _ (ParseChunksExtract [] buf pst) = + return $ D.Skip $ ParseChunksStop buf pst + + stepOuter _ (ParseChunksExtract (x:xs) backBuf pst) = do + pRes <- pstep pst x + case pRes of + PR.Partial 0 pst1 -> + return $ D.Skip $ ParseChunksExtract xs [] pst1 + PR.Partial n pst1 -> do + assert (n <= sum (map Array.length (x:backBuf))) (return ()) + let src0 = takeArrayListRev n (x:backBuf) + src = Prelude.reverse src0 ++ xs + return $ D.Skip $ ParseChunksExtract src [] pst1 + PR.Continue 0 pst1 -> + return $ D.Skip $ ParseChunksExtract xs (x:backBuf) pst1 + PR.Continue n pst1 -> do + assert (n <= sum (map Array.length (x:backBuf))) (return ()) + let (src0, buf1) = splitAtArrayListRev n (x:backBuf) + src = Prelude.reverse src0 ++ xs + return $ D.Skip $ ParseChunksExtract src buf1 pst1 + PR.Done 0 b -> + return + $ D.Skip + $ ParseChunksYield (Right b) (ParseChunksInitBuf xs) + PR.Done n b -> do + assert (n <= sum (map Array.length (x:backBuf))) (return ()) + let src0 = takeArrayListRev n (x:backBuf) + src = Prelude.reverse src0 ++ xs + return + $ D.Skip + $ ParseChunksYield (Right b) (ParseChunksInitBuf src) + PR.SError err -> do + let next = ParseChunksInitLeftOver [] + return + $ D.Skip + $ ParseChunksYield (Left (ParseError err)) next + + + -- This is a simplified ParseChunksExtract + stepOuter _ (ParseChunksStop backBuf pst) = do + pRes <- extract pst + case pRes of + PR.FContinue 0 pst1 -> + return $ D.Skip $ ParseChunksStop backBuf pst1 + PR.FContinue n pst1 -> do + assert (n <= sum (map Array.length backBuf)) (return ()) + let (src0, buf1) = splitAtArrayListRev n backBuf + src = Prelude.reverse src0 + return $ D.Skip $ ParseChunksExtract src buf1 pst1 + PR.FDone 0 b -> + return + $ D.Skip + $ ParseChunksYield (Right b) (ParseChunksInitLeftOver []) + PR.FDone n b -> do + assert (n <= sum (map Array.length backBuf)) (return ()) + let src0 = takeArrayListRev n backBuf + src = Prelude.reverse src0 + return + $ D.Skip + $ ParseChunksYield (Right b) (ParseChunksInitBuf src) + PR.FError err -> do + let next = ParseChunksInitLeftOver [] + return + $ D.Skip + $ ParseChunksYield (Left (ParseError err)) next + + stepOuter _ (ParseChunksYield a next) = return $ D.Yield a next + +-- | Apply an 'ChunkFold' repeatedly on an array stream and emit the +-- fold outputs in the output stream. +-- +-- See "Streamly.Data.Stream.foldMany" for more details. +-- +-- /Pre-release/ +{-# INLINE runArrayFoldMany #-} +runArrayFoldMany + :: (Monad m, Unbox a) + => ChunkFold m a b + -> StreamK m (Array a) + -> StreamK m (Either ParseError b) +runArrayFoldMany p m = fromStream $ runArrayFoldManyD p (toStream m) diff --git a/src/Streamly/Internal/Data/Array/Type.hs b/src/Streamly/Internal/Data/Array/Type.hs --- a/src/Streamly/Internal/Data/Array/Type.hs +++ b/src/Streamly/Internal/Data/Array/Type.hs @@ -1,592 +1,1557 @@ {-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Array.Type --- Copyright : (c) 2020 Composewell Technologies --- --- License : BSD3-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- See notes in "Streamly.Internal.Data.Array.Mut.Type" --- -module Streamly.Internal.Data.Array.Type - ( - -- $arrayNotes - Array (..) - , asPtrUnsafe - - -- * Freezing and Thawing - , unsafeFreeze - , unsafeFreezeWithShrink - , unsafeThaw - - -- * Pinning and Unpinning - , pin - , unpin - - -- * Construction - , splice - - , fromList - , fromListN - , fromListRev - , fromListRevN - , fromStreamDN - , fromStreamD - - -- * Split - , breakOn - - -- * Elimination - , unsafeIndexIO - , unsafeIndex -- getIndexUnsafe - , byteLength - , length - - , foldl' - , foldr - , splitAt - - , toStreamD - , toStreamDRev - , toStreamK - , toStreamKRev - , toStream - , toStreamRev - , read - , readRev - , readerRev - , toList - - -- * Folds - , writeWith - , writeN - , writeNUnsafe - , MA.ArrayUnsafe (..) - , writeNAligned - , write - - -- * Streams of arrays - , chunksOf - , bufferChunks - , flattenArrays - , flattenArraysRev - ) -where - -#include "ArrayMacros.h" -#include "inline.hs" - -import Control.Exception (assert) -import Control.Monad (replicateM) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Functor.Identity (Identity(..)) -import Data.Proxy (Proxy(..)) -import Data.Word (Word8) -import GHC.Base (build) -import GHC.Exts (IsList, IsString(..)) - -import GHC.IO (unsafePerformIO) -import GHC.Ptr (Ptr(..)) -import Streamly.Internal.Data.Array.Mut.Type (MutArray(..), MutableByteArray) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Unboxed (Unbox, peekWith, sizeOf) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Text.Read (readPrec) - -import Prelude hiding (length, foldr, read, unlines, splitAt) - -import qualified GHC.Exts as Exts -import qualified Streamly.Internal.Data.Array.Mut.Type as MA -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -import qualified Streamly.Internal.Data.Unboxed as Unboxed -import qualified Streamly.Internal.Data.Unfold.Type as Unfold -import qualified Text.ParserCombinators.ReadPrec as ReadPrec - -import Streamly.Internal.System.IO (unsafeInlineIO, defaultChunkSize) - -#include "DocTestDataArray.hs" - -------------------------------------------------------------------------------- --- Array Data Type -------------------------------------------------------------------------------- - --- $arrayNotes --- --- We can use an 'Unbox' constraint in the Array type and the constraint can --- be automatically provided to a function that pattern matches on the Array --- type. However, it has huge performance cost, so we do not use it. --- Investigate a GHC improvement possiblity. --- -data Array a = -#ifdef DEVBUILD - Unbox a => -#endif - -- All offsets are in terms of bytes from the start of arraycontents - Array - { arrContents :: {-# UNPACK #-} !MutableByteArray - , arrStart :: {-# UNPACK #-} !Int -- offset - , arrEnd :: {-# UNPACK #-} !Int -- offset + len - } - -------------------------------------------------------------------------------- --- Utility functions -------------------------------------------------------------------------------- - --- | Use an @Array a@ as @Ptr a@. --- --- See 'MA.asPtrUnsafe' in the Mutable array module for more details. --- --- /Unsafe/ --- --- /Pre-release/ --- -asPtrUnsafe :: MonadIO m => Array a -> (Ptr a -> m b) -> m b -asPtrUnsafe arr = MA.asPtrUnsafe (unsafeThaw arr) - -------------------------------------------------------------------------------- --- Freezing and Thawing -------------------------------------------------------------------------------- - --- XXX For debugging we can track slices/references through a weak IORef. Then --- trigger a GC after freeze/thaw and assert that there are no references --- remaining. - --- | Makes an immutable array using the underlying memory of the mutable --- array. --- --- Please make sure that there are no other references to the mutable array --- lying around, so that it is never used after freezing it using --- /unsafeFreeze/. If the underlying array is mutated, the immutable promise --- is lost. --- --- /Pre-release/ -{-# INLINE unsafeFreeze #-} -unsafeFreeze :: MutArray a -> Array a -unsafeFreeze (MutArray ac as ae _) = Array ac as ae - --- | Similar to 'unsafeFreeze' but uses 'MA.rightSize' on the mutable array --- first. -{-# INLINE unsafeFreezeWithShrink #-} -unsafeFreezeWithShrink :: Unbox a => MutArray a -> Array a -unsafeFreezeWithShrink arr = unsafePerformIO $ do - MutArray ac as ae _ <- MA.rightSize arr - return $ Array ac as ae - --- | Makes a mutable array using the underlying memory of the immutable array. --- --- Please make sure that there are no other references to the immutable array --- lying around, so that it is never used after thawing it using /unsafeThaw/. --- If the resulting array is mutated, any references to the older immutable --- array are mutated as well. --- --- /Pre-release/ -{-# INLINE unsafeThaw #-} -unsafeThaw :: Array a -> MutArray a -unsafeThaw (Array ac as ae) = MutArray ac as ae ae - -------------------------------------------------------------------------------- --- Pinning & Unpinning -------------------------------------------------------------------------------- - -{-# INLINE pin #-} -pin :: Array a -> IO (Array a) -pin = fmap unsafeFreeze . MA.pin . unsafeThaw - -{-# INLINE unpin #-} -unpin :: Array a -> IO (Array a) -unpin = fmap unsafeFreeze . MA.unpin . unsafeThaw - -------------------------------------------------------------------------------- --- Construction -------------------------------------------------------------------------------- - --- Splice two immutable arrays creating a new array. -{-# INLINE splice #-} -splice :: (MonadIO m, Unbox a) => Array a -> Array a -> m (Array a) -splice arr1 arr2 = - unsafeFreeze <$> MA.splice (unsafeThaw arr1) (unsafeThaw arr2) - --- | Create an 'Array' from the first N elements of a list. The array is --- allocated to size N, if the list terminates before N elements then the --- array may hold less than N elements. --- -{-# INLINABLE fromListN #-} -fromListN :: Unbox a => Int -> [a] -> Array a -fromListN n xs = unsafePerformIO $ unsafeFreeze <$> MA.fromListN n xs - --- | Create an 'Array' from the first N elements of a list in reverse order. --- The array is allocated to size N, if the list terminates before N elements --- then the array may hold less than N elements. --- --- /Pre-release/ -{-# INLINABLE fromListRevN #-} -fromListRevN :: Unbox a => Int -> [a] -> Array a -fromListRevN n xs = unsafePerformIO $ unsafeFreeze <$> MA.fromListRevN n xs - --- | Create an 'Array' from a list. The list must be of finite size. --- -{-# INLINE fromList #-} -fromList :: Unbox a => [a] -> Array a -fromList xs = unsafePerformIO $ unsafeFreeze <$> MA.fromList xs - --- | Create an 'Array' from a list in reverse order. The list must be of finite --- size. --- --- /Pre-release/ -{-# INLINABLE fromListRev #-} -fromListRev :: Unbox a => [a] -> Array a -fromListRev xs = unsafePerformIO $ unsafeFreeze <$> MA.fromListRev xs - -{-# INLINE_NORMAL fromStreamDN #-} -fromStreamDN :: forall m a. (MonadIO m, Unbox a) - => Int -> D.Stream m a -> m (Array a) -fromStreamDN limit str = unsafeFreeze <$> MA.fromStreamDN limit str - -{-# INLINE_NORMAL fromStreamD #-} -fromStreamD :: forall m a. (MonadIO m, Unbox a) - => D.Stream m a -> m (Array a) -fromStreamD str = unsafeFreeze <$> MA.fromStreamD str - -------------------------------------------------------------------------------- --- Streams of arrays -------------------------------------------------------------------------------- - -{-# INLINE bufferChunks #-} -bufferChunks :: (MonadIO m, Unbox a) => - D.Stream m a -> m (K.StreamK m (Array a)) -bufferChunks m = D.foldr K.cons K.nil $ chunksOf defaultChunkSize m - --- | @chunksOf n stream@ groups the elements in the input stream into arrays of --- @n@ elements each. --- --- Same as the following but may be more efficient: --- --- >>> chunksOf n = Stream.foldMany (Array.writeN n) --- --- /Pre-release/ -{-# INLINE_NORMAL chunksOf #-} -chunksOf :: forall m a. (MonadIO m, Unbox a) - => Int -> D.Stream m a -> D.Stream m (Array a) -chunksOf n str = D.map unsafeFreeze $ MA.chunksOf n str - --- | Use the "read" unfold instead. --- --- @flattenArrays = unfoldMany read@ --- --- We can try this if there are any fusion issues in the unfold. --- -{-# INLINE_NORMAL flattenArrays #-} -flattenArrays :: forall m a. (MonadIO m, Unbox a) - => D.Stream m (Array a) -> D.Stream m a -flattenArrays = MA.flattenArrays . D.map unsafeThaw - --- | Use the "readRev" unfold instead. --- --- @flattenArrays = unfoldMany readRev@ --- --- We can try this if there are any fusion issues in the unfold. --- -{-# INLINE_NORMAL flattenArraysRev #-} -flattenArraysRev :: forall m a. (MonadIO m, Unbox a) - => D.Stream m (Array a) -> D.Stream m a -flattenArraysRev = MA.flattenArraysRev . D.map unsafeThaw - --- Drops the separator byte -{-# INLINE breakOn #-} -breakOn :: MonadIO m - => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8)) -breakOn sep arr = do - (a, b) <- MA.breakOn sep (unsafeThaw arr) - return (unsafeFreeze a, unsafeFreeze <$> b) - -------------------------------------------------------------------------------- --- Elimination -------------------------------------------------------------------------------- - --- | Return element at the specified index without checking the bounds. --- --- Unsafe because it does not check the bounds of the array. -{-# INLINE_NORMAL unsafeIndexIO #-} -unsafeIndexIO :: forall a. Unbox a => Int -> Array a -> IO a -unsafeIndexIO i arr = MA.getIndexUnsafe i (unsafeThaw arr) - --- | Return element at the specified index without checking the bounds. -{-# INLINE_NORMAL unsafeIndex #-} -unsafeIndex :: forall a. Unbox a => Int -> Array a -> a -unsafeIndex i arr = let !r = unsafeInlineIO $ unsafeIndexIO i arr in r - --- | /O(1)/ Get the byte length of the array. --- -{-# INLINE byteLength #-} -byteLength :: Array a -> Int -byteLength = MA.byteLength . unsafeThaw - --- | /O(1)/ Get the length of the array i.e. the number of elements in the --- array. --- -{-# INLINE length #-} -length :: Unbox a => Array a -> Int -length arr = MA.length (unsafeThaw arr) - --- | Unfold an array into a stream in reverse order. --- -{-# INLINE_NORMAL readerRev #-} -readerRev :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a -readerRev = Unfold.lmap unsafeThaw $ MA.readerRevWith (return . unsafeInlineIO) - -{-# INLINE_NORMAL toStreamD #-} -toStreamD :: forall m a. (Monad m, Unbox a) => Array a -> D.Stream m a -toStreamD arr = MA.toStreamDWith (return . unsafeInlineIO) (unsafeThaw arr) - -{-# INLINE toStreamK #-} -toStreamK :: forall m a. (Monad m, Unbox a) => Array a -> K.StreamK m a -toStreamK arr = MA.toStreamKWith (return . unsafeInlineIO) (unsafeThaw arr) - -{-# INLINE_NORMAL toStreamDRev #-} -toStreamDRev :: forall m a. (Monad m, Unbox a) => Array a -> D.Stream m a -toStreamDRev arr = - MA.toStreamDRevWith (return . unsafeInlineIO) (unsafeThaw arr) - -{-# INLINE toStreamKRev #-} -toStreamKRev :: forall m a. (Monad m, Unbox a) => Array a -> K.StreamK m a -toStreamKRev arr = - MA.toStreamKRevWith (return . unsafeInlineIO) (unsafeThaw arr) - --- | Convert an 'Array' into a stream. --- --- /Pre-release/ -{-# INLINE_EARLY read #-} -read :: (Monad m, Unbox a) => Array a -> Stream m a -read = toStreamD - --- | Same as 'read' --- -{-# DEPRECATED toStream "Please use 'read' instead." #-} -{-# INLINE_EARLY toStream #-} -toStream :: (Monad m, Unbox a) => Array a -> Stream m a -toStream = read --- XXX add fallback to StreamK rule --- {-# RULES "Streamly.Array.read fallback to StreamK" [1] --- forall a. S.readK (read a) = K.fromArray a #-} - --- | Convert an 'Array' into a stream in reverse order. --- --- /Pre-release/ -{-# INLINE_EARLY readRev #-} -readRev :: (Monad m, Unbox a) => Array a -> Stream m a -readRev = toStreamDRev - --- | Same as 'readRev' --- -{-# DEPRECATED toStreamRev "Please use 'readRev' instead." #-} -{-# INLINE_EARLY toStreamRev #-} -toStreamRev :: (Monad m, Unbox a) => Array a -> Stream m a -toStreamRev = readRev - --- XXX add fallback to StreamK rule --- {-# RULES "Streamly.Array.readRev fallback to StreamK" [1] --- forall a. S.toStreamK (readRev a) = K.revFromArray a #-} - -{-# INLINE_NORMAL foldl' #-} -foldl' :: forall a b. Unbox a => (b -> a -> b) -> b -> Array a -> b -foldl' f z arr = runIdentity $ D.foldl' f z $ toStreamD arr - -{-# INLINE_NORMAL foldr #-} -foldr :: Unbox a => (a -> b -> b) -> b -> Array a -> b -foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr - --- | Create two slices of an array without copying the original array. The --- specified index @i@ is the first index of the second slice. --- -splitAt :: Unbox a => Int -> Array a -> (Array a, Array a) -splitAt i arr = (unsafeFreeze a, unsafeFreeze b) - where - (a, b) = MA.splitAt i (unsafeThaw arr) - --- Use foldr/build fusion to fuse with list consumers --- This can be useful when using the IsList instance -{-# INLINE_LATE toListFB #-} -toListFB :: forall a b. Unbox a => (a -> b -> b) -> b -> Array a -> b -toListFB c n Array{..} = go arrStart - where - - go p | assert (p <= arrEnd) (p == arrEnd) = n - go p = - -- unsafeInlineIO allows us to run this in Identity monad for pure - -- toList/foldr case which makes them much faster due to not - -- accumulating the list and fusing better with the pure consumers. - -- - -- This should be safe as the array contents are guaranteed to be - -- evaluated/written to before we peekWith at them. - let !x = unsafeInlineIO $ peekWith arrContents p - in c x (go (INDEX_NEXT(p,a))) - --- | Convert an 'Array' into a list. --- -{-# INLINE toList #-} -toList :: Unbox a => Array a -> [a] -toList s = build (\c n -> toListFB c n s) - -------------------------------------------------------------------------------- --- Folds -------------------------------------------------------------------------------- - --- | @writeN n@ folds a maximum of @n@ elements from the input stream to an --- 'Array'. --- -{-# INLINE_NORMAL writeN #-} -writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) -writeN = fmap unsafeFreeze . MA.writeN - --- | @writeNAligned alignment n@ folds a maximum of @n@ elements from the input --- stream to an 'Array' aligned to the given size. --- --- /Pre-release/ --- -{-# INLINE_NORMAL writeNAligned #-} -writeNAligned :: forall m a. (MonadIO m, Unbox a) - => Int -> Int -> Fold m a (Array a) -writeNAligned alignSize = fmap unsafeFreeze . MA.writeNAligned alignSize - --- | Like 'writeN' but does not check the array bounds when writing. The fold --- driver must not call the step function more than 'n' times otherwise it will --- corrupt the memory and crash. This function exists mainly because any --- conditional in the step function blocks fusion causing 10x performance --- slowdown. --- -{-# INLINE_NORMAL writeNUnsafe #-} -writeNUnsafe :: forall m a. (MonadIO m, Unbox a) - => Int -> Fold m a (Array a) -writeNUnsafe n = unsafeFreeze <$> MA.writeNUnsafe n - -{-# INLINE_NORMAL writeWith #-} -writeWith :: forall m a. (MonadIO m, Unbox a) - => Int -> Fold m a (Array a) --- writeWith n = FL.rmapM spliceArrays $ toArraysOf n -writeWith elemCount = unsafeFreeze <$> MA.writeWith elemCount - --- | Fold the whole input to a single array. --- --- /Caution! Do not use this on infinite streams./ --- -{-# INLINE write #-} -write :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) -write = fmap unsafeFreeze MA.write - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance (Show a, Unbox a) => Show (Array a) where - {-# INLINE show #-} - show arr = "fromList " ++ show (toList arr) - -instance (Unbox a, Read a, Show a) => Read (Array a) where - {-# INLINE readPrec #-} - readPrec = do - fromListWord <- replicateM 9 ReadPrec.get - if fromListWord == "fromList " - then fromList <$> readPrec - else ReadPrec.pfail - -instance (a ~ Char) => IsString (Array a) where - {-# INLINE fromString #-} - fromString = fromList - --- GHC versions 8.0 and below cannot derive IsList -instance Unbox a => IsList (Array a) where - type (Item (Array a)) = a - {-# INLINE fromList #-} - fromList = fromList - {-# INLINE fromListN #-} - fromListN = fromListN - {-# INLINE toList #-} - toList = toList - --- XXX we are assuming that Unboxed equality means element equality. This may --- or may not be correct? arrcmp is 40% faster compared to stream equality. -instance (Unbox a, Eq a) => Eq (Array a) where - {-# INLINE (==) #-} - arr1 == arr2 = - (==) EQ $ unsafeInlineIO $! unsafeThaw arr1 `MA.cmp` unsafeThaw arr2 - -instance (Unbox a, Ord a) => Ord (Array a) where - {-# INLINE compare #-} - compare arr1 arr2 = runIdentity $ - D.cmpBy compare (toStreamD arr1) (toStreamD arr2) - - -- Default definitions defined in base do not have an INLINE on them, so we - -- replicate them here with an INLINE. - {-# INLINE (<) #-} - x < y = case compare x y of { LT -> True; _ -> False } - - {-# INLINE (<=) #-} - x <= y = case compare x y of { GT -> False; _ -> True } - - {-# INLINE (>) #-} - x > y = case compare x y of { GT -> True; _ -> False } - - {-# INLINE (>=) #-} - x >= y = case compare x y of { LT -> False; _ -> True } - - -- These two default methods use '<=' rather than 'compare' - -- because the latter is often more expensive - {-# INLINE max #-} - max x y = if x <= y then y else x - - {-# INLINE min #-} - min x y = if x <= y then x else y - -#ifdef DEVBUILD --- Definitions using the Unboxed constraint from the Array type. These are to --- make the Foldable instance possible though it is much slower (7x slower). --- -{-# INLINE_NORMAL _toStreamD_ #-} -_toStreamD_ :: forall m a. MonadIO m => Int -> Array a -> D.Stream m a -_toStreamD_ size Array{..} = D.Stream step arrStart - - where - - {-# INLINE_LATE step #-} - step _ p | p == arrEnd = return D.Stop - step _ p = liftIO $ do - x <- peekWith arrContents p - return $ D.Yield x (p + size) - -{- -XXX Why isn't Unboxed implicit? This does not compile unless I use the Unboxed -contraint. -{-# INLINE_NORMAL _foldr #-} -_foldr :: forall a b. (a -> b -> b) -> b -> Array a -> b -_foldr f z arr = - let !n = SIZE_OF(a) - in unsafePerformIO $ D.foldr f z $ toStreamD_ n arr --- | Note that the 'Foldable' instance is 7x slower than the direct --- operations. -instance Foldable Array where - foldr = _foldr --} - -#endif - -------------------------------------------------------------------------------- --- Semigroup and Monoid -------------------------------------------------------------------------------- - -instance Unbox a => Semigroup (Array a) where - arr1 <> arr2 = unsafePerformIO $ splice arr1 arr2 - -nil :: -#ifdef DEVBUILD - Unbox a => -#endif - Array a -nil = Array Unboxed.nil 0 0 - -instance Unbox a => Monoid (Array a) where - mempty = nil - mappend = (<>) +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +-- | +-- Module : Streamly.Internal.Data.Array.Type +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- See notes in "Streamly.Internal.Data.MutArray.Type" +-- + +module Streamly.Internal.Data.Array.Type + ( + -- ** Type + -- $arrayNotes + Array (..) + + -- ** Conversion + -- *** Mutable and Immutable + , unsafeFreeze + , unsafeFreezeWithShrink + , unsafeThaw + + -- *** Pinned and Unpinned + , pin + , unpin + , isPinned + + -- *** Casting + , unsafePinnedAsPtr + , unsafeAsForeignPtr + + -- * Subarrays + , unsafeSliceOffLen + + -- ** Construction + , empty + + -- * Random Access + -- , (!!) + , getIndex + , getIndexRev + , head + , last + , init + , tail + , uncons + , unsnoc + + -- *** Slicing + -- | Get a subarray without copying + , unsafeBreakAt + , breakAt + , breakEndByWord8_ + , breakEndBy + , breakEndBy_ + , revBreakEndBy + , revBreakEndBy_ + -- drop + -- dropRev/dropEnd + , dropAround + , dropWhile + , revDropWhile + + -- *** Stream Folds + , unsafeMakePure + , createOf + , createOf' + , unsafeCreateOf + , unsafeCreateOf' + , create + , create' + , createWith + + -- *** From containers + , fromListN + , fromListN' + , fromList + , fromList' + , fromListRevN + , fromListRev + , fromStreamN + , fromStream + , fromPureStreamN + , fromPureStream + , fromCString# + , fromCString + , fromW16CString# + , fromW16CString + , fromPtrN + , fromChunks + , fromChunksK + , unsafeFromForeignPtr + + -- ** Reading + + -- *** Indexing + , unsafeGetIndexIO + , unsafeGetIndexRevIO + , unsafeGetIndex + , unsafeGetIndexRev + + -- *** To Streams + , read + , readRev + , toStreamK + , toStreamKRev + + -- *** To Containers + , toList + + -- *** Unfolds + , producer -- experimental + , unsafeReader + , reader + , readerRev + + -- *** Size + , null + , length + , byteLength + + -- ** Folding + , foldl' + , foldr + , byteCmp + , byteEq + , listCmp + , listEq + + -- ** Appending + , splice -- XXX requires MonadIO + -- appendString + -- appendCString/CString# + + -- ** Streams of arrays + -- *** Chunk + -- | Group a stream into arrays. + , chunksOf + , chunksOf' + , buildChunks + , chunksEndBy + , chunksEndBy' + , chunksEndByLn + , chunksEndByLn' + + -- *** Split + -- | Split an array into slices. + , splitEndBy + , splitEndBy_ + + -- *** Concat + -- | Append the arrays in a stream to form a stream of elements. + , concat + , concatRev + + -- *** Compact + -- | Append the arrays in a stream to form a stream of larger arrays. + , createCompactMin + , createCompactMin' + , scanCompactMin + , scanCompactMin' + , compactMin + + -- ** Deprecated + , breakOn + , splitAt + , asPtrUnsafe + , unsafeIndex + , bufferChunks + , flattenArrays + , flattenArraysRev + , fromArrayStreamK + , fromStreamDN + , fromStreamD + , toStreamD + , toStreamDRev + , toStream + , toStreamRev + , nil + , writeWith + , writeN + , pinnedWriteN + , writeNUnsafe + , pinnedWriteNUnsafe + , pinnedWriteNAligned + , write + , pinnedWrite + , fromByteStr# + , fromByteStr + , fCompactGE + , fPinnedCompactGE + , lCompactGE + , lPinnedCompactGE + , compactGE + , pinnedCreateOf + , unsafePinnedCreateOf + , pinnedCreate + , pinnedFromListN + , pinnedFromList + , pinnedChunksOf + , unsafeIndexIO + , getIndexUnsafe + , readerUnsafe + ) +where + +#include "ArrayMacros.h" +#include "deprecation.h" +#include "inline.hs" + +import Control.Exception (assert) +import Control.Monad (replicateM, when) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Char (ord) +import Data.Functor.Identity (Identity(..)) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Proxy (Proxy(..)) +import Data.Word (Word8, Word16, Word32, Word64) +import GHC.Base (build) +import GHC.Exts (IsList, IsString(..), Addr#, minusAddr#) +import GHC.Int (Int(..)) +import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..)) + +import GHC.IO (unsafePerformIO) +import GHC.Ptr (Ptr(..), nullPtr) +import Streamly.Internal.Data.Producer.Type (Producer(..)) +import Streamly.Internal.Data.MutArray.Type (MutArray) +import Streamly.Internal.Data.MutByteArray.Type (MutByteArray) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Scanl.Type (Scanl (..)) +import Streamly.Internal.Data.Stream.Type (Stream) +import Streamly.Internal.Data.StreamK.Type (StreamK) +import Streamly.Internal.Data.Unbox (Unbox(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Text.Read (readPrec) + +import Prelude hiding + ( Foldable(..), concat, head, init, last, read, tail, unlines, splitAt + , dropWhile) + +import qualified GHC.Exts as Exts +import qualified Streamly.Internal.Data.Fold.Type as Fold +import qualified Streamly.Internal.Data.MutArray.Type as MA +import qualified Streamly.Internal.Data.Stream.Type as D +import qualified Streamly.Internal.Data.StreamK.Type as K +import qualified Streamly.Internal.Data.MutByteArray.Type as Unboxed +import qualified Streamly.Internal.Data.Producer as Producer +import qualified Streamly.Internal.Data.Scanl.Type as Scanl +import qualified Streamly.Internal.Data.Unfold.Type as Unfold +import qualified Text.ParserCombinators.ReadPrec as ReadPrec + +import Streamly.Internal.System.IO (unsafeInlineIO, defaultChunkSize) + +#include "DocTestDataArray.hs" + +------------------------------------------------------------------------------- +-- Notes +------------------------------------------------------------------------------- + +-- IMPORTANT: + +-- We need to be careful while using unsafePerformIO when array creation is +-- involved. +-- +-- * We need to make sure the unsafe IO line does not float out of the binding. +-- * The order of the IO actions should be sane. For example, `touch` after `f`. +-- +-- Assume the unsafe IO action floats up. If it makes sense given this +-- assumption, it's probably OK to use usafe IO. +-- +-- A general approach should be never to use unsafe IO where Array creation is +-- involved or touch is involved. + +------------------------------------------------------------------------------- +-- Array Data Type +------------------------------------------------------------------------------- + +-- $arrayNotes +-- +-- We can use an 'Unbox' constraint in the Array type and the constraint can +-- be automatically provided to a function that pattern matches on the Array +-- type. However, it has huge performance cost, so we do not use it. +-- Investigate a GHC improvement possiblity. +-- +data Array a = +#ifdef DEVBUILD + Unbox a => +#endif + -- All offsets are in terms of bytes from the start of arraycontents + Array + { arrContents :: {-# UNPACK #-} !MutByteArray + , arrStart :: {-# UNPACK #-} !Int -- offset + , arrEnd :: {-# UNPACK #-} !Int -- offset + len + } + +------------------------------------------------------------------------------- +-- Utility functions +------------------------------------------------------------------------------- + +-- XXX Rename this to "unsafeAsPtr"? +-- | Use an @Array a@ as @Ptr a@. +-- +-- See 'MA.unsafePinnedAsPtr' in the Mutable array module for more details. +-- +-- /Unsafe/ +-- +-- 1. The accessor must not access the array beyond the specified length. +-- 2. The accessor must not mutate the array. +-- +-- /Pre-release/ +-- +{-# INLINE unsafePinnedAsPtr #-} +unsafePinnedAsPtr :: MonadIO m => Array a -> (Ptr a -> Int -> IO b) -> m b +unsafePinnedAsPtr arr f = do + let marr = unsafeThaw arr + pinned <- liftIO $ MA.pin marr + MA.unsafeAsPtr pinned f + +-- | Use an @Array a@ as @ForeignPtr a@. +-- +-- /Unsafe/ because of direct pointer operations. The user must ensure that they +-- are writing within the legal bounds of the array. +-- +-- /Pre-release/ +-- +{-# INLINE unsafeAsForeignPtr #-} +unsafeAsForeignPtr + :: MonadIO m => Array a -> (ForeignPtr a -> Int -> IO b) -> m b +unsafeAsForeignPtr arr0 f = do + let marr = unsafeThaw arr0 + pinned <- liftIO $ MA.pin marr + MA.unsafeAsPtr pinned (finner (MA.arrContents pinned)) + where + finner arrContents_ (Ptr addr#) i = + let fptrContents = + PlainPtr (Unboxed.getMutByteArray# arrContents_) + fptr = ForeignPtr addr# fptrContents + in f fptr i + +{-# INLINE mutableByteArrayContents# #-} +mutableByteArrayContents# :: Exts.MutableByteArray# s -> Addr# +#if __GLASGOW_HASKELL__ >= 902 +mutableByteArrayContents# = Exts.mutableByteArrayContents# +#else +mutableByteArrayContents# x = Exts.byteArrayContents# (Exts.unsafeCoerce# x) +#endif + +-- | @unsafeFromForeignPtr fptr len@ converts the "ForeignPtr" to an "Array". +-- +unsafeFromForeignPtr + :: MonadIO m => ForeignPtr Word8 -> Int -> m (Array Word8) +unsafeFromForeignPtr (ForeignPtr addr# _) i + | Ptr addr# == nullPtr || i == 0 = pure empty +unsafeFromForeignPtr (ForeignPtr addr# (PlainPtr marr#)) len = + let off = I# (addr# `minusAddr#` mutableByteArrayContents# marr#) + in pure (Array (Unboxed.MutByteArray marr#) off (off + len)) +unsafeFromForeignPtr (ForeignPtr addr# _) len = + fromPtrN len (Ptr addr#) + +{-# DEPRECATED asPtrUnsafe "Please use unsafePinnedAsPtr instead." #-} +{-# INLINE asPtrUnsafe #-} +asPtrUnsafe :: MonadIO m => Array a -> (Ptr a -> m b) -> m b +asPtrUnsafe arr f = MA.unsafePinnedAsPtr (unsafeThaw arr) (\p _ -> f p) + +------------------------------------------------------------------------------- +-- Freezing and Thawing +------------------------------------------------------------------------------- + +-- XXX For debugging we can track slices/references through a weak IORef. Then +-- trigger a GC after freeze/thaw and assert that there are no references +-- remaining. + +-- | Makes an immutable array using the underlying memory of the mutable +-- array. +-- +-- Please make sure that there are no other references to the mutable array +-- lying around, so that it is never used after freezing it using +-- /unsafeFreeze/. If the underlying array is mutated, the immutable promise +-- is lost. +-- +-- /Pre-release/ +{-# INLINE unsafeFreeze #-} +unsafeFreeze :: MutArray a -> Array a +unsafeFreeze (MA.MutArray ac as ae _) = Array ac as ae + +-- | Similar to 'unsafeFreeze' but uses 'MA.rightSize' on the mutable array +-- first. +{-# INLINE unsafeFreezeWithShrink #-} +unsafeFreezeWithShrink :: Unbox a => MutArray a -> Array a +unsafeFreezeWithShrink arr = unsafePerformIO $ do + MA.MutArray ac as ae _ <- MA.rightSize arr + return $ Array ac as ae + +-- | Makes a mutable array using the underlying memory of the immutable array. +-- +-- Please make sure that there are no other references to the immutable array +-- lying around, so that it is never used after thawing it using /unsafeThaw/. +-- If the resulting array is mutated, any references to the older immutable +-- array are mutated as well. +-- +-- /Pre-release/ +{-# INLINE unsafeThaw #-} +unsafeThaw :: Array a -> MutArray a +unsafeThaw (Array ac as ae) = MA.MutArray ac as ae ae + +------------------------------------------------------------------------------- +-- Pinning & Unpinning +------------------------------------------------------------------------------- + +-- | Return a copy of the 'Array' in pinned memory if unpinned, else return the +-- original array. +{-# INLINE pin #-} +pin :: Array a -> IO (Array a) +pin = fmap unsafeFreeze . MA.pin . unsafeThaw + +-- | Return a copy of the 'Array' in unpinned memory if pinned, else return the +-- original array. +{-# INLINE unpin #-} +unpin :: Array a -> IO (Array a) +unpin = fmap unsafeFreeze . MA.unpin . unsafeThaw + +-- | Return 'True' if the array is allocated in pinned memory. +{-# INLINE isPinned #-} +isPinned :: Array a -> Bool +isPinned = MA.isPinned . unsafeThaw + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +-- | Copy two immutable arrays into a new array. If you want to splice more +-- than two arrays then this operation would be highly inefficient because it +-- would make a copy on every splice operation, instead use the +-- 'fromChunksK' operation to combine n immutable arrays. +{-# INLINE splice #-} +splice :: (MonadIO m +#ifdef DEVBUILD + , Unbox a +#endif + ) + => Array a -> Array a -> m (Array a) +splice arr1 arr2 = + unsafeFreeze <$> MA.spliceCopy (unsafeThaw arr1) (unsafeThaw arr2) + +-- | Create an 'Array' from the first N elements of a list. The array is +-- allocated to size N, if the list terminates before N elements then the +-- array may hold less than N elements. +-- +{-# INLINABLE fromListN #-} +fromListN :: Unbox a => Int -> [a] -> Array a +fromListN n xs = unsafePerformIO $ unsafeFreeze <$> MA.fromListN n xs + +-- | Like 'fromListN' but creates a pinned array. +{-# INLINABLE fromListN' #-} +pinnedFromListN, fromListN' :: Unbox a => Int -> [a] -> Array a +fromListN' n xs = + unsafePerformIO $ unsafeFreeze <$> MA.fromListN' n xs +RENAME_PRIME(pinnedFromListN,fromListN) + +-- | Create an 'Array' from the first N elements of a list in reverse order. +-- The array is allocated to size N, if the list terminates before N elements +-- then the array may hold less than N elements. +-- +-- /Pre-release/ +{-# INLINABLE fromListRevN #-} +fromListRevN :: Unbox a => Int -> [a] -> Array a +fromListRevN n xs = unsafePerformIO $ unsafeFreeze <$> MA.fromListRevN n xs + +-- | Create an 'Array' from a list. The list must be of finite size. +-- +{-# INLINE fromList #-} +fromList :: Unbox a => [a] -> Array a +fromList xs = unsafePerformIO $ unsafeFreeze <$> MA.fromList xs + +-- | Like 'fromList' but creates a pinned array. +{-# INLINE fromList' #-} +pinnedFromList, fromList' :: Unbox a => [a] -> Array a +fromList' xs = unsafePerformIO $ unsafeFreeze <$> MA.fromList' xs +RENAME_PRIME(pinnedFromList,fromList) + +-- | Create an 'Array' from a list in reverse order. The list must be of finite +-- size. +-- +-- /Pre-release/ +{-# INLINABLE fromListRev #-} +fromListRev :: Unbox a => [a] -> Array a +fromListRev xs = unsafePerformIO $ unsafeFreeze <$> MA.fromListRev xs + +-- | Create an 'Array' from the first N elements of a stream. The array is +-- allocated to size N, if the stream terminates before N elements then the +-- array may hold less than N elements. +-- +-- >>> fromStreamN n = Stream.fold (Array.createOf n) +-- +-- /Pre-release/ +{-# INLINE_NORMAL fromStreamN #-} +fromStreamN :: (MonadIO m, Unbox a) => Int -> Stream m a -> m (Array a) +fromStreamN n m = do + when (n < 0) $ error "writeN: negative write count specified" + unsafeFreeze <$> MA.fromStreamN n m +-- fromStreamN n = D.fold (writeN n) + +{-# DEPRECATED fromStreamDN "Please use fromStreamN instead." #-} +fromStreamDN :: forall m a. (MonadIO m, Unbox a) + => Int -> D.Stream m a -> m (Array a) +fromStreamDN = fromStreamN + +-- | Create an 'Array' from a stream. This is useful when we want to create a +-- single array from a stream of unknown size. 'writeN' is at least twice +-- as efficient when the size is already known. +-- +-- >>> fromStream = Stream.fold Array.create +-- +-- Note that if the input stream is too large memory allocation for the array +-- may fail. When the stream size is not known, `chunksOf` followed by +-- processing of indvidual arrays in the resulting stream should be preferred. +-- +-- /Pre-release/ +{-# INLINE_NORMAL fromStreamD #-} +fromStream :: (MonadIO m, Unbox a) => Stream m a -> m (Array a) +fromStream = D.fold write +-- fromStreamD str = unsafeFreeze <$> MA.fromStream str + +{-# DEPRECATED fromStreamD "Please use fromStream instead." #-} +fromStreamD :: forall m a. (MonadIO m, Unbox a) + => D.Stream m a -> m (Array a) +fromStreamD = fromStream + +------------------------------------------------------------------------------- +-- Slice +------------------------------------------------------------------------------- + +-- | /O(1)/ Slice an array in constant time. +-- +-- Caution: The bounds of the slice are not checked. +-- +-- /Unsafe/ +-- +-- /Pre-release/ +{-# INLINE unsafeSliceOffLen #-} +unsafeSliceOffLen :: + forall a. Unbox a + => Int -- ^ starting index + -> Int -- ^ length of the slice + -> Array a + -> Array a +unsafeSliceOffLen index len (Array contents start e) = + let size = SIZE_OF(a) + start1 = start + (index * size) + end1 = start1 + (len * size) + in assert (end1 <= e) (Array contents start1 end1) + +------------------------------------------------------------------------------- +-- Elimination +------------------------------------------------------------------------------- + +-- | +-- +-- >>> null arr = Array.byteLength arr == 0 +-- +-- Note that this may be faster than checking Array.length as length +-- calculation involves a division operation. +-- +-- /Pre-release/ +{-# INLINE null #-} +null :: Array a -> Bool +null arr = byteLength arr == 0 + +-- XXX Change this to a partial function instead of a Maybe type? And use +-- MA.getIndex instead. + +-- | /O(1)/ Lookup the element at the given index. Index starts from 0. +-- +{-# INLINE getIndex #-} +getIndex :: forall a. Unbox a => Int -> Array a -> Maybe a +getIndex i arr = + unsafeInlineIO $ do + let elemPtr = INDEX_OF(arrStart arr, i, a) + if i >= 0 && INDEX_VALID(elemPtr, arrEnd arr, a) + then Just <$> peekAt elemPtr (arrContents arr) + else return Nothing + +-- | Like 'getIndex' but indexes the array in reverse from the end. +-- +-- /Pre-release/ +{-# INLINE getIndexRev #-} +getIndexRev :: forall a. Unbox a => Int -> Array a -> Maybe a +getIndexRev i arr = + unsafeInlineIO $ do + let elemPtr = RINDEX_OF(arrEnd arr, i, a) + if i >= 0 && elemPtr >= arrStart arr + then Just <$> peekAt elemPtr (arrContents arr) + else return Nothing + +{-# INLINE head #-} +head :: Unbox a => Array a -> Maybe a +head = getIndex 0 + +{-# INLINE last #-} +last :: Unbox a => Array a -> Maybe a +last = getIndexRev 0 + +{-# INLINE unsafeTail #-} +unsafeTail :: forall a. Unbox a => Array a -> Array a +unsafeTail Array{..} = Array arrContents (arrStart + SIZE_OF(a)) arrEnd + +{-# INLINE tail #-} +tail :: Unbox a => Array a -> Array a +tail arr@Array{..} = + if arrEnd > arrStart + then unsafeTail arr + else arr + +{-# INLINE uncons #-} +uncons :: Unbox a => Array a -> Maybe (a, Array a) +uncons arr = + if null arr + then Nothing + else Just (unsafeGetIndex 0 arr, unsafeTail arr) + +{-# INLINE unsafeInit #-} +unsafeInit :: forall a. Unbox a => Array a -> Array a +unsafeInit Array{..} = Array arrContents arrStart (arrEnd - SIZE_OF(a)) + +{-# INLINE init #-} +init :: Unbox a => Array a -> Array a +init arr@Array{..} = + if arrEnd > arrStart + then unsafeInit arr + else arr + +{-# INLINE unsnoc #-} +unsnoc :: Unbox a => Array a -> Maybe (Array a, a) +unsnoc arr = + if null arr + then Nothing + else Just (unsafeTail arr, unsafeGetIndexRev 0 arr) + +------------------------------------------------------------------------------- +-- Streams of arrays +------------------------------------------------------------------------------- + +{-# INLINE buildChunks #-} +buildChunks :: (MonadIO m, Unbox a) => + D.Stream m a -> m (K.StreamK m (Array a)) +buildChunks m = D.foldr K.cons K.nil $ chunksOf defaultChunkSize m + +{-# DEPRECATED bufferChunks "Please use buildChunks instead." #-} +bufferChunks :: (MonadIO m, Unbox a) => + D.Stream m a -> m (K.StreamK m (Array a)) +bufferChunks = buildChunks + +-- | @chunksOf n stream@ groups the elements in the input stream into arrays of +-- @n@ elements each. +-- +-- Same as the following but may be more efficient: +-- +-- >>> chunksOf n = Stream.foldMany (Array.createOf n) +-- +-- /Pre-release/ +{-# INLINE_NORMAL chunksOf #-} +chunksOf :: forall m a. (MonadIO m, Unbox a) + => Int -> D.Stream m a -> D.Stream m (Array a) +chunksOf n str = D.map unsafeFreeze $ MA.chunksOf n str + +-- | Like 'chunksOf' but creates pinned arrays. +{-# INLINE_NORMAL chunksOf' #-} +pinnedChunksOf, chunksOf' :: forall m a. (MonadIO m, Unbox a) + => Int -> D.Stream m a -> D.Stream m (Array a) +chunksOf' n str = D.map unsafeFreeze $ MA.chunksOf' n str +RENAME_PRIME(pinnedChunksOf,chunksOf) + +-- | Create arrays from the input stream using a predicate to find the end of +-- the chunk. When the predicate matches, the chunk ends, the matching element +-- is included in the chunk. +-- +-- Definition: +-- +-- >>> chunksEndBy p = Stream.foldMany (Fold.takeEndBy p Array.create) +-- +{-# INLINE chunksEndBy #-} +chunksEndBy :: forall m a. (MonadIO m, Unbox a) + => (a -> Bool) -> D.Stream m a -> D.Stream m (Array a) +chunksEndBy p = D.foldMany (Fold.takeEndBy p create) + +-- | Like 'chunksEndBy' but creates pinned arrays. +-- +{-# INLINE chunksEndBy' #-} +chunksEndBy' :: forall m a. (MonadIO m, Unbox a) + => (a -> Bool) -> D.Stream m a -> D.Stream m (Array a) +chunksEndBy' p = D.foldMany (Fold.takeEndBy p create') + +-- | Create chunks using newline as the separator, including it. +{-# INLINE chunksEndByLn #-} +chunksEndByLn :: (MonadIO m) + => D.Stream m Word8 -> D.Stream m (Array Word8) +chunksEndByLn = chunksEndBy (== fromIntegral (ord '\n')) + +-- | Like 'chunksEndByLn' but creates pinned arrays. +{-# INLINE chunksEndByLn' #-} +chunksEndByLn' :: (MonadIO m) + => D.Stream m Word8 -> D.Stream m (Array Word8) +chunksEndByLn' = chunksEndBy' (== fromIntegral (ord '\n')) + +-- XXX Remove MonadIO + +{-# INLINE splitEndBy #-} +splitEndBy :: (MonadIO m, Unbox a) => + (a -> Bool) -> Array a -> Stream m (Array a) +splitEndBy p arr = D.map unsafeFreeze $ MA.splitEndBy p (unsafeThaw arr) + +-- | Split the array into a stream of slices using a predicate. The element +-- matching the predicate is dropped. +-- +-- /Pre-release/ +{-# INLINE splitEndBy_ #-} +splitEndBy_ :: (Monad m, Unbox a) => + (a -> Bool) -> Array a -> Stream m (Array a) +splitEndBy_ predicate arr = + fmap (\(i, len) -> unsafeSliceOffLen i len arr) + $ D.indexEndBy_ predicate (read arr) + +-- | Convert a stream of arrays into a stream of their elements. +-- +-- >>> concat = Stream.unfoldEach Array.reader +-- +{-# INLINE_NORMAL concat #-} +concat :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a +concat = MA.concatWith (pure . unsafeInlineIO) . D.map unsafeThaw +-- concat = D.unfoldMany reader + +{-# DEPRECATED flattenArrays "Please use \"unfoldMany reader\" instead." #-} +{-# INLINE flattenArrays #-} +flattenArrays :: forall m a. (MonadIO m, Unbox a) + => D.Stream m (Array a) -> D.Stream m a +flattenArrays = concat + +-- | Convert a stream of arrays into a stream of their elements reversing the +-- contents of each array before flattening. +-- +-- >>> concatRev = Stream.unfoldEach Array.readerRev +-- +{-# INLINE_NORMAL concatRev #-} +concatRev :: forall m a. (Monad m, Unbox a) + => D.Stream m (Array a) -> D.Stream m a +-- XXX this requires MonadIO whereas the unfoldMany version does not +concatRev = MA.concatRevWith (pure . unsafeInlineIO) . D.map unsafeThaw +-- concatRev = D.unfoldMany readerRev + +{-# DEPRECATED flattenArraysRev "Please use \"unfoldMany readerRev\" instead." #-} +{-# INLINE flattenArraysRev #-} +flattenArraysRev :: forall m a. (MonadIO m, Unbox a) + => D.Stream m (Array a) -> D.Stream m a +flattenArraysRev = concatRev + +------------------------------------------------------------------------------- +-- Compact +------------------------------------------------------------------------------- + +-- XXX Note that this thaws immutable arrays for appending, that may be +-- problematic if multiple users do the same thing, however, thawed immutable +-- arrays would have no capacity to append, therefore, a copy will be forced +-- anyway. + +-- | Fold @createCompactMin n@ coalesces adjacent arrays in the input +-- stream until the size becomes greater than or equal to n. +-- +-- Generates unpinned arrays irrespective of the pinning status of input +-- arrays. +{-# INLINE_NORMAL createCompactMin #-} +createCompactMin, fCompactGE :: (MonadIO m, Unbox a) => + Int -> Fold m (Array a) (Array a) +createCompactMin n = + fmap unsafeFreeze $ Fold.lmap unsafeThaw $ MA.createCompactMin n + +RENAME(fCompactGE,createCompactMin) + +-- | Pinned version of 'createCompactMin'. +{-# INLINE_NORMAL createCompactMin' #-} +createCompactMin', fPinnedCompactGE :: (MonadIO m, Unbox a) => + Int -> Fold m (Array a) (Array a) +createCompactMin' n = + fmap unsafeFreeze $ Fold.lmap unsafeThaw $ MA.createCompactMin' n + +{-# DEPRECATED fPinnedCompactGE "Please use createCompactMin' instead." #-} +{-# INLINE fPinnedCompactGE #-} +fPinnedCompactGE = createCompactMin + +-- | @compactBySize n stream@ coalesces adjacent arrays in the @stream@ until +-- the size becomes greater than or equal to @n@. +-- +-- >>> compactBySize n = Stream.foldMany (Array.createCompactMin n) +-- +-- Generates unpinned arrays irrespective of the pinning status of input +-- arrays. +{-# INLINE compactMin #-} +compactMin, compactGE :: + (MonadIO m, Unbox a) + => Int -> Stream m (Array a) -> Stream m (Array a) +compactMin n stream = + D.map unsafeFreeze $ MA.compactMin n $ D.map unsafeThaw stream + +RENAME(compactGE,compactMin) + +-- | Like 'compactBySizeGE' but for transforming folds instead of stream. +-- +-- >>> lCompactBySizeGE n = Fold.many (Array.createCompactMin n) +-- +-- Generates unpinned arrays irrespective of the pinning status of input +-- arrays. +{-# DEPRECATED lCompactGE "Please use scanCompactMin instead." #-} +{-# INLINE_NORMAL lCompactGE #-} +lCompactGE :: (MonadIO m, Unbox a) + => Int -> Fold m (Array a) () -> Fold m (Array a) () +lCompactGE n fld = + Fold.lmap unsafeThaw $ MA.lCompactGE n (Fold.lmap unsafeFreeze fld) + +-- | Pinned version of 'lCompactGE'. +{-# DEPRECATED lPinnedCompactGE "Please use scanCompactMin' instead." #-} +{-# INLINE_NORMAL lPinnedCompactGE #-} +lPinnedCompactGE :: (MonadIO m, Unbox a) + => Int -> Fold m (Array a) () -> Fold m (Array a) () +lPinnedCompactGE n fld = + Fold.lmap unsafeThaw $ MA.lPinnedCompactGE n (Fold.lmap unsafeFreeze fld) + +{-# INLINE scanCompactMin #-} +scanCompactMin :: forall m a. (MonadIO m, Unbox a) + => Int -> Scanl m (Array a) (Maybe (Array a)) +scanCompactMin n = + Scanl.lmap unsafeThaw + $ fmap (fmap unsafeFreeze) + $ MA.scanCompactMin n + +{-# INLINE scanCompactMin' #-} +scanCompactMin' :: forall m a. (MonadIO m, Unbox a) + => Int -> Scanl m (Array a) (Maybe (Array a)) +scanCompactMin' n = + Scanl.lmap unsafeThaw + $ fmap (fmap unsafeFreeze) + $ MA.scanCompactMin' n + +------------------------------------------------------------------------------- +-- Splitting +------------------------------------------------------------------------------- + +-- Drops the separator byte +{-# INLINE breakEndByWord8_ #-} +breakEndByWord8_, breakOn :: MonadIO m + => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8)) +breakEndByWord8_ sep arr = do + (a, b) <- MA.breakOn sep (unsafeThaw arr) + return (unsafeFreeze a, unsafeFreeze <$> b) +RENAME(breakOn,breakEndByWord8_) + +------------------------------------------------------------------------------- +-- Elimination +------------------------------------------------------------------------------- + +-- | Return element at the specified index without checking the bounds. +-- +-- Unsafe because it does not check the bounds of the array. +{-# INLINE_NORMAL unsafeGetIndexIO #-} +unsafeGetIndexIO, unsafeIndexIO :: forall a. Unbox a => Int -> Array a -> IO a +unsafeGetIndexIO i arr = MA.unsafeGetIndex i (unsafeThaw arr) + +-- | Return element at the specified index without checking the bounds. +{-# INLINE_NORMAL unsafeGetIndex #-} +unsafeGetIndex, getIndexUnsafe :: forall a. Unbox a => Int -> Array a -> a +unsafeGetIndex i arr = let !r = unsafeInlineIO $ unsafeGetIndexIO i arr in r + +{-# DEPRECATED unsafeIndex "Please use 'unsafeGetIndex' instead" #-} +{-# INLINE_NORMAL unsafeIndex #-} +unsafeIndex :: forall a. Unbox a => Int -> Array a -> a +unsafeIndex = unsafeGetIndex + +{-# INLINE_NORMAL unsafeGetIndexRevIO #-} +unsafeGetIndexRevIO :: forall a. Unbox a => Int -> Array a -> IO a +unsafeGetIndexRevIO i arr = MA.unsafeGetIndexRev i (unsafeThaw arr) + +{-# INLINE_NORMAL unsafeGetIndexRev #-} +unsafeGetIndexRev :: forall a. Unbox a => Int -> Array a -> a +unsafeGetIndexRev i arr = + let !r = unsafeInlineIO $ unsafeGetIndexRevIO i arr in r + +-- | /O(1)/ Get the byte length of the array. +-- +{-# INLINE byteLength #-} +byteLength :: Array a -> Int +byteLength = MA.byteLength . unsafeThaw + +-- | /O(1)/ Get the length of the array i.e. the number of elements in the +-- array. +-- +{-# INLINE length #-} +length :: Unbox a => Array a -> Int +length arr = MA.length (unsafeThaw arr) + +{-# INLINE_NORMAL producer #-} +producer :: forall m a. (Monad m, Unbox a) => Producer m (Array a) a +producer = + Producer.translate unsafeThaw unsafeFreeze + $ MA.producerWith (return . unsafeInlineIO) + +-- | Unfold an array into a stream. +-- +{-# INLINE_NORMAL reader #-} +reader :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a +reader = Producer.simplify producer + +-- | Unfold an array into a stream, does not check the end of the array, the +-- user is responsible for terminating the stream within the array bounds. For +-- high performance application where the end condition can be determined by +-- a terminating fold. +-- +-- Written in the hope that it may be faster than "read", however, in the case +-- for which this was written, "read" proves to be faster even though the core +-- generated with unsafeRead looks simpler. +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL unsafeReader #-} +unsafeReader, readerUnsafe :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a +unsafeReader = Unfold step inject + where + + inject (Array contents start end) = + return (MA.ArrayUnsafe contents end start) + + {-# INLINE_LATE step #-} + step (MA.ArrayUnsafe contents end p) = do + -- unsafeInlineIO allows us to run this in Identity monad for pure + -- toList/foldr case which makes them much faster due to not + -- accumulating the list and fusing better with the pure consumers. + -- + -- This should be safe as the array contents are guaranteed to be + -- evaluated/written to before we peek at them. + let !x = unsafeInlineIO $ peekAt p contents + let !p1 = INDEX_NEXT(p,a) + return $ D.Yield x (MA.ArrayUnsafe contents end p1) + +-- | Unfold an array into a stream in reverse order. +-- +{-# INLINE_NORMAL readerRev #-} +readerRev :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a +readerRev = Unfold.lmap unsafeThaw $ MA.readerRevWith (return . unsafeInlineIO) + +{-# DEPRECATED toStreamD "Please use 'read' instead." #-} +{-# INLINE_NORMAL toStreamD #-} +toStreamD :: forall m a. (Monad m, Unbox a) => Array a -> D.Stream m a +toStreamD = read + +{-# INLINE toStreamK #-} +toStreamK :: forall m a. (Monad m, Unbox a) => Array a -> K.StreamK m a +toStreamK arr = MA.toStreamKWith (return . unsafeInlineIO) (unsafeThaw arr) + +{-# DEPRECATED toStreamDRev "Please use 'readRev' instead." #-} +{-# INLINE_NORMAL toStreamDRev #-} +toStreamDRev :: forall m a. (Monad m, Unbox a) => Array a -> D.Stream m a +toStreamDRev = readRev + +{-# INLINE toStreamKRev #-} +toStreamKRev :: forall m a. (Monad m, Unbox a) => Array a -> K.StreamK m a +toStreamKRev arr = + MA.toStreamKRevWith (return . unsafeInlineIO) (unsafeThaw arr) + +-- | Convert an 'Array' into a stream. +-- +-- /Pre-release/ +{-# INLINE_EARLY read #-} +read :: (Monad m, Unbox a) => Array a -> Stream m a +read arr = MA.toStreamWith (return . unsafeInlineIO) (unsafeThaw arr) + +-- | Same as 'read' +-- +{-# DEPRECATED toStream "Please use 'read' instead." #-} +{-# INLINE_EARLY toStream #-} +toStream :: (Monad m, Unbox a) => Array a -> Stream m a +toStream = read +-- XXX add fallback to StreamK rule +-- {-# RULES "Streamly.Array.read fallback to StreamK" [1] +-- forall a. S.readK (read a) = K.fromArray a #-} + +-- | Convert an 'Array' into a stream in reverse order. +-- +-- /Pre-release/ +{-# INLINE_EARLY readRev #-} +readRev :: (Monad m, Unbox a) => Array a -> Stream m a +readRev arr = MA.toStreamRevWith (return . unsafeInlineIO) (unsafeThaw arr) + +-- | Same as 'readRev' +-- +{-# DEPRECATED toStreamRev "Please use 'readRev' instead." #-} +{-# INLINE_EARLY toStreamRev #-} +toStreamRev :: (Monad m, Unbox a) => Array a -> Stream m a +toStreamRev = readRev + +-- XXX add fallback to StreamK rule +-- {-# RULES "Streamly.Array.readRev fallback to StreamK" [1] +-- forall a. S.toStreamK (readRev a) = K.revFromArray a #-} + +{-# INLINE_NORMAL foldl' #-} +foldl' :: forall a b. Unbox a => (b -> a -> b) -> b -> Array a -> b +foldl' f z arr = runIdentity $ D.foldl' f z $ toStreamD arr + +{-# INLINE_NORMAL foldr #-} +foldr :: Unbox a => (a -> b -> b) -> b -> Array a -> b +foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr + +-- | Like 'breakAt' but does not check whether the index is valid. +-- +{-# INLINE unsafeBreakAt #-} +unsafeBreakAt :: Unbox a => + Int -> Array a -> (Array a, Array a) +unsafeBreakAt i arr = (unsafeFreeze a, unsafeFreeze b) + + where + + (a, b) = MA.unsafeBreakAt i (unsafeThaw arr) + +-- | Create two slices of an array without copying the original array. The +-- specified index @i@ is the first index of the second slice. +-- +{-# INLINE breakAt #-} +breakAt, splitAt :: Unbox a => Int -> Array a -> (Array a, Array a) +breakAt i arr = (unsafeFreeze a, unsafeFreeze b) + + where + + (a, b) = MA.breakAt i (unsafeThaw arr) +RENAME(splitAt,breakAt) + +{-# INLINE breakEndBy #-} +breakEndBy :: Unbox a => (a -> Bool) -> Array a -> (Array a, Array a) +breakEndBy p arr = (unsafeFreeze a, unsafeFreeze b) + + where + + (a, b) = unsafePerformIO $ MA.breakEndBy p (unsafeThaw arr) + +{-# INLINE breakEndBy_ #-} +breakEndBy_ :: Unbox a => (a -> Bool) -> Array a -> (Array a, Array a) +breakEndBy_ p arr = (unsafeFreeze a, unsafeFreeze b) + + where + + (a, b) = unsafePerformIO $ MA.breakEndBy_ p (unsafeThaw arr) + +{-# INLINE revBreakEndBy #-} +revBreakEndBy :: Unbox a => (a -> Bool) -> Array a -> (Array a, Array a) +revBreakEndBy p arr = (unsafeFreeze a, unsafeFreeze b) + + where + + (a, b) = unsafePerformIO $ MA.revBreakEndBy p (unsafeThaw arr) + +{-# INLINE revBreakEndBy_ #-} +revBreakEndBy_ :: Unbox a => (a -> Bool) -> Array a -> (Array a, Array a) +revBreakEndBy_ p arr = (unsafeFreeze a, unsafeFreeze b) + + where + + (a, b) = unsafePerformIO $ MA.revBreakEndBy_ p (unsafeThaw arr) + +-- XXX Remove unsafePerformIO + +-- | Strip elements which match the predicate, from both ends. +-- +-- /Pre-release/ +{-# INLINE dropAround #-} +dropAround :: Unbox a => (a -> Bool) -> Array a -> Array a +dropAround eq arr = + unsafeFreeze $ unsafePerformIO $ MA.dropAround eq (unsafeThaw arr) + +-- | Strip elements which match the predicate, from the start of the array. +-- +-- /Pre-release/ +{-# INLINE dropWhile #-} +dropWhile :: Unbox a => (a -> Bool) -> Array a -> Array a +dropWhile eq arr = + unsafeFreeze $ unsafePerformIO $ MA.dropWhile eq (unsafeThaw arr) + +-- | Strip elements which match the predicate, from the end of the array. +-- +-- /Pre-release/ +{-# INLINE revDropWhile #-} +revDropWhile :: Unbox a => (a -> Bool) -> Array a -> Array a +revDropWhile eq arr = + unsafeFreeze $ unsafePerformIO $ MA.revDropWhile eq (unsafeThaw arr) + +-- Use foldr/build fusion to fuse with list consumers +-- This can be useful when using the IsList instance +{-# INLINE_LATE toListFB #-} +toListFB :: forall a b. Unbox a => (a -> b -> b) -> b -> Array a -> b +toListFB c n Array{..} = go arrStart + where + + go p | assert (p <= arrEnd) (p == arrEnd) = n + go p = + -- unsafeInlineIO allows us to run this in Identity monad for pure + -- toList/foldr case which makes them much faster due to not + -- accumulating the list and fusing better with the pure consumers. + -- + -- This should be safe as the array contents are guaranteed to be + -- evaluated/written to before we peekAt at them. + let !x = unsafeInlineIO $ peekAt p arrContents + in c x (go (INDEX_NEXT(p,a))) + +-- | Convert an 'Array' into a list. +-- +{-# INLINE toList #-} +toList :: Unbox a => Array a -> [a] +toList s = build (\c n -> toListFB c n s) + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +-- | @createOf n@ folds a maximum of @n@ elements from the input stream to an +-- 'Array'. +-- +{-# INLINE_NORMAL createOf #-} +createOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) +createOf = fmap unsafeFreeze . MA.createOf + +{-# DEPRECATED writeN "Please use createOf instead." #-} +{-# INLINE writeN #-} +writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) +writeN = createOf + +-- | Like 'createOf' but creates a pinned array. +{-# INLINE_NORMAL createOf' #-} +pinnedCreateOf, createOf' :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) +createOf' = fmap unsafeFreeze . MA.createOf' +RENAME_PRIME(pinnedCreateOf,createOf) + +{-# DEPRECATED pinnedWriteN "Please use createOf' instead." #-} +{-# INLINE pinnedWriteN #-} +pinnedWriteN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) +pinnedWriteN = createOf' + +-- | @pinnedWriteNAligned alignment n@ folds a maximum of @n@ elements from the input +-- stream to an 'Array' aligned to the given size. +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL pinnedWriteNAligned #-} +{-# DEPRECATED pinnedWriteNAligned "To be removed." #-} +pinnedWriteNAligned :: forall m a. (MonadIO m, Unbox a) + => Int -> Int -> Fold m a (Array a) +pinnedWriteNAligned alignSize = fmap unsafeFreeze . MA.pinnedWriteNAligned alignSize + +-- | Like 'createOf' but does not check the array bounds when writing. The fold +-- driver must not call the step function more than 'n' times otherwise it will +-- corrupt the memory and crash. This function exists mainly because any +-- conditional in the step function blocks fusion causing 10x performance +-- slowdown. +-- +{-# INLINE_NORMAL unsafeCreateOf #-} +unsafeCreateOf :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (Array a) +unsafeCreateOf n = unsafeFreeze <$> MA.unsafeCreateOf n + +{-# DEPRECATED writeNUnsafe "Please use unsafeCreateOf instead." #-} +{-# INLINE writeNUnsafe #-} +writeNUnsafe :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (Array a) +writeNUnsafe = unsafeCreateOf + +{-# INLINE_NORMAL unsafeCreateOf' #-} +unsafePinnedCreateOf, unsafeCreateOf' :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (Array a) +unsafeCreateOf' n = unsafeFreeze <$> MA.unsafeCreateOf' n +RENAME_PRIME(unsafePinnedCreateOf,unsafeCreateOf) + +{-# DEPRECATED pinnedWriteNUnsafe "Please use unsafeCreateOf' instead." #-} +{-# INLINE pinnedWriteNUnsafe #-} +pinnedWriteNUnsafe :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (Array a) +pinnedWriteNUnsafe = unsafeCreateOf' + +-- | A version of "create" that let's you pass in the initial capacity of the +-- array in terms of the number of elements. +-- +-- Semantically @createWith 10@ and @createWith 100@ will behave in the same +-- way. @createWith 100@ will be more performant though. +-- +-- > create = createWith elementCount +-- +-- /Pre-release/ +{-# INLINE_NORMAL createWith #-} +createWith :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (Array a) +-- createWith n = FL.rmapM spliceArrays $ toArraysOf n +createWith elemCount = unsafeFreeze <$> MA.createWith elemCount + +{-# DEPRECATED writeWith "Please use createWith instead." #-} +{-# INLINE writeWith #-} +writeWith :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (Array a) +writeWith = createWith + +-- | Fold the whole input to a single array. +-- +-- /Caution! Do not use this on infinite streams./ +-- +{-# INLINE create #-} +create :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) +create = fmap unsafeFreeze MA.create + +{-# DEPRECATED write "Please use create instead." #-} +{-# INLINE write #-} +write :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) +write = create + +-- | Like 'create' but creates a pinned array. +{-# INLINE create' #-} +pinnedCreate, create' :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) +create' = fmap unsafeFreeze MA.create' +RENAME_PRIME(pinnedCreate,create) + +{-# DEPRECATED pinnedWrite "Please use create' instead." #-} +{-# INLINE pinnedWrite #-} +pinnedWrite :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) +pinnedWrite = create' + +-- | Fold "step" has a dependency on "initial", and each step is dependent on +-- the previous invocation of step due to state passing, finally extract +-- depends on the result of step, therefore, as long as the fold is driven in +-- the correct order the operations would be correctly ordered. We need to +-- ensure that we strictly evaluate the previous step completely before the +-- next step. +-- +-- To not share the same array we need to make sure that the result of +-- "initial" is not shared. Existential type ensures that it does not get +-- shared across different folds. However, if we invoke "initial" multiple +-- times for the same fold, there is a possiblity of sharing the two because +-- the compiler would consider it as a pure value. One such example is the +-- chunksOf combinator, or using an array creation fold with foldMany +-- combinator. Is there a proper way in GHC to tell it to not share a pure +-- expression in a particular case? +-- +-- For this reason array creation folds have a MonadIO constraint. Pure folds +-- could be unsafe and dangerous. This is dangerous especially when used with +-- foldMany like operations. +-- +-- >>> unsafePureWrite = Array.unsafeMakePure Array.create +-- +{-# INLINE unsafeMakePure #-} +unsafeMakePure :: Monad m => Fold IO a b -> Fold m a b +unsafeMakePure (Fold step initial extract final) = + Fold (\x a -> return $! unsafeInlineIO (step x a)) + (return $! unsafePerformIO initial) + (\s -> return $! unsafeInlineIO $ extract s) + (\s -> return $! unsafeInlineIO $ final s) + +{-# INLINE fromPureStreamN #-} +fromPureStreamN :: Unbox a => Int -> Stream Identity a -> Array a +fromPureStreamN n x = + unsafePerformIO $ fmap unsafeFreeze (MA.fromPureStreamN n x) + +-- | Convert a pure stream in Identity monad to an immutable array. +-- +-- Same as the following but with better performance: +-- +-- >>> fromPureStream = Array.fromList . runIdentity . Stream.toList +-- +fromPureStream :: Unbox a => Stream Identity a -> Array a +fromPureStream x = unsafePerformIO $ fmap unsafeFreeze (MA.fromPureStream x) +-- fromPureStream = runIdentity . D.fold (unsafeMakePure write) +-- fromPureStream = fromList . runIdentity . D.toList + +-- | @fromPtrN len addr@ copies @len@ bytes from @addr@ into an array. The +-- memory pointed by @addr@ must be pinned or static. +-- +-- /Unsafe:/ The caller is responsible to ensure that the pointer passed is +-- valid up to the given length. +-- +fromPtrN :: MonadIO m => Int -> Ptr Word8 -> m (Array Word8) +fromPtrN n addr = fmap unsafeFreeze (MA.fromPtrN n addr) + +-- | Copy a null terminated immutable 'Addr#' Word8 sequence into an array. +-- +-- /Unsafe:/ The caller is responsible for safe addressing. +-- +-- Note that this is completely safe when reading from Haskell string +-- literals because they are guaranteed to be NULL terminated: +-- +-- Note, you can use lazy unsafePerformIO _only if_ the pointer is immutable. +-- +-- >>> Array.toList $ unsafePerformIO $ Array.fromCString# "\1\2\3\0"# +-- [1,2,3] +-- +fromCString# :: MonadIO m => Addr# -> m (Array Word8) +fromCString# addr = fmap unsafeFreeze (MA.fromCString# addr) + +{-# DEPRECATED fromByteStr# "Please use fromCString# instead." #-} +fromByteStr# :: Addr# -> Array Word8 +fromByteStr# addr = unsafePerformIO $ fromCString# addr + +-- | Copy a C string consisting of 16-bit wide chars and terminated by a 16-bit +-- null char, into a Word16 array. The null character is not copied. +-- +-- Useful for copying UTF16 strings on Windows. +-- +fromW16CString# :: MonadIO m => Addr# -> m (Array Word16) +fromW16CString# addr = fmap unsafeFreeze (MA.fromW16CString# addr) + +fromCString :: MonadIO m => Ptr Word8 -> m (Array Word8) +fromCString (Ptr addr#) = fromCString# addr# + +{-# DEPRECATED fromByteStr "Please use fromCString instead." #-} +fromByteStr :: Ptr Word8 -> Array Word8 +fromByteStr = unsafePerformIO . fromCString + +-- | Copy a C string consisting of 16-bit wide chars and terminated by a 16-bit +-- null char, into a Word16 array. The null character is not copied. +-- +-- Useful for copying UTF16 strings on Windows. +-- +fromW16CString :: MonadIO m => Ptr Word8 -> m (Array Word16) +fromW16CString (Ptr addr#) = fromW16CString# addr# + +-- XXX implement fromChunks/fromChunkList instead? + +-- | Convert an array stream to an array. Note that this requires peak memory +-- that is double the size of the array stream. +-- +{-# INLINE fromChunksK #-} +fromChunksK :: (MonadIO m, Unbox a) => StreamK m (Array a) -> m (Array a) +fromChunksK stream = + -- We buffer the entire stream and then allocate the target array of the + -- same size, thus requiring double the memory. + fmap unsafeFreeze $ MA.fromChunksK $ fmap unsafeThaw stream + +{-# DEPRECATED fromArrayStreamK "Please use fromChunksK instead." #-} +fromArrayStreamK :: (Unbox a, MonadIO m) => StreamK m (Array a) -> m (Array a) +fromArrayStreamK = fromChunksK + +-- | Given a stream of arrays, splice them all together to generate a single +-- array. The stream must be /finite/. +-- +{-# INLINE fromChunks #-} +fromChunks :: (MonadIO m, Unbox a) => Stream m (Array a) -> m (Array a) +fromChunks s = + -- XXX Check which implementation is better + -- This may also require double the memory as we double the space every + -- time, when copying the last array we may have reallocated almost double + -- the space required before we right size it. + fmap unsafeFreeze $ MA.fromChunksRealloced (fmap unsafeThaw s) + -- fromChunkStreamK $ D.toStreamK s + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance (Show a, Unbox a) => Show (Array a) where + {-# INLINE show #-} + show arr = "fromList " ++ show (toList arr) + +instance (Unbox a, Read a, Show a) => Read (Array a) where + {-# INLINE readPrec #-} + readPrec = do + fromListWord <- replicateM 9 ReadPrec.get + if fromListWord == "fromList " + then fromList <$> readPrec + else ReadPrec.pfail + +instance (a ~ Char) => IsString (Array a) where + {-# INLINE fromString #-} + fromString = fromList + +-- GHC versions 8.0 and below cannot derive IsList +instance Unbox a => IsList (Array a) where + type (Item (Array a)) = a + {-# INLINE fromList #-} + fromList = fromList + {-# INLINE fromListN #-} + fromListN = fromListN + {-# INLINE toList #-} + toList = toList + +-- | Compare an array with a list. +{-# INLINE listCmp #-} +listCmp :: (Unbox a, Ord a) => [a] -> Array a -> Ordering +listCmp xs arr = runIdentity $ D.cmpBy compare (D.fromList xs) (toStream arr) + +-- | Check equality of an array with a list. +{-# INLINE listEq #-} +listEq :: (Unbox a, Ord a) => [a] -> Array a -> Bool +listEq xs arr = runIdentity $ D.eqBy (==) (D.fromList xs) (toStream arr) + +-- | Byte compare two arrays. Compare the length of the arrays. If the length +-- is equal, compare the lexicographical ordering of two underlying byte arrays +-- otherwise return the result of length comparison. +-- +-- /Unsafe/: Note that the 'Unbox' instance of sum types with constructors of +-- different sizes may leave some memory uninitialized which can make byte +-- comparison unreliable. +-- +-- /Pre-release/ +{-# INLINE byteCmp #-} +byteCmp :: Array a -> Array a -> Ordering +byteCmp arr1 arr2 = + -- unsafePerformIO? + unsafeInlineIO $! unsafeThaw arr1 `MA.byteCmp` unsafeThaw arr2 + +-- | Byte equality of two arrays. +-- +-- >>> byteEq arr1 arr2 = (==) EQ $ Array.byteCmp arr1 arr2 +-- +-- /Unsafe/: See 'byteCmp'. +{-# INLINE byteEq #-} +byteEq :: Array a -> Array a -> Bool +byteEq arr1 arr2 = (==) EQ $ byteCmp arr1 arr2 + +#define MK_EQ_INSTANCE(typ) \ +instance {-# OVERLAPPING #-} Eq (Array typ) where { \ +; {-# INLINE (==) #-} \ +; (==) = byteEq \ +} + +MK_EQ_INSTANCE(Char) +MK_EQ_INSTANCE(Word8) +MK_EQ_INSTANCE(Word16) +MK_EQ_INSTANCE(Word32) + +-- XXX The Word64 default instance should be as fast because we are comparing +-- 64-bit at a time. +MK_EQ_INSTANCE(Word64) +MK_EQ_INSTANCE(Int) +MK_EQ_INSTANCE(Int8) +MK_EQ_INSTANCE(Int16) +MK_EQ_INSTANCE(Int32) + +-- XXX The Int64 default instance should be as fast. +MK_EQ_INSTANCE(Int64) + +-- | If the type allows a byte-by-byte comparison this instance can be +-- overlapped by a more specific instance that uses 'byteCmp'. Byte comparison +-- can be significantly faster. +-- +instance {-# OVERLAPPABLE #-} (Unbox a, Eq a) => Eq (Array a) where + {-# INLINE (==) #-} + arr1 == arr2 = + -- Does unboxed byte equality mean element equality? + -- XXX This is incorrect for sum types, as we may have some + -- uninitialized memory in that case. If we always initialize the + -- unused memory to zero we can use this. + -- Byte comparison is 40% faster compared to stream equality. + -- (==) EQ $ unsafeInlineIO $! unsafeThaw arr1 `MA.cmp` unsafeThaw arr2 + (toStreamD arr1 :: Stream Identity a) == toStreamD arr2 + +instance (Unbox a, Ord a) => Ord (Array a) where + {-# INLINE compare #-} + compare arr1 arr2 = runIdentity $ + D.cmpBy compare (toStreamD arr1) (toStreamD arr2) + + -- Default definitions defined in base do not have an INLINE on them, so we + -- replicate them here with an INLINE. + {-# INLINE (<) #-} + x < y = case compare x y of { LT -> True; _ -> False } + + {-# INLINE (<=) #-} + x <= y = case compare x y of { GT -> False; _ -> True } + + {-# INLINE (>) #-} + x > y = case compare x y of { GT -> True; _ -> False } + + {-# INLINE (>=) #-} + x >= y = case compare x y of { LT -> False; _ -> True } + + -- These two default methods use '<=' rather than 'compare' + -- because the latter is often more expensive + {-# INLINE max #-} + max x y = if x <= y then y else x + + {-# INLINE min #-} + min x y = if x <= y then x else y + +#ifdef DEVBUILD +-- Definitions using the Unboxed constraint from the Array type. These are to +-- make the Foldable instance possible though it is much slower (7x slower). +-- +{-# INLINE_NORMAL _toStreamD_ #-} +_toStreamD_ :: forall m a. MonadIO m => Int -> Array a -> D.Stream m a +_toStreamD_ size Array{..} = D.Stream step arrStart + + where + + {-# INLINE_LATE step #-} + step _ p | p == arrEnd = return D.Stop + step _ p = liftIO $ do + x <- peekAt p arrContents + return $ D.Yield x (p + size) + +{- +XXX Why isn't Unboxed implicit? This does not compile unless I use the Unboxed +contraint. +{-# INLINE_NORMAL _foldr #-} +_foldr :: forall a b. (a -> b -> b) -> b -> Array a -> b +_foldr f z arr = + let !n = SIZE_OF(a) + in unsafePerformIO $ D.foldr f z $ toStreamD_ n arr +-- | Note that the 'Foldable' instance is 7x slower than the direct +-- operations. +instance Foldable Array where + foldr = _foldr +-} + +#endif + +------------------------------------------------------------------------------- +-- Semigroup and Monoid +------------------------------------------------------------------------------- + +-- XXX Deprecate and remove the Semigroup and Monoid instances because of +-- potential misuse chances. + +-- | This should not be used for combining many or N arrays as it would copy +-- the two arrays everytime to a new array. For coalescing multiple arrays use +-- 'fromChunksK' instead. +instance Unbox a => Semigroup (Array a) where + arr1 <> arr2 = unsafePerformIO $ splice arr1 arr2 + +empty :: +#ifdef DEVBUILD + Unbox a => +#endif + Array a +empty = Array Unboxed.empty 0 0 + +{-# DEPRECATED nil "Please use empty instead." #-} +nil :: +#ifdef DEVBUILD + Unbox a => +#endif + Array a +nil = empty + +instance Unbox a => Monoid (Array a) where + mempty = nil + mappend = (<>) + +------------------------------------------------------------------------------- +-- Backward Compatibility +------------------------------------------------------------------------------- + +RENAME(unsafeIndexIO,unsafeGetIndexIO) +RENAME(getIndexUnsafe,unsafeGetIndex) +RENAME(readerUnsafe,unsafeReader) diff --git a/src/Streamly/Internal/Data/Binary/Parser.hs b/src/Streamly/Internal/Data/Binary/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Binary/Parser.hs @@ -0,0 +1,399 @@ +-- | +-- Module : Streamly.Internal.Data.Binary.Parser +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- Decode Haskell data types from byte streams. +-- +-- It would be inefficient to use this to compose parsers for general algebraic +-- data types. For general deserialization of ADTs please use the Serialize +-- type class instances. The fastest way to deserialize byte streams +-- representing Haskell data types is to write them to arrays and deserialize +-- the array using the Serialize type class. + +module Streamly.Internal.Data.Binary.Parser + ( + -- * Type class + FromBytes (..) + + -- * Decoders + , unit + , bool + , ordering + , eqWord8 -- XXX rename to word8Eq + , word8 + , word16be + , word16le + , word32be + , word32le + , word64be + , word64le + , word64host + , int8 + , int16be + , int16le + , int32be + , int32le + , int64be + , int64le + , float32be + , float32le + , double64be + , double64le + , charLatin1 + ) +where + +import Control.Monad.IO.Class (MonadIO) +import Data.Bits ((.|.), unsafeShiftL) +import Data.Char (chr) +import Data.Int (Int8, Int16, Int32, Int64) +import GHC.Float (castWord32ToFloat, castWord64ToDouble) +import Data.Word (Word8, Word16, Word32, Word64) +import Streamly.Internal.Data.Parser (Parser) +import Streamly.Internal.Data.Maybe.Strict (Maybe'(..)) +import Streamly.Internal.Data.Tuple.Strict (Tuple' (..)) +import qualified Streamly.Data.Array as A +import qualified Streamly.Internal.Data.Array as A + (unsafeGetIndex, unsafeCast) +import qualified Streamly.Internal.Data.Parser as PR + (fromPure, either, satisfy, takeEQ) +import qualified Streamly.Internal.Data.Parser as PRD + (Parser(..), Initial(..), Step(..), Final(..)) + +-- Note: The () type does not need to have an on-disk representation in theory. +-- But we use a concrete representation for it so that we count how many () +-- types we have. Or when we have an array of units the array a concrete +-- length. + +-- | A value of type '()' is encoded as @0@ in binary encoding. +-- +-- @ +-- 0 ==> () +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE unit #-} +unit :: Monad m => Parser Word8 m () +unit = eqWord8 0 *> PR.fromPure () + +{-# INLINE word8ToBool #-} +word8ToBool :: Word8 -> Either String Bool +word8ToBool 0 = Right False +word8ToBool 1 = Right True +word8ToBool w = Left ("Invalid Bool encoding " ++ Prelude.show w) + +-- | A value of type 'Bool' is encoded as follows in binary encoding. +-- +-- @ +-- 0 ==> False +-- 1 ==> True +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE bool #-} +bool :: Monad m => Parser Word8 m Bool +bool = PR.either word8ToBool + +{-# INLINE word8ToOrdering #-} +word8ToOrdering :: Word8 -> Either String Ordering +word8ToOrdering 0 = Right LT +word8ToOrdering 1 = Right EQ +word8ToOrdering 2 = Right GT +word8ToOrdering w = Left ("Invalid Ordering encoding " ++ Prelude.show w) + +-- | A value of type 'Ordering' is encoded as follows in binary encoding. +-- +-- @ +-- 0 ==> LT +-- 1 ==> EQ +-- 2 ==> GT +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE ordering #-} +ordering :: Monad m => Parser Word8 m Ordering +ordering = PR.either word8ToOrdering + +-- XXX should go in a Word8 parser module? +-- | Accept the input byte only if it is equal to the specified value. +-- +-- /Pre-release/ +-- +{-# INLINE eqWord8 #-} +eqWord8 :: Monad m => Word8 -> Parser Word8 m Word8 +eqWord8 b = PR.satisfy (== b) + +-- | Accept any byte. +-- +-- /Pre-release/ +-- +{-# INLINE word8 #-} +word8 :: Monad m => Parser Word8 m Word8 +word8 = PR.satisfy (const True) + +-- | Big endian (MSB first) Word16 +{-# INLINE word16beD #-} +word16beD :: Monad m => PRD.Parser Word8 m Word16 +word16beD = PRD.Parser step initial extract + + where + + initial = return $ PRD.IPartial Nothing' + + step Nothing' a = + -- XXX We can use a non-failing parser or a fold so that we do not + -- have to buffer for backtracking which is inefficient. + return $ PRD.SContinue 1 (Just' (fromIntegral a `unsafeShiftL` 8)) + step (Just' w) a = + return $ PRD.SDone 1 (w .|. fromIntegral a) + + extract _ = return $ PRD.FError "word16be: end of input" + +-- | Parse two bytes as a 'Word16', the first byte is the MSB of the Word16 and +-- second byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word16be #-} +word16be :: Monad m => Parser Word8 m Word16 +word16be = word16beD + +-- | Little endian (LSB first) Word16 +{-# INLINE word16leD #-} +word16leD :: Monad m => PRD.Parser Word8 m Word16 +word16leD = PRD.Parser step initial extract + + where + + initial = return $ PRD.IPartial Nothing' + + step Nothing' a = + return $ PRD.SContinue 1 (Just' (fromIntegral a)) + step (Just' w) a = + return $ PRD.SDone 1 (w .|. fromIntegral a `unsafeShiftL` 8) + + extract _ = return $ PRD.FError "word16le: end of input" + +-- | Parse two bytes as a 'Word16', the first byte is the LSB of the Word16 and +-- second byte is the MSB (little endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word16le #-} +word16le :: Monad m => Parser Word8 m Word16 +word16le = word16leD + +-- | Big endian (MSB first) Word32 +{-# INLINE word32beD #-} +word32beD :: Monad m => PRD.Parser Word8 m Word32 +word32beD = PRD.Parser step initial extract + + where + + initial = return $ PRD.IPartial $ Tuple' 0 24 + + step (Tuple' w sh) a = return $ + if sh /= 0 + then + let w1 = w .|. (fromIntegral a `unsafeShiftL` sh) + in PRD.SContinue 1 (Tuple' w1 (sh - 8)) + else PRD.SDone 1 (w .|. fromIntegral a) + + extract _ = return $ PRD.FError "word32beD: end of input" + +-- | Parse four bytes as a 'Word32', the first byte is the MSB of the Word32 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word32be #-} +word32be :: Monad m => Parser Word8 m Word32 +word32be = word32beD + +-- | Little endian (LSB first) Word32 +{-# INLINE word32leD #-} +word32leD :: Monad m => PRD.Parser Word8 m Word32 +word32leD = PRD.Parser step initial extract + + where + + initial = return $ PRD.IPartial $ Tuple' 0 0 + + step (Tuple' w sh) a = return $ + let w1 = w .|. (fromIntegral a `unsafeShiftL` sh) + in if sh /= 24 + then PRD.SContinue 1 (Tuple' w1 (sh + 8)) + else PRD.SDone 1 w1 + + extract _ = return $ PRD.FError "word32leD: end of input" + +-- | Parse four bytes as a 'Word32', the first byte is the MSB of the Word32 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word32le #-} +word32le :: Monad m => Parser Word8 m Word32 +word32le = word32leD + +-- | Big endian (MSB first) Word64 +{-# INLINE word64beD #-} +word64beD :: Monad m => PRD.Parser Word8 m Word64 +word64beD = PRD.Parser step initial extract + + where + + initial = return $ PRD.IPartial $ Tuple' 0 56 + + step (Tuple' w sh) a = return $ + if sh /= 0 + then + let w1 = w .|. (fromIntegral a `unsafeShiftL` sh) + in PRD.SContinue 1 (Tuple' w1 (sh - 8)) + else PRD.SDone 1 (w .|. fromIntegral a) + + extract _ = return $ PRD.FError "word64beD: end of input" + +-- | Parse eight bytes as a 'Word64', the first byte is the MSB of the Word64 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word64be #-} +word64be :: Monad m => Parser Word8 m Word64 +word64be = word64beD + +-- | Little endian (LSB first) Word64 +{-# INLINE word64leD #-} +word64leD :: Monad m => PRD.Parser Word8 m Word64 +word64leD = PRD.Parser step initial extract + + where + + initial = return $ PRD.IPartial $ Tuple' 0 0 + + step (Tuple' w sh) a = return $ + let w1 = w .|. (fromIntegral a `unsafeShiftL` sh) + in if sh /= 56 + then PRD.SContinue 1 (Tuple' w1 (sh + 8)) + else PRD.SDone 1 w1 + + extract _ = return $ PRD.FError "word64leD: end of input" + +-- | Parse eight bytes as a 'Word64', the first byte is the MSB of the Word64 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word64le #-} +word64le :: Monad m => Parser Word8 m Word64 +word64le = word64leD + +{-# INLINE int8 #-} +int8 :: Monad m => Parser Word8 m Int8 +int8 = fromIntegral <$> word8 + +-- | Parse two bytes as a 'Int16', the first byte is the MSB of the Int16 and +-- second byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int16be #-} +int16be :: Monad m => Parser Word8 m Int16 +int16be = fromIntegral <$> word16be + +-- | Parse two bytes as a 'Int16', the first byte is the LSB of the Int16 and +-- second byte is the MSB (little endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int16le #-} +int16le :: Monad m => Parser Word8 m Int16 +int16le = fromIntegral <$> word16le + +-- | Parse four bytes as a 'Int32', the first byte is the MSB of the Int32 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int32be #-} +int32be :: Monad m => Parser Word8 m Int32 +int32be = fromIntegral <$> word32be + +-- | Parse four bytes as a 'Int32', the first byte is the MSB of the Int32 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int32le #-} +int32le :: Monad m => Parser Word8 m Int32 +int32le = fromIntegral <$> word32le + +-- | Parse eight bytes as a 'Int64', the first byte is the MSB of the Int64 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int64be #-} +int64be :: Monad m => Parser Word8 m Int64 +int64be = fromIntegral <$> word64be + +-- | Parse eight bytes as a 'Int64', the first byte is the MSB of the Int64 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int64le #-} +int64le :: Monad m => Parser Word8 m Int64 +int64le = fromIntegral <$> word64le + +{-# INLINE float32be #-} +float32be :: MonadIO m => Parser Word8 m Float +float32be = castWord32ToFloat <$> word32be + +{-# INLINE float32le #-} +float32le :: MonadIO m => Parser Word8 m Float +float32le = castWord32ToFloat <$> word32le + +{-# INLINE double64be #-} +double64be :: MonadIO m => Parser Word8 m Double +double64be = castWord64ToDouble <$> word64be + +{-# INLINE double64le #-} +double64le :: MonadIO m => Parser Word8 m Double +double64le = castWord64ToDouble <$> word64le + +-- | Accept any byte. +-- +-- /Pre-release/ +-- +{-# INLINE charLatin1 #-} +charLatin1 :: Monad m => Parser Word8 m Char +charLatin1 = fmap (chr . fromIntegral) word8 + +------------------------------------------------------------------------------- +-- Host byte order +------------------------------------------------------------------------------- + +-- | Parse eight bytes as a 'Word64' in the host byte order. +-- +-- /Pre-release/ +-- +{-# INLINE word64host #-} +word64host :: MonadIO m => Parser Word8 m Word64 +word64host = + fmap (A.unsafeGetIndex 0 . A.unsafeCast) $ PR.takeEQ 8 (A.createOf 8) + +------------------------------------------------------------------------------- +-- Type class +------------------------------------------------------------------------------- + +class FromBytes a where + -- | Decode a byte stream to a Haskell type. + fromBytes :: Parser Word8 m a diff --git a/src/Streamly/Internal/Data/Binary/Stream.hs b/src/Streamly/Internal/Data/Binary/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Binary/Stream.hs @@ -0,0 +1,383 @@ +-- | +-- Module : Streamly.Internal.Data.Binary.Stream +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- Encode Haskell data types to byte streams. +-- +-- The primary purpose of this module is to serialize primitive Haskell types +-- to streams for convenient byte by byte processing when such a need arises. +-- +-- It would be inefficient to use this to build byte streams from algebraic +-- data types. For general serialization of ADTs please use the Serialize type +-- class instances. The fastest way to convert general Haskell types to byte +-- streams is to serialize them to an array and then stream the array. + +-- XXX remove unit, bool, ordering, and the type class as well + +module Streamly.Internal.Data.Binary.Stream + ( + -- * Type class + ToBytes (..) + + -- * Encoders + , unit + , bool + , ordering + , word8 + , word16be + , word16le + , word32be + , word32le + , word64be + , word64le + , word64host + , int8 + , int16be + , int16le + , int32be + , int32le + , int64be + , int64le + , float32be + , float32le + , double64be + , double64le + , charLatin1 + , charUtf8 + ) +where + +#include "MachDeps.h" + +import Data.Bits (shiftR) +import Data.Char (ord) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import GHC.Float (castDoubleToWord64, castFloatToWord32) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.Stream (Step(..)) +import Streamly.Internal.Unicode.Stream (readCharUtf8) + +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Stream as D + +-- XXX Use StreamD directly? + +-- | A value of type '()' is encoded as @0@ in binary encoding. +-- +-- @ +-- 0 ==> () +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE unit #-} +unit :: Applicative m => Stream m Word8 +unit = Stream.fromPure 0 + +{-# INLINE boolToWord8 #-} +boolToWord8 :: Bool -> Word8 +boolToWord8 False = 0 +boolToWord8 True = 1 + +-- | A value of type 'Bool' is encoded as follows in binary encoding. +-- +-- @ +-- 0 ==> False +-- 1 ==> True +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE bool #-} +bool :: Applicative m => Bool -> Stream m Word8 +bool = Stream.fromPure . boolToWord8 + +{-# INLINE orderingToWord8 #-} +orderingToWord8 :: Ordering -> Word8 +orderingToWord8 LT = 0 +orderingToWord8 EQ = 1 +orderingToWord8 GT = 2 + +-- | A value of type 'Ordering' is encoded as follows in binary encoding. +-- +-- @ +-- 0 ==> LT +-- 1 ==> EQ +-- 2 ==> GT +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE ordering #-} +ordering :: Applicative m => Ordering -> Stream m Word8 +ordering = Stream.fromPure . orderingToWord8 + +-- | Stream a 'Word8'. +-- +-- /Pre-release/ +-- +{-# INLINE word8 #-} +word8 :: Applicative m => Word8 -> Stream m Word8 +word8 = Stream.fromPure + +data W16State = W16B1 | W16B2 | W16Done + +{-# INLINE word16beD #-} +word16beD :: Applicative m => Word16 -> D.Stream m Word8 +word16beD w = D.Stream step W16B1 + + where + + step _ W16B1 = pure $ Yield (fromIntegral (shiftR w 8) :: Word8) W16B2 + step _ W16B2 = pure $ Yield (fromIntegral w :: Word8) W16Done + step _ W16Done = pure Stop + +-- | Stream a 'Word16' as two bytes, the first byte is the MSB of the Word16 +-- and second byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word16be #-} +word16be :: Monad m => Word16 -> Stream m Word8 +word16be = word16beD + +-- | Little endian (LSB first) Word16 +{-# INLINE word16leD #-} +word16leD :: Applicative m => Word16 -> D.Stream m Word8 +word16leD w = D.Stream step W16B1 + + where + + step _ W16B1 = pure $ Yield (fromIntegral w :: Word8) W16B2 + step _ W16B2 = pure $ Yield (fromIntegral (shiftR w 8) :: Word8) W16Done + step _ W16Done = pure Stop + +-- | Stream a 'Word16' as two bytes, the first byte is the LSB of the Word16 +-- and second byte is the MSB (little endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word16le #-} +word16le :: Monad m => Word16 -> Stream m Word8 +word16le = word16leD + +data W32State = W32B1 | W32B2 | W32B3 | W32B4 | W32Done + +-- | Big endian (MSB first) Word32 +{-# INLINE word32beD #-} +word32beD :: Applicative m => Word32 -> D.Stream m Word8 +word32beD w = D.Stream step W32B1 + + where + + yield n s = pure $ Yield (fromIntegral (shiftR w n) :: Word8) s + + step _ W32B1 = yield 24 W32B2 + step _ W32B2 = yield 16 W32B3 + step _ W32B3 = yield 8 W32B4 + step _ W32B4 = pure $ Yield (fromIntegral w :: Word8) W32Done + step _ W32Done = pure Stop + +-- | Stream a 'Word32' as four bytes, the first byte is the MSB of the Word32 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word32be #-} +word32be :: Monad m => Word32 -> Stream m Word8 +word32be = word32beD + +-- | Little endian (LSB first) Word32 +{-# INLINE word32leD #-} +word32leD :: Applicative m => Word32 -> D.Stream m Word8 +word32leD w = D.Stream step W32B1 + + where + + yield n s = pure $ Yield (fromIntegral (shiftR w n) :: Word8) s + + step _ W32B1 = pure $ Yield (fromIntegral w :: Word8) W32B2 + step _ W32B2 = yield 8 W32B3 + step _ W32B3 = yield 16 W32B4 + step _ W32B4 = yield 24 W32Done + step _ W32Done = pure Stop + +-- | Stream a 'Word32' as four bytes, the first byte is the MSB of the Word32 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word32le #-} +word32le :: Monad m => Word32 -> Stream m Word8 +word32le = word32leD + +data W64State = + W64B1 | W64B2 | W64B3 | W64B4 | W64B5 | W64B6 | W64B7 | W64B8 | W64Done + +-- | Big endian (MSB first) Word64 +{-# INLINE word64beD #-} +word64beD :: Applicative m => Word64 -> D.Stream m Word8 +word64beD w = D.Stream step W64B1 + + where + + yield n s = pure $ Yield (fromIntegral (shiftR w n) :: Word8) s + + step _ W64B1 = yield 56 W64B2 + step _ W64B2 = yield 48 W64B3 + step _ W64B3 = yield 40 W64B4 + step _ W64B4 = yield 32 W64B5 + step _ W64B5 = yield 24 W64B6 + step _ W64B6 = yield 16 W64B7 + step _ W64B7 = yield 8 W64B8 + step _ W64B8 = pure $ Yield (fromIntegral w :: Word8) W64Done + step _ W64Done = pure Stop + +-- | Stream a 'Word64' as eight bytes, the first byte is the MSB of the Word64 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word64be #-} +word64be :: Monad m => Word64 -> Stream m Word8 +word64be = word64beD + +-- | Little endian (LSB first) Word64 +{-# INLINE word64leD #-} +word64leD :: Applicative m => Word64 -> D.Stream m Word8 +word64leD w = D.Stream step W64B1 + + where + + yield n s = pure $ Yield (fromIntegral (shiftR w n) :: Word8) s + + step _ W64B1 = pure $ Yield (fromIntegral w :: Word8) W64B2 + step _ W64B2 = yield 8 W64B3 + step _ W64B3 = yield 16 W64B4 + step _ W64B4 = yield 24 W64B5 + step _ W64B5 = yield 32 W64B6 + step _ W64B6 = yield 40 W64B7 + step _ W64B7 = yield 48 W64B8 + step _ W64B8 = yield 56 W64Done + step _ W64Done = pure Stop + +-- | Stream a 'Word64' as eight bytes, the first byte is the MSB of the Word64 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE word64le #-} +word64le :: Monad m => Word64 -> Stream m Word8 +word64le = word64leD + +{-# INLINE int8 #-} +int8 :: Applicative m => Int8 -> Stream m Word8 +int8 i = word8 (fromIntegral i :: Word8) + +-- | Stream a 'Int16' as two bytes, the first byte is the MSB of the Int16 +-- and second byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int16be #-} +int16be :: Monad m => Int16 -> Stream m Word8 +int16be i = word16be (fromIntegral i :: Word16) + +-- | Stream a 'Int16' as two bytes, the first byte is the LSB of the Int16 +-- and second byte is the MSB (little endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int16le #-} +int16le :: Monad m => Int16 -> Stream m Word8 +int16le i = word16le (fromIntegral i :: Word16) + +-- | Stream a 'Int32' as four bytes, the first byte is the MSB of the Int32 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int32be #-} +int32be :: Monad m => Int32 -> Stream m Word8 +int32be i = word32be (fromIntegral i :: Word32) + +{-# INLINE int32le #-} +int32le :: Monad m => Int32 -> Stream m Word8 +int32le i = word32le (fromIntegral i :: Word32) + +-- | Stream a 'Int64' as eight bytes, the first byte is the MSB of the Int64 +-- and last byte is the LSB (big endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int64be #-} +int64be :: Monad m => Int64 -> Stream m Word8 +int64be i = word64be (fromIntegral i :: Word64) + +-- | Stream a 'Int64' as eight bytes, the first byte is the LSB of the Int64 +-- and last byte is the MSB (little endian representation). +-- +-- /Pre-release/ +-- +{-# INLINE int64le #-} +int64le :: Monad m => Int64 -> Stream m Word8 +int64le i = word64le (fromIntegral i :: Word64) + +-- | Big endian (MSB first) Float +{-# INLINE float32be #-} +float32be :: Monad m => Float -> Stream m Word8 +float32be = word32beD . castFloatToWord32 + +-- | Little endian (LSB first) Float +{-# INLINE float32le #-} +float32le :: Monad m => Float -> Stream m Word8 +float32le = word32leD . castFloatToWord32 + +-- | Big endian (MSB first) Double +{-# INLINE double64be #-} +double64be :: Monad m => Double -> Stream m Word8 +double64be = word64beD . castDoubleToWord64 + +-- | Little endian (LSB first) Double +{-# INLINE double64le #-} +double64le :: Monad m => Double -> Stream m Word8 +double64le = word64leD . castDoubleToWord64 + +-- | Encode a Unicode character to stream of bytes in 0-255 range. +-- +{-# INLINE charLatin1 #-} +charLatin1 :: Applicative m => Char -> Stream m Word8 +charLatin1 = Stream.fromPure . fromIntegral . ord + +{-# INLINE charUtf8 #-} +charUtf8 :: Monad m => Char -> Stream m Word8 +charUtf8 = Stream.unfold readCharUtf8 + +------------------------------------------------------------------------------- +-- Host byte order +------------------------------------------------------------------------------- + +-- | Stream a 'Word64' as eight bytes in the host byte order. +-- +-- /Pre-release/ +-- +{-# INLINE word64host #-} +word64host :: Monad m => Word64 -> Stream m Word8 +word64host = +#ifdef WORDS_BIGENDIAN + word64be +#else + word64le +#endif + +------------------------------------------------------------------------------- +-- Type class +------------------------------------------------------------------------------- + +class ToBytes a where + -- | Convert a Haskell type to a byte stream. + toBytes :: a -> Stream m Word8 diff --git a/src/Streamly/Internal/Data/Builder.hs b/src/Streamly/Internal/Data/Builder.hs --- a/src/Streamly/Internal/Data/Builder.hs +++ b/src/Streamly/Internal/Data/Builder.hs @@ -16,7 +16,10 @@ ) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) +#endif +import Data.Bifunctor (first) ------------------------------------------------------------------------------ -- The Builder type @@ -27,16 +30,16 @@ -- or even a Fold. Unlike fold the step function is one-shot and not called in -- a loop. newtype Builder s m a = - Builder (s -> m (s, a)) + Builder (s -> m (a, s)) -- | Maps a function on the output of the fold (the type @b@). instance Functor m => Functor (Builder s m) where {-# INLINE fmap #-} - fmap f (Builder step1) = Builder (fmap (fmap f) . step1) + fmap f (Builder step1) = Builder (fmap (first f) . step1) {-# INLINE fromPure #-} fromPure :: Applicative m => b -> Builder s m b -fromPure b = Builder (\s -> pure (s, b)) +fromPure b = Builder (\s -> pure (b, s)) -- | Chain the actions and zip the outputs. {-# INLINE sequenceWith #-} @@ -47,9 +50,9 @@ where step s = do - (s1, x) <- stepL s - (s2, y) <- stepR s1 - pure (s2, func x y) + (x, s1) <- stepL s + (y, s2) <- stepR s1 + pure (func x y, s2) instance Monad m => Applicative (Builder a m) where {-# INLINE pure #-} @@ -74,7 +77,7 @@ where step s = do - (s1, x) <- stepL s + (x, s1) <- stepL s let Builder stepR = f x - (s2, y) <- stepR s1 - pure (s2, y) + (y, s2) <- stepR s1 + pure (y, s2) diff --git a/src/Streamly/Internal/Data/CString.hs b/src/Streamly/Internal/Data/CString.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/CString.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE UnliftedFFITypes #-} + +-- | +-- Module : Streamly.Internal.Data.CString +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- MutByteArray representing null terminated c strings. +-- All APIs in this module are unsafe and caution must be used when using them. +-- Completely experimental. Everything is subject to change without notice. + +module Streamly.Internal.Data.CString + ( + splice + , spliceCString + , splicePtrN + , putCString + , length + ) + +where + +#ifdef DEBUG +#include "assert.hs" +#endif + +import GHC.Ptr (Ptr(..), castPtr) +import Foreign.C (CString, CSize(..)) +import GHC.Exts (MutableByteArray#, RealWorld) +import GHC.Word (Word8) + +import Streamly.Internal.Data.MutByteArray.Type hiding (length) + +import Prelude hiding (length) + +-- XXX Use cstringLength# from GHC.CString in ghc-prim +foreign import ccall unsafe "string.h strlen" c_strlen + :: MutableByteArray# RealWorld -> IO CSize + +-- XXX Use cstringLength# from GHC.CString in ghc-prim +foreign import ccall unsafe "string.h strlen" c_strlen_pinned + :: CString -> IO CSize + +{-# INLINE length #-} +length :: MutByteArray -> IO Int +length (MutByteArray src#) = do + fmap fromIntegral $ c_strlen src# + +-- | Join two null terminated cstrings, the null byte of the first string is +-- overwritten. Does not check the destination length or source length. +-- Destination must have enough space to accomodate src. +-- +-- Returns the offset of the null byte. +-- +-- /Unsafe/ +splice :: MutByteArray -> MutByteArray -> IO Int +splice dst@(MutByteArray dst#) src@(MutByteArray src#) = do + srcLen <- fmap fromIntegral $ c_strlen src# +#ifdef DEBUG + srcLen1 <- length src + assertM(srcLen <= srcLen1) +#endif + dstLen <- fmap fromIntegral $ c_strlen dst# +#ifdef DEBUG + dstLen1 <- length dst + assertM(dstLen <= dstLen1) + assertM(dstLen + srcLen + 1 <= dstLen1) +#endif + unsafePutSlice src 0 dst dstLen (srcLen + 1) + return $ dstLen + srcLen + +-- | Append specified number of bytes from a Ptr to a MutByteArray CString. The +-- null byte of CString is overwritten and the result is terminated with a null +-- byte. +{-# INLINE splicePtrN #-} +splicePtrN :: MutByteArray -> Ptr Word8 -> Int -> IO Int +splicePtrN dst@(MutByteArray dst#) src srcLen = do + dstLen <- fmap fromIntegral $ c_strlen dst# +#ifdef DEBUG + dstLen1 <- length dst + assertM(dstLen <= dstLen1) + assertM(dstLen + srcLen + 1 <= dstLen1) +#endif + -- unsafePutSlice src 0 dst dstLen srcLen + -- XXX unsafePutPtrN signature consistency with serialization routines + -- XXX unsafePutSlice as well + unsafePutPtrN src dst dstLen (srcLen + 1) + return $ dstLen + srcLen + +-- | Join a null terminated cstring MutByteByteArray with a null terminated +-- cstring Ptr. +{-# INLINE spliceCString #-} +spliceCString :: MutByteArray -> CString -> IO Int +spliceCString dst src = do + srcLen <- fmap fromIntegral $ c_strlen_pinned src + splicePtrN dst (castPtr src) srcLen + +-- XXX this is CString serialization. + +-- | @putCString dst dstOffset cstr@ writes the cstring cstr at dstOffset in +-- the dst MutByteArray. The result is terminated by a null byte. +{-# INLINE putCString #-} +putCString :: MutByteArray -> Int -> CString -> IO Int +putCString dst off src = do + srcLen <- fmap fromIntegral $ c_strlen_pinned src + unsafePutPtrN (castPtr src) dst off (srcLen + 1) + return $ off + srcLen diff --git a/src/Streamly/Internal/Data/Fold.hs b/src/Streamly/Internal/Data/Fold.hs --- a/src/Streamly/Internal/Data/Fold.hs +++ b/src/Streamly/Internal/Data/Fold.hs @@ -1,2598 +1,36 @@ {-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Fold --- Copyright : (c) 2019 Composewell Technologies --- (c) 2013 Gabriel Gonzalez --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- See "Streamly.Data.Fold" for an overview and --- "Streamly.Internal.Data.Fold.Type" for design notes. - -module Streamly.Internal.Data.Fold - ( - -- * Imports - -- $setup - - -- * Fold Type - Step (..) - , Fold (..) - , Tee (..) - - -- * Constructors - -- | Which constructor to use? - -- - -- * @foldl*@: If the fold never terminates i.e. does not use the 'Done' - -- constructor otherwise use the @foldt*@ variants. - -- * @*M@: Use the @M@ suffix variants if any of the step, initial, or - -- extract function is monadic, otherwise use the pure variants. - -- - , foldl' - , foldlM' - , foldl1' - , foldlM1' - , foldt' - , foldtM' - , foldr' - , foldrM' - - -- * Mappers - -- | Monadic functions useful with mapM/lmapM on folds or streams. - , tracing - , trace - - -- * Folds - - -- ** Accumulators - -- *** Semigroups and Monoids - , sconcat - , mconcat - , foldMap - , foldMapM - - -- *** Reducers - , drain - , drainMapM - , the - , length - , lengthGeneric - , mean - , rollingHash - , defaultSalt - , rollingHashWithSalt - , rollingHashFirstN - -- , rollingHashLastN - - -- *** Saturating Reducers - -- | 'product' terminates if it becomes 0. Other folds can theoretically - -- saturate on bounded types, and therefore terminate, however, they will - -- run forever on unbounded types like Integer/Double. - , sum - , product - , maximumBy - , maximum - , minimumBy - , minimum - - -- *** Collectors - -- | Avoid using these folds in scalable or performance critical - -- applications, they buffer all the input in GC memory which can be - -- detrimental to performance if the input is large. - , toList - , toListRev - -- $toListRev - , toStream - , toStreamRev - , toStreamK - , toStreamKRev - , topBy - , top - , bottomBy - , bottom - - -- *** Scanners - -- | Stateful transformation of the elements. Useful in combination with - -- the 'scanMaybe' combinator. For scanners the result of the fold is - -- usually a transformation of the current element rather than an - -- aggregation of all elements till now. - , latest - -- , nthLast -- using Ring array - , indexingWith - , indexing - , indexingRev - , rollingMapM - - -- *** Filters - -- | Useful in combination with the 'scanMaybe' combinator. - , filtering - , deleteBy - , uniqBy - , uniq - , repeated - , findIndices - , elemIndices - - -- ** Terminating Folds - -- *** Empty folds - -- | Folds that return a result without consuming any input. - , fromPure - , fromEffect - , fromRefold - - -- *** Singleton folds - -- | Folds that terminate after consuming exactly one input element. All - -- these can be implemented in terms of the 'maybe' fold. - , one - , null -- XXX not very useful and could be problematic, remove it? - , satisfy - , maybe - - -- *** Multi folds - -- | Terminate after consuming one or more elements. - , drainN - -- , lastN - -- , (!!) - , indexGeneric - , index - , findM - , find - , lookup - , findIndex - , elemIndex - , elem - , notElem - , all - , any - , and - , or - - -- ** Trimmers - -- | Useful in combination with the 'scanMaybe' combinator. - , taking - , dropping - , takingEndByM - , takingEndBy - , takingEndByM_ - , takingEndBy_ - , droppingWhileM - , droppingWhile - , prune - - -- * Running A Fold - , drive - -- , breakStream - - -- * Building Incrementally - , extractM - , reduce - , close - , isClosed - , snoc - , snocl - , snocM - , snoclM - - , addOne - , addStream - - -- * Combinators - -- ** Utilities - , with - - -- ** Transforming the Monad - , morphInner - , generalizeInner - - -- ** Mapping on output - , rmapM - - -- ** Mapping on Input - , transform - , lmap - --, lsequence - , lmapM - - -- ** Sliding Window - , slide2 - - -- ** Scanning Input - , scan - , scanMany - , postscan - , indexed - - -- ** Zipping Input - , zipStreamWithM - , zipStream - - -- ** Filtering Input - , catMaybes - , mapMaybeM - , mapMaybe - , scanMaybe - , filter - , filterM - , sampleFromthen - - -- Either streams - , catLefts - , catRights - , catEithers - - {- - -- ** Insertion - -- | Insertion adds more elements to the stream. - - , insertBy - , intersperseM - - -- ** Reordering - , reverse - -} - - -- ** Trimming - , take - - -- By elements - , takeEndBy - , takeEndBy_ - , takeEndBySeq - , takeEndBySeq_ - {- - , drop - , dropWhile - , dropWhileM - -} - - -- ** Serial Append - , splitWith - , split_ - -- , tail - -- , init - , splitAt -- spanN - -- , splitIn -- sessionN - - -- ** Parallel Distribution - , teeWith - , tee - , teeWithFst - , teeWithMin - , distribute - -- , distributeFst - -- , distributeMin - - -- ** Unzipping - , unzip - -- These two can be expressed using lmap/lmapM and unzip - , unzipWith - , unzipWithM - , unzipWithFstM - , unzipWithMinM - - -- ** Parallel Alternative - , shortest - , longest - - -- ** Partitioning - , partitionByM - , partitionByFstM - , partitionByMinM - , partitionBy - , partition - - -- ** Splitting - , many - , manyPost - , groupsOf - , chunksBetween - , refoldMany - , refoldMany1 - , intersperseWithQuotes - - -- ** Nesting - , unfoldMany - , concatSequence - , concatMap - , duplicate - , refold - - -- * Deprecated - , foldr - , drainBy - , last - , head - , sequence - , mapM - , variance - , stdDev - , serialWith - ) -where - -#include "inline.hs" -#include "ArrayMacros.h" - -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Bifunctor (first) -import Data.Bits (shiftL, shiftR, (.|.), (.&.)) -import Data.Either (isLeft, isRight, fromLeft, fromRight) -import Data.Int (Int64) -import Data.Proxy (Proxy(..)) -import Data.Word (Word32) -import Foreign.Storable (Storable, peek) -import Streamly.Internal.Data.Array.Mut.Type (MutArray(..)) -import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) -import Streamly.Internal.Data.Pipe.Type (Pipe (..), PipeState(..)) -import Streamly.Internal.Data.Unboxed (Unbox, sizeOf) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..)) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) - -import qualified Prelude -import qualified Streamly.Internal.Data.Array.Mut.Type as MA -import qualified Streamly.Internal.Data.Array.Type as Array -import qualified Streamly.Internal.Data.Fold.Window as FoldW -import qualified Streamly.Internal.Data.Pipe.Type as Pipe -import qualified Streamly.Internal.Data.Ring.Unboxed as Ring -import qualified Streamly.Internal.Data.Stream.StreamD.Type as StreamD - -import Prelude hiding - ( filter, foldl1, drop, dropWhile, take, takeWhile, zipWith - , foldl, foldr, map, mapM_, sequence, all, any, sum, product, elem - , notElem, maximum, minimum, head, last, tail, length, null - , reverse, iterate, init, and, or, lookup, (!!) - , scanl, scanl1, replicate, concatMap, mconcat, foldMap, unzip - , span, splitAt, break, mapM, zip, maybe) -import Streamly.Internal.Data.Fold.Type -import Streamly.Internal.Data.Fold.Tee - -#include "DocTestDataFold.hs" - ------------------------------------------------------------------------------- --- Running ------------------------------------------------------------------------------- - --- | Drive a fold using the supplied 'Stream', reducing the resulting --- expression strictly at each step. --- --- Definition: --- --- >>> drive = flip Stream.fold --- --- Example: --- --- >>> Fold.drive (Stream.enumerateFromTo 1 100) Fold.sum --- 5050 --- -{-# INLINE drive #-} -drive :: Monad m => Stream m a -> Fold m a b -> m b -drive = flip StreamD.fold - -{- --- | Like 'drive' but also returns the remaining stream. The resulting stream --- would be 'Stream.nil' if the stream finished before the fold. --- --- Definition: --- --- >>> breakStream = flip Stream.foldBreak --- --- /CPS/ --- -{-# INLINE breakStreamK #-} -breakStreamK :: Monad m => StreamK m a -> Fold m a b -> m (b, StreamK m a) -breakStreamK strm fl = fmap f $ K.foldBreak fl (Stream.toStreamK strm) - - where - - f (b, str) = (b, Stream.fromStreamK str) --} - --- | Append a stream to a fold to build the fold accumulator incrementally. We --- can repeatedly call 'addStream' on the same fold to continue building the --- fold and finally use 'drive' to finish the fold and extract the result. Also --- see the 'Streamly.Data.Fold.addOne' operation which is a singleton version --- of 'addStream'. --- --- Definitions: --- --- >>> addStream stream = Fold.drive stream . Fold.duplicate --- --- Example, build a list incrementally: --- --- >>> :{ --- pure (Fold.toList :: Fold IO Int [Int]) --- >>= Fold.addOne 1 --- >>= Fold.addStream (Stream.enumerateFromTo 2 4) --- >>= Fold.drive Stream.nil --- >>= print --- :} --- [1,2,3,4] --- --- This can be used as an O(n) list append compared to the O(n^2) @++@ when --- used for incrementally building a list. --- --- Example, build a stream incrementally: --- --- >>> :{ --- pure (Fold.toStream :: Fold IO Int (Stream Identity Int)) --- >>= Fold.addOne 1 --- >>= Fold.addStream (Stream.enumerateFromTo 2 4) --- >>= Fold.drive Stream.nil --- >>= print --- :} --- fromList [1,2,3,4] --- --- This can be used as an O(n) stream append compared to the O(n^2) @<>@ when --- used for incrementally building a stream. --- --- Example, build an array incrementally: --- --- >>> :{ --- pure (Array.write :: Fold IO Int (Array Int)) --- >>= Fold.addOne 1 --- >>= Fold.addStream (Stream.enumerateFromTo 2 4) --- >>= Fold.drive Stream.nil --- >>= print --- :} --- fromList [1,2,3,4] --- --- Example, build an array stream incrementally: --- --- >>> :{ --- let f :: Fold IO Int (Stream Identity (Array Int)) --- f = Fold.groupsOf 2 (Array.writeN 3) Fold.toStream --- in pure f --- >>= Fold.addOne 1 --- >>= Fold.addStream (Stream.enumerateFromTo 2 4) --- >>= Fold.drive Stream.nil --- >>= print --- :} --- fromList [fromList [1,2],fromList [3,4]] --- -addStream :: Monad m => Stream m a -> Fold m a b -> m (Fold m a b) -addStream stream = drive stream . duplicate - ------------------------------------------------------------------------------- --- Transformations on fold inputs ------------------------------------------------------------------------------- - --- | Flatten the monadic output of a fold to pure output. --- -{-# DEPRECATED sequence "Use \"rmapM id\" instead" #-} -{-# INLINE sequence #-} -sequence :: Monad m => Fold m a (m b) -> Fold m a b -sequence = rmapM id - --- | Map a monadic function on the output of a fold. --- -{-# DEPRECATED mapM "Use rmapM instead" #-} -{-# INLINE mapM #-} -mapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c -mapM = rmapM - --- | --- >>> mapMaybeM f = Fold.lmapM f . Fold.catMaybes --- -{-# INLINE mapMaybeM #-} -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Fold m b r -> Fold m a r -mapMaybeM f = lmapM f . catMaybes - --- | @mapMaybe f fold@ maps a 'Maybe' returning function @f@ on the input of --- the fold, filters out 'Nothing' elements, and return the values extracted --- from 'Just'. --- --- >>> mapMaybe f = Fold.lmap f . Fold.catMaybes --- >>> mapMaybe f = Fold.mapMaybeM (return . f) --- --- >>> f x = if even x then Just x else Nothing --- >>> fld = Fold.mapMaybe f Fold.toList --- >>> Stream.fold fld (Stream.enumerateFromTo 1 10) --- [2,4,6,8,10] --- -{-# INLINE mapMaybe #-} -mapMaybe :: Monad m => (a -> Maybe b) -> Fold m b r -> Fold m a r -mapMaybe f = lmap f . catMaybes - ------------------------------------------------------------------------------- --- Transformations on fold inputs ------------------------------------------------------------------------------- - --- | Apply a monadic function on the input and return the input. --- --- >>> Stream.fold (Fold.lmapM (Fold.tracing print) Fold.drain) $ (Stream.enumerateFromTo (1 :: Int) 2) --- 1 --- 2 --- --- /Pre-release/ --- -{-# INLINE tracing #-} -tracing :: Monad m => (a -> m b) -> (a -> m a) -tracing f x = void (f x) >> return x - --- | Apply a monadic function to each element flowing through and discard the --- results. --- --- >>> Stream.fold (Fold.trace print Fold.drain) $ (Stream.enumerateFromTo (1 :: Int) 2) --- 1 --- 2 --- --- >>> trace f = Fold.lmapM (Fold.tracing f) --- --- /Pre-release/ -{-# INLINE trace #-} -trace :: Monad m => (a -> m b) -> Fold m a r -> Fold m a r -trace f = lmapM (tracing f) - --- rename to lpipe? --- --- | Apply a transformation on a 'Fold' using a 'Pipe'. --- --- /Pre-release/ -{-# INLINE transform #-} -transform :: Monad m => Pipe m a b -> Fold m b c -> Fold m a c -transform (Pipe pstep1 pstep2 pinitial) (Fold fstep finitial fextract) = - Fold step initial extract - - where - - initial = first (Tuple' pinitial) <$> finitial - - step (Tuple' ps fs) x = do - r <- pstep1 ps x - go fs r - - where - - -- XXX use SPEC? - go acc (Pipe.Yield b (Consume ps')) = do - acc' <- fstep acc b - return - $ case acc' of - Partial s -> Partial $ Tuple' ps' s - Done b2 -> Done b2 - go acc (Pipe.Yield b (Produce ps')) = do - acc' <- fstep acc b - r <- pstep2 ps' - case acc' of - Partial s -> go s r - Done b2 -> return $ Done b2 - go acc (Pipe.Continue (Consume ps')) = - return $ Partial $ Tuple' ps' acc - go acc (Pipe.Continue (Produce ps')) = do - r <- pstep2 ps' - go acc r - - extract (Tuple' _ fs) = fextract fs - -{-# INLINE scanWith #-} -scanWith :: Monad m => Bool -> Fold m a b -> Fold m b c -> Fold m a c -scanWith isMany (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract - - where - - {-# INLINE runStep #-} - runStep actionL sR = do - rL <- actionL - case rL of - Done bL -> do - rR <- stepR sR bL - case rR of - Partial sR1 -> - if isMany - then runStep initialL sR1 - else Done <$> extractR sR1 - Done bR -> return $ Done bR - Partial sL -> do - !b <- extractL sL - rR <- stepR sR b - return - $ case rR of - Partial sR1 -> Partial (sL, sR1) - Done bR -> Done bR - - initial = do - r <- initialR - case r of - Partial sR -> runStep initialL sR - Done b -> return $ Done b - - step (sL, sR) x = runStep (stepL sL x) sR - - extract = extractR . snd - --- | Scan the input of a 'Fold' to change it in a stateful manner using another --- 'Fold'. The scan stops as soon as the fold terminates. --- --- /Pre-release/ -{-# INLINE scan #-} -scan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c -scan = scanWith False - --- XXX This does not fuse beacuse of the recursive step. Need to investigate. --- --- | Scan the input of a 'Fold' to change it in a stateful manner using another --- 'Fold'. The scan restarts with a fresh state if the fold terminates. --- --- /Pre-release/ -{-# INLINE scanMany #-} -scanMany :: Monad m => Fold m a b -> Fold m b c -> Fold m a c -scanMany = scanWith True - ------------------------------------------------------------------------------- --- Filters ------------------------------------------------------------------------------- - --- | Returns the latest element omitting the first occurrence that satisfies --- the given equality predicate. --- --- Example: --- --- >>> input = Stream.fromList [1,3,3,5] --- >>> Stream.fold Fold.toList $ Stream.scanMaybe (Fold.deleteBy (==) 3) input --- [1,3,5] --- -{-# INLINE_NORMAL deleteBy #-} -deleteBy :: Monad m => (a -> a -> Bool) -> a -> Fold m a (Maybe a) -deleteBy eq x0 = fmap extract $ foldl' step (Tuple' False Nothing) - - where - - step (Tuple' False _) x = - if eq x x0 - then Tuple' True Nothing - else Tuple' False (Just x) - step (Tuple' True _) x = Tuple' True (Just x) - - extract (Tuple' _ x) = x - --- | Provide a sliding window of length 2 elements. --- --- See "Streamly.Internal.Data.Fold.Window". --- -{-# INLINE slide2 #-} -slide2 :: Monad m => Fold m (a, Maybe a) b -> Fold m a b -slide2 (Fold step1 initial1 extract1) = Fold step initial extract - - where - - initial = - first (Tuple' Nothing) <$> initial1 - - step (Tuple' prev s) cur = - first (Tuple' (Just cur)) <$> step1 s (cur, prev) - - extract (Tuple' _ s) = extract1 s - --- | Return the latest unique element using the supplied comparison function. --- Returns 'Nothing' if the current element is same as the last element --- otherwise returns 'Just'. --- --- Example, strip duplicate path separators: --- --- >>> input = Stream.fromList "//a//b" --- >>> f x y = x == '/' && y == '/' --- >>> Stream.fold Fold.toList $ Stream.scanMaybe (Fold.uniqBy f) input --- "/a/b" --- --- Space: @O(1)@ --- --- /Pre-release/ --- -{-# INLINE uniqBy #-} -uniqBy :: Monad m => (a -> a -> Bool) -> Fold m a (Maybe a) -uniqBy eq = rollingMap f - - where - - f pre curr = - case pre of - Nothing -> Just curr - Just x -> if x `eq` curr then Nothing else Just curr - --- | See 'uniqBy'. --- --- Definition: --- --- >>> uniq = Fold.uniqBy (==) --- -{-# INLINE uniq #-} -uniq :: (Monad m, Eq a) => Fold m a (Maybe a) -uniq = uniqBy (==) - --- | Strip all leading and trailing occurrences of an element passing a --- predicate and make all other consecutive occurrences uniq. --- --- >> prune p = Stream.dropWhileAround p $ Stream.uniqBy (x y -> p x && p y) --- --- @ --- > Stream.prune isSpace (Stream.fromList " hello world! ") --- "hello world!" --- --- @ --- --- Space: @O(1)@ --- --- /Unimplemented/ -{-# INLINE prune #-} -prune :: - -- (Monad m, Eq a) => - (a -> Bool) -> Fold m a (Maybe a) -prune = error "Not implemented yet!" - --- | Emit only repeated elements, once. --- --- /Unimplemented/ -repeated :: -- (Monad m, Eq a) => - Fold m a (Maybe a) -repeated = error "Not implemented yet!" - ------------------------------------------------------------------------------- --- Left folds ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Run Effects ------------------------------------------------------------------------------- - --- | --- Definitions: --- --- >>> drainMapM f = Fold.lmapM f Fold.drain --- >>> drainMapM f = Fold.foldMapM (void . f) --- --- Drain all input after passing it through a monadic function. This is the --- dual of mapM_ on stream producers. --- -{-# INLINE drainMapM #-} -drainMapM :: Monad m => (a -> m b) -> Fold m a () -drainMapM f = lmapM f drain - -{-# DEPRECATED drainBy "Please use 'drainMapM' instead." #-} -{-# INLINE drainBy #-} -drainBy :: Monad m => (a -> m b) -> Fold m a () -drainBy = drainMapM - --- | Returns the latest element of the input stream, if any. --- --- >>> latest = Fold.foldl1' (\_ x -> x) --- >>> latest = fmap getLast $ Fold.foldMap (Last . Just) --- -{-# INLINE latest #-} -latest :: Monad m => Fold m a (Maybe a) -latest = foldl1' (\_ x -> x) - -{-# DEPRECATED last "Please use 'latest' instead." #-} -{-# INLINE last #-} -last :: Monad m => Fold m a (Maybe a) -last = latest - --- | Terminates with 'Nothing' as soon as it finds an element different than --- the previous one, returns 'the' element if the entire input consists of the --- same element. --- -{-# INLINE the #-} -the :: (Monad m, Eq a) => Fold m a (Maybe a) -the = foldt' step initial id - - where - - initial = Partial Nothing - - step Nothing x = Partial (Just x) - step old@(Just x0) x = - if x0 == x - then Partial old - else Done Nothing - ------------------------------------------------------------------------------- --- To Summary ------------------------------------------------------------------------------- - --- | Like 'length', except with a more general 'Num' return value --- --- Definition: --- --- >>> lengthGeneric = fmap getSum $ Fold.foldMap (Sum . const 1) --- >>> lengthGeneric = Fold.foldl' (\n _ -> n + 1) 0 --- --- /Pre-release/ -{-# INLINE lengthGeneric #-} -lengthGeneric :: (Monad m, Num b) => Fold m a b -lengthGeneric = foldl' (\n _ -> n + 1) 0 - --- | Determine the length of the input stream. --- --- Definition: --- --- >>> length = Fold.lengthGeneric --- >>> length = fmap getSum $ Fold.foldMap (Sum . const 1) --- -{-# INLINE length #-} -length :: Monad m => Fold m a Int -length = lengthGeneric - - --- | Determine the sum of all elements of a stream of numbers. Returns additive --- identity (@0@) when the stream is empty. Note that this is not numerically --- stable for floating point numbers. --- --- >>> sum = FoldW.cumulative FoldW.sum --- --- Same as following but numerically stable: --- --- >>> sum = Fold.foldl' (+) 0 --- >>> sum = fmap Data.Monoid.getSum $ Fold.foldMap Data.Monoid.Sum --- -{-# INLINE sum #-} -sum :: (Monad m, Num a) => Fold m a a -sum = FoldW.cumulative FoldW.sum - --- | Determine the product of all elements of a stream of numbers. Returns --- multiplicative identity (@1@) when the stream is empty. The fold terminates --- when it encounters (@0@) in its input. --- --- Same as the following but terminates on multiplication by @0@: --- --- >>> product = fmap Data.Monoid.getProduct $ Fold.foldMap Data.Monoid.Product --- -{-# INLINE product #-} -product :: (Monad m, Num a, Eq a) => Fold m a a -product = foldt' step (Partial 1) id - - where - - step x a = - if a == 0 - then Done 0 - else Partial $ x * a - ------------------------------------------------------------------------------- --- To Summary (Maybe) ------------------------------------------------------------------------------- - --- | Determine the maximum element in a stream using the supplied comparison --- function. --- -{-# INLINE maximumBy #-} -maximumBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe a) -maximumBy cmp = foldl1' max' - - where - - max' x y = - case cmp x y of - GT -> x - _ -> y - --- | Determine the maximum element in a stream. --- --- Definitions: --- --- >>> maximum = Fold.maximumBy compare --- >>> maximum = Fold.foldl1' max --- --- Same as the following but without a default maximum. The 'Max' Monoid uses --- the 'minBound' as the default maximum: --- --- >>> maximum = fmap Data.Semigroup.getMax $ Fold.foldMap Data.Semigroup.Max --- -{-# INLINE maximum #-} -maximum :: (Monad m, Ord a) => Fold m a (Maybe a) -maximum = foldl1' max - --- | Computes the minimum element with respect to the given comparison function --- -{-# INLINE minimumBy #-} -minimumBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe a) -minimumBy cmp = foldl1' min' - - where - - min' x y = - case cmp x y of - GT -> y - _ -> x - --- | Determine the minimum element in a stream using the supplied comparison --- function. --- --- Definitions: --- --- >>> minimum = Fold.minimumBy compare --- >>> minimum = Fold.foldl1' min --- --- Same as the following but without a default minimum. The 'Min' Monoid uses the --- 'maxBound' as the default maximum: --- --- >>> maximum = fmap Data.Semigroup.getMin $ Fold.foldMap Data.Semigroup.Min --- -{-# INLINE minimum #-} -minimum :: (Monad m, Ord a) => Fold m a (Maybe a) -minimum = foldl1' min - ------------------------------------------------------------------------------- --- To Summary (Statistical) ------------------------------------------------------------------------------- - --- | Compute a numerically stable arithmetic mean of all elements in the input --- stream. --- -{-# INLINE mean #-} -mean :: (Monad m, Fractional a) => Fold m a a -mean = fmap done $ foldl' step begin - - where - - begin = Tuple' 0 0 - - step (Tuple' x n) y = - let n1 = n + 1 - in Tuple' (x + (y - x) / n1) n1 - - done (Tuple' x _) = x - --- | Compute a numerically stable (population) variance over all elements in --- the input stream. --- -{-# DEPRECATED variance "Use the streamly-statistics package instead" #-} -{-# INLINE variance #-} -variance :: (Monad m, Fractional a) => Fold m a a -variance = fmap done $ foldl' step begin - - where - - begin = Tuple3' 0 0 0 - - step (Tuple3' n mean_ m2) x = Tuple3' n' mean' m2' - - where - - n' = n + 1 - mean' = (n * mean_ + x) / (n + 1) - delta = x - mean_ - m2' = m2 + delta * delta * n / (n + 1) - - done (Tuple3' n _ m2) = m2 / n - --- | Compute a numerically stable (population) standard deviation over all --- elements in the input stream. --- -{-# DEPRECATED stdDev "Use the streamly-statistics package instead" #-} -{-# INLINE stdDev #-} -stdDev :: (Monad m, Floating a) => Fold m a a -stdDev = sqrt <$> variance - --- | Compute an 'Int' sized polynomial rolling hash --- --- > H = salt * k ^ n + c1 * k ^ (n - 1) + c2 * k ^ (n - 2) + ... + cn * k ^ 0 --- --- Where @c1@, @c2@, @cn@ are the elements in the input stream and @k@ is a --- constant. --- --- This hash is often used in Rabin-Karp string search algorithm. --- --- See https://en.wikipedia.org/wiki/Rolling_hash --- -{-# INLINE rollingHashWithSalt #-} -rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64 -rollingHashWithSalt = foldl' step - - where - - k = 2891336453 :: Int64 - - step cksum a = cksum * k + fromIntegral (fromEnum a) - --- | A default salt used in the implementation of 'rollingHash'. -{-# INLINE defaultSalt #-} -defaultSalt :: Int64 -defaultSalt = -2578643520546668380 - --- | Compute an 'Int' sized polynomial rolling hash of a stream. --- --- >>> rollingHash = Fold.rollingHashWithSalt Fold.defaultSalt --- -{-# INLINE rollingHash #-} -rollingHash :: (Monad m, Enum a) => Fold m a Int64 -rollingHash = rollingHashWithSalt defaultSalt - --- | Compute an 'Int' sized polynomial rolling hash of the first n elements of --- a stream. --- --- >>> rollingHashFirstN n = Fold.take n Fold.rollingHash --- --- /Pre-release/ -{-# INLINE rollingHashFirstN #-} -rollingHashFirstN :: (Monad m, Enum a) => Int -> Fold m a Int64 -rollingHashFirstN n = take n rollingHash - --- XXX Compare this with the implementation in Fold.Window, preferrably use the --- latter if performance is good. - --- | Apply a function on every two successive elements of a stream. The first --- argument of the map function is the previous element and the second argument --- is the current element. When processing the very first element in the --- stream, the previous element is 'Nothing'. --- --- /Pre-release/ --- -{-# INLINE rollingMapM #-} -rollingMapM :: Monad m => (Maybe a -> a -> m b) -> Fold m a b -rollingMapM f = Fold step initial extract - - where - - -- XXX We need just a postscan. We do not need an initial result here. - -- Or we can supply a default initial result as an argument to rollingMapM. - initial = return $ Partial (Nothing, error "Empty stream") - - step (prev, _) cur = do - x <- f prev cur - return $ Partial (Just cur, x) - - extract = return . snd - --- | --- >>> rollingMap f = Fold.rollingMapM (\x y -> return $ f x y) --- -{-# INLINE rollingMap #-} -rollingMap :: Monad m => (Maybe a -> a -> b) -> Fold m a b -rollingMap f = rollingMapM (\x y -> return $ f x y) - ------------------------------------------------------------------------------- --- Monoidal left folds ------------------------------------------------------------------------------- - --- | Semigroup concat. Append the elements of an input stream to a provided --- starting value. --- --- Definition: --- --- >>> sconcat = Fold.foldl' (<>) --- --- >>> semigroups = fmap Data.Monoid.Sum $ Stream.enumerateFromTo 1 10 --- >>> Stream.fold (Fold.sconcat 10) semigroups --- Sum {getSum = 65} --- -{-# INLINE sconcat #-} -sconcat :: (Monad m, Semigroup a) => a -> Fold m a a -sconcat = foldl' (<>) - --- | Monoid concat. Fold an input stream consisting of monoidal elements using --- 'mappend' and 'mempty'. --- --- Definition: --- --- >>> mconcat = Fold.sconcat mempty --- --- >>> monoids = fmap Data.Monoid.Sum $ Stream.enumerateFromTo 1 10 --- >>> Stream.fold Fold.mconcat monoids --- Sum {getSum = 55} --- -{-# INLINE mconcat #-} -mconcat :: - ( Monad m - , Monoid a) => Fold m a a -mconcat = sconcat mempty - --- | --- Definition: --- --- >>> foldMap f = Fold.lmap f Fold.mconcat --- --- Make a fold from a pure function that folds the output of the function --- using 'mappend' and 'mempty'. --- --- >>> sum = Fold.foldMap Data.Monoid.Sum --- >>> Stream.fold sum $ Stream.enumerateFromTo 1 10 --- Sum {getSum = 55} --- -{-# INLINE foldMap #-} -foldMap :: (Monad m, Monoid b) => (a -> b) -> Fold m a b -foldMap f = lmap f mconcat - --- | --- Definition: --- --- >>> foldMapM f = Fold.lmapM f Fold.mconcat --- --- Make a fold from a monadic function that folds the output of the function --- using 'mappend' and 'mempty'. --- --- >>> sum = Fold.foldMapM (return . Data.Monoid.Sum) --- >>> Stream.fold sum $ Stream.enumerateFromTo 1 10 --- Sum {getSum = 55} --- -{-# INLINE foldMapM #-} -foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Fold m a b -foldMapM act = foldlM' step (pure mempty) - - where - - step m a = do - m' <- act a - return $! mappend m m' - ------------------------------------------------------------------------------- --- To Containers ------------------------------------------------------------------------------- - --- $toListRev --- This is more efficient than 'Streamly.Internal.Data.Fold.toList'. toList is --- exactly the same as reversing the list after 'toListRev'. - --- | Buffers the input stream to a list in the reverse order of the input. --- --- Definition: --- --- >>> toListRev = Fold.foldl' (flip (:)) [] --- --- /Warning!/ working on large lists accumulated as buffers in memory could be --- very inefficient, consider using "Streamly.Array" instead. --- - --- xn : ... : x2 : x1 : [] -{-# INLINE toListRev #-} -toListRev :: Monad m => Fold m a [a] -toListRev = foldl' (flip (:)) [] - ------------------------------------------------------------------------------- --- Partial Folds ------------------------------------------------------------------------------- - --- | A fold that drains the first n elements of its input, running the effects --- and discarding the results. --- --- Definition: --- --- >>> drainN n = Fold.take n Fold.drain --- --- /Pre-release/ -{-# INLINE drainN #-} -drainN :: Monad m => Int -> Fold m a () -drainN n = take n drain - ------------------------------------------------------------------------------- --- To Elements ------------------------------------------------------------------------------- - --- | Like 'index', except with a more general 'Integral' argument --- --- /Pre-release/ -{-# INLINE indexGeneric #-} -indexGeneric :: (Integral i, Monad m) => i -> Fold m a (Maybe a) -indexGeneric i = foldt' step (Partial 0) (const Nothing) - - where - - step j a = - if i == j - then Done $ Just a - else Partial (j + 1) - --- | Return the element at the given index. --- --- Definition: --- --- >>> index = Fold.indexGeneric --- -{-# INLINE index #-} -index :: Monad m => Int -> Fold m a (Maybe a) -index = indexGeneric - --- | Consume a single input and transform it using the supplied 'Maybe' --- returning function. --- --- /Pre-release/ --- -{-# INLINE maybe #-} -maybe :: Monad m => (a -> Maybe b) -> Fold m a (Maybe b) -maybe f = foldt' (const (Done . f)) (Partial Nothing) id - --- | Consume a single element and return it if it passes the predicate else --- return 'Nothing'. --- --- Definition: --- --- >>> satisfy f = Fold.maybe (\a -> if f a then Just a else Nothing) --- --- /Pre-release/ -{-# INLINE satisfy #-} -satisfy :: Monad m => (a -> Bool) -> Fold m a (Maybe a) -satisfy f = maybe (\a -> if f a then Just a else Nothing) -{- -satisfy f = Fold step (return $ Partial ()) (const (return Nothing)) - - where - - step () a = return $ Done $ if f a then Just a else Nothing --} - --- Naming notes: --- --- "head" and "next" are two alternative names for the same API. head sounds --- apt in the context of lists but next sounds more apt in the context of --- streams where we think in terms of generating and consuming the next element --- rather than taking the head of some static/persistent structure. --- --- We also want to keep the nomenclature consistent across folds and parsers, --- "head" becomes even more unintuitive for parsers because there are two --- possible variants viz. peek and next. --- --- Also, the "head" fold creates confusion in situations like --- https://github.com/composewell/streamly/issues/1404 where intuitive --- expectation from head is to consume the entire stream and just give us the --- head. There we want to convey the notion that we consume one element from --- the stream and stop. The name "one" already being used in parsers for this --- purpose sounds more apt from this perspective. --- --- The source of confusion is perhaps due to the fact that some folds consume --- the entire stream and others terminate early. It may have been clearer if we --- had separate abstractions for the two use cases. - --- XXX We can possibly use "head" for the purposes of reducing the entire --- stream to the head element i.e. take the head and drain the rest. - --- | Take one element from the stream and stop. --- --- Definition: --- --- >>> one = Fold.maybe Just --- --- This is similar to the stream 'Stream.uncons' operation. --- -{-# INLINE one #-} -one :: Monad m => Fold m a (Maybe a) -one = maybe Just - --- | Extract the first element of the stream, if any. --- --- >>> head = Fold.one --- -{-# DEPRECATED head "Please use \"one\" instead" #-} -{-# INLINE head #-} -head :: Monad m => Fold m a (Maybe a) -head = one - --- | Returns the first element that satisfies the given predicate. --- --- /Pre-release/ -{-# INLINE findM #-} -findM :: Monad m => (a -> m Bool) -> Fold m a (Maybe a) -findM predicate = Fold step (return $ Partial ()) (const $ return Nothing) - - where - - step () a = - let f r = - if r - then Done (Just a) - else Partial () - in f <$> predicate a - --- | Returns the first element that satisfies the given predicate. --- -{-# INLINE find #-} -find :: Monad m => (a -> Bool) -> Fold m a (Maybe a) -find p = findM (return . p) - --- | In a stream of (key-value) pairs @(a, b)@, return the value @b@ of the --- first pair where the key equals the given value @a@. --- --- Definition: --- --- >>> lookup x = fmap snd <$> Fold.find ((== x) . fst) --- -{-# INLINE lookup #-} -lookup :: (Eq a, Monad m) => a -> Fold m (a,b) (Maybe b) -lookup a0 = foldt' step (Partial ()) (const Nothing) - - where - - step () (a, b) = - if a == a0 - then Done $ Just b - else Partial () - --- | Returns the first index that satisfies the given predicate. --- -{-# INLINE findIndex #-} -findIndex :: Monad m => (a -> Bool) -> Fold m a (Maybe Int) -findIndex predicate = foldt' step (Partial 0) (const Nothing) - - where - - step i a = - if predicate a - then Done $ Just i - else Partial (i + 1) - --- | Returns the index of the latest element if the element satisfies the given --- predicate. --- -{-# INLINE findIndices #-} -findIndices :: Monad m => (a -> Bool) -> Fold m a (Maybe Int) -findIndices predicate = - -- XXX implement by combining indexing and filtering scans - fmap (either (const Nothing) Just) $ foldl' step (Left (-1)) - - where - - step i a = - if predicate a - then Right (either id id i + 1) - else Left (either id id i + 1) - --- | Returns the index of the latest element if the element matches the given --- value. --- --- Definition: --- --- >>> elemIndices a = Fold.findIndices (== a) --- -{-# INLINE elemIndices #-} -elemIndices :: (Monad m, Eq a) => a -> Fold m a (Maybe Int) -elemIndices a = findIndices (== a) - --- | Returns the first index where a given value is found in the stream. --- --- Definition: --- --- >>> elemIndex a = Fold.findIndex (== a) --- -{-# INLINE elemIndex #-} -elemIndex :: (Eq a, Monad m) => a -> Fold m a (Maybe Int) -elemIndex a = findIndex (== a) - ------------------------------------------------------------------------------- --- To Boolean ------------------------------------------------------------------------------- - --- Similar to 'eof' parser, but the fold consumes and discards an input element --- when not at eof. XXX Remove or Rename to "eof"? - --- | Consume one element, return 'True' if successful else return 'False'. In --- other words, test if the input is empty or not. --- --- WARNING! It consumes one element if the stream is not empty. If that is not --- what you want please use the eof parser instead. --- --- Definition: --- --- >>> null = fmap isJust Fold.one --- -{-# INLINE null #-} -null :: Monad m => Fold m a Bool -null = foldt' (\() _ -> Done False) (Partial ()) (const True) - --- | Returns 'True' if any element of the input satisfies the predicate. --- --- Definition: --- --- >>> any p = Fold.lmap p Fold.or --- --- Example: --- --- >>> Stream.fold (Fold.any (== 0)) $ Stream.fromList [1,0,1] --- True --- -{-# INLINE any #-} -any :: Monad m => (a -> Bool) -> Fold m a Bool -any predicate = foldt' step initial id - - where - - initial = Partial False - - step _ a = - if predicate a - then Done True - else Partial False - --- | Return 'True' if the given element is present in the stream. --- --- Definition: --- --- >>> elem a = Fold.any (== a) --- -{-# INLINE elem #-} -elem :: (Eq a, Monad m) => a -> Fold m a Bool -elem a = any (== a) - --- | Returns 'True' if all elements of the input satisfy the predicate. --- --- Definition: --- --- >>> all p = Fold.lmap p Fold.and --- --- Example: --- --- >>> Stream.fold (Fold.all (== 0)) $ Stream.fromList [1,0,1] --- False --- -{-# INLINE all #-} -all :: Monad m => (a -> Bool) -> Fold m a Bool -all predicate = foldt' step initial id - - where - - initial = Partial True - - step _ a = - if predicate a - then Partial True - else Done False - --- | Returns 'True' if the given element is not present in the stream. --- --- Definition: --- --- >>> notElem a = Fold.all (/= a) --- -{-# INLINE notElem #-} -notElem :: (Eq a, Monad m) => a -> Fold m a Bool -notElem a = all (/= a) - --- | Returns 'True' if all elements are 'True', 'False' otherwise --- --- Definition: --- --- >>> and = Fold.all (== True) --- -{-# INLINE and #-} -and :: Monad m => Fold m Bool Bool -and = all (== True) - --- | Returns 'True' if any element is 'True', 'False' otherwise --- --- Definition: --- --- >>> or = Fold.any (== True) --- -{-# INLINE or #-} -or :: Monad m => Fold m Bool Bool -or = any (== True) - ------------------------------------------------------------------------------- --- Grouping/Splitting ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Grouping without looking at elements ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Binary APIs ------------------------------------------------------------------------------- - --- | @splitAt n f1 f2@ composes folds @f1@ and @f2@ such that first @n@ --- elements of its input are consumed by fold @f1@ and the rest of the stream --- is consumed by fold @f2@. --- --- >>> let splitAt_ n xs = Stream.fold (Fold.splitAt n Fold.toList Fold.toList) $ Stream.fromList xs --- --- >>> splitAt_ 6 "Hello World!" --- ("Hello ","World!") --- --- >>> splitAt_ (-1) [1,2,3] --- ([],[1,2,3]) --- --- >>> splitAt_ 0 [1,2,3] --- ([],[1,2,3]) --- --- >>> splitAt_ 1 [1,2,3] --- ([1],[2,3]) --- --- >>> splitAt_ 3 [1,2,3] --- ([1,2,3],[]) --- --- >>> splitAt_ 4 [1,2,3] --- ([1,2,3],[]) --- --- > splitAt n f1 f2 = Fold.splitWith (,) (Fold.take n f1) f2 --- --- /Internal/ - -{-# INLINE splitAt #-} -splitAt - :: Monad m - => Int - -> Fold m a b - -> Fold m a c - -> Fold m a (b, c) -splitAt n fld = splitWith (,) (take n fld) - ------------------------------------------------------------------------------- --- Element Aware APIs ------------------------------------------------------------------------------- --- ------------------------------------------------------------------------------- --- Binary APIs ------------------------------------------------------------------------------- - -{-# INLINE takingEndByM #-} -takingEndByM :: Monad m => (a -> m Bool) -> Fold m a (Maybe a) -takingEndByM p = Fold step initial (return . toMaybe) - - where - - initial = return $ Partial Nothing' - - step _ a = do - r <- p a - return - $ if r - then Done $ Just a - else Partial $ Just' a - --- | --- --- >>> takingEndBy p = Fold.takingEndByM (return . p) --- -{-# INLINE takingEndBy #-} -takingEndBy :: Monad m => (a -> Bool) -> Fold m a (Maybe a) -takingEndBy p = takingEndByM (return . p) - -{-# INLINE takingEndByM_ #-} -takingEndByM_ :: Monad m => (a -> m Bool) -> Fold m a (Maybe a) -takingEndByM_ p = Fold step initial (return . toMaybe) - - where - - initial = return $ Partial Nothing' - - step _ a = do - r <- p a - return - $ if r - then Done Nothing - else Partial $ Just' a - --- | --- --- >>> takingEndBy_ p = Fold.takingEndByM_ (return . p) --- -{-# INLINE takingEndBy_ #-} -takingEndBy_ :: Monad m => (a -> Bool) -> Fold m a (Maybe a) -takingEndBy_ p = takingEndByM_ (return . p) - -{-# INLINE droppingWhileM #-} -droppingWhileM :: Monad m => (a -> m Bool) -> Fold m a (Maybe a) -droppingWhileM p = Fold step initial (return . toMaybe) - - where - - initial = return $ Partial Nothing' - - step Nothing' a = do - r <- p a - return - $ Partial - $ if r - then Nothing' - else Just' a - step _ a = return $ Partial $ Just' a - --- | --- >>> droppingWhile p = Fold.droppingWhileM (return . p) --- -{-# INLINE droppingWhile #-} -droppingWhile :: Monad m => (a -> Bool) -> Fold m a (Maybe a) -droppingWhile p = droppingWhileM (return . p) - --- Note: Keep this consistent with S.splitOn. In fact we should eliminate --- S.splitOn in favor of the fold. --- --- XXX Use Fold.many instead once it is fixed. --- > Stream.splitOnSuffix p f = Stream.foldMany (Fold.takeEndBy_ p f) - --- | Like 'takeEndBy' but drops the element on which the predicate succeeds. --- --- Example: --- --- >>> input = Stream.fromList "hello\nthere\n" --- >>> line = Fold.takeEndBy_ (== '\n') Fold.toList --- >>> Stream.fold line input --- "hello" --- --- >>> Stream.fold Fold.toList $ Stream.foldMany line input --- ["hello","there"] --- -{-# INLINE takeEndBy_ #-} -takeEndBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b --- takeEndBy_ predicate = scanMaybe (takingEndBy_ predicate) -takeEndBy_ predicate (Fold fstep finitial fextract) = - Fold step finitial fextract - - where - - step s a = - if not (predicate a) - then fstep s a - else Done <$> fextract s - --- Note: --- > Stream.splitWithSuffix p f = Stream.foldMany (Fold.takeEndBy p f) - --- | Take the input, stop when the predicate succeeds taking the succeeding --- element as well. --- --- Example: --- --- >>> input = Stream.fromList "hello\nthere\n" --- >>> line = Fold.takeEndBy (== '\n') Fold.toList --- >>> Stream.fold line input --- "hello\n" --- --- >>> Stream.fold Fold.toList $ Stream.foldMany line input --- ["hello\n","there\n"] --- -{-# INLINE takeEndBy #-} -takeEndBy :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b --- takeEndBy predicate = scanMaybe (takingEndBy predicate) -takeEndBy predicate (Fold fstep finitial fextract) = - Fold step finitial fextract - - where - - step s a = do - res <- fstep s a - if not (predicate a) - then return res - else do - case res of - Partial s1 -> Done <$> fextract s1 - Done b -> return $ Done b - ------------------------------------------------------------------------------- --- Binary splitting on a separator ------------------------------------------------------------------------------- - -data SplitOnSeqState acc a rb rh w ck = - SplitOnSeqEmpty !acc - | SplitOnSeqSingle !acc !a - | SplitOnSeqWord !acc !Int !w - | SplitOnSeqWordLoop !acc !w - | SplitOnSeqKR !acc !Int !rb !rh - | SplitOnSeqKRLoop !acc !ck !rb !rh - --- XXX Need to add tests for takeEndBySeq, we have tests for takeEndBySeq_ . - --- | Continue taking the input until the input sequence matches the supplied --- sequence, taking the supplied sequence as well. If the pattern is empty this --- acts as an identity fold. --- --- >>> s = Stream.fromList "hello there. How are you?" --- >>> f = Fold.takeEndBySeq (Array.fromList "re") Fold.toList --- >>> Stream.fold f s --- "hello there" --- --- >>> Stream.fold Fold.toList $ Stream.foldMany f s --- ["hello there",". How are"," you?"] --- --- /Pre-release/ -{-# INLINE takeEndBySeq #-} -takeEndBySeq :: forall m a b. (MonadIO m, Storable a, Unbox a, Enum a, Eq a) => - Array.Array a - -> Fold m a b - -> Fold m a b -takeEndBySeq patArr (Fold fstep finitial fextract) = - Fold step initial extract - - where - - patLen = Array.length patArr - - initial = do - res <- finitial - case res of - Partial acc - | patLen == 0 -> - -- XXX Should we match nothing or everything on empty - -- pattern? - -- Done <$> fextract acc - return $ Partial $ SplitOnSeqEmpty acc - | patLen == 1 -> do - pat <- liftIO $ Array.unsafeIndexIO 0 patArr - return $ Partial $ SplitOnSeqSingle acc pat - | SIZE_OF(a) * patLen <= sizeOf (Proxy :: Proxy Word) -> - return $ Partial $ SplitOnSeqWord acc 0 0 - | otherwise -> do - (rb, rhead) <- liftIO $ Ring.new patLen - return $ Partial $ SplitOnSeqKR acc 0 rb rhead - Done b -> return $ Done b - - -- Word pattern related - maxIndex = patLen - 1 - - elemBits = SIZE_OF(a) * 8 - - wordMask :: Word - wordMask = (1 `shiftL` (elemBits * patLen)) - 1 - - wordPat :: Word - wordPat = wordMask .&. Array.foldl' addToWord 0 patArr - - addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) - - -- For Rabin-Karp search - k = 2891336453 :: Word32 - coeff = k ^ patLen - - addCksum cksum a = cksum * k + fromIntegral (fromEnum a) - - deltaCksum cksum old new = - addCksum cksum new - coeff * fromIntegral (fromEnum old) - - -- XXX shall we use a random starting hash or 1 instead of 0? - -- XXX Need to keep this cached across fold calls in foldmany - -- XXX We may need refold to inject the cached state instead of - -- initializing the state every time. - -- XXX Allocation of ring buffer should also be done once - patHash = Array.foldl' addCksum 0 patArr - - step (SplitOnSeqEmpty s) x = do - res <- fstep s x - case res of - Partial s1 -> return $ Partial $ SplitOnSeqEmpty s1 - Done b -> return $ Done b - step (SplitOnSeqSingle s pat) x = do - res <- fstep s x - case res of - Partial s1 - | pat /= x -> return $ Partial $ SplitOnSeqSingle s1 pat - | otherwise -> Done <$> fextract s1 - Done b -> return $ Done b - step (SplitOnSeqWord s idx wrd) x = do - res <- fstep s x - let wrd1 = addToWord wrd x - case res of - Partial s1 - | idx == maxIndex -> do - if wrd1 .&. wordMask == wordPat - then Done <$> fextract s1 - else return $ Partial $ SplitOnSeqWordLoop s1 wrd1 - | otherwise -> - return $ Partial $ SplitOnSeqWord s1 (idx + 1) wrd1 - Done b -> return $ Done b - step (SplitOnSeqWordLoop s wrd) x = do - res <- fstep s x - let wrd1 = addToWord wrd x - case res of - Partial s1 - | wrd1 .&. wordMask == wordPat -> - Done <$> fextract s1 - | otherwise -> - return $ Partial $ SplitOnSeqWordLoop s1 wrd1 - Done b -> return $ Done b - step (SplitOnSeqKR s idx rb rh) x = do - res <- fstep s x - case res of - Partial s1 -> do - rh1 <- liftIO $ Ring.unsafeInsert rb rh x - if idx == maxIndex - then do - let fld = Ring.unsafeFoldRing (Ring.ringBound rb) - let !ringHash = fld addCksum 0 rb - if ringHash == patHash && Ring.unsafeEqArray rb rh1 patArr - then Done <$> fextract s1 - else return $ Partial $ SplitOnSeqKRLoop s1 ringHash rb rh1 - else - return $ Partial $ SplitOnSeqKR s1 (idx + 1) rb rh1 - Done b -> return $ Done b - step (SplitOnSeqKRLoop s cksum rb rh) x = do - res <- fstep s x - case res of - Partial s1 -> do - old <- liftIO $ peek rh - rh1 <- liftIO $ Ring.unsafeInsert rb rh x - let ringHash = deltaCksum cksum old x - if ringHash == patHash && Ring.unsafeEqArray rb rh1 patArr - then Done <$> fextract s1 - else return $ Partial $ SplitOnSeqKRLoop s1 ringHash rb rh1 - Done b -> return $ Done b - - extract state = - let st = - case state of - SplitOnSeqEmpty s -> s - SplitOnSeqSingle s _ -> s - SplitOnSeqWord s _ _ -> s - SplitOnSeqWordLoop s _ -> s - SplitOnSeqKR s _ _ _ -> s - SplitOnSeqKRLoop s _ _ _ -> s - in fextract st - --- | Like 'takeEndBySeq' but discards the matched sequence. --- --- /Pre-release/ --- -{-# INLINE takeEndBySeq_ #-} -takeEndBySeq_ :: forall m a b. (MonadIO m, Storable a, Unbox a, Enum a, Eq a) => - Array.Array a - -> Fold m a b - -> Fold m a b -takeEndBySeq_ patArr (Fold fstep finitial fextract) = - Fold step initial extract - - where - - patLen = Array.length patArr - - initial = do - res <- finitial - case res of - Partial acc - | patLen == 0 -> - -- XXX Should we match nothing or everything on empty - -- pattern? - -- Done <$> fextract acc - return $ Partial $ SplitOnSeqEmpty acc - | patLen == 1 -> do - pat <- liftIO $ Array.unsafeIndexIO 0 patArr - return $ Partial $ SplitOnSeqSingle acc pat - -- XXX Need to add tests for this case - | SIZE_OF(a) * patLen <= sizeOf (Proxy :: Proxy Word) -> - return $ Partial $ SplitOnSeqWord acc 0 0 - | otherwise -> do - (rb, rhead) <- liftIO $ Ring.new patLen - return $ Partial $ SplitOnSeqKR acc 0 rb rhead - Done b -> return $ Done b - - -- Word pattern related - maxIndex = patLen - 1 - - elemBits = SIZE_OF(a) * 8 - - wordMask :: Word - wordMask = (1 `shiftL` (elemBits * patLen)) - 1 - - elemMask :: Word - elemMask = (1 `shiftL` elemBits) - 1 - - wordPat :: Word - wordPat = wordMask .&. Array.foldl' addToWord 0 patArr - - addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) - - -- For Rabin-Karp search - k = 2891336453 :: Word32 - coeff = k ^ patLen - - addCksum cksum a = cksum * k + fromIntegral (fromEnum a) - - deltaCksum cksum old new = - addCksum cksum new - coeff * fromIntegral (fromEnum old) - - -- XXX shall we use a random starting hash or 1 instead of 0? - -- XXX Need to keep this cached across fold calls in foldMany - -- XXX We may need refold to inject the cached state instead of - -- initializing the state every time. - -- XXX Allocation of ring buffer should also be done once - patHash = Array.foldl' addCksum 0 patArr - - step (SplitOnSeqEmpty s) x = do - res <- fstep s x - case res of - Partial s1 -> return $ Partial $ SplitOnSeqEmpty s1 - Done b -> return $ Done b - step (SplitOnSeqSingle s pat) x = do - if pat /= x - then do - res <- fstep s x - case res of - Partial s1 -> return $ Partial $ SplitOnSeqSingle s1 pat - Done b -> return $ Done b - else Done <$> fextract s - step (SplitOnSeqWord s idx wrd) x = do - let wrd1 = addToWord wrd x - if idx == maxIndex - then do - if wrd1 .&. wordMask == wordPat - then Done <$> fextract s - else return $ Partial $ SplitOnSeqWordLoop s wrd1 - else return $ Partial $ SplitOnSeqWord s (idx + 1) wrd1 - step (SplitOnSeqWordLoop s wrd) x = do - let wrd1 = addToWord wrd x - old = (wordMask .&. wrd) - `shiftR` (elemBits * (patLen - 1)) - res <- fstep s (toEnum $ fromIntegral old) - case res of - Partial s1 - | wrd1 .&. wordMask == wordPat -> - Done <$> fextract s1 - | otherwise -> - return $ Partial $ SplitOnSeqWordLoop s1 wrd1 - Done b -> return $ Done b - step (SplitOnSeqKR s idx rb rh) x = do - rh1 <- liftIO $ Ring.unsafeInsert rb rh x - if idx == maxIndex - then do - let fld = Ring.unsafeFoldRing (Ring.ringBound rb) - let !ringHash = fld addCksum 0 rb - if ringHash == patHash && Ring.unsafeEqArray rb rh1 patArr - then Done <$> fextract s - else return $ Partial $ SplitOnSeqKRLoop s ringHash rb rh1 - else return $ Partial $ SplitOnSeqKR s (idx + 1) rb rh1 - step (SplitOnSeqKRLoop s cksum rb rh) x = do - old <- liftIO $ peek rh - res <- fstep s old - case res of - Partial s1 -> do - rh1 <- liftIO $ Ring.unsafeInsert rb rh x - let ringHash = deltaCksum cksum old x - if ringHash == patHash && Ring.unsafeEqArray rb rh1 patArr - then Done <$> fextract s1 - else return $ Partial $ SplitOnSeqKRLoop s1 ringHash rb rh1 - Done b -> return $ Done b - - -- XXX extract should return backtrack count as well. If the fold - -- terminates early inside extract, we may still have buffered data - -- remaining which will be lost if we do not communicate that to the - -- driver. - extract state = do - let consumeWord s n wrd = do - if n == 0 - then fextract s - else do - let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1))) - r <- fstep s (toEnum $ fromIntegral old) - case r of - Partial s1 -> consumeWord s1 (n - 1) wrd - Done b -> return b - - let consumeRing s n rb rh = - if n == 0 - then fextract s - else do - old <- liftIO $ peek rh - let rh1 = Ring.advance rb rh - r <- fstep s old - case r of - Partial s1 -> consumeRing s1 (n - 1) rb rh1 - Done b -> return b - - case state of - SplitOnSeqEmpty s -> fextract s - SplitOnSeqSingle s _ -> fextract s - SplitOnSeqWord s idx wrd -> consumeWord s idx wrd - SplitOnSeqWordLoop s wrd -> consumeWord s patLen wrd - SplitOnSeqKR s idx rb _ -> consumeRing s idx rb (Ring.startOf rb) - SplitOnSeqKRLoop s _ rb rh -> consumeRing s patLen rb rh - ------------------------------------------------------------------------------- --- Distributing ------------------------------------------------------------------------------- --- --- | Distribute one copy of the stream to each fold and zip the results. --- --- @ --- |-------Fold m a b--------| --- ---stream m a---| |---m (b,c) --- |-------Fold m a c--------| --- @ --- --- Definition: --- --- >>> tee = Fold.teeWith (,) --- --- Example: --- --- >>> t = Fold.tee Fold.sum Fold.length --- >>> Stream.fold t (Stream.enumerateFromTo 1.0 100.0) --- (5050.0,100) --- -{-# INLINE tee #-} -tee :: Monad m => Fold m a b -> Fold m a c -> Fold m a (b,c) -tee = teeWith (,) - --- XXX use "List" instead of "[]"?, use Array for output to scale it to a large --- number of consumers? For polymorphic case a vector could be helpful. For --- Storables we can use arrays. Will need separate APIs for those. --- --- | Distribute one copy of the stream to each fold and collect the results in --- a container. --- --- @ --- --- |-------Fold m a b--------| --- ---stream m a---| |---m [b] --- |-------Fold m a b--------| --- | | --- ... --- @ --- --- >>> Stream.fold (Fold.distribute [Fold.sum, Fold.length]) (Stream.enumerateFromTo 1 5) --- [15,5] --- --- >>> distribute = Prelude.foldr (Fold.teeWith (:)) (Fold.fromPure []) --- --- This is the consumer side dual of the producer side 'sequence' operation. --- --- Stops when all the folds stop. --- -{-# INLINE distribute #-} -distribute :: Monad m => [Fold m a b] -> Fold m a [b] -distribute = Prelude.foldr (teeWith (:)) (fromPure []) - ------------------------------------------------------------------------------- --- Partitioning ------------------------------------------------------------------------------- - -{-# INLINE partitionByMUsing #-} -partitionByMUsing :: Monad m => - ( (x -> y -> (x, y)) - -> Fold m (Either b c) x - -> Fold m (Either b c) y - -> Fold m (Either b c) (x, y) - ) - -> (a -> m (Either b c)) - -> Fold m b x - -> Fold m c y - -> Fold m a (x, y) -partitionByMUsing t f fld1 fld2 = - let l = lmap (fromLeft undefined) fld1 -- :: Fold m (Either b c) x - r = lmap (fromRight undefined) fld2 -- :: Fold m (Either b c) y - in lmapM f (t (,) (filter isLeft l) (filter isRight r)) - --- | Partition the input over two folds using an 'Either' partitioning --- predicate. --- --- @ --- --- |-------Fold b x--------| --- -----stream m a --> (Either b c)----| |----(x,y) --- |-------Fold c y--------| --- @ --- --- Example, send input to either fold randomly: --- --- >>> :set -package random --- >>> import System.Random (randomIO) --- >>> randomly a = randomIO >>= \x -> return $ if x then Left a else Right a --- >>> f = Fold.partitionByM randomly Fold.length Fold.length --- >>> Stream.fold f (Stream.enumerateFromTo 1 100) --- ... --- --- Example, send input to the two folds in a proportion of 2:1: --- --- >>> :{ --- proportionately m n = do --- ref <- newIORef $ cycle $ concat [replicate m Left, replicate n Right] --- return $ \a -> do --- r <- readIORef ref --- writeIORef ref $ tail r --- return $ Prelude.head r a --- :} --- --- >>> :{ --- main = do --- g <- proportionately 2 1 --- let f = Fold.partitionByM g Fold.length Fold.length --- r <- Stream.fold f (Stream.enumerateFromTo (1 :: Int) 100) --- print r --- :} --- --- >>> main --- (67,33) --- --- --- This is the consumer side dual of the producer side 'mergeBy' operation. --- --- When one fold is done, any input meant for it is ignored until the other --- fold is also done. --- --- Stops when both the folds stop. --- --- /See also: 'partitionByFstM' and 'partitionByMinM'./ --- --- /Pre-release/ -{-# INLINE partitionByM #-} -partitionByM :: Monad m - => (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y) -partitionByM = partitionByMUsing teeWith - --- | Similar to 'partitionByM' but terminates when the first fold terminates. --- -{-# INLINE partitionByFstM #-} -partitionByFstM :: Monad m - => (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y) -partitionByFstM = partitionByMUsing teeWithFst - --- | Similar to 'partitionByM' but terminates when any fold terminates. --- -{-# INLINE partitionByMinM #-} -partitionByMinM :: Monad m => - (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y) -partitionByMinM = partitionByMUsing teeWithMin - --- Note: we could use (a -> Bool) instead of (a -> Either b c), but the latter --- makes the signature clearer as to which case belongs to which fold. --- XXX need to check the performance in both cases. - --- | Same as 'partitionByM' but with a pure partition function. --- --- Example, count even and odd numbers in a stream: --- --- >>> :{ --- let f = Fold.partitionBy (\n -> if even n then Left n else Right n) --- (fmap (("Even " ++) . show) Fold.length) --- (fmap (("Odd " ++) . show) Fold.length) --- in Stream.fold f (Stream.enumerateFromTo 1 100) --- :} --- ("Even 50","Odd 50") --- --- /Pre-release/ -{-# INLINE partitionBy #-} -partitionBy :: Monad m - => (a -> Either b c) -> Fold m b x -> Fold m c y -> Fold m a (x, y) -partitionBy f = partitionByM (return . f) - --- | Compose two folds such that the combined fold accepts a stream of 'Either' --- and routes the 'Left' values to the first fold and 'Right' values to the --- second fold. --- --- Definition: --- --- >>> partition = Fold.partitionBy id --- -{-# INLINE partition #-} -partition :: Monad m - => Fold m b x -> Fold m c y -> Fold m (Either b c) (x, y) -partition = partitionBy id - -{- --- | Send one item to each fold in a round-robin fashion. This is the consumer --- side dual of producer side 'mergeN' operation. --- --- partitionN :: Monad m => [Fold m a b] -> Fold m a [b] --- partitionN fs = Fold step begin done --} - ------------------------------------------------------------------------------- --- Unzipping ------------------------------------------------------------------------------- - -{-# INLINE unzipWithMUsing #-} -unzipWithMUsing :: Monad m => - ( (x -> y -> (x, y)) - -> Fold m (b, c) x - -> Fold m (b, c) y - -> Fold m (b, c) (x, y) - ) - -> (a -> m (b, c)) - -> Fold m b x - -> Fold m c y - -> Fold m a (x, y) -unzipWithMUsing t f fld1 fld2 = - let f1 = lmap fst fld1 -- :: Fold m (b, c) b - f2 = lmap snd fld2 -- :: Fold m (b, c) c - in lmapM f (t (,) f1 f2) - --- | Like 'unzipWith' but with a monadic splitter function. --- --- Definition: --- --- >>> unzipWithM k f1 f2 = Fold.lmapM k (Fold.unzip f1 f2) --- --- /Pre-release/ -{-# INLINE unzipWithM #-} -unzipWithM :: Monad m - => (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y) -unzipWithM = unzipWithMUsing teeWith - --- | Similar to 'unzipWithM' but terminates when the first fold terminates. --- -{-# INLINE unzipWithFstM #-} -unzipWithFstM :: Monad m => - (a -> m (b, c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y) -unzipWithFstM = unzipWithMUsing teeWithFst - --- | Similar to 'unzipWithM' but terminates when any fold terminates. --- -{-# INLINE unzipWithMinM #-} -unzipWithMinM :: Monad m => - (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y) -unzipWithMinM = unzipWithMUsing teeWithMin - --- | Split elements in the input stream into two parts using a pure splitter --- function, direct each part to a different fold and zip the results. --- --- Definitions: --- --- >>> unzipWith f = Fold.unzipWithM (return . f) --- >>> unzipWith f fld1 fld2 = Fold.lmap f (Fold.unzip fld1 fld2) --- --- This fold terminates when both the input folds terminate. --- --- /Pre-release/ -{-# INLINE unzipWith #-} -unzipWith :: Monad m - => (a -> (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y) -unzipWith f = unzipWithM (return . f) - --- | Send the elements of tuples in a stream of tuples through two different --- folds. --- --- @ --- --- |-------Fold m a x--------| --- ---------stream of (a,b)--| |----m (x,y) --- |-------Fold m b y--------| --- --- @ --- --- Definition: --- --- >>> unzip = Fold.unzipWith id --- --- This is the consumer side dual of the producer side 'zip' operation. --- -{-# INLINE unzip #-} -unzip :: Monad m => Fold m a x -> Fold m b y -> Fold m (a,b) (x,y) -unzip = unzipWith id - ------------------------------------------------------------------------------- --- Combining streams and folds - Zipping ------------------------------------------------------------------------------- - --- XXX These can be implemented using the fold scan, using the stream as a --- state. --- XXX Stream Skip state cannot be efficiently handled in folds but can be --- handled in parsers using the Continue facility. See zipWithM in the Parser --- module. --- --- cmpBy, eqBy, isPrefixOf, isSubsequenceOf etc can be implemented using --- zipStream. - --- | Zip a stream with the input of a fold using the supplied function. --- --- /Unimplemented/ --- -{-# INLINE zipStreamWithM #-} -zipStreamWithM :: -- Monad m => - (a -> b -> m c) -> Stream m a -> Fold m c x -> Fold m b x -zipStreamWithM = undefined - --- | Zip a stream with the input of a fold. --- --- >>> zip = Fold.zipStreamWithM (curry return) --- --- /Unimplemented/ --- -{-# INLINE zipStream #-} -zipStream :: Monad m => Stream m a -> Fold m (a, b) x -> Fold m b x -zipStream = zipStreamWithM (curry return) - --- | Pair each element of a fold input with its index, starting from index 0. --- -{-# INLINE indexingWith #-} -indexingWith :: Monad m => Int -> (Int -> Int) -> Fold m a (Maybe (Int, a)) -indexingWith i f = fmap toMaybe $ foldl' step initial - - where - - initial = Nothing' - - step Nothing' a = Just' (i, a) - step (Just' (n, _)) a = Just' (f n, a) - --- | --- >>> indexing = Fold.indexingWith 0 (+ 1) --- -{-# INLINE indexing #-} -indexing :: Monad m => Fold m a (Maybe (Int, a)) -indexing = indexingWith 0 (+ 1) - --- | --- >>> indexingRev n = Fold.indexingWith n (subtract 1) --- -{-# INLINE indexingRev #-} -indexingRev :: Monad m => Int -> Fold m a (Maybe (Int, a)) -indexingRev n = indexingWith n (subtract 1) - --- | Pair each element of a fold input with its index, starting from index 0. --- --- >>> indexed = Fold.scanMaybe Fold.indexing --- -{-# INLINE indexed #-} -indexed :: Monad m => Fold m (Int, a) b -> Fold m a b -indexed = scanMaybe indexing - --- | Change the predicate function of a Fold from @a -> b@ to accept an --- additional state input @(s, a) -> b@. Convenient to filter with an --- addiitonal index or time input. --- --- >>> filterWithIndex = Fold.with Fold.indexed Fold.filter --- --- @ --- filterWithAbsTime = with timestamped filter --- filterWithRelTime = with timeIndexed filter --- @ --- --- /Pre-release/ -{-# INLINE with #-} -with :: - (Fold m (s, a) b -> Fold m a b) - -> (((s, a) -> c) -> Fold m (s, a) b -> Fold m (s, a) b) - -> (((s, a) -> c) -> Fold m a b -> Fold m a b) -with f comb g = f . comb g . lmap snd - --- XXX Implement as a filter --- sampleFromthen :: Monad m => Int -> Int -> Fold m a (Maybe a) - --- | @sampleFromthen offset stride@ samples the element at @offset@ index and --- then every element at strides of @stride@. --- -{-# INLINE sampleFromthen #-} -sampleFromthen :: Monad m => Int -> Int -> Fold m a b -> Fold m a b -sampleFromthen offset size = - with indexed filter (\(i, _) -> (i + offset) `mod` size == 0) - ------------------------------------------------------------------------------- --- Nesting ------------------------------------------------------------------------------- - --- | @concatSequence f t@ applies folds from stream @t@ sequentially and --- collects the results using the fold @f@. --- --- /Unimplemented/ --- -{-# INLINE concatSequence #-} -concatSequence :: - -- IsStream t => - Fold m b c -> t (Fold m a b) -> Fold m a c -concatSequence _f _p = undefined - --- | Group the input stream into groups of elements between @low@ and @high@. --- Collection starts in chunks of @low@ and then keeps doubling until we reach --- @high@. Each chunk is folded using the provided fold function. --- --- This could be useful, for example, when we are folding a stream of unknown --- size to a stream of arrays and we want to minimize the number of --- allocations. --- --- NOTE: this would be an application of "many" using a terminating fold. --- --- /Unimplemented/ --- -{-# INLINE chunksBetween #-} -chunksBetween :: -- Monad m => - Int -> Int -> Fold m a b -> Fold m b c -> Fold m a c -chunksBetween _low _high _f1 _f2 = undefined - --- | A fold that buffers its input to a pure stream. --- --- /Warning!/ working on large streams accumulated as buffers in memory could --- be very inefficient, consider using "Streamly.Data.Array" instead. --- --- >>> toStream = fmap Stream.fromList Fold.toList --- --- /Pre-release/ -{-# INLINE toStream #-} -toStream :: (Monad m, Monad n) => Fold m a (Stream n a) -toStream = fmap StreamD.fromList toList - --- This is more efficient than 'toStream'. toStream is exactly the same as --- reversing the stream after toStreamRev. --- --- | Buffers the input stream to a pure stream in the reverse order of the --- input. --- --- >>> toStreamRev = fmap Stream.fromList Fold.toListRev --- --- /Warning!/ working on large streams accumulated as buffers in memory could --- be very inefficient, consider using "Streamly.Data.Array" instead. --- --- /Pre-release/ - --- xn : ... : x2 : x1 : [] -{-# INLINE toStreamRev #-} -toStreamRev :: (Monad m, Monad n) => Fold m a (Stream n a) -toStreamRev = fmap StreamD.fromList toListRev - --- XXX This does not fuse. It contains a recursive step function. We will need --- a Skip input constructor in the fold type to make it fuse. --- --- | Unfold and flatten the input stream of a fold. --- --- @ --- Stream.fold (unfoldMany u f) = Stream.fold f . Stream.unfoldMany u --- @ --- --- /Pre-release/ -{-# INLINE unfoldMany #-} -unfoldMany :: Monad m => Unfold m a b -> Fold m b c -> Fold m a c -unfoldMany (Unfold ustep inject) (Fold fstep initial extract) = - Fold consume initial extract - - where - - {-# INLINE produce #-} - produce fs us = do - ures <- ustep us - case ures of - StreamD.Yield b us1 -> do - fres <- fstep fs b - case fres of - Partial fs1 -> produce fs1 us1 - -- XXX What to do with the remaining stream? - Done c -> return $ Done c - StreamD.Skip us1 -> produce fs us1 - StreamD.Stop -> return $ Partial fs - - {-# INLINE_LATE consume #-} - consume s a = inject a >>= produce s - --- | Get the bottom most @n@ elements using the supplied comparison function. --- -{-# INLINE bottomBy #-} -bottomBy :: (MonadIO m, Unbox a) => - (a -> a -> Ordering) - -> Int - -> Fold m a (MutArray a) -bottomBy cmp n = Fold step initial extract - - where - - initial = do - arr <- MA.newPinned n - if n <= 0 - then return $ Done arr - else return $ Partial (arr, 0) - - step (arr, i) x = - if i < n - then do - arr' <- MA.snoc arr x - MA.bubble cmp arr' - return $ Partial (arr', i + 1) - else do - x1 <- MA.getIndexUnsafe (i - 1) arr - case x `cmp` x1 of - LT -> do - MA.putIndexUnsafe (i - 1) arr x - MA.bubble cmp arr - return $ Partial (arr, i) - _ -> return $ Partial (arr, i) - - extract = return . fst - --- | Get the top @n@ elements using the supplied comparison function. --- --- To get bottom n elements instead: --- --- >>> bottomBy cmp = Fold.topBy (flip cmp) --- --- Example: --- --- >>> stream = Stream.fromList [2::Int,7,9,3,1,5,6,11,17] --- >>> Stream.fold (Fold.topBy compare 3) stream >>= MutArray.toList --- [17,11,9] --- --- /Pre-release/ --- -{-# INLINE topBy #-} -topBy :: (MonadIO m, Unbox a) => - (a -> a -> Ordering) - -> Int - -> Fold m a (MutArray a) -topBy cmp = bottomBy (flip cmp) - --- | Fold the input stream to top n elements. --- --- Definition: --- --- >>> top = Fold.topBy compare --- --- >>> stream = Stream.fromList [2::Int,7,9,3,1,5,6,11,17] --- >>> Stream.fold (Fold.top 3) stream >>= MutArray.toList --- [17,11,9] --- --- /Pre-release/ -{-# INLINE top #-} -top :: (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (MutArray a) -top = bottomBy $ flip compare - --- | Fold the input stream to bottom n elements. --- --- Definition: --- --- >>> bottom = Fold.bottomBy compare --- --- >>> stream = Stream.fromList [2::Int,7,9,3,1,5,6,11,17] --- >>> Stream.fold (Fold.bottom 3) stream >>= MutArray.toList --- [1,2,3] --- --- /Pre-release/ -{-# INLINE bottom #-} -bottom :: (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (MutArray a) -bottom = bottomBy compare - ------------------------------------------------------------------------------- --- Interspersed parsing ------------------------------------------------------------------------------- - -data IntersperseQState fs ps = - IntersperseQUnquoted !fs !ps - | IntersperseQQuoted !fs !ps - | IntersperseQQuotedEsc !fs !ps - --- Useful for parsing CSV with quoting and escaping -{-# INLINE intersperseWithQuotes #-} -intersperseWithQuotes :: (Monad m, Eq a) => - a -> a -> a -> Fold m a b -> Fold m b c -> Fold m a c -intersperseWithQuotes - quote - esc - separator - (Fold stepL initialL extractL) - (Fold stepR initialR extractR) = Fold step initial extract - - where - - errMsg p status = - error $ "intersperseWithQuotes: " ++ p ++ " parsing fold cannot " - ++ status ++ " without input" - - {-# INLINE initL #-} - initL mkState = do - resL <- initialL - case resL of - Partial sL -> - return $ Partial $ mkState sL - Done _ -> - errMsg "content" "succeed" - - initial = do - res <- initialR - case res of - Partial sR -> initL (IntersperseQUnquoted sR) - Done b -> return $ Done b - - {-# INLINE collect #-} - collect nextS sR b = do - res <- stepR sR b - case res of - Partial s -> - initL (nextS s) - Done c -> return (Done c) - - {-# INLINE process #-} - process a sL sR nextState = do - r <- stepL sL a - case r of - Partial s -> return $ Partial (nextState sR s) - Done b -> collect nextState sR b - - {-# INLINE processQuoted #-} - processQuoted a sL sR nextState = do - r <- stepL sL a - case r of - Partial s -> return $ Partial (nextState sR s) - Done _ -> error "Collecting fold finished inside quote" - - step (IntersperseQUnquoted sR sL) a - | a == separator = do - b <- extractL sL - collect IntersperseQUnquoted sR b - | a == quote = processQuoted a sL sR IntersperseQQuoted - | otherwise = process a sL sR IntersperseQUnquoted - - step (IntersperseQQuoted sR sL) a - | a == esc = processQuoted a sL sR IntersperseQQuotedEsc - | a == quote = process a sL sR IntersperseQUnquoted - | otherwise = processQuoted a sL sR IntersperseQQuoted - - step (IntersperseQQuotedEsc sR sL) a = - processQuoted a sL sR IntersperseQQuoted - - extract (IntersperseQUnquoted sR _) = extractR sR - extract (IntersperseQQuoted _ _) = - error "intersperseWithQuotes: finished inside quote" - extract (IntersperseQQuotedEsc _ _) = - error "intersperseWithQuotes: finished inside quote, at escape char" +{-# OPTIONS_GHC -Wno-deprecations #-} +-- | +-- Module : Streamly.Internal.Data.Fold +-- Copyright : (c) 2019 Composewell Technologies +-- (c) 2013 Gabriel Gonzalez +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- See "Streamly.Data.Fold" for an overview and +-- "Streamly.Internal.Data.Fold.Type" for design notes. + +module Streamly.Internal.Data.Fold + ( + -- * Imports + -- $setup + + module Streamly.Internal.Data.Fold.Type + , module Streamly.Internal.Data.Fold.Tee + , module Streamly.Internal.Data.Fold.Combinators + , module Streamly.Internal.Data.Fold.Container + , module Streamly.Internal.Data.Fold.Window + , module Streamly.Internal.Data.Fold.Exception + ) +where + +import Streamly.Internal.Data.Fold.Combinators +import Streamly.Internal.Data.Fold.Container +import Streamly.Internal.Data.Fold.Exception +import Streamly.Internal.Data.Fold.Tee +import Streamly.Internal.Data.Fold.Type +import Streamly.Internal.Data.Fold.Window + +#include "DocTestDataFold.hs" diff --git a/src/Streamly/Internal/Data/Fold/Chunked.hs b/src/Streamly/Internal/Data/Fold/Chunked.hs --- a/src/Streamly/Internal/Data/Fold/Chunked.hs +++ b/src/Streamly/Internal/Data/Fold/Chunked.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + -- | -- Module : Streamly.Internal.Data.Fold.Chunked -- Copyright : (c) 2021 Composewell Technologies @@ -6,7 +9,7 @@ -- Stability : experimental -- Portability : GHC -- --- Use "Streamly.Data.Parser.Chunked" instead. +-- Use "Streamly.Data.Parser" instead. -- -- Fold a stream of foreign arrays. @Fold m a b@ in this module works -- on a stream of "Array a" and produces an output of type @b@. @@ -19,18 +22,19 @@ -- folds in Data.Fold to correctly work on an array stream as if it is an -- element stream. For example: -- --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Internal.Data.Stream.Chunked as ArrayStream --- >>> import qualified Streamly.Internal.Data.Fold.Chunked as ChunkFold --- >>> import qualified Streamly.Data.Stream as Stream --- >>> import qualified Streamly.Data.StreamK as StreamK +-- >> import qualified Streamly.Data.Fold as Fold +-- >> import qualified Streamly.Internal.Data.Array.Stream as ArrayStream +-- >> import qualified Streamly.Internal.Data.Fold.Chunked as ChunkFold +-- >> import qualified Streamly.Data.Stream as Stream +-- >> import qualified Streamly.Data.StreamK as StreamK -- --- >>> f = ChunkFold.fromFold (Fold.take 7 Fold.toList) --- >>> s = Stream.chunksOf 5 $ Stream.fromList "hello world" --- >>> ArrayStream.runArrayFold f (StreamK.fromStream s) +-- >> f = ChunkFold.fromFold (Fold.take 7 Fold.toList) +-- >> s = Array.chunksOf 5 $ Stream.fromList "hello world" +-- >> ArrayStream.runArrayFold f (StreamK.fromStream s) -- Right "hello w" -- module Streamly.Internal.Data.Fold.Chunked + {-# DEPRECATED "Please use Streamly.Data.Parser instead." #-} ( ChunkFold (..) @@ -58,22 +62,22 @@ #include "ArrayMacros.h" +#if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) +#endif import Control.Exception (assert) import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (first) import Data.Proxy (Proxy(..)) -import Streamly.Internal.Data.Unboxed (peekWith, sizeOf, Unbox) +import Streamly.Internal.Data.Unbox (Unbox(..)) import GHC.Types (SPEC(..)) -import Streamly.Internal.Data.Array.Mut.Type (touch) -import Streamly.Internal.Data.Array.Type (Array(..)) -import Streamly.Internal.Data.Parser.ParserD (Initial(..), Step(..)) +import Streamly.Internal.Data.Array (Array(..)) +import Streamly.Internal.Data.Parser (Initial(..), Step(..), Final(..)) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.Array.Type as Array import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Parser.ParserD as ParserD -import qualified Streamly.Internal.Data.Parser.ParserD.Type as ParserD +import qualified Streamly.Internal.Data.Parser as ParserD import qualified Streamly.Internal.Data.Parser as Parser import Prelude hiding (concatMap, take) @@ -102,8 +106,8 @@ {-# INLINE fromFold #-} fromFold :: forall m a b. (MonadIO m, Unbox a) => Fold.Fold m a b -> ChunkFold m a b -fromFold (Fold.Fold fstep finitial fextract) = - ChunkFold (ParserD.Parser step initial (fmap (Done 0) . fextract)) +fromFold (Fold.Fold fstep finitial _ ffinal) = + ChunkFold (ParserD.Parser step initial extract) where @@ -123,7 +127,7 @@ assert (cur == end) (return ()) return $ Partial 0 fs goArray !_ !cur !fs = do - x <- liftIO $ peekWith contents cur + x <- liftIO $ peekAt cur contents res <- fstep fs x let elemSize = SIZE_OF(a) next = INDEX_NEXT(cur,a) @@ -133,6 +137,8 @@ Fold.Partial fs1 -> goArray SPEC next fs1 + extract = fmap (FDone 0) . ffinal + -- | Convert an element 'ParserD.Parser' into an array stream fold. If the -- parser fails the fold would throw an exception. -- @@ -160,8 +166,7 @@ else return $ st (arrRem + n) fs1 goArray !_ !cur !fs = do - x <- liftIO $ peekWith contents cur - liftIO $ touch contents + x <- liftIO $ peekAt cur contents res <- step1 fs x let elemSize = SIZE_OF(a) next = INDEX_NEXT(cur,a) @@ -173,7 +178,7 @@ partial arrRem cur next elemSize Partial n fs1 ParserD.Continue n fs1 -> do partial arrRem cur next elemSize Continue n fs1 - Error err -> return $ Error err + SError err -> return $ SError err -- | Convert an element 'Parser.Parser' into an array stream fold. If the -- parser fails the fold would throw an exception. @@ -315,8 +320,8 @@ iextract s = do r <- extract1 s return $ case r of - Done _ b -> IDone b - Error err -> IError err + FDone _ b -> IDone b + FError err -> IError err _ -> error "Bug: ChunkFold take invalid state in initial" initial = do @@ -338,10 +343,9 @@ -- i2 == i1 == j == 0 r <- extract1 s return $ case r of - Error err -> Error err - Done n1 b -> Done n1 b - Continue n1 s1 -> Continue n1 (Tuple' i2 s1) - Partial _ _ -> error "Partial in extract" + FError err -> SError err + FDone n1 b -> Done n1 b + FContinue n1 s1 -> Continue n1 (Tuple' i2 s1) -- Tuple' (how many more items to take) (fold state) step (Tuple' i r) arr = do @@ -354,7 +358,7 @@ Partial j s -> partial i1 Partial j s Continue j s -> partial i1 Continue j s Done j b -> return $ Done j b - Error err -> return $ Error err + SError err -> return $ SError err else do let !(Array contents start _) = arr end = INDEX_OF(start,i,a) @@ -364,14 +368,14 @@ res <- step1 r arr1 case res of Partial 0 s -> - ParserD.bimapOverrideCount + ParserD.bimapMorphOverrideCount remaining (Tuple' 0) id <$> extract1 s Partial j s -> return $ Partial (remaining + j) (Tuple' j s) Continue 0 s -> - ParserD.bimapOverrideCount + ParserD.bimapMorphOverrideCount remaining (Tuple' 0) id <$> extract1 s Continue j s -> return $ Continue (remaining + j) (Tuple' j s) Done j b -> return $ Done (remaining + j) b - Error err -> return $ Error err + SError err -> return $ SError err extract (Tuple' i r) = first (Tuple' i) <$> extract1 r diff --git a/src/Streamly/Internal/Data/Fold/Combinators.hs b/src/Streamly/Internal/Data/Fold/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Combinators.hs @@ -0,0 +1,2383 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Fold.Combinators +-- Copyright : (c) 2019 Composewell Technologies +-- (c) 2013 Gabriel Gonzalez +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- See "Streamly.Data.Fold" for an overview and +-- "Streamly.Internal.Data.Fold.Type" for design notes. + +module Streamly.Internal.Data.Fold.Combinators + ( + -- * Mappers + -- | Monadic functions useful with mapM/lmapM on folds or streams. + tracing + , trace + + -- * Folds + + -- ** Accumulators + -- *** Semigroups and Monoids + , sconcat + , mconcat + , foldMap + , foldMapM + + -- *** Reducers + , drainMapM + , the + , mean + , rollingHash + , Scanl.defaultSalt + , rollingHashWithSalt + , rollingHashFirstN + -- , rollingHashLastN + + -- *** Saturating Reducers + -- | 'product' terminates if it becomes 0. Other folds can theoretically + -- saturate on bounded types, and therefore terminate, however, they will + -- run forever on unbounded types like Integer/Double. + , sum + , product + , maximumBy + , maximum + , minimumBy + , minimum + , rangeBy + , range + + -- *** Collectors + -- | Avoid using these folds in scalable or performance critical + -- applications, they buffer all the input in GC memory which can be + -- detrimental to performance if the input is large. + , toStream + , toStreamRev + , topBy + , top + , bottomBy + , bottom + + -- *** Scanners + -- | Stateful transformation of the elements. Useful in combination with + -- the 'scanMaybe' combinator. For scanners the result of the fold is + -- usually a transformation of the current element rather than an + -- aggregation of all elements till now. + -- , nthLast -- using RingArray array + , rollingMap + , rollingMapM + + -- *** Filters + + -- XXX deprecate these in favor of corresponding scans + + -- | Useful in combination with the 'scanMaybe' combinator. + , deleteBy + , uniqBy + , uniq + , repeated + , findIndices + , elemIndices + + -- *** Singleton folds + -- | Folds that terminate after consuming exactly one input element. All + -- these can be implemented in terms of the 'maybe' fold. + , one + , null -- XXX not very useful and could be problematic, remove it? + , satisfy + , maybe + + -- *** Multi folds + -- | Terminate after consuming one or more elements. + , drainN + -- , lastN + -- , (!!) + , genericIndex + , index + , findM + , find + , lookup + , findIndex + , elemIndex + , elem + , notElem + , all + , any + , and + , or + + -- ** Trimmers + -- | Useful in combination with the 'scanMaybe' combinator. + , takingEndByM + , takingEndBy + , takingEndByM_ + , takingEndBy_ + , droppingWhileM + , droppingWhile + , prune + + -- * Running A Fold + , drive + -- , breakStream + + -- * Building Incrementally + , addStream + + -- * Combinators + -- ** Utilities + , with + + -- ** Sliding Window + , slide2 + + -- ** Scanning Input + , pipe + , indexed + + -- ** Zipping Input + , zipStreamWithM + , zipStream + + -- ** Filtering Input + , mapMaybeM + , mapMaybe + , sampleFromthen + + {- + -- ** Insertion + -- | Insertion adds more elements to the stream. + + , insertBy + , intersperseM + + -- ** Reordering + , reverse + -} + + -- ** Trimming + + -- By elements + , takeEndBySeq + , takeEndBySeq_ + {- + , drop + , dropWhile + , dropWhileM + -} + + -- ** Serial Append + -- , tail + -- , init + , splitAt -- spanN + -- , splitIn -- sessionN + + -- ** Parallel Distribution + , tee + , distribute + , distributeScan + -- , distributeFst + -- , distributeMin + + -- ** Unzipping + , unzip + -- These two can be expressed using lmap/lmapM and unzip + , unzipWith + , unzipWithM + , unzipWithFstM + , unzipWithMinM + + -- ** Partitioning + , partitionByM + , partitionByFstM + , partitionByMinM + , partitionBy + , partition + + -- ** Splitting + , chunksBetween + , intersperseWithQuotes + + -- ** Nesting + , unfoldMany + , concatSequence + + -- * Deprecated + , drainBy + , head + , sequence + , mapM + , variance + , stdDev + , indexingWith + , indexing + , indexingRev + ) +where + +#include "inline.hs" +#include "ArrayMacros.h" + +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Bifunctor (first) +import Data.Bits (shiftL, shiftR, (.|.), (.&.)) +import Data.Either (isLeft, isRight, fromLeft, fromRight) +import Data.Int (Int64) +import Data.Proxy (Proxy(..)) +import Data.Word (Word32) +import Streamly.Internal.Data.Array.Type (Array(..)) +import Streamly.Internal.Data.Scanl.Type (Scanl(..)) +import Streamly.Internal.Data.Unbox (Unbox(..)) +import Streamly.Internal.Data.MutArray.Type (MutArray(..)) +import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) +import Streamly.Internal.Data.Pipe.Type (Pipe (..)) +import Streamly.Internal.Data.RingArray (RingArray(..)) +-- import Streamly.Internal.Data.Scan (Scan (..)) +import Streamly.Internal.Data.Stream.Type (Stream) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) + +import qualified Prelude +import qualified Streamly.Internal.Data.MutArray.Type as MA +import qualified Streamly.Internal.Data.Array.Type as Array +import qualified Streamly.Internal.Data.Pipe.Type as Pipe +import qualified Streamly.Internal.Data.RingArray as RingArray +import qualified Streamly.Internal.Data.Scanl.Combinators as Scanl +import qualified Streamly.Internal.Data.Scanl.Type as Scanl +import qualified Streamly.Internal.Data.Stream.Type as StreamD + +import Prelude hiding + ( Foldable(..), filter, drop, dropWhile, take, takeWhile, zipWith + , map, mapM_, sequence, all, any + , notElem, head, last, tail + , reverse, iterate, init, and, or, lookup, (!!) + , scanl, scanl1, replicate, concatMap, mconcat, unzip + , span, splitAt, break, mapM, zip, maybe) +import Streamly.Internal.Data.Fold.Type + +#include "DocTestDataFold.hs" + +------------------------------------------------------------------------------ +-- Running +------------------------------------------------------------------------------ + +-- | Drive a fold using the supplied 'Stream', reducing the resulting +-- expression strictly at each step. +-- +-- Definition: +-- +-- >>> drive = flip Stream.fold +-- +-- Example: +-- +-- >>> Fold.drive (Stream.enumerateFromTo 1 100) Fold.sum +-- 5050 +-- +{-# INLINE drive #-} +drive :: Monad m => Stream m a -> Fold m a b -> m b +drive = flip StreamD.fold + +{- +-- | Like 'drive' but also returns the remaining stream. The resulting stream +-- would be 'Stream.nil' if the stream finished before the fold. +-- +-- Definition: +-- +-- >>> breakStream = flip Stream.foldBreak +-- +-- /CPS/ +-- +{-# INLINE breakStreamK #-} +breakStreamK :: Monad m => StreamK m a -> Fold m a b -> m (b, StreamK m a) +breakStreamK strm fl = fmap f $ K.foldBreak fl (Stream.toStreamK strm) + + where + + f (b, str) = (b, Stream.fromStreamK str) +-} + +-- | Append a stream to a fold to build the fold accumulator incrementally. We +-- can repeatedly call 'addStream' on the same fold to continue building the +-- fold and finally use 'drive' to finish the fold and extract the result. Also +-- see the 'Streamly.Data.Fold.addOne' operation which is a singleton version +-- of 'addStream'. +-- +-- Definitions: +-- +-- >>> addStream stream = Fold.drive stream . Fold.duplicate +-- +-- Example, build a list incrementally: +-- +-- >>> :{ +-- pure (Fold.toList :: Fold IO Int [Int]) +-- >>= Fold.addOne 1 +-- >>= Fold.addStream (Stream.enumerateFromTo 2 4) +-- >>= Fold.drive Stream.nil +-- >>= print +-- :} +-- [1,2,3,4] +-- +-- This can be used as an O(n) list append compared to the O(n^2) @++@ when +-- used for incrementally building a list. +-- +-- Example, build a stream incrementally: +-- +-- >>> :{ +-- pure (Fold.toStream :: Fold IO Int (Stream Identity Int)) +-- >>= Fold.addOne 1 +-- >>= Fold.addStream (Stream.enumerateFromTo 2 4) +-- >>= Fold.drive Stream.nil +-- >>= print +-- :} +-- fromList [1,2,3,4] +-- +-- This can be used as an O(n) stream append compared to the O(n^2) @<>@ when +-- used for incrementally building a stream. +-- +-- Example, build an array incrementally: +-- +-- >>> :{ +-- pure (Array.create :: Fold IO Int (Array Int)) +-- >>= Fold.addOne 1 +-- >>= Fold.addStream (Stream.enumerateFromTo 2 4) +-- >>= Fold.drive Stream.nil +-- >>= print +-- :} +-- fromList [1,2,3,4] +-- +-- Example, build an array stream incrementally: +-- +-- >>> :{ +-- let f :: Fold IO Int (Stream Identity (Array Int)) +-- f = Fold.groupsOf 2 (Array.createOf 3) Fold.toStream +-- in pure f +-- >>= Fold.addOne 1 +-- >>= Fold.addStream (Stream.enumerateFromTo 2 4) +-- >>= Fold.drive Stream.nil +-- >>= print +-- :} +-- fromList [fromList [1,2],fromList [3,4]] +-- +addStream :: Monad m => Stream m a -> Fold m a b -> m (Fold m a b) +addStream stream = drive stream . duplicate + +------------------------------------------------------------------------------ +-- Transformations on fold inputs +------------------------------------------------------------------------------ + +-- | Flatten the monadic output of a fold to pure output. +-- +{-# DEPRECATED sequence "Use \"rmapM id\" instead" #-} +{-# INLINE sequence #-} +sequence :: Monad m => Fold m a (m b) -> Fold m a b +sequence = rmapM id + +-- | Map a monadic function on the output of a fold. +-- +{-# DEPRECATED mapM "Use rmapM instead" #-} +{-# INLINE mapM #-} +mapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c +mapM = rmapM + +-- | +-- >>> mapMaybeM f = Fold.lmapM f . Fold.catMaybes +-- +{-# INLINE mapMaybeM #-} +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Fold m b r -> Fold m a r +mapMaybeM f = lmapM f . catMaybes + +-- | @mapMaybe f fold@ maps a 'Maybe' returning function @f@ on the input of +-- the fold, filters out 'Nothing' elements, and return the values extracted +-- from 'Just'. +-- +-- >>> mapMaybe f = Fold.lmap f . Fold.catMaybes +-- >>> mapMaybe f = Fold.mapMaybeM (return . f) +-- +-- >>> f x = if even x then Just x else Nothing +-- >>> fld = Fold.mapMaybe f Fold.toList +-- >>> Stream.fold fld (Stream.enumerateFromTo 1 10) +-- [2,4,6,8,10] +-- +{-# INLINE mapMaybe #-} +mapMaybe :: Monad m => (a -> Maybe b) -> Fold m b r -> Fold m a r +mapMaybe f = lmap f . catMaybes + +------------------------------------------------------------------------------ +-- Transformations on fold inputs +------------------------------------------------------------------------------ + +-- | Apply a monadic function on the input and return the input. +-- +-- >>> Stream.fold (Fold.lmapM (Fold.tracing print) Fold.drain) $ (Stream.enumerateFromTo (1 :: Int) 2) +-- 1 +-- 2 +-- +-- /Pre-release/ +-- +{-# INLINE tracing #-} +tracing :: Monad m => (a -> m b) -> (a -> m a) +tracing f x = void (f x) >> return x + +-- | Apply a monadic function to each element flowing through and discard the +-- results. +-- +-- >>> Stream.fold (Fold.trace print Fold.drain) $ (Stream.enumerateFromTo (1 :: Int) 2) +-- 1 +-- 2 +-- +-- >>> trace f = Fold.lmapM (Fold.tracing f) +-- +-- /Pre-release/ +{-# INLINE trace #-} +trace :: Monad m => (a -> m b) -> Fold m a r -> Fold m a r +trace f = lmapM (tracing f) + +-- | Attach a 'Pipe' on the input of a 'Fold'. +-- +-- /Pre-release/ +{-# INLINE pipe #-} +pipe :: Monad m => Pipe m a b -> Fold m b c -> Fold m a c +pipe (Pipe consume produce pinitial) (Fold fstep finitial fextract ffinal) = + Fold step initial extract final + + where + + initial = first (Tuple' pinitial) <$> finitial + + step (Tuple' cs fs) x = do + r <- consume cs x + go fs r + + where + + -- XXX use SPEC? + go acc (Pipe.YieldC cs1 b) = do + acc1 <- fstep acc b + return + $ case acc1 of + Partial s -> Partial $ Tuple' cs1 s + Done b1 -> Done b1 + -- XXX this case is recursive may cause fusion issues. + -- To remove recursion we will need a produce mode in folds which makes + -- it similar to pipes except that it does not yield intermediate + -- values.. + go acc (Pipe.YieldP ps1 b) = do + acc1 <- fstep acc b + r <- produce ps1 + case acc1 of + Partial s -> go s r + Done b1 -> return $ Done b1 + go acc (Pipe.SkipC cs1) = + return $ Partial $ Tuple' cs1 acc + -- XXX this case is recursive may cause fusion issues. + go acc (Pipe.SkipP ps1) = do + r <- produce ps1 + go acc r + -- XXX a Stop in consumer means we dropped the input. + go acc Pipe.Stop = Done <$> ffinal acc + + extract (Tuple' _ fs) = fextract fs + + final (Tuple' _ fs) = ffinal fs + +------------------------------------------------------------------------------ +-- Filters +------------------------------------------------------------------------------ + +-- | Returns the latest element omitting the first occurrence that satisfies +-- the given equality predicate. +-- +-- Example: +-- +-- >>> input = Stream.fromList [1,3,3,5] +-- +-- >> Stream.toList $ Stream.scanMaybe (Fold.deleteBy (==) 3) input +-- [1,3,5] +-- +{-# INLINE_NORMAL deleteBy #-} +deleteBy :: Monad m => (a -> a -> Bool) -> a -> Fold m a (Maybe a) +deleteBy eq = fromScanl . Scanl.deleteBy eq + +-- | Provide a sliding window of length 2 elements. +-- +-- See "Streamly.Internal.Data.Fold.Window". +-- +{-# INLINE slide2 #-} +slide2 :: Monad m => Fold m (a, Maybe a) b -> Fold m a b +slide2 (Fold step1 initial1 extract1 final1) = Fold step initial extract final + + where + + initial = + first (Tuple' Nothing) <$> initial1 + + step (Tuple' prev s) cur = + first (Tuple' (Just cur)) <$> step1 s (cur, prev) + + extract (Tuple' _ s) = extract1 s + + final (Tuple' _ s) = final1 s + +-- | Return the latest unique element using the supplied comparison function. +-- Returns 'Nothing' if the current element is same as the last element +-- otherwise returns 'Just'. +-- +-- Example, strip duplicate path separators: +-- +-- >>> input = Stream.fromList "//a//b" +-- >>> f x y = x == '/' && y == '/' +-- +-- >> Stream.toList $ Stream.scanMaybe (Fold.uniqBy f) input +-- "/a/b" +-- +-- Space: @O(1)@ +-- +-- /Pre-release/ +-- +{-# INLINE uniqBy #-} +uniqBy :: Monad m => (a -> a -> Bool) -> Fold m a (Maybe a) +uniqBy = fromScanl . Scanl.uniqBy + +-- | See 'uniqBy'. +-- +-- Definition: +-- +-- >>> uniq = Fold.uniqBy (==) +-- +{-# INLINE uniq #-} +uniq :: (Monad m, Eq a) => Fold m a (Maybe a) +uniq = fromScanl Scanl.uniq + +-- | Strip all leading and trailing occurrences of an element passing a +-- predicate and make all other consecutive occurrences uniq. +-- +-- >> prune p = Stream.dropWhileAround p $ Stream.uniqBy (x y -> p x && p y) +-- +-- @ +-- > Stream.prune isSpace (Stream.fromList " hello world! ") +-- "hello world!" +-- +-- @ +-- +-- Space: @O(1)@ +-- +-- /Unimplemented/ +{-# INLINE prune #-} +prune :: + -- (Monad m, Eq a) => + (a -> Bool) -> Fold m a (Maybe a) +prune = error "Not implemented yet!" + +-- | Emit only repeated elements, once. +-- +-- /Unimplemented/ +repeated :: -- (Monad m, Eq a) => + Fold m a (Maybe a) +repeated = error "Not implemented yet!" + +------------------------------------------------------------------------------ +-- Left folds +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Run Effects +------------------------------------------------------------------------------ + +-- | +-- Definitions: +-- +-- >>> drainMapM f = Fold.lmapM f Fold.drain +-- >>> drainMapM f = Fold.foldMapM (void . f) +-- +-- Drain all input after passing it through a monadic function. This is the +-- dual of mapM_ on stream producers. +-- +{-# INLINE drainMapM #-} +drainMapM :: Monad m => (a -> m b) -> Fold m a () +drainMapM f = lmapM f drain + +{-# DEPRECATED drainBy "Please use 'drainMapM' instead." #-} +{-# INLINE drainBy #-} +drainBy :: Monad m => (a -> m b) -> Fold m a () +drainBy = drainMapM + +-- | Terminates with 'Nothing' as soon as it finds an element different than +-- the previous one, returns 'the' element if the entire input consists of the +-- same element. +-- +{-# INLINE the #-} +the :: (Monad m, Eq a) => Fold m a (Maybe a) +the = fromScanl Scanl.the + +------------------------------------------------------------------------------ +-- To Summary +------------------------------------------------------------------------------ + +-- | Determine the sum of all elements of a stream of numbers. Returns additive +-- identity (@0@) when the stream is empty. Note that this is not numerically +-- stable for floating point numbers. +-- +-- >>> sum = Fold.fromScanl (Scanl.cumulativeScan Scanl.incrSum) +-- +-- Same as following but numerically stable: +-- +-- >>> sum = Fold.foldl' (+) 0 +-- >>> sum = fmap Data.Monoid.getSum $ Fold.foldMap Data.Monoid.Sum +-- +{-# INLINE sum #-} +sum :: (Monad m, Num a) => Fold m a a +sum = fromScanl Scanl.sum + +-- | Determine the product of all elements of a stream of numbers. Returns +-- multiplicative identity (@1@) when the stream is empty. The fold terminates +-- when it encounters (@0@) in its input. +-- +-- Same as the following but terminates on multiplication by @0@: +-- +-- >>> product = fmap Data.Monoid.getProduct $ Fold.foldMap Data.Monoid.Product +-- +{-# INLINE product #-} +product :: (Monad m, Num a, Eq a) => Fold m a a +product = fromScanl Scanl.product + +------------------------------------------------------------------------------ +-- To Summary (Maybe) +------------------------------------------------------------------------------ + +-- | Determine the maximum element in a stream using the supplied comparison +-- function. +-- +{-# INLINE maximumBy #-} +maximumBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe a) +maximumBy cmp = foldl1' max' + + where + + max' x y = + case cmp x y of + GT -> x + _ -> y + +-- | Determine the maximum element in a stream. +-- +-- Definitions: +-- +-- >>> maximum = Fold.maximumBy compare +-- >>> maximum = Fold.foldl1' max +-- +-- Same as the following but without a default maximum. The 'Max' Monoid uses +-- the 'minBound' as the default maximum: +-- +-- >>> maximum = fmap Data.Semigroup.getMax $ Fold.foldMap Data.Semigroup.Max +-- +{-# INLINE maximum #-} +maximum :: (Monad m, Ord a) => Fold m a (Maybe a) +maximum = foldl1' max + +-- | Computes the minimum element with respect to the given comparison function +-- +{-# INLINE minimumBy #-} +minimumBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe a) +minimumBy cmp = foldl1' min' + + where + + min' x y = + case cmp x y of + GT -> y + _ -> x + +-- | Determine the minimum element in a stream using the supplied comparison +-- function. +-- +-- Definitions: +-- +-- >>> minimum = Fold.minimumBy compare +-- >>> minimum = Fold.foldl1' min +-- +-- Same as the following but without a default minimum. The 'Min' Monoid uses the +-- 'maxBound' as the default maximum: +-- +-- >>> maximum = fmap Data.Semigroup.getMin $ Fold.foldMap Data.Semigroup.Min +-- +{-# INLINE minimum #-} +minimum :: (Monad m, Ord a) => Fold m a (Maybe a) +minimum = foldl1' min + +{-# INLINE rangeBy #-} +rangeBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe (a, a)) +rangeBy cmp = fromScanl (Scanl.rangeBy cmp) + +-- | Find minimum and maximum elements i.e. (min, max). +-- +{-# INLINE range #-} +range :: (Monad m, Ord a) => Fold m a (Maybe (a, a)) +range = fromScanl Scanl.range + +------------------------------------------------------------------------------ +-- To Summary (Statistical) +------------------------------------------------------------------------------ + +-- | Compute a numerically stable arithmetic mean of all elements in the input +-- stream. +-- +{-# INLINE mean #-} +mean :: (Monad m, Fractional a) => Fold m a a +mean = fromScanl Scanl.mean + +-- | Compute a numerically stable (population) variance over all elements in +-- the input stream. +-- +{-# DEPRECATED variance "Use the streamly-statistics package instead" #-} +{-# INLINE variance #-} +variance :: (Monad m, Fractional a) => Fold m a a +variance = fmap done $ foldl' step begin + + where + + begin = Tuple3' 0 0 0 + + step (Tuple3' n mean_ m2) x = Tuple3' n' mean' m2' + + where + + n' = n + 1 + mean' = (n * mean_ + x) / (n + 1) + delta = x - mean_ + m2' = m2 + delta * delta * n / (n + 1) + + done (Tuple3' n _ m2) = m2 / n + +-- | Compute a numerically stable (population) standard deviation over all +-- elements in the input stream. +-- +{-# DEPRECATED stdDev "Use the streamly-statistics package instead" #-} +{-# INLINE stdDev #-} +stdDev :: (Monad m, Floating a) => Fold m a a +stdDev = sqrt <$> variance + +-- | Compute an 'Int' sized polynomial rolling hash +-- +-- > H = salt * k ^ n + c1 * k ^ (n - 1) + c2 * k ^ (n - 2) + ... + cn * k ^ 0 +-- +-- Where @c1@, @c2@, @cn@ are the elements in the input stream and @k@ is a +-- constant. +-- +-- This hash is often used in Rabin-Karp string search algorithm. +-- +-- See https://en.wikipedia.org/wiki/Rolling_hash +-- +{-# INLINE rollingHashWithSalt #-} +rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64 +rollingHashWithSalt = fromScanl . Scanl.rollingHashWithSalt + +-- | Compute an 'Int' sized polynomial rolling hash of a stream. +-- +-- >>> rollingHash = Fold.rollingHashWithSalt Fold.defaultSalt +-- +{-# INLINE rollingHash #-} +rollingHash :: (Monad m, Enum a) => Fold m a Int64 +rollingHash = fromScanl Scanl.rollingHash + +-- | Compute an 'Int' sized polynomial rolling hash of the first n elements of +-- a stream. +-- +-- >>> rollingHashFirstN n = Fold.take n Fold.rollingHash +-- +-- /Pre-release/ +{-# INLINE rollingHashFirstN #-} +rollingHashFirstN :: (Monad m, Enum a) => Int -> Fold m a Int64 +rollingHashFirstN = fromScanl . Scanl.rollingHashFirstN + +-- XXX Compare this with the implementation in Fold.Window, preferrably use the +-- latter if performance is good. + +-- | Apply a function on every two successive elements of a stream. The first +-- argument of the map function is the previous element and the second argument +-- is the current element. When processing the very first element in the +-- stream, the previous element is 'Nothing'. +-- +-- /Pre-release/ +-- +{-# INLINE rollingMapM #-} +rollingMapM :: Monad m => (Maybe a -> a -> m b) -> Fold m a b +rollingMapM = fromScanl . Scanl.rollingMapM + +-- | +-- >>> rollingMap f = Fold.rollingMapM (\x y -> return $ f x y) +-- +{-# INLINE rollingMap #-} +rollingMap :: Monad m => (Maybe a -> a -> b) -> Fold m a b +rollingMap = fromScanl . Scanl.rollingMap + +------------------------------------------------------------------------------ +-- Monoidal left folds +------------------------------------------------------------------------------ + +-- | Semigroup concat. Append the elements of an input stream to a provided +-- starting value. +-- +-- Definition: +-- +-- >>> sconcat = Fold.foldl' (<>) +-- +-- >>> semigroups = fmap Data.Monoid.Sum $ Stream.enumerateFromTo 1 10 +-- >>> Stream.fold (Fold.sconcat 10) semigroups +-- Sum {getSum = 65} +-- +{-# INLINE sconcat #-} +sconcat :: (Monad m, Semigroup a) => a -> Fold m a a +sconcat = fromScanl . Scanl.sconcat + +-- | Monoid concat. Fold an input stream consisting of monoidal elements using +-- 'mappend' and 'mempty'. +-- +-- Definition: +-- +-- >>> mconcat = Fold.sconcat mempty +-- +-- >>> monoids = fmap Data.Monoid.Sum $ Stream.enumerateFromTo 1 10 +-- >>> Stream.fold Fold.mconcat monoids +-- Sum {getSum = 55} +-- +{-# INLINE mconcat #-} +mconcat :: + ( Monad m + , Monoid a) => Fold m a a +mconcat = fromScanl Scanl.mconcat + +-- | +-- Definition: +-- +-- >>> foldMap f = Fold.lmap f Fold.mconcat +-- +-- Make a fold from a pure function that folds the output of the function +-- using 'mappend' and 'mempty'. +-- +-- >>> sum = Fold.foldMap Data.Monoid.Sum +-- >>> Stream.fold sum $ Stream.enumerateFromTo 1 10 +-- Sum {getSum = 55} +-- +{-# INLINE foldMap #-} +foldMap :: (Monad m, Monoid b) => (a -> b) -> Fold m a b +foldMap = fromScanl . Scanl.foldMap + +-- | +-- Definition: +-- +-- >>> foldMapM f = Fold.lmapM f Fold.mconcat +-- +-- Make a fold from a monadic function that folds the output of the function +-- using 'mappend' and 'mempty'. +-- +-- >>> sum = Fold.foldMapM (return . Data.Monoid.Sum) +-- >>> Stream.fold sum $ Stream.enumerateFromTo 1 10 +-- Sum {getSum = 55} +-- +{-# INLINE foldMapM #-} +foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Fold m a b +foldMapM = fromScanl . Scanl.foldMapM + +------------------------------------------------------------------------------ +-- Partial Folds +------------------------------------------------------------------------------ + +-- | A fold that drains the first n elements of its input, running the effects +-- and discarding the results. +-- +-- Definition: +-- +-- >>> drainN n = Fold.take n Fold.drain +-- +-- /Pre-release/ +{-# INLINE drainN #-} +drainN :: Monad m => Int -> Fold m a () +drainN = fromScanl . Scanl.drainN + +------------------------------------------------------------------------------ +-- To Elements +------------------------------------------------------------------------------ + +-- | Like 'index', except with a more general 'Integral' argument +-- +-- /Pre-release/ +{-# INLINE genericIndex #-} +genericIndex :: (Integral i, Monad m) => i -> Fold m a (Maybe a) +genericIndex i = foldt' step (Partial 0) (const Nothing) + + where + + step j a = + if i == j + then Done $ Just a + else Partial (j + 1) + +-- | Return the element at the given index. +-- +-- Definition: +-- +-- >>> index = Fold.genericIndex +-- +{-# INLINE index #-} +index :: Monad m => Int -> Fold m a (Maybe a) +index = genericIndex + +-- | Consume a single input and transform it using the supplied 'Maybe' +-- returning function. +-- +-- /Pre-release/ +-- +{-# INLINE maybe #-} +maybe :: Monad m => (a -> Maybe b) -> Fold m a (Maybe b) +maybe f = foldt' (const (Done . f)) (Partial Nothing) id + +-- | Consume a single element and return it if it passes the predicate else +-- return 'Nothing'. +-- +-- Definition: +-- +-- >>> satisfy f = Fold.maybe (\a -> if f a then Just a else Nothing) +-- +-- /Pre-release/ +{-# INLINE satisfy #-} +satisfy :: Monad m => (a -> Bool) -> Fold m a (Maybe a) +satisfy f = maybe (\a -> if f a then Just a else Nothing) +{- +satisfy f = Fold step (return $ Partial ()) (const (return Nothing)) + + where + + step () a = return $ Done $ if f a then Just a else Nothing +-} + +-- Naming notes: +-- +-- "head" and "next" are two alternative names for the same API. head sounds +-- apt in the context of lists but next sounds more apt in the context of +-- streams where we think in terms of generating and consuming the next element +-- rather than taking the head of some static/persistent structure. +-- +-- We also want to keep the nomenclature consistent across folds and parsers, +-- "head" becomes even more unintuitive for parsers because there are two +-- possible variants viz. peek and next. +-- +-- Also, the "head" fold creates confusion in situations like +-- https://github.com/composewell/streamly/issues/1404 where intuitive +-- expectation from head is to consume the entire stream and just give us the +-- head. There we want to convey the notion that we consume one element from +-- the stream and stop. The name "one" already being used in parsers for this +-- purpose sounds more apt from this perspective. +-- +-- The source of confusion is perhaps due to the fact that some folds consume +-- the entire stream and others terminate early. It may have been clearer if we +-- had separate abstractions for the two use cases. + +-- XXX We can possibly use "head" for the purposes of reducing the entire +-- stream to the head element i.e. take the head and drain the rest. + +-- | Take one element from the stream and stop. +-- +-- Definition: +-- +-- >>> one = Fold.maybe Just +-- +-- This is similar to the stream 'Stream.uncons' operation. +-- +{-# INLINE one #-} +one :: Monad m => Fold m a (Maybe a) +one = maybe Just + +-- | Extract the first element of the stream, if any. +-- +-- >>> head = Fold.one +-- +{-# DEPRECATED head "Please use \"one\" instead" #-} +{-# INLINE head #-} +head :: Monad m => Fold m a (Maybe a) +head = one + +-- | Returns the first element that satisfies the given predicate. +-- +-- /Pre-release/ +{-# INLINE findM #-} +findM :: Monad m => (a -> m Bool) -> Fold m a (Maybe a) +findM predicate = + Fold step (return $ Partial ()) extract extract + + where + + step () a = + let f r = + if r + then Done (Just a) + else Partial () + in f <$> predicate a + + extract = const $ return Nothing + +-- | Returns the first element that satisfies the given predicate. +-- +{-# INLINE find #-} +find :: Monad m => (a -> Bool) -> Fold m a (Maybe a) +find p = findM (return . p) + +-- | In a stream of (key-value) pairs @(a, b)@, return the value @b@ of the +-- first pair where the key equals the given value @a@. +-- +-- Definition: +-- +-- >>> lookup x = fmap snd <$> Fold.find ((== x) . fst) +-- +{-# INLINE lookup #-} +lookup :: (Eq a, Monad m) => a -> Fold m (a,b) (Maybe b) +lookup a0 = foldt' step (Partial ()) (const Nothing) + + where + + step () (a, b) = + if a == a0 + then Done $ Just b + else Partial () + +-- | Returns the first index that satisfies the given predicate. +-- +{-# INLINE findIndex #-} +findIndex :: Monad m => (a -> Bool) -> Fold m a (Maybe Int) +findIndex predicate = foldt' step (Partial 0) (const Nothing) + + where + + step i a = + if predicate a + then Done $ Just i + else Partial (i + 1) + +-- | Returns the index of the latest element if the element satisfies the given +-- predicate. +-- +{-# INLINE findIndices #-} +findIndices :: Monad m => (a -> Bool) -> Fold m a (Maybe Int) +findIndices = fromScanl . Scanl.findIndices + +-- | Returns the index of the latest element if the element matches the given +-- value. +-- +-- Definition: +-- +-- >>> elemIndices a = Fold.findIndices (== a) +-- +{-# INLINE elemIndices #-} +elemIndices :: (Monad m, Eq a) => a -> Fold m a (Maybe Int) +elemIndices = fromScanl . Scanl.elemIndices + +-- | Returns the first index where a given value is found in the stream. +-- +-- Definition: +-- +-- >>> elemIndex a = Fold.findIndex (== a) +-- +{-# INLINE elemIndex #-} +elemIndex :: (Eq a, Monad m) => a -> Fold m a (Maybe Int) +elemIndex a = findIndex (== a) + +------------------------------------------------------------------------------ +-- To Boolean +------------------------------------------------------------------------------ + +-- Similar to 'eof' parser, but the fold consumes and discards an input element +-- when not at eof. XXX Remove or Rename to "eof"? + +-- | Consume one element, return 'True' if successful else return 'False'. In +-- other words, test if the input is empty or not. +-- +-- WARNING! It consumes one element if the stream is not empty. If that is not +-- what you want please use the eof parser instead. +-- +-- Definition: +-- +-- >>> null = fmap isJust Fold.one +-- +{-# INLINE null #-} +null :: Monad m => Fold m a Bool +null = foldt' (\() _ -> Done False) (Partial ()) (const True) + +-- | Returns 'True' if any element of the input satisfies the predicate. +-- +-- Definition: +-- +-- >>> any p = Fold.lmap p Fold.or +-- +-- Example: +-- +-- >>> Stream.fold (Fold.any (== 0)) $ Stream.fromList [1,0,1] +-- True +-- +{-# INLINE any #-} +any :: Monad m => (a -> Bool) -> Fold m a Bool +any predicate = foldt' step initial id + + where + + initial = Partial False + + step _ a = + if predicate a + then Done True + else Partial False + +-- | Return 'True' if the given element is present in the stream. +-- +-- Definition: +-- +-- >>> elem a = Fold.any (== a) +-- +{-# INLINE elem #-} +elem :: (Eq a, Monad m) => a -> Fold m a Bool +elem a = any (== a) + +-- | Returns 'True' if all elements of the input satisfy the predicate. +-- +-- Definition: +-- +-- >>> all p = Fold.lmap p Fold.and +-- +-- Example: +-- +-- >>> Stream.fold (Fold.all (== 0)) $ Stream.fromList [1,0,1] +-- False +-- +{-# INLINE all #-} +all :: Monad m => (a -> Bool) -> Fold m a Bool +all predicate = foldt' step initial id + + where + + initial = Partial True + + step _ a = + if predicate a + then Partial True + else Done False + +-- | Returns 'True' if the given element is not present in the stream. +-- +-- Definition: +-- +-- >>> notElem a = Fold.all (/= a) +-- +{-# INLINE notElem #-} +notElem :: (Eq a, Monad m) => a -> Fold m a Bool +notElem a = all (/= a) + +-- | Returns 'True' if all elements are 'True', 'False' otherwise +-- +-- Definition: +-- +-- >>> and = Fold.all (== True) +-- +{-# INLINE and #-} +and :: Monad m => Fold m Bool Bool +and = all id + +-- | Returns 'True' if any element is 'True', 'False' otherwise +-- +-- Definition: +-- +-- >>> or = Fold.any (== True) +-- +{-# INLINE or #-} +or :: Monad m => Fold m Bool Bool +or = any id + +------------------------------------------------------------------------------ +-- Grouping/Splitting +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Grouping without looking at elements +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Binary APIs +------------------------------------------------------------------------------ + +-- | @splitAt n f1 f2@ composes folds @f1@ and @f2@ such that first @n@ +-- elements of its input are consumed by fold @f1@ and the rest of the stream +-- is consumed by fold @f2@. +-- +-- >>> let splitAt_ n xs = Stream.fold (Fold.splitAt n Fold.toList Fold.toList) $ Stream.fromList xs +-- +-- >>> splitAt_ 6 "Hello World!" +-- ("Hello ","World!") +-- +-- >>> splitAt_ (-1) [1,2,3] +-- ([],[1,2,3]) +-- +-- >>> splitAt_ 0 [1,2,3] +-- ([],[1,2,3]) +-- +-- >>> splitAt_ 1 [1,2,3] +-- ([1],[2,3]) +-- +-- >>> splitAt_ 3 [1,2,3] +-- ([1,2,3],[]) +-- +-- >>> splitAt_ 4 [1,2,3] +-- ([1,2,3],[]) +-- +-- > splitAt n f1 f2 = Fold.splitWith (,) (Fold.take n f1) f2 +-- +-- /Internal/ + +{-# INLINE splitAt #-} +splitAt + :: Monad m + => Int + -> Fold m a b + -> Fold m a c + -> Fold m a (b, c) +splitAt n fld = splitWith (,) (take n fld) + +------------------------------------------------------------------------------ +-- Element Aware APIs +------------------------------------------------------------------------------ +-- +------------------------------------------------------------------------------ +-- Binary APIs +------------------------------------------------------------------------------ + +{-# INLINE takingEndByM #-} +takingEndByM :: Monad m => (a -> m Bool) -> Fold m a (Maybe a) +takingEndByM p = Fold step initial extract extract + + where + + initial = return $ Partial Nothing' + + step _ a = do + r <- p a + return + $ if r + then Done $ Just a + else Partial $ Just' a + + extract = return . toMaybe + +-- | +-- +-- >>> takingEndBy p = Fold.takingEndByM (return . p) +-- +{-# INLINE takingEndBy #-} +takingEndBy :: Monad m => (a -> Bool) -> Fold m a (Maybe a) +takingEndBy p = takingEndByM (return . p) + +{-# INLINE takingEndByM_ #-} +takingEndByM_ :: Monad m => (a -> m Bool) -> Fold m a (Maybe a) +takingEndByM_ p = Fold step initial extract extract + + where + + initial = return $ Partial Nothing' + + step _ a = do + r <- p a + return + $ if r + then Done Nothing + else Partial $ Just' a + + extract = return . toMaybe + +-- | +-- +-- >>> takingEndBy_ p = Fold.takingEndByM_ (return . p) +-- +{-# INLINE takingEndBy_ #-} +takingEndBy_ :: Monad m => (a -> Bool) -> Fold m a (Maybe a) +takingEndBy_ p = takingEndByM_ (return . p) + +{-# INLINE droppingWhileM #-} +droppingWhileM :: Monad m => (a -> m Bool) -> Fold m a (Maybe a) +droppingWhileM p = Fold step initial extract extract + + where + + initial = return $ Partial Nothing' + + step Nothing' a = do + r <- p a + return + $ Partial + $ if r + then Nothing' + else Just' a + step _ a = return $ Partial $ Just' a + + extract = return . toMaybe + +-- | +-- >>> droppingWhile p = Fold.droppingWhileM (return . p) +-- +{-# INLINE droppingWhile #-} +droppingWhile :: Monad m => (a -> Bool) -> Fold m a (Maybe a) +droppingWhile p = droppingWhileM (return . p) + +------------------------------------------------------------------------------ +-- Binary splitting on a separator +------------------------------------------------------------------------------ + +data SplitOnSeqState mba acc a rh w ck = + SplitOnSeqEmpty !acc + | SplitOnSeqSingle !acc !a + | SplitOnSeqWord !acc !Int !w + | SplitOnSeqWordLoop !acc !w + | SplitOnSeqKR !acc !Int !mba + | SplitOnSeqKRLoop !acc !ck !mba !rh + +-- XXX Need to add tests for takeEndBySeq, we have tests for takeEndBySeq_ . + +-- | Continue taking the input until the input sequence matches the supplied +-- sequence, taking the supplied sequence as well. If the pattern is empty this +-- acts as an identity fold. +-- +-- >>> s = Stream.fromList "Gauss---Euler---Noether" +-- >>> f = Fold.takeEndBySeq (Array.fromList "---") Fold.toList +-- >>> Stream.fold f s +-- "Gauss---" +-- +-- >>> Stream.fold Fold.toList $ Stream.foldMany f s +-- ["Gauss---","Euler---","Noether"] +-- +-- Uses Rabin-Karp algorithm for substring search. +-- +-- See also: 'Streamly.Data.Stream.splitOnSeq' and +-- 'Streamly.Data.Stream.splitEndBySeq'. +-- +-- /Pre-release/ +{-# INLINE takeEndBySeq #-} +takeEndBySeq :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => + Array.Array a + -> Fold m a b + -> Fold m a b +takeEndBySeq patArr (Fold fstep finitial fextract ffinal) = + Fold step initial extract final + + where + + patLen = Array.length patArr + patBytes = Array.byteLength patArr + maxIndex = patLen - 1 + maxOffset = patBytes - SIZE_OF(a) + + initial = do + res <- finitial + case res of + Partial acc + | patLen == 0 -> + -- XXX Should we match nothing or everything on empty + -- pattern? + -- Done <$> ffinal acc + return $ Partial $ SplitOnSeqEmpty acc + | patLen == 1 -> do + pat <- liftIO $ Array.unsafeGetIndexIO 0 patArr + return $ Partial $ SplitOnSeqSingle acc pat + | SIZE_OF(a) * patLen <= sizeOf (Proxy :: Proxy Word) -> + return $ Partial $ SplitOnSeqWord acc 0 0 + | otherwise -> do + (MutArray mba _ _ _) :: MutArray a <- + liftIO $ MA.emptyOf patLen + return $ Partial $ SplitOnSeqKR acc 0 mba + Done b -> return $ Done b + + -- Word pattern related + elemBits = SIZE_OF(a) * 8 + + wordMask :: Word + wordMask = (1 `shiftL` (elemBits * patLen)) - 1 + + wordPat :: Word + wordPat = wordMask .&. Array.foldl' addToWord 0 patArr + + addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) + + -- For Rabin-Karp search + k = 2891336453 :: Word32 + coeff = k ^ patLen + + addCksum cksum a = cksum * k + fromIntegral (fromEnum a) + + deltaCksum cksum old new = + addCksum cksum new - coeff * fromIntegral (fromEnum old) + + -- XXX shall we use a random starting hash or 1 instead of 0? + -- XXX Need to keep this cached across fold calls in foldmany + -- XXX We may need refold to inject the cached state instead of + -- initializing the state every time. + -- XXX Allocation of ring buffer should also be done once + patHash = Array.foldl' addCksum 0 patArr + + step (SplitOnSeqEmpty s) x = do + res <- fstep s x + case res of + Partial s1 -> return $ Partial $ SplitOnSeqEmpty s1 + Done b -> return $ Done b + step (SplitOnSeqSingle s pat) x = do + res <- fstep s x + case res of + Partial s1 + | pat /= x -> return $ Partial $ SplitOnSeqSingle s1 pat + | otherwise -> Done <$> ffinal s1 + Done b -> return $ Done b + step (SplitOnSeqWord s idx wrd) x = do + res <- fstep s x + let wrd1 = addToWord wrd x + case res of + Partial s1 + | idx == maxIndex -> do + if wrd1 .&. wordMask == wordPat + then Done <$> ffinal s1 + else return $ Partial $ SplitOnSeqWordLoop s1 wrd1 + | otherwise -> + return $ Partial $ SplitOnSeqWord s1 (idx + 1) wrd1 + Done b -> return $ Done b + step (SplitOnSeqWordLoop s wrd) x = do + res <- fstep s x + let wrd1 = addToWord wrd x + case res of + Partial s1 + | wrd1 .&. wordMask == wordPat -> + Done <$> ffinal s1 + | otherwise -> + return $ Partial $ SplitOnSeqWordLoop s1 wrd1 + Done b -> return $ Done b + step (SplitOnSeqKR s offset mba) x = do + res <- fstep s x + case res of + Partial s1 -> do + liftIO $ pokeAt offset mba x + if offset == maxOffset + then do + let arr :: Array a = Array + { arrContents = mba + , arrStart = 0 + , arrEnd = patBytes + } + let ringHash = Array.foldl' addCksum 0 arr + if ringHash == patHash && Array.byteEq arr patArr + then Done <$> ffinal s1 + else return $ Partial $ SplitOnSeqKRLoop s1 ringHash mba 0 + else + return $ Partial $ SplitOnSeqKR s1 (offset + SIZE_OF(a)) mba + Done b -> return $ Done b + step (SplitOnSeqKRLoop s cksum mba offset) x = do + res <- fstep s x + case res of + Partial s1 -> do + let rb = RingArray + { ringContents = mba + , ringSize = patBytes + , ringHead = offset + } + (rb1, old :: a) <- liftIO (RingArray.replace rb x) + let ringHash = deltaCksum cksum old x + let rh1 = ringHead rb1 + matches <- + if ringHash == patHash + then liftIO $ RingArray.eqArray rb1 patArr + else return False + if matches + then Done <$> ffinal s1 + else return $ Partial $ SplitOnSeqKRLoop s1 ringHash mba rh1 + Done b -> return $ Done b + + extractFunc fex state = + let st = + case state of + SplitOnSeqEmpty s -> s + SplitOnSeqSingle s _ -> s + SplitOnSeqWord s _ _ -> s + SplitOnSeqWordLoop s _ -> s + SplitOnSeqKR s _ _ -> s + SplitOnSeqKRLoop s _ _ _ -> s + in fex st + + extract = extractFunc fextract + + final = extractFunc ffinal + +-- | Like 'takeEndBySeq' but discards the matched sequence. +-- +-- >>> s = Stream.fromList "Gauss---Euler---Noether" +-- >>> f = Fold.takeEndBySeq_ (Array.fromList "---") Fold.toList +-- >>> Stream.fold f s +-- "Gauss" +-- +-- >>> Stream.fold Fold.toList $ Stream.foldMany f s +-- ["Gauss","Euler","Noether"] +-- +-- See also: 'Streamly.Data.Stream.splitOnSeq' and +-- 'Streamly.Data.Stream.splitEndBySeq_'. +-- +-- /Pre-release/ +-- +{-# INLINE takeEndBySeq_ #-} +takeEndBySeq_ :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => + Array.Array a + -> Fold m a b + -> Fold m a b +takeEndBySeq_ patArr (Fold fstep finitial fextract ffinal) = + Fold step initial extract final + + where + + patLen = Array.length patArr + patBytes = Array.byteLength patArr + maxIndex = patLen - 1 + maxOffset = patBytes - SIZE_OF(a) + + initial = do + res <- finitial + case res of + Partial acc + | patLen == 0 -> + -- XXX Should we match nothing or everything on empty + -- pattern? + -- Done <$> ffinal acc + return $ Partial $ SplitOnSeqEmpty acc + | patLen == 1 -> do + pat <- liftIO $ Array.unsafeGetIndexIO 0 patArr + return $ Partial $ SplitOnSeqSingle acc pat + -- XXX Need to add tests for this case + | SIZE_OF(a) * patLen <= sizeOf (Proxy :: Proxy Word) -> + return $ Partial $ SplitOnSeqWord acc 0 0 + | otherwise -> do + (MutArray mba _ _ _) :: MutArray a <- + liftIO $ MA.emptyOf patLen + return $ Partial $ SplitOnSeqKR acc 0 mba + Done b -> return $ Done b + + -- Word pattern related + elemBits = SIZE_OF(a) * 8 + + wordMask :: Word + wordMask = (1 `shiftL` (elemBits * patLen)) - 1 + + elemMask :: Word + elemMask = (1 `shiftL` elemBits) - 1 + + wordPat :: Word + wordPat = wordMask .&. Array.foldl' addToWord 0 patArr + + addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) + + -- For Rabin-Karp search + k = 2891336453 :: Word32 + coeff = k ^ patLen + + addCksum cksum a = cksum * k + fromIntegral (fromEnum a) + + deltaCksum cksum old new = + addCksum cksum new - coeff * fromIntegral (fromEnum old) + + -- XXX shall we use a random starting hash or 1 instead of 0? + -- XXX Need to keep this cached across fold calls in foldMany + -- XXX We may need refold to inject the cached state instead of + -- initializing the state every time. + -- XXX Allocation of ring buffer should also be done once + patHash = Array.foldl' addCksum 0 patArr + + step (SplitOnSeqEmpty s) x = do + res <- fstep s x + case res of + Partial s1 -> return $ Partial $ SplitOnSeqEmpty s1 + Done b -> return $ Done b + step (SplitOnSeqSingle s pat) x = do + if pat /= x + then do + res <- fstep s x + case res of + Partial s1 -> return $ Partial $ SplitOnSeqSingle s1 pat + Done b -> return $ Done b + else Done <$> ffinal s + step (SplitOnSeqWord s idx wrd) x = do + let wrd1 = addToWord wrd x + if idx == maxIndex + then do + if wrd1 .&. wordMask == wordPat + then Done <$> ffinal s + else return $ Partial $ SplitOnSeqWordLoop s wrd1 + else return $ Partial $ SplitOnSeqWord s (idx + 1) wrd1 + step (SplitOnSeqWordLoop s wrd) x = do + let wrd1 = addToWord wrd x + old = (wordMask .&. wrd) + `shiftR` (elemBits * (patLen - 1)) + res <- fstep s (toEnum $ fromIntegral old) + case res of + Partial s1 + | wrd1 .&. wordMask == wordPat -> + Done <$> ffinal s1 + | otherwise -> + return $ Partial $ SplitOnSeqWordLoop s1 wrd1 + Done b -> return $ Done b + step (SplitOnSeqKR s offset mba) x = do + liftIO $ pokeAt offset mba x + if offset == maxOffset + then do + let arr :: Array a = Array + { arrContents = mba + , arrStart = 0 + , arrEnd = patBytes + } + let ringHash = Array.foldl' addCksum 0 arr + if ringHash == patHash && Array.byteEq arr patArr + then Done <$> ffinal s + else return $ Partial $ SplitOnSeqKRLoop s ringHash mba 0 + else return $ Partial $ SplitOnSeqKR s (offset + SIZE_OF(a)) mba + step (SplitOnSeqKRLoop s cksum mba offset) x = do + let rb = RingArray + { ringContents = mba + , ringSize = patBytes + , ringHead = offset + } + (rb1, old :: a) <- liftIO (RingArray.replace rb x) + res <- fstep s old + case res of + Partial s1 -> do + let ringHash = deltaCksum cksum old x + let rh1 = ringHead rb1 + matches <- + if ringHash == patHash + then liftIO $ RingArray.eqArray rb1 patArr + else return False + if matches + then Done <$> ffinal s1 + else return $ Partial $ SplitOnSeqKRLoop s1 ringHash mba rh1 + Done b -> return $ Done b + + -- XXX extract should return backtrack count as well. If the fold + -- terminates early inside extract, we may still have buffered data + -- remaining which will be lost if we do not communicate that to the + -- driver. + extractFunc fex state = do + let consumeWord s n wrd = do + if n == 0 + then fex s + else do + let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1))) + r <- fstep s (toEnum $ fromIntegral old) + case r of + Partial s1 -> consumeWord s1 (n - 1) wrd + Done b -> return b + + let consumeArray s end mba offset = + if offset == end + then fex s + else do + old <- liftIO $ peekAt offset mba + r <- fstep s old + case r of + Partial s1 -> + consumeArray s1 end mba (offset + SIZE_OF(a)) + Done b -> return b + + let consumeRing s orig mba offset = do + let rb :: RingArray a = RingArray + { ringContents = mba + , ringSize = patBytes + , ringHead = offset + } + old <- RingArray.unsafeGetHead rb + let rb1 = RingArray.moveForward rb + r <- fstep s old + case r of + Partial s1 -> + let rh = ringHead rb1 + in if rh == orig + then fex s1 + else consumeRing s1 orig mba rh + Done b -> return b + + case state of + SplitOnSeqEmpty s -> fex s + SplitOnSeqSingle s _ -> fex s + SplitOnSeqWord s idx wrd -> consumeWord s idx wrd + SplitOnSeqWordLoop s wrd -> consumeWord s patLen wrd + SplitOnSeqKR s end mba -> consumeArray s end mba 0 + SplitOnSeqKRLoop s _ mba rh -> consumeRing s rh mba rh + + extract = extractFunc fextract + + final = extractFunc ffinal + +------------------------------------------------------------------------------ +-- Distributing +------------------------------------------------------------------------------ +-- +-- | Distribute one copy of the stream to each fold and zip the results. +-- +-- @ +-- |-------Fold m a b--------| +-- ---stream m a---| |---m (b,c) +-- |-------Fold m a c--------| +-- @ +-- +-- Definition: +-- +-- >>> tee = Fold.teeWith (,) +-- +-- Example: +-- +-- >>> t = Fold.tee Fold.sum Fold.length +-- >>> Stream.fold t (Stream.enumerateFromTo 1.0 100.0) +-- (5050.0,100) +-- +{-# INLINE tee #-} +tee :: Monad m => Fold m a b -> Fold m a c -> Fold m a (b,c) +tee = teeWith (,) + +-- XXX use "List" instead of "[]"?, use Array for output to scale it to a large +-- number of consumers? For polymorphic case a vector could be helpful. For +-- Unboxs we can use arrays. Will need separate APIs for those. +-- +-- | Distribute one copy of the stream to each fold and collect the results in +-- a container. +-- +-- @ +-- +-- |-------Fold m a b--------| +-- ---stream m a---| |---m [b] +-- |-------Fold m a b--------| +-- | | +-- ... +-- @ +-- +-- >>> Stream.fold (Fold.distribute [Fold.sum, Fold.length]) (Stream.enumerateFromTo 1 5) +-- [15,5] +-- +-- >>> distribute = Prelude.foldr (Fold.teeWith (:)) (Fold.fromPure []) +-- +-- This is the consumer side dual of the producer side 'sequence' operation. +-- +-- Stops when all the folds stop. +-- +{-# INLINE distribute #-} +distribute :: Monad m => [Fold m a b] -> Fold m a [b] +distribute = Prelude.foldr (teeWith (:)) (fromPure []) + +-- XXX use mutable cells for better performance. + +-- | Distribute the input to the folds returned by an effect. The effect is +-- executed every time an input is processed, and the folds returned by it are +-- added to the distribution list. The scan returns the results of the folds as +-- they complete. To avoid adding the same folds repeatedly, the action must +-- return the folds only once e.g. it can be implemented using modifyIORef +-- replacing the original value by an empty list before returning it. +-- +-- >>> import Data.IORef +-- >>> ref <- newIORef [Fold.take 2 Fold.sum, Fold.take 2 Fold.length :: Fold IO Int Int] +-- >>> gen = atomicModifyIORef ref (\xs -> ([], xs)) +-- >>> Stream.toList $ Stream.scanl (Fold.distributeScan gen) (Stream.enumerateFromTo 1 10) +-- [[],[],[],[2,3],[],[],[],[],[],[],[]] +-- +{-# INLINE distributeScan #-} +distributeScan :: Monad m => m [Fold m a b] -> Scanl m a [b] +distributeScan getFolds = Scanl consume initial extract final + + where + + initial = return $ Partial (Tuple' [] []) + + run st [] _ = return $ Partial st + run (Tuple' ys zs) (Fold step init extr fin : xs) a = do + res <- init + case res of + Partial fs -> do + r <- step fs a + run (Tuple' (Fold step (return r) extr fin : ys) zs) xs a + Done b -> do + run (Tuple' ys (b : zs)) xs a + + consume (Tuple' st _) x = do + xs <- getFolds + xs1 <- Prelude.mapM reduce xs + let st1 = st ++ xs1 + run (Tuple' [] []) st1 x + + extract (Tuple' _ done) = return done + + final (Tuple' st done) = do + Prelude.mapM_ finalM st + return done + +------------------------------------------------------------------------------ +-- Partitioning +------------------------------------------------------------------------------ + +{-# INLINE partitionByMUsing #-} +partitionByMUsing :: Monad m => + ( (x -> y -> (x, y)) + -> Fold m (Either b c) x + -> Fold m (Either b c) y + -> Fold m (Either b c) (x, y) + ) + -> (a -> m (Either b c)) + -> Fold m b x + -> Fold m c y + -> Fold m a (x, y) +partitionByMUsing t f fld1 fld2 = + let l = lmap (fromLeft undefined) fld1 -- :: Fold m (Either b c) x + r = lmap (fromRight undefined) fld2 -- :: Fold m (Either b c) y + in lmapM f (t (,) (filter isLeft l) (filter isRight r)) + +-- | Partition the input over two folds using an 'Either' partitioning +-- predicate. +-- +-- @ +-- +-- |-------Fold b x--------| +-- -----stream m a --> (Either b c)----| |----(x,y) +-- |-------Fold c y--------| +-- @ +-- +-- Example, send input to either fold randomly: +-- +-- >>> :set -package random +-- >>> import System.Random (randomIO) +-- >>> randomly a = randomIO >>= \x -> return $ if x then Left a else Right a +-- >>> f = Fold.partitionByM randomly Fold.length Fold.length +-- >>> Stream.fold f (Stream.enumerateFromTo 1 100) +-- ... +-- +-- Example, send input to the two folds in a proportion of 2:1: +-- +-- >>> :set -fno-warn-unrecognised-warning-flags +-- >>> :set -fno-warn-x-partial +-- >>> :{ +-- proportionately m n = do +-- ref <- newIORef $ cycle $ concat [replicate m Left, replicate n Right] +-- return $ \a -> do +-- r <- readIORef ref +-- writeIORef ref $ tail r +-- return $ Prelude.head r a +-- :} +-- +-- >>> :{ +-- main = do +-- g <- proportionately 2 1 +-- let f = Fold.partitionByM g Fold.length Fold.length +-- r <- Stream.fold f (Stream.enumerateFromTo (1 :: Int) 100) +-- print r +-- :} +-- +-- >>> main +-- (67,33) +-- +-- +-- This is the consumer side dual of the producer side 'mergeBy' operation. +-- +-- When one fold is done, any input meant for it is ignored until the other +-- fold is also done. +-- +-- Stops when both the folds stop. +-- +-- /See also: 'partitionByFstM' and 'partitionByMinM'./ +-- +-- /Pre-release/ +{-# INLINE partitionByM #-} +partitionByM :: Monad m + => (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y) +partitionByM = partitionByMUsing teeWith + +-- | Similar to 'partitionByM' but terminates when the first fold terminates. +-- +{-# INLINE partitionByFstM #-} +partitionByFstM :: Monad m + => (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y) +partitionByFstM = partitionByMUsing teeWithFst + +-- | Similar to 'partitionByM' but terminates when any fold terminates. +-- +{-# INLINE partitionByMinM #-} +partitionByMinM :: Monad m => + (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y) +partitionByMinM = partitionByMUsing teeWithMin + +-- Note: we could use (a -> Bool) instead of (a -> Either b c), but the latter +-- makes the signature clearer as to which case belongs to which fold. +-- XXX need to check the performance in both cases. + +-- | Same as 'partitionByM' but with a pure partition function. +-- +-- Example, count even and odd numbers in a stream: +-- +-- >>> :{ +-- let f = Fold.partitionBy (\n -> if even n then Left n else Right n) +-- (fmap (("Even " ++) . show) Fold.length) +-- (fmap (("Odd " ++) . show) Fold.length) +-- in Stream.fold f (Stream.enumerateFromTo 1 100) +-- :} +-- ("Even 50","Odd 50") +-- +-- /Pre-release/ +{-# INLINE partitionBy #-} +partitionBy :: Monad m + => (a -> Either b c) -> Fold m b x -> Fold m c y -> Fold m a (x, y) +partitionBy f = partitionByM (return . f) + +-- | Compose two folds such that the combined fold accepts a stream of 'Either' +-- and routes the 'Left' values to the first fold and 'Right' values to the +-- second fold. +-- +-- Definition: +-- +-- >>> partition = Fold.partitionBy id +-- +{-# INLINE partition #-} +partition :: Monad m + => Fold m b x -> Fold m c y -> Fold m (Either b c) (x, y) +partition = partitionBy id + +{- +-- | Send one item to each fold in a round-robin fashion. This is the consumer +-- side dual of producer side 'mergeN' operation. +-- +-- partitionN :: Monad m => [Fold m a b] -> Fold m a [b] +-- partitionN fs = Fold step begin done +-} + +------------------------------------------------------------------------------ +-- Unzipping +------------------------------------------------------------------------------ + +{-# INLINE unzipWithMUsing #-} +unzipWithMUsing :: Monad m => + ( (x -> y -> (x, y)) + -> Fold m (b, c) x + -> Fold m (b, c) y + -> Fold m (b, c) (x, y) + ) + -> (a -> m (b, c)) + -> Fold m b x + -> Fold m c y + -> Fold m a (x, y) +unzipWithMUsing t f fld1 fld2 = + let f1 = lmap fst fld1 -- :: Fold m (b, c) b + f2 = lmap snd fld2 -- :: Fold m (b, c) c + in lmapM f (t (,) f1 f2) + +-- | Like 'unzipWith' but with a monadic splitter function. +-- +-- Definition: +-- +-- >>> unzipWithM k f1 f2 = Fold.lmapM k (Fold.unzip f1 f2) +-- +-- /Pre-release/ +{-# INLINE unzipWithM #-} +unzipWithM :: Monad m + => (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y) +unzipWithM = unzipWithMUsing teeWith + +-- | Similar to 'unzipWithM' but terminates when the first fold terminates. +-- +{-# INLINE unzipWithFstM #-} +unzipWithFstM :: Monad m => + (a -> m (b, c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y) +unzipWithFstM = unzipWithMUsing teeWithFst + +-- | Similar to 'unzipWithM' but terminates when any fold terminates. +-- +{-# INLINE unzipWithMinM #-} +unzipWithMinM :: Monad m => + (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y) +unzipWithMinM = unzipWithMUsing teeWithMin + +-- | Split elements in the input stream into two parts using a pure splitter +-- function, direct each part to a different fold and zip the results. +-- +-- Definitions: +-- +-- >>> unzipWith f = Fold.unzipWithM (return . f) +-- >>> unzipWith f fld1 fld2 = Fold.lmap f (Fold.unzip fld1 fld2) +-- +-- This fold terminates when both the input folds terminate. +-- +-- /Pre-release/ +{-# INLINE unzipWith #-} +unzipWith :: Monad m + => (a -> (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y) +unzipWith f = unzipWithM (return . f) + +-- | Send the elements of tuples in a stream of tuples through two different +-- folds. +-- +-- @ +-- +-- |-------Fold m a x--------| +-- ---------stream of (a,b)--| |----m (x,y) +-- |-------Fold m b y--------| +-- +-- @ +-- +-- Definition: +-- +-- >>> unzip = Fold.unzipWith id +-- +-- This is the consumer side dual of the producer side 'zip' operation. +-- +{-# INLINE unzip #-} +unzip :: Monad m => Fold m a x -> Fold m b y -> Fold m (a,b) (x,y) +unzip = unzipWith id + +------------------------------------------------------------------------------ +-- Combining streams and folds - Zipping +------------------------------------------------------------------------------ + +-- XXX These can be implemented using the fold scan, using the stream as a +-- state. +-- XXX Stream Skip state cannot be efficiently handled in folds but can be +-- handled in parsers using the Continue facility. See zipWithM in the Parser +-- module. +-- +-- cmpBy, eqBy, isPrefixOf, isSubsequenceOf etc can be implemented using +-- zipStream. + +-- | Zip a stream with the input of a fold using the supplied function. +-- +-- /Unimplemented/ +-- +{-# INLINE zipStreamWithM #-} +zipStreamWithM :: -- Monad m => + (a -> b -> m c) -> Stream m a -> Fold m c x -> Fold m b x +zipStreamWithM = undefined + +-- | Zip a stream with the input of a fold. +-- +-- >>> zip = Fold.zipStreamWithM (curry return) +-- +-- /Unimplemented/ +-- +{-# INLINE zipStream #-} +zipStream :: Monad m => Stream m a -> Fold m (a, b) x -> Fold m b x +zipStream = zipStreamWithM (curry return) + +-- | Pair each element of a fold input with its index, starting from index 0. +-- +{-# DEPRECATED indexingWith "Use Scanl.indexingWith instead" #-} +{-# INLINE indexingWith #-} +indexingWith :: Monad m => Int -> (Int -> Int) -> Fold m a (Maybe (Int, a)) +indexingWith i f = fmap toMaybe $ foldl' step initial + + where + + initial = Nothing' + + step Nothing' a = Just' (i, a) + step (Just' (n, _)) a = Just' (f n, a) + +-- | +-- >> indexing = Fold.indexingWith 0 (+ 1) +-- +{-# DEPRECATED indexing "Use Scanl.indexing instead" #-} +{-# INLINE indexing #-} +indexing :: Monad m => Fold m a (Maybe (Int, a)) +indexing = indexingWith 0 (+ 1) + +-- | +-- >> indexingRev n = Fold.indexingWith n (subtract 1) +-- +{-# DEPRECATED indexingRev "Use Scanl.indexingRev instead" #-} +{-# INLINE indexingRev #-} +indexingRev :: Monad m => Int -> Fold m a (Maybe (Int, a)) +indexingRev n = indexingWith n (subtract 1) + +-- | Pair each element of a fold input with its index, starting from index 0. +-- +-- >>> indexed = Fold.postscanlMaybe Scanl.indexing +-- +{-# INLINE indexed #-} +indexed :: Monad m => Fold m (Int, a) b -> Fold m a b +indexed = postscanlMaybe Scanl.indexing + +-- | Change the predicate function of a Fold from @a -> b@ to accept an +-- additional state input @(s, a) -> b@. Convenient to filter with an +-- addiitonal index or time input. +-- +-- >>> filterWithIndex = Fold.with Fold.indexed Fold.filter +-- +-- @ +-- filterWithAbsTime = with timestamped filter +-- filterWithRelTime = with timeIndexed filter +-- @ +-- +-- /Pre-release/ +{-# INLINE with #-} +with :: + (Fold m (s, a) b -> Fold m a b) + -> (((s, a) -> c) -> Fold m (s, a) b -> Fold m (s, a) b) + -> (((s, a) -> c) -> Fold m a b -> Fold m a b) +with f comb g = f . comb g . lmap snd + +-- XXX Implement as a filter +-- sampleFromthen :: Monad m => Int -> Int -> Fold m a (Maybe a) + +-- | @sampleFromthen offset stride@ samples the element at @offset@ index and +-- then every element at strides of @stride@. +-- +{-# INLINE sampleFromthen #-} +sampleFromthen :: Monad m => Int -> Int -> Fold m a b -> Fold m a b +sampleFromthen offset size = + with indexed filter (\(i, _) -> (i + offset) `mod` size == 0) + +------------------------------------------------------------------------------ +-- Nesting +------------------------------------------------------------------------------ + +-- | @concatSequence f t@ applies folds from stream @t@ sequentially and +-- collects the results using the fold @f@. +-- +-- /Unimplemented/ +-- +{-# INLINE concatSequence #-} +concatSequence :: + -- IsStream t => + Fold m b c -> t (Fold m a b) -> Fold m a c +concatSequence _f _p = undefined + +-- | Group the input stream into groups of elements between @low@ and @high@. +-- Collection starts in chunks of @low@ and then keeps doubling until we reach +-- @high@. Each chunk is folded using the provided fold function. +-- +-- This could be useful, for example, when we are folding a stream of unknown +-- size to a stream of arrays and we want to minimize the number of +-- allocations. +-- +-- NOTE: this would be an application of "many" using a terminating fold. +-- +-- /Unimplemented/ +-- +{-# INLINE chunksBetween #-} +chunksBetween :: -- Monad m => + Int -> Int -> Fold m a b -> Fold m b c -> Fold m a c +chunksBetween _low _high _f1 _f2 = undefined + +-- | A fold that buffers its input to a pure stream. +-- +-- /Warning!/ working on large streams accumulated as buffers in memory could +-- be very inefficient, consider using "Streamly.Data.Array" instead. +-- +-- >>> toStream = fmap Stream.fromList Fold.toList +-- +-- /Pre-release/ +{-# INLINE toStream #-} +toStream :: (Monad m, Monad n) => Fold m a (Stream n a) +toStream = fromScanl Scanl.toStream + +-- This is more efficient than 'toStream'. toStream is exactly the same as +-- reversing the stream after toStreamRev. +-- +-- | Buffers the input stream to a pure stream in the reverse order of the +-- input. +-- +-- >>> toStreamRev = fmap Stream.fromList Fold.toListRev +-- +-- /Warning!/ working on large streams accumulated as buffers in memory could +-- be very inefficient, consider using "Streamly.Data.Array" instead. +-- +-- /Pre-release/ + +-- xn : ... : x2 : x1 : [] +{-# INLINE toStreamRev #-} +toStreamRev :: (Monad m, Monad n) => Fold m a (Stream n a) +toStreamRev = fromScanl Scanl.toStreamRev + +-- XXX This does not fuse. It contains a recursive step function. We will need +-- a Skip input constructor in the fold type to make it fuse. +-- +-- | Unfold and flatten the input stream of a fold. +-- +-- @ +-- Stream.fold (unfoldMany u f) = Stream.fold f . Stream.unfoldMany u +-- @ +-- +-- /Pre-release/ +{-# INLINE unfoldMany #-} +unfoldMany :: Monad m => Unfold m a b -> Fold m b c -> Fold m a c +unfoldMany (Unfold ustep inject) (Fold fstep initial extract final) = + Fold consume initial extract final + + where + + {-# INLINE produce #-} + produce fs us = do + ures <- ustep us + case ures of + StreamD.Yield b us1 -> do + fres <- fstep fs b + case fres of + Partial fs1 -> produce fs1 us1 + -- XXX What to do with the remaining stream? + Done c -> return $ Done c + StreamD.Skip us1 -> produce fs us1 + StreamD.Stop -> return $ Partial fs + + {-# INLINE_LATE consume #-} + consume s a = inject a >>= produce s + +-- | Get the bottom most @n@ elements using the supplied comparison function. +-- +{-# INLINE bottomBy #-} +bottomBy :: (MonadIO m, Unbox a) => + (a -> a -> Ordering) + -> Int + -> Fold m a (MutArray a) +bottomBy cmp = fromScanl . Scanl.bottomBy cmp + +-- | Get the top @n@ elements using the supplied comparison function. +-- +-- To get bottom n elements instead: +-- +-- >>> bottomBy cmp = Fold.topBy (flip cmp) +-- +-- Example: +-- +-- >>> stream = Stream.fromList [2::Int,7,9,3,1,5,6,11,17] +-- >>> Stream.fold (Fold.topBy compare 3) stream >>= MutArray.toList +-- [17,11,9] +-- +-- /Pre-release/ +-- +{-# INLINE topBy #-} +topBy :: (MonadIO m, Unbox a) => + (a -> a -> Ordering) + -> Int + -> Fold m a (MutArray a) +topBy cmp = bottomBy (flip cmp) + +-- | Fold the input stream to top n elements. +-- +-- Definition: +-- +-- >>> top = Fold.topBy compare +-- +-- >>> stream = Stream.fromList [2::Int,7,9,3,1,5,6,11,17] +-- >>> Stream.fold (Fold.top 3) stream >>= MutArray.toList +-- [17,11,9] +-- +-- /Pre-release/ +{-# INLINE top #-} +top :: (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (MutArray a) +top = fromScanl . Scanl.top + +-- | Fold the input stream to bottom n elements. +-- +-- Definition: +-- +-- >>> bottom = Fold.bottomBy compare +-- +-- >>> stream = Stream.fromList [2::Int,7,9,3,1,5,6,11,17] +-- >>> Stream.fold (Fold.bottom 3) stream >>= MutArray.toList +-- [1,2,3] +-- +-- /Pre-release/ +{-# INLINE bottom #-} +bottom :: (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (MutArray a) +bottom = fromScanl . Scanl.bottom + +------------------------------------------------------------------------------ +-- Interspersed parsing +------------------------------------------------------------------------------ + +data IntersperseQState fs ps = + IntersperseQUnquoted !fs !ps + | IntersperseQQuoted !fs !ps + | IntersperseQQuotedEsc !fs !ps + +-- Useful for parsing CSV with quoting and escaping +{-# INLINE intersperseWithQuotes #-} +intersperseWithQuotes :: (Monad m, Eq a) => + a -> a -> a -> Fold m a b -> Fold m b c -> Fold m a c +intersperseWithQuotes + quote + esc + separator + (Fold stepL initialL _ finalL) + (Fold stepR initialR extractR finalR) = Fold step initial extract final + + where + + errMsg p status = + error $ "intersperseWithQuotes: " ++ p ++ " parsing fold cannot " + ++ status ++ " without input" + + {-# INLINE initL #-} + initL mkState = do + resL <- initialL + case resL of + Partial sL -> + return $ Partial $ mkState sL + Done _ -> + errMsg "content" "succeed" + + initial = do + res <- initialR + case res of + Partial sR -> initL (IntersperseQUnquoted sR) + Done b -> return $ Done b + + {-# INLINE collect #-} + collect nextS sR b = do + res <- stepR sR b + case res of + Partial s -> + initL (nextS s) + Done c -> return (Done c) + + {-# INLINE process #-} + process a sL sR nextState = do + r <- stepL sL a + case r of + Partial s -> return $ Partial (nextState sR s) + Done b -> collect nextState sR b + + {-# INLINE processQuoted #-} + processQuoted a sL sR nextState = do + r <- stepL sL a + case r of + Partial s -> return $ Partial (nextState sR s) + Done _ -> do + _ <- finalR sR + error "Collecting fold finished inside quote" + + step (IntersperseQUnquoted sR sL) a + | a == separator = do + b <- finalL sL + collect IntersperseQUnquoted sR b + | a == quote = processQuoted a sL sR IntersperseQQuoted + | otherwise = process a sL sR IntersperseQUnquoted + + step (IntersperseQQuoted sR sL) a + | a == esc = processQuoted a sL sR IntersperseQQuotedEsc + | a == quote = process a sL sR IntersperseQUnquoted + | otherwise = processQuoted a sL sR IntersperseQQuoted + + step (IntersperseQQuotedEsc sR sL) a = + processQuoted a sL sR IntersperseQQuoted + + extract (IntersperseQUnquoted sR _) = extractR sR + extract (IntersperseQQuoted _ _) = + error "intersperseWithQuotes: finished inside quote" + extract (IntersperseQQuotedEsc _ _) = + error "intersperseWithQuotes: finished inside quote, at escape char" + + final (IntersperseQUnquoted sR sL) = finalL sL *> finalR sR + final (IntersperseQQuoted sR sL) = do + _ <- finalR sR + _ <- finalL sL + error "intersperseWithQuotes: finished inside quote" + final (IntersperseQQuotedEsc sR sL) = do + _ <- finalR sR + _ <- finalL sL + error "intersperseWithQuotes: finished inside quote, at escape char" diff --git a/src/Streamly/Internal/Data/Fold/Container.hs b/src/Streamly/Internal/Data/Fold/Container.hs --- a/src/Streamly/Internal/Data/Fold/Container.hs +++ b/src/Streamly/Internal/Data/Fold/Container.hs @@ -1,3 +1,11 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} + +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.Internal.Data.Fold.Container -- Copyright : (c) 2019 Composewell Technologies @@ -9,16 +17,13 @@ module Streamly.Internal.Data.Fold.Container ( - -- * Imports - -- $setup - -- * Set operations toSet , toIntSet , countDistinct , countDistinctInt - , nub - , nubInt + , nub -- XXX deprecate in favor of scan + , nubInt -- XXX deprecate in favor of scan -- * Map operations , frequency @@ -27,18 +32,31 @@ -- | Direct values in the input stream to different folds using an n-ary -- fold selector. 'demux' is a generalization of 'classify' (and -- 'partition') where each key of the classifier can use a different fold. + -- + -- You need to see only 'demux' if you are looking to find the capabilities + -- of these combinators, all others are variants of that. + + -- *** Output is a container + -- | Use key specific folds to fold corresponding values to a key-value + -- container. + , demuxerToContainer + , demuxerToContainerIO + , demuxerToMap + , demuxerToMapIO + + -- *** Input is explicit key-value tuple + -- | Like above but inputs are in explicit key-value pair form. , demuxKvToContainer , demuxKvToMap - , demuxToContainer - , demuxToContainerIO - , demuxToMap - , demuxToMapIO - - , demuxGeneric - , demux - , demuxGenericIO - , demuxIO + -- *** Scan of finished fold results + -- | Use key specific folds to fold corresponding values to a key-value + -- stream, restarts the fold again after it terminates, thus resulting in a + -- stream of values for each key. + , demuxScanGeneric + , demuxScan + , demuxScanGenericIO + , demuxScanIO -- TODO: These can be implemented using the above operations -- , demuxSel -- Stop when the fold for the specified key stops @@ -65,12 +83,27 @@ , toMap , toMapIO + , classifyScanGeneric + , classifyScan + , classifyScanGenericIO + , classifyScanIO + -- , toContainerSel + -- , toContainerMin + + -- * Deprecated + , demuxGeneric + , demux + , demuxGenericIO + , demuxIO + , demuxToContainer + , demuxToContainerIO + , demuxToMap + , demuxToMapIO + , classifyGeneric , classify , classifyGenericIO , classifyIO - -- , toContainerSel - -- , toContainerMin ) where @@ -83,24 +116,17 @@ import Data.IntSet (IntSet) import Data.Set (Set) import Streamly.Internal.Data.IsMap (IsMap(..)) +import Streamly.Internal.Data.Scanl.Type (Scanl(..)) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..)) -import qualified Data.IntSet as IntSet import qualified Data.Set as Set import qualified Streamly.Internal.Data.IsMap as IsMap +import qualified Streamly.Internal.Data.Scanl.Container as Scanl -import Prelude hiding (length) -import Streamly.Internal.Data.Fold +import Prelude hiding (Foldable(..)) +import Streamly.Internal.Data.Fold.Type --- $setup --- >>> :m --- >>> :set -XFlexibleContexts --- >>> import qualified Data.Map as Map --- >>> import qualified Data.Set as Set --- >>> import qualified Data.IntSet as IntSet --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Stream as Stream --- >>> import qualified Streamly.Internal.Data.Fold.Container as Fold +#include "DocTestDataFold.hs" -- | Fold the input to a set. -- @@ -110,7 +136,7 @@ -- {-# INLINE toSet #-} toSet :: (Monad m, Ord a) => Fold m a (Set a) -toSet = foldl' (flip Set.insert) Set.empty +toSet = fromScanl Scanl.toSet -- | Fold the input to an int set. For integer inputs this performs better than -- 'toSet'. @@ -121,7 +147,7 @@ -- {-# INLINE toIntSet #-} toIntSet :: Monad m => Fold m Int IntSet -toIntSet = foldl' (flip IntSet.insert) IntSet.empty +toIntSet = fromScanl Scanl.toIntSet -- XXX Name as nubOrd? Or write a nubGeneric @@ -131,38 +157,21 @@ -- Example: -- -- >>> stream = Stream.fromList [1::Int,1,2,3,4,4,5,1,5,7] --- >>> Stream.fold Fold.toList $ Stream.scanMaybe Fold.nub stream +-- +-- >> Stream.toList $ Stream.scanMaybe Fold.nub stream -- [1,2,3,4,5,7] -- -- /Pre-release/ {-# INLINE nub #-} nub :: (Monad m, Ord a) => Fold m a (Maybe a) -nub = fmap (\(Tuple' _ x) -> x) $ foldl' step initial - - where - - initial = Tuple' Set.empty Nothing - - step (Tuple' set _) x = - if Set.member x set - then Tuple' set Nothing - else Tuple' (Set.insert x set) (Just x) +nub = fromScanl Scanl.nub -- | Like 'nub' but specialized to a stream of 'Int', for better performance. -- -- /Pre-release/ {-# INLINE nubInt #-} nubInt :: Monad m => Fold m Int (Maybe Int) -nubInt = fmap (\(Tuple' _ x) -> x) $ foldl' step initial - - where - - initial = Tuple' IntSet.empty Nothing - - step (Tuple' set _) x = - if IntSet.member x set - then Tuple' set Nothing - else Tuple' (IntSet.insert x set) (Just x) +nubInt = fromScanl Scanl.nubInt -- XXX Try Hash set -- XXX Add a countDistinct window fold @@ -173,7 +182,7 @@ -- Definition: -- -- >>> countDistinct = fmap Set.size Fold.toSet --- >>> countDistinct = Fold.postscan Fold.nub $ Fold.catMaybes $ Fold.length +-- >>> countDistinct = Fold.postscanl Scanl.nub $ Fold.catMaybes $ Fold.length -- -- The memory used is proportional to the number of distinct elements in the -- stream, to guard against using too much memory use it as a scan and @@ -186,7 +195,7 @@ {-# INLINE countDistinct #-} countDistinct :: (Monad m, Ord a) => Fold m a Int -- countDistinct = postscan nub $ catMaybes length -countDistinct = fmap Set.size toSet +countDistinct = fromScanl Scanl.countDistinct {- countDistinct = fmap (\(Tuple' _ n) -> n) $ foldl' step initial @@ -209,13 +218,13 @@ -- Definition: -- -- >>> countDistinctInt = fmap IntSet.size Fold.toIntSet --- >>> countDistinctInt = Fold.postscan Fold.nubInt $ Fold.catMaybes $ Fold.length +-- >>> countDistinctInt = Fold.postscanl Scanl.nubInt $ Fold.catMaybes $ Fold.length -- -- /Pre-release/ {-# INLINE countDistinctInt #-} countDistinctInt :: Monad m => Fold m Int Int -- countDistinctInt = postscan nubInt $ catMaybes length -countDistinctInt = fmap IntSet.size toIntSet +countDistinctInt = fromScanl Scanl.countDistinctInt {- countDistinctInt = fmap (\(Tuple' _ n) -> n) $ foldl' step initial @@ -245,25 +254,33 @@ -- -- XXX If we use Refold in it, it can perhaps fuse/be more efficient. For -- example we can store just the result rather than storing the whole fold in --- the Map. +-- the Map. This would be similar to a refold based classify. -- -- Note: There are separate functions to determine Key and Fold from the input -- because key is to be determined on each input whereas fold is to be -- determined only once for a key. +-- +-- XXX Should we use (k -> m (Fold m a b)) instead since the fold is key +-- specific? This should give better safety. +-- | This is the most general of all demux, classify operations. +-- +-- See 'demux' for documentation. +{-# DEPRECATED demuxGeneric "Use demuxScanGeneric instead" #-} {-# INLINE demuxGeneric #-} demuxGeneric :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (m (f b), Maybe (Key f, b)) -demuxGeneric getKey getFold = fmap extract $ foldlM' step initial +demuxGeneric getKey getFold = + Fold (\s a -> Partial <$> step s a) (Partial <$> initial) extract final where initial = return $ Tuple' IsMap.mapEmpty Nothing {-# INLINE runFold #-} - runFold kv (Fold step1 initial1 extract1) (k, a) = do + runFold kv (Fold step1 initial1 extract1 final1) (k, a) = do res <- initial1 case res of Partial s -> do @@ -271,10 +288,14 @@ return $ case res1 of Partial _ -> - let fld = Fold step1 (return res1) extract1 + let fld = Fold step1 (return res1) extract1 final1 in Tuple' (IsMap.mapInsert k fld kv) Nothing Done b -> Tuple' (IsMap.mapDelete k kv) (Just (k, b)) - Done b -> return $ Tuple' kv (Just (k, b)) + Done b -> + -- Done in "initial" is possible only for the very first time + -- the fold is initialized, and in that case we have not yet + -- inserted it in the Map, so we do not need to delete it. + return $ Tuple' kv (Just (k, b)) step (Tuple' kv _) a = do let k = getKey a @@ -284,27 +305,177 @@ runFold kv fld (k, a) Just f -> runFold kv f (k, a) - extract (Tuple' kv x) = (Prelude.mapM f kv, x) + extract (Tuple' kv x) = return (Prelude.mapM f kv, x) where - f (Fold _ i e) = do + f (Fold _ i e _) = do r <- i case r of Partial s -> e s - Done b -> return b + _ -> error "demuxGeneric: unreachable code" --- | In a key value stream, fold values corresponding to each key with a key --- specific fold. The fold returns the fold result as the second component of --- the output tuple whenever a fold terminates. The first component of the --- tuple is a Map of in-progress folds. If a fold terminates, another --- instance of the fold is started upon receiving an input with that key. + final (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f (Fold _ i _ fin) = do + r <- i + case r of + Partial s -> fin s + _ -> error "demuxGeneric: unreachable code" + +-- XXX There seem to be a significant difference in demux and classify. In +-- demux once a key is done we again restart it and give the result of the +-- last one. In classify, we do not restart once it is done. To keep it +-- simple we should use the classify behavior. + +-- | This is the most general of all demux, classify operations. -- +-- See 'demux' for documentation. +{-# INLINE demuxerToContainer #-} +demuxerToContainer :: (Monad m, IsMap f, Traversable f) => + (a -> Key f) + -> (Key f -> m (Maybe (Fold m a b))) + -> Fold m a (f b) +demuxerToContainer getKey getFold = + Fold (\s a -> Partial <$> step s a) (Partial <$> initial) undefined final + + where + + initial = return $ Tuple' IsMap.mapEmpty IsMap.mapEmpty + + {-# INLINE runFold #-} + runFold kv kv1 (Fold step1 initial1 _ final1) (k, a) = do + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + return + $ case res1 of + Partial _ -> + let fld = Fold step1 (return res1) undefined final1 + in Tuple' (IsMap.mapInsert k fld kv) kv1 + Done b -> + Tuple' + (IsMap.mapDelete k kv) + (IsMap.mapInsert k b kv1) + Done b -> + -- Done in "initial" is possible only for the very first time + -- the fold is initialized, and in that case we have not yet + -- inserted it in the Map, so we do not need to delete it. + return $ Tuple' kv (IsMap.mapInsert k b kv1) + + step (Tuple' kv kv1) a = do + let k = getKey a + case IsMap.mapLookup k kv of + Nothing -> do + mfld <- getFold k + case mfld of + Nothing -> pure $ Tuple' kv kv1 + Just fld -> runFold kv kv1 fld (k, a) + Just f -> runFold kv kv1 f (k, a) + + final (Tuple' kv kv1) = do + r <- Prelude.mapM f kv + return $ IsMap.mapUnion r kv1 + + where + + f (Fold _ i _ fin) = do + r <- i + case r of + Partial s -> fin s + _ -> error "demuxerToContainer: unreachable code" + +-- | Scanning variant of 'demuxerToContainer'. +{-# INLINE demuxScanGeneric #-} +demuxScanGeneric :: (Monad m, IsMap f, Traversable f) => + (a -> Key f) + -> (Key f -> m (Maybe (Fold m a b))) + -> Scanl m a (m (f b), Maybe (Key f, b)) +demuxScanGeneric getKey getFold = + Scanl (\s a -> Partial <$> step s a) (Partial <$> initial) extract final + + where + + initial = return $ Tuple' IsMap.mapEmpty Nothing + + {-# INLINE runFold #-} + runFold kv (Fold step1 initial1 extract1 final1) (k, a) = do + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + return + $ case res1 of + Partial _ -> + let fld = Fold step1 (return res1) extract1 final1 + in Tuple' (IsMap.mapInsert k fld kv) Nothing + Done b -> Tuple' (IsMap.mapDelete k kv) (Just (k, b)) + Done b -> + -- Done in "initial" is possible only for the very first time + -- the fold is initialized, and in that case we have not yet + -- inserted it in the Map, so we do not need to delete it. + return $ Tuple' kv (Just (k, b)) + + step (Tuple' kv _) a = do + let k = getKey a + case IsMap.mapLookup k kv of + Nothing -> do + mfld <- getFold k + case mfld of + Nothing -> pure $ Tuple' kv Nothing + Just fld -> runFold kv fld (k, a) + Just f -> runFold kv f (k, a) + + extract (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f (Fold _ i e _) = do + r <- i + case r of + Partial s -> e s + _ -> error "demuxGeneric: unreachable code" + + final (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f (Fold _ i _ fin) = do + r <- i + case r of + Partial s -> fin s + _ -> error "demuxGeneric: unreachable code" + +-- | @demux getKey getFold@: In a key value stream, fold values corresponding +-- to each key using a key specific fold. @getFold@ is invoked to generate a +-- key specific fold when a key is encountered for the first time in the +-- stream. +-- +-- The first component of the output tuple is a key-value Map of in-progress +-- folds. The fold returns the fold result as the second component of the +-- output tuple whenever a fold terminates. +-- +-- If a fold terminates, another instance of the fold is started upon receiving +-- an input with that key, @getFold@ is invoked again whenever the key is +-- encountered again. +-- -- This can be used to scan a stream and collect the results from the scan -- output. -- +-- Since the fold generator function is monadic we can add folds dynamically. +-- For example, we can maintain a Map of keys to folds in an IORef and lookup +-- the fold from that corresponding to a key. This Map can be changed +-- dynamically, folds for new keys can be added or folds for old keys can be +-- deleted or modified. +-- +-- Compare with 'classify', the fold in 'classify' is a static fold. +-- -- /Pre-release/ -- +{-# DEPRECATED demux "Use demuxScan instead" #-} {-# INLINE demux #-} demux :: (Monad m, Ord k) => (a -> k) @@ -312,40 +483,66 @@ -> Fold m a (m (Map k b), Maybe (k, b)) demux = demuxGeneric +{-# INLINE demuxUsingMap #-} +demuxUsingMap :: (Monad m, Ord k) => + (a -> k) + -> (k -> m (Maybe (Fold m a b))) + -> Scanl m a (m (Map k b), Maybe (k, b)) +demuxUsingMap = demuxScanGeneric + +-- | Scanning variant of 'demuxerToMap'. +-- +-- TODO: To drain the final in-progress folds this requires the drain step of +-- Scanl to be streaming. +-- +{-# INLINE demuxScan #-} +demuxScan :: (Monad m, Ord k) => + (a -> k) + -> (k -> m (Maybe (Fold m a b))) + -> Scanl m a (Maybe (k, b)) +demuxScan getKey = fmap snd . demuxUsingMap getKey + +-- | This is specialized version of 'demuxGeneric' that uses mutable IO cells +-- as fold accumulators for better performance. +{-# DEPRECATED demuxGenericIO "Use demuxScanGenericIO instead" #-} {-# INLINE demuxGenericIO #-} demuxGenericIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (m (f b), Maybe (Key f, b)) -demuxGenericIO getKey getFold = fmap extract $ foldlM' step initial +demuxGenericIO getKey getFold = + Fold (\s a -> Partial <$> step s a) (Partial <$> initial) extract final where initial = return $ Tuple' IsMap.mapEmpty Nothing {-# INLINE initFold #-} - initFold kv (Fold step1 initial1 extract1) (k, a) = do + initFold kv (Fold step1 initial1 extract1 final1) (k, a) = do res <- initial1 case res of Partial s -> do res1 <- step1 s a case res1 of Partial _ -> do - let fld = Fold step1 (return res1) extract1 + -- XXX Instead of using a Fold type here use a custom + -- type with an IORef (possibly unboxed) for the + -- accumulator. That will reduce the allocations. + let fld = Fold step1 (return res1) extract1 final1 ref <- liftIO $ newIORef fld return $ Tuple' (IsMap.mapInsert k ref kv) Nothing Done b -> return $ Tuple' kv (Just (k, b)) Done b -> return $ Tuple' kv (Just (k, b)) {-# INLINE runFold #-} - runFold kv ref (Fold step1 initial1 extract1) (k, a) = do + runFold kv ref (Fold step1 initial1 extract1 final1) (k, a) = do res <- initial1 case res of Partial s -> do res1 <- step1 s a case res1 of Partial _ -> do - let fld = Fold step1 (return res1) extract1 + let fld = Fold step1 (return res1) extract1 final1 liftIO $ writeIORef ref fld return $ Tuple' kv Nothing Done b -> @@ -363,20 +560,192 @@ f <- liftIO $ readIORef ref runFold kv ref f (k, a) - extract (Tuple' kv x) = (Prelude.mapM f kv, x) + extract (Tuple' kv x) = return (Prelude.mapM f kv, x) where f ref = do - (Fold _ i e) <- liftIO $ readIORef ref + Fold _ i e _ <- liftIO $ readIORef ref r <- i case r of Partial s -> e s - Done b -> return b + _ -> error "demuxGenericIO: unreachable code" + final (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f ref = do + Fold _ i _ fin <- liftIO $ readIORef ref + r <- i + case r of + Partial s -> fin s + _ -> error "demuxGenericIO: unreachable code" + +-- | This is a specialized version of 'demuxToContainer' that uses mutable IO cells +-- as fold accumulators for better performance. +{-# INLINE demuxerToContainerIO #-} +demuxerToContainerIO :: (MonadIO m, IsMap f, Traversable f) => + (a -> Key f) + -> (Key f -> m (Maybe (Fold m a b))) + -> Fold m a (f b) +demuxerToContainerIO getKey getFold = + Fold (\s a -> Partial <$> step s a) (Partial <$> initial) undefined final + + where + + initial = return $ Tuple' IsMap.mapEmpty IsMap.mapEmpty + + {-# INLINE initFold #-} + initFold kv kv1 (Fold step1 initial1 _ final1) (k, a) = do + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + case res1 of + Partial _ -> do + -- XXX Instead of using a Fold type here use a custom + -- type with an IORef (possibly unboxed) for the + -- accumulator. That will reduce the allocations. + let fld = Fold step1 (return res1) undefined final1 + ref <- liftIO $ newIORef fld + return $ Tuple' (IsMap.mapInsert k ref kv) kv1 + Done b -> return $ Tuple' kv (IsMap.mapInsert k b kv1) + Done b -> return $ Tuple' kv (IsMap.mapInsert k b kv1) + + {-# INLINE runFold #-} + runFold kv kv1 ref (Fold step1 initial1 _ final1) (k, a) = do + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + case res1 of + Partial _ -> do + let fld = Fold step1 (return res1) undefined final1 + liftIO $ writeIORef ref fld + return $ Tuple' kv kv1 + Done b -> + let r = IsMap.mapDelete k kv + in return $ Tuple' r (IsMap.mapInsert k b kv1) + Done _ -> error "demuxGenericIO: unreachable" + + step (Tuple' kv kv1) a = do + let k = getKey a + case IsMap.mapLookup k kv of + Nothing -> do + res <- getFold k + case res of + Nothing -> pure $ Tuple' kv kv1 + Just f -> initFold kv kv1 f (k, a) + Just ref -> do + f <- liftIO $ readIORef ref + runFold kv kv1 ref f (k, a) + + final (Tuple' kv kv1) = do + r <- Prelude.mapM f kv + return $ IsMap.mapUnion r kv1 + + where + + f ref = do + Fold _ i _ fin <- liftIO $ readIORef ref + r <- i + case r of + Partial s -> fin s + _ -> error "demuxGenericIO: unreachable code" + +-- | This is a specialized version of 'demux' that uses mutable IO cells as +-- fold accumulators for better performance. +-- +-- Keep in mind that the values in the returned Map may be changed by the +-- ongoing fold if you are using those concurrently in another thread. +-- +{-# INLINE demuxScanGenericIO #-} +demuxScanGenericIO :: (MonadIO m, IsMap f, Traversable f) => + (a -> Key f) + -> (Key f -> m (Maybe (Fold m a b))) + -> Scanl m a (m (f b), Maybe (Key f, b)) +demuxScanGenericIO getKey getFold = + Scanl (\s a -> Partial <$> step s a) (Partial <$> initial) extract final + + where + + initial = return $ Tuple' IsMap.mapEmpty Nothing + + {-# INLINE initFold #-} + initFold kv (Fold step1 initial1 extract1 final1) (k, a) = do + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + case res1 of + Partial _ -> do + -- XXX Instead of using a Fold type here use a custom + -- type with an IORef (possibly unboxed) for the + -- accumulator. That will reduce the allocations. + let fld = Fold step1 (return res1) extract1 final1 + ref <- liftIO $ newIORef fld + return $ Tuple' (IsMap.mapInsert k ref kv) Nothing + Done b -> return $ Tuple' kv (Just (k, b)) + Done b -> return $ Tuple' kv (Just (k, b)) + + {-# INLINE runFold #-} + runFold kv ref (Fold step1 initial1 extract1 final1) (k, a) = do + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + case res1 of + Partial _ -> do + let fld = Fold step1 (return res1) extract1 final1 + liftIO $ writeIORef ref fld + return $ Tuple' kv Nothing + Done b -> + let kv1 = IsMap.mapDelete k kv + in return $ Tuple' kv1 (Just (k, b)) + Done _ -> error "demuxGenericIO: unreachable" + + step (Tuple' kv _) a = do + let k = getKey a + case IsMap.mapLookup k kv of + Nothing -> do + res <- getFold k + case res of + Nothing -> pure $ Tuple' kv Nothing + Just f -> initFold kv f (k, a) + Just ref -> do + f <- liftIO $ readIORef ref + runFold kv ref f (k, a) + + extract (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f ref = do + Fold _ i e _ <- liftIO $ readIORef ref + r <- i + case r of + Partial s -> e s + _ -> error "demuxGenericIO: unreachable code" + + final (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f ref = do + Fold _ i _ fin <- liftIO $ readIORef ref + r <- i + case r of + Partial s -> fin s + _ -> error "demuxGenericIO: unreachable code" + -- | This is specialized version of 'demux' that uses mutable IO cells as -- fold accumulators for better performance. -- +-- Keep in mind that the values in the returned Map may be changed by the +-- ongoing fold if you are using those concurrently in another thread. +-- +{-# DEPRECATED demuxIO "Use demuxScanIO instead" #-} {-# INLINE demuxIO #-} demuxIO :: (MonadIO m, Ord k) => (a -> k) @@ -384,6 +753,34 @@ -> Fold m a (m (Map k b), Maybe (k, b)) demuxIO = demuxGenericIO +{-# INLINE demuxUsingMapIO #-} +demuxUsingMapIO :: (MonadIO m, Ord k) => + (a -> k) + -> (k -> m (Maybe (Fold m a b))) + -> Scanl m a (m (Map k b), Maybe (k, b)) +demuxUsingMapIO = demuxScanGenericIO + +-- | This is a specialized version of 'demuxScan' that uses mutable IO cells as +-- scan accumulators for better performance. +-- +-- TODO: To drain the final in-progress folds this requires the drain step of +-- Scanl to be streaming. +-- +{-# INLINE demuxScanIO #-} +demuxScanIO :: (MonadIO m, Ord k) => + (a -> k) + -> (k -> m (Maybe (Fold m a b))) + -> Scanl m a (Maybe (k, b)) +demuxScanIO getKey = fmap snd . demuxUsingMapIO getKey + +-- | Fold a key value stream to a key-value Map. If the same key appears +-- multiple times, only the last value is retained. +{-# INLINE kvToMapOverwriteGeneric #-} +kvToMapOverwriteGeneric :: (Monad m, IsMap f) => Fold m (Key f, a) (f a) +kvToMapOverwriteGeneric = + foldl' (\kv (k, v) -> IsMap.mapInsert k v kv) IsMap.mapEmpty + +{-# DEPRECATED demuxToContainer "Use demuxerToContainer instead" #-} {-# INLINE demuxToContainer #-} demuxToContainer :: (Monad m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (f b) @@ -400,11 +797,42 @@ -- | This collects all the results of 'demux' in a Map. -- +{-# DEPRECATED demuxToMap "Use demuxerToMap instead" #-} {-# INLINE demuxToMap #-} demuxToMap :: (Monad m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) demuxToMap = demuxToContainer +-- | @demuxerToMap getKey getFold@: In a key value stream, fold values +-- corresponding to each key using a key specific fold. @getFold@ is invoked to +-- generate a key specific fold when a key is encountered for the first time in +-- the stream. +-- +-- If a fold terminates, another instance of the fold is started upon receiving +-- an input with that key, @getFold@ is invoked again whenever the key is +-- encountered again. +-- +-- This combinator can be used to scan a stream and collect the results from +-- the scan output. +-- +-- Since the fold generator function is monadic, folds for new keys can be +-- added dynamically or folds for old keys can be deleted or modified. For +-- example, we can maintain a Map of keys to folds in an IORef and lookup the +-- fold from that corresponding to a key. This Map can be changed dynamically. +-- +-- Note that this fold never terminates. Inputs that do not correspond to a +-- fold in the map are dropped. +-- +-- Compare with 'classify', the fold in 'classify' is a static fold. +-- +-- /Pre-release/ +-- +{-# INLINE demuxerToMap #-} +demuxerToMap :: (Monad m, Ord k) => + (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Fold m a (Map k b) +demuxerToMap = demuxerToContainer + +{-# DEPRECATED demuxToContainerIO "Use demuxerToContainerIO instead" #-} {-# INLINE demuxToContainerIO #-} demuxToContainerIO :: (MonadIO m, IsMap f, Traversable f) => (a -> Key f) -> (a -> m (Fold m a b)) -> Fold m a (f b) @@ -421,28 +849,36 @@ -- | Same as 'demuxToMap' but uses 'demuxIO' for better performance. -- +{-# DEPRECATED demuxToMapIO "Use demuxerToMapIO instead" #-} {-# INLINE demuxToMapIO #-} demuxToMapIO :: (MonadIO m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) demuxToMapIO = demuxToContainerIO +-- | Same as 'demuxerToMap' but uses mutable cells for better performance. +-- +{-# INLINE demuxerToMapIO #-} +demuxerToMapIO :: (MonadIO m, Ord k) => + (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Fold m a (Map k b) +demuxerToMapIO = demuxerToContainerIO + {-# INLINE demuxKvToContainer #-} demuxKvToContainer :: (Monad m, IsMap f, Traversable f) => - (Key f -> m (Fold m a b)) -> Fold m (Key f, a) (f b) -demuxKvToContainer f = demuxToContainer fst (\(k, _) -> fmap (lmap snd) (f k)) + (Key f -> m (Maybe (Fold m a b))) -> Fold m (Key f, a) (f b) +demuxKvToContainer f = demuxerToContainer fst (fmap (fmap (lmap snd)) . f) -- | Fold a stream of key value pairs using a function that maps keys to folds. -- -- Definition: -- --- >>> demuxKvToMap f = Fold.demuxToContainer fst (Fold.lmap snd . f) +-- >>> demuxKvToMap f = Fold.demuxerToContainer fst (Fold.lmap snd . f) -- -- Example: -- -- >>> import Data.Map (Map) -- >>> :{ --- let f "SUM" = return Fold.sum --- f _ = return Fold.product +-- let f "SUM" = return (Just Fold.sum) +-- f _ = return (Just Fold.product) -- input = Stream.fromList [("SUM",1),("PRODUCT",2),("SUM",3),("PRODUCT",4)] -- in Stream.fold (Fold.demuxKvToMap f) input :: IO (Map String Int) -- :} @@ -451,7 +887,7 @@ -- /Pre-release/ {-# INLINE demuxKvToMap #-} demuxKvToMap :: (Monad m, Ord k) => - (k -> m (Fold m a b)) -> Fold m (k, a) (Map k b) + (k -> m (Maybe (Fold m a b))) -> Fold m (k, a) (Map k b) demuxKvToMap = demuxKvToContainer ------------------------------------------------------------------------------ @@ -464,6 +900,10 @@ -- done then initial would set a flag in the state to ignore the input or -- return an error. +-- XXX Use a Refold m k a b so that we can make the fold key specifc. +-- XXX Is using a function (a -> k) better than using the input (k,a)? + +{-# DEPRECATED classifyGeneric "Use classifyScanGeneric instead" #-} {-# INLINE classifyGeneric #-} classifyGeneric :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => -- Note: we need to return the Map itself to display the in-progress values @@ -471,8 +911,8 @@ -- for that use case. We return an action because we want it to be lazy so -- that the downstream consumers can choose to process or discard it. (a -> Key f) -> Fold m a b -> Fold m a (m (f b), Maybe (Key f, b)) -classifyGeneric f (Fold step1 initial1 extract1) = - fmap extract $ foldlM' step initial +classifyGeneric f (Fold step1 initial1 extract1 final1) = + Fold (\s a -> Partial <$> step s a) (Partial <$> initial) extract final where @@ -509,8 +949,124 @@ let kv1 = IsMap.mapDelete k kv in Tuple3' kv1 (Set.insert k set) (Just (k, b)) - extract (Tuple3' kv _ x) = (Prelude.mapM extract1 kv, x) + extract (Tuple3' kv _ x) = return (Prelude.mapM extract1 kv, x) + final (Tuple3' kv set x) = return (IsMap.mapTraverseWithKey f1 kv, x) + + where + + f1 k s = do + if Set.member k set + -- XXX Why are we doing this? If it is in the set then it will not + -- be in the map and vice-versa. + then extract1 s + else final1 s + +{-# INLINE toContainer #-} +toContainer :: (Monad m, IsMap f, Traversable f) => + (a -> Key f) -> Fold m a b -> Fold m a (f b) +toContainer f (Fold step1 initial1 _ final1) = + Fold (\s a -> Partial <$> step s a) (Partial <$> initial) undefined final + + where + + initial = return $ Tuple' IsMap.mapEmpty IsMap.mapEmpty + + {-# INLINE initFold #-} + initFold kv kv1 k a = do + x <- initial1 + case x of + Partial s -> do + r <- step1 s a + return + $ case r of + Partial s1 -> + Tuple' (IsMap.mapInsert k s1 kv) kv1 + Done b -> + Tuple' kv (IsMap.mapInsert k b kv1) + Done b -> return (Tuple' kv (IsMap.mapInsert k b kv1)) + + step (Tuple' kv kv1) a = do + let k = f a + case IsMap.mapLookup k kv of + Nothing -> do + case IsMap.mapLookup k kv1 of + Nothing -> initFold kv kv1 k a + Just _ -> return (Tuple' kv kv1) + Just s -> do + r <- step1 s a + return + $ case r of + Partial s1 -> + Tuple' (IsMap.mapInsert k s1 kv) kv1 + Done b -> + let res = IsMap.mapDelete k kv + in Tuple' res (IsMap.mapInsert k b kv1) + + final (Tuple' kv kv1) = do + r <- Prelude.mapM final1 kv + return $ IsMap.mapUnion r kv1 + +-- | Scanning variant of 'toContainer'. +-- +{-# INLINE classifyScanGeneric #-} +classifyScanGeneric :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => + -- Note: we need to return the Map itself to display the in-progress values + -- e.g. to implement top. We could possibly create a separate abstraction + -- for that use case. We return an action because we want it to be lazy so + -- that the downstream consumers can choose to process or discard it. + (a -> Key f) -> Fold m a b -> Scanl m a (m (f b), Maybe (Key f, b)) +classifyScanGeneric f (Fold step1 initial1 extract1 final1) = + Scanl (\s a -> Partial <$> step s a) (Partial <$> initial) extract final + + where + + initial = return $ Tuple3' IsMap.mapEmpty Set.empty Nothing + + {-# INLINE initFold #-} + initFold kv set k a = do + x <- initial1 + case x of + Partial s -> do + r <- step1 s a + return + $ case r of + Partial s1 -> + Tuple3' (IsMap.mapInsert k s1 kv) set Nothing + Done b -> + Tuple3' kv set (Just (k, b)) + Done b -> return (Tuple3' kv (Set.insert k set) (Just (k, b))) + + step (Tuple3' kv set _) a = do + let k = f a + case IsMap.mapLookup k kv of + Nothing -> do + if Set.member k set + then return (Tuple3' kv set Nothing) + else initFold kv set k a + Just s -> do + r <- step1 s a + return + $ case r of + Partial s1 -> + Tuple3' (IsMap.mapInsert k s1 kv) set Nothing + Done b -> + let kv1 = IsMap.mapDelete k kv + in Tuple3' kv1 (Set.insert k set) (Just (k, b)) + + extract (Tuple3' kv _ x) = return (Prelude.mapM extract1 kv, x) + + final (Tuple3' kv set x) = return (IsMap.mapTraverseWithKey f1 kv, x) + + where + + f1 k s = do + if Set.member k set + -- XXX Why are we doing this? If it is in the set then it will not + -- be in the map and vice-versa. + then extract1 s + else final1 s + -- | Folds the values for each key using the supplied fold. When scanning, as -- soon as the fold is complete, its result is available in the second -- component of the tuple. The first component of the tuple is a snapshot of @@ -520,22 +1076,38 @@ -- -- Definition: -- --- >>> classify f fld = Fold.demux f (const fld) +-- >> classify f fld = Fold.demux f (const fld) -- +{-# DEPRECATED classify "Use classifyScan instead" #-} {-# INLINE classify #-} classify :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (m (Map k b), Maybe (k, b)) classify = classifyGeneric +{-# INLINE classifyUsingMap #-} +classifyUsingMap :: (Monad m, Ord k) => + (a -> k) -> Fold m a b -> Scanl m a (m (Map k b), Maybe (k, b)) +classifyUsingMap = classifyScanGeneric + +-- XXX Make it consistent with demux. + +-- | Scanning variant of 'toMap'. +-- +{-# INLINE classifyScan #-} +classifyScan :: (MonadIO m, Ord k) => + (a -> k) -> Fold m a b -> Scanl m a (Maybe (k, b)) +classifyScan getKey = fmap snd . classifyUsingMap getKey + -- XXX we can use a Prim IORef if we can constrain the state "s" to be Prim -- -- The code is almost the same as classifyGeneric except the IORef operations. +{-# DEPRECATED classifyGenericIO "Use classifyGenericIO from Scanl module" #-} {-# INLINE classifyGenericIO #-} classifyGenericIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (m (f b), Maybe (Key f, b)) -classifyGenericIO f (Fold step1 initial1 extract1) = - fmap extract $ foldlM' step initial +classifyGenericIO f (Fold step1 initial1 extract1 final1) = + Fold (\s a -> Partial <$> step s a) (Partial <$> initial) extract final where @@ -574,29 +1146,169 @@ in return $ Tuple3' kv1 (Set.insert k set) (Just (k, b)) - extract (Tuple3' kv _ x) = - (Prelude.mapM (\ref -> liftIO (readIORef ref) >>= extract1) kv, x) + extract (Tuple3' kv _ x) = return (Prelude.mapM g kv, x) + where + + g ref = liftIO (readIORef ref) >>= extract1 + + final (Tuple3' kv set x) = return (IsMap.mapTraverseWithKey g kv, x) + + where + + g k ref = do + s <- liftIO $ readIORef ref + if Set.member k set + then extract1 s + else final1 s + +-- XXX we can use a Prim IORef if we can constrain the state "s" to be Prim +-- +-- The code is almost the same as classifyGeneric except the IORef operations. + +{-# INLINE toContainerIO #-} +toContainerIO :: (MonadIO m, IsMap f, Traversable f) => + (a -> Key f) -> Fold m a b -> Fold m a (f b) +toContainerIO f (Fold step1 initial1 _ final1) = + Fold (\s a -> Partial <$> step s a) (Partial <$> initial) undefined final + + where + + initial = return $ Tuple' IsMap.mapEmpty IsMap.mapEmpty + + {-# INLINE initFold #-} + initFold kv kv1 k a = do + x <- initial1 + case x of + Partial s -> do + r <- step1 s a + case r of + Partial s1 -> do + ref <- liftIO $ newIORef s1 + return $ Tuple' (IsMap.mapInsert k ref kv) kv1 + Done b -> + return $ Tuple' kv (IsMap.mapInsert k b kv1) + Done b -> return (Tuple' kv (IsMap.mapInsert k b kv1)) + + step (Tuple' kv kv1) a = do + let k = f a + case IsMap.mapLookup k kv of + Nothing -> do + case IsMap.mapLookup k kv1 of + Nothing -> initFold kv kv1 k a + Just _ -> return $ Tuple' kv kv1 + Just ref -> do + s <- liftIO $ readIORef ref + r <- step1 s a + case r of + Partial s1 -> do + liftIO $ writeIORef ref s1 + return $ Tuple' kv kv1 + Done b -> + let res = IsMap.mapDelete k kv + in return + $ Tuple' res (IsMap.mapInsert k b kv1) + + final (Tuple' kv kv1) = do + r <- Prelude.mapM g kv + return $ IsMap.mapUnion r kv1 + + where + + g ref = liftIO (readIORef ref) >>= final1 + +-- | Scanning variant of 'classifyGenericIO'. +-- +{-# INLINE classifyScanGenericIO #-} +classifyScanGenericIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => + (a -> Key f) -> Fold m a b -> Scanl m a (m (f b), Maybe (Key f, b)) +classifyScanGenericIO f (Fold step1 initial1 extract1 final1) = + Scanl (\s a -> Partial <$> step s a) (Partial <$> initial) extract final + + where + + initial = return $ Tuple3' IsMap.mapEmpty Set.empty Nothing + + {-# INLINE initFold #-} + initFold kv set k a = do + x <- initial1 + case x of + Partial s -> do + r <- step1 s a + case r of + Partial s1 -> do + ref <- liftIO $ newIORef s1 + return $ Tuple3' (IsMap.mapInsert k ref kv) set Nothing + Done b -> + return $ Tuple3' kv set (Just (k, b)) + Done b -> return (Tuple3' kv (Set.insert k set) (Just (k, b))) + + step (Tuple3' kv set _) a = do + let k = f a + case IsMap.mapLookup k kv of + Nothing -> do + if Set.member k set + then return (Tuple3' kv set Nothing) + else initFold kv set k a + Just ref -> do + s <- liftIO $ readIORef ref + r <- step1 s a + case r of + Partial s1 -> do + liftIO $ writeIORef ref s1 + return $ Tuple3' kv set Nothing + Done b -> + let kv1 = IsMap.mapDelete k kv + in return + $ Tuple3' kv1 (Set.insert k set) (Just (k, b)) + + extract (Tuple3' kv _ x) = return (Prelude.mapM g kv, x) + + where + + g ref = liftIO (readIORef ref) >>= extract1 + + final (Tuple3' kv set x) = return (IsMap.mapTraverseWithKey g kv, x) + + where + + g k ref = do + s <- liftIO $ readIORef ref + if Set.member k set + then extract1 s + else final1 s + -- | Same as classify except that it uses mutable IORef cells in the -- Map providing better performance. Be aware that if this is used as a scan, -- the values in the intermediate Maps would be mutable. -- -- Definitions: -- --- >>> classifyIO f fld = Fold.demuxIO f (const fld) +-- >> classifyIO f fld = Fold.demuxIO f (const fld) -- +{-# DEPRECATED classifyIO "Use classifyScanIO instead" #-} {-# INLINE classifyIO #-} classifyIO :: (MonadIO m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (m (Map k b), Maybe (k, b)) classifyIO = classifyGenericIO --- | Fold a key value stream to a key-value Map. If the same key appears --- multiple times, only the last value is retained. -{-# INLINE kvToMapOverwriteGeneric #-} -kvToMapOverwriteGeneric :: (Monad m, IsMap f) => Fold m (Key f, a) (f a) -kvToMapOverwriteGeneric = - foldl' (\kv (k, v) -> IsMap.mapInsert k v kv) IsMap.mapEmpty +{-# INLINE classifyUsingMapIO #-} +classifyUsingMapIO :: (MonadIO m, Ord k) => + (a -> k) -> Fold m a b -> Scanl m a (m (Map k b), Maybe (k, b)) +classifyUsingMapIO = classifyScanGenericIO +-- | This is a specialized version of 'classifyScan' that uses mutable IO cells +-- as scan accumulators for better performance. +-- +-- TODO: To drain the final in-progress folds this requires the drain step of +-- Scanl to be streaming. +-- +{-# INLINE classifyScanIO #-} +classifyScanIO :: (MonadIO m, Ord k) => + (a -> k) -> Fold m a b -> Scanl m a (Maybe (k, b)) +classifyScanIO getKey = fmap snd . classifyUsingMapIO getKey + +{- {-# INLINE toContainer #-} toContainer :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (f b) @@ -610,6 +1322,7 @@ (rmapM getMap $ lmap fst latest) (lmap snd $ catMaybes kvToMapOverwriteGeneric) in postscan classifier aggregator +-} -- | Split the input stream based on a key field and fold each split using the -- given fold. Useful for map/reduce, bucketizing the input in different bins @@ -647,6 +1360,7 @@ (a -> k) -> Fold m a b -> Fold m a (Map k b) toMap = toContainer +{- {-# INLINE toContainerIO #-} toContainerIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => (a -> Key f) -> Fold m a b -> Fold m a (f b) @@ -660,6 +1374,7 @@ (rmapM getMap $ lmap fst latest) (lmap snd $ catMaybes kvToMapOverwriteGeneric) in postscan classifier aggregator +-} -- | Same as 'toMap' but maybe faster because it uses mutable cells as -- fold accumulators in the Map. diff --git a/src/Streamly/Internal/Data/Fold/Exception.hs b/src/Streamly/Internal/Data/Fold/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Exception.hs @@ -0,0 +1,199 @@ +-- | +-- Module : Streamly.Internal.Data.Fold.Exception +-- Copyright : (c) 2025 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Fold.Exception + ( + -- * Resources + before + , bracketIO + , finallyIO + + -- * Exceptions + , onException + ) +where + +------------------------------------------------------------------------------ +-- Imports +------------------------------------------------------------------------------ + +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Catch (MonadCatch) +import Streamly.Internal.Data.IOFinalizer (newIOFinalizer, runIOFinalizer) + +import qualified Control.Monad.Catch as MC + +import Streamly.Internal.Data.Fold.Step +import Streamly.Internal.Data.Fold.Type + +------------------------------------------------------------------------------ +-- Exceptions +------------------------------------------------------------------------------ + +{- + +-- | Exception handling states of a fold +data HandleExc s f1 f2 = InitDone !s | InitFailed !f1 | StepFailed !f2 + +-- | @handle initHandler stepHandler fold@ produces a new fold from a given +-- fold. The new fold executes the original @fold@, if an exception occurs +-- when initializing the fold then @initHandler@ is executed and fold resulting +-- from that starts execution. If an exception occurs while executing the +-- @step@ function of a fold then the @stephandler@ is executed and we start +-- executing the fold resulting from that. +-- +-- The exception is caught and handled, not rethrown. If the exception handler +-- itself throws an exception that exception is thrown. +-- +-- /Internal/ +-- +{-# INLINE handle #-} +handle :: (MonadCatch m, Exception e) + => (e -> m (Fold m a b)) + -> (e -> Fold m a b -> m (Fold m a b)) + -> Fold m a b + -> Fold m a b +handle initH stepH (Fold step1 initial1 extract1) = Fold step initial extract + + where + + initial = fmap InitDone initial1 `MC.catch` (fmap InitFailed . initH) + + step (InitDone s) a = + let f = Fold step1 (return s) extract1 + in fmap InitDone (step1 s a) + `MC.catch` (\e -> fmap StepFailed (stepH e f)) + step (InitFailed (Fold step2 initial2 extract2)) a = do + s <- initial2 + s1 <- step2 s a + return $ InitFailed $ Fold step2 (return s1) extract2 + step (StepFailed (Fold step2 initial2 extract2)) a = do + s <- initial2 + s1 <- step2 s a + return $ StepFailed $ Fold step2 (return s1) extract2 + + extract (InitDone s) = extract1 s + extract (InitFailed (Fold _ initial2 extract2)) = initial2 >>= extract2 + extract (StepFailed (Fold _ initial2 extract2)) = initial2 >>= extract2 + +-} + +-- | @onException action fold@ runs @action@ whenever the fold throws an +-- exception. The action is executed on any exception whether it is in +-- initial, step or extract action of the fold. +-- +-- The exception is not caught, simply rethrown. If the @action@ itself +-- throws an exception that exception is thrown instead of the original +-- exception. +-- +-- /Internal/ +-- +{-# INLINE onException #-} +onException :: MonadCatch m => m x -> Fold m a b -> Fold m a b +onException action (Fold step1 initial1 extract1 final1) = + Fold step initial extract final + + where + + initial = initial1 `MC.onException` action + step s a = step1 s a `MC.onException` action + extract s = extract1 s `MC.onException` action + final s = final1 s `MC.onException` action + +-- | @bracketIO before after between@ runs @before@ and invokes @between@ using +-- its output, then runs the fold generated by @between@. If the fold ends +-- normally, due to an exception or if it is garbage collected prematurely then +-- @after@ is run with the output of @before@ as argument. +-- +-- If @before@ or @after@ throw an exception that exception is thrown. +-- +{-# INLINE bracketIO #-} +bracketIO :: (MonadIO m, MonadCatch m) + => IO x -> (x -> IO c) -> (x -> Fold m a b) -> Fold m a b +bracketIO bef aft bet = Fold step initial extract final + + where + + initial = do + r <- liftIO bef + ref <- liftIO $ newIOFinalizer (aft r) + case bet r of + Fold step1 initial1 extract1 final1 -> do + res <- initial1 `MC.onException` liftIO (runIOFinalizer ref) + case res of + Partial s -> do + let fld1 = Fold step1 (pure (Partial s)) extract1 final1 + pure $ Partial $ Tuple' ref fld1 + Done b -> do + liftIO $ runIOFinalizer ref + pure $ Done b + + step (Tuple' ref (Fold step1 initial1 extract1 final1)) a = do + res <- initial1 + case res of + Partial s -> do + s1 <- step1 s a `MC.onException` liftIO (runIOFinalizer ref) + let fld1 = Fold step1 (pure s1) extract1 final1 + pure $ Partial $ Tuple' ref fld1 + Done b -> do + liftIO $ runIOFinalizer ref + pure $ Done b + + extract (Tuple' ref (Fold _ initial1 extract1 _)) = do + res <- initial1 + case res of + Partial s -> extract1 s `MC.onException` liftIO (runIOFinalizer ref) + Done b -> pure b + + final (Tuple' ref (Fold _ initial1 _ final1)) = do + res <- initial1 + case res of + Partial s -> do + val <- final1 s `MC.onException` liftIO (runIOFinalizer ref) + runIOFinalizer ref + pure val + Done b -> pure b + +-- | Run a side effect whenever the fold stops normally, aborts due to an +-- exception or is garbage collected. +-- +{-# INLINE finallyIO #-} +finallyIO :: (MonadIO m, MonadCatch m) => IO b -> Fold m a b -> Fold m a b +finallyIO aft (Fold step1 initial1 extract1 final1) = + Fold step initial extract final + + where + + initial = do + ref <- liftIO $ newIOFinalizer aft + res <- initial1 `MC.onException` liftIO (runIOFinalizer ref) + pure $ case res of + Done b -> Done b + Partial s -> Partial $ Tuple' ref s + + step (Tuple' ref s) a = do + res <- step1 s a `MC.onException` liftIO (runIOFinalizer ref) + pure $ case res of + Done b -> Done b + Partial s1 -> Partial $ Tuple' ref s1 + + extract (Tuple' ref s) = + extract1 s `MC.onException` liftIO (runIOFinalizer ref) + + final (Tuple' ref s) = do + res <- final1 s `MC.onException` liftIO (runIOFinalizer ref) + liftIO $ runIOFinalizer ref + pure res + + +-- | Run a side effect before the initialization of the fold. +-- +{-# INLINE before #-} +before :: Monad m => m x -> Fold m a b -> Fold m a b +before effect (Fold s i e f) = Fold s (effect *> i) e f diff --git a/src/Streamly/Internal/Data/Fold/Step.hs b/src/Streamly/Internal/Data/Fold/Step.hs --- a/src/Streamly/Internal/Data/Fold/Step.hs +++ b/src/Streamly/Internal/Data/Fold/Step.hs @@ -8,7 +8,7 @@ -- module Streamly.Internal.Data.Fold.Step ( - -- * Types + -- * Step Type Step (..) , mapMStep @@ -28,6 +28,18 @@ -- terminate early whereas we use data constructors. It allows stream fusion in -- contrast to the foldr/build fusion when composing with functions. +-- XXX Change the semantics of Done such that when we return Done, the input is +-- always unused. Then we can include the takeWhile fold as well under folds. +-- This will be a breaking change, so rename "Done" to "Stop" so that users are +-- forced to look at all places where it is used. +-- +-- Perhaps we do not need to return the Step type in initial. Instead of +-- returning "Done" in initial we can wait for the next input or invocation of +-- "final". This should simplify the composition of initial considerably. +-- +-- Also, rename Partial to Skip, to keep it consistent with Scans/Pipes/Streams. +-- Make Partial a pattern synonym to keep backward compatibility. + -- | Represents the result of the @step@ of a 'Fold'. 'Partial' returns an -- intermediate state of the fold, the fold step can be called again with the -- state or the driver can use @extract@ on the state to get the result out. @@ -40,7 +52,7 @@ = Partial !s | Done !b --- | 'first' maps over 'Partial' and 'second' maps over 'Done'. +-- | 'first' maps over the fold state and 'second' maps over the fold result. -- instance Bifunctor Step where {-# INLINE bimap #-} diff --git a/src/Streamly/Internal/Data/Fold/Tee.hs b/src/Streamly/Internal/Data/Fold/Tee.hs --- a/src/Streamly/Internal/Data/Fold/Tee.hs +++ b/src/Streamly/Internal/Data/Fold/Tee.hs @@ -16,7 +16,9 @@ ) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) +#endif import Streamly.Internal.Data.Fold.Type (Fold) import qualified Streamly.Internal.Data.Fold.Type as Fold @@ -77,7 +79,7 @@ -- | '<>' distributes the input to both the argument 'Tee's and combines their -- outputs using the 'Monoid' instance of the output type. -- -instance (Semigroup b, Monoid b, Monad m) => Monoid (Tee m a b) where +instance (Monoid b, Monad m) => Monoid (Tee m a b) where {-# INLINE mempty #-} mempty = pure mempty diff --git a/src/Streamly/Internal/Data/Fold/Type.hs b/src/Streamly/Internal/Data/Fold/Type.hs --- a/src/Streamly/Internal/Data/Fold/Type.hs +++ b/src/Streamly/Internal/Data/Fold/Type.hs @@ -126,6 +126,25 @@ -- or to not be able to use `take 0` if we have it. Also, applicative and -- monadic composition of folds would not be possible. -- +-- == Cleanup Action +-- +-- Fold may use other folds in the downstream pipeline. When a fold is done and +-- it wants to terminate it needs to wait for the downstream folds before it +-- returns. For example, if the downstream fold is an async fold we need to +-- wait for the async fold to finish and return the final result. +-- +-- To be able to support this use case we need a cleanup action in the fold. +-- The fold gets finalized once the cleanup is called and we can use extract to +-- get the final state/result of the fold. +-- +-- Similar to folds we may have a cleanup action in streams as well. Currently, +-- we rely on GC to cleanup the streams, if we use a cleanup action then we can +-- perform cleanup quickly. Also, similar to folds we can also have an +-- "initial" action in streams as well to generate the initial state. It could +-- decouple the initialization of the stream from the first element being +-- pulled. For example, you may want to start a timer at initialization rather +-- than at the first element pull of the stream. +-- -- == Terminating Folds with backtracking -- -- Consider the example of @takeWhile@ operation, it needs to inspect an @@ -191,8 +210,8 @@ -- -- This means: takeWhile, groupBy, wordBy would be implemented as parsers. -- --- A proposed design is to use the same Step type with Error in Folds as well --- as Parsers. Folds won't use the Error constructor and even if they use, it +-- A proposed design is to use the same Step type with SError in Folds as well +-- as Parsers. Folds won't use the SError constructor and even if they use, it -- will be equivalent to just throwing an error. They won't have an -- alternative. -- @@ -225,7 +244,7 @@ -- would succeed if the condition is satisfied and it would fail otherwise, on -- failure an alternative parser can be used on the same input. -- --- We add @Error@ and @Continue@ to the @Step@ type of fold. @Continue@ is to +-- We add @SError@ and @Continue@ to the @Step@ type of fold. @Continue@ is to -- skip producing an output or to backtrack. We also add the ability to -- backtrack in @Partial@ and @Done@.: -- @@ -238,7 +257,7 @@ -- Partial Int s -- partial result and how much to backtrack -- | Done Int b -- final result and how much to backtrack -- | Continue Int s -- no result and how much to backtrack --- | Error String -- error +-- | SError String -- error -- -- data Parser a m b = -- forall s. Fold @@ -325,18 +344,16 @@ -- module Streamly.Internal.Data.Fold.Type ( - -- * Imports - -- $setup + module Streamly.Internal.Data.Fold.Step - -- * Types - Step (..) + -- * Fold Type , Fold (..) -- * Constructors , foldl' , foldlM' , foldl1' - , foldlM1' + , foldl1M' , foldt' , foldtM' , foldr' @@ -345,11 +362,18 @@ -- * Folds , fromPure , fromEffect + -- XXX Do refold ops belong to Scanl or Fold? , fromRefold + , fromScanl , drain , toList + , toListRev + -- $toListRev , toStreamK , toStreamKRev + , genericLength + , length + , latest -- * Combinators @@ -359,7 +383,14 @@ -- ** Mapping Input , lmap , lmapM + + -- ** Scanning input , postscan + , scanl + , scanlMany + , postscanl + , postscanlMaybe + -- , runScan -- ** Filtering , catMaybes @@ -374,8 +405,13 @@ -- ** Trimming , take , taking + , takeEndBy_ + , takeEndBy , dropping + -- ** Condition + , ifThen + -- ** Sequential application , splitWith -- rename to "append" , split_ @@ -403,13 +439,13 @@ , longest -- * Running A Fold - , extractM , reduce , snoc , addOne , snocM , snocl , snoclM + , finalM , close , isClosed @@ -420,26 +456,38 @@ -- * Deprecated , foldr , serialWith + , foldlM1' + , extractM + , scan + , scanMany + , last ) where #include "inline.hs" +#if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) -import Control.Monad ((>=>)) +#endif +import Control.Monad ((>=>), void) import Data.Bifunctor (Bifunctor(..)) import Data.Either (fromLeft, fromRight, isLeft, isRight) import Data.Functor.Identity (Identity(..)) import Fusion.Plugin.Types (Fuse(..)) -import Streamly.Internal.Data.Fold.Step (Step(..), mapMStep, chainStepM) -import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) -import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) +import Streamly.Internal.Data.Either.Strict (Either'(..)) import Streamly.Internal.Data.Refold.Type (Refold(..)) +import Streamly.Internal.Data.Scanl.Type (Scanl(..)) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +-- import qualified Streamly.Internal.Data.Stream.Step as Stream +import qualified Streamly.Internal.Data.StreamK.Type as K +import qualified Streamly.Internal.Data.Scanl.Type as Scanl -import Prelude hiding (concatMap, filter, foldr, map, take) +import Prelude hiding (Foldable(..), concatMap, filter, map, take, scanl, last) +-- Entire module is exported, do not import selectively +import Streamly.Internal.Data.Fold.Step + #include "DocTestDataFold.hs" ------------------------------------------------------------------------------ @@ -450,24 +498,89 @@ -- The type @b@ is the accumulator of the writer. That's the reason the -- default folds in various modules are called "write". --- | The type @Fold m a b@ having constructor @Fold step initial extract@ --- represents a fold over an input stream of values of type @a@ to a final --- value of type @b@ in 'Monad' @m@. +-- An alternative to using an "extract" function is to use "Partial s b" style +-- partial value so that we always emit the output value and there is no need +-- to extract. Then extract can be used for cleanup purposes. But in this case +-- in some cases we may need a "Continue" constructor where an output value is +-- not available, this was implicit earlier. Also, "b" should be lazy here so +-- that we do not always compute it even if we do not need it. -- --- The fold uses an intermediate state @s@ as accumulator, the type @s@ is --- internal to the specific fold definition. The initial value of the fold --- state @s@ is returned by @initial@. The @step@ function consumes an input --- and either returns the final result @b@ if the fold is done or the next --- intermediate state (see 'Step'). At any point the fold driver can extract --- the result from the intermediate state using the @extract@ function. +-- Partial s b --> extract :: s -> b +-- Continue --> extract :: s -> Maybe b -- +-- But keeping 'b' lazy does not let the fold optimize well. It leads to +-- significant regressions in the key-value folds. +-- +-- The "final" function complicates combinators that take other folds as +-- argument because we need to call their finalizers at right places. An +-- alternative to reduce this complexity where it is not required is to use a +-- separate type for bracketed folds but then we need to manage the complexity +-- of two different fold types. + +-- The "final" function could be (s -> m (Step s b)), like in parsers so that +-- it can be called in a loop to drain the fold. + +-- | The type @Fold m a b@ represents a consumer of an input stream of values +-- of type @a@ and returning a final value of type @b@ in 'Monad' @m@. The +-- constructor of a fold is @Fold step initial extract final@. +-- +-- The fold uses an internal state of type @s@. The initial value of the state +-- @s@ is created by @initial@. This function is called once and only once +-- before the fold starts consuming input. Any resource allocation can be done +-- in this function. +-- +-- The @step@ function is called on each input, it consumes an input and +-- returns the next intermediate state (see 'Step') or the final result @b@ if +-- the fold terminates. +-- +-- Folds are no longer used for scanning, please see the 'Streamly.Data.Scanl' +-- module for scanning. The @extract@ operation is no longer used and will be +-- removed in future. +-- +-- Before a fold terminates, @final@ is called once and only once (unless the +-- fold terminated in @initial@ itself). Any resources allocated by @initial@ +-- can be released in @final@. +-- +-- When implementing fold combinators, care should be taken to cleanup any +-- state of the argument folds held by the fold by calling the respective +-- @final@ at all exit points of the fold. Also, @final@ should not be called +-- more than once. Note that if a fold terminates by 'Done' constructor, there +-- is no state to cleanup. +-- -- NOTE: The constructor is not yet released, smart constructors are provided -- to create folds. -- data Fold m a b = - -- | @Fold @ @ step @ @ initial @ @ extract@ - forall s. Fold (s -> a -> m (Step s b)) (m (Step s b)) (s -> m b) + -- XXX Since we have scans now, we can remove the extract function. + -- XXX initial can be made pure, like in streams, we can add effects by using + -- bracket like operations. + -- | @Fold@ @step@ @initial@ @extract@ @final@ + forall s. Fold (s -> a -> m (Step s b)) (m (Step s b)) (s -> m b) (s -> m b) +-- XXX Have functions to modify initial, step, final of a fold. That way we +-- won't have to use the constructor in many cases. + +{- +-- XXX Change the type to as follows. This takes care of the unfoldMany case +-- where we need to continue in produce mode. Can we keep the same Step as +-- Scanl without impacting the key-value folds? +-- +-- Note: this will require a change in Parser type as well for Parser.fromFold +-- to work. +-- +data Step s b = + Consume s + | Produce s + | Stop b + +data Fold m a b = + forall s. Fold + (s -> a -> m (Step s b)) -- consume step + (m (Step s b)) -- initial + (s -> m (Step s b)) -- produce step + (s -> m (Step s b)) -- drain step +-} + ------------------------------------------------------------------------------ -- Mapping on the output ------------------------------------------------------------------------------ @@ -476,7 +589,8 @@ -- {-# INLINE rmapM #-} rmapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c -rmapM f (Fold step initial extract) = Fold step1 initial1 (extract >=> f) +rmapM f (Fold step initial extract final) = + Fold step1 initial1 (extract >=> f) (final >=> f) where @@ -487,6 +601,11 @@ -- Left fold constructors ------------------------------------------------------------------------------ +-- | Convert a left scan to a fold. +{-# INLINE fromScanl #-} +fromScanl :: Scanl m a b -> Fold m a b +fromScanl (Scanl step initial extract final) = Fold step initial extract final + -- | Make a fold from a left fold style pure step function and initial value of -- the accumulator. -- @@ -502,11 +621,7 @@ -- {-# INLINE foldl' #-} foldl' :: Monad m => (b -> a -> b) -> b -> Fold m a b -foldl' step initial = - Fold - (\s a -> return $ Partial $ step s a) - (return (Partial initial)) - return +foldl' step = fromScanl . Scanl.mkScanl step -- | Make a fold from a left fold style monadic step function and initial value -- of the accumulator. @@ -520,8 +635,7 @@ -- {-# INLINE foldlM' #-} foldlM' :: Monad m => (b -> a -> m b) -> m b -> Fold m a b -foldlM' step initial = - Fold (\s a -> Partial <$> step s a) (Partial <$> initial) return +foldlM' step = fromScanl . Scanl.mkScanlM step -- | Make a strict left fold, for non-empty streams, using first element as the -- starting value. Returns Nothing if the stream is empty. @@ -529,25 +643,65 @@ -- /Pre-release/ {-# INLINE foldl1' #-} foldl1' :: Monad m => (a -> a -> a) -> Fold m a (Maybe a) -foldl1' step = fmap toMaybe $ foldl' step1 Nothing' - - where - - step1 Nothing' a = Just' a - step1 (Just' x) a = Just' $ step x a +foldl1' = fromScanl . Scanl.mkScanl1 -- | Like 'foldl1\'' but with a monadic step function. -- -- /Pre-release/ +{-# DEPRECATED foldlM1' "Please use foldl1M' instead" #-} {-# INLINE foldlM1' #-} foldlM1' :: Monad m => (a -> a -> m a) -> Fold m a (Maybe a) -foldlM1' step = fmap toMaybe $ foldlM' step1 (return Nothing') +foldlM1' = foldl1M' +-- | Like 'foldl1\'' but with a monadic step function. +-- +-- /Pre-release/ +{-# INLINE foldl1M' #-} +foldl1M' :: Monad m => (a -> a -> m a) -> Fold m a (Maybe a) +foldl1M' = fromScanl . Scanl.mkScanl1M + +{- +data FromScan s b = FromScanInit !s | FromScanGo !s !b + +-- XXX we can attach a scan on the last fold e.g. "runScan s last". Or run a +-- scan on a fold that supplies a default value? +-- +-- If we are pushing a value to a scan and the scan stops we will lose the +-- input. Only those scans that do not use the Stop constructor can be used as +-- folds or with folds? The Stop constructor makes them suitable to be composed +-- with pull based streams, push based folds cannot work with that. Do we need +-- two types of scans then, scans for streams and scans for folds? ScanR and +-- ScanL? + +-- | This does not work correctly yet. We lose the last input. +-- +{-# INLINE fromScan #-} +fromScan :: Monad m => Scan m a b -> Fold m a (Maybe b) +fromScan (Scan consume initial) = + Fold fstep (return $ Partial (FromScanInit initial)) fextract fextract + where - step1 Nothing' a = return $ Just' a - step1 (Just' x) a = Just' <$> step x a + fstep (FromScanInit ss) a = do + r <- consume ss a + return $ case r of + Stream.Yield b s -> Partial (FromScanGo s b) + Stream.Skip s -> Partial (FromScanInit s) + -- XXX We have lost the input here. + -- XXX Need to change folds to always return Done on the next input + Stream.Stop -> Done Nothing + fstep (FromScanGo ss acc) a = do + r <- consume ss a + return $ case r of + Stream.Yield b s -> Partial (FromScanGo s b) + Stream.Skip s -> Partial (FromScanGo s acc) + -- XXX We have lost the input here. + Stream.Stop -> Done (Just acc) + fextract (FromScanInit _) = return Nothing + fextract (FromScanGo _ acc) = return (Just acc) +-} + ------------------------------------------------------------------------------ -- Right fold constructors ------------------------------------------------------------------------------ @@ -569,7 +723,7 @@ -- {-# INLINE foldr' #-} foldr' :: Monad m => (a -> b -> b) -> b -> Fold m a b -foldr' f z = fmap ($ z) $ foldl' (\g x -> g . f x) id +foldr' f = fromScanl . Scanl.mkScanr f {-# DEPRECATED foldr "Please use foldr' instead." #-} {-# INLINE foldr #-} @@ -590,8 +744,7 @@ -- /Pre-release/ {-# INLINE foldrM' #-} foldrM' :: Monad m => (a -> b -> m b) -> m b -> Fold m a b -foldrM' g z = - rmapM (z >>=) $ foldlM' (\f x -> return $ g x >=> f) (return return) +foldrM' g = fromScanl . Scanl.mkScanrM g ------------------------------------------------------------------------------ -- General fold constructors @@ -618,8 +771,7 @@ -- {-# INLINE foldt' #-} foldt' :: Monad m => (s -> a -> Step s b) -> Step s b -> (s -> b) -> Fold m a b -foldt' step initial extract = - Fold (\s a -> return $ step s a) (return initial) (return . extract) +foldt' step initial = fromScanl . Scanl.mkScant step initial -- | Make a terminating fold with an effectful step function and initial state, -- and a state extraction function. @@ -632,21 +784,21 @@ -- {-# INLINE foldtM' #-} foldtM' :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> Fold m a b -foldtM' = Fold +foldtM' step initial extract = Fold step initial extract extract ------------------------------------------------------------------------------ -- Refold ------------------------------------------------------------------------------ -- This is similar to how we run an Unfold to generate a Stream. A Fold is like --- a Stream and a Fold2 is like an Unfold. +-- a Stream and a Refold is like an Unfold. -- -- | Make a fold from a consumer. -- -- /Internal/ fromRefold :: Refold m c a b -> c -> Fold m a b fromRefold (Refold step inject extract) c = - Fold step (inject c) extract + Fold step (inject c) extract extract ------------------------------------------------------------------------------ -- Basic Folds @@ -660,8 +812,12 @@ -- {-# INLINE drain #-} drain :: Monad m => Fold m a () -drain = foldl' (\_ _ -> ()) () +drain = fromScanl Scanl.drain +------------------------------------------------------------------------------ +-- To Containers +------------------------------------------------------------------------------ + -- | Folds the input stream to a list. -- -- /Warning!/ working on large lists accumulated as buffers in memory could be @@ -672,8 +828,27 @@ -- {-# INLINE toList #-} toList :: Monad m => Fold m a [a] -toList = foldr' (:) [] +toList = fromScanl Scanl.toList +-- $toListRev +-- This is more efficient than 'Streamly.Internal.Data.Fold.toList'. toList is +-- exactly the same as reversing the list after 'toListRev'. + +-- | Buffers the input stream to a list in the reverse order of the input. +-- +-- Definition: +-- +-- >>> toListRev = Fold.foldl' (flip (:)) [] +-- +-- /Warning!/ working on large lists accumulated as buffers in memory could be +-- very inefficient, consider using "Streamly.Array" instead. +-- + +-- xn : ... : x2 : x1 : [] +{-# INLINE toListRev #-} +toListRev :: Monad m => Fold m a [a] +toListRev = foldl' (flip (:)) [] + -- | Buffers the input stream to a pure stream in the reverse order of the -- input. -- @@ -687,7 +862,7 @@ -- xn : ... : x2 : x1 : [] {-# INLINE toStreamKRev #-} toStreamKRev :: Monad m => Fold m a (K.StreamK n a) -toStreamKRev = foldl' (flip K.cons) K.nil +toStreamKRev = fromScanl Scanl.toStreamKRev -- | A fold that buffers its input to a pure stream. -- @@ -697,8 +872,45 @@ -- /Internal/ {-# INLINE toStreamK #-} toStreamK :: Monad m => Fold m a (K.StreamK n a) -toStreamK = foldr K.cons K.nil +toStreamK = fromScanl Scanl.toStreamK +-- | Like 'length', except with a more general 'Num' return value +-- +-- Definition: +-- +-- >>> genericLength = fmap getSum $ Fold.foldMap (Sum . const 1) +-- >>> genericLength = Fold.foldl' (\n _ -> n + 1) 0 +-- +-- /Pre-release/ +{-# INLINE genericLength #-} +genericLength :: (Monad m, Num b) => Fold m a b +genericLength = fromScanl Scanl.genericLength + +-- | Determine the length of the input stream. +-- +-- Definition: +-- +-- >>> length = Fold.genericLength +-- >>> length = fmap getSum $ Fold.foldMap (Sum . const 1) +-- +{-# INLINE length #-} +length :: Monad m => Fold m a Int +length = fromScanl Scanl.length + +-- | Returns the latest element of the input stream, if any. +-- +-- >>> latest = Fold.foldl1' (\_ x -> x) +-- >>> latest = fmap getLast $ Fold.foldMap (Last . Just) +-- +{-# INLINE latest #-} +latest :: Monad m => Fold m a (Maybe a) +latest = fromScanl Scanl.latest + +{-# DEPRECATED last "Please use 'latest' instead." #-} +{-# INLINE last #-} +last :: Monad m => Fold m a (Maybe a) +last = latest + ------------------------------------------------------------------------------ -- Instances ------------------------------------------------------------------------------ @@ -706,7 +918,8 @@ -- | Maps a function on the output of the fold (the type @b@). instance Functor m => Functor (Fold m a) where {-# INLINE fmap #-} - fmap f (Fold step1 initial1 extract) = Fold step initial (fmap2 f extract) + fmap f (Fold step1 initial1 extract final) = + Fold step initial (fmap2 f extract) (fmap2 f final) where @@ -741,7 +954,7 @@ -- {-# INLINE fromPure #-} fromPure :: Applicative m => b -> Fold m a b -fromPure b = Fold undefined (pure $ Done b) pure +fromPure b = Fold undefined (pure $ Done b) pure pure -- | Make a fold that yields the result of the supplied effectful action -- without consuming any further input. @@ -750,7 +963,7 @@ -- {-# INLINE fromEffect #-} fromEffect :: Applicative m => m b -> Fold m a b -fromEffect b = Fold undefined (Done <$> b) pure +fromEffect b = Fold undefined (Done <$> b) pure pure {-# ANN type SeqFoldState Fuse #-} data SeqFoldState sl f sr = SeqFoldL !sl | SeqFoldR !f !sr @@ -775,16 +988,20 @@ -- complexity, because each composition adds a new branch that each subsequent -- fold's input element has to traverse, therefore, it cannot scale to a large -- number of compositions. After around 100 compositions the performance starts --- dipping rapidly compared to a CPS style implementation. When you need --- scaling use parser monad instead. +-- dipping rapidly compared to a CPS style implementation. -- +-- For larger number of compositions you can convert the fold to a parser and +-- use ParserK. +-- -- /Time: O(n^2) where n is the number of compositions./ -- {-# INLINE splitWith #-} splitWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c -splitWith func (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract +splitWith func + (Fold stepL initialL _ finalL) + (Fold stepR initialR _ finalR) = + Fold step initial extract final where @@ -801,13 +1018,18 @@ step (SeqFoldL st) a = runL (stepL st a) step (SeqFoldR f st) a = runR (stepR st a) f - extract (SeqFoldR f sR) = fmap f (extractR sR) - extract (SeqFoldL sL) = do - rL <- extractL sL + -- XXX splitWith should not be used for scanning + -- It would rarely make sense and resource tracking and cleanup would be + -- expensive. especially when multiple splitWith are chained. + extract _ = error "splitWith: cannot be used for scanning" + + final (SeqFoldR f sR) = fmap f (finalR sR) + final (SeqFoldL sL) = do + rL <- finalL sL res <- initialR fmap (func rL) $ case res of - Partial sR -> extractR sR + Partial sR -> finalR sR Done rR -> return rR {-# DEPRECATED serialWith "Please use \"splitWith\" instead" #-} @@ -827,8 +1049,8 @@ -- {-# INLINE split_ #-} split_ :: Monad m => Fold m x a -> Fold m x b -> Fold m x b -split_ (Fold stepL initialL _) (Fold stepR initialR extractR) = - Fold step initial extract +split_ (Fold stepL initialL _ finalL) (Fold stepR initialR _ finalR) = + Fold step initial extract final where @@ -851,11 +1073,16 @@ resR <- stepR st a return $ first SeqFoldR_ resR - extract (SeqFoldR_ sR) = extractR sR - extract (SeqFoldL_ _) = do + -- XXX split_ should not be used for scanning + -- See splitWith for more details. + extract _ = error "split_: cannot be used for scanning" + + final (SeqFoldR_ sR) = finalR sR + final (SeqFoldL_ sL) = do + _ <- finalL sL res <- initialR case res of - Partial sR -> extractR sR + Partial sR -> finalR sR Done rR -> return rR -- | 'Applicative' form of 'splitWith'. Split the input serially over two @@ -903,8 +1130,10 @@ -- {-# INLINE teeWith #-} teeWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c -teeWith f (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract +teeWith f + (Fold stepL initialL extractL finalL) + (Fold stepR initialR extractR finalR) = + Fold step initial extract final where @@ -931,6 +1160,10 @@ extract (TeeLeft bR sL) = (`f` bR) <$> extractL sL extract (TeeRight bL sR) = f bL <$> extractR sR + final (TeeBoth sL sR) = f <$> finalL sL <*> finalR sR + final (TeeLeft bR sL) = (`f` bR) <$> finalL sL + final (TeeRight bL sR) = f bL <$> finalR sR + {-# ANN type TeeFstState Fuse #-} data TeeFstState sL sR b = TeeFstBoth !sL !sR @@ -943,8 +1176,10 @@ {-# INLINE teeWithFst #-} teeWithFst :: Monad m => (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d -teeWithFst f (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract +teeWithFst f + (Fold stepL initialL extractL finalL) + (Fold stepR initialR extractR finalR) = + Fold step initial extract final where @@ -963,7 +1198,7 @@ Done bl -> do Done . f bl <$> case resR of - Partial sr -> extractR sr + Partial sr -> finalR sr Done br -> return br initial = runBoth initialL initialR @@ -974,6 +1209,9 @@ extract (TeeFstBoth sL sR) = f <$> extractL sL <*> extractR sR extract (TeeFstLeft bR sL) = (`f` bR) <$> extractL sL + final (TeeFstBoth sL sR) = f <$> finalL sL <*> finalR sR + final (TeeFstLeft bR sL) = (`f` bR) <$> finalL sL + -- | Like 'teeWith' but terminates as soon as any one of the two folds -- terminates. -- @@ -982,8 +1220,10 @@ {-# INLINE teeWithMin #-} teeWithMin :: Monad m => (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d -teeWithMin f (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract +teeWithMin f + (Fold stepL initialL extractL finalL) + (Fold stepR initialR extractR finalR) = + Fold step initial extract final where @@ -995,12 +1235,12 @@ Partial sl -> do case resR of Partial sr -> return $ Partial $ Tuple' sl sr - Done br -> Done . (`f` br) <$> extractL sl + Done br -> Done . (`f` br) <$> finalL sl Done bl -> do Done . f bl <$> case resR of - Partial sr -> extractR sr + Partial sr -> finalR sr Done br -> return br initial = runBoth initialL initialR @@ -1009,6 +1249,8 @@ extract (Tuple' sL sR) = f <$> extractL sL <*> extractR sR + final (Tuple' sL sR) = f <$> finalL sL <*> finalR sR + -- | Shortest alternative. Apply both folds in parallel but choose the result -- from the one which consumed least input i.e. take the shortest succeeding -- fold. @@ -1020,8 +1262,8 @@ -- {-# INLINE shortest #-} shortest :: Monad m => Fold m x a -> Fold m x b -> Fold m x (Either a b) -shortest (Fold stepL initialL extractL) (Fold stepR initialR _) = - Fold step initial extract +shortest (Fold stepL initialL extractL finalL) (Fold stepR initialR _ finalR) = + Fold step initial extract final where @@ -1029,10 +1271,16 @@ runBoth actionL actionR = do resL <- actionL resR <- actionR - return $ - case resL of - Partial sL -> bimap (Tuple' sL) Right resR - Done bL -> Done $ Left bL + case resL of + Partial sL -> + case resR of + Partial sR -> return $ Partial $ Tuple' sL sR + Done bR -> finalL sL >> return (Done (Right bR)) + Done bL -> do + case resR of + Partial sR -> void (finalR sR) + Done _ -> return () + return (Done (Left bL)) initial = runBoth initialL initialR @@ -1040,6 +1288,8 @@ extract (Tuple' sL _) = Left <$> extractL sL + final (Tuple' sL sR) = Left <$> finalL sL <* finalR sR + {-# ANN type LongestState Fuse #-} data LongestState sL sR = LongestBoth !sL !sR @@ -1057,8 +1307,10 @@ -- {-# INLINE longest #-} longest :: Monad m => Fold m x a -> Fold m x b -> Fold m x (Either a b) -longest (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract +longest + (Fold stepL initialL _ finalL) + (Fold stepR initialR _ finalR) = + Fold step initial extract final where @@ -1081,17 +1333,23 @@ step (LongestLeft sL) a = bimap LongestLeft Left <$> stepL sL a step (LongestRight sR) a = bimap LongestRight Right <$> stepR sR a - left sL = Left <$> extractL sL - extract (LongestLeft sL) = left sL - extract (LongestRight sR) = Right <$> extractR sR - extract (LongestBoth sL _) = left sL + -- XXX Scan with this may not make sense as we cannot determine the longest + -- until one of them have exhausted. + extract _ = error $ "longest: scan is not allowed as longest cannot be " + ++ "determined until one fold has exhausted." -data ConcatMapState m sa a c - = B !sa - | forall s. C (s -> a -> m (Step s c)) !s (s -> m c) + final (LongestLeft sL) = Left <$> finalL sL + final (LongestRight sR) = Right <$> finalR sR + final (LongestBoth sL sR) = Left <$> finalL sL <* finalR sR +data ConcatMapState m sa a b c + = B !sa (sa -> m b) + | forall s. C (s -> a -> m (Step s c)) !s (s -> m c) (s -> m c) + -- | Map a 'Fold' returning function on the result of a 'Fold' and run the --- returned fold. This operation can be used to express data dependencies +-- returned fold. This is akin to an n-ary version of 'splitWith' where the +-- next fold for splitting the input is decided dynamically using the previous +-- result. This operation can be used to express data dependencies -- between fold operations. -- -- Let's say the first element in the stream is a count of the following @@ -1111,43 +1369,47 @@ -- {-# INLINE concatMap #-} concatMap :: Monad m => (b -> Fold m a c) -> Fold m a b -> Fold m a c -concatMap f (Fold stepa initiala extracta) = Fold stepc initialc extractc +concatMap f (Fold stepa initiala _ finala) = + Fold stepc initialc extractc finalc where initialc = do r <- initiala case r of - Partial s -> return $ Partial (B s) + Partial s -> return $ Partial (B s finala) Done b -> initInnerFold (f b) - stepc (B s) a = do + stepc (B s fin) a = do r <- stepa s a case r of - Partial s1 -> return $ Partial (B s1) + Partial s1 -> return $ Partial (B s1 fin) Done b -> initInnerFold (f b) - stepc (C stepInner s extractInner) a = do + stepc (C stepInner s extractInner fin) a = do r <- stepInner s a return $ case r of - Partial sc -> Partial (C stepInner sc extractInner) + Partial sc -> Partial (C stepInner sc extractInner fin) Done c -> Done c - extractc (B s) = do - r <- extracta s - initExtract (f r) - extractc (C _ sInner extractInner) = extractInner sInner + -- XXX Cannot use for scanning + extractc _ = error "concatMap: cannot be used for scanning" - initInnerFold (Fold step i e) = do + initInnerFold (Fold step i e fin) = do r <- i return $ case r of - Partial s -> Partial (C step s e) + Partial s -> Partial (C step s e fin) Done c -> Done c - initExtract (Fold _ i e) = do + initFinalize (Fold _ i _ fin) = do r <- i case r of - Partial s -> e s + Partial s -> fin s Done c -> return c + finalc (B s fin) = do + r <- fin s + initFinalize (f r) + finalc (C _ sInner _ fin) = fin sInner + ------------------------------------------------------------------------------ -- Mapping on input ------------------------------------------------------------------------------ @@ -1166,7 +1428,7 @@ -- {-# INLINE lmap #-} lmap :: (a -> b) -> Fold m b r -> Fold m a r -lmap f (Fold step begin done) = Fold step' begin done +lmap f (Fold step begin done final) = Fold step' begin done final where step' x a = step x (f a) @@ -1174,20 +1436,27 @@ -- {-# INLINE lmapM #-} lmapM :: Monad m => (a -> m b) -> Fold m b r -> Fold m a r -lmapM f (Fold step begin done) = Fold step' begin done +lmapM f (Fold step begin done final) = Fold step' begin done final where step' x a = f a >>= step x +------------------------------------------------------------------------------ +-- Scanning +------------------------------------------------------------------------------ + -- | Postscan the input of a 'Fold' to change it in a stateful manner using -- another 'Fold'. -- -- @postscan scanner collector@ -- -- /Pre-release/ +{-# DEPRECATED postscan "Please use 'postscanl' instead." #-} {-# INLINE postscan #-} postscan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c -postscan (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract +postscan + (Fold stepL initialL extractL finalL) + (Fold stepR initialR extractR finalR) = + Fold step initial extract final where @@ -1198,30 +1467,255 @@ Done bL -> do rR <- stepR sR bL case rR of - Partial sR1 -> Done <$> extractR sR1 + Partial sR1 -> Done <$> finalR sR1 Done bR -> return $ Done bR Partial sL -> do !b <- extractL sL rR <- stepR sR b - return - $ case rR of - Partial sR1 -> Partial (sL, sR1) - Done bR -> Done bR + case rR of + Partial sR1 -> return $ Partial (sL, sR1) + Done bR -> finalL sL >> return (Done bR) initial = do + rR <- initialR + case rR of + Partial sR -> do + rL <- initialL + case rL of + Done _ -> Done <$> finalR sR + Partial sL -> return $ Partial (sL, sR) + Done b -> return $ Done b + + -- XXX should use Tuple' + step (sL, sR) x = runStep (stepL sL x) sR + + extract = extractR . snd + + final (sL, sR) = finalL sL *> finalR sR + +{- +{-# INLINE runScanWith #-} +runScanWith :: Monad m => Bool -> Scan m a b -> Fold m b c -> Fold m a c +runScanWith isMany + (Scan stepL initialL) + (Fold stepR initialR extractR finalR) = + Fold step initial extract final + + where + + step (sL, sR) x = do + rL <- stepL sL x + case rL of + StreamD.Yield b sL1 -> do + rR <- stepR sR b + case rR of + Partial sR1 -> return $ Partial (sL1, sR1) + Done bR -> return (Done bR) + StreamD.Skip sL1 -> return $ Partial (sL1, sR) + -- XXX We have dropped the input. + -- XXX Need same behavior for Stop in Fold so that the driver can + -- consistently assume it is dropped. + StreamD.Stop -> + if isMany + then return $ Partial (initialL, sR) + else Done <$> finalR sR + + initial = do r <- initialR - rL <- initialL case r of - Partial sR -> + Partial sR -> return $ Partial (initialL, sR) + Done b -> return $ Done b + + extract = extractR . snd + + final = finalR . snd + +-- | Scan the input of a 'Fold' to change it in a stateful manner using a +-- 'Scan'. The scan stops as soon as the fold terminates. +-- +-- /Pre-release/ +{-# INLINE runScan #-} +runScan :: Monad m => Scan m a b -> Fold m b c -> Fold m a c +runScan = runScanWith False +-} + +-- | @postscanl scanner collector@ postscans the input of the @collector@ fold +-- to change it in a stateful manner using 'scanner'. +-- +-- /Pre-release/ +{-# INLINE postscanl #-} +postscanl :: Monad m => Scanl m a b -> Fold m b c -> Fold m a c +postscanl + (Scanl stepL initialL extractL finalL) + (Fold stepR initialR _ finalR) = + Fold step initial undefined final + + where + + {-# INLINE runStep #-} + runStep actionL sR = do + rL <- actionL + case rL of + Done bL -> do + rR <- stepR sR bL + case rR of + Partial sR1 -> Done <$> finalR sR1 + Done bR -> return $ Done bR + Partial sL -> do + !b <- extractL sL + rR <- stepR sR b + case rR of + Partial sR1 -> return $ Partial (sL, sR1) + Done bR -> finalL sL >> return (Done bR) + + initial = do + rR <- initialR + case rR of + Partial sR -> do + rL <- initialL case rL of - Done _ -> Done <$> extractR sR + Done _ -> Done <$> finalR sR Partial sL -> return $ Partial (sL, sR) Done b -> return $ Done b + -- XXX should use Tuple' step (sL, sR) x = runStep (stepL sL x) sR + final (sL, sR) = finalL sL *> finalR sR + +-- | Use a 'Maybe' returning left scan for filtering the input of a fold. +-- +-- >>> scanlMaybe p f = Fold.postscanl p (Fold.catMaybes f) +-- +-- /Pre-release/ +{-# INLINE postscanlMaybe #-} +postscanlMaybe :: Monad m => Scanl m a (Maybe b) -> Fold m b c -> Fold m a c +postscanlMaybe f1 f2 = postscanl f1 (catMaybes f2) + +{-# INLINE scanWith #-} +scanWith :: Monad m => Bool -> Fold m a b -> Fold m b c -> Fold m a c +scanWith isMany + (Fold stepL initialL extractL finalL) + (Fold stepR initialR extractR finalR) = + Fold step initial extract final + + where + + {-# INLINE runStep #-} + runStep actionL sR = do + rL <- actionL + case rL of + Done bL -> do + rR <- stepR sR bL + case rR of + Partial sR1 -> + if isMany + -- XXX recursive call. If initialL returns Done then it + -- will not terminate. In that case we should return + -- error in the beginning itself. And we should remove + -- this recursion, assuming it won't return Done. + then runStep initialL sR1 + else Done <$> finalR sR1 + Done bR -> return $ Done bR + Partial sL -> do + !b <- extractL sL + rR <- stepR sR b + case rR of + Partial sR1 -> return $ Partial (sL, sR1) + Done bR -> finalL sL >> return (Done bR) + + initial = do + r <- initialR + case r of + Partial sR -> runStep initialL sR + Done b -> return $ Done b + + step (sL, sR) x = runStep (stepL sL x) sR + extract = extractR . snd + final (sL, sR) = finalL sL *> finalR sR + +-- | Scan the input of a 'Fold' to change it in a stateful manner using another +-- 'Fold'. The scan stops as soon as the fold terminates. +-- +-- /Pre-release/ +{-# DEPRECATED scan "Please use 'scanl' instead." #-} +{-# INLINE scan #-} +scan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c +scan = scanWith False + +-- XXX This does not fuse beacuse of the recursive step. Need to investigate. +-- +-- | Scan the input of a 'Fold' to change it in a stateful manner using another +-- 'Fold'. The scan restarts with a fresh state if the fold terminates. +-- +-- /Pre-release/ +{-# DEPRECATED scanMany "Please use 'scanlMany' instead." #-} +{-# INLINE scanMany #-} +scanMany :: Monad m => Fold m a b -> Fold m b c -> Fold m a c +scanMany = scanWith True + +{-# INLINE scanlWith #-} +scanlWith :: Monad m => Bool -> Scanl m a b -> Fold m b c -> Fold m a c +scanlWith isMany + (Scanl stepL initialL extractL finalL) + (Fold stepR initialR _ finalR) = + Fold step initial undefined final + + where + + {-# INLINE runStep #-} + runStep actionL sR = do + rL <- actionL + case rL of + Done bL -> do + rR <- stepR sR bL + case rR of + Partial sR1 -> + if isMany + -- XXX recursive call. If initialL returns Done then it + -- will not terminate. In that case we should return + -- error in the beginning itself. And we should remove + -- this recursion, assuming it won't return Done. + then runStep initialL sR1 + else Done <$> finalR sR1 + Done bR -> return $ Done bR + Partial sL -> do + !b <- extractL sL + rR <- stepR sR b + case rR of + Partial sR1 -> return $ Partial (sL, sR1) + Done bR -> finalL sL >> return (Done bR) + + initial = do + r <- initialR + case r of + Partial sR -> runStep initialL sR + Done b -> return $ Done b + + step (sL, sR) x = runStep (stepL sL x) sR + + final (sL, sR) = finalL sL *> finalR sR + +-- | Scan the input of a 'Fold' to change it in a stateful manner using a +-- 'Scanl'. The scan stops as soon as the fold terminates. +-- +-- /Pre-release/ +{-# INLINE scanl #-} +scanl :: Monad m => Scanl m a b -> Fold m b c -> Fold m a c +scanl = scanlWith False + +-- XXX This does not fuse beacuse of the recursive step. Need to investigate. + +-- | Scan the input of a 'Fold' to change it in a stateful manner using a +-- 'Scanl'. The scan restarts with a fresh state if it terminates. +-- +-- /Pre-release/ +{-# INLINE scanlMany #-} +scanlMany :: Monad m => Scanl m a b -> Fold m b c -> Fold m a c +scanlMany = scanlWith True + ------------------------------------------------------------------------------ -- Filtering ------------------------------------------------------------------------------ @@ -1234,7 +1728,7 @@ -- {-# INLINE_NORMAL catMaybes #-} catMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b -catMaybes (Fold step initial extract) = Fold step1 initial extract +catMaybes (Fold step initial extract final) = Fold step1 initial extract final where @@ -1245,9 +1739,10 @@ -- | Use a 'Maybe' returning fold as a filtering scan. -- --- >>> scanMaybe p f = Fold.postscan p (Fold.catMaybes f) +-- >> scanMaybe p f = Fold.postscan p (Fold.catMaybes f) -- -- /Pre-release/ +{-# DEPRECATED scanMaybe "Please use 'postscanlMaybe' instead." #-} {-# INLINE scanMaybe #-} scanMaybe :: Monad m => Fold m a (Maybe b) -> Fold m b c -> Fold m a c scanMaybe f1 f2 = postscan f1 (catMaybes f2) @@ -1267,14 +1762,13 @@ -- >>> Stream.fold (Fold.filter (> 5) Fold.sum) $ Stream.fromList [1..10] -- 40 -- --- >>> filter p = Fold.scanMaybe (Fold.filtering p) -- >>> filter p = Fold.filterM (return . p) -- >>> filter p = Fold.mapMaybe (\x -> if p x then Just x else Nothing) -- {-# INLINE filter #-} filter :: Monad m => (a -> Bool) -> Fold m a r -> Fold m a r -- filter p = scanMaybe (filtering p) -filter f (Fold step begin done) = Fold step' begin done +filter f (Fold step begin extract final) = Fold step' begin extract final where step' x a = if f a then step x a else return $ Partial x @@ -1285,7 +1779,7 @@ -- {-# INLINE filterM #-} filterM :: Monad m => (a -> m Bool) -> Fold m a r -> Fold m a r -filterM f (Fold step begin done) = Fold step' begin done +filterM f (Fold step begin extract final) = Fold step' begin extract final where step' x a = do use <- f a @@ -1334,36 +1828,11 @@ {-# INLINE taking #-} taking :: Monad m => Int -> Fold m a (Maybe a) -taking n = foldt' step initial extract - - where - - initial = - if n <= 0 - then Done Nothing - else Partial (Tuple'Fused n Nothing) - - step (Tuple'Fused i _) a = - if i > 1 - then Partial (Tuple'Fused (i - 1) (Just a)) - else Done (Just a) - - extract (Tuple'Fused _ r) = r +taking = fromScanl . Scanl.taking {-# INLINE dropping #-} dropping :: Monad m => Int -> Fold m a (Maybe a) -dropping n = foldt' step initial extract - - where - - initial = Partial (Tuple'Fused n Nothing) - - step (Tuple'Fused i _) a = - if i > 0 - then Partial (Tuple'Fused (i - 1) Nothing) - else Partial (Tuple'Fused i (Just a)) - - extract (Tuple'Fused _ r) = r +dropping = fromScanl . Scanl.dropping -- | Take at most @n@ input elements and fold them using the supplied fold. A -- negative count is treated as 0. @@ -1374,7 +1843,7 @@ {-# INLINE take #-} take :: Monad m => Int -> Fold m a b -> Fold m a b -- take n = scanMaybe (taking n) -take n (Fold fstep finitial fextract) = Fold step initial extract +take n (Fold fstep finitial fextract ffinal) = Fold step initial extract final where @@ -1386,7 +1855,7 @@ s1 = Tuple'Fused i1 s if i1 < n then return $ Partial s1 - else Done <$> fextract s + else Done <$> ffinal s Done b -> return $ Done b initial = finitial >>= next (-1) @@ -1395,6 +1864,100 @@ extract (Tuple'Fused _ r) = fextract r + final (Tuple'Fused _ r) = ffinal r + +-- Note: Keep this consistent with S.splitOn. In fact we should eliminate +-- S.splitOn in favor of the fold. +-- +-- XXX Use Fold.many instead once it is fixed. +-- > Stream.splitOnSuffix p f = Stream.foldMany (Fold.takeEndBy_ p f) + +-- | Like 'takeEndBy' but drops the element on which the predicate succeeds. +-- +-- Example: +-- +-- >>> input = Stream.fromList "hello\nthere\n" +-- >>> line = Fold.takeEndBy_ (== '\n') Fold.toList +-- >>> Stream.fold line input +-- "hello" +-- +-- >>> Stream.fold Fold.toList $ Stream.foldMany line input +-- ["hello","there"] +-- +{-# INLINE takeEndBy_ #-} +takeEndBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b +-- takeEndBy_ predicate = scanMaybe (takingEndBy_ predicate) +takeEndBy_ predicate (Fold fstep finitial fextract ffinal) = + Fold step finitial fextract ffinal + + where + + step s a = + if not (predicate a) + then fstep s a + else Done <$> ffinal s + +-- Note: +-- > Stream.splitWithSuffix p f = Stream.foldMany (Fold.takeEndBy p f) + +-- | Take the input, stop when the predicate succeeds taking the succeeding +-- element as well. +-- +-- Example: +-- +-- >>> input = Stream.fromList "hello\nthere\n" +-- >>> line = Fold.takeEndBy (== '\n') Fold.toList +-- >>> Stream.fold line input +-- "hello\n" +-- +-- >>> Stream.fold Fold.toList $ Stream.foldMany line input +-- ["hello\n","there\n"] +-- +{-# INLINE takeEndBy #-} +takeEndBy :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b +-- takeEndBy predicate = scanMaybe (takingEndBy predicate) +takeEndBy predicate (Fold fstep finitial fextract ffinal) = + Fold step finitial fextract ffinal + + where + + step s a = do + res <- fstep s a + if not (predicate a) + then return res + else do + case res of + Partial s1 -> Done <$> ffinal s1 + Done b -> return $ Done b + +-- Fusible if-then-else + +-- | Evaluate a condition, if True then use the first fold otherwise use the +-- second fold. +{-# INLINE ifThen #-} +ifThen :: Monad m => m Bool -> Fold m a b -> Fold m a b -> Fold m a b +ifThen predicate + (Fold step1 initial1 extract1 final1) + (Fold step2 initial2 extract2 final2) + = Fold step initial extract final + + where + + initial = do + r <- predicate + if r + then first Left' <$> initial1 + else first Right' <$> initial2 + + step (Left' s) x = first Left' <$> step1 s x + step (Right' s) x = first Right' <$> step2 s x + + extract (Left' s) = extract1 s + extract (Right' s) = extract2 s + + final (Left' s) = final1 s + final (Right' s) = final2 s + ------------------------------------------------------------------------------ -- Nesting ------------------------------------------------------------------------------ @@ -1412,8 +1975,8 @@ -- /Pre-release/ {-# INLINE duplicate #-} duplicate :: Monad m => Fold m a b -> Fold m a (Fold m a b) -duplicate (Fold step1 initial1 extract1) = - Fold step initial (\s -> pure $ Fold step1 (pure $ Partial s) extract1) +duplicate (Fold step1 initial1 extract1 final1) = + Fold step initial extract final where @@ -1421,6 +1984,11 @@ step s a = second fromPure <$> step1 s a + -- Scanning may be problematic due to multiple finalizations. + extract = error "duplicate: scanning may be problematic" + + final s = pure $ Fold step1 (pure $ Partial s) extract1 final1 + -- If there were a finalize/flushing action in the stream type that would be -- equivalent to running initialize in Fold. But we do not have a flushing -- action in streams. @@ -1432,9 +2000,9 @@ -- /Pre-release/ {-# INLINE reduce #-} reduce :: Monad m => Fold m a b -> m (Fold m a b) -reduce (Fold step initial extract) = do +reduce (Fold step initial extract final) = do i <- initial - return $ Fold step (return i) extract + return $ Fold step (return i) extract final -- This is the dual of Stream @cons@. @@ -1444,7 +2012,8 @@ -- /Pre-release/ {-# INLINE snoclM #-} snoclM :: Monad m => Fold m a b -> m a -> Fold m a b -snoclM (Fold fstep finitial fextract) action = Fold fstep initial fextract +snoclM (Fold fstep finitial fextract ffinal) action = + Fold fstep initial fextract ffinal where @@ -1464,14 +2033,15 @@ -- Example: -- -- >>> import qualified Data.Foldable as Foldable --- >>> Fold.extractM $ Foldable.foldl Fold.snocl Fold.toList [1..3] +-- >>> Fold.finalM $ Foldable.foldl Fold.snocl Fold.toList [1..3] -- [1,2,3] -- -- /Pre-release/ {-# INLINE snocl #-} snocl :: Monad m => Fold m a b -> a -> Fold m a b -- snocl f = snoclM f . return -snocl (Fold fstep finitial fextract) a = Fold fstep initial fextract +snocl (Fold fstep finitial fextract ffinal) a = + Fold fstep initial fextract ffinal where @@ -1491,12 +2061,12 @@ -- /Pre-release/ {-# INLINE snocM #-} snocM :: Monad m => Fold m a b -> m a -> m (Fold m a b) -snocM (Fold step initial extract) action = do +snocM (Fold step initial extract final) action = do res <- initial r <- case res of Partial fs -> action >>= step fs Done _ -> return res - return $ Fold step (return r) extract + return $ Fold step (return r) extract final -- Definitions: -- @@ -1515,12 +2085,12 @@ -- /Pre-release/ {-# INLINE snoc #-} snoc :: Monad m => Fold m a b -> a -> m (Fold m a b) -snoc (Fold step initial extract) a = do +snoc (Fold step initial extract final) a = do res <- initial r <- case res of Partial fs -> step fs a Done _ -> return res - return $ Fold step (return r) extract + return $ Fold step (return r) extract final -- | Append a singleton value to the fold. -- @@ -1540,31 +2110,48 @@ -- -- >>> extractM = Fold.drive Stream.nil -- +-- /Pre-release/ +{-# DEPRECATED extractM "Please use finalM instead" #-} +{-# INLINE extractM #-} +extractM :: Monad m => Fold m a b -> m b +extractM (Fold _ initial extract _) = do + res <- initial + case res of + Partial fs -> extract fs + Done b -> return b + +-- | Finalize a fold and extract the accumulated result of the fold. +-- +-- Definition: +-- +-- >>> finalM = Fold.drive Stream.nil +-- -- Example: -- --- >>> Fold.extractM Fold.toList +-- >>> Fold.finalM Fold.toList -- [] -- -- /Pre-release/ -{-# INLINE extractM #-} -extractM :: Monad m => Fold m a b -> m b -extractM (Fold _ initial extract) = do +{-# INLINE finalM #-} +finalM :: Monad m => Fold m a b -> m b +finalM (Fold _ initial _ final) = do res <- initial case res of - Partial fs -> extract fs + Partial fs -> final fs Done b -> return b -- | Close a fold so that it does not accept any more input. {-# INLINE close #-} close :: Monad m => Fold m a b -> Fold m a b -close (Fold _ initial1 extract1) = Fold undefined initial undefined +close (Fold _ initial1 _ final1) = + Fold undefined initial undefined undefined where initial = do res <- initial1 case res of - Partial s -> Done <$> extract1 s + Partial s -> Done <$> final1 s Done b -> return $ Done b -- Corresponds to the null check for streams. @@ -1574,7 +2161,7 @@ -- /Pre-release/ {-# INLINE isClosed #-} isClosed :: Monad m => Fold m a b -> m Bool -isClosed (Fold _ initial _) = do +isClosed (Fold _ initial _ _) = do res <- initial return $ case res of Partial _ -> False @@ -1608,8 +2195,10 @@ -- {-# INLINE many #-} many :: Monad m => Fold m a b -> Fold m b c -> Fold m a c -many (Fold sstep sinitial sextract) (Fold cstep cinitial cextract) = - Fold step initial extract +many + (Fold sstep sinitial sextract sfinal) + (Fold cstep cinitial cextract cfinal) = + Fold step initial extract final where @@ -1658,6 +2247,13 @@ Partial s -> cextract s Done b -> return b + final (ManyFirst ss cs) = sfinal ss *> cfinal cs + final (ManyLoop ss cs) = do + cres <- sfinal ss >>= cstep cs + case cres of + Partial s -> cfinal s + Done b -> return b + -- | Like many, but the "first" fold emits an output at the end even if no -- input is received. -- @@ -1667,8 +2263,10 @@ -- {-# INLINE manyPost #-} manyPost :: Monad m => Fold m a b -> Fold m b c -> Fold m a c -manyPost (Fold sstep sinitial sextract) (Fold cstep cinitial cextract) = - Fold step initial extract +manyPost + (Fold sstep sinitial sextract sfinal) + (Fold cstep cinitial cextract cfinal) = + Fold step initial extract final where @@ -1704,6 +2302,12 @@ Partial s -> cextract s Done b -> return b + final (Tuple' ss cs) = do + cres <- sfinal ss >>= cstep cs + case cres of + Partial s -> cfinal s + Done b -> return b + -- | @groupsOf n split collect@ repeatedly applies the @split@ fold to chunks -- of @n@ items in the input stream and supplies the result to the @collect@ -- fold. @@ -1732,7 +2336,10 @@ -- {-# INLINE refoldMany #-} refoldMany :: Monad m => Fold m a b -> Refold m x b c -> Refold m x a c -refoldMany (Fold sstep sinitial sextract) (Refold cstep cinject cextract) = +refoldMany + (Fold sstep sinitial sextract _sfinal) + -- XXX We will need a "final" in refold as well + (Refold cstep cinject cextract) = Refold step inject extract where @@ -1783,7 +2390,9 @@ -- /Internal/ {-# INLINE refoldMany1 #-} refoldMany1 :: Monad m => Refold m x a b -> Fold m b c -> Refold m x a c -refoldMany1 (Refold sstep sinject sextract) (Fold cstep cinitial cextract) = +refoldMany1 + (Refold sstep sinject sextract) + (Fold cstep cinitial cextract _cfinal) = Refold step inject extract where @@ -1834,7 +2443,7 @@ {-# INLINE refold #-} refold :: Monad m => Refold m b a c -> Fold m a b -> Fold m a c refold (Refold step inject extract) f = - Fold step (extractM f >>= inject) extract + Fold step (extractM f >>= inject) extract extract ------------------------------------------------------------------------------ -- morphInner @@ -1844,8 +2453,8 @@ -- -- /Pre-release/ morphInner :: (forall x. m x -> n x) -> Fold m a b -> Fold n a b -morphInner f (Fold step initial extract) = - Fold (\x a -> f $ step x a) (f initial) (f . extract) +morphInner f (Fold step initial extract final) = + Fold (\x a -> f $ step x a) (f initial) (f . extract) (f . final) -- | Adapt a pure fold to any monad. -- diff --git a/src/Streamly/Internal/Data/Fold/Window.hs b/src/Streamly/Internal/Data/Fold/Window.hs --- a/src/Streamly/Internal/Data/Fold/Window.hs +++ b/src/Streamly/Internal/Data/Fold/Window.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Internal.Data.Fold.Window -- Copyright : (c) 2020 Composewell Technologies @@ -18,10 +19,13 @@ -- For more advanced statistical measures see the @streamly-statistics@ -- package. --- XXX A window fold can be driven either using the Ring.slidingWindow +-- XXX A window fold can be driven either using the RingArray.slidingWindow -- combinator or by zipping nthLast fold and last fold. +-- XXX Deprecate all the functions in this module. These should be scans only. + module Streamly.Internal.Data.Fold.Window + {-# DEPRECATED "Please use Streamly.Internal.Data.Scanl instead." #-} ( -- * Incremental Folds -- | Folds of type @Fold m (a, Maybe a) b@ are incremental sliding window @@ -36,47 +40,46 @@ -- window folds by keeping the second element of the input tuple as -- @Nothing@. -- - lmap + windowLmap , cumulative - , rollingMap - , rollingMapM + , windowRollingMap + , windowRollingMapM -- ** Sums - , length - , sum - , sumInt - , powerSum - , powerSumFrac + , windowLength + , windowSum + , windowSumInt + , windowPowerSum + , windowPowerSumFrac -- ** Location - , minimum - , maximum - , range - , mean + , windowMinimum + , windowMaximum + , windowRange + , windowMean ) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Bifunctor(bimap) -import Foreign.Storable (Storable, peek) +import Data.Proxy (Proxy(..)) +import Streamly.Internal.Data.RingArray (RingArray(..)) +import Streamly.Internal.Data.Unbox (Unbox(..)) import Streamly.Internal.Data.Fold.Type (Fold(..), Step(..)) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3Fused' (Tuple3Fused')) import qualified Streamly.Internal.Data.Fold.Type as Fold -import qualified Streamly.Internal.Data.Ring.Unboxed as Ring +import qualified Streamly.Internal.Data.MutArray.Type as MutArray +import qualified Streamly.Internal.Data.RingArray as RingArray +-- import qualified Streamly.Internal.Data.Scanl.Type as Scanl import Prelude hiding (length, sum, minimum, maximum) --- $setup --- >>> import Data.Bifunctor(bimap) --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Internal.Data.Fold.Window as FoldW --- >>> import qualified Streamly.Internal.Data.Ring.Unboxed as Ring --- >>> import qualified Streamly.Data.Stream as Stream --- >>> import Prelude hiding (length, sum, minimum, maximum) +#include "ArrayMacros.h" +#include "DocTestDataFold.hs" ------------------------------------------------------------------------------- -- Utilities @@ -85,11 +88,12 @@ -- | Map a function on the incoming as well as outgoing element of a rolling -- window fold. -- +-- >>> :set -fno-warn-deprecations -- >>> lmap f = Fold.lmap (bimap f (f <$>)) -- -{-# INLINE lmap #-} -lmap :: (c -> a) -> Fold m (a, Maybe a) b -> Fold m (c, Maybe c) b -lmap f = Fold.lmap (bimap f (f <$>)) +{-# INLINE windowLmap #-} +windowLmap :: (c -> a) -> Fold m (a, Maybe a) b -> Fold m (c, Maybe c) b +windowLmap f = Fold.lmap (bimap f (f <$>)) -- | Convert an incremental fold to a cumulative fold using the entire input -- stream as a single window. @@ -105,10 +109,10 @@ -- | Apply an effectful function on the latest and the oldest element of the -- window. -{-# INLINE rollingMapM #-} -rollingMapM :: Monad m => +{-# INLINE windowRollingMapM #-} +windowRollingMapM :: Monad m => (Maybe a -> a -> m (Maybe b)) -> Fold m (a, Maybe a) (Maybe b) -rollingMapM f = Fold.foldlM' f1 initial +windowRollingMapM f = Fold.foldlM' f1 initial where @@ -118,12 +122,12 @@ -- | Apply a pure function on the latest and the oldest element of the window. -- --- >>> rollingMap f = FoldW.rollingMapM (\x y -> return $ f x y) +-- >>> windowRollingMap f = Fold.windowRollingMapM (\x y -> return $ f x y) -- -{-# INLINE rollingMap #-} -rollingMap :: Monad m => +{-# INLINE windowRollingMap #-} +windowRollingMap :: Monad m => (Maybe a -> a -> Maybe b) -> Fold m (a, Maybe a) (Maybe b) -rollingMap f = Fold.foldl' f1 initial +windowRollingMap f = Fold.foldl' f1 initial where @@ -136,7 +140,7 @@ ------------------------------------------------------------------------------- -- XXX Overflow. --- + -- | The sum of all the elements in a rolling window. The input elements are -- required to be intergal numbers. -- @@ -146,9 +150,9 @@ -- -- /Internal/ -- -{-# INLINE sumInt #-} -sumInt :: forall m a. (Monad m, Integral a) => Fold m (a, Maybe a) a -sumInt = Fold step initial extract +{-# INLINE windowSumInt #-} +windowSumInt :: forall m a. (Monad m, Integral a) => Fold m (a, Maybe a) a +windowSumInt = Fold step initial extract extract where @@ -164,14 +168,14 @@ extract = return -- XXX Overflow. --- + -- | Sum of all the elements in a rolling window: -- -- \(S = \sum_{i=1}^n x_{i}\) -- -- This is the first power sum. -- --- >>> sum = powerSum 1 +-- >>> windowSum = Fold.windowPowerSum 1 -- -- Uses Kahan-Babuska-Neumaier style summation for numerical stability of -- floating precision arithmetic. @@ -180,9 +184,9 @@ -- -- /Time/: \(\mathcal{O}(n)\) -- -{-# INLINE sum #-} -sum :: forall m a. (Monad m, Num a) => Fold m (a, Maybe a) a -sum = Fold step initial extract +{-# INLINE windowSum #-} +windowSum :: forall m a. (Monad m, Num a) => Fold m (a, Maybe a) a +windowSum = Fold step initial extract extract where @@ -217,11 +221,11 @@ -- -- This is the \(0\)th power sum. -- --- >>> length = powerSum 0 +-- >>> length = Fold.windowPowerSum 0 -- -{-# INLINE length #-} -length :: (Monad m, Num b) => Fold m (a, Maybe a) b -length = Fold.foldl' step 0 +{-# INLINE windowLength #-} +windowLength :: (Monad m, Num b) => Fold m (a, Maybe a) b +windowLength = Fold.foldl' step 0 where @@ -232,29 +236,40 @@ -- -- \(S_k = \sum_{i=1}^n x_{i}^k\) -- --- >>> powerSum k = lmap (^ k) sum +-- >>> windowPowerSum k = Fold.windowLmap (^ k) Fold.windowSum -- -- /Space/: \(\mathcal{O}(1)\) -- -- /Time/: \(\mathcal{O}(n)\) -{-# INLINE powerSum #-} -powerSum :: (Monad m, Num a) => Int -> Fold m (a, Maybe a) a -powerSum k = lmap (^ k) sum +{-# INLINE windowPowerSum #-} +windowPowerSum :: (Monad m, Num a) => Int -> Fold m (a, Maybe a) a +windowPowerSum k = windowLmap (^ k) windowSum -- | Like 'powerSum' but powers can be negative or fractional. This is slower -- than 'powerSum' for positive intergal powers. -- --- >>> powerSumFrac p = lmap (** p) sum +-- >>> windowPowerSumFrac p = Fold.windowLmap (** p) Fold.windowSum -- -{-# INLINE powerSumFrac #-} -powerSumFrac :: (Monad m, Floating a) => a -> Fold m (a, Maybe a) a -powerSumFrac p = lmap (** p) sum +{-# INLINE windowPowerSumFrac #-} +windowPowerSumFrac :: (Monad m, Floating a) => a -> Fold m (a, Maybe a) a +windowPowerSumFrac p = windowLmap (** p) windowSum ------------------------------------------------------------------------------- -- Location ------------------------------------------------------------------------------- --- XXX Remove MonadIO constraint +{-# INLINE ringRange #-} +ringRange :: (MonadIO m, Unbox a, Ord a) => RingArray a -> m (Maybe (a, a)) +-- Ideally this should perform the same as the implementation below, but it is +-- 2x worse, need to investigate why. +-- ringRange = RingArray.fold (Fold.fromScanl Scanl.range) +ringRange rb@RingArray{..} = do + if ringSize == 0 + then return Nothing + else do + x <- liftIO $ peekAt 0 ringContents + let accum (mn, mx) a = return (min mn a, max mx a) + in fmap Just $ RingArray.foldlM' accum (x, x) rb -- | Determine the maximum and minimum in a rolling window. -- @@ -265,44 +280,40 @@ -- -- /Time/: \(\mathcal{O}(n*w)\) where \(w\) is the window size. -- -{-# INLINE range #-} -range :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe (a, a)) -range n = Fold step initial extract +{-# INLINE windowRange #-} +windowRange :: forall m a. (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (Maybe (a, a)) +-- windowRange = + -- Fold.fromScanl . RingArray.scanFoldRingsBy (Fold.fromScanl Scanl.range) +-- Ideally this should perform the same as the implementation below which is +-- just expanded form of this. Some inlining/exitify optimization makes this +-- perform much worse. Need to investigate and fix that. +-- windowRange = Fold.fromScanl . RingArray.scanCustomFoldRingsBy ringRange +windowRange n = Fold step initial extract extract where - -- XXX Use Ring unfold and then fold for composing maximum and minimum to - -- get the range. - initial = if n <= 0 - then error "range: window size must be > 0" - else - let f (a, b) = Partial $ Tuple3Fused' a b (0 :: Int) - in fmap f $ liftIO $ Ring.new n - - step (Tuple3Fused' rb rh i) a = do - rh1 <- liftIO $ Ring.unsafeInsert rb rh a - return $ Partial $ Tuple3Fused' rb rh1 (i + 1) + then error "ringsOf: window size must be > 0" + else do + arr :: MutArray.MutArray a <- liftIO $ MutArray.emptyOf n + return $ Partial $ Tuple3Fused' (MutArray.arrContents arr) 0 0 - -- XXX We need better Ring array APIs so that we can unfold the ring to a - -- stream and fold the stream using a fold of our choice. - -- - -- We could just scan the stream to get a stream of ring buffers and then - -- map required folds over those, but we need to be careful that all those - -- rings refer to the same mutable ring, therefore, downstream needs to - -- process those strictly before it can change. - foldFunc i - | i < n = Ring.unsafeFoldRingM - | otherwise = Ring.unsafeFoldRingFullM + step (Tuple3Fused' mba rh i) a = do + RingArray _ _ rh1 <- RingArray.replace_ (RingArray mba (n * SIZE_OF(a)) rh) a + return $ Partial $ Tuple3Fused' mba rh1 (i + 1) - extract (Tuple3Fused' rb rh i) = - if i == 0 - then return Nothing - else do - x <- liftIO $ peek rh - let accum (mn, mx) a = return (min mn a, max mx a) - fmap Just $ foldFunc i rh accum (x, x) rb + -- XXX exitify optimization causes a problem here when modular folds are + -- used. Sometimes inlining "extract" is helpful. + -- {-# INLINE extract #-} + extract (Tuple3Fused' mba rh i) = + -- XXX If newest is lower than the current min than new is the min. + -- XXX If exiting one was equal to min only then we need to find new min + -- XXX We can supply a custom extract function to a generic window + -- operation. + let rs = min i n * SIZE_OF(a) + rh1 = if i <= n then 0 else rh + in ringRange $ RingArray mba rs rh1 -- | Find the minimum element in a rolling window. -- @@ -316,9 +327,11 @@ -- -- /Time/: \(\mathcal{O}(n*w)\) where \(w\) is the window size. -- -{-# INLINE minimum #-} -minimum :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe a) -minimum n = fmap (fmap fst) $ range n +{-# INLINE windowMinimum #-} +windowMinimum :: (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (Maybe a) +windowMinimum n = fmap (fmap fst) $ windowRange n +-- windowMinimum = + -- Fold.fromScanl . RingArray.scanFoldRingsBy (Fold.fromScanl Scanl.minimum) -- | The maximum element in a rolling window. -- @@ -329,9 +342,11 @@ -- -- /Time/: \(\mathcal{O}(n*w)\) where \(w\) is the window size. -- -{-# INLINE maximum #-} -maximum :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe a) -maximum n = fmap (fmap snd) $ range n +{-# INLINE windowMaximum #-} +windowMaximum :: (MonadIO m, Unbox a, Ord a) => Int -> Fold m a (Maybe a) +windowMaximum n = fmap (fmap snd) $ windowRange n +-- windowMaximum = + -- Fold.fromScanl . RingArray.scanFoldRingsBy (Fold.fromScanl Scanl.maximum) -- | Arithmetic mean of elements in a sliding window: -- @@ -341,11 +356,11 @@ -- sliding window and Cumulative Moving Avergae (CMA) when used on the entire -- stream. -- --- >>> mean = Fold.teeWith (/) sum length +-- >>> mean = Fold.teeWith (/) Fold.windowSum Fold.windowLength -- -- /Space/: \(\mathcal{O}(1)\) -- -- /Time/: \(\mathcal{O}(n)\) -{-# INLINE mean #-} -mean :: forall m a. (Monad m, Fractional a) => Fold m (a, Maybe a) a -mean = Fold.teeWith (/) sum length +{-# INLINE windowMean #-} +windowMean :: forall m a. (Monad m, Fractional a) => Fold m (a, Maybe a) a +windowMean = Fold.teeWith (/) windowSum windowLength diff --git a/src/Streamly/Internal/Data/IOFinalizer.hs b/src/Streamly/Internal/Data/IOFinalizer.hs --- a/src/Streamly/Internal/Data/IOFinalizer.hs +++ b/src/Streamly/Internal/Data/IOFinalizer.hs @@ -66,6 +66,9 @@ -- never runs again. Note, the finalizing action runs with async exceptions -- masked. -- +-- If this function is called multiple times, the action is guaranteed to run +-- once and only once. +-- -- /Pre-release/ runIOFinalizer :: MonadIO m => IOFinalizer -> m () runIOFinalizer (IOFinalizer ref) = liftIO $ do @@ -83,9 +86,16 @@ -- | Run an action clearing the finalizer atomically wrt async exceptions. The -- action is run with async exceptions masked. -- +-- This function can be called at most once after setting the finalizer. If the +-- finalizer is not set it is considered a bug. +-- -- /Pre-release/ clearingIOFinalizer :: MonadIO m => IOFinalizer -> IO a -> m a clearingIOFinalizer (IOFinalizer ref) action = do liftIO $ mask_ $ do - writeIORef ref Nothing - action + res <- readIORef ref + case res of + Just _ -> do + writeIORef ref Nothing + action + Nothing -> error "clearingIOFinalizer: finalizer not set" diff --git a/src/Streamly/Internal/Data/IORef.hs b/src/Streamly/Internal/Data/IORef.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/IORef.hs @@ -0,0 +1,114 @@ +-- | +-- Module : Streamly.Internal.Data.IORef +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A mutable variable in a mutation capable monad (IO) holding a 'Unboxed' +-- value. This allows fast modification because of unboxed storage. +-- +-- = Multithread Consistency Notes +-- +-- In general, any value that straddles a machine word cannot be guaranteed to +-- be consistently read from another thread without a lock. GHC heap objects +-- are always machine word aligned, therefore, a 'IORef' is also word aligned. +-- On a 64-bit platform, writing a 64-bit aligned type from one thread and +-- reading it from another thread should give consistent old or new value. The +-- same holds true for 32-bit values on a 32-bit platform. + +module Streamly.Internal.Data.IORef + ( + IORef + + -- Construction + , newIORef + + -- Write + , writeIORef + , modifyIORef' + + -- Read + , readIORef + , pollGenericIORef + , pollIORefInt + ) +where + +#include "inline.hs" +#include "deprecation.h" + +import Control.Monad.IO.Class (MonadIO(..)) +#if __GLASGOW_HASKELL__ >= 810 +import Data.Kind (Type) +#endif +import Data.Proxy (Proxy(..)) +import Streamly.Internal.Data.MutByteArray.Type (MutByteArray) +import Streamly.Internal.Data.Unbox (Unbox(..), sizeOf) + +import qualified Streamly.Internal.Data.MutByteArray.Type as MBA +import qualified Streamly.Internal.Data.Stream.Type as D + +-- | An 'IORef' holds a single 'Unbox'-able value. +#if __GLASGOW_HASKELL__ >= 810 +type IORef :: Type -> Type +#endif +newtype IORef a = IORef MutByteArray + +-- | Create a new 'IORef'. +-- +-- /Pre-release/ +{-# INLINE newIORef #-} +newIORef :: forall a. Unbox a => a -> IO (IORef a) +newIORef x = do + var <- MBA.new (sizeOf (Proxy :: Proxy a)) + pokeAt 0 var x + return $ IORef var + +-- | Write a value to an 'IORef'. +-- +-- /Pre-release/ +{-# INLINE writeIORef #-} +writeIORef :: Unbox a => IORef a -> a -> IO () +writeIORef (IORef var) = pokeAt 0 var + +-- | Read a value from an 'IORef'. +-- +-- /Pre-release/ +{-# INLINE readIORef #-} +readIORef :: Unbox a => IORef a -> IO a +readIORef (IORef var) = peekAt 0 var + +-- | Modify the value of an 'IORef' using a function with strict application. +-- +-- /Pre-release/ +{-# INLINE modifyIORef' #-} +modifyIORef' :: Unbox a => IORef a -> (a -> a) -> IO () +modifyIORef' var g = do + x <- readIORef var + writeIORef var (g x) + +-- | Internal, do not use. +{-# INLINE_NORMAL pollGenericIORef #-} +pollGenericIORef :: (MonadIO m, Unbox a) => IORef a -> D.Stream m a +pollGenericIORef var = D.Stream step () + + where + + {-# INLINE_LATE step #-} + step _ () = liftIO (readIORef var) >>= \x -> return $ D.Yield x () + +-- | Generate a stream by continuously reading the IORef. +-- +-- This operation reads the IORef without any synchronization. It can be +-- assumed to be atomic because the size fits into machine register size. We +-- are assuming that compiler uses single instructions to access the memory. It +-- may read stale values though until caches are synchronised in a +-- multiprocessor architecture. +-- +-- /Pre-release/ +{-# INLINE_NORMAL pollIORefInt #-} +pollIORefInt :: MonadIO m => IORef Int -> D.Stream m Int +pollIORefInt = pollGenericIORef diff --git a/src/Streamly/Internal/Data/IORef/Unboxed.hs b/src/Streamly/Internal/Data/IORef/Unboxed.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/IORef/Unboxed.hs +++ /dev/null @@ -1,100 +0,0 @@ --- | --- Module : Streamly.Internal.Data.IORef.Unboxed --- Copyright : (c) 2019 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- A mutable variable in a mutation capable monad (IO) holding a 'Unboxed' --- value. This allows fast modification because of unboxed storage. --- --- = Multithread Consistency Notes --- --- In general, any value that straddles a machine word cannot be guaranteed to --- be consistently read from another thread without a lock. GHC heap objects --- are always machine word aligned, therefore, a 'IORef' is also word aligned. --- On a 64-bit platform, writing a 64-bit aligned type from one thread and --- reading it from another thread should give consistent old or new value. The --- same holds true for 32-bit values on a 32-bit platform. - -module Streamly.Internal.Data.IORef.Unboxed - ( - IORef - - -- * Construction - , newIORef - - -- * Write - , writeIORef - , modifyIORef' - - -- * Read - , readIORef - , toStreamD - ) -where - -#include "inline.hs" - -import Data.Proxy (Proxy(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Streamly.Internal.Data.Unboxed - ( MutableByteArray(..) - , Unbox - , sizeOf - , peekWith - , pokeWith - , newUnpinnedBytes - ) - -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D - --- | An 'IORef' holds a single 'Unbox'-able value. -newtype IORef a = IORef MutableByteArray - --- | Create a new 'IORef'. --- --- /Pre-release/ -{-# INLINE newIORef #-} -newIORef :: forall a. Unbox a => a -> IO (IORef a) -newIORef x = do - var <- newUnpinnedBytes (sizeOf (Proxy :: Proxy a)) - pokeWith var 0 x - return $ IORef var - --- | Write a value to an 'IORef'. --- --- /Pre-release/ -{-# INLINE writeIORef #-} -writeIORef :: Unbox a => IORef a -> a -> IO () -writeIORef (IORef var) = pokeWith var 0 - --- | Read a value from an 'IORef'. --- --- /Pre-release/ -{-# INLINE readIORef #-} -readIORef :: Unbox a => IORef a -> IO a -readIORef (IORef var) = peekWith var 0 - --- | Modify the value of an 'IORef' using a function with strict application. --- --- /Pre-release/ -{-# INLINE modifyIORef' #-} -modifyIORef' :: Unbox a => IORef a -> (a -> a) -> IO () -modifyIORef' var g = do - x <- readIORef var - writeIORef var (g x) - --- | Generate a stream by continuously reading the IORef. --- --- /Pre-release/ -{-# INLINE_NORMAL toStreamD #-} -toStreamD :: (MonadIO m, Unbox a) => IORef a -> D.Stream m a -toStreamD var = D.Stream step () - - where - - {-# INLINE_LATE step #-} - step _ () = liftIO (readIORef var) >>= \x -> return $ D.Yield x () diff --git a/src/Streamly/Internal/Data/IsMap.hs b/src/Streamly/Internal/Data/IsMap.hs --- a/src/Streamly/Internal/Data/IsMap.hs +++ b/src/Streamly/Internal/Data/IsMap.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} -- | -- Module : Streamly.Internal.Data.IsMap -- Copyright : (c) 2022 Composewell Technologies @@ -28,6 +32,8 @@ mapDelete :: Key f -> f a -> f a mapUnion :: f a -> f a -> f a mapNull :: f a -> Bool + mapTraverseWithKey :: + Applicative t => (Key f -> a -> t b) -> f a -> t (f b) instance Ord k => IsMap (Map k) where type Key (Map k) = k @@ -39,6 +45,7 @@ mapDelete = Map.delete mapUnion = Map.union mapNull = Map.null + mapTraverseWithKey = Map.traverseWithKey instance IsMap IntMap.IntMap where type Key IntMap.IntMap = Int @@ -50,3 +57,4 @@ mapDelete = IntMap.delete mapUnion = IntMap.union mapNull = IntMap.null + mapTraverseWithKey = IntMap.traverseWithKey diff --git a/src/Streamly/Internal/Data/List.hs b/src/Streamly/Internal/Data/List.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/List.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Streamly.Internal.Data.List --- Copyright : (c) 2018 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : pre-release --- Portability : GHC --- --- Lists are just a special case of monadic streams. The stream type @Stream --- Identity a@ can be used as a replacement for @[a]@. The 'List' type in this --- module is just a newtype wrapper around @Stream Identity@ for better type --- inference when using the 'OverloadedLists' GHC extension. @List a@ provides --- better performance compared to @[a]@. Standard list, string and list --- comprehension syntax can be used with the 'List' type by enabling --- 'OverloadedLists', 'OverloadedStrings' and 'MonadComprehensions' GHC --- extensions. There would be a slight difference in the 'Show' and 'Read' --- strings of streamly list as compared to regular lists. --- --- Conversion to stream types is free, any stream combinator can be used on --- lists by converting them to streams. However, for convenience, this module --- provides combinators that work directly on the 'List' type. --- --- --- @ --- List $ S.map (+ 1) $ toStream (1 \`Cons\` Nil) --- @ --- --- To convert a 'List' to regular lists, you can use any of the following: --- --- * @toList . toStream@ and @toStream . fromList@ --- * 'Data.Foldable.toList' from "Data.Foldable" --- * 'GHC.Exts.toList' and 'GHC.Exts.fromList' from 'IsList' in "GHC.Exts" --- --- If you have made use of 'Nil' and 'Cons' constructors in the code and you --- want to replace streamly lists with standard lists, all you need to do is --- import these definitions: --- --- @ --- type List = [] --- pattern Nil <- [] where Nil = [] --- pattern Cons x xs = x : xs --- infixr 5 `Cons` --- {-\# COMPLETE Cons, Nil #-} --- @ --- --- See for more details and --- for comprehensive usage examples. --- -module Streamly.Internal.Data.List - ( - List (Nil, Cons) - - , toStream - , fromStream - - -- XXX we may want to use rebindable syntax for variants instead of using - -- different types (applicative do and apWith). - , ZipList (..) - , fromZipList - , toZipList - ) -where - -import Control.Arrow (second) -import Data.Functor.Identity (Identity, runIdentity) -import GHC.Exts (IsList(..), IsString(..)) -import Streamly.Internal.Data.Stream.Cross (CrossStream(..)) -import Streamly.Internal.Data.Stream.Type (Stream) -import Streamly.Internal.Data.Stream.Zip (ZipStream(..)) -import Text.Read (readPrec) - -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -import qualified Streamly.Internal.Data.Stream.Type as Stream - --- XXX Rename to PureStream. - --- | @List a@ is a replacement for @[a]@. --- --- /Pre-release/ -newtype List a = List { toCrossStream :: CrossStream Identity a } - deriving - ( Eq, Ord - , Semigroup, Monoid, Functor, Foldable - , Applicative, Traversable, Monad, IsList) - -toStream :: List a -> Stream Identity a -toStream = unCrossStream . toCrossStream - -fromStream :: Stream Identity a -> List a -fromStream xs = List (CrossStream xs) - -instance (a ~ Char) => IsString (List a) where - {-# INLINE fromString #-} - fromString = List . fromList - -instance Show a => Show (List a) where - show (List x) = show $ unCrossStream x - -instance Read a => Read (List a) where - readPrec = fromStream <$> readPrec - ------------------------------------------------------------------------------- --- Patterns ------------------------------------------------------------------------------- - --- Note: When using the OverloadedLists extension we should be able to pattern --- match using the regular list contructors. OverloadedLists uses 'toList' to --- perform the pattern match, it should not be too bad as it works lazily in --- the Identity monad. We need these patterns only when not using that --- extension. - --- | An empty list constructor and pattern that matches an empty 'List'. --- Corresponds to '[]' for Haskell lists. --- -pattern Nil :: List a -pattern Nil <- (runIdentity . K.null . Stream.toStreamK . toStream -> True) - - where - - Nil = List $ CrossStream (Stream.fromStreamK K.nil) - -infixr 5 `Cons` - --- | A list constructor and pattern that deconstructs a 'List' into its head --- and tail. Corresponds to ':' for Haskell lists. --- -pattern Cons :: a -> List a -> List a -pattern Cons x xs <- - (fmap (second (List . CrossStream . Stream.fromStreamK)) - . runIdentity . K.uncons . Stream.toStreamK . toStream - -> Just (x, xs) - ) - - where - - Cons x xs = List $ CrossStream $ Stream.cons x (toStream xs) - -{-# COMPLETE Nil, Cons #-} - ------------------------------------------------------------------------------- --- ZipList ------------------------------------------------------------------------------- - --- | Just like 'List' except that it has a zipping 'Applicative' instance --- and no 'Monad' instance. --- -newtype ZipList a = ZipList { toZipStream :: ZipStream Identity a } - deriving - ( Show, Read, Eq, Ord - , Semigroup, Monoid, Functor, Foldable - , Applicative, Traversable, IsList - ) - -instance (a ~ Char) => IsString (ZipList a) where - {-# INLINE fromString #-} - fromString = ZipList . fromList - --- | Convert a 'ZipList' to a regular 'List' --- -fromZipList :: ZipList a -> List a -fromZipList (ZipList zs) = List $ CrossStream (unZipStream zs) - --- | Convert a regular 'List' to a 'ZipList' --- -toZipList :: List a -> ZipList a -toZipList = ZipList . ZipStream . toStream diff --git a/src/Streamly/Internal/Data/MutArray.hs b/src/Streamly/Internal/Data/MutArray.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/MutArray.hs @@ -0,0 +1,425 @@ +-- | +-- Module : Streamly.Internal.Data.MutArray +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +-- XXX To detect array overflow issues we can have a debug mode in RTS where we +-- allocate one additional page beyond a large allocation and unmap that page +-- so that we get segfault if it is accessed. Also any unpinned large +-- allocations can be kept unmapped for a while after being freed in case those +-- are being used by someone, also we can aggressively move such pages to +-- detect problems more quickly. +-- +module Streamly.Internal.Data.MutArray + ( + -- * MutArray.Type module + module Streamly.Internal.Data.MutArray.Type + -- * MutArray module + , indexerFromLen + , splitterFromLen + -- , splitFromLen + -- , splitChunksOf + , compactMax + , compactMax' + , compactSepByByte_ + , compactEndByByte_ + , compactEndByLn_ + , createOfLast + + -- XXX Do not expose these yet, we should perhaps expose only the Get/Put + -- monads instead? Decide after implementing the monads. + + -- * Serialization + , serialize + , deserialize + , serializePtrN + , deserializePtrN + + -- * Deprecated + , slicerFromLen + , sliceIndexerFromLen + , genSlicesFromLen + , getSlicesFromLen + , compactLE + , pinnedCompactLE + , compactOnByte + , compactOnByteSuffix + , IORef + , newIORef + , writeIORef + , modifyIORef' + , readIORef + , pollIntIORef + ) +where + +#include "assert.hs" +#include "deprecation.h" +#include "inline.hs" +#include "ArrayMacros.h" + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Word (Word8) +import Foreign.Ptr (Ptr) +import Streamly.Internal.Data.MutByteArray.Type (PinnedState(..)) +import Streamly.Internal.Data.Serialize.Type (Serialize) +import Streamly.Internal.Data.Stream.Type (Stream) +import Streamly.Internal.Data.Unbox (Unbox) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.Data.Fold.Type (Fold) + +import qualified Streamly.Internal.Data.IORef as IORef +import qualified Streamly.Internal.Data.RingArray as RingArray +import qualified Streamly.Internal.Data.Serialize.Type as Serialize +import qualified Streamly.Internal.Data.Stream.Nesting as Stream +import qualified Streamly.Internal.Data.Stream.Type as Stream +import qualified Streamly.Internal.Data.Fold.Type as Fold +-- import qualified Streamly.Internal.Data.Stream.Transform as Stream +import qualified Streamly.Internal.Data.Unfold as Unfold + +import Prelude hiding (foldr, length, read) +import Streamly.Internal.Data.MutArray.Type + +-- | Generate a stream of array slice descriptors ((index, len)) of specified +-- length from an array, starting from the supplied array index. The last slice +-- may be shorter than the requested length depending on the array length. +-- +-- /Pre-release/ +{-# INLINE indexerFromLen #-} +indexerFromLen, sliceIndexerFromLen :: forall m a. (Monad m, Unbox a) + => Int -- ^ from index + -> Int -- ^ length of the slice + -> Unfold m (MutArray a) (Int, Int) +indexerFromLen from len = + let fromThenTo n = (from, from + len, n - 1) + mkSlice n i = return (i, min len (n - i)) + in Unfold.lmap length + $ Unfold.mapM (uncurry mkSlice) . Unfold.carry + $ Unfold.lmap fromThenTo Unfold.enumerateFromThenTo +RENAME(sliceIndexerFromLen,indexerFromLen) + +{-# DEPRECATED genSlicesFromLen "Please use indexerFromLen instead." #-} +genSlicesFromLen :: forall m a. (Monad m, Unbox a) + => Int -- ^ from index + -> Int -- ^ length of the slice + -> Unfold m (MutArray a) (Int, Int) +genSlicesFromLen = indexerFromLen + +-- | Generate a stream of slices of specified length from an array, starting +-- from the supplied array index. The last slice may be shorter than the +-- requested length depending on the array length. +-- +-- /Pre-release/ +{-# INLINE splitterFromLen #-} +splitterFromLen, slicerFromLen :: forall m a. (Monad m, Unbox a) + => Int -- ^ from index + -> Int -- ^ length of the slice + -> Unfold m (MutArray a) (MutArray a) +splitterFromLen from len = + let mkSlice arr (i, n) = return $ unsafeSliceOffLen i n arr + in Unfold.mapM (uncurry mkSlice) + $ Unfold.carry (indexerFromLen from len) +RENAME(slicerFromLen,splitterFromLen) + +{-# DEPRECATED getSlicesFromLen "Please use splitterFromLen instead." #-} +getSlicesFromLen :: forall m a. (Monad m, Unbox a) + => Int -- ^ from index + -> Int -- ^ length of the slice + -> Unfold m (MutArray a) (MutArray a) +getSlicesFromLen = splitterFromLen + +-------------------------------------------------------------------------------- +-- Serialization/Deserialization using Serialize +-------------------------------------------------------------------------------- + +{-# INLINE unsafeSerialize #-} +unsafeSerialize :: (MonadIO m, Serialize a) => + MutArray Word8 -> a -> m (MutArray Word8) +unsafeSerialize (MutArray mbarr start end bound) a = do +#ifdef DEBUG + let len = Serialize.addSizeTo 0 a + assertM(bound - end >= len) +#endif + off <- liftIO $ Serialize.serializeAt end mbarr a + pure $ MutArray mbarr start off bound + +{-# NOINLINE serializeRealloc #-} +serializeRealloc :: forall m a. (MonadIO m, Serialize a) => + (Int -> Int) + -> MutArray Word8 + -> a + -> m (MutArray Word8) +serializeRealloc sizer arr x = do + let len = Serialize.addSizeTo 0 x + arr1 <- liftIO $ reallocBytesWith "serializeRealloc" sizer len arr + unsafeSerialize arr1 x + +{-# INLINE serializeWith #-} +serializeWith :: forall m a. (MonadIO m, Serialize a) => + (Int -> Int) + -> MutArray Word8 + -> a + -> m (MutArray Word8) +serializeWith sizer arr@(MutArray mbarr start end bound) x = do + let len = Serialize.addSizeTo 0 x + if (bound - end) >= len + then do + off <- liftIO $ Serialize.serializeAt end mbarr x + assertM(len <= off) + pure $ MutArray mbarr start off bound + -- XXX this will inhibit unboxing? + else serializeRealloc sizer arr x + +-- | Serializes a (Ptr, len) pair in the same way as an array. The serialized +-- value can be de-serialized as an array or consumed as a pointer using +-- deserializePtrN. +-- +-- The Ptr must be pinned or the existence of the Ptr must be ensured by the +-- user of this API. +-- +-- /Unimplemented/ +{-# INLINE serializePtrN #-} +serializePtrN :: -- (MonadIO m) => + MutArray Word8 -> Ptr a -> Int -> m (MutArray Word8) +-- assert/error out if Ptr is not pinned. unsafe prefix? +-- First serialize the length and then splice the ptr +serializePtrN _arr _ptr _len = undefined + +-- | Consume a serialized array or (Ptr, length) from the MutArray using an IO +-- action that consumes the pointer directly. +-- +-- WARNING! The array must be a pinned array. +-- +-- /Unimplemented/ +{-# INLINE deserializePtrN #-} +deserializePtrN :: -- (MonadIO m) => + MutArray Word8 -> (Ptr a -> Int -> m b) -> m (a, MutArray Word8) +-- assert/error out if the array is not pinned. unsafe prefix? +deserializePtrN _arr _action = undefined + +-- | Serialize the supplied Haskell value at the end of the mutable array, +-- growing the array size. If there is no reserve capacity left in the array +-- the array is reallocated to double the current size. +-- +-- Like 'snoc' except that the value is serialized to the byte array. +-- +-- Note: If you are serializing a large number of small fields, and the types +-- are statically known, then it may be more efficient to declare a record of +-- those fields and derive an 'Serialize' instance of the entire record. +-- +-- /Unstable API/ +{-# INLINE serialize #-} +serialize :: forall m a. (MonadIO m, Serialize a) => + MutArray Word8 -> a -> m (MutArray Word8) +serialize = serializeWith f + + where + + f oldSize = + if isPower2 oldSize + then oldSize * 2 + else roundUpToPower2 oldSize * 2 + +-- | Deserialize a Haskell value from the beginning of a mutable array. The +-- deserialized value is removed from the array and the remaining array is +-- returned. +-- +-- Like 'uncons' except that the value is deserialized from the byte array. +-- +-- Note: If you are deserializing a large number of small fields, and the types +-- are statically known, then it may be more efficient to declare a record of +-- those fields and derive 'Serialize' instance of the entire record. +-- +-- /Unstable API/ +{-# INLINE deserialize #-} +deserialize :: (MonadIO m, Serialize a) => + MutArray Word8 -> m (a, MutArray Word8) +deserialize arr@(MutArray {..}) = do + let lenArr = byteLength arr + (off, val) <- + liftIO $ Serialize.deserializeAt arrStart arrContents (arrStart + lenArr) + assertM(off <= arrStart + lenArr) + pure (val, MutArray arrContents off arrEnd arrBound) + +------------------------------------------------------------------------------- +-- Compacting Streams of Arrays +------------------------------------------------------------------------------- + +-- | @compactLE maxElems@ coalesces adjacent arrays in the input stream +-- only if the combined size would be less than or equal to @maxElems@ +-- elements. Note that it won't split an array if the original array is already +-- larger than maxElems. +-- +-- @maxElems@ must be greater than 0. +-- +-- Generates unpinned arrays irrespective of the pinning status of input +-- arrays. +{-# INLINE compactMax #-} +compactMax, compactLE :: (MonadIO m, Unbox a) => + Int -> Stream m (MutArray a) -> Stream m (MutArray a) +-- XXX compactLE can be moved to MutArray/Type if we are not using the parser +-- to implement it. +compactMax = compactLeAs Unpinned +-- The parser version turns out to be a little bit slower. +-- compactLE n = Stream.catRights . Stream.parseManyD (pCompactLE n) + +RENAME(compactLE,compactMax) + +-- | Like 'compactBySizeLE' but generates pinned arrays. +{-# INLINE_NORMAL compactMax' #-} +compactMax', pinnedCompactLE :: forall m a. (MonadIO m, Unbox a) + => Int -> Stream m (MutArray a) -> Stream m (MutArray a) +compactMax' = compactLeAs Pinned +-- compactMax' n = Stream.catRights . Stream.parseManyD (pPinnedCompactLE n) + +{-# DEPRECATED pinnedCompactLE "Please use compactMax' instead." #-} +{-# INLINE pinnedCompactLE #-} +pinnedCompactLE = compactMax' + +data SplitState s arr + = Initial s + | Buffering s arr + | Splitting s arr + | Yielding arr (SplitState s arr) + | Finishing + +-- | Split a stream of arrays on a given separator byte, dropping the separator +-- and coalescing all the arrays between two separators into a single array. +-- +{-# INLINE_NORMAL _compactSepByByteCustom #-} +_compactSepByByteCustom + :: MonadIO m + => Word8 + -> Stream m (MutArray Word8) + -> Stream m (MutArray Word8) +_compactSepByByteCustom byte (Stream.Stream step state) = + Stream.Stream step' (Initial state) + + where + + {-# INLINE_LATE step' #-} + step' gst (Initial st) = do + r <- step gst st + case r of + Stream.Yield arr s -> do + (arr1, marr2) <- breakEndByWord8_ byte arr + return $ case marr2 of + Nothing -> Stream.Skip (Buffering s arr1) + Just arr2 -> Stream.Skip (Yielding arr1 (Splitting s arr2)) + Stream.Skip s -> return $ Stream.Skip (Initial s) + Stream.Stop -> return Stream.Stop + + step' gst (Buffering st buf) = do + r <- step gst st + case r of + Stream.Yield arr s -> do + (arr1, marr2) <- breakEndByWord8_ byte arr + -- XXX Use spliceExp instead and then rightSize? + buf1 <- splice buf arr1 + return $ case marr2 of + Nothing -> Stream.Skip (Buffering s buf1) + Just x -> Stream.Skip (Yielding buf1 (Splitting s x)) + Stream.Skip s -> return $ Stream.Skip (Buffering s buf) + Stream.Stop -> return $ + if byteLength buf == 0 + then Stream.Stop + else Stream.Skip (Yielding buf Finishing) + + step' _ (Splitting st buf) = do + (arr1, marr2) <- breakEndByWord8_ byte buf + return $ case marr2 of + Nothing -> Stream.Skip $ Buffering st arr1 + Just arr2 -> Stream.Skip $ Yielding arr1 (Splitting st arr2) + + step' _ (Yielding arr next) = return $ Stream.Yield arr next + step' _ Finishing = return Stream.Stop + +-- XXX implement predicate based version of this compactSepBy_, compactEndBy_ +-- XXX the versions that use equality can be named compactSepByElem_ etc. The +-- byte/word etc versions of that can be specialized using rewrite rules. + +-- | Split a stream of arrays on a given separator byte, dropping the separator +-- and coalescing all the arrays between two separators into a single array. +-- +{-# INLINE compactSepByByte_ #-} +compactSepByByte_, compactOnByte + :: (MonadIO m) + => Word8 + -> Stream m (MutArray Word8) + -> Stream m (MutArray Word8) +-- XXX compare perf of custom vs idiomatic version +-- compactOnByte = _compactOnByteCustom +-- XXX use spliceExp and rightSize? +compactSepByByte_ byte = Stream.splitInnerBy (breakEndByWord8_ byte) splice + +RENAME(compactOnByte,compactSepByByte_) + +-- | Split a stream of arrays on a given separator byte, dropping the separator +-- and coalescing all the arrays between two separators into a single array. +-- +{-# INLINE compactEndByByte_ #-} +compactEndByByte_, compactOnByteSuffix + :: (MonadIO m) + => Word8 + -> Stream m (MutArray Word8) + -> Stream m (MutArray Word8) +compactEndByByte_ byte = + -- XXX use spliceExp and rightSize? + Stream.splitInnerBySuffix + (\arr -> byteLength arr == 0) (breakEndByWord8_ byte) splice + +RENAME(compactOnByteSuffix,compactEndByByte_) + +-- XXX On windows we should compact on "\r\n". We can just compact on '\n' and +-- drop the last byte in each array if it is '\r'. + +-- | Compact byte arrays on newline character, dropping the newline char. +{-# INLINE compactEndByLn_ #-} +compactEndByLn_ :: MonadIO m + => Stream m (MutArray Word8) + -> Stream m (MutArray Word8) +compactEndByLn_ = compactEndByByte_ 10 + +-- | @createOfLast n@ folds a maximum of @n@ elements from the end of the input +-- stream to an 'MutArray'. +-- +{-# INLINE createOfLast #-} +createOfLast :: (Unbox a, MonadIO m) => Int -> Fold m a (MutArray a) +createOfLast n = + Fold.ifThen + (pure (n <= 0)) + (Fold.fromPure empty) + (Fold.rmapM RingArray.toMutArray $ RingArray.createOfLast n) + +-------------------------------------------------------------------------------- +-- IoRef (Deprecated) +-------------------------------------------------------------------------------- + +{-# DEPRECATED IORef "Use IORef from MutByteArray module." #-} +type IORef = IORef.IORef + +{-# DEPRECATED pollIntIORef "Use pollIntIORef from MutByteArray module." #-} +pollIntIORef :: (MonadIO m, Unbox a) => IORef a -> Stream m a +pollIntIORef = IORef.pollGenericIORef + +{-# DEPRECATED newIORef "Use newIORef from MutByteArray module." #-} +newIORef :: forall a. Unbox a => a -> IO (IORef a) +newIORef = IORef.newIORef + + +{-# DEPRECATED writeIORef "Use writeIORef from MutByteArray module." #-} +writeIORef :: Unbox a => IORef a -> a -> IO () +writeIORef = IORef.writeIORef + + +{-# DEPRECATED modifyIORef' "Use modifyIORef' from MutByteArray module." #-} +modifyIORef' :: Unbox a => IORef a -> (a -> a) -> IO () +modifyIORef' = IORef.modifyIORef' + + +{-# DEPRECATED readIORef "Use readIORef from MutByteArray module." #-} +readIORef :: Unbox a => IORef a -> IO a +readIORef = IORef.readIORef diff --git a/src/Streamly/Internal/Data/MutArray/Generic.hs b/src/Streamly/Internal/Data/MutArray/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/MutArray/Generic.hs @@ -0,0 +1,981 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UnboxedTuples #-} +-- | +-- Module : Streamly.Internal.Data.MutArray.Generic +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.MutArray.Generic +( + -- * Type + -- $arrayNotes + MutArray (..) + + -- * Constructing and Writing + -- ** Construction + , nil + + -- ** Utils + , initializeOfFilledUpto + + -- *** Uninitialized Arrays + , emptyOf + -- , newArrayWith + + -- *** From streams + , unsafeCreateOf + , createOf + , createWith -- createOfMin/createMin/createGE? + , create + , fromStreamN + , fromStream + , fromPureStream + + -- , writeRevN + -- , writeRev + + -- ** From containers + , fromListN + , fromList + + -- * Random writes + , putIndex + , unsafePutIndex + , putIndices + -- , putFromThenTo + -- , putFrom -- start writing at the given position + -- , putUpto -- write from beginning up to the given position + -- , putFromTo + -- , putFromRev + -- , putUptoRev + , unsafeModifyIndex + , modifyIndex + -- , modifyIndices + -- , modify + -- , swapIndices + + -- * Growing and Shrinking + -- Arrays grow only at the end, though it is possible to grow on both sides + -- and therefore have a cons as well as snoc. But that will require two + -- bounds in the array representation. + + -- ** Reallocation + , realloc + , uninit + + -- ** Appending elements + , snocWith + , snoc + -- , snocLinear + -- , snocMay + , unsafeSnoc + + -- ** Appending streams + -- , writeAppendNUnsafe + -- , writeAppendN + -- , writeAppendWith + -- , writeAppend + + -- ** Truncation + -- These are not the same as slicing the array at the beginning, they may + -- reduce the length as well as the capacity of the array. + -- , truncateWith + -- , truncate + -- , truncateExp + + -- * Eliminating and Reading + + -- ** Unfolds + , reader + -- , readerRev + , producerWith -- experimental + , producer -- experimental + + -- ** To containers + , read + , readRev + , toStreamK + -- , toStreamKRev + , toList + + -- ** Random reads + , getIndex + , unsafeGetIndex + , unsafeGetIndexWith + -- , getIndices + -- , getFromThenTo + -- , getIndexRev + + -- * Size + , length + + -- * In-place Mutation Algorithms + , dropAround + -- , reverse + -- , permute + -- , partitionBy + -- , shuffleBy + -- , divideBy + -- , mergeBy + + -- * Folding + -- , foldl' + -- , foldr + , cmp + , eq + + -- * Arrays of arrays + -- We can add dimensionality parameter to the array type to get + -- multidimensional arrays. Multidimensional arrays would just be a + -- convenience wrapper on top of single dimensional arrays. + + -- | Operations dealing with multiple arrays, streams of arrays or + -- multidimensional array representations. + + -- ** Construct from streams + , chunksOf + -- , arrayStreamKFromStreamD + -- , writeChunks + + -- ** Eliminate to streams + -- , flattenArrays + -- , flattenArraysRev + -- , fromArrayStreamK + + -- ** Construct from arrays + -- get chunks without copying + , unsafeSliceOffLen + , sliceOffLen + -- , getSlicesFromLenN + -- , splitAt -- XXX should be able to express using sliceOffLen + -- , breakOn + + -- ** Appending arrays + -- , spliceCopy + -- , spliceWith + -- , splice + -- , spliceExp + , unsafePutSlice + -- , appendSlice + -- , appendSliceFrom + + , clone + + -- * Deprecated + , getSlice + , strip + , new + , writeNUnsafe + , writeN + , writeWith + , write + , getIndexUnsafe + , getIndexUnsafeWith + , putIndexUnsafe + , modifyIndexUnsafe + , snocUnsafe + , getSliceUnsafe + , putSliceUnsafe + ) +where + +#include "inline.hs" +#include "deprecation.h" +#include "assert.hs" + +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Functor.Identity (Identity(..)) +import GHC.Base + ( MutableArray# + , RealWorld + , copyMutableArray# + , newArray# + , readArray# + , writeArray# + ) +import GHC.IO (IO(..)) +import GHC.Int (Int(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Producer.Type (Producer (..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.Data.Stream.Type (Stream) +import Streamly.Internal.Data.SVar.Type (adaptState) + +import qualified Streamly.Internal.Data.Fold.Type as FL +import qualified Streamly.Internal.Data.Producer as Producer +import qualified Streamly.Internal.Data.Stream.Type as D +import qualified Streamly.Internal.Data.Stream.Generate as D +import qualified Streamly.Internal.Data.Stream.Lift as D +import qualified Streamly.Internal.Data.StreamK.Type as K + +import Prelude hiding (read, length, replicate) + +#include "DocTestDataMutArrayGeneric.hs" + +------------------------------------------------------------------------------- +-- MutArray Data Type +------------------------------------------------------------------------------- + +data MutArray a = + MutArray + { arrContents# :: MutableArray# RealWorld a + -- ^ The internal contents of the array representing the entire array. + + , arrStart :: {-# UNPACK #-}!Int + -- ^ The starting index of this slice. + + , arrEnd :: {-# UNPACK #-}!Int + -- ^ The index after the last initialized index. + + , arrBound :: {-# UNPACK #-}!Int + -- ^ The first invalid index. + } + +{-# INLINE bottomElement #-} +bottomElement :: a +bottomElement = + error + $ unwords + [ funcName + , "This is the bottom element of the array." + , "This is a place holder and should never be reached!" + ] + + where + + funcName = "Streamly.Internal.Data.MutArray.Generic.bottomElement:" + +-- XXX Would be nice if GHC can provide something like newUninitializedArray# so +-- that we do not have to write undefined or error in the whole array. + +{-# INLINE initializeOfFilledUpto #-} +initializeOfFilledUpto :: MonadIO m => Int -> Int -> a -> m (MutArray a) +initializeOfFilledUpto n@(I# n#) end val = + liftIO + $ IO + $ \s# -> + case newArray# n# val s# of + (# s1#, arr# #) -> + let ma = MutArray arr# 0 end n + in (# s1#, ma #) + +-- | @emptyOf count@ allocates a zero length array that can be extended to hold +-- up to 'count' items without reallocating. +-- +-- /Pre-release/ +{-# INLINE emptyOf #-} +emptyOf :: MonadIO m => Int -> m (MutArray a) +emptyOf n = initializeOfFilledUpto n 0 bottomElement + +{-# DEPRECATED new "Please use emptyOf instead." #-} +{-# INLINE new #-} +new :: MonadIO m => Int -> m (MutArray a) +new = emptyOf + +-- XXX This could be pure? + +-- | +-- Definition: +-- +-- >>> nil = MutArray.emptyOf 0 +{-# INLINE nil #-} +nil :: MonadIO m => m (MutArray a) +nil = new 0 + +------------------------------------------------------------------------------- +-- Random writes +------------------------------------------------------------------------------- + +-- | Write the given element to the given index of the 'MutableArray#'. Does not +-- check if the index is out of bounds of the array. +-- +-- /Pre-release/ +{-# INLINE putIndexUnderlying #-} +putIndexUnderlying :: MonadIO m => Int -> MutableArray# RealWorld a -> a -> m () +putIndexUnderlying n _arrContents# x = + liftIO + $ IO + $ \s# -> + case n of + I# n# -> + let s1# = writeArray# _arrContents# n# x s# + in (# s1#, () #) + +-- | Write the given element to the given index of the array. Does not check if +-- the index is out of bounds of the array. +-- +-- /Pre-release/ +{-# INLINE unsafePutIndex #-} +unsafePutIndex, putIndexUnsafe :: forall m a. MonadIO m => Int -> MutArray a -> a -> m () +unsafePutIndex i arr@(MutArray {..}) x = + assert (i >= 0 && i < length arr) + (putIndexUnderlying (i + arrStart) arrContents# x) + +invalidIndex :: String -> Int -> a +invalidIndex label i = + error $ label ++ ": invalid array index " ++ show i + +-- | /O(1)/ Write the given element at the given index in the array. +-- Performs in-place mutation of the array. +-- +-- >>> putIndex ix arr val = MutArray.modifyIndex ix arr (const (val, ())) +-- +-- /Pre-release/ +{-# INLINE putIndex #-} +putIndex :: MonadIO m => Int -> MutArray a -> a -> m () +putIndex i arr x = + if i >= 0 && i < length arr + then unsafePutIndex i arr x + else invalidIndex "putIndex" i + +-- | Write an input stream of (index, value) pairs to an array. Throws an +-- error if any index is out of bounds. +-- +-- /Pre-release/ +{-# INLINE putIndices #-} +putIndices :: MonadIO m + => MutArray a -> Fold m (Int, a) () +putIndices arr = FL.foldlM' step (return ()) + + where + + step () (i, x) = putIndex i arr x + +-- | Modify a given index of an array using a modifier function without checking +-- the bounds. +-- +-- Unsafe because it does not check the bounds of the array. +-- +-- /Pre-release/ +unsafeModifyIndex, modifyIndexUnsafe :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b +unsafeModifyIndex i MutArray {..} f = do + liftIO + $ IO + $ \s# -> + case i + arrStart of + I# n# -> + case readArray# arrContents# n# s# of + (# s1#, a #) -> + let (a1, b) = f a + s2# = writeArray# arrContents# n# a1 s1# + in (# s2#, b #) + +-- | Modify a given index of an array using a modifier function. +-- +-- /Pre-release/ +modifyIndex :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b +modifyIndex i arr f = do + if i >= 0 && i < length arr + then unsafeModifyIndex i arr f + else invalidIndex "modifyIndex" i + +------------------------------------------------------------------------------- +-- Resizing +------------------------------------------------------------------------------- + +-- | Reallocates the array according to the new size. This is a safe function +-- that always creates a new array and copies the old array into the new one. +-- If the reallocated size is less than the original array it results in a +-- truncated version of the original array. +-- +realloc :: MonadIO m => Int -> MutArray a -> m (MutArray a) +realloc n arr = do + arr1 <- new n + let !newLen@(I# newLen#) = min n (length arr) + !(I# arrS#) = arrStart arr + !(I# arr1S#) = arrStart arr1 + arrC# = arrContents# arr + arr1C# = arrContents# arr1 + !newEnd = arrStart arr1 + newLen + !newBound = arrStart arr1 + n + liftIO + $ IO + $ \s# -> + let s1# = copyMutableArray# arrC# arrS# arr1C# arr1S# newLen# s# + in (# s1#, arr1 {arrEnd = newEnd, arrBound = newBound} #) + +reallocWith :: + MonadIO m => String -> (Int -> Int) -> Int -> MutArray a -> m (MutArray a) +reallocWith label sizer reqSize arr = do + let oldSize = length arr + newSize = sizer oldSize + safeSize = max newSize (oldSize + reqSize) + assert (newSize >= oldSize + reqSize || error badSize) (return ()) + realloc safeSize arr + + where + + badSize = concat + [ label + , ": new array size is less than required size " + , show reqSize + , ". Please check the sizing function passed." + ] + +------------------------------------------------------------------------------- +-- Snoc +------------------------------------------------------------------------------- + +-- XXX Not sure of the behavior of writeArray# if we specify an index which is +-- out of bounds. This comment should be rewritten based on that. +-- | Really really unsafe, appends the element into the first array, may +-- cause silent data corruption or if you are lucky a segfault if the index +-- is out of bounds. +-- +-- /Internal/ +{-# INLINE unsafeSnoc #-} +snocUnsafe, unsafeSnoc :: MonadIO m => MutArray a -> a -> m (MutArray a) +unsafeSnoc arr@(MutArray{..}) x = do + let newEnd = arrEnd + 1 + putIndexUnderlying arrEnd arrContents# x + return $ arr {arrEnd = newEnd} + +-- NOINLINE to move it out of the way and not pollute the instruction cache. +{-# NOINLINE snocWithRealloc #-} +snocWithRealloc :: MonadIO m => (Int -> Int) -> MutArray a -> a -> m (MutArray a) +snocWithRealloc sizer arr x = do + arr1 <- reallocWith "snocWithRealloc" sizer 1 arr + unsafeSnoc arr1 x + +-- | @snocWith sizer arr elem@ mutates @arr@ to append @elem@. The length of +-- the array increases by 1. +-- +-- If there is no reserved space available in @arr@ it is reallocated to a size +-- in bytes determined by the @sizer oldSize@ function, where @oldSize@ is the +-- original size of the array. +-- +-- Note that the returned array may be a mutated version of the original array. +-- +-- /Pre-release/ +{-# INLINE snocWith #-} +snocWith :: MonadIO m => (Int -> Int) -> MutArray a -> a -> m (MutArray a) +snocWith sizer arr@MutArray {..} x = do + if arrEnd < arrBound + then unsafeSnoc arr x + else snocWithRealloc sizer arr x + +-- XXX round it to next power of 2. + +-- | The array is mutated to append an additional element to it. If there is no +-- reserved space available in the array then it is reallocated to double the +-- original size. +-- +-- This is useful to reduce allocations when appending unknown number of +-- elements. +-- +-- Note that the returned array may be a mutated version of the original array. +-- +-- >>> snoc = MutArray.snocWith (* 2) +-- +-- Performs O(n * log n) copies to grow, but is liberal with memory allocation. +-- +-- /Pre-release/ +{-# INLINE snoc #-} +snoc :: MonadIO m => MutArray a -> a -> m (MutArray a) +snoc = snocWith (* 2) + +-- | Make the uninitialized memory in the array available for use extending it +-- by the supplied length beyond the current length of the array. The array may +-- be reallocated. +-- +{-# INLINE uninit #-} +uninit :: MonadIO m => MutArray a -> Int -> m (MutArray a) +uninit arr@MutArray{..} len = + if arrEnd + len <= arrBound + then return $ arr {arrEnd = arrEnd + len} + else realloc (length arr + len) arr + +------------------------------------------------------------------------------- +-- Random reads +------------------------------------------------------------------------------- + +-- | Return the element at the specified index without checking the bounds from +-- a @MutableArray# RealWorld@. +-- +-- Unsafe because it does not check the bounds of the array. +{-# INLINE unsafeGetIndexWith #-} +unsafeGetIndexWith, getIndexUnsafeWith :: MonadIO m => MutableArray# RealWorld a -> Int -> m a +unsafeGetIndexWith _arrContents# n = + liftIO + $ IO + $ \s# -> + let !(I# i#) = n + in readArray# _arrContents# i# s# + +-- | Return the element at the specified index without checking the bounds. +-- +-- Unsafe because it does not check the bounds of the array. +{-# INLINE_NORMAL unsafeGetIndex #-} +unsafeGetIndex, getIndexUnsafe :: MonadIO m => Int -> MutArray a -> m a +unsafeGetIndex n MutArray {..} = unsafeGetIndexWith arrContents# (n + arrStart) + +-- | /O(1)/ Lookup the element at the given index. Index starts from 0. +-- +{-# INLINE getIndex #-} +getIndex :: MonadIO m => Int -> MutArray a -> m (Maybe a) +getIndex i arr = + if i >= 0 && i < length arr + then Just <$> unsafeGetIndex i arr + else return Nothing + +------------------------------------------------------------------------------- +-- Subarrays +------------------------------------------------------------------------------- + +-- XXX We can also get immutable slices. + +-- | /O(1)/ Slice an array in constant time. +-- +-- Unsafe: The bounds of the slice are not checked. +-- +-- /Unsafe/ +-- +-- /Pre-release/ +{-# INLINE unsafeSliceOffLen #-} +unsafeSliceOffLen, getSliceUnsafe + :: Int -- ^ from index + -> Int -- ^ length of the slice + -> MutArray a + -> MutArray a +unsafeSliceOffLen index len arr@MutArray {..} = + assert (index >= 0 && len >= 0 && index + len <= length arr) + $ arr {arrStart = newStart, arrEnd = newEnd} + where + newStart = arrStart + index + newEnd = newStart + len + +-- | /O(1)/ Slice an array in constant time. Throws an error if the slice +-- extends out of the array bounds. +-- +-- /Pre-release/ +{-# INLINE sliceOffLen #-} +sliceOffLen, getSlice + :: Int -- ^ from index + -> Int -- ^ length of the slice + -> MutArray a + -> MutArray a +sliceOffLen index len arr@MutArray{..} = + if index >= 0 && len >= 0 && index + len <= length arr + then arr {arrStart = newStart, arrEnd = newEnd} + else error + $ "sliceOffLen: invalid slice, index " + ++ show index ++ " length " ++ show len + where + newStart = arrStart + index + newEnd = newStart + len + +------------------------------------------------------------------------------- +-- to Lists and streams +------------------------------------------------------------------------------- + +-- XXX Maybe faster to create a list explicitly instead of mapM, if list fusion +-- does not work well. + +-- | Convert an 'Array' into a list. +-- +-- /Pre-release/ +{-# INLINE toList #-} +toList :: MonadIO m => MutArray a -> m [a] +toList arr = mapM (`unsafeGetIndex` arr) [0 .. (length arr - 1)] + +-- | Generates a stream from the elements of a @MutArray@. +-- +-- >>> read = Stream.unfold MutArray.reader +-- +{-# INLINE_NORMAL read #-} +read :: MonadIO m => MutArray a -> D.Stream m a +read arr = + D.mapM (`unsafeGetIndex` arr) $ D.enumerateFromToIntegral 0 (length arr - 1) + +-- Check equivalence with StreamK.fromStream . toStreamD and remove +{-# INLINE toStreamK #-} +toStreamK :: MonadIO m => MutArray a -> K.StreamK m a +toStreamK arr = K.unfoldrM step 0 + + where + + arrLen = length arr + step i + | i == arrLen = return Nothing + | otherwise = do + x <- unsafeGetIndex i arr + return $ Just (x, i + 1) + +{-# INLINE_NORMAL readRev #-} +readRev :: MonadIO m => MutArray a -> D.Stream m a +readRev arr = + D.mapM (`unsafeGetIndex` arr) + $ D.enumerateFromThenToIntegral (arrLen - 1) (arrLen - 2) 0 + where + arrLen = length arr + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +-- XXX deduplicate this across unboxed array and this module? + +-- | The default chunk size by which the array creation routines increase the +-- size of the array when the array is grown linearly. +arrayChunkSize :: Int +arrayChunkSize = 1024 + +-- | Like 'createOf' but does not check the array bounds when writing. The fold +-- driver must not call the step function more than 'n' times otherwise it will +-- corrupt the memory and crash. This function exists mainly because any +-- conditional in the step function blocks fusion causing 10x performance +-- slowdown. +-- +-- /Pre-release/ +{-# INLINE_NORMAL unsafeCreateOf #-} +unsafeCreateOf :: MonadIO m => Int -> Fold m a (MutArray a) +unsafeCreateOf n = Fold step initial return return + + where + + initial = FL.Partial <$> new (max n 0) + + step arr x = FL.Partial <$> unsafeSnoc arr x + +{-# DEPRECATED writeNUnsafe "Please use unsafeCreateOf instead." #-} +{-# INLINE writeNUnsafe #-} +writeNUnsafe :: MonadIO m => Int -> Fold m a (MutArray a) +writeNUnsafe = unsafeCreateOf + +-- | @createOf n@ folds a maximum of @n@ elements from the input stream to an +-- 'Array'. +-- +-- >>> createOf n = Fold.take n (MutArray.unsafeCreateOf n) +-- +-- /Pre-release/ +{-# INLINE_NORMAL createOf #-} +createOf :: MonadIO m => Int -> Fold m a (MutArray a) +createOf n = FL.take n $ unsafeCreateOf n + +{-# DEPRECATED writeN "Please use createOf instead." #-} +{-# INLINE writeN #-} +writeN :: MonadIO m => Int -> Fold m a (MutArray a) +writeN = createOf + +-- >>> f n = MutArray.writeAppendWith (* 2) (MutArray.pinnedNew n) +-- >>> writeWith n = Fold.rmapM MutArray.rightSize (f n) +-- >>> writeWith n = Fold.rmapM MutArray.fromArrayStreamK (MutArray.writeChunks n) + +-- | @createWith minCount@ folds the whole input to a single array. The array +-- starts at a size big enough to hold minCount elements, the size is doubled +-- every time the array needs to be grown. +-- +-- /Caution! Do not use this on infinite streams./ +-- +-- /Pre-release/ +{-# INLINE_NORMAL createWith #-} +createWith :: MonadIO m => Int -> Fold m a (MutArray a) +-- writeWith n = FL.rmapM rightSize $ writeAppendWith (* 2) (pinnedNew n) +createWith elemCount = FL.rmapM extract $ FL.foldlM' step initial + + where + + initial = do + when (elemCount < 0) $ error "createWith: elemCount is negative" + new elemCount + + step arr@(MutArray _ start end bound) x + | end == bound = do + let oldSize = end - start + newSize = max (oldSize * 2) 1 + arr1 <- realloc newSize arr + unsafeSnoc arr1 x + step arr x = unsafeSnoc arr x + + -- extract = rightSize + extract = return + +{-# DEPRECATED writeWith "Please use createWith instead." #-} +{-# INLINE writeWith #-} +writeWith :: MonadIO m => Int -> Fold m a (MutArray a) +writeWith = createWith + +-- | Fold the whole input to a single array. +-- +-- Same as 'createWith' using an initial array size of 'arrayChunkSize' bytes +-- rounded up to the element size. +-- +-- /Caution! Do not use this on infinite streams./ +-- +{-# INLINE create #-} +create :: MonadIO m => Fold m a (MutArray a) +create = writeWith arrayChunkSize + +{-# DEPRECATED write "Please use create instead." #-} +{-# INLINE write #-} +write :: MonadIO m => Fold m a (MutArray a) +write = create + +-- | Create a 'MutArray' from the first @n@ elements of a stream. The +-- array is allocated to size @n@, if the stream terminates before @n@ +-- elements then the array may hold less than @n@ elements. +-- +{-# INLINE fromStreamN #-} +fromStreamN :: MonadIO m => Int -> Stream m a -> m (MutArray a) +fromStreamN n = D.fold (writeN n) + +{-# INLINE fromStream #-} +fromStream :: MonadIO m => Stream m a -> m (MutArray a) +fromStream = D.fold write + +{-# INLINABLE fromListN #-} +fromListN :: MonadIO m => Int -> [a] -> m (MutArray a) +fromListN n xs = fromStreamN n $ D.fromList xs + +{-# INLINABLE fromList #-} +fromList :: MonadIO m => [a] -> m (MutArray a) +fromList xs = fromStream $ D.fromList xs + +{-# INLINABLE fromPureStream #-} +fromPureStream :: MonadIO m => Stream Identity a -> m (MutArray a) +fromPureStream xs = + D.fold write $ D.morphInner (return . runIdentity) xs + +------------------------------------------------------------------------------- +-- Chunking +------------------------------------------------------------------------------- + +data GroupState s a start end bound + = GroupStart s + | GroupBuffer s (MutableArray# RealWorld a) start end bound + | GroupYield + (MutableArray# RealWorld a) + start + end + bound + (GroupState s a start end bound) + | GroupFinish + +-- | @chunksOf n stream@ groups the input stream into a stream of +-- arrays of size n. +-- +-- @chunksOf n = foldMany (MutArray.writeN n)@ +-- +-- /Pre-release/ +{-# INLINE_NORMAL chunksOf #-} +chunksOf :: forall m a. MonadIO m + => Int -> D.Stream m a -> D.Stream m (MutArray a) +-- XXX the idiomatic implementation leads to large regression in the D.reverse' +-- benchmark. It seems it has difficulty producing optimized code when +-- converting to StreamK. Investigate GHC optimizations. +-- chunksOf n = D.foldMany (writeN n) +chunksOf n (D.Stream step state) = + D.Stream step' (GroupStart state) + + where + + -- start is always 0 + -- end and len are always equal + + {-# INLINE_LATE step' #-} + step' _ (GroupStart st) = do + when (n <= 0) $ + -- XXX we can pass the module string from the higher level API + error $ "Streamly.Internal.Data.Array.Generic.Mut.Type.chunksOf: " + ++ "the size of arrays [" ++ show n + ++ "] must be a natural number" + (MutArray contents start end bound :: MutArray a) <- new n + return $ D.Skip (GroupBuffer st contents start end bound) + + step' gst (GroupBuffer st contents start end bound) = do + r <- step (adaptState gst) st + case r of + D.Yield x s -> do + putIndexUnderlying end contents x + let end1 = end + 1 + return $ + if end1 >= bound + then D.Skip + (GroupYield + contents start end1 bound (GroupStart s)) + else D.Skip (GroupBuffer s contents start end1 bound) + D.Skip s -> + return $ D.Skip (GroupBuffer s contents start end bound) + D.Stop -> + return + $ D.Skip (GroupYield contents start end bound GroupFinish) + + step' _ (GroupYield contents start end bound next) = + return $ D.Yield (MutArray contents start end bound) next + + step' _ GroupFinish = return D.Stop + +------------------------------------------------------------------------------- +-- Unfolds +------------------------------------------------------------------------------- + +-- | Resumable unfold of an array. +-- +{-# INLINE_NORMAL producerWith #-} +producerWith :: Monad m => (forall b. IO b -> m b) -> Producer m (MutArray a) a +producerWith liftio = Producer step inject extract + + where + + {-# INLINE inject #-} + inject arr = return (arr, 0) + + {-# INLINE extract #-} + extract (arr, i) = + return $ arr {arrStart = arrStart arr + i} + + {-# INLINE_LATE step #-} + step (arr, i) + | i == length arr = return D.Stop + step (arr, i) = do + x <- liftio $ unsafeGetIndex i arr + return $ D.Yield x (arr, i + 1) + +-- | Resumable unfold of an array. +-- +{-# INLINE_NORMAL producer #-} +producer :: MonadIO m => Producer m (MutArray a) a +producer = producerWith liftIO + +-- | Unfold an array into a stream. +-- +{-# INLINE_NORMAL reader #-} +reader :: MonadIO m => Unfold m (MutArray a) a +reader = Producer.simplify producer + +-------------------------------------------------------------------------------- +-- Appending arrays +-------------------------------------------------------------------------------- + +-- | Put a sub range of a source array into a subrange of a destination array. +-- This is not safe as it does not check the bounds. +{-# INLINE unsafePutSlice #-} +unsafePutSlice, putSliceUnsafe :: MonadIO m => + MutArray a -> Int -> MutArray a -> Int -> Int -> m () +unsafePutSlice src srcStart dst dstStart len = liftIO $ do + assertM(len <= length dst) + assertM(len <= length src) + let !(I# srcStart#) = srcStart + arrStart src + !(I# dstStart#) = dstStart + arrStart dst + !(I# len#) = len + let arrS# = arrContents# src + arrD# = arrContents# dst + IO $ \s# -> (# copyMutableArray# + arrS# srcStart# arrD# dstStart# len# s# + , () #) + +{-# INLINE clone #-} +clone :: MonadIO m => MutArray a -> m (MutArray a) +clone src = do + let len = length src + dst <- new len + unsafePutSlice src 0 dst 0 len + return dst + +------------------------------------------------------------------------------- +-- Size +------------------------------------------------------------------------------- + +{-# INLINE length #-} +length :: MutArray a -> Int +length arr = arrEnd arr - arrStart arr + +------------------------------------------------------------------------------- +-- Equality +------------------------------------------------------------------------------- + +-- | Compare the length of the arrays. If the length is equal, compare the +-- lexicographical ordering of two underlying byte arrays otherwise return the +-- result of length comparison. +-- +-- /Pre-release/ +{-# INLINE cmp #-} +cmp :: (MonadIO m, Ord a) => MutArray a -> MutArray a -> m Ordering +cmp a1 a2 = + case compare lenA1 lenA2 of + EQ -> loop (lenA1 - 1) + x -> return x + + where + + lenA1 = length a1 + lenA2 = length a2 + + loop i + | i < 0 = return EQ + | otherwise = do + v1 <- unsafeGetIndex i a1 + v2 <- unsafeGetIndex i a2 + case compare v1 v2 of + EQ -> loop (i - 1) + x -> return x + +{-# INLINE eq #-} +eq :: (MonadIO m, Eq a) => MutArray a -> MutArray a -> m Bool +eq a1 a2 = + if lenA1 == lenA2 + then loop (lenA1 - 1) + else return False + + where + + lenA1 = length a1 + lenA2 = length a2 + + loop i + | i < 0 = return True + | otherwise = do + v1 <- unsafeGetIndex i a1 + v2 <- unsafeGetIndex i a2 + if v1 == v2 + then loop (i - 1) + else return False + +{-# INLINE dropAround #-} +dropAround, strip :: MonadIO m => (a -> Bool) -> MutArray a -> m (MutArray a) +dropAround p arr = liftIO $ do + let lastIndex = length arr - 1 + indexR <- getIndexR lastIndex -- last predicate failing index + if indexR < 0 + then nil + else do + indexL <- getIndexL 0 -- first predicate failing index + if indexL == 0 && indexR == lastIndex + then return arr + else + let newLen = indexR - indexL + 1 + in return $ unsafeSliceOffLen indexL newLen arr + + where + + getIndexR idx + | idx < 0 = return idx + | otherwise = do + r <- unsafeGetIndex idx arr + if p r + then getIndexR (idx - 1) + else return idx + + getIndexL idx = do + r <- unsafeGetIndex idx arr + if p r + then getIndexL (idx + 1) + else return idx + +-------------------------------------------------------------------------------- +-- Renaming +-------------------------------------------------------------------------------- + +RENAME(strip,dropAround) +RENAME(putIndexUnsafe, unsafePutIndex) +RENAME(modifyIndexUnsafe, unsafeModifyIndex) +RENAME(getIndexUnsafe, unsafeGetIndex) +RENAME(getIndexUnsafeWith, unsafeGetIndexWith) +RENAME(getSliceUnsafe,unsafeSliceOffLen) +RENAME(putSliceUnsafe, unsafePutSlice) +RENAME(getSlice,sliceOffLen) +RENAME(snocUnsafe, unsafeSnoc) diff --git a/src/Streamly/Internal/Data/MutArray/Lib.c b/src/Streamly/Internal/Data/MutArray/Lib.c new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/MutArray/Lib.c @@ -0,0 +1,15 @@ +#include + +// Find the char "c" starting from "dst+off" and up to "len" chars from +// it, returns the index of the character found, considering dst + off +// as the base pointer. If index is greater than or equal to len the +// char is not found. +size_t memchr_index(const void *dst, size_t off, int c, size_t len) { + void *p = memchr ((char *)dst + off, c, len); + + if (p) { + return (size_t) (p - dst - off); + } else { + return len; + } +} diff --git a/src/Streamly/Internal/Data/MutArray/Stream.hs b/src/Streamly/Internal/Data/MutArray/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/MutArray/Stream.hs @@ -0,0 +1,146 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} +-- | +-- Module : Streamly.Internal.Data.MutArray.Stream +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Combinators to efficiently manipulate streams of mutable arrays. +-- +-- We can either push these in the MutArray module with a "chunks" prefix or +-- keep this as a separate module and release it. +-- +module Streamly.Internal.Data.MutArray.Stream +{-# DEPRECATED "Please use \"Streamly.Internal.Data.MutArray\" instead." #-} + ( + -- * Generation + MArray.chunksOf + , MArray.pinnedChunksOf + , MArray.writeChunks -- chunksWrite? + , MArray.splitOn -- chunksSplitOn + + -- * Compaction + , packArraysChunksOf + , MArray.SpliceState (..) + , lpackArraysChunksOf + , compact -- chunksCompact + , compactLE + , compactEQ + , compactGE + + -- * Elimination + , MArray.flattenArrays -- chunksConcat + , MArray.flattenArraysRev -- chunksConcatRev + , MArray.fromArrayStreamK -- chunksCoalesce + ) +where + +import Control.Monad.IO.Class (MonadIO(..)) +import Streamly.Internal.Data.Unbox (Unbox) +import Streamly.Internal.Data.MutArray.Type (MutArray(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Parser (ParseError) +import Streamly.Internal.Data.Stream.Type (Stream) + +import qualified Streamly.Internal.Data.MutArray as MArray +import qualified Streamly.Internal.Data.Fold.Type as FL +import qualified Streamly.Internal.Data.Parser as ParserD +import qualified Streamly.Internal.Data.Stream as D + +------------------------------------------------------------------------------- +-- Compact +------------------------------------------------------------------------------- + +-- XXX This can be removed once compactLEFold/compactLE are implemented. +-- +-- | This mutates the first array (if it has space) to append values from the +-- second one. This would work for immutable arrays as well because an +-- immutable array never has space so a new array is allocated instead of +-- mutating it. +-- +-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a +-- maximum specified size. Note that if a single array is bigger than the +-- specified size we do not split it to fit. When we coalesce multiple arrays +-- if the size would exceed the specified size we do not coalesce therefore the +-- actual array size may be less than the specified chunk size. +-- +-- @since 0.7.0 +{-# INLINE packArraysChunksOf #-} +packArraysChunksOf :: (MonadIO m, Unbox a) + => Int -> D.Stream m (MutArray a) -> D.Stream m (MutArray a) +packArraysChunksOf = MArray.compactLE + +-- XXX Remove this once compactLEFold is implemented +-- lpackArraysChunksOf = Fold.many compactLEFold +-- +{-# INLINE lpackArraysChunksOf #-} +lpackArraysChunksOf :: (MonadIO m, Unbox a) + => Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () +lpackArraysChunksOf = MArray.lCompactGE + +-- XXX Same as compactLE, to be removed once that is implemented. +-- +-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a +-- maximum specified size in bytes. +-- +-- /Internal/ +{-# INLINE compact #-} +compact :: (MonadIO m, Unbox a) + => Int -> Stream m (MutArray a) -> Stream m (MutArray a) +compact = packArraysChunksOf + +-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a +-- maximum specified size. Note that if a single array is bigger than the +-- specified size we do not split it to fit. When we coalesce multiple arrays +-- if the size would exceed the specified size we do not coalesce therefore the +-- actual array size may be less than the specified chunk size. +-- +-- /Internal/ +{-# INLINE compactLEParserD #-} +compactLEParserD :: + forall m a. (MonadIO m, Unbox a) + => Int -> ParserD.Parser (MutArray a) m (MutArray a) +compactLEParserD = MArray.pCompactLE + +-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a +-- minimum specified size. Note that if all the arrays in the stream together +-- are smaller than the specified size the resulting array will be smaller than +-- the specified size. When we coalesce multiple arrays if the size would exceed +-- the specified size we stop coalescing further. +-- +-- /Internal/ +{-# INLINE compactGEFold #-} +compactGEFold :: + forall m a. (MonadIO m, Unbox a) + => Int -> FL.Fold m (MutArray a) (MutArray a) +compactGEFold = MArray.fCompactGE + +-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a +-- maximum specified size in bytes. +-- +-- /Internal/ +compactLE :: (MonadIO m, Unbox a) => + Int -> Stream m (MutArray a) -> Stream m (Either ParseError (MutArray a)) +compactLE n = D.parseManyD (compactLEParserD n) + +-- | Like 'compactLE' but generates arrays of exactly equal to the size +-- specified except for the last array in the stream which could be shorter. +-- +-- /Unimplemented/ +{-# INLINE compactEQ #-} +compactEQ :: -- (MonadIO m, Unbox a) => + Int -> Stream m (MutArray a) -> Stream m (MutArray a) +compactEQ _n _xs = undefined + -- IsStream.fromStreamD $ D.foldMany (compactEQFold n) (IsStream.toStreamD xs) + +-- | Like 'compactLE' but generates arrays of size greater than or equal to the +-- specified except for the last array in the stream which could be shorter. +-- +-- /Internal/ +{-# INLINE compactGE #-} +compactGE :: + (MonadIO m, Unbox a) + => Int -> Stream m (MutArray a) -> Stream m (MutArray a) +compactGE n = D.foldMany (compactGEFold n) diff --git a/src/Streamly/Internal/Data/MutArray/Type.hs b/src/Streamly/Internal/Data/MutArray/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/MutArray/Type.hs @@ -0,0 +1,4221 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UnliftedFFITypes #-} +-- | +-- Module : Streamly.Internal.Data.MutArray.Type +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Pinned and unpinned mutable array for 'Unboxed' types. Fulfils the following +-- goals: +-- +-- * Random access (array) +-- * Efficient storage (unboxed) +-- * Performance (unboxed access) +-- * Performance - in-place operations (mutable) +-- * Performance - GC (pinned, mutable) +-- * interfacing with OS (pinned) +-- +-- Stream and Fold APIs allow easy, efficient and convenient operations on +-- arrays. +-- +-- Mutable arrays and file system files are quite similar, they can grow and +-- their content is mutable. Therefore, both have similar APIs as well. We +-- strive to keep the API consistent for both. Ideally, you should be able to +-- replace one with another with little changes to the code. + +module Streamly.Internal.Data.MutArray.Type + ( + -- ** Type + -- $arrayNotes + MutArray (..) + , fromMutByteArray + , toMutByteArray + + -- ** Conversion + -- *** Pinned and Unpinned + , pin + , unpin + , isPinned + + -- ** Casting + , cast + , unsafeCast + , asBytes + , unsafeAsPtr -- XXX asPtr + , asCString + , asCWString + + -- ** Construction + , empty + -- , singleton + + -- *** New + -- | New arrays are always empty arrays with some reserve capacity to + -- extend the length without reallocating. + , emptyOf + , emptyWithAligned -- XXX emptyAlignAtWith + , emptyOf' + + -- *** Slicing + -- | Get a subarray without copying + + -- Element agnostic. + , unsafeSliceOffLen + , sliceOffLen + + -- Counting from the beginning + -- We use the name "break" for splitting into two parts. And the word + -- "split" for splitting into possibly more than two. + , unsafeBreakAt + , breakAt -- called splitAt in lists + -- , take + -- , drop + -- , uncons + -- , tail + + -- Counting from the end + -- , revBreakAt + -- , takeEnd + -- , dropEnd + -- , unsnoc + -- , init + + -- Element aware + -- search from the beginning + , breakEndByWord8_ + , breakEndBy + , breakEndBy_ + -- , breakBeginBy -- called break in lists + -- , breakSpan -- called span in lists + -- , breakBeginBySeq -- called breakOn in text + -- , breakSepBy_ + , dropWhile + -- , takeWhile + -- , stripPrefix + + -- search from the end + , revBreakEndBy + , revBreakEndBy_ + -- , revBreakBeginBy -- called breakOnEnd in text + , revDropWhile -- dropWhileEnd + -- , takeWhileEnd + -- , stripSuffix + + , dropAround + + -- *** Stream Folds + -- | Note: create is just appending to an empty array. So keep the names + -- consistent with append operations. + , ArrayUnsafe (..) + + -- With allocator, of capacity + , unsafeCreateWithOf + , createWithOf -- create alloc with + + , unsafeCreateOf + , createOf + , createMinOf + , create -- XXX should we change the min to one elem or one Word? + -- , createGrowBy + + -- Reverse variants + , revCreateOf + -- , revCreate + + -- Pinned variants + + , unsafeCreateOf' + , createOf' + , create' + + -- *** From containers + -- | These can be implemented by appending a stream to an empty array. + , clone -- XXX fromMutArray or copyMutArray + , clone' + , fromListN + , fromListN' + , fromList + , fromList' + , fromListRevN + , fromListRev + , fromStreamN + , fromStream + , fromPureStreamN + , fromPureStream + , fromCString# + , fromW16CString# + , fromPtrN + , fromChunksK + , fromChunksRealloced -- fromSmallChunks + + , unsafeCreateWithPtr' + + -- ** Random writes + , putIndex + -- , putIndexRev -- or revPutIndex + , unsafePutIndex + , putIndices + -- , putFromThenTo + -- , putFrom -- start writing at the given position + -- , putUpto -- write from beginning up to the given position + -- , putFromTo + -- , putFromRev + -- , putUptoRev + , unsafeModifyIndex + , modifyIndex + , modifyIndices + , modify + , swapIndices + , unsafeSwapIndices + + -- ** Reading + + -- *** Indexing + -- , head + , getIndex + , unsafeGetIndex + , unsafeGetIndexRev + -- , getFromThenTo + -- , last + , getIndexRev -- getRevIndex? + , indexReader + , indexReaderWith + + -- -- *** Searching + -- See the Data.Array module as well + -- , binarySearch + -- , findIndicesOf + -- , getIndicesOf + -- , indexFinder + -- , findIndexOf + -- , find + -- , elem + + -- *** To Streams + , read + , readRev + , toStreamWith + , toStreamRevWith + , toStreamK + , toStreamKWith + , toStreamKRev + , toStreamKRevWith + + -- *** To Containers + , toList + + -- *** Unfolds + -- experimental + , producerWith + , producer + + , reader + , readerRevWith + , readerRev + + -- ** Size and Capacity + -- *** Size + -- , null + -- , compareLength + , length + , byteLength + + -- *** Capacity Reporting + , capacity + , free + , byteCapacity + , bytesFree + + -- *** Capacity Management + -- There are two ways of growing an array: + -- + -- * grow: double, align to next power of 2 if large, never shrink + -- * growBy: align to block size if large, never shrink + + , blockSize + , arrayChunkBytes + , allocBytesToElemCount + , reallocBytes + , reallocBytesWith + + -- , grow -- double the used capacity and align to power of 2 + , growTo + , growBy + , growExp + , rightSize + , vacate + + -- ** Folding + , foldl' + , foldr + , fold + , foldRev -- XXX revFold + , byteCmp + , byteEq + + -- ** In-place Mutation Algorithms + , reverse + , permute + , partitionBy + , shuffleBy + , divideBy + , mergeBy + , bubble + , rangeBy + -- , filter + + -- ** Growing and Shrinking + -- | Arrays grow only at the end, though technically it is possible to + -- grow on both sides and therefore we can have a cons as well as snoc. But + -- cons is not implemented yet. + + -- *** Appending elements + -- | snoc is the fundamental operation for growing arrays. Streaming folds, + -- appending streams can be implemented in terms of snoc. + + -- XXX snoc 128/256/512 bit data using SIMD. + , snocWith -- XXX snocGrowWith + , snoc + , snocGrowBy + , snocMay + , unsafeSnoc + + -- , revSnoc -- cons + -- , revSnocGrowBy -- consGrowBy + + -- *** Folds for appending streams + -- | Fundamentally these are a sequence of snoc operations. + -- Folds are named "append" whereas joining two arrays is named as "splice". + + , appendWith -- XXX replace by pure appendGrowWith + + , unsafeAppendMax -- can be renamed to unsafeAppendN later + , appendMax -- can be renamed to appendN later + -- , appendMin -- like createMinOf, supplies a min hint to reduce allocs + -- , appendGrowWith + , append2 -- to be renamed to append later + , appendGrowBy + + -- , revAppend + -- , revAppendN + -- , revAppendGrowBy + + -- *** Appending streams + -- | Fundamentally these are a sequence of snoc operations. These are + -- convenience operations implemented in terms of folds. + , unsafeAppendPtrN + , appendPtrN + , appendCString + , appendCString# + -- , appendStreamGrowWith + , appendStream + , appendStreamN + -- , appendStreamGrowBy + + -- *** Splicing arrays + -- | TODO: We can replace memcpy with stream copy using Word64. Arrays are + -- aligned on 64-bit boundaries on 64-bit CPUs. A fast way to copy an + -- array is to unsafeCast it to Word64, read it as a stream, write the + -- stream to Word64 array and unsafeCast it again. We can use SIMD + -- read/write as well. + + , spliceCopy -- XXX freeze and splice instead? + , splice + , spliceWith -- XXX spliceGrowWith + , spliceExp -- XXX spliceGrowExp + -- , spliceN + -- , spliceGrowBy + , unsafeSplice + -- , putSlice + -- , appendSlice + -- , appendSliceFrom + + -- XXX Do not expose these yet, we should perhaps expose only the Peek/Poke + -- monads instead? Decide after implementing the monads. + + -- ** Serialization using Unbox + -- | Fixed length serialization. + -- Serialization operations are essentially a combination of serialization + -- using Unbox/Serialize type class, followed by snoc. TODO: use SIMD for + -- snoc. + , poke + , pokeMay + -- , pokeGrowBy + , unsafePokeSkip -- XXX unsafePoke_ + -- , revPoke + + -- ** Deserialization using Unbox + -- Fixed length deserialization. + , peek + , unsafePeek + , unsafePeekSkip -- XXX unsafePeek_ + -- , revPeek + + -- Arrays of arrays + -- We can add dimensionality parameter to the array type to get + -- multidimensional arrays. Multidimensional arrays would just be a + -- convenience wrapper on top of single dimensional arrays. + + -- ** Streams of Arrays + -- *** Chunk + -- | Group a stream into arrays. + , chunksOf + , chunksOf' -- chunksOf' + -- , timedChunksOf -- see the Streamly.Data.Stream.Prelude module + , buildChunks + , chunksEndBy + , chunksEndBy' + , chunksEndByLn + , chunksEndByLn' + -- , chunksBeginBySeq -- for parsing streams with headers + + -- *** Split + -- | Split an array into a stream of slices. + + -- Note: some splitting APIs are in MutArray.hs + , splitEndBy_ + , splitEndBy + -- , splitSepBy_ + -- , splitSepBySeq + -- , splitGroupBy + -- , splitWordsBy + + -- *** Concat + -- | Append the arrays in a stream to form a stream of elements. + , concat + -- , concatSepBy + -- , concatEndBy + -- , concatEndByLn -- unlines - concat a byte chunk stream using newline byte separator + -- , concatWordsBy + , concatWith -- internal + , concatRev + , concatRevWith -- internal + + -- *** Compact + -- | Coalesce arrays together in a stream of arrays to form a stream of + -- larger arrays. + , SpliceState (..) + , compactLeAs -- internal + + -- Creation folds/parsers + , createCompactMax + , createCompactMax' + , createCompactMin + , createCompactMin' + + -- Stream compaction + , compactMin + -- , compactMin' + , compactExact + -- , compactExact' + + -- Scans + , scanCompactMin + , scanCompactMin' + + -- ** Utilities + , isPower2 + , roundUpToPower2 + + -- * Deprecated + , getSlice + , strip + , breakOn + , splitAt + , realloc + , createOfWith + , peekUncons + , peekUnconsUnsafe + , pokeAppend + , pokeAppendMay + , castUnsafe + , newArrayWith + , getSliceUnsafe + , putIndexUnsafe + , modifyIndexUnsafe + , getIndexUnsafe + , snocUnsafe + , spliceUnsafe + , pokeSkipUnsafe + , peekSkipUnsafe + , asPtrUnsafe + , writeChunks + , flattenArrays + , flattenArraysRev + , fromArrayStreamK + , fromStreamDN + , fromStreamD + , cmp + , getIndices + , getIndicesWith + , resize + , resizeExp + , nil + , new + , pinnedNew + , pinnedNewBytes + , writeAppendNUnsafe + , writeAppendN + , writeAppendWith + , writeAppend + , writeNWithUnsafe + , writeNWith + , writeNUnsafe + , pinnedWriteNUnsafe + , writeN + , pinnedWriteN + , pinnedWriteNAligned -- XXX not required + , writeWith + , write + , pinnedWrite + , writeRevN + , fromByteStr# + , pCompactLE + , pPinnedCompactLE + , fCompactGE + , fPinnedCompactGE + , lPinnedCompactGE + , lCompactGE + , compactGE + , pinnedEmptyOf + , pinnedChunksOf + , pinnedCreateOf + , pinnedCreate + , pinnedFromListN + , pinnedFromList + , pinnedClone + , unsafePinnedCreateOf + , splitOn + , pinnedNewAligned + , unsafePinnedAsPtr + , grow + , createWith + , snocLinear + , unsafeAppendN + , appendN + , append + ) +where + +#include "assert.hs" +#include "deprecation.h" +#include "inline.hs" +#include "ArrayMacros.h" +#include "MachDeps.h" + +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Bifunctor (first) +import Data.Bits (shiftR, (.|.), (.&.)) +import Data.Char (ord) +import Data.Functor.Identity (Identity(..)) +import Data.Proxy (Proxy(..)) +import Data.Word (Word8, Word16) +import Foreign.C.String (CString, CWString) +import Foreign.C.Types (CSize(..), CChar, CWchar) +import Foreign.Ptr (plusPtr, castPtr) +import Streamly.Internal.Data.MutByteArray.Type + ( MutByteArray(..) + , PinnedState(..) + , getMutByteArray# + , unsafePutSlice + , blockSize + , largeObjectThreshold + , unsafeByteCmp + ) +import Streamly.Internal.Data.Unbox (Unbox(..)) +import GHC.Base (noinline) +import GHC.Exts (Addr#, MutableByteArray#, RealWorld) +import GHC.Ptr (Ptr(..)) +import GHC.Exts (byteArrayContents#, unsafeCoerce#) + +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Producer.Type (Producer (..)) +import Streamly.Internal.Data.Scanl.Type (Scanl (..)) +import Streamly.Internal.Data.Stream.Type (Stream) +import Streamly.Internal.Data.Parser.Type (Parser (..)) +import Streamly.Internal.Data.StreamK.Type (StreamK) +import Streamly.Internal.Data.SVar.Type (adaptState, defState) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.System.IO (arrayPayloadSize, defaultChunkSize) + +import qualified Streamly.Internal.Data.Fold.Type as FL +import qualified Streamly.Internal.Data.MutByteArray.Type as Unboxed +import qualified Streamly.Internal.Data.Parser.Type as Parser +-- import qualified Streamly.Internal.Data.Fold.Type as Fold +import qualified Streamly.Internal.Data.Producer as Producer +import qualified Streamly.Internal.Data.Stream.Type as D +import qualified Streamly.Internal.Data.Stream.Lift as D +import qualified Streamly.Internal.Data.Stream.Generate as D +import qualified Streamly.Internal.Data.StreamK.Type as K +import qualified Prelude + +import Prelude hiding + (Foldable(..), concat, read, unlines, splitAt, reverse, truncate, dropWhile) + +#include "DocTestDataMutArray.hs" + +------------------------------------------------------------------------------- +-- Foreign helpers +------------------------------------------------------------------------------- + +-- NOTE: Have to be "ccall unsafe" so that we can pass unpinned memory to +-- these. For passing unpinned memory safely we have to pass unlifted byte +-- array pointers in FFI so that neither the constructor nor the array can +-- become stale if a GC kicks in at any point before the call. + +foreign import ccall unsafe "string.h memcpy" c_memcpy_pinned_src + :: MutableByteArray# RealWorld -> Ptr Word8 -> CSize -> IO (Ptr Word8) + +foreign import ccall unsafe "memchr_index" c_memchr_index + :: MutableByteArray# RealWorld -> CSize -> Word8 -> CSize -> IO CSize + +-- XXX Use cstringLength# from GHC.CString in ghc-prim +foreign import ccall unsafe "string.h strlen" c_strlen_pinned + :: Addr# -> IO CSize + +-- | Given an 'Unboxed' type (unused first arg) and a number of bytes, return +-- how many elements of that type will completely fit in those bytes. +-- +{-# INLINE bytesToElemCount #-} +bytesToElemCount :: forall a. Unbox a => a -> Int -> Int +bytesToElemCount _ n = n `div` SIZE_OF(a) + +------------------------------------------------------------------------------- +-- MutArray Data Type +------------------------------------------------------------------------------- + +-- Note on using "IO" callbacks: +-- +-- The Array APIs should use "IO" callbacks instead of lifted callbacks as the +-- lifted callbacks aren't optimized properly. +-- +-- See: +-- https://github.com/composewell/streamly/issues/2820 +-- https://github.com/composewell/streamly/issues/2589 + + +-- $arrayNotes +-- +-- We can use an 'Unboxed' constraint in the MutArray type and the constraint +-- can be automatically provided to a function that pattern matches on the +-- MutArray type. However, it has huge performance cost, so we do not use it. +-- Investigate a GHC improvement possiblity. + +-- | An unboxed mutable array. An array is created with a given length +-- and capacity. Length is the number of valid elements in the array. Capacity +-- is the maximum number of elements that the array can be expanded to without +-- having to reallocate the memory. +-- +-- The elements in the array can be mutated in-place without changing the +-- reference (constructor). However, the length of the array cannot be mutated +-- in-place. A new array reference is generated when the length changes. When +-- the length is increased (upto the maximum reserved capacity of the array), +-- the array is not reallocated and the new reference uses the same underlying +-- memory as the old one. +-- +-- Several routines in this module allow the programmer to control the capacity +-- of the array. The programmer can control the trade-off between memory usage +-- and performance impact due to reallocations when growing or shrinking the +-- array. +-- +data MutArray a = +#ifdef DEVBUILD + Unbox a => +#endif + -- The array is a range into arrContents. arrContents may be a superset of + -- the slice represented by the array. All offsets are in bytes. + MutArray + { arrContents :: {-# UNPACK #-} !MutByteArray + , arrStart :: {-# UNPACK #-} !Int -- ^ index into arrContents + , arrEnd :: {-# UNPACK #-} !Int -- ^ index into arrContents + -- Represents the first invalid index of + -- the array. + -- XXX rename to arrCapacity to be consistent with ring. + , arrBound :: {-# UNPACK #-} !Int -- ^ first invalid index of arrContents. + } + +------------------------------------------------------------------------------- +-- Construction and destructuring +------------------------------------------------------------------------------- + +{-# INLINE fromMutByteArray #-} +fromMutByteArray :: MonadIO m => MutByteArray -> Int -> Int -> m (MutArray a) +fromMutByteArray arr start end = do + len <- liftIO $ Unboxed.length arr + return $ MutArray + { arrContents = arr + , arrStart = start + , arrEnd = end + , arrBound = len + } + +{-# INLINE toMutByteArray #-} +toMutByteArray :: MutArray a -> (MutByteArray, Int, Int) +toMutByteArray MutArray{..} = (arrContents, arrStart, arrEnd) + +------------------------------------------------------------------------------- +-- Pinning & Unpinning +------------------------------------------------------------------------------- + +-- | Return a copy of the array in pinned memory if unpinned, else return the +-- original array. +{-# INLINE pin #-} +pin :: MutArray a -> IO (MutArray a) +pin arr@MutArray{..} = + if Unboxed.isPinned arrContents + then pure arr + else clone' arr + +-- | Return a copy of the array in unpinned memory if pinned, else return the +-- original array. +{-# INLINE unpin #-} +unpin :: MutArray a -> IO (MutArray a) +unpin arr@MutArray{..} = + if Unboxed.isPinned arrContents + then clone arr + else pure arr + +-- | Return 'True' if the array is allocated in pinned memory. +{-# INLINE isPinned #-} +isPinned :: MutArray a -> Bool +isPinned MutArray{..} = Unboxed.isPinned arrContents + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +-- XXX Change the names to use "new" instead of "newArray". That way we can use +-- the same names for managed file system objects as well. For unmanaged ones +-- we can use open/create etc as usual. +-- +-- A new array is similar to "touch" creating a zero length file. An mmapped +-- array would be similar to a sparse file with holes. TBD: support mmapped +-- files and arrays. + +-- GHC always guarantees word-aligned memory, alignment is important only when +-- we need more than that. See stg_pinnedNewAlignedByteArrayzh and +-- allocatePinned in GHC source. + +-- XXX Rename to emptyAlignedWith, alignSize should be first arg. + +-- | @emptyWithAligned allocator alignment count@ allocates a new array of zero +-- length and with a capacity to hold @count@ elements, using @allocator +-- size alignment@ as the memory allocator function. +-- +-- Alignment must be greater than or equal to machine word size and a power of +-- 2. +-- +-- Alignment is ignored if the allocator allocates unpinned memory. +-- +-- /Pre-release/ +{-# INLINE emptyWithAligned #-} +newArrayWith, emptyWithAligned :: forall m a. (MonadIO m, Unbox a) + => (Int -> Int -> IO MutByteArray) -> Int -> Int -> m (MutArray a) +emptyWithAligned alloc alignSize count = liftIO $ do + let size = max (count * SIZE_OF(a)) 0 + contents <- alloc size alignSize + return $ MutArray + { arrContents = contents + , arrStart = 0 + , arrEnd = 0 + , arrBound = size + } + +-- For arrays "nil" sounds a bit odd. empty is better. The only problem with +-- empty is that it is also used by the Alternative type class. But assuming we +-- will mostly import the Array module qualified this should be fine. + +-- | Create an empty array. +empty :: +#ifdef DEVBUILD + Unbox a => +#endif + MutArray a +empty = MutArray Unboxed.empty 0 0 0 + +{-# DEPRECATED nil "Please use empty instead." #-} +nil :: +#ifdef DEVBUILD + Unbox a => +#endif + MutArray a +nil = empty + +{-# INLINE newBytesAs #-} +newBytesAs :: MonadIO m => +#ifdef DEVBUILD + Unbox a => +#endif + PinnedState -> Int -> m (MutArray a) +newBytesAs ps bytes = do + contents <- liftIO $ Unboxed.newAs ps bytes + return $ MutArray + { arrContents = contents + , arrStart = 0 + , arrEnd = 0 + , arrBound = bytes + } + +-- | Allocates a pinned empty array that with a reserved capacity of bytes. +-- The memory of the array is uninitialized and the allocation is aligned as +-- per the 'Unboxed' instance of the type. +-- +-- > pinnedNewBytes = (unsafeCast :: Array Word8 -> a) . emptyOf' +-- +-- /Pre-release/ +{-# INLINE pinnedNewBytes #-} +{-# DEPRECATED pinnedNewBytes "Please use emptyOf' to create a Word8 array and cast it accordingly." #-} +pinnedNewBytes :: MonadIO m => +#ifdef DEVBUILD + Unbox a => +#endif + Int -> m (MutArray a) +pinnedNewBytes = newBytesAs Pinned + +-- | Like 'emptyWithAligned' but using an allocator is a pinned memory allocator and +-- the alignment is dictated by the 'Unboxed' instance of the type. +-- +-- /Internal/ +{-# DEPRECATED pinnedNewAligned "Please use emptyOf' to create a Word8 array and cast it accordingly." #-} +{-# INLINE pinnedNewAligned #-} +pinnedNewAligned :: (MonadIO m, Unbox a) => Int -> Int -> m (MutArray a) +pinnedNewAligned = emptyWithAligned (\s _ -> liftIO $ Unboxed.new' s) + +{-# INLINE newAs #-} +newAs :: (MonadIO m, Unbox a) => PinnedState -> Int -> m (MutArray a) +newAs ps = + emptyWithAligned + (\s _ -> liftIO $ Unboxed.newAs ps s) + (error "new: alignment is not used in unpinned arrays.") + +-- XXX can unaligned allocation be more efficient when alignment is not needed? + +-- | Allocates a pinned array of zero length but growable to the specified +-- capacity without reallocation. +{-# INLINE emptyOf' #-} +pinnedEmptyOf, emptyOf' :: (MonadIO m, Unbox a) => Int -> m (MutArray a) +emptyOf' = newAs Pinned +RENAME_PRIME(pinnedEmptyOf,emptyOf) + +{-# DEPRECATED pinnedNew "Please use emptyOf' instead." #-} +{-# INLINE pinnedNew #-} +pinnedNew :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) +pinnedNew = emptyOf' + +-- | Allocates an unpinned array of zero length but growable to the specified +-- capacity without reallocation. +-- +{-# INLINE emptyOf #-} +emptyOf :: (MonadIO m, Unbox a) => Int -> m (MutArray a) +emptyOf = newAs Unpinned + +{-# DEPRECATED new "Please use emptyOf instead." #-} +{-# INLINE new #-} +new :: (MonadIO m, Unbox a) => Int -> m (MutArray a) +new = emptyOf + +------------------------------------------------------------------------------- +-- Random writes +------------------------------------------------------------------------------- + +-- | Write the given element to the given index of the array. Does not check if +-- the index is out of bounds of the array. +-- +-- /Pre-release/ +{-# INLINE unsafePutIndex #-} +putIndexUnsafe, unsafePutIndex :: forall m a. (MonadIO m, Unbox a) + => Int -> MutArray a -> a -> m () +unsafePutIndex i MutArray{..} x = do + let index = INDEX_OF(arrStart, i, a) + assert (i >= 0 && INDEX_VALID(index, arrEnd, a)) (return ()) + liftIO $ pokeAt index arrContents x + +invalidIndex :: String -> Int -> a +invalidIndex label i = + error $ label ++ ": invalid array index " ++ show i + +-- | /O(1)/ Write the given element at the given index in the array. +-- Performs in-place mutation of the array. +-- +-- >>> putIndex ix arr val = MutArray.modifyIndex ix arr (const (val, ())) +-- >>> f = MutArray.putIndices +-- >>> putIndex ix arr val = Stream.fold (f arr) (Stream.fromPure (ix, val)) +-- +{-# INLINE putIndex #-} +putIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () +putIndex i MutArray{..} x = do + let index = INDEX_OF(arrStart,i,a) + if i >= 0 && INDEX_VALID(index,arrEnd,a) + then liftIO $ pokeAt index arrContents x + else invalidIndex "putIndex" i + +-- | Write an input stream of (index, value) pairs to an array. Throws an +-- error if any index is out of bounds. +-- +-- /Pre-release/ +{-# INLINE putIndices #-} +putIndices :: forall m a. (MonadIO m, Unbox a) + => MutArray a -> Fold m (Int, a) () +putIndices arr = FL.foldlM' step (return ()) + + where + + step () (i, x) = putIndex i arr x + +-- | Modify a given index of an array using a modifier function. +-- +-- Unsafe because it does not check the bounds of the array. +-- +-- /Pre-release/ +modifyIndexUnsafe, unsafeModifyIndex :: forall m a b. (MonadIO m, Unbox a) => + Int -> MutArray a -> (a -> (a, b)) -> m b +unsafeModifyIndex i MutArray{..} f = liftIO $ do + let index = INDEX_OF(arrStart,i,a) + assert (i >= 0 && INDEX_NEXT(index,a) <= arrEnd) (return ()) + r <- peekAt index arrContents + let (x, res) = f r + pokeAt index arrContents x + return res + +-- | Modify a given index of an array using a modifier function. +-- +-- /Pre-release/ +modifyIndex :: forall m a b. (MonadIO m, Unbox a) => + Int -> MutArray a -> (a -> (a, b)) -> m b +modifyIndex i MutArray{..} f = do + let index = INDEX_OF(arrStart,i,a) + if i >= 0 && INDEX_VALID(index,arrEnd,a) + then liftIO $ do + r <- peekAt index arrContents + let (x, res) = f r + pokeAt index arrContents x + return res + else invalidIndex "modifyIndex" i + +-- | Modify the array indices generated by the supplied stream. +-- +-- /Pre-release/ +{-# INLINE modifyIndices #-} +modifyIndices :: forall m a . (MonadIO m, Unbox a) + => MutArray a -> (Int -> a -> a) -> Fold m Int () +modifyIndices arr f = FL.foldlM' step initial + + where + + initial = return () + + step () i = + let f1 x = (f i x, ()) + in modifyIndex i arr f1 + +-- | Modify each element of an array using the supplied modifier function. +-- +-- This is an in-place equivalent of an immutable map operation. +-- +-- /Pre-release/ +modify :: forall m a. (MonadIO m, Unbox a) + => MutArray a -> (a -> a) -> m () +modify MutArray{..} f = liftIO $ + go arrStart + + where + + go i = + when (INDEX_VALID(i,arrEnd,a)) $ do + r <- peekAt i arrContents + pokeAt i arrContents (f r) + go (INDEX_NEXT(i,a)) + +-- XXX We could specify the number of bytes to swap instead of Proxy. Need +-- to ensure that the memory does not overlap. +{-# INLINE swapArrayByteIndices #-} +swapArrayByteIndices :: + forall a. Unbox a + => Proxy a + -> MutByteArray + -> Int + -> Int + -> IO () +swapArrayByteIndices _ arrContents i1 i2 = do + r1 <- peekAt i1 arrContents + r2 <- peekAt i2 arrContents + pokeAt i1 arrContents (r2 :: a) + pokeAt i2 arrContents (r1 :: a) + +-- | Swap the elements at two indices without validating the indices. +-- +-- /Unsafe/: This could result in memory corruption if indices are not valid. +-- +-- /Pre-release/ +{-# INLINE unsafeSwapIndices #-} +unsafeSwapIndices :: forall m a. (MonadIO m, Unbox a) + => Int -> Int -> MutArray a -> m () +unsafeSwapIndices i1 i2 MutArray{..} = liftIO $ do + let t1 = INDEX_OF(arrStart,i1,a) + t2 = INDEX_OF(arrStart,i2,a) + swapArrayByteIndices (Proxy :: Proxy a) arrContents t1 t2 + +-- | Swap the elements at two indices. +-- +-- /Pre-release/ +swapIndices :: forall m a. (MonadIO m, Unbox a) + => Int -> Int -> MutArray a -> m () +swapIndices i1 i2 MutArray{..} = liftIO $ do + let t1 = INDEX_OF(arrStart,i1,a) + t2 = INDEX_OF(arrStart,i2,a) + when (i1 < 0 || INDEX_INVALID(t1,arrEnd,a)) + $ invalidIndex "swapIndices" i1 + when (i2 < 0 || INDEX_INVALID(t2,arrEnd,a)) + $ invalidIndex "swapIndices" i2 + swapArrayByteIndices (Proxy :: Proxy a) arrContents t1 t2 + +------------------------------------------------------------------------------- +-- Rounding +------------------------------------------------------------------------------- + +-- XXX Should be done only when we are using the GHC allocator. +-- | Round up an array larger than 'largeObjectThreshold' to use the whole +-- block. +{-# INLINE roundUpLargeArray #-} +roundUpLargeArray :: Int -> Int +roundUpLargeArray size = + if size >= largeObjectThreshold + then + assert + (blockSize /= 0 && ((blockSize .&. (blockSize - 1)) == 0)) + ((size + blockSize - 1) .&. negate blockSize) + else size + +{-# INLINE isPower2 #-} +isPower2 :: Int -> Bool +isPower2 n = n .&. (n - 1) == 0 + +{-# INLINE roundUpToPower2 #-} +roundUpToPower2 :: Int -> Int +roundUpToPower2 n = +#if WORD_SIZE_IN_BITS == 64 + 1 + z6 +#else + 1 + z5 +#endif + + where + + z0 = n - 1 + z1 = z0 .|. z0 `shiftR` 1 + z2 = z1 .|. z1 `shiftR` 2 + z3 = z2 .|. z2 `shiftR` 4 + z4 = z3 .|. z3 `shiftR` 8 + z5 = z4 .|. z4 `shiftR` 16 + z6 = z5 .|. z5 `shiftR` 32 + +-- | @allocBytesToBytes elem allocatedBytes@ returns the array size in bytes +-- such that the real allocation is less than or equal to @allocatedBytes@, +-- unless @allocatedBytes@ is less than the size of one array element in which +-- case it returns one element's size. +-- +{-# INLINE allocBytesToBytes #-} +allocBytesToBytes :: forall a. Unbox a => a -> Int -> Int +allocBytesToBytes _ n = max (arrayPayloadSize n) (SIZE_OF(a)) + +-- | Given an 'Unboxed' type (unused first arg) and real allocation size +-- (including overhead), return how many elements of that type will completely +-- fit in it, returns at least 1. +-- +{-# INLINE allocBytesToElemCount #-} +allocBytesToElemCount :: Unbox a => a -> Int -> Int +allocBytesToElemCount x bytes = + let n = bytesToElemCount x (allocBytesToBytes x bytes) + in assert (n >= 1) n + +-- | The default chunk size by which the array creation routines increase the +-- size of the array when the array is grown linearly. +arrayChunkBytes :: Int +arrayChunkBytes = 1024 + +------------------------------------------------------------------------------- +-- Resizing +------------------------------------------------------------------------------- + +-- | Round the second argument down to multiples of the first argument. +{-# INLINE roundDownTo #-} +roundDownTo :: Int -> Int -> Int +roundDownTo elemSize size = size - (size `mod` elemSize) + +-- NOTE: we are passing elemSize explicitly to avoid an Unboxed constraint. +-- Since this is not inlined, Unboxed constraint leads to dictionary passing +-- which complicates some inspection tests. +-- +{-# NOINLINE reallocExplicitAs #-} +reallocExplicitAs :: PinnedState -> Int -> Int -> MutArray a -> IO (MutArray a) +reallocExplicitAs ps elemSize newCapacityInBytes MutArray{..} = do + assertM(arrEnd <= arrBound) + + let newCapMaxInBytes = roundUpLargeArray newCapacityInBytes + oldSizeInBytes = arrEnd - arrStart + -- XXX Should we round up instead? + newCapInBytes = roundDownTo elemSize newCapMaxInBytes + newLenInBytes = min oldSizeInBytes newCapInBytes + + assert (oldSizeInBytes `mod` elemSize == 0) (return ()) + assert (newLenInBytes >= 0) (return ()) + assert (newLenInBytes `mod` elemSize == 0) (return ()) + + contents <- + Unboxed.reallocSliceAs + ps newCapInBytes arrContents arrStart newLenInBytes + + return $ MutArray + { arrStart = 0 + , arrContents = contents + , arrEnd = newLenInBytes + , arrBound = newCapInBytes + } + +-- XXX We may also need reallocAs to allocate as pinned/unpinned explicitly. In +-- fact clone/clone' can be implemented using reallocAs. + +-- | @realloc newCapacity array@ reallocates the array to the specified +-- capacity in bytes. +-- +-- If the new size is less than the original array the array gets truncated. +-- If the new size is not a multiple of array element size then it is rounded +-- down to multiples of array size. If the new size is more than +-- 'largeObjectThreshold' then it is rounded up to the block size (4K). +-- +-- If the original array is pinned, the newly allocated array is also pinned. +{-# INLINABLE reallocBytes #-} +realloc, reallocBytes :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (MutArray a) +reallocBytes bytes arr = + let ps = + if isPinned arr + then Pinned + else Unpinned + in liftIO $ reallocExplicitAs ps (SIZE_OF(a)) bytes arr + +-- | @reallocBytesWith label capSizer minIncrBytes array@. The label is used +-- in error messages and the capSizer is used to determine the capacity of the +-- new array in bytes given the current byte length of the array. +reallocBytesWith :: forall m a. (MonadIO m , Unbox a) => + String + -> (Int -> Int) + -> Int + -> MutArray a + -> m (MutArray a) +reallocBytesWith label capSizer minIncrBytes arr = do + let oldSizeBytes = arrEnd arr - arrStart arr + newCapBytes = capSizer oldSizeBytes + newSizeBytes = oldSizeBytes + minIncrBytes + safeCapBytes = max newCapBytes newSizeBytes + assertM(safeCapBytes >= newSizeBytes || error (badSize newSizeBytes)) + + realloc safeCapBytes arr + + where + + badSize newSize = + Prelude.concat + [ label + , ": new array size (in bytes) is less than required size " + , show newSize + , ". Please check the sizing function passed." + ] + +-- | @growTo newCapacity array@ changes the total capacity of the array so that +-- it is enough to hold the specified number of elements. Nothing is done if +-- the specified capacity is less than the length of the array. +-- +-- If the capacity is more than 'largeObjectThreshold' then it is rounded up to +-- the block size (4K). +-- +-- Nothing is done if the requested capacity is <= 0. +-- +-- /Pre-release/ +{-# INLINE growTo #-} +growTo, grow :: forall m a. (MonadIO m, Unbox a) => + Int -> MutArray a -> m (MutArray a) +growTo nElems arr@MutArray{..} = do + let req = SIZE_OF(a) * nElems + cap = arrBound - arrStart + if req < cap + then return arr + else realloc req arr + +RENAME(grow,growTo) + +-- | Like 'growTo' but specifies the required reserve (unused) capacity rather +-- than the total capacity. Increases the reserve capacity, if required, to at +-- least the given amount. +-- +-- Nothing is done if the requested capacity is <= 0. +-- +{-# INLINE growBy #-} +growBy :: forall m a. (MonadIO m, Unbox a) => + Int -> MutArray a -> m (MutArray a) +growBy nElems arr@MutArray{..} = do + let req = arrEnd - arrStart + SIZE_OF(a) * nElems + cap = arrBound - arrStart + if req < cap + then return arr + else realloc req arr + +{-# DEPRECATED resize "Please use growTo instead." #-} +{-# INLINE resize #-} +resize :: forall m a. (MonadIO m, Unbox a) => + Int -> MutArray a -> m (MutArray a) +resize = grow + +-- | Like 'growTo' but if the requested byte capacity is more than +-- 'largeObjectThreshold' then it is rounded up to the closest power of 2. +-- +-- Nothing is done if the requested capacity is <= 0. +-- +-- /Pre-release/ +{-# INLINE growExp #-} +growExp :: forall m a. (MonadIO m, Unbox a) => + Int -> MutArray a -> m (MutArray a) +growExp nElems arr@MutArray{..} = do + let req = roundUpLargeArray (SIZE_OF(a) * nElems) + req1 = + if req > largeObjectThreshold + then roundUpToPower2 req + else req + cap = arrBound - arrStart + if req1 < cap + then return arr + else realloc req1 arr + +{-# DEPRECATED resizeExp "Please use growExp instead." #-} +{-# INLINE resizeExp #-} +resizeExp :: forall m a. (MonadIO m, Unbox a) => + Int -> MutArray a -> m (MutArray a) +resizeExp = growExp + +-- | Resize the allocated memory to drop any reserved free space at the end of +-- the array and reallocate it to reduce wastage. +-- +-- Up to 25% wastage is allowed to avoid reallocations. If the capacity is +-- more than 'largeObjectThreshold' then free space up to the 'blockSize' is +-- retained. +-- +-- /Pre-release/ +{-# INLINE rightSize #-} +rightSize :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m (MutArray a) +rightSize arr@MutArray{..} = do + assert (arrEnd <= arrBound) (return ()) + let start = arrStart + len = arrEnd - start + cap = arrBound - start + target = roundUpLargeArray len + waste = arrBound - arrEnd + assert (target >= len) (return ()) + assert (len `mod` SIZE_OF(a) == 0) (return ()) + -- We trade off some wastage (25%) to avoid reallocations and copying. + if target < cap && len < 3 * waste + then realloc target arr + else return arr + +-- | Reset the array end position to start, thus truncating the array to 0 +-- length, making it empty. The capacity of the array remains unchanged. The +-- array refers to the same memory as before. +{-# INLINE vacate #-} +vacate :: MutArray a -> MutArray a +vacate MutArray{..} = MutArray arrContents arrStart arrStart arrBound + +------------------------------------------------------------------------------- +-- Snoc +------------------------------------------------------------------------------- + +-- XXX We can possibly use a smallMutableByteArray to hold the start, end, +-- bound pointers. Using fully mutable handle will ensure that we do not have +-- multiple references to the same array of different lengths lying around and +-- potentially misused. In that case "snoc" need not return a new array (snoc +-- :: MutArray a -> a -> m ()), it will just modify the old reference. The array +-- length will be mutable. This means the length function would also be +-- monadic. Mutable arrays would behave more like files that grow in that +-- case. + +-- | Snoc using a 'Ptr'. Low level reusable function. +-- +-- /Internal/ +{-# INLINE snocNewEnd #-} +snocNewEnd :: (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m (MutArray a) +snocNewEnd newEnd arr@MutArray{..} x = liftIO $ do + assert (newEnd <= arrBound) (return ()) + pokeAt arrEnd arrContents x + return $ arr {arrEnd = newEnd} + +-- | Really really unsafe, appends the element into the first array, may +-- cause silent data corruption or if you are lucky a segfault if the first +-- array does not have enough space to append the element. +-- +-- /Internal/ +{-# INLINE unsafeSnoc #-} +snocUnsafe, unsafeSnoc :: forall m a. (MonadIO m, Unbox a) => + MutArray a -> a -> m (MutArray a) +unsafeSnoc arr@MutArray{..} = snocNewEnd (INDEX_NEXT(arrEnd,a)) arr + +-- | Like 'snoc' but does not reallocate when pre-allocated array capacity +-- becomes full. +-- +-- /Internal/ +{-# INLINE snocMay #-} +snocMay :: forall m a. (MonadIO m, Unbox a) => + MutArray a -> a -> m (Maybe (MutArray a)) +snocMay arr@MutArray{..} x = do + let newEnd = INDEX_NEXT(arrEnd,a) + if newEnd <= arrBound + then Just <$> snocNewEnd newEnd arr x + else return Nothing + +-- | Increments the capacity such that there is at least one unused slot even +-- if the sizer returns a size less than or equal to current size. + +-- NOINLINE to move it out of the way and not pollute the instruction cache. +{-# NOINLINE snocWithRealloc #-} +snocWithRealloc :: forall m a. (MonadIO m, Unbox a) => + (Int -> Int) + -> MutArray a + -> a + -> m (MutArray a) +snocWithRealloc sizer arr x = do + arr1 <- reallocBytesWith "snocWith" sizer (SIZE_OF(a)) arr + unsafeSnoc arr1 x + +-- XXX sizer should use elements instead of bytes? That may increase the cost +-- but sizing is not a frequent operation. + +-- | @snocWith sizer arr elem@ mutates @arr@ to append @elem@. The used length +-- of the array increases by 1. +-- +-- If there is no reserved space available in @arr@ it is reallocated to a size +-- in bytes determined by the @sizer oldSizeBytes@ function, where +-- @oldSizeBytes@ is the original size of the array in bytes. The sizer +-- function should return a capacity more than or equal to the current used +-- size. If the capacity returned is less than or equal to the current used +-- size, the array is still grown by one element. +-- +-- If the new array size is more than 'largeObjectThreshold' then it is rounded +-- up to 'blockSize'. +-- +-- Note that the returned array may be a mutated version of the original array. +-- +-- /Pre-release/ +{-# INLINE snocWith #-} +snocWith :: forall m a. (MonadIO m, Unbox a) => + (Int -> Int) + -> MutArray a + -> a + -> m (MutArray a) +snocWith sizer arr x = do + let newEnd = INDEX_NEXT(arrEnd arr,a) + if newEnd <= arrBound arr + then snocNewEnd newEnd arr x + else snocWithRealloc sizer arr x + +-- | The array is mutated to append an additional element to it. If there +-- is no reserved space available in the array then it is reallocated to grow +-- it by 'arrayChunkBytes' rounded up to 'blockSize' when the size becomes more +-- than 'largeObjectThreshold'. +-- +-- Note that the returned array may be a mutated version of the original array. +-- +-- Performs O(n^2) copies to grow but is thrifty on memory. +-- +-- /Pre-release/ +{-# DEPRECATED snocLinear "Please use snocGrowBy instead. snocLinear ~ snocGrowBy (1024 / sizeOf (Proxy :: Proxy a) + 1)" #-} +{-# INLINE snocLinear #-} +snocLinear :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) +snocLinear = snocWith (+ allocBytesToBytes (undefined :: a) arrayChunkBytes) + +-- | The array is mutated to append an additional element to it. +-- +-- If there is no reserved space available in the array then it is reallocated +-- to grow it by adding space for the requested number of elements, the new +-- size is rounded up to 'blockSize' when the size becomes more than +-- 'largeObjectThreshold'. If the size specified is <= 0 then the array is +-- grown by one element. +-- +-- Note that the returned array may be a mutated version of the original array. +-- +-- Performs O(n^2) copies to grow but is thrifty on memory compared to 'snoc'. +-- +-- /Pre-release/ +{-# INLINE snocGrowBy #-} +snocGrowBy :: forall m a. (MonadIO m, Unbox a) => + Int -> MutArray a -> a -> m (MutArray a) +snocGrowBy n = snocWith (+ (n * SIZE_OF(a))) + +-- | The array is mutated to append an additional element to it. If there is no +-- reserved space available in the array then it is reallocated to double the +-- original size and aligned to a power of 2. +-- +-- This is useful to reduce allocations when appending unknown number of +-- elements. +-- +-- Note that the returned array may be a mutated version of the original array. +-- +-- Performs only O(n * log n) copies to grow, but is liberal with memory +-- allocation compared to 'snocGrowBy'. +-- +{-# INLINE snoc #-} +snoc :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) +snoc = snocWith f + + where + + f oldSize = + if isPower2 oldSize + then oldSize * 2 + else roundUpToPower2 oldSize * 2 + +------------------------------------------------------------------------------- +-- Serialization/Deserialization using Unbox +------------------------------------------------------------------------------- + +{-# INLINE pokeNewEnd #-} +pokeNewEnd :: (MonadIO m, Unbox a) => + Int -> MutArray Word8 -> a -> m (MutArray Word8) +pokeNewEnd newEnd arr@MutArray{..} x = liftIO $ do + assert (newEnd <= arrBound) (return ()) + liftIO $ pokeAt arrEnd arrContents x + return $ arr {arrEnd = newEnd} + +-- | Really really unsafe, unboxes a Haskell type and appends the resulting +-- bytes to the byte array, may cause silent data corruption or if you are +-- lucky a segfault if the array does not have enough space to append the +-- element. +-- +-- /Internal/ +{-# INLINE unsafePoke #-} +unsafePoke :: forall m a. (MonadIO m, Unbox a) => + MutArray Word8 -> a -> m (MutArray Word8) +unsafePoke arr@MutArray{..} = pokeNewEnd (arrEnd + SIZE_OF(a)) arr + +-- | Skip the specified number of bytes in the array. The data in the skipped +-- region remains uninitialzed. +{-# INLINE unsafePokeSkip #-} +pokeSkipUnsafe, unsafePokeSkip :: Int -> MutArray Word8 -> MutArray Word8 +unsafePokeSkip n arr@MutArray{..} = do + let newEnd = arrEnd + n + in assert (newEnd <= arrBound) (arr {arrEnd = newEnd}) + +-- | Like 'poke' but does not grow the array when pre-allocated array +-- capacity becomes full. +-- +-- /Internal/ +{-# INLINE pokeMay #-} +pokeAppendMay, pokeMay :: forall m a. (MonadIO m, Unbox a) => + MutArray Word8 -> a -> m (Maybe (MutArray Word8)) +pokeMay arr@MutArray{..} x = liftIO $ do + let newEnd = arrEnd + SIZE_OF(a) + if newEnd <= arrBound + then Just <$> pokeNewEnd newEnd arr x + else return Nothing + +{-# NOINLINE pokeWithRealloc #-} +pokeWithRealloc :: forall m a. (MonadIO m, Unbox a) => + (Int -> Int) + -> MutArray Word8 + -> a + -> m (MutArray Word8) +pokeWithRealloc sizer arr x = do + arr1 <- liftIO $ reallocBytesWith "pokeWithRealloc" sizer (SIZE_OF(a)) arr + unsafePoke arr1 x + +{-# INLINE pokeWith #-} +pokeWith :: forall m a. (MonadIO m, Unbox a) => + (Int -> Int) + -> MutArray Word8 + -> a + -> m (MutArray Word8) +pokeWith allocSize arr x = liftIO $ do + let newEnd = arrEnd arr + SIZE_OF(a) + if newEnd <= arrBound arr + then pokeNewEnd newEnd arr x + else pokeWithRealloc allocSize arr x + +-- | Unbox a Haskell type and append the resulting bytes to a mutable byte +-- array. The array is grown exponentially when more space is needed. +-- +-- Like 'snoc' except that the value is unboxed to the byte array. +-- +-- Note: If you are serializing a large number of small fields, and the types +-- are statically known, then it may be more efficient to declare a record of +-- those fields and derive an 'Unbox' instance of the entire record. +-- +{-# INLINE poke #-} +pokeAppend, poke :: forall m a. (MonadIO m, Unbox a) => + MutArray Word8 -> a -> m (MutArray Word8) +poke = pokeWith f + + where + + f oldSize = + if isPower2 oldSize + then oldSize * 2 + else roundUpToPower2 oldSize * 2 + +-- | Really really unsafe, create a Haskell value from an unboxed byte array, +-- does not check if the array is big enough, may return garbage or if you are +-- lucky may cause a segfault. +-- +-- /Internal/ +{-# INLINE unsafePeek #-} +peekUnconsUnsafe, unsafePeek :: forall m a. (MonadIO m, Unbox a) => + MutArray Word8 -> m (a, MutArray Word8) +unsafePeek MutArray{..} = do + let start1 = arrStart + SIZE_OF(a) + assert (start1 <= arrEnd) (return ()) + liftIO $ do + r <- peekAt arrStart arrContents + return (r, MutArray arrContents start1 arrEnd arrBound) + +-- | Discard the specified number of bytes at the beginning of the array. +{-# INLINE unsafePeekSkip #-} +peekSkipUnsafe, unsafePeekSkip :: Int -> MutArray Word8 -> MutArray Word8 +unsafePeekSkip n MutArray{..} = + let start1 = arrStart + n + in assert (start1 <= arrEnd) (MutArray arrContents start1 arrEnd arrBound) + +-- | Create a Haskell value from its unboxed representation from the head of a +-- byte array, return the value and the remaining array. +-- +-- Like 'uncons' except that the value is deserialized from the byte array. +-- +-- Note: If you are deserializing a large number of small fields, and the types +-- are statically known, then it may be more efficient to declare a record of +-- those fields and derive an 'Unbox' instance of the entire record. +{-# INLINE peek #-} +peekUncons, peek :: forall m a. (MonadIO m, Unbox a) => + MutArray Word8 -> m (Maybe a, MutArray Word8) +peek arr@MutArray{..} = do + let start1 = arrStart + SIZE_OF(a) + if start1 > arrEnd + then return (Nothing, arr) + else liftIO $ do + r <- peekAt arrStart arrContents + return (Just r, MutArray arrContents start1 arrEnd arrBound) + +------------------------------------------------------------------------------- +-- Random reads +------------------------------------------------------------------------------- + +-- XXX Can this be deduplicated with array/foreign + +-- | Return the element at the specified index without checking the bounds. +-- +-- Unsafe because it does not check the bounds of the array. +{-# INLINE_NORMAL unsafeGetIndex #-} +getIndexUnsafe, unsafeGetIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a +unsafeGetIndex i MutArray{..} = do + let index = INDEX_OF(arrStart,i,a) + assert (i >= 0 && INDEX_VALID(index,arrEnd,a)) (return ()) + liftIO $ peekAt index arrContents + +-- | /O(1)/ Lookup the element at the given index. Index starts from 0. +-- +{-# INLINE getIndex #-} +getIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m (Maybe a) +getIndex i MutArray{..} = do + let index = INDEX_OF(arrStart,i,a) + if i >= 0 && INDEX_VALID(index,arrEnd,a) + then liftIO $ Just <$> peekAt index arrContents + else return Nothing + +{-# INLINE_NORMAL unsafeGetIndexRev #-} +unsafeGetIndexRev :: forall m a. (MonadIO m, Unbox a) => + Int -> MutArray a -> m a +unsafeGetIndexRev i MutArray{..} = do + let index = RINDEX_OF(arrEnd,i,a) + assert (i >= 0 && INDEX_VALID(index,arrEnd,a)) (return ()) + liftIO $ peekAt index arrContents + +-- | /O(1)/ Lookup the element at the given index from the end of the array. +-- Index starts from 0. +-- +-- Slightly faster than computing the forward index and using getIndex. +-- +{-# INLINE getIndexRev #-} +getIndexRev :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a +getIndexRev i MutArray{..} = do + let index = RINDEX_OF(arrEnd,i,a) + if i >= 0 && index >= arrStart + then liftIO $ peekAt index arrContents + else invalidIndex "getIndexRev" i + +data GetIndicesState contents start end st = + GetIndicesState contents start end st + +{-# INLINE indexReaderWith #-} +indexReaderWith :: (Monad m, Unbox a) => + (forall b. IO b -> m b) -> D.Stream m Int -> Unfold m (MutArray a) a +indexReaderWith liftio (D.Stream stepi sti) = Unfold step inject + + where + + inject (MutArray contents start end _) = + return $ GetIndicesState contents start end sti + + {-# INLINE_LATE step #-} + step (GetIndicesState contents start end st) = do + r <- stepi defState st + case r of + D.Yield i s -> do + x <- liftio $ getIndex i (MutArray contents start end undefined) + case x of + Just v -> return $ D.Yield v (GetIndicesState contents start end s) + Nothing -> error "Invalid Index" + D.Skip s -> return $ D.Skip (GetIndicesState contents start end s) + D.Stop -> return D.Stop + +{-# DEPRECATED getIndicesWith "Please use indexReaderWith instead." #-} +{-# INLINE getIndicesWith #-} +getIndicesWith :: (Monad m, Unbox a) => + (forall b. IO b -> m b) -> D.Stream m Int -> Unfold m (MutArray a) a +getIndicesWith = indexReaderWith + +-- | Given an unfold that generates array indices, read the elements on those +-- indices from the supplied MutArray. An error is thrown if an index is out of +-- bounds. +-- +-- /Pre-release/ +{-# INLINE indexReader #-} +indexReader :: (MonadIO m, Unbox a) => Stream m Int -> Unfold m (MutArray a) a +indexReader = indexReaderWith liftIO + +-- XXX DO NOT REMOVE, change the signature to use Stream instead of unfold +{-# DEPRECATED getIndices "Please use indexReader instead." #-} +{-# INLINE getIndices #-} +getIndices :: (MonadIO m, Unbox a) => Stream m Int -> Unfold m (MutArray a) a +getIndices = indexReader + +------------------------------------------------------------------------------- +-- Subarrays +------------------------------------------------------------------------------- + +-- XXX We can also get immutable slices. +-- XXX sliceFromLen for a stream of slices starting from a given index + +-- | /O(1)/ Slice an array in constant time. +-- +-- Unsafe: The bounds of the slice are not checked. +-- +-- /Unsafe/ +-- +-- /Pre-release/ +{-# INLINE unsafeSliceOffLen #-} +unsafeSliceOffLen, getSliceUnsafe :: forall a. Unbox a + => Int -- ^ from index + -> Int -- ^ length of the slice + -> MutArray a + -> MutArray a +unsafeSliceOffLen index len (MutArray contents start e _) = + let fp1 = INDEX_OF(start,index,a) + end = fp1 + (len * SIZE_OF(a)) + in assert + (index >= 0 && len >= 0 && end <= e) + -- Note: In a slice we always use bound = end so that the slice + -- user cannot overwrite elements beyond the end of the slice. + (MutArray contents fp1 end end) + +-- | /O(1)/ Get a reference to a slice from a mutable array. Throws an error if +-- the slice extends out of the array bounds. +-- +-- The capacity of the slice is the same as its length i.e. it does not have +-- any unused or reserved space at the end. +-- +-- The slice shares the same underlying mutable array when created. However, if +-- the slice or the original array is reallocated by growing or shrinking then +-- it will be copied to new memory and they will no longer share the same +-- memory. +-- +-- /Pre-release/ +{-# INLINE sliceOffLen #-} +sliceOffLen, getSlice :: forall a. Unbox a => + Int -- ^ from index + -> Int -- ^ length of the slice + -> MutArray a + -> MutArray a +sliceOffLen index len (MutArray contents start e _) = + let fp1 = INDEX_OF(start,index,a) + end = fp1 + (len * SIZE_OF(a)) + in if index >= 0 && len >= 0 && end <= e + -- Note: In a slice we always use bound = end so that the slice user + -- cannot overwrite elements beyond the end of the slice. + then MutArray contents fp1 end end + else error + $ "sliceOffLen: invalid slice, index " + ++ show index ++ " length " ++ show len + +------------------------------------------------------------------------------- +-- In-place mutation algorithms +------------------------------------------------------------------------------- + +-- XXX consider the bulk update/accumulation/permutation APIs from vector. + +-- | You may not need to reverse an array because you can consume it in reverse +-- using 'readerRev'. To reverse large arrays you can read in reverse and write +-- to another array. However, in-place reverse can be useful to take adavantage +-- of cache locality and when you do not want to allocate additional memory. +-- +{-# INLINE reverse #-} +reverse :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m () +reverse MutArray{..} = liftIO $ do + let l = arrStart + h = INDEX_PREV(arrEnd,a) + in swap l h + + where + + swap l h = do + when (l < h) $ do + swapArrayByteIndices (Proxy :: Proxy a) arrContents l h + swap (INDEX_NEXT(l,a)) (INDEX_PREV(h,a)) + +-- | Generate the next permutation of the sequence, returns False if this is +-- the last permutation. +-- +-- /Unimplemented/ +{-# INLINE permute #-} +permute :: MutArray a -> m Bool +permute = undefined + +-- | Partition an array into two halves using a partitioning predicate. The +-- first half retains values where the predicate is 'False' and the second half +-- retains values where the predicate is 'True'. +-- +-- /Pre-release/ +{-# INLINE partitionBy #-} +partitionBy :: forall m a. (MonadIO m, Unbox a) + => (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) +partitionBy f arr@MutArray{..} = liftIO $ do + if arrStart >= arrEnd + then return (arr, arr) + else do + ptr <- go arrStart (INDEX_PREV(arrEnd,a)) + let pl = MutArray arrContents arrStart ptr ptr + pr = MutArray arrContents ptr arrEnd arrEnd + return (pl, pr) + + where + + -- Invariant low < high on entry, and on return as well + moveHigh low high = do + h <- peekAt high arrContents + if f h + then + -- Correctly classified, continue the loop + let high1 = INDEX_PREV(high,a) + in if low == high1 + then return Nothing + else moveHigh low high1 + else return (Just (high, h)) -- incorrectly classified + + -- Keep a low pointer starting at the start of the array (first partition) + -- and a high pointer starting at the end of the array (second partition). + -- Keep incrementing the low ptr and decrementing the high ptr until both + -- are wrongly classified, at that point swap the two and continue until + -- the two pointer cross each other. + -- + -- Invariants when entering this loop: + -- low <= high + -- Both low and high are valid locations within the array + go low high = do + l <- peekAt low arrContents + if f l + then + -- low is wrongly classified + if low == high + then return low + else do -- low < high + r <- moveHigh low high + case r of + Nothing -> return low + Just (high1, h) -> do -- low < high1 + pokeAt low arrContents h + pokeAt high1 arrContents l + let low1 = INDEX_NEXT(low,a) + high2 = INDEX_PREV(high1,a) + if low1 <= high2 + then go low1 high2 + else return low1 -- low1 > high2 + + else do + -- low is correctly classified + let low1 = INDEX_NEXT(low,a) + if low == high + then return low1 + else go low1 high + +-- | Shuffle corresponding elements from two arrays using a shuffle function. +-- If the shuffle function returns 'False' then do nothing otherwise swap the +-- elements. This can be used in a bottom up fold to shuffle or reorder the +-- elements. +-- +-- /Unimplemented/ +{-# INLINE shuffleBy #-} +shuffleBy :: (a -> a -> m Bool) -> MutArray a -> MutArray a -> m () +shuffleBy = undefined + +-- XXX we can also make the folds partial by stopping at a certain level. +-- +-- | @divideBy level partition array@ performs a top down hierarchical +-- recursive partitioning fold of items in the container using the given +-- function as the partition function. Level indicates the level in the tree +-- where the fold would stop. +-- +-- This performs a quick sort if the partition function is +-- 'partitionBy (< pivot)'. +-- +-- /Unimplemented/ +{-# INLINABLE divideBy #-} +divideBy :: + Int -> (MutArray a -> m (MutArray a, MutArray a)) -> MutArray a -> m () +divideBy = undefined + +-- | @mergeBy level merge array@ performs a pairwise bottom up fold recursively +-- merging the pairs using the supplied merge function. Level indicates the +-- level in the tree where the fold would stop. +-- +-- This performs a random shuffle if the merge function is random. If we +-- stop at level 0 and repeatedly apply the function then we can do a bubble +-- sort. +-- +-- /Unimplemented/ +mergeBy :: Int -> (MutArray a -> MutArray a -> m ()) -> MutArray a -> m () +mergeBy = undefined + +-- XXX Use vector instructions in arrays to find min/max/range faster + +-- XXX If we can mutate the array then we can do pairwise processing to keep +-- min in the first slot and max in the second. Then compare adjacent mins and +-- keep the min of those in the first slot, and similarly for max. Thus +-- reducing the comparisons in binary fashion. +-- +-- Or we can use mergeBy as defined above. +-- +-- If we cannot mutate the array then we can (1) copy it and use the above +-- algo, or (2) stream the array and use pairwise concat. + +-- | Find the minimum and maximum elements in the array using the provided +-- comparison function. +rangeBy :: (a -> a -> Ordering) -> MutArray a -> IO (Maybe (a, a)) +rangeBy = undefined + +------------------------------------------------------------------------------- +-- Size +------------------------------------------------------------------------------- + +-- | /O(1)/ Get the byte length of the array. +-- +{-# INLINE byteLength #-} +byteLength :: MutArray a -> Int +byteLength MutArray{..} = + let len = arrEnd - arrStart + in assert (len >= 0) len + +-- Note: try to avoid the use of length in performance sensitive internal +-- routines as it involves a costly 'div' operation. Instead use the end ptr +-- in the array to check the bounds etc. + +-- | /O(1)/ Get the used length of the array i.e. the number of elements in the +-- array. +-- +-- Note that 'byteLength' is less expensive than this operation, as 'length' +-- involves a costly division operation. +-- +{-# INLINE length #-} +length :: forall a. Unbox a => MutArray a -> Int +length arr = + let elemSize = SIZE_OF(a) + blen = byteLength arr + in assert (blen `mod` elemSize == 0) (blen `div` elemSize) + +-- | Get the total capacity of an array. An array may have space reserved +-- beyond the current used length of the array. +-- +-- /Pre-release/ +{-# INLINE byteCapacity #-} +byteCapacity :: MutArray a -> Int +byteCapacity MutArray{..} = + let len = arrBound - arrStart + in assert (len >= 0) len + +-- | The remaining capacity in the array for appending more elements without +-- reallocation. +-- +-- /Pre-release/ +{-# INLINE bytesFree #-} +bytesFree :: MutArray a -> Int +bytesFree MutArray{..} = + let n = arrBound - arrEnd + in assert (n >= 0) n + +{-# INLINE capacity #-} +capacity :: forall a. Unbox a => MutArray a -> Int +capacity arr = + let elemSize = SIZE_OF(a) + bcap = byteCapacity arr + in assert (bcap `mod` elemSize == 0) (bcap `div` elemSize) + +{-# INLINE free #-} +free :: forall a. Unbox a => MutArray a -> Int +free arr = + let elemSize = SIZE_OF(a) + bfree = bytesFree arr + in assert (bfree `mod` elemSize == 0) (bfree `div` elemSize) + +------------------------------------------------------------------------------- +-- Streams of arrays - Creation +------------------------------------------------------------------------------- + +data GroupState s contents start end bound + = GroupStart s + | GroupBuffer s contents start end bound + | GroupYield + contents start end bound (GroupState s contents start end bound) + | GroupFinish + +{-# INLINE_NORMAL chunksOfAs #-} +chunksOfAs :: forall m a. (MonadIO m, Unbox a) + => PinnedState -> Int -> D.Stream m a -> D.Stream m (MutArray a) +chunksOfAs ps n (D.Stream step state) = + D.Stream step' (GroupStart state) + + where + + {-# INLINE_LATE step' #-} + step' _ (GroupStart st) = do + when (n <= 0) $ + -- XXX we can pass the module string from the higher level API + error $ "Streamly.Internal.Data.MutArray.Mut.Type.chunksOf: " + ++ "the size of arrays [" ++ show n + ++ "] must be a natural number" + (MutArray contents start end bound :: MutArray a) <- newAs ps n + return $ D.Skip (GroupBuffer st contents start end bound) + + step' gst (GroupBuffer st contents start end bound) = do + r <- step (adaptState gst) st + case r of + D.Yield x s -> do + liftIO $ pokeAt end contents x + let end1 = INDEX_NEXT(end,a) + return $ + if end1 >= bound + then D.Skip + (GroupYield + contents start end1 bound (GroupStart s)) + else D.Skip (GroupBuffer s contents start end1 bound) + D.Skip s -> + return $ D.Skip (GroupBuffer s contents start end bound) + D.Stop -> + return + $ D.Skip (GroupYield contents start end bound GroupFinish) + + step' _ (GroupYield contents start end bound next) = + return $ D.Yield (MutArray contents start end bound) next + + step' _ GroupFinish = return D.Stop + +-- | @chunksOf n stream@ groups the elements in the input stream into arrays of +-- @n@ elements each. +-- +-- Same as the following but may be more efficient: +-- +-- >>> chunksOf n = Stream.foldMany (MutArray.createOf n) +-- +-- /Pre-release/ +{-# INLINE_NORMAL chunksOf #-} +chunksOf :: forall m a. (MonadIO m, Unbox a) + => Int -> D.Stream m a -> D.Stream m (MutArray a) +-- XXX the idiomatic implementation leads to large regression in the D.reverse' +-- benchmark. It seems it has difficulty producing optimized code when +-- converting to StreamK. Investigate GHC optimizations. +-- chunksOf n = D.foldMany (createOf n) +chunksOf = chunksOfAs Unpinned + +-- | Like 'chunksOf' but creates pinned arrays. +{-# INLINE_NORMAL chunksOf' #-} +pinnedChunksOf, chunksOf' :: forall m a. (MonadIO m, Unbox a) + => Int -> D.Stream m a -> D.Stream m (MutArray a) +-- chunksOf' n = D.foldMany (createOf' n) +chunksOf' = chunksOfAs Pinned +RENAME_PRIME(pinnedChunksOf,chunksOf) + +-- | Create arrays from the input stream using a predicate to find the end of +-- the chunk. When the predicate matches, the chunk ends, the matching element +-- is included in the chunk. +-- +-- Definition: +-- +-- >>> chunksEndBy p = Stream.foldMany (Fold.takeEndBy p MutArray.create) +-- +{-# INLINE chunksEndBy #-} +chunksEndBy :: forall m a. (MonadIO m, Unbox a) + => (a -> Bool) -> D.Stream m a -> D.Stream m (MutArray a) +chunksEndBy p = D.foldMany (FL.takeEndBy p create) + +-- | Like 'chunksEndBy' but creates pinned arrays. +-- +{-# INLINE chunksEndBy' #-} +chunksEndBy' :: forall m a. (MonadIO m, Unbox a) + => (a -> Bool) -> D.Stream m a -> D.Stream m (MutArray a) +chunksEndBy' p = D.foldMany (FL.takeEndBy p create') + +-- | Create chunks using newline as the separator, including it. +{-# INLINE chunksEndByLn #-} +chunksEndByLn :: (MonadIO m) + => D.Stream m Word8 -> D.Stream m (MutArray Word8) +chunksEndByLn = chunksEndBy (== fromIntegral (ord '\n')) + +-- | Like 'chunksEndByLn' but creates pinned arrays. +{-# INLINE chunksEndByLn' #-} +chunksEndByLn' :: (MonadIO m) + => D.Stream m Word8 -> D.Stream m (MutArray Word8) +chunksEndByLn' = chunksEndBy' (== fromIntegral (ord '\n')) + +-- | When we are buffering a stream of unknown size into an array we do not +-- know how much space to pre-allocate. So we start with the min size and emit +-- the array then keep on doubling the size every time. Thus we do not need to +-- guess the optimum chunk size. +-- +-- We can incorporate this in chunksOfAs if the additional size parameter does +-- not impact perf. +-- +{-# INLINE _chunksOfRange #-} +_chunksOfRange :: -- (MonadIO m, Unbox a) => + PinnedState -> Int -> Int -> D.Stream m a -> D.Stream m (MutArray a) +_chunksOfRange _ps _low _hi = undefined + +-- XXX buffer to a list instead? +-- | Buffer the stream into arrays in memory. +{-# INLINE arrayStreamKFromStreamDAs #-} +arrayStreamKFromStreamDAs :: forall m a. (MonadIO m, Unbox a) => + PinnedState -> D.Stream m a -> m (StreamK m (MutArray a)) +arrayStreamKFromStreamDAs ps = + let n = allocBytesToElemCount (undefined :: a) defaultChunkSize + in D.foldr K.cons K.nil . chunksOfAs ps n + +------------------------------------------------------------------------------- +-- Streams of arrays - Flattening +------------------------------------------------------------------------------- + +data FlattenState s contents a = + OuterLoop s + | InnerLoop s contents !Int !Int + +{-# INLINE_NORMAL concatWith #-} +concatWith :: forall m a. (Monad m, Unbox a) + => (forall b. IO b -> m b) -> D.Stream m (MutArray a) -> D.Stream m a +concatWith liftio (D.Stream step state) = D.Stream step' (OuterLoop state) + + where + + {-# INLINE_LATE step' #-} + step' gst (OuterLoop st) = do + r <- step (adaptState gst) st + return $ case r of + D.Yield MutArray{..} s -> + D.Skip (InnerLoop s arrContents arrStart arrEnd) + D.Skip s -> D.Skip (OuterLoop s) + D.Stop -> D.Stop + + step' _ (InnerLoop st _ p end) | assert (p <= end) (p == end) = + return $ D.Skip $ OuterLoop st + + step' _ (InnerLoop st contents p end) = do + !x <- liftio $ peekAt p contents + return $ D.Yield x (InnerLoop st contents (INDEX_NEXT(p,a)) end) + +-- | Same as the following but may be more efficient due to better fusion: +-- +-- >>> concat = Stream.unfoldEach MutArray.reader +-- +{-# INLINE_NORMAL concat #-} +concat :: forall m a. (MonadIO m, Unbox a) + => D.Stream m (MutArray a) -> D.Stream m a +concat = concatWith liftIO + +{-# DEPRECATED flattenArrays "Please use \"unfoldMany reader\" instead." #-} +{-# INLINE flattenArrays #-} +flattenArrays :: forall m a. (MonadIO m, Unbox a) + => D.Stream m (MutArray a) -> D.Stream m a +flattenArrays = concat + +{-# INLINE_NORMAL concatRevWith #-} +concatRevWith :: forall m a. (Monad m, Unbox a) + => (forall b. IO b -> m b) -> D.Stream m (MutArray a) -> D.Stream m a +concatRevWith liftio (D.Stream step state) = D.Stream step' (OuterLoop state) + + where + + {-# INLINE_LATE step' #-} + step' gst (OuterLoop st) = do + r <- step (adaptState gst) st + return $ case r of + D.Yield MutArray{..} s -> + let p = INDEX_PREV(arrEnd,a) + in D.Skip (InnerLoop s arrContents p arrStart) + D.Skip s -> D.Skip (OuterLoop s) + D.Stop -> D.Stop + + step' _ (InnerLoop st _ p start) | p < start = + return $ D.Skip $ OuterLoop st + + step' _ (InnerLoop st contents p start) = do + !x <- liftio $ peekAt p contents + let cur = INDEX_PREV(p,a) + return $ D.Yield x (InnerLoop st contents cur start) + +-- | Use the "readerRev" unfold instead. +-- +-- @concat = unfoldMany readerRev@ +-- +-- We can try this if there are any fusion issues in the unfold. +-- +{-# INLINE_NORMAL concatRev #-} +concatRev :: forall m a. (MonadIO m, Unbox a) + => D.Stream m (MutArray a) -> D.Stream m a +concatRev = concatRevWith liftIO + +{-# DEPRECATED flattenArraysRev "Please use \"unfoldMany readerRev\" instead." #-} +{-# INLINE flattenArraysRev #-} +flattenArraysRev :: forall m a. (MonadIO m, Unbox a) + => D.Stream m (MutArray a) -> D.Stream m a +flattenArraysRev = concatRev + +------------------------------------------------------------------------------- +-- Unfolds +------------------------------------------------------------------------------- + +data ArrayUnsafe a = ArrayUnsafe + {-# UNPACK #-} !MutByteArray -- contents + {-# UNPACK #-} !Int -- index 1 + {-# UNPACK #-} !Int -- index 2 + +toArrayUnsafe :: MutArray a -> ArrayUnsafe a +toArrayUnsafe (MutArray contents start end _) = ArrayUnsafe contents start end + +fromArrayUnsafe :: +#ifdef DEVBUILD + Unbox a => +#endif + ArrayUnsafe a -> MutArray a +fromArrayUnsafe (ArrayUnsafe contents start end) = + MutArray contents start end end + +{-# INLINE_NORMAL producerWith #-} +producerWith :: + forall m a. (Monad m, Unbox a) + => (forall b. IO b -> m b) -> Producer m (MutArray a) a +producerWith liftio = Producer step (return . toArrayUnsafe) extract + where + + {-# INLINE_LATE step #-} + step (ArrayUnsafe _ cur end) + | assert (cur <= end) (cur == end) = return D.Stop + step (ArrayUnsafe contents cur end) = do + -- When we use a purely lazy Monad like Identity, we need to force a + -- few actions for correctness and execution order sanity. We want + -- the peek to occur right here and not lazily at some later point + -- because we want the peek to be ordered with respect to the touch. + !x <- liftio $ peekAt cur contents + return $ D.Yield x (ArrayUnsafe contents (INDEX_NEXT(cur,a)) end) + + extract = return . fromArrayUnsafe + +-- | Resumable unfold of an array. +-- +{-# INLINE_NORMAL producer #-} +producer :: forall m a. (MonadIO m, Unbox a) => Producer m (MutArray a) a +producer = producerWith liftIO + +-- | Unfold an array into a stream. +-- +{-# INLINE_NORMAL reader #-} +reader :: forall m a. (MonadIO m, Unbox a) => Unfold m (MutArray a) a +reader = Producer.simplify producer + +{-# INLINE_NORMAL readerRevWith #-} +readerRevWith :: + forall m a. (Monad m, Unbox a) + => (forall b. IO b -> m b) -> Unfold m (MutArray a) a +readerRevWith liftio = Unfold step inject + where + + inject (MutArray contents start end _) = + let p = INDEX_PREV(end,a) + in return $ ArrayUnsafe contents start p + + {-# INLINE_LATE step #-} + step (ArrayUnsafe _ start p) | p < start = return D.Stop + step (ArrayUnsafe contents start p) = do + !x <- liftio $ peekAt p contents + return $ D.Yield x (ArrayUnsafe contents start (INDEX_PREV(p,a))) + +-- | Unfold an array into a stream in reverse order. +-- +{-# INLINE_NORMAL readerRev #-} +readerRev :: forall m a. (MonadIO m, Unbox a) => Unfold m (MutArray a) a +readerRev = readerRevWith liftIO + +------------------------------------------------------------------------------- +-- to Lists and streams +------------------------------------------------------------------------------- + +{- +-- Use foldr/build fusion to fuse with list consumers +-- This can be useful when using the IsList instance +{-# INLINE_LATE toListFB #-} +toListFB :: forall a b. Unbox a => (a -> b -> b) -> b -> MutArray a -> b +toListFB c n MutArray{..} = go arrStart + where + + go p | assert (p <= arrEnd) (p == arrEnd) = n + go p = + -- unsafeInlineIO allows us to run this in Identity monad for pure + -- toList/foldr case which makes them much faster due to not + -- accumulating the list and fusing better with the pure consumers. + -- + -- This should be safe as the array contents are guaranteed to be + -- evaluated/written to before we peek at them. + -- XXX + let !x = unsafeInlineIO $ do + r <- peekAt arrContents p + return r + in c x (go (PTR_NEXT(p,a))) +-} + +-- XXX Monadic foldr/build fusion? +-- Reference: https://www.researchgate.net/publication/220676509_Monadic_augment_and_generalised_short_cut_fusion + +-- | Convert a 'MutArray' into a list. +-- +{-# INLINE toList #-} +toList :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m [a] +toList MutArray{..} = liftIO $ go arrStart + where + + go p | assert (p <= arrEnd) (p == arrEnd) = return [] + go p = do + x <- peekAt p arrContents + (:) x <$> go (INDEX_NEXT(p,a)) + +{-# INLINE_NORMAL toStreamWith #-} +toStreamWith :: + forall m a. (Monad m, Unbox a) + => (forall b. IO b -> m b) -> MutArray a -> D.Stream m a +toStreamWith liftio MutArray{..} = D.Stream step arrStart + + where + + {-# INLINE_LATE step #-} + step _ p | assert (p <= arrEnd) (p == arrEnd) = return D.Stop + step _ p = liftio $ do + r <- peekAt p arrContents + return $ D.Yield r (INDEX_NEXT(p,a)) + +-- | Convert a 'MutArray' into a stream. +-- +-- >>> read = Stream.unfold MutArray.reader +-- +{-# INLINE_NORMAL read #-} +read :: forall m a. (MonadIO m, Unbox a) => MutArray a -> D.Stream m a +read = toStreamWith liftIO + +{-# INLINE toStreamKWith #-} +toStreamKWith :: + forall m a. (Monad m, Unbox a) + => (forall b. IO b -> m b) -> MutArray a -> StreamK m a +toStreamKWith liftio MutArray{..} = go arrStart + + where + + go p | assert (p <= arrEnd) (p == arrEnd) = K.nil + | otherwise = + let elemM = peekAt p arrContents + in liftio elemM `K.consM` go (INDEX_NEXT(p,a)) + +{-# INLINE toStreamK #-} +toStreamK :: forall m a. (MonadIO m, Unbox a) => MutArray a -> StreamK m a +toStreamK = toStreamKWith liftIO + +{-# INLINE_NORMAL toStreamRevWith #-} +toStreamRevWith :: + forall m a. (Monad m, Unbox a) + => (forall b. IO b -> m b) -> MutArray a -> D.Stream m a +toStreamRevWith liftio MutArray{..} = + let p = INDEX_PREV(arrEnd,a) + in D.Stream step p + + where + + {-# INLINE_LATE step #-} + step _ p | p < arrStart = return D.Stop + step _ p = liftio $ do + r <- peekAt p arrContents + return $ D.Yield r (INDEX_PREV(p,a)) + +-- | Convert a 'MutArray' into a stream in reverse order. +-- +-- >>> readRev = Stream.unfold MutArray.readerRev +-- +{-# INLINE_NORMAL readRev #-} +readRev :: forall m a. (MonadIO m, Unbox a) => MutArray a -> D.Stream m a +readRev = toStreamRevWith liftIO + +{-# INLINE toStreamKRevWith #-} +toStreamKRevWith :: + forall m a. (Monad m, Unbox a) + => (forall b. IO b -> m b) -> MutArray a -> StreamK m a +toStreamKRevWith liftio MutArray {..} = + let p = INDEX_PREV(arrEnd,a) + in go p + + where + + go p | p < arrStart = K.nil + | otherwise = + let elemM = peekAt p arrContents + in liftio elemM `K.consM` go (INDEX_PREV(p,a)) + +{-# INLINE toStreamKRev #-} +toStreamKRev :: forall m a. (MonadIO m, Unbox a) => MutArray a -> StreamK m a +toStreamKRev = toStreamKRevWith liftIO + +------------------------------------------------------------------------------- +-- Folding +------------------------------------------------------------------------------- + +-- XXX Need something like "MutArray m a" enforcing monadic action to avoid the +-- possibility of such APIs. +-- +-- | Strict left fold of an array. +{-# INLINE_NORMAL foldl' #-} +foldl' :: (MonadIO m, Unbox a) => (b -> a -> b) -> b -> MutArray a -> m b +foldl' f z arr = D.foldl' f z $ read arr + +-- | Right fold of an array. +{-# INLINE_NORMAL foldr #-} +foldr :: (MonadIO m, Unbox a) => (a -> b -> b) -> b -> MutArray a -> m b +foldr f z arr = D.foldr f z $ read arr + +-- | Fold an array using a 'Fold'. +-- +-- For example: +-- +-- >>> findIndex eq = MutArray.fold (Fold.findIndex eq) +-- +-- /Pre-release/ +{-# INLINE fold #-} +fold :: (MonadIO m, Unbox a) => Fold m a b -> MutArray a -> m b +fold f arr = D.fold f (read arr) + +-- | Fold an arary starting from end up to beginning. +-- +-- For example: +-- +-- >>> findIndexRev eq = MutArray.foldRev (Fold.findIndex eq) +-- +foldRev :: (MonadIO m, Unbox a) => Fold m a b -> MutArray a -> m b +foldRev f arr = D.fold f (readRev arr) + +------------------------------------------------------------------------------- +-- Folds for appending +------------------------------------------------------------------------------- + +-- Note: Arrays may be allocated with a specific alignment at the beginning of +-- the array. If you need to maintain that alignment on reallocations then you +-- can resize the array manually before append, using an aligned resize +-- operation. + +-- XXX Keep the bound intact to not lose any free space? Perf impact? + +-- | @unsafeAppendN n arr@ appends up to @n@ input items to the supplied +-- array. +-- +-- Unsafe: Do not drive the fold beyond @n@ elements, it will lead to memory +-- corruption or segfault. +-- +-- Any free space left in the array after appending @n@ elements is lost. +-- +-- /Internal/ +{-# DEPRECATED unsafeAppendN "Please use unsafeAppendMax instead." #-} +{-# INLINE_NORMAL unsafeAppendN #-} +unsafeAppendN :: forall m a. (MonadIO m, Unbox a) => + Int + -> m (MutArray a) + -> Fold m a (MutArray a) +unsafeAppendN n action = fmap fromArrayUnsafe $ FL.foldlM' step initial + + where + + initial = do + assert (n >= 0) (return ()) + arr@(MutArray _ _ end bound) <- action + let free_ = bound - end + needed = n * SIZE_OF(a) + -- XXX We can also reallocate if the array has too much free space, + -- otherwise we lose that space. + arr1 <- + if free_ < needed + then noinline reallocBytesWith "unsafeAppendN" (+ needed) needed arr + else return arr + return $ toArrayUnsafe arr1 + + step (ArrayUnsafe contents start end) x = do + liftIO $ pokeAt end contents x + -- We are using end as the bound, so no reserved space left. + return $ ArrayUnsafe contents start (INDEX_NEXT(end,a)) + +-- | @unsafeAppendMax n arr@ appends up to @n@ input items to the supplied +-- array. +-- +-- Unsafe: Do not drive the fold beyond @n@ elements, it will lead to memory +-- corruption or segfault. +-- +-- /Internal/ +{-# INLINE_NORMAL unsafeAppendMax #-} +unsafeAppendMax :: forall m a. (MonadIO m, Unbox a) => + Int + -> MutArray a + -> Fold m a (MutArray a) +unsafeAppendMax n arr@MutArray{..} = + fmap final $ FL.foldlM' step initial + + where + + free_ = arrBound - arrEnd + needed = n * SIZE_OF(a) + bound = arrBound + needed - free_ + + initial = do + assert (n >= 0) (return ()) + arr1 <- + if free_ < needed + then noinline + reallocBytesWith "unsafeAppendMax" (+ needed) needed arr + else return arr + return $ toArrayUnsafe arr1 + + step (ArrayUnsafe contents start end) x = do + liftIO $ pokeAt end contents x + return $ ArrayUnsafe contents start (INDEX_NEXT(end,a)) + + final (ArrayUnsafe contents start end) = + MutArray contents start end bound + +{-# DEPRECATED writeAppendNUnsafe "Please use unsafeAppendN instead." #-} +{-# INLINE writeAppendNUnsafe #-} +writeAppendNUnsafe :: forall m a. (MonadIO m, Unbox a) => + Int + -> m (MutArray a) + -> Fold m a (MutArray a) +writeAppendNUnsafe = unsafeAppendN + +-- | Append @n@ elements to an existing array. Any free space left in the array +-- after appending @n@ elements is lost. +-- +-- >>> appendN n initial = Fold.take n (MutArray.unsafeAppendN n initial) +-- +{-# DEPRECATED appendN "Please use appendMax instead." #-} +{-# INLINE_NORMAL appendN #-} +appendN :: forall m a. (MonadIO m, Unbox a) => + Int -> m (MutArray a) -> Fold m a (MutArray a) +appendN n initial = FL.take n (unsafeAppendN n initial) + +-- | Allocates space for n additional elements. The fold terminates after +-- appending n elements. If less than n elements are supplied then the space +-- for the remaining elements is guaranteed to be reserved. +-- +-- >>> appendMax n arr = Fold.take n (MutArray.unsafeAppendMax n arr) +-- +{-# INLINE_NORMAL appendMax #-} +appendMax :: forall m a. (MonadIO m, Unbox a) => + Int -> MutArray a -> Fold m a (MutArray a) +appendMax n initial = FL.take n (unsafeAppendMax n initial) + +{-# DEPRECATED writeAppendN "Please use appendN instead." #-} +{-# INLINE writeAppendN #-} +writeAppendN :: forall m a. (MonadIO m, Unbox a) => + Int -> m (MutArray a) -> Fold m a (MutArray a) +writeAppendN = appendN + +-- | @appendWith sizer action@ mutates the array generated by @action@ to +-- append the input stream. If there is no reserved space available in the +-- array it is reallocated to a size in bytes determined by @sizer oldSize@, +-- where @oldSize@ is the current size of the array in bytes. If the sizer +-- returns less than or equal to the current size then the size is incremented +-- by one element. +-- +-- Note that the returned array may be a mutated version of original array. +-- +-- >>> appendWith sizer = Fold.foldlM' (MutArray.snocWith sizer) +-- +-- /Pre-release/ +{-# INLINE appendWith #-} +appendWith :: forall m a. (MonadIO m, Unbox a) => + (Int -> Int) -> m (MutArray a) -> Fold m a (MutArray a) +appendWith sizer = FL.foldlM' (snocWith sizer) + +{-# DEPRECATED writeAppendWith "Please use appendWith instead." #-} +{-# INLINE writeAppendWith #-} +writeAppendWith :: forall m a. (MonadIO m, Unbox a) => + (Int -> Int) -> m (MutArray a) -> Fold m a (MutArray a) +writeAppendWith = appendWith + +-- | @append action@ mutates the array generated by @action@ to append the +-- input stream. If there is no reserved space available in the array it is +-- reallocated to double the size and aligned to power of 2. +-- +-- Note that the returned array may be a mutated version of original array. +-- +-- >>> append = Fold.foldlM' MutArray.snoc +-- +{-# DEPRECATED append "Please use append2 instead." #-} +{-# INLINE append #-} +append :: forall m a. (MonadIO m, Unbox a) => + m (MutArray a) -> Fold m a (MutArray a) +-- append = appendWith (* 2) +append = FL.foldlM' snoc + +-- | Fold @append2 arr@ mutates the array arr to append the input stream. If +-- there is no reserved space available in the array it is reallocated to +-- double the size and aligned to power of 2. +-- +-- Note that the returned array may be a mutated version of original array. +-- +-- >>> append2 arr = Fold.foldlM' MutArray.snoc (pure arr) +-- +{-# INLINE append2 #-} +append2 :: (MonadIO m, Unbox a) => MutArray a -> Fold m a (MutArray a) +append2 arr = FL.foldlM' snoc (pure arr) + +{-# DEPRECATED writeAppend "Please use append instead." #-} +{-# INLINE writeAppend #-} +writeAppend :: forall m a. (MonadIO m, Unbox a) => + m (MutArray a) -> Fold m a (MutArray a) +writeAppend = append + +-- | @appendGrowBy arr@ mutates the array arr to append the input stream. If +-- there is no reserved space available in the array it is reallocated to add +-- space for the min number of elements supplied and align to block size if the +-- array becomes larger than 'largeObjectThreshold'. +-- +-- Note that the returned array may be a mutated version of original array. +-- +-- >>> appendGrowBy n arr = Fold.foldlM' (MutArray.snocGrowBy n) (pure arr) +-- +{-# INLINE appendGrowBy #-} +appendGrowBy :: (MonadIO m, Unbox a) => + Int -> MutArray a -> Fold m a (MutArray a) +appendGrowBy n arr = FL.foldlM' (snocGrowBy n) (pure arr) + +------------------------------------------------------------------------------- +-- Actions for Appending streams +------------------------------------------------------------------------------- + +-- | +-- >>> appendStream arr = Stream.fold (MutArray.append (pure arr)) +-- +{-# INLINE appendStream #-} +appendStream :: (MonadIO m, Unbox a) => + MutArray a -> Stream m a -> m (MutArray a) +appendStream arr = D.fold (append (pure arr)) + +-- | +-- >>> appendStreamN n arr = Stream.fold (MutArray.appendMax n arr) +-- +{-# INLINE appendStreamN #-} +appendStreamN :: (MonadIO m, Unbox a) => + Int -> MutArray a -> Stream m a -> m (MutArray a) +appendStreamN n arr = D.fold (appendMax n arr) + +-- | The array is grown only by the required amount of space. +{-# INLINE appendCString# #-} +appendCString# :: MonadIO m => MutArray Word8 -> Addr# -> m (MutArray Word8) +appendCString# arr addr = do + len <- liftIO $ c_strlen_pinned addr + appendPtrN arr (Ptr addr) (fromIntegral len) + +-- Note: in hsc code # is treated in a special way, so it is difficult to use +-- appendCString# +{-# INLINE appendCString #-} +appendCString :: MonadIO m => MutArray Word8 -> Ptr a -> m (MutArray Word8) +appendCString arr (Ptr addr) = appendCString# arr addr + +------------------------------------------------------------------------------- +-- Folds for creating +------------------------------------------------------------------------------- + +-- XXX Use "IO" instead of "m" in the alloc function + +-- XXX We can carry bound as well in the state to make sure we do not lose the +-- remaining capacity. Need to check perf impact. + +-- | Like 'unsafeCreateOf' but takes a new array allocator @alloc size@ +-- function as argument. +-- +-- >>> unsafeCreateWithOf alloc n = MutArray.unsafeAppendN (alloc n) n +-- +-- /Pre-release/ +{-# INLINE_NORMAL unsafeCreateWithOf #-} +unsafeCreateWithOf :: forall m a. (MonadIO m, Unbox a) + => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) +unsafeCreateWithOf alloc n = fromArrayUnsafe <$> FL.foldlM' step initial + + where + + initial = toArrayUnsafe <$> alloc (max n 0) + + step (ArrayUnsafe contents start end) x = do + liftIO $ pokeAt end contents x + return + $ ArrayUnsafe contents start (INDEX_NEXT(end,a)) + +{-# DEPRECATED writeNWithUnsafe "Please use unsafeCreateWithOf instead." #-} +{-# INLINE writeNWithUnsafe #-} +writeNWithUnsafe :: forall m a. (MonadIO m, Unbox a) + => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) +writeNWithUnsafe = unsafeCreateWithOf + +{-# INLINE_NORMAL writeNUnsafeAs #-} +writeNUnsafeAs :: forall m a. (MonadIO m, Unbox a) + => PinnedState -> Int -> Fold m a (MutArray a) +writeNUnsafeAs ps = unsafeCreateWithOf (newAs ps) + +-- | Like 'createOf' but does not check the array bounds when writing. The fold +-- driver must not call the step function more than 'n' times otherwise it will +-- corrupt the memory and crash. This function exists mainly because any +-- conditional in the step function blocks fusion causing 10x performance +-- slowdown. +-- +-- >>> unsafeCreateOf = MutArray.unsafeCreateWithOf MutArray.emptyOf +-- +{-# INLINE_NORMAL unsafeCreateOf #-} +unsafeCreateOf :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (MutArray a) +unsafeCreateOf = writeNUnsafeAs Unpinned + +{-# DEPRECATED writeNUnsafe "Please use unsafeCreateOf instead." #-} +{-# INLINE writeNUnsafe #-} +writeNUnsafe :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (MutArray a) +writeNUnsafe = unsafeCreateOf + +-- | Like 'unsafeCreateOf' but creates a pinned array. +{-# INLINE_NORMAL unsafeCreateOf' #-} +unsafePinnedCreateOf, unsafeCreateOf' :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (MutArray a) +unsafeCreateOf' = writeNUnsafeAs Pinned +RENAME_PRIME(unsafePinnedCreateOf,unsafeCreateOf) + +{-# DEPRECATED pinnedWriteNUnsafe "Please use unsafeCreateOf' instead." #-} +{-# INLINE pinnedWriteNUnsafe #-} +pinnedWriteNUnsafe :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (MutArray a) +pinnedWriteNUnsafe = unsafeCreateOf' + +-- XXX Use "IO" instead of "m" in the alloc function + +-- | @createWithOf alloc n@ folds a maximum of @n@ elements into an array +-- allocated using the @alloc@ function. +-- +-- The array capacity is guranteed to be at least @n@. +-- +-- >>> createWithOf alloc n = Fold.take n (MutArray.unsafeCreateWithOf alloc n) +-- >>> createWithOf alloc n = MutArray.appendN (alloc n) n +-- +{-# INLINE_NORMAL createWithOf #-} +createOfWith, createWithOf :: forall m a. (MonadIO m, Unbox a) + => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) +createWithOf alloc n = FL.take n (unsafeCreateWithOf alloc n) + +{-# DEPRECATED writeNWith "Please use createWithOf instead." #-} +{-# INLINE writeNWith #-} +writeNWith :: forall m a. (MonadIO m, Unbox a) + => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) +writeNWith = createWithOf + +{-# INLINE_NORMAL writeNAs #-} +writeNAs :: + forall m a. (MonadIO m, Unbox a) + => PinnedState + -> Int + -> Fold m a (MutArray a) +writeNAs ps = createWithOf (newAs ps) + +-- | @createOf n@ folds a maximum of @n@ elements from the input stream to an +-- 'MutArray'. +-- +-- The array capacity is guranteed to be at least @n@. +-- +-- >>> createOf = MutArray.createWithOf MutArray.emptyOf +-- >>> createOf n = Fold.take n (MutArray.unsafeCreateOf n) +-- >>> createOf n = MutArray.appendMax n MutArray.empty +-- +{-# INLINE_NORMAL createOf #-} +createOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) +createOf = writeNAs Unpinned + +{-# DEPRECATED writeN "Please use createOf instead." #-} +{-# INLINE writeN #-} +writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) +writeN = createOf + +-- | Like 'createOf' but creates a pinned array. +{-# INLINE_NORMAL createOf' #-} +pinnedCreateOf, createOf' :: + forall m a. (MonadIO m, Unbox a) + => Int + -> Fold m a (MutArray a) +createOf' = writeNAs Pinned +RENAME_PRIME(pinnedCreateOf,createOf) + +{-# DEPRECATED pinnedWriteN "Please use createOf' instead." #-} +{-# INLINE pinnedWriteN #-} +pinnedWriteN :: + forall m a. (MonadIO m, Unbox a) + => Int + -> Fold m a (MutArray a) +pinnedWriteN = createOf' + +-- | Like unsafeCreateWithOf but writes the array in reverse order. +-- +-- /Internal/ +{-# INLINE_NORMAL writeRevNWithUnsafe #-} +writeRevNWithUnsafe :: forall m a. (MonadIO m, Unbox a) + => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) +writeRevNWithUnsafe alloc n = fromArrayUnsafe <$> FL.foldlM' step initial + + where + + toArrayUnsafeRev (MutArray contents _ _ bound) = + ArrayUnsafe contents bound bound + + initial = toArrayUnsafeRev <$> alloc (max n 0) + + step (ArrayUnsafe contents start end) x = do + let ptr = INDEX_PREV(start,a) + liftIO $ pokeAt ptr contents x + return + $ ArrayUnsafe contents ptr end + +-- | Like createWithOf but writes the array in reverse order. +-- +-- /Internal/ +{-# INLINE_NORMAL writeRevNWith #-} +writeRevNWith :: forall m a. (MonadIO m, Unbox a) + => (Int -> m (MutArray a)) -> Int -> Fold m a (MutArray a) +writeRevNWith alloc n = FL.take n (writeRevNWithUnsafe alloc n) + +-- | Like 'createOf' but writes the array in reverse order. +-- +-- /Pre-release/ +{-# INLINE_NORMAL revCreateOf #-} +revCreateOf :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) +revCreateOf = writeRevNWith new + +{-# DEPRECATED writeRevN "Please use revCreateOf instead." #-} +{-# INLINE writeRevN #-} +writeRevN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (MutArray a) +writeRevN = revCreateOf + +-- | @pinnedWriteNAligned align n@ folds a maximum of @n@ elements from the +-- input stream to a 'MutArray' aligned to the given size. +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL pinnedWriteNAligned #-} +pinnedWriteNAligned :: forall m a. (MonadIO m, Unbox a) + => Int -> Int -> Fold m a (MutArray a) +pinnedWriteNAligned align = createWithOf (pinnedNewAligned align) + +-- XXX Buffer to a list instead? + +-- | Buffer a stream into a stream of arrays. +-- +-- >>> buildChunks n = Fold.many (MutArray.createOf n) Fold.toStreamK +-- +-- Breaking an array into an array stream can be useful to consume a large +-- array sequentially such that memory of the array is released incrementatlly. +-- +-- See also: 'arrayStreamKFromStreamD'. +-- +-- /Unimplemented/ +-- +{-# INLINE_NORMAL buildChunks #-} +buildChunks :: (MonadIO m, Unbox a) => + Int -> Fold m a (StreamK n (MutArray a)) +buildChunks n = FL.many (createOf n) FL.toStreamK + +{-# DEPRECATED writeChunks "Please use buildChunks instead." #-} +{-# INLINE writeChunks #-} +writeChunks :: (MonadIO m, Unbox a) => + Int -> Fold m a (StreamK n (MutArray a)) +writeChunks = buildChunks + +-- | Grows by doubling +{-# INLINE_NORMAL writeWithAs #-} +writeWithAs :: forall m a. (MonadIO m, Unbox a) + => PinnedState -> Int -> Fold m a (MutArray a) +-- writeWithAs ps n = FL.rmapM rightSize $ appendWith (* 2) (newAs ps n) +writeWithAs ps elemCount = + FL.rmapM extract $ FL.foldlM' step initial + + where + + -- XXX create an empty Array if the count is <= 0? + initial = do + when (elemCount < 0) $ error "createWith: elemCount is negative" + newAs ps elemCount + + step arr@(MutArray _ start end bound) x + | INDEX_NEXT(end,a) > bound = do + let oldSize = end - start + newSize = max (oldSize * 2) 1 + arr1 <- liftIO $ reallocExplicitAs ps (SIZE_OF(a)) newSize arr + unsafeSnoc arr1 x + step arr x = unsafeSnoc arr x + + extract = liftIO . rightSize + +-- XXX Compare createWith with fromStreamD which uses an array of streams +-- implementation. We can write this using buildChunks above if that is faster. +-- If createWith is faster then we should use that to implement +-- fromStreamD. +-- +-- XXX The realloc based implementation needs to make one extra copy if we use +-- shrinkToFit. On the other hand, the stream of arrays implementation may +-- buffer the array chunk pointers in memory but it does not have to shrink as +-- we know the exact size in the end. However, memory copying does not seem to +-- be as expensive as the allocations. Therefore, we need to reduce the number +-- of allocations instead. Also, the size of allocations matters, right sizing +-- an allocation even at the cost of copying seems to help. Should be measured +-- on a big stream with heavy calls to toArray to see the effect. +-- +-- XXX check if GHC's memory allocator is efficient enough. We can try the C +-- malloc to compare against. + +-- | @createMinOf count@ folds the whole input to a single array. The array +-- starts at a size big enough to hold minCount elements, the size is doubled +-- every time the array needs to be grown. +-- +-- The array capacity is guaranteed to be at least count. +-- +-- /Caution! Do not use this on infinite streams./ +-- +-- >>> f n = MutArray.appendWith (* 2) (MutArray.emptyOf n) +-- >>> createWith n = Fold.rmapM MutArray.rightSize (f n) +-- >>> createWith n = Fold.rmapM MutArray.fromChunksK (MutArray.buildChunks n) +-- +-- /Pre-release/ +{-# INLINE_NORMAL createMinOf #-} +createMinOf, createWith :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (MutArray a) +-- createWith n = FL.rmapM rightSize $ appendWith (* 2) (emptyOf n) +createMinOf = writeWithAs Unpinned + +RENAME(createWith,createMinOf) + +{-# DEPRECATED writeWith "Please use createMinOf instead." #-} +{-# INLINE writeWith #-} +writeWith :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m a (MutArray a) +writeWith = createMinOf + +-- | Fold the whole input to a single array. +-- +-- Same as 'createMinOf using an initial array size of 'arrayChunkBytes' bytes +-- rounded up to the element size. If the array is expected to be smaller than +-- 'arrayChunkBytes' then use 'createMinOf' to avoid wasting memory. +-- +-- /Caution! Do not use this on infinite streams./ +-- +{-# INLINE create #-} +create :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) +create = createMinOf (allocBytesToElemCount (undefined :: a) arrayChunkBytes) + +{-# DEPRECATED write "Please use create instead." #-} +{-# INLINE write #-} +write :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) +write = create + +-- | Like 'create' but creates a pinned array. +{-# INLINE create' #-} +pinnedCreate, create' :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) +create' = + writeWithAs Pinned (allocBytesToElemCount (undefined :: a) arrayChunkBytes) +RENAME_PRIME(pinnedCreate,create) + +{-# DEPRECATED pinnedWrite "Please use create' instead." #-} +{-# INLINE pinnedWrite #-} +pinnedWrite :: forall m a. (MonadIO m, Unbox a) => Fold m a (MutArray a) +pinnedWrite = create' + +------------------------------------------------------------------------------- +-- construct from streams, known size +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL fromStreamDNAs #-} +fromStreamDNAs :: forall m a. (MonadIO m, Unbox a) + => PinnedState -> Int -> D.Stream m a -> m (MutArray a) +fromStreamDNAs ps limit str = do + (arr :: MutArray a) <- newAs ps limit + end <- D.foldlM' + (fwrite (arrContents arr)) + (return $ arrEnd arr) + $ D.take limit str + return $ arr {arrEnd = end} + + where + + fwrite arrContents ptr x = do + liftIO $ pokeAt ptr arrContents x + return $ INDEX_NEXT(ptr,a) + +-- | Create a MutArray of given size from a stream. +-- +-- >>> fromStreamN n = Stream.fold (MutArray.createOf n) +-- +{-# INLINE_NORMAL fromStreamN #-} +fromStreamN :: forall m a. (MonadIO m, Unbox a) + => Int -> D.Stream m a -> m (MutArray a) +-- fromStreamDN n = D.fold (createOf n) +fromStreamN = fromStreamDNAs Unpinned + +{-# DEPRECATED fromStreamDN "Please use fromStreamN instead." #-} +{-# INLINE fromStreamDN #-} +fromStreamDN :: forall m a. (MonadIO m, Unbox a) + => Int -> D.Stream m a -> m (MutArray a) +fromStreamDN = fromStreamN + +-- | Create a 'MutArray' from the first N elements of a list. The array is +-- allocated to size N, if the list terminates before N elements then the +-- array may hold less than N elements. +-- +{-# INLINABLE fromListN #-} +fromListN :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) +fromListN n xs = fromStreamN n $ D.fromList xs + +-- | Like 'fromListN' but creates a pinned array. +{-# INLINABLE fromListN' #-} +pinnedFromListN, fromListN' :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) +fromListN' n xs = fromStreamDNAs Pinned n $ D.fromList xs +RENAME_PRIME(pinnedFromListN,fromListN) + +-- | Like fromListN but writes the array in reverse order. +-- +-- /Pre-release/ +{-# INLINE fromListRevN #-} +fromListRevN :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) +fromListRevN n xs = D.fold (revCreateOf n) $ D.fromList xs + +-- | Convert a pure stream in Identity monad to a mutable array. +{-# INLINABLE fromPureStreamN #-} +fromPureStreamN :: (MonadIO m, Unbox a) => + Int -> Stream Identity a -> m (MutArray a) +fromPureStreamN n = D.fold (createOf n) . D.generalizeInner + +-- | Convert a pure stream in Identity monad to a mutable array. +{-# INLINABLE fromPureStream #-} +fromPureStream :: (MonadIO m, Unbox a) => Stream Identity a -> m (MutArray a) +fromPureStream = D.fold create . D.generalizeInner + +-- | @fromPtrN len addr@ copies @len@ bytes from @addr@ into an array. +-- +-- /Unsafe:/ +-- +-- The caller has to ensure that: +-- +-- 1. the pointer is pinned and alive during the call. +-- 2. the pointer passed is valid up to the given length. +-- +{-# INLINABLE fromPtrN #-} +fromPtrN :: MonadIO m => Int -> Ptr Word8 -> m (MutArray Word8) +fromPtrN len addr = do + -- memcpy is better than stream copy when the size is known. + -- XXX We can implement a stream copy in a similar way by streaming Word64 + -- first and then remaining Word8. + (arr :: MutArray Word8) <- emptyOf len + let mbarr = getMutByteArray# (arrContents arr) + _ <- liftIO $ c_memcpy_pinned_src mbarr addr (fromIntegral len) + pure (arr { arrEnd = len }) + +-- | @fromCString# addr@ copies a C string consisting of bytes and +-- terminated by a null byte, into a Word8 array. The null byte is not copied. +-- +-- >>> MutArray.fromCString# "hello"# +-- +-- /Unsafe:/ +-- +-- The caller has to ensure that: +-- +-- 1. the @addr@ is pinned and alive during the call. +-- 2. the pointer passed is valid up to the point where null byte is found. +-- +{-# INLINABLE fromCString# #-} +fromCString# :: MonadIO m => Addr# -> m (MutArray Word8) +fromCString# addr = do + -- It is better to count the size first and allocate exact space. + -- Also, memcpy is better than stream copy when the size is known. + -- C strlen compares 4 bytes at a time, so is better than the stream + -- version. https://github.com/bminor/glibc/blob/master/string/strlen.c + -- XXX We can possibly use a stream of Word64 to do the same. + -- fromByteStr# addr = fromPureStream (D.fromByteStr# addr) + len <- liftIO $ c_strlen_pinned addr + fromPtrN (fromIntegral len) (Ptr addr) + +{-# DEPRECATED fromByteStr# "Please fromCString# instead." #-} +{-# INLINABLE fromByteStr# #-} +fromByteStr# :: MonadIO m => Addr# -> m (MutArray Word8) +fromByteStr# = fromCString# + +-- | @fromW16CString# addr@ copies a C string consisting of 16-bit wide chars +-- and terminated by a 16-bit null char, into a Word16 array. The null +-- character is not copied. +-- +-- Useful for copying UTF16 strings on Windows. +-- +-- /Unsafe:/ +-- +-- The caller has to ensure that: +-- +-- 1. the @addr@ is pinned and alive during the call. +-- 2. the pointer passed is valid up to the point where null Word16 is found. +-- +{-# INLINABLE fromW16CString# #-} +fromW16CString# :: MonadIO m => Addr# -> m (MutArray Word16) +fromW16CString# addr = do + -- XXX this can be done faster if we process one Word64 at a time + w16len <- D.fold FL.length $ D.fromW16CString# addr + let bytes = w16len * 2 + arr <- fromPtrN bytes (Ptr addr) + pure $ unsafeCast arr + +------------------------------------------------------------------------------- +-- convert a stream of arrays to a single array by reallocating and copying +------------------------------------------------------------------------------- + +-- XXX Both of these implementations of splicing seem to perform equally well. +-- We need to perform benchmarks over a range of sizes though. + +-- | Also see 'fromChunksK'. +{-# INLINE fromChunksRealloced #-} +fromChunksRealloced :: forall m a. (MonadIO m, Unbox a) + => Stream m (MutArray a) -> m (MutArray a) +fromChunksRealloced s = do + res <- D.uncons s + case res of + Just (a, strm) -> do + arr <- D.foldlM' spliceExp (pure a) strm + -- Reallocation is exponential so there may be 50% empty space in + -- worst case. One more reallocation to reclaim the space. + rightSize arr + Nothing -> pure nil + +------------------------------------------------------------------------------- +-- convert a stream of arrays to a single array by buffering arrays first +------------------------------------------------------------------------------- + +{-# INLINE arrayStreamKLength #-} +arrayStreamKLength :: (Monad m, Unbox a) => StreamK m (MutArray a) -> m Int +arrayStreamKLength as = K.foldl' (+) 0 (K.map length as) + +-- | Convert an array stream to an array. Note that this requires peak memory +-- that is double the size of the array stream. +-- +{-# INLINE fromChunkskAs #-} +fromChunkskAs :: (Unbox a, MonadIO m) => + PinnedState -> StreamK m (MutArray a) -> m (MutArray a) +fromChunkskAs ps as = do + len <- arrayStreamKLength as + arr <- newAs ps len + -- XXX is StreamK fold faster or StreamD fold? + K.foldlM' unsafeSplice (pure arr) as + -- fromStreamDN len $ D.unfoldMany reader $ D.fromStreamK as + +-- XXX Need to compare this with fromChunks and fromChunkList and keep the +-- fastest or simplest one if all are equally fast. + +-- | Convert an array stream to an array. Note that this requires peak memory +-- that is double the size of the array stream. +-- +-- Also see 'fromChunksRealloced'. +-- +{-# INLINE fromChunksK #-} +fromChunksK :: (Unbox a, MonadIO m) => + StreamK m (MutArray a) -> m (MutArray a) +fromChunksK = fromChunkskAs Unpinned + +{-# DEPRECATED fromArrayStreamK "Please use fromChunksK instead." #-} +{-# INLINE fromArrayStreamK #-} +fromArrayStreamK :: (Unbox a, MonadIO m) => + StreamK m (MutArray a) -> m (MutArray a) +fromArrayStreamK = fromChunksK + +{-# INLINE fromStreamDAs #-} +fromStreamDAs :: + (MonadIO m, Unbox a) => PinnedState -> D.Stream m a -> m (MutArray a) +fromStreamDAs ps m = + arrayStreamKFromStreamDAs Unpinned m >>= fromChunkskAs ps + +-- | Create an 'Array' from a stream. This is useful when we want to create a +-- single array from a stream of unknown size. 'createOf' is at least twice +-- as efficient when the size is already known. +-- +-- Note that if the input stream is too large memory allocation for the array +-- may fail. When the stream size is not known, `chunksOf` followed by +-- processing of indvidual arrays in the resulting stream should be preferred. +-- +-- /Pre-release/ +{-# INLINE fromStream #-} +fromStream :: (MonadIO m, Unbox a) => Stream m a -> m (MutArray a) +fromStream = fromStreamDAs Unpinned + +-- fromStream (Stream m) = P.fold create m +-- CAUTION: a very large number (millions) of arrays can degrade performance +-- due to GC overhead because we need to buffer the arrays before we flatten +-- all the arrays. +-- +-- XXX Compare if this is faster or "fold create". +-- +-- | We could take the approach of doubling the memory allocation on each +-- overflow. This would result in more or less the same amount of copying as in +-- the chunking approach. However, if we have to shrink in the end then it may +-- result in an extra copy of the entire data. +-- +-- >>> fromStreamD = StreamD.fold MutArray.create +-- +{-# INLINE fromStreamD #-} +{-# DEPRECATED fromStreamD "Please use fromStream instead." #-} +fromStreamD :: (MonadIO m, Unbox a) => D.Stream m a -> m (MutArray a) +fromStreamD = fromStream + +-- | Create a 'MutArray' from a list. The list must be of finite size. +-- +{-# INLINE fromList #-} +fromList :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) +fromList xs = fromStreamD $ D.fromList xs + +-- | Like 'fromList' but creates a pinned array. +{-# INLINE fromList' #-} +pinnedFromList, fromList' :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) +fromList' xs = fromStreamDAs Pinned $ D.fromList xs +RENAME_PRIME(pinnedFromList,fromList) + +-- XXX We are materializing the whole list first for getting the length. Check +-- if the 'fromList' like chunked implementation would fare better. + +-- | Like 'fromList' but writes the contents of the list in reverse order. +{-# INLINE fromListRev #-} +fromListRev :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) +fromListRev xs = fromListRevN (Prelude.length xs) xs + +------------------------------------------------------------------------------- +-- Cloning +------------------------------------------------------------------------------- + +-- Arrays are aligned on 64-bit boundaries. The fastest way to copy an array is +-- to unsafeCast it to Word64, read it, write it to Word64 array and unsafeCast +-- it again. We can use SIMD read/write as well. + +{-# INLINE cloneAs #-} +cloneAs :: + ( MonadIO m +#ifdef DEVBUILD + , Unbox a +#endif + ) + => PinnedState -> MutArray a -> m (MutArray a) +cloneAs ps src = + do + let startSrc = arrStart src + srcLen = arrEnd src - startSrc + newArrContents <- + Unboxed.unsafeCloneSliceAs ps startSrc srcLen (arrContents src) + return $ MutArray newArrContents 0 srcLen srcLen + +-- | Clone the elements of a MutArray. Does not clone the reserve capacity. +-- +-- To clone a slice of "MutArray" you can create a slice with "unsafeSliceOffLen" +-- and then use "clone". +-- +-- The new "MutArray" is unpinned in nature. Use "clone'" to clone the +-- MutArray in pinned memory. +{-# INLINE clone #-} +clone :: + ( MonadIO m +#ifdef DEVBUILD + , Unbox a +#endif + ) + => MutArray a -> m (MutArray a) +clone = cloneAs Unpinned + +-- Similar to "clone" but uses pinned memory. +{-# INLINE clone' #-} +pinnedClone, clone' :: + ( MonadIO m +#ifdef DEVBUILD + , Unbox a +#endif + ) + => MutArray a -> m (MutArray a) +clone' = cloneAs Pinned +RENAME_PRIME(pinnedClone,clone) + +------------------------------------------------------------------------------- +-- Combining +------------------------------------------------------------------------------- + +-- | Copy two arrays into a newly allocated array. If the first array is pinned +-- the spliced array is also pinned. +-- +-- Note: If you freeze and splice it will create a new array. +{-# INLINE spliceCopy #-} +spliceCopy :: forall m a. MonadIO m => +#ifdef DEVBUILD + Unbox a => +#endif + MutArray a -> MutArray a -> m (MutArray a) +spliceCopy arr1 arr2 = do + let start1 = arrStart arr1 + start2 = arrStart arr2 + len1 = arrEnd arr1 - start1 + len2 = arrEnd arr2 - start2 + let len = len1 + len2 + newArrContents <- + if Unboxed.isPinned (arrContents arr1) + then liftIO $ Unboxed.new' len + else liftIO $ Unboxed.new len + unsafePutSlice (arrContents arr1) start1 newArrContents 0 len1 + unsafePutSlice (arrContents arr2) start2 newArrContents len1 len2 + return $ MutArray newArrContents 0 len len + +-- | Really really unsafe, appends the second array into the first array. If +-- the first array does not have enough space it may cause silent data +-- corruption or if you are lucky a segfault. +{-# INLINE unsafeSplice #-} +spliceUnsafe, unsafeSplice :: MonadIO m => + MutArray a -> MutArray a -> m (MutArray a) +unsafeSplice dst src = do + let startSrc = arrStart src + srcLen = arrEnd src - startSrc + endDst = arrEnd dst + assertM(endDst + srcLen <= arrBound dst) + unsafePutSlice + (arrContents src) startSrc (arrContents dst) endDst srcLen + return $ dst {arrEnd = endDst + srcLen} + +-- | Append specified number of bytes from a given pointer to the MutArray. +-- +-- /Unsafe:/ +-- +-- The caller has to ensure that: +-- +-- 1. the MutArray is valid up to the given length. +-- 2. the source pointer is pinned and alive during the call. +-- 3. the pointer passed is valid up to the given length. +-- +{-# INLINE unsafeAppendPtrN #-} +unsafeAppendPtrN :: MonadIO m => + MutArray Word8 -> Ptr Word8 -> Int -> m (MutArray Word8) +unsafeAppendPtrN arr ptr ptrLen = do + let newEnd = arrEnd arr + ptrLen + assertM(newEnd <= arrBound arr) + Unboxed.unsafePutPtrN ptr (arrContents arr) (arrEnd arr) ptrLen + return $ arr {arrEnd = newEnd} + +{-# INLINE appendPtrN #-} +appendPtrN :: MonadIO m => + MutArray Word8 -> Ptr Word8 -> Int -> m (MutArray Word8) +appendPtrN arr ptr ptrLen = do + arr1 <- growBy ptrLen arr + unsafeAppendPtrN arr1 ptr ptrLen + +-- | @spliceWith sizer dst src@ mutates @dst@ to append @src@. If there is no +-- reserved space available in @dst@ it is reallocated to a size determined by +-- the @sizer dstBytes srcBytes@ function, where @dstBytes@ is the size of the +-- first array and @srcBytes@ is the size of the second array, in bytes. +-- +-- Note that the returned array may be a mutated version of first array. +-- +-- /Pre-release/ +{-# INLINE spliceWith #-} +spliceWith :: forall m a. (MonadIO m, Unbox a) => + (Int -> Int -> Int) -> MutArray a -> MutArray a -> m (MutArray a) +spliceWith sizer dst@(MutArray _ start end bound) src = do +{- + let f = appendWith (`sizer` byteLength src) (return dst) + in D.fold f (toStreamD src) +-} + assert (end <= bound) (return ()) + let srcBytes = arrEnd src - arrStart src + + dst1 <- + if end + srcBytes >= bound + then do + let dstBytes = end - start + newSizeInBytes = sizer dstBytes srcBytes + when (newSizeInBytes < dstBytes + srcBytes) + $ error + $ "splice: newSize is less than the total size " + ++ "of arrays being appended. Please check the " + ++ "sizer function passed." + realloc newSizeInBytes dst + else return dst + unsafeSplice dst1 src + +-- | The first array is extended in-place to append the second array. If there is no +-- reserved space available in the first array then a new allocation of exact +-- required size is done. +-- +-- Note that the returned array may be an extended version of first array, +-- referring to the same memory as the original array. +-- +-- >>> splice = MutArray.spliceWith (+) +-- +-- If the original array is pinned the spliced array is also pinned. +-- +-- /Pre-release/ +{-# INLINE splice #-} +splice :: (MonadIO m, Unbox a) => MutArray a -> MutArray a -> m (MutArray a) +splice = spliceWith (+) + +-- | Like 'append' but the growth of the array is exponential. Whenever a new +-- allocation is required the previous array size is at least doubled. +-- +-- This is useful to reduce allocations when folding many arrays together. +-- +-- Note that the returned array may be a mutated version of first array. +-- +-- >>> spliceExp = MutArray.spliceWith (\l1 l2 -> max (l1 * 2) (l1 + l2)) +-- +-- /Pre-release/ +{-# INLINE spliceExp #-} +spliceExp :: (MonadIO m, Unbox a) => MutArray a -> MutArray a -> m (MutArray a) +spliceExp = spliceWith (\l1 l2 -> max (l1 * 2) (l1 + l2)) + +------------------------------------------------------------------------------- +-- Splitting +------------------------------------------------------------------------------- + +{-# INLINE splitUsing #-} +splitUsing :: (MonadIO m, Unbox a) => + ((a -> Bool) -> Stream m a -> Stream m (Int, Int)) + -> (a -> Bool) -> MutArray a -> Stream m (MutArray a) +splitUsing f predicate arr = + fmap (\(i, len) -> unsafeSliceOffLen i len arr) + $ f predicate (read arr) + +-- | Generate a stream of array slices using a predicate. The array element +-- matching the predicate is dropped. +-- +-- /Pre-release/ +{-# INLINE splitEndBy_ #-} +splitEndBy_, splitOn :: (MonadIO m, Unbox a) => + (a -> Bool) -> MutArray a -> Stream m (MutArray a) +splitEndBy_ = splitUsing D.indexEndBy_ + +RENAME(splitOn,splitEndBy_) + +-- | Generate a stream of array slices using a predicate. The array element +-- matching the predicate is included. +-- +-- /Pre-release/ +{-# INLINE splitEndBy #-} +splitEndBy :: (MonadIO m, Unbox a) => + (a -> Bool) -> MutArray a -> Stream m (MutArray a) +splitEndBy = splitUsing D.indexEndBy + +-- XXX See advanceStartTill for a potential performance issue with this type of +-- code which needed to be investigated. Measure the perf of this and use +-- advanceStartTill if that turns out to be better. + +{-# INLINE breakUsing #-} +breakUsing :: (MonadIO m, Unbox a) => + Int -> ((a -> Bool) -> Stream m a -> Stream m (Int, Int)) + -> (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) +breakUsing adj indexer predicate arr = do + -- XXX Use MutArray.fold Fold.findIndex instead. + r <- D.head $ indexer predicate (read arr) + case r of + Just (i, len) -> + -- assert (i == 0) + -- XXX avoid using length (div operation) + let arrLen = length arr + i1 = len + adj + arr1 = + if i1 >= arrLen + then empty + else unsafeSliceOffLen i1 (arrLen - i1) arr + in return (unsafeSliceOffLen i len arr, arr1) + Nothing -> return (arr, empty) + +{-# INLINE revBreakUsing #-} +revBreakUsing :: (MonadIO m, Unbox a) => + Bool -> (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) +revBreakUsing withSep predicate arr = do + let indexer = if withSep then D.indexEndBy else D.indexEndBy_ + adj = if withSep then 0 else 1 + -- XXX Use MutArray.foldRev Fold.findIndex instead. + r <- D.head $ indexer predicate (readRev arr) + case r of + Just (_, len) -> + -- assert (i == 0) + -- XXX avoid using length (div operation) + let arrLen = length arr + len1 = len + adj + arr0 = + if len1 >= arrLen + then empty + else unsafeSliceOffLen 0 (arrLen - len1) arr + arr1 = unsafeSliceOffLen (arrLen - len) len arr + in return (arr0, arr1) + Nothing -> return (arr, empty) + +-- | +-- >>> arr <- MutArray.fromList "hello world" +-- >>> (a,b) <- MutArray.breakEndBy (== ' ') arr +-- >>> MutArray.toList a +-- "hello " +-- >>> MutArray.toList b +-- "world" +-- +{-# INLINE breakEndBy #-} +breakEndBy :: (MonadIO m, Unbox a) => + (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) +breakEndBy = breakUsing 0 D.indexEndBy + +-- | Break the array into two slices when the predicate succeeds. The array +-- element matching the predicate is dropped. If the predicate never succeeds +-- the second array is empty. +-- +-- >>> arr <- MutArray.fromList "hello world" +-- >>> (a,b) <- MutArray.breakEndBy_ (== ' ') arr +-- >>> MutArray.toList a +-- "hello" +-- >>> MutArray.toList b +-- "world" +-- +-- /Pre-release/ +{-# INLINE breakEndBy_ #-} +breakEndBy_ :: (MonadIO m, Unbox a) => + (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) +breakEndBy_ = breakUsing 1 D.indexEndBy_ + +-- | +-- +-- >>> arr <- MutArray.fromList "hello world" +-- >>> (a,b) <- MutArray.revBreakEndBy (== ' ') arr +-- >>> MutArray.toList a +-- "hello" +-- >>> MutArray.toList b +-- " world" +-- +{-# INLINE revBreakEndBy #-} +revBreakEndBy :: (MonadIO m, Unbox a) => + (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) +revBreakEndBy = revBreakUsing True + +-- | +-- +-- >>> arr <- MutArray.fromList "hello world" +-- >>> (a,b) <- MutArray.revBreakEndBy_ (== ' ') arr +-- >>> MutArray.toList a +-- "hello" +-- >>> MutArray.toList b +-- "world" +-- +{-# INLINE revBreakEndBy_ #-} +revBreakEndBy_ :: (MonadIO m, Unbox a) => + (a -> Bool) -> MutArray a -> m (MutArray a, MutArray a) +revBreakEndBy_ = revBreakUsing False + +-- Note: We could return empty array instead of Nothing. But then we cannot +-- distinguish if the separator was found in the end or was not found at all. +-- XXX Do we need to distinguish that? + +-- | Drops the separator byte +{-# INLINE breakEndByWord8_ #-} +breakEndByWord8_, breakOn :: MonadIO m + => Word8 -> MutArray Word8 -> m (MutArray Word8, Maybe (MutArray Word8)) +breakEndByWord8_ sep arr@MutArray{..} = liftIO $ do + -- XXX We do not need memchr here, we can use a Haskell equivalent. + -- Need efficient stream based primitives that work on Word64. + let marr = getMutByteArray# arrContents + len = fromIntegral (arrEnd - arrStart) + sepIndex <- c_memchr_index marr (fromIntegral arrStart) sep len + let intIndex = fromIntegral sepIndex + return $ + if sepIndex >= len + then (arr, Nothing) + else + ( MutArray + { arrContents = arrContents + , arrStart = arrStart + , arrEnd = arrStart + intIndex -- exclude the separator + , arrBound = arrStart + intIndex + } + , Just $ MutArray + { arrContents = arrContents + , arrStart = arrStart + (intIndex + 1) + , arrEnd = arrEnd + , arrBound = arrBound + } + ) +RENAME(breakOn,breakEndByWord8_) + +-- | Like 'breakAt' but does not check whether the index is valid. +-- +-- >>> unsafeBreakAt i arr = (MutArray.unsafeSliceOffLen 0 i arr, MutArray.unsafeSliceOffLen i (MutArray.length arr - i) arr) +-- +{-# INLINE unsafeBreakAt #-} +unsafeBreakAt :: forall a. Unbox a => + Int -> MutArray a -> (MutArray a, MutArray a) +unsafeBreakAt i MutArray{..} = + -- (unsafeSliceOffLen 0 i arr, unsafeSliceOffLen i (length arr - i) arr) + let off = i * SIZE_OF(a) + p = arrStart + off + in ( MutArray + { arrContents = arrContents + , arrStart = arrStart + , arrEnd = p + , arrBound = p + } + , MutArray + { arrContents = arrContents + , arrStart = p + , arrEnd = arrEnd + , arrBound = arrBound + } + ) + +-- | Create two slices of an array without copying the original array. The +-- specified index @i@ is the first index of the second slice. +-- +{-# INLINE breakAt #-} +breakAt, splitAt + :: forall a. Unbox a => Int -> MutArray a -> (MutArray a, MutArray a) +breakAt i arr = + let maxIndex = length arr - 1 + in if i < 0 + then error "sliceAt: negative array index" + else if i > maxIndex + then error $ "sliceAt: specified array index " ++ show i + ++ " is beyond the maximum index " ++ show maxIndex + else unsafeBreakAt i arr +RENAME(splitAt,breakAt) + +------------------------------------------------------------------------------- +-- Casting +------------------------------------------------------------------------------- + +-- | Cast an array having elements of type @a@ into an array having elements of +-- type @b@. The array size must be a multiple of the size of type @b@ +-- otherwise accessing the last element of the array may result into a crash or +-- a random value. +-- +-- /Pre-release/ +-- +castUnsafe, unsafeCast :: +#ifdef DEVBUILD + Unbox b => +#endif + MutArray a -> MutArray b +unsafeCast (MutArray contents start end bound) = + MutArray contents start end bound + +-- | Cast an @MutArray a@ into an @MutArray Word8@. +-- +asBytes :: MutArray a -> MutArray Word8 +asBytes = unsafeCast + +-- | Cast an array having elements of type @a@ into an array having elements of +-- type @b@. The length of the array should be a multiple of the size of the +-- target element otherwise 'Nothing' is returned. +-- +cast :: forall a b. Unbox b => MutArray a -> Maybe (MutArray b) +cast arr = + let len = byteLength arr + r = len `mod` SIZE_OF(b) + in if r /= 0 + then Nothing + else Just $ unsafeCast arr + +-- XXX Should we just name it asPtr, the unsafety is implicit for any pointer +-- operations. And we are safe from Haskell perspective because we will be +-- pinning the memory. + +-- | NOTE: this is deprecated because it can lead to accidental problems if the +-- user tries to use it to mutate the array because it does not return the new +-- array after pinning. +{-# DEPRECATED unsafePinnedAsPtr "Pin the array and then use unsafeAsPtr." #-} +{-# INLINE unsafePinnedAsPtr #-} +unsafePinnedAsPtr :: MonadIO m => MutArray a -> (Ptr a -> Int -> m b) -> m b +unsafePinnedAsPtr mutarr f = do + let arr0 = arrContents mutarr + arr <- liftIO $ Unboxed.pin arr0 + let !ptr = Ptr (byteArrayContents# + (unsafeCoerce# (getMutByteArray# arr))) + r <- f (ptr `plusPtr` arrStart mutarr) (byteLength mutarr) + liftIO $ Unboxed.touch arr + return r + +{-# DEPRECATED asPtrUnsafe "Pin the array and then use unsafeAsPtr." #-} +{-# INLINE asPtrUnsafe #-} +asPtrUnsafe :: MonadIO m => MutArray a -> (Ptr a -> m b) -> m b +asPtrUnsafe a f = unsafePinnedAsPtr a (\p _ -> f p) + +-- | @unsafeAsPtr arr f@, f is a function used as @f ptr len@ where @ptr@ is a +-- pointer to the beginning of array and @len@ is the byte-length of the array. +-- +-- /Unsafe/ WARNING: +-- +-- 1. The array must be pinned, otherwise it will lead to memory corruption. +-- 2. The user must not use the pointer beyond the supplied length. +-- +-- /Pre-release/ +-- +{-# INLINE unsafeAsPtr #-} +unsafeAsPtr :: MonadIO m => MutArray a -> (Ptr a -> Int -> IO b) -> m b +unsafeAsPtr arr f = + Unboxed.unsafeAsPtr + (arrContents arr) + (\ptr -> f (ptr `plusPtr` arrStart arr) (byteLength arr)) + +-- | @unsafeCreateWithPtr' capacity populator@ creates a pinned array of +-- @capacity@ bytes and invokes the @populator@ function to populate it. +-- @populator ptr len@ gets the pointer to the array and MUST return the amount +-- of the capacity populated in bytes. +-- +-- /Unsafe/ because the populator is allowed to use the pointer only up to +-- specified length. In other words, bytes populated MUST be less than or equal +-- to the total capacity. +{-# INLINE unsafeCreateWithPtr' #-} +unsafeCreateWithPtr' + :: MonadIO m => Int -> (Ptr Word8 -> IO Int) -> m (MutArray Word8) +unsafeCreateWithPtr' cap pop = do + (arr :: MutArray Word8) <- emptyOf' cap + len <- Unboxed.unsafeAsPtr (arrContents arr) pop + when (len > cap) (error (errMsg len)) + -- arrStart == 0 + pure (arr { arrEnd = len }) + + + where + + errMsg len = + "unsafeCreateWithPtr': length > capacity, " + ++ "length = " ++ show len ++ ", " + ++ "capacity = " ++ show cap + +asCString :: MutArray a -> (CString -> IO b) -> IO b +asCString arr act = do + let pinned = isPinned arr + req = byteLength arr + SIZE_OF(CChar) + arr1 <- + if byteCapacity arr < req || not pinned + then reallocExplicitAs Pinned 1 req arr + else return arr + arr2 :: MutArray CChar <- snocUnsafe (unsafeCast arr1) (0 :: CChar) + unsafeAsPtr arr2 $ \ptr _ -> act (castPtr ptr) + +asCWString :: MutArray a -> (CWString -> IO b) -> IO b +asCWString arr act = do + let pinned = isPinned arr + req = byteLength arr + SIZE_OF(CWchar) + arr1 <- + if byteCapacity arr < req || not pinned + then reallocExplicitAs Pinned 1 req arr + else return arr + arr2 :: MutArray CWchar <- snocUnsafe (unsafeCast arr1) (0 :: CWchar) + unsafeAsPtr arr2 $ \ptr _ -> act (castPtr ptr) + +------------------------------------------------------------------------------- +-- Equality +------------------------------------------------------------------------------- + +-- | Byte compare two arrays. Compare the length of the arrays. If the length +-- is equal, compare the lexicographical ordering of two underlying byte arrays +-- otherwise return the result of length comparison. +-- +-- /Unsafe/: Note that the 'Unbox' instance of sum types with constructors of +-- different sizes may leave some memory uninitialized which can make byte +-- comparison unreliable. +-- +-- /Pre-release/ +{-# INLINE byteCmp #-} +byteCmp :: MonadIO m => MutArray a -> MutArray a -> m Ordering +byteCmp arr1 arr2 = do + let !marr1 = arrContents arr1 + !marr2 = arrContents arr2 + !len1 = byteLength arr1 + !len2 = byteLength arr2 + !st1 = arrStart arr1 + !st2 = arrStart arr2 + case compare len1 len2 of + EQ -> do + r <- liftIO $ unsafeByteCmp marr1 st1 marr2 st2 len1 + return $ compare r 0 + x -> return x + +{-# INLINE cmp #-} +{-# DEPRECATED cmp "Please use byteCmp instead." #-} +cmp :: MonadIO m => MutArray a -> MutArray a -> m Ordering +cmp = byteCmp + +-- | Byte equality of two arrays. +-- +-- >>> byteEq arr1 arr2 = (==) EQ <$> MutArray.byteCmp arr1 arr2 +-- +-- /Unsafe/: See 'byteCmp'. +{-# INLINE byteEq #-} +byteEq :: MonadIO m => MutArray a -> MutArray a -> m Bool +byteEq arr1 arr2 = fmap (EQ ==) $ byteCmp arr1 arr2 + +------------------------------------------------------------------------------- +-- Compact +------------------------------------------------------------------------------- + +-- Note: LE versions avoid an extra copy compared to GE. LE parser trades +-- backtracking one array in lieu of avoiding a copy. However, LE and GE both +-- can leave some memory unused. They may split the last array to fit it +-- exactly in the space. + +{-# INLINE_NORMAL pCompactLeAs #-} +pCompactLeAs :: + forall m a. (MonadIO m, Unbox a) + => PinnedState -> Int -> Parser (MutArray a) m (MutArray a) +pCompactLeAs ps maxElems = Parser step initial extract + + where + + maxBytes = maxElems * SIZE_OF(a) + + functionName = "Streamly.Internal.Data.MutArray.pCompactLE" + + initial = + return + $ if maxElems <= 0 + then error + $ functionName + ++ ": the size of arrays [" + ++ show maxElems ++ "] must be a natural number" + else Parser.IPartial Nothing + + step Nothing arr = + return + $ let len = byteLength arr + in if len >= maxBytes + then Parser.SDone 1 arr + else Parser.SPartial 1 (Just arr) + -- XXX Split the last array to use the space more compactly. + step (Just buf) arr = + let len = byteLength buf + byteLength arr + in if len > maxBytes + then return $ Parser.SDone 0 buf + else do + buf1 <- + if byteCapacity buf < maxBytes + then liftIO $ reallocExplicitAs + ps (SIZE_OF(a)) maxBytes buf + else return buf + buf2 <- unsafeSplice buf1 arr + return $ Parser.SPartial 1 (Just buf2) + + extract Nothing = return $ Parser.FDone 0 nil + extract (Just buf) = return $ Parser.FDone 0 buf + +-- | Parser @createCompactMax maxElems@ coalesces adjacent arrays in the +-- input stream only if the combined size would be less than or equal to +-- @maxElems@ elements. Note that it won't split an array if the original array +-- is already larger than maxElems. +-- +-- @maxElems@ must be greater than 0. +-- +-- Generates unpinned arrays irrespective of the pinning status of input +-- arrays. +-- +-- Note that a fold compacting to less than or equal to a given size is not +-- possible, as folds cannot backtrack. +-- +-- /Internal/ +{-# INLINE createCompactMax #-} +createCompactMax, pCompactLE :: + forall m a. (MonadIO m, Unbox a) + => Int -> Parser (MutArray a) m (MutArray a) +createCompactMax = pCompactLeAs Unpinned + +RENAME(pCompactLE,createCompactMax) + +-- | Pinned version of 'createCompactMax'. +{-# INLINE createCompactMax' #-} +createCompactMax', pPinnedCompactLE :: + forall m a. (MonadIO m, Unbox a) + => Int -> Parser (MutArray a) m (MutArray a) +createCompactMax' = pCompactLeAs Pinned + +{-# DEPRECATED pPinnedCompactLE "Please use createCompactMax' instead." #-} +{-# INLINE pPinnedCompactLE #-} +pPinnedCompactLE = createCompactMax' + +data SpliceState s arr + = SpliceInitial s + | SpliceBuffering s arr + | SpliceYielding arr (SpliceState s arr) + | SpliceFinish + +-- | This mutates the first array (if it has space) to append values from the +-- second one. This would work for immutable arrays as well because an +-- immutable array never has additional space so a new array is allocated +-- instead of mutating it. +{-# INLINE_NORMAL compactLeAs #-} +compactLeAs :: forall m a. (MonadIO m, Unbox a) + => PinnedState -> Int -> D.Stream m (MutArray a) -> D.Stream m (MutArray a) +compactLeAs ps maxElems (D.Stream step state) = + D.Stream step' (SpliceInitial state) + + where + + maxBytes = maxElems * SIZE_OF(a) + + functionName = "Streamly.Internal.Data.MutArray.rCompactLE" + + {-# INLINE_LATE step' #-} + step' gst (SpliceInitial st) = do + when (maxElems <= 0) $ + -- XXX we can pass the module string from the higher level API + error $ functionName ++ ": the size of arrays [" ++ show maxElems + ++ "] must be a natural number" + r <- step gst st + case r of + D.Yield arr s -> return $ + let len = byteLength arr + in if len >= maxBytes + then D.Skip (SpliceYielding arr (SpliceInitial s)) + else D.Skip (SpliceBuffering s arr) + D.Skip s -> return $ D.Skip (SpliceInitial s) + D.Stop -> return D.Stop + + -- XXX Split the last array to use the space more compactly. + step' gst (SpliceBuffering st buf) = do + r <- step gst st + case r of + D.Yield arr s -> do + let len = byteLength buf + byteLength arr + if len > maxBytes + then return $ + D.Skip (SpliceYielding buf (SpliceBuffering s arr)) + else do + buf1 <- if byteCapacity buf < maxBytes + then liftIO $ reallocExplicitAs + ps (SIZE_OF(a)) maxBytes buf + else return buf + buf2 <- unsafeSplice buf1 arr + return $ D.Skip (SpliceBuffering s buf2) + D.Skip s -> return $ D.Skip (SpliceBuffering s buf) + D.Stop -> return $ D.Skip (SpliceYielding buf SpliceFinish) + + step' _ SpliceFinish = return D.Stop + + step' _ (SpliceYielding arr next) = return $ D.Yield arr next + + +{-# INLINE_NORMAL fCompactGeAs #-} +fCompactGeAs :: + forall m a. (MonadIO m, Unbox a) + => PinnedState -> Int -> FL.Fold m (MutArray a) (MutArray a) +fCompactGeAs ps minElems = Fold step initial extract extract + + where + + minBytes = minElems * SIZE_OF(a) + + functionName = "Streamly.Internal.Data.MutArray.fCompactGE" + + initial = + return + $ if minElems < 0 + then error + $ functionName + ++ ": the size of arrays [" + ++ show minElems ++ "] must be a natural number" + else FL.Partial Nothing + + step Nothing arr = + return + $ let len = byteLength arr + in if len >= minBytes + then FL.Done arr + else FL.Partial (Just arr) + -- XXX Buffer arrays as a list to avoid copy and reallocations + step (Just buf) arr = do + let len = byteLength buf + byteLength arr + buf1 <- + if byteCapacity buf < len + then liftIO $ reallocExplicitAs + ps (SIZE_OF(a)) (max minBytes len) buf + else return buf + buf2 <- unsafeSplice buf1 arr + if len >= minBytes + then return $ FL.Done buf2 + else return $ FL.Partial (Just buf2) + + extract Nothing = return nil + extract (Just buf) = return buf + +-- | Fold @createCompactMin minElems@ coalesces adjacent arrays in the +-- input stream until the size becomes greater than or equal to @minElems@. +-- +-- Generates unpinned arrays irrespective of the pinning status of input +-- arrays. +{-# INLINE createCompactMin #-} +createCompactMin, fCompactGE :: + forall m a. (MonadIO m, Unbox a) + => Int -> FL.Fold m (MutArray a) (MutArray a) +createCompactMin = fCompactGeAs Unpinned + +RENAME(fCompactGE,createCompactMin) + +-- | Pinned version of 'createCompactMin'. +{-# INLINE createCompactMin' #-} +createCompactMin', fPinnedCompactGE :: + forall m a. (MonadIO m, Unbox a) + => Int -> FL.Fold m (MutArray a) (MutArray a) +createCompactMin' = fCompactGeAs Pinned + +{-# DEPRECATED fPinnedCompactGE "Please use createCompactMin' instead." #-} +{-# INLINE fPinnedCompactGE #-} +fPinnedCompactGE = createCompactMin' + +{-# INLINE_NORMAL lCompactGeAs #-} +lCompactGeAs :: forall m a. (MonadIO m, Unbox a) + => PinnedState -> Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () +-- The fold version turns out to be a little bit slower. +-- lCompactGeAs ps n = FL.many (fCompactGeAs ps n) +lCompactGeAs ps minElems (Fold step1 initial1 _ final1) = + Fold step initial extract final + + where + + minBytes = minElems * SIZE_OF(a) + + functionName = "Streamly.Internal.Data.MutArray.lCompactGE" + + initial = do + when (minElems <= 0) $ + -- XXX we can pass the module string from the higher level API + error $ functionName ++ ": the size of arrays [" + ++ show minElems ++ "] must be a natural number" + + r <- initial1 + return $ first (Tuple' Nothing) r + + {-# INLINE runInner #-} + runInner len acc buf = + if len >= minBytes + then do + r <- step1 acc buf + case r of + FL.Done _ -> return $ FL.Done () + FL.Partial s -> do + _ <- final1 s + res <- initial1 + return $ first (Tuple' Nothing) res + else return $ FL.Partial $ Tuple' (Just buf) acc + + step (Tuple' Nothing r1) arr = + runInner (byteLength arr) r1 arr + + -- XXX Buffer arrays as a list to avoid copy and reallocations + step (Tuple' (Just buf) r1) arr = do + let len = byteLength buf + byteLength arr + buf1 <- if byteCapacity buf < len + then liftIO $ reallocExplicitAs + ps (SIZE_OF(a)) (max minBytes len) buf + else return buf + buf2 <- unsafeSplice buf1 arr + runInner len r1 buf2 + + -- XXX Several folds do extract >=> final, therefore, we need to make final + -- return "m b" rather than using extract post it if we want extract to be + -- partial. + -- + -- extract forces the pending buffer to be sent to the fold which is not + -- what we want. + extract _ = error "lCompactGE: not designed for scanning" + + final (Tuple' Nothing r1) = final1 r1 + final (Tuple' (Just buf) r1) = do + r <- step1 r1 buf + case r of + FL.Partial rr -> final1 rr + FL.Done _ -> return () + +-- | Like 'compactGE' but for transforming folds instead of stream. +-- +-- >> lCompactGE n = Fold.many (MutArray.fCompactGE n) +-- +-- Generates unpinned arrays irrespective of the pinning status of input +-- arrays. +{-# DEPRECATED lCompactGE "Please use scanCompactMin instead." #-} +{-# INLINE lCompactGE #-} +lCompactGE :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () +lCompactGE = lCompactGeAs Unpinned + +-- | Pinned version of 'lCompactGE'. +{-# DEPRECATED lPinnedCompactGE "Please use scanCompactMin' instead." #-} +{-# INLINE lPinnedCompactGE #-} +lPinnedCompactGE :: forall m a. (MonadIO m, Unbox a) + => Int -> Fold m (MutArray a) () -> Fold m (MutArray a) () +lPinnedCompactGE = lCompactGeAs Pinned + +data CompactMinState arr = + CompactMinInit | CompactMinIncomplete arr | CompactMinComplete arr + +{-# INLINE_NORMAL scanCompactMinAs #-} +scanCompactMinAs :: forall m a. (MonadIO m, Unbox a) + => PinnedState -> Int -> Scanl m (MutArray a) (Maybe (MutArray a)) +scanCompactMinAs ps minElems = + Scanl step initial extract final + + where + + minBytes = minElems * SIZE_OF(a) + + functionName = "Streamly.Internal.Data.MutArray.scanCompactMin" + + initial = do + when (minElems <= 0) $ + -- XXX we can pass the module string from the higher level API + error $ functionName ++ ": the size of arrays [" + ++ show minElems ++ "] must be a natural number" + + return $ FL.Partial CompactMinInit + + {-# INLINE runInner #-} + runInner len buf = + if len >= minBytes + then do + return $ FL.Partial $ CompactMinComplete buf + else return $ FL.Partial $ CompactMinIncomplete buf + + step CompactMinInit arr = + runInner (byteLength arr) arr + + step (CompactMinComplete _) arr = + runInner (byteLength arr) arr + + -- XXX Buffer arrays as a list to avoid copy and reallocations + step (CompactMinIncomplete buf) arr = do + let len = byteLength buf + byteLength arr + buf1 <- if byteCapacity buf < len + then liftIO $ reallocExplicitAs + ps (SIZE_OF(a)) (max minBytes len) buf + else return buf + buf2 <- unsafeSplice buf1 arr + runInner len buf2 + + extract CompactMinInit = return Nothing + extract (CompactMinComplete arr) = return (Just arr) + extract (CompactMinIncomplete _) = return Nothing + + final CompactMinInit = return Nothing + final (CompactMinComplete arr) = return (Just arr) + final (CompactMinIncomplete arr) = return (Just arr) + +-- | Like 'compactMin' but a scan. +{-# INLINE scanCompactMin #-} +scanCompactMin :: forall m a. (MonadIO m, Unbox a) + => Int -> Scanl m (MutArray a) (Maybe (MutArray a)) +scanCompactMin = scanCompactMinAs Unpinned + +-- | Like 'compactMin'' but a scan. +{-# INLINE scanCompactMin' #-} +scanCompactMin' :: forall m a. (MonadIO m, Unbox a) + => Int -> Scanl m (MutArray a) (Maybe (MutArray a)) +scanCompactMin' = scanCompactMinAs Pinned + +-- | @compactMin n stream@ coalesces adjacent arrays in the @stream@ until +-- the compacted array size becomes greater than or equal to @n@. +-- +-- >>> compactMin n = Stream.foldMany (MutArray.createCompactMin n) +-- +{-# INLINE compactMin #-} +compactMin, compactGE :: + (MonadIO m, Unbox a) + => Int -> Stream m (MutArray a) -> Stream m (MutArray a) +compactMin n = D.foldMany (createCompactMin n) + +RENAME(compactGE,compactMin) + +-- | 'compactExact n' coalesces adajacent arrays in the input stream to +-- arrays of exact size @n@. +-- +-- /Unimplemented/ +{-# INLINE compactExact #-} +compactExact :: -- (MonadIO m, Unbox a) => + Int -> Stream m (MutArray a) -> Stream m (MutArray a) +compactExact _n = undefined -- D.parseManyD (pCompactEQ n) + +------------------------------------------------------------------------------- +-- In-place mutation algorithms +------------------------------------------------------------------------------- + +-- XXX Can use SIMD +-- XXX findIndex can be implemented using this if fold perf is not good enough. + +{-# INLINE advanceStartTill #-} +advanceStartTill :: forall a. (Unbox a) => (a -> Bool) -> MutArray a -> IO Int +advanceStartTill eq MutArray{..} = go arrStart + + where + + {- + -- XXX This should have the same perf but it does not, investigate. + getStart = do + r <- liftIO $ D.head $ D.findIndices (not . eq) $ toStreamD arr + pure $ + case r of + Nothing -> arrEnd + Just i -> PTR_INDEX(arrStart,i,a) + -} + + go cur = + if cur < arrEnd + then do + r <- peekAt cur arrContents + if eq r + then go (INDEX_NEXT(cur,a)) + else return cur + else return cur + +{-# INLINE retractEndTill #-} +retractEndTill :: forall a. (Unbox a) => (a -> Bool) -> MutArray a -> IO Int +retractEndTill eq MutArray{..} = go arrEnd + + where + + go cur = do + if cur > arrStart + then do + let prev = INDEX_PREV(cur,a) + r <- peekAt prev arrContents + if eq r + then go prev + else return cur + else return cur + +-- | Strip elements which match the predicate, from the start of the array. +-- +-- >>> arr <- MutArray.fromList " hello world" +-- >>> a <- MutArray.dropWhile (== ' ') arr +-- >>> MutArray.toList a +-- "hello world" +-- +-- /Pre-release/ +{-# INLINE dropWhile #-} +dropWhile :: forall a m. (Unbox a, MonadIO m) => + (a -> Bool) -> MutArray a -> m (MutArray a) +dropWhile eq arr@MutArray{..} = liftIO $ do + st <- advanceStartTill eq arr + -- return arr{arrStart = st} + return $ + if st >= arrEnd + then empty + else arr{arrStart = st} + +-- | Strip elements which match the predicate, from the end of the array. +-- +-- >>> arr <- MutArray.fromList "hello world " +-- >>> a <- MutArray.revDropWhile (== ' ') arr +-- >>> MutArray.toList a +-- "hello world" +-- +-- /Pre-release/ +{-# INLINE revDropWhile #-} +revDropWhile :: forall a m. (Unbox a, MonadIO m) => + (a -> Bool) -> MutArray a -> m (MutArray a) +revDropWhile eq arr@MutArray{..} = liftIO $ do + end <- retractEndTill eq arr + -- return arr {arrEnd = end} + return $ + if end <= arrStart + then empty + else arr{arrEnd = end} + +-- | Strip elements which match the predicate, from both ends. +-- +-- >>> arr <- MutArray.fromList " hello world " +-- >>> a <- MutArray.dropAround (== ' ') arr +-- >>> MutArray.toList a +-- "hello world" +-- +-- /Pre-release/ +{-# INLINE dropAround #-} +dropAround, strip :: forall a m. (Unbox a, MonadIO m) => + (a -> Bool) -> MutArray a -> m (MutArray a) +dropAround eq arr = liftIO $ dropWhile eq arr >>= revDropWhile eq +RENAME(strip,dropAround) + +-- | Given an array sorted in ascending order except the last element being out +-- of order, use bubble sort to place the last element at the right place such +-- that the array remains sorted in ascending order. +-- +-- /Pre-release/ +{-# INLINE bubble #-} +bubble :: (MonadIO m, Unbox a) => (a -> a -> Ordering) -> MutArray a -> m () +bubble cmp0 arr = + when (l > 1) $ do + x <- unsafeGetIndex (l - 1) arr + go x (l - 2) + + where + + l = length arr + + go x i = + if i >= 0 + then do + x1 <- unsafeGetIndex i arr + case x `cmp0` x1 of + LT -> do + unsafePutIndex (i + 1) arr x1 + go x (i - 1) + _ -> unsafePutIndex (i + 1) arr x + else unsafePutIndex (i + 1) arr x + +-------------------------------------------------------------------------------- +-- Renaming +-------------------------------------------------------------------------------- + +RENAME(realloc,reallocBytes) +RENAME(castUnsafe,unsafeCast) +RENAME(newArrayWith,emptyWithAligned) +RENAME(getSliceUnsafe,unsafeSliceOffLen) +RENAME(getSlice,sliceOffLen) +RENAME(putIndexUnsafe,unsafePutIndex) +RENAME(modifyIndexUnsafe,unsafeModifyIndex) +RENAME(getIndexUnsafe,unsafeGetIndex) +RENAME(snocUnsafe,unsafeSnoc) +RENAME(spliceUnsafe,unsafeSplice) +RENAME(pokeSkipUnsafe,unsafePokeSkip) +RENAME(peekSkipUnsafe,unsafePeekSkip) +RENAME(peekUncons,peek) +RENAME(peekUnconsUnsafe,unsafePeek) +RENAME(pokeAppend,poke) +RENAME(pokeAppendMay,pokeMay) + +-- This renaming can be done directly without deprecations. But I'm keeping this +-- intentionally. Packdiff should be able to point out such APIs that we can +-- just remove. +RENAME(createOfWith,createWithOf) diff --git a/src/Streamly/Internal/Data/MutByteArray.hs b/src/Streamly/Internal/Data/MutByteArray.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/MutByteArray.hs @@ -0,0 +1,241 @@ +-- This is required as all the instances in this module are orphan instances. +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Streamly.Internal.Data.MutByteArray +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- + +module Streamly.Internal.Data.MutByteArray + ( + -- * MutByteArray + module Streamly.Internal.Data.MutByteArray.Type + -- * Unbox + , module Streamly.Internal.Data.Unbox + , module Streamly.Internal.Data.Unbox.TH + -- * Serialize + , module Streamly.Internal.Data.Serialize.Type + -- * Serialize TH + , module Streamly.Internal.Data.Serialize.TH + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Data.Proxy (Proxy(..)) +import Streamly.Internal.Data.Array (Array(..)) +import GHC.Exts (Int(..), sizeofByteArray#, unsafeCoerce#) +import GHC.Word (Word8) + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Num.Integer (Integer(..)) +#else +import GHC.Integer.GMP.Internals (Integer(..), BigNat(..)) +#endif + +import Streamly.Internal.Data.MutByteArray.Type +import Streamly.Internal.Data.Serialize.TH +import Streamly.Internal.Data.Serialize.Type +import Streamly.Internal.Data.Unbox +import Streamly.Internal.Data.Unbox.TH + +-------------------------------------------------------------------------------- +-- Common instances +-------------------------------------------------------------------------------- + +-- Note +-- ==== +-- +-- Even a non-functional change such as changing the order of constructors will +-- change the instance derivation. +-- +-- This will not pose a problem if both, encode, and decode are done by the same +-- version of the application. There *might* be a problem if version that +-- encodes differs from the version that decodes. +-- +-- We need to add some compatibility tests using different versions of +-- dependencies. +-- +-- Although such chages for the most basic types won't happen we need to detect +-- if it ever happens. +-- +-- Should we worry about these kind of changes and this kind of compatibility? +-- This is a problem for all types of derivations that depend on the order of +-- constructors, for example, Enum. + +-- Note on Windows build +-- ===================== +-- +-- On Windows, having template haskell splices here fail the build with the +-- following error: +-- +-- @ +-- addLibrarySearchPath: C:\... (Win32 error 3): The system cannot find the path specified. +-- @ +-- +-- The error might be irrelavant but having these splices triggers it. We should +-- either fix the problem or avoid the use to template haskell splices in this +-- file. +-- +-- Similar issue: https://github.com/haskell/cabal/issues/4741 + +-- $(Serialize.deriveSerialize ''Maybe) +instance Serialize a => Serialize (Maybe a) where + + {-# INLINE addSizeTo #-} + addSizeTo acc x = + case x of + Nothing -> acc + 1 + Just field0 -> addSizeTo (acc + 1) field0 + + {-# INLINE deserializeAt #-} + deserializeAt initialOffset arr endOffset = do + (i0, tag) <- deserializeAt initialOffset arr endOffset + case tag :: Word8 of + 0 -> pure (i0, Nothing) + 1 -> do (i1, a0) <- deserializeAt i0 arr endOffset + pure (i1, Just a0) + _ -> error "Found invalid tag while peeking (Maybe a)" + + {-# INLINE serializeAt #-} + serializeAt initialOffset arr val = + case val of + Nothing -> serializeAt initialOffset arr (0 :: Word8) + Just field0 -> do + i0 <- serializeAt initialOffset arr (1 :: Word8) + serializeAt i0 arr field0 + +-- $(Serialize.deriveSerialize ''Either) +instance (Serialize a, Serialize b) => Serialize (Either a b) where + + {-# INLINE addSizeTo #-} + addSizeTo acc x = + case x of + Left field0 -> addSizeTo (acc + 1) field0 + Right field0 -> addSizeTo (acc + 1) field0 + + {-# INLINE deserializeAt #-} + deserializeAt initialOffset arr endOffset = do + (i0, tag) <- deserializeAt initialOffset arr endOffset + case tag :: Word8 of + 0 -> do (i1, a0) <- deserializeAt i0 arr endOffset + pure (i1, Left a0) + 1 -> do (i1, a0) <- deserializeAt i0 arr endOffset + pure (i1, Right a0) + _ -> error "Found invalid tag while peeking (Either a b)" + + {-# INLINE serializeAt #-} + serializeAt initialOffset arr val = + case val of + Left field0 -> do + i0 <- serializeAt initialOffset arr (0 :: Word8) + serializeAt i0 arr field0 + Right field0 -> do + i0 <- serializeAt initialOffset arr (1 :: Word8) + serializeAt i0 arr field0 + +instance Serialize (Proxy a) where + + {-# INLINE addSizeTo #-} + addSizeTo acc _ = acc + 1 + + {-# INLINE deserializeAt #-} + deserializeAt initialOffset _ _ = pure (initialOffset + 1, Proxy) + + {-# INLINE serializeAt #-} + serializeAt initialOffset _ _ = pure (initialOffset + 1) + +-------------------------------------------------------------------------------- +-- Integer +-------------------------------------------------------------------------------- + +data LiftedInteger + = LIS Int + | LIP (Array Word) + | LIN (Array Word) + +-- $(Serialize.deriveSerialize ''LiftedInteger) +instance Serialize LiftedInteger where + + {-# INLINE addSizeTo #-} + addSizeTo acc x = + case x of + LIS field0 -> addSizeTo (acc + 1) field0 + LIP field0 -> addSizeTo (acc + 1) field0 + LIN field0 -> addSizeTo (acc + 1) field0 + + {-# INLINE deserializeAt #-} + deserializeAt initialOffset arr endOffset = do + (i0, tag) <- deserializeAt initialOffset arr endOffset + case tag :: Word8 of + 0 -> do (i1, a0) <- deserializeAt i0 arr endOffset + pure (i1, LIS a0) + 1 -> do (i1, a0) <- deserializeAt i0 arr endOffset + pure (i1, LIP a0) + 2 -> do (i1, a0) <- deserializeAt i0 arr endOffset + pure (i1, LIN a0) + _ -> error "Found invalid tag while peeking (LiftedInteger)" + + {-# INLINE serializeAt #-} + serializeAt initialOffset arr val = + case val of + LIS field0 -> do + i0 <- serializeAt initialOffset arr (0 :: Word8) + serializeAt i0 arr field0 + LIP field0 -> do + i0 <- serializeAt initialOffset arr (1 :: Word8) + serializeAt i0 arr field0 + LIN field0 -> do + i0 <- serializeAt initialOffset arr (2 :: Word8) + serializeAt i0 arr field0 + +#if __GLASGOW_HASKELL__ >= 900 + +{-# INLINE liftInteger #-} +liftInteger :: Integer -> LiftedInteger +liftInteger (IS x) = LIS (I# x) +liftInteger (IP x) = + LIP (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x))) +liftInteger (IN x) = + LIN (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x))) + +{-# INLINE unliftInteger #-} +unliftInteger :: LiftedInteger -> Integer +unliftInteger (LIS (I# x)) = IS x +unliftInteger (LIP (Array (MutByteArray x) _ _)) = IP (unsafeCoerce# x) +unliftInteger (LIN (Array (MutByteArray x) _ _)) = IN (unsafeCoerce# x) + +#else + +{-# INLINE liftInteger #-} +liftInteger :: Integer -> LiftedInteger +liftInteger (S# x) = LIS (I# x) +liftInteger (Jp# (BN# x)) = + LIP (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x))) +liftInteger (Jn# (BN# x)) = + LIN (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x))) + +{-# INLINE unliftInteger #-} +unliftInteger :: LiftedInteger -> Integer +unliftInteger (LIS (I# x)) = S# x +unliftInteger (LIP (Array (MutByteArray x) _ _)) = + Jp# (BN# (unsafeCoerce# x)) +unliftInteger (LIN (Array (MutByteArray x) _ _)) = + Jn# (BN# (unsafeCoerce# x)) + +#endif + +instance Serialize Integer where + {-# INLINE addSizeTo #-} + addSizeTo i a = addSizeTo i (liftInteger a) + + {-# INLINE deserializeAt #-} + deserializeAt off arr end = + fmap unliftInteger <$> deserializeAt off arr end + + {-# INLINE serializeAt #-} + serializeAt off arr val = serializeAt off arr (liftInteger val) diff --git a/src/Streamly/Internal/Data/MutByteArray/Type.hs b/src/Streamly/Internal/Data/MutByteArray/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/MutByteArray/Type.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +-- | +-- Module : Streamly.Internal.Data.MutByteArray.Type +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.MutByteArray.Type + ( + -- ** MutByteArray + MutByteArray(..) + , getMutByteArray# + + -- ** Helpers + , touch + + -- ** Pinning + , PinnedState(..) + , isPinned + , pin + , unpin + + -- ** Allocation + , empty + , newAs + , new + , new' + , reallocSliceAs + + -- ** Access + , length + , unsafeAsPtr + + -- ** Modify + , unsafePutSlice + , unsafePutPtrN + + -- ** Copy + , unsafeCloneSliceAs + , unsafeCloneSlice + , unsafePinnedCloneSlice -- XXX unsafeCloneSlice' + + -- ** Compare + , unsafeByteCmp + + -- ** Capacity Management + , blockSize + , largeObjectThreshold + + -- ** Deprecated + , MutableByteArray + , getMutableByteArray# + , newBytesAs + , sizeOfMutableByteArray + , putSliceUnsafe + , cloneSliceUnsafeAs + , cloneSliceUnsafe + , pinnedCloneSliceUnsafe + , pinnedNewAlignedBytes + , asPtrUnsafe + , unsafePinnedAsPtr + , nil + , pinnedNew + ) where + +#include "deprecation.h" + +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad (when) +import Data.Word (Word8) +#ifdef DEBUG +import Debug.Trace (trace) +#endif +import Foreign.C.Types (CSize(..)) +import GHC.Base (IO(..)) +import System.IO.Unsafe (unsafePerformIO) + +import GHC.Exts +import Prelude hiding (length) + +-------------------------------------------------------------------------------- +-- The ArrayContents type +-------------------------------------------------------------------------------- + +data PinnedState + = Pinned + | Unpinned deriving (Show, Eq) + +-- XXX can use UnliftedNewtypes + +-- | A lifted mutable byte array type wrapping @MutableByteArray# RealWorld@. +-- This is a low level array used to back high level unboxed arrays and +-- serialized data. +data MutByteArray = MutByteArray (MutableByteArray# RealWorld) + +{-# DEPRECATED MutableByteArray "Please use MutByteArray instead" #-} +type MutableByteArray = MutByteArray + +{-# INLINE getMutByteArray# #-} +getMutableByteArray#, getMutByteArray# :: MutByteArray -> MutableByteArray# RealWorld +getMutByteArray# (MutByteArray mbarr) = mbarr + +-- | Return the size of the array in bytes. +{-# INLINE length #-} +sizeOfMutableByteArray, length :: MutByteArray -> IO Int +length (MutByteArray arr) = + IO $ \s -> + case getSizeofMutableByteArray# arr s of + (# s1, i #) -> (# s1, I# i #) + +{-# INLINE touch #-} +touch :: MutByteArray -> IO () +touch (MutByteArray contents) = + IO $ \s -> case touch# contents s of s' -> (# s', () #) + +-- XXX Some functions in this module are "IO" and others are "m", we need to +-- make it consistent. + +-- | NOTE: this is deprecated because it can lead to accidental problems if the +-- user tries to use it to mutate the array because it does not return the new +-- array after pinning. +{-# DEPRECATED unsafePinnedAsPtr "Pin the array and then use unsafeAsPtr." #-} +{-# INLINE unsafePinnedAsPtr #-} +unsafePinnedAsPtr :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b +unsafePinnedAsPtr arr0 f = do + arr <- liftIO $ pin arr0 + let !ptr = Ptr (byteArrayContents# + (unsafeCoerce# (getMutByteArray# arr))) + r <- f ptr + liftIO $ touch arr + return r + +{-# DEPRECATED asPtrUnsafe "Pin the array and then use unsafeAsPtr." #-} +{-# INLINE asPtrUnsafe #-} +asPtrUnsafe :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b +asPtrUnsafe = unsafePinnedAsPtr + +-- | Use a @MutByteArray@ as @Ptr a@. This is useful when we want to pass +-- an array as a pointer to some operating system call or to a "safe" FFI call. +-- +-- /Unsafe/ WARNING: +-- +-- 1. Will lead to memory corruption if the array is not pinned. Use +-- only if the array is known to be pinned already or pin it explicitly. +-- +-- 2. Ensure that the pointer is accessed within the legal bounds of the array. +-- The size of the MutByteArray must be taken into account. +-- +-- /Pre-release/ +-- +{-# INLINE unsafeAsPtr #-} +unsafeAsPtr :: MonadIO m => MutByteArray -> (Ptr a -> IO b) -> m b +unsafeAsPtr arr f = liftIO $ do + when (not (isPinned arr)) + $ error "unsafeAsPtr requires the array to be pinned" + + let !ptr = Ptr (byteArrayContents# + (unsafeCoerce# (getMutByteArray# arr))) + r <- f ptr + -- While f is using the bare pointer, the MutByteArray may be garbage + -- collected by the GC, tell the GC that we are still using it. + touch arr + return r + +-------------------------------------------------------------------------------- +-- Creation +-------------------------------------------------------------------------------- + +{-# NOINLINE empty #-} +empty :: MutByteArray +empty = unsafePerformIO $ new 0 + +{-# DEPRECATED nil "Please use empty instead" #-} +nil :: MutByteArray +nil = empty + +-- XXX Should we use bitshifts in calculations or it gets optimized by the +-- compiler/processor itself? +-- +-- | The page or block size used by the GHC allocator. Allocator allocates at +-- least a block and then allocates smaller allocations from within a block. +blockSize :: Int +blockSize = 4 * 1024 + +-- | Allocations larger than 'largeObjectThreshold' are in multiples of block +-- size and are always pinned. The space beyond the end of a large object up to +-- the end of the block is unused. +largeObjectThreshold :: Int +largeObjectThreshold = (blockSize * 8) `div` 10 + +{-# INLINE pinnedNewRaw #-} +pinnedNewRaw :: Int -> IO MutByteArray +pinnedNewRaw (I# nbytes) = IO $ \s -> + case newPinnedByteArray# nbytes s of + (# s', mbarr# #) -> + let c = MutByteArray mbarr# + in (# s', c #) + +{-# INLINE new' #-} +new', pinnedNew :: Int -> IO MutByteArray +new' nbytes | nbytes < 0 = + errorWithoutStackTrace "new': size must be >= 0" +new' nbytes = pinnedNewRaw nbytes +RENAME_PRIME(pinnedNew,new) + +-- XXX add "newRoundedUp" to round up the large size to the next page boundary +-- and return the allocated size. +-- Uses the pinned version of allocated if the size required is > +-- largeObjectThreshold +{-# INLINE new #-} +new :: Int -> IO MutByteArray +new nbytes | nbytes > largeObjectThreshold = pinnedNewRaw nbytes +new nbytes | nbytes < 0 = + errorWithoutStackTrace "newByteArray: size must be >= 0" +new (I# nbytes) = IO $ \s -> + case newByteArray# nbytes s of + (# s', mbarr# #) -> + let c = MutByteArray mbarr# + in (# s', c #) + +{-# DEPRECATED pinnedNewAlignedBytes "Please use pinnedNew instead" #-} +{-# INLINE pinnedNewAlignedBytes #-} +pinnedNewAlignedBytes :: Int -> Int -> IO MutByteArray +pinnedNewAlignedBytes nbytes _align | nbytes < 0 = + errorWithoutStackTrace "pinnedNewAlignedBytes: size must be >= 0" +pinnedNewAlignedBytes (I# nbytes) (I# align) = IO $ \s -> + case newAlignedPinnedByteArray# nbytes align s of + (# s', mbarr# #) -> + let c = MutByteArray mbarr# + in (# s', c #) + +{-# INLINE newAs #-} +newBytesAs, newAs :: PinnedState -> Int -> IO MutByteArray +newAs Unpinned = new +newAs Pinned = pinnedNew + +-- | @reallocSliceAs pinType newLen array offset len@ reallocates a slice +-- from @array@ starting at @offset@ and having length @len@ to a new array of +-- length @newLen@ copying the old data to the new. Note that if the @newLen@ +-- is smaller than @len@ it will truncate the old data. +{-# INLINE reallocSliceAs #-} +reallocSliceAs :: + PinnedState -> Int -> MutByteArray -> Int -> Int -> IO MutByteArray +reallocSliceAs ps newLen (MutByteArray src#) srcStart srcLen = do + MutByteArray dst# <- newBytesAs ps newLen + + -- Copy old data + let !(I# srcStart#) = srcStart + !(I# newLen#) = min srcLen newLen + IO $ \s# -> (# copyMutableByteArray# src# srcStart# + dst# 0# newLen# s#, MutByteArray dst# #) + +------------------------------------------------------------------------------- +-- Copying +------------------------------------------------------------------------------- + +-- Note: Array copy is more efficient than streaming copy. +-- CopyMutableByteArray# translates to genMemcpy in GHC/CmmToAsm/X86/CodeGen.hs +-- glibc memcpy copies bytes/words/pages - unrolls the loops: +-- https://github.com/bminor/glibc/blob/4290aed05135ae4c0272006442d147f2155e70d7/string/memcpy.c +-- https://github.com/bminor/glibc/blob/4290aed05135ae4c0272006442d147f2155e70d7/string/wordcopy.c + +-- | @unsafePutSlice src srcOffset dst dstOffset len@ copies @len@ bytes from +-- @src@ at @srcOffset@ to dst at @dstOffset@. +-- +-- This is unsafe as it does not check the bounds of @src@ or @dst@. +-- +{-# INLINE unsafePutSlice #-} +putSliceUnsafe, unsafePutSlice :: + MonadIO m + => MutByteArray + -> Int + -> MutByteArray + -> Int + -> Int + -> m () +unsafePutSlice src srcStartBytes dst dstStartBytes lenBytes = liftIO $ do +#ifdef DEBUG + srcLen <- length src + dstLen <- length dst + when (srcLen - srcStartBytes < lenBytes) + $ error $ "unsafePutSlice: src overflow: start" ++ show srcStartBytes + ++ " end " ++ show srcLen ++ " len " ++ show lenBytes + when (dstLen - dstStartBytes < lenBytes) + $ error $ "unsafePutSlice: dst overflow: start" ++ show dstStartBytes + ++ " end " ++ show dstLen ++ " len " ++ show lenBytes +#endif + let !(I# srcStartBytes#) = srcStartBytes + !(I# dstStartBytes#) = dstStartBytes + !(I# lenBytes#) = lenBytes + let arrS# = getMutByteArray# src + arrD# = getMutByteArray# dst + IO $ \s# -> (# copyMutableByteArray# + arrS# srcStartBytes# arrD# dstStartBytes# lenBytes# s# + , () #) + +foreign import ccall unsafe "string.h memcpy" c_memcpy_pinned + :: Addr# -> Addr# -> CSize -> IO (Ptr Word8) + +-- | @unsafePutPtrN srcPtr dst dstOffset len@ copies @len@ bytes from @srcPtr@ +-- to dst at @dstOffset@. +-- +-- /Unsafe/: +-- +-- The caller has to ensure that: +-- +-- * the MutByteArray @dst@ is valid up to @dstOffset + len@. +-- * the @srcPtr@ is alive and pinned during the call. +-- * the @srcPtr@ is valid up to length @len@. +-- +{-# INLINE unsafePutPtrN #-} +unsafePutPtrN :: + MonadIO m + => Ptr Word8 + -> MutByteArray + -> Int + -> Int + -> m () +unsafePutPtrN (Ptr srcAddr) dst dstOffset len = liftIO $ do +#ifdef DEBUG + dstLen <- length dst + when (dstLen - dstOffset < len) + $ error $ "unsafePutPtrN: dst overflow: start" ++ show dstOffset + ++ " end " ++ show dstLen ++ " len " ++ show len +#endif + let !dstAddr# = byteArrayContents# (unsafeCoerce# (getMutByteArray# dst)) + !(I# dstOff#) = dstOffset + !dstAddr1# = plusAddr# dstAddr# dstOff# + _ <- c_memcpy_pinned dstAddr1# srcAddr (fromIntegral len) + pure () + +-- | Unsafe as it does not check whether the start offset and length supplied +-- are valid inside the array. +{-# INLINE unsafeCloneSliceAs #-} +cloneSliceUnsafeAs, unsafeCloneSliceAs :: MonadIO m => + PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray +unsafeCloneSliceAs ps srcOff srcLen src = + liftIO $ do + mba <- newAs ps srcLen + unsafePutSlice src srcOff mba 0 srcLen + return mba + +-- | @unsafeCloneSlice offset len arr@ clones a slice of the supplied array +-- starting at the given offset and equal to the given length. +{-# INLINE unsafeCloneSlice #-} +cloneSliceUnsafe, unsafeCloneSlice :: MonadIO m => Int -> Int -> MutByteArray -> m MutByteArray +unsafeCloneSlice = unsafeCloneSliceAs Unpinned + +-- | @unsafePinnedCloneSlice offset len arr@ +{-# INLINE unsafePinnedCloneSlice #-} +pinnedCloneSliceUnsafe, unsafePinnedCloneSlice :: MonadIO m => + Int -> Int -> MutByteArray -> m MutByteArray +unsafePinnedCloneSlice = unsafeCloneSliceAs Pinned + +unsafeByteCmp + :: MutByteArray -> Int -> MutByteArray -> Int -> Int -> IO Int +unsafeByteCmp + (MutByteArray marr1) (I# st1#) (MutByteArray marr2) (I# st2#) (I# len#) = + IO $ \s# -> + let res = + I# + (compareByteArrays# + (unsafeCoerce# marr1) + st1# + (unsafeCoerce# marr2) + st2# + len#) + in (# s#, res #) + +------------------------------------------------------------------------------- +-- Pinning & Unpinning +------------------------------------------------------------------------------- + +-- | Return 'True' if the array is allocated in pinned memory. +{-# INLINE isPinned #-} +isPinned :: MutByteArray -> Bool +isPinned (MutByteArray arr#) = + let pinnedInt = I# (isMutableByteArrayPinned# arr#) + in pinnedInt /= 0 + + +{-# INLINE cloneMutableArrayWith# #-} +cloneMutableArrayWith# + :: (Int# -> State# RealWorld -> (# State# RealWorld + , MutableByteArray# RealWorld #)) + -> MutableByteArray# RealWorld + -> State# RealWorld + -> (# State# RealWorld, MutableByteArray# RealWorld #) +cloneMutableArrayWith# alloc# arr# s# = + case getSizeofMutableByteArray# arr# s# of + (# s1#, i# #) -> + case alloc# i# s1# of + (# s2#, arr1# #) -> + case copyMutableByteArray# arr# 0# arr1# 0# i# s2# of + s3# -> (# s3#, arr1# #) + +-- | Return a copy of the array in pinned memory if unpinned, else return the +-- original array. +{-# INLINE pin #-} +pin :: MutByteArray -> IO MutByteArray +pin arr@(MutByteArray marr#) = + if isPinned arr + then return arr + else +#ifdef DEBUG + do + -- XXX dump stack trace + trace ("pin: Copying array") (return ()) +#endif + IO + $ \s# -> + case cloneMutableArrayWith# newPinnedByteArray# marr# s# of + (# s1#, marr1# #) -> (# s1#, MutByteArray marr1# #) + +-- | Return a copy of the array in unpinned memory if pinned, else return the +-- original array. +{-# INLINE unpin #-} +unpin :: MutByteArray -> IO MutByteArray +unpin arr@(MutByteArray marr#) = + if not (isPinned arr) + then return arr + else +#ifdef DEBUG + do + -- XXX dump stack trace + trace ("unpin: Copying array") (return ()) +#endif + IO + $ \s# -> + case cloneMutableArrayWith# newByteArray# marr# s# of + (# s1#, marr1# #) -> (# s1#, MutByteArray marr1# #) + +-------------------------------------------------------------------------------- +-- Renaming +-------------------------------------------------------------------------------- + +RENAME(getMutableByteArray#, getMutByteArray#) +RENAME(newBytesAs, newAs) +RENAME(sizeOfMutableByteArray, length) +RENAME(putSliceUnsafe, unsafePutSlice) +RENAME(cloneSliceUnsafeAs, unsafeCloneSliceAs) +RENAME(cloneSliceUnsafe, unsafeCloneSlice) +RENAME(pinnedCloneSliceUnsafe, unsafePinnedCloneSlice) diff --git a/src/Streamly/Internal/Data/Parser.hs b/src/Streamly/Internal/Data/Parser.hs --- a/src/Streamly/Internal/Data/Parser.hs +++ b/src/Streamly/Internal/Data/Parser.hs @@ -1,14 +1,3639 @@ --- | --- Module : Streamly.Internal.Data.Parser --- Copyright : (c) 2019 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Parser - ( module Streamly.Internal.Data.Parser.ParserD - ) -where - -import Streamly.Internal.Data.Parser.ParserD +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoMonoLocalBinds #-} +-- | +-- Module : Streamly.Internal.Data.Parser +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Parser + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + module Streamly.Internal.Data.Parser.Type + --, module Streamly.Internal.Data.Parser.Tee + + -- * Downgrade to Fold + , toFold + + -- First order parsers + -- * Accumulators + , fromFold + , fromFoldMaybe + + -- * Map on input + , postscan + + -- * Element parsers + , peek + + -- All of these can be expressed in terms of either + , one + , oneEq + , oneNotEq + , oneOf + , noneOf + , eof + , satisfy + , maybe + , either + + -- * Sequence parsers (tokenizers) + -- + -- | Parsers chained in series, if one parser terminates the composition + -- terminates. Currently we are using folds to collect the output of the + -- parsers but we can use Parsers instead of folds to make the composition + -- more powerful. For example, we can do: + -- + -- takeEndByOrMax cond n p = takeEndBy cond (take n p) + -- takeEndByBetween cond m n p = takeEndBy cond (takeBetween m n p) + -- takeWhileBetween cond m n p = takeWhile cond (takeBetween m n p) + , lookAhead + + -- ** By length + -- | Grab a sequence of input elements without inspecting them + , takeBetween + -- , take -- takeBetween 0 n + , takeEQ -- takeBetween n n + , takeGE -- takeBetween n maxBound + -- , takeGE1 -- take1 -- takeBetween 1 n + , takeP + + -- Grab a sequence of input elements by inspecting them + -- ** Exact match + , listEq + , listEqBy + , streamEqBy + , subsequenceBy + + -- ** By predicate + , takeWhile + , takeWhileP + , takeWhile1 + , dropWhile + + -- ** Separated by elements + -- | Separator could be in prefix postion ('takeBeginBy'), or suffix + -- position ('takeEndBy'). See 'deintercalate', 'sepBy' etc for infix + -- separator parsing, also see 'intersperseQuotedBy' fold. + + -- These can be implemented modularly with refolds, using takeWhile and + -- satisfy. + , takeEndBy + , takeEndBy_ + , takeEndByEsc + -- , takeEndByEsc_ + , takeBeginBy + , takeBeginBy_ + , takeEitherSepBy + , wordBy + + -- ** Grouped by element comparison + , groupBy + , groupByRolling + , groupByRollingEither + + -- ** Framed by elements + -- | Also see 'intersperseQuotedBy' fold. + -- Framed by a one or more ocurrences of a separator around a word like + -- spaces or quotes. No nesting. + , wordFramedBy -- XXX Remove this? Covered by wordWithQuotes? + , wordWithQuotes + , wordKeepQuotes + , wordProcessQuotes + + -- Framed by separate start and end characters, potentially nested. + -- blockWithQuotes allows quotes inside a block. However, + -- takeFramedByGeneric can be used to express takeBeginBy, takeEndBy and + -- block with escaping. + -- , takeFramedBy + , takeFramedBy_ + , takeFramedByEsc_ + , takeFramedByGeneric + , blockWithQuotes + + -- Matching strings + -- , prefixOf -- match any prefix of a given string + -- , suffixOf -- match any suffix of a given string + -- , infixOf -- match any substring of a given string + + -- ** Spanning + , span + , spanBy + , spanByRolling + + -- Second order parsers (parsers using parsers) + -- * Binary Combinators + {- + -- ** Parallel Applicatives + , teeWith + , teeWithFst + , teeWithMin + -- , teeTill -- like manyTill but parallel + -} + + {- + -- ** Parallel Alternatives + , shortest + , longest + -- , fastest + -} + + -- * N-ary Combinators + -- ** Sequential Collection + , sequence + + -- ** Sequential Repetition + , count + , countBetween + -- , countBetweenTill + , manyP + , many + , some + + -- ** Interleaved Repetition + -- Use two folds, run a primary parser, its rejected values go to the + -- secondary parser. + , deintercalate + , deintercalate1 + , deintercalateAll + -- , deintercalatePrefix + -- , deintercalateSuffix + + -- *** Special cases + -- | TODO: traditional implmentations of these may be of limited use. For + -- example, consider parsing lines separated by @\\r\\n@. The main parser + -- will have to detect and exclude the sequence @\\r\\n@ anyway so that we + -- can apply the "sep" parser. + -- + -- We can instead implement these as special cases of deintercalate. + -- + -- @ + -- , endBy + -- , sepEndBy + -- , beginBy + -- , sepBeginBy + -- , sepAroundBy + -- @ + , sepBy1 + , sepBy + , sepByAll + + , manyTillP + , manyTill + , manyThen + + -- -- * Distribution + -- + -- A simple and stupid impl would be to just convert the stream to an array + -- and give the array reference to all consumers. The array can be grown on + -- demand by any consumer and truncated when nonbody needs it. + -- + -- -- ** Distribute to collection + -- -- ** Distribute to repetition + + -- ** Interleaved collection + -- | + -- + -- 1. Round robin + -- 2. Priority based + , roundRobin + + -- -- ** Interleaved repetition + -- repeat one parser and when it fails run an error recovery parser + -- e.g. to find a key frame in the stream after an error + + -- ** Collection of Alternatives + -- | Unimplemented + -- + -- @ + -- , shortestN + -- , longestN + -- , fastestN -- first N successful in time + -- , choiceN -- first N successful in position + -- @ + -- , choice -- first successful in position + + -- ** Repeated Alternatives + , retryMaxTotal + , retryMaxSuccessive + , retry + + -- ** Zipping Input + , zipWithM + , zip + , indexed + , makeIndexFilter + , sampleFromthen + + -- * Deprecated + , next + , takeStartBy + , takeStartBy_ + ) +where + +#include "inline.hs" +#include "deprecation.h" +#include "assert.hs" + +import Data.Bifunctor (first) +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.SVar.Type (defState) +import Streamly.Internal.Data.Either.Strict (Either'(..)) +import Streamly.Internal.Data.Maybe.Strict (Maybe'(..)) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) +import Streamly.Internal.Data.Stream.Type (Stream) + +import qualified Data.Foldable as Foldable +import qualified Streamly.Internal.Data.Fold.Type as FL +import qualified Streamly.Internal.Data.Stream.Type as D +import qualified Streamly.Internal.Data.Stream.Generate as D + +import Streamly.Internal.Data.Parser.Type +--import Streamly.Internal.Data.Parser.Tee -- It's empty + +import Prelude hiding + (any, all, take, takeWhile, sequence, concatMap, maybe, either, span + , zip, filter, dropWhile) + +#include "DocTestDataParser.hs" + +------------------------------------------------------------------------------- +-- Downgrade a parser to a Fold +------------------------------------------------------------------------------- + +-- | Make a 'Fold' from a 'Parser'. The fold just throws an exception if the +-- parser fails or tries to backtrack. +-- +-- This can be useful in combinators that accept a Fold and we know that a +-- Parser cannot fail or failure exception is acceptable as there is no way to +-- recover. +-- +-- /Pre-release/ +-- +{-# INLINE toFold #-} +toFold :: Monad m => Parser a m b -> Fold m a b +toFold (Parser pstep pinitial pextract) = Fold step initial extract final + + where + + initial = do + r <- pinitial + case r of + IPartial s -> return $ FL.Partial s + IDone b -> return $ FL.Done b + IError err -> + error $ "toFold: parser throws error in initial" ++ err + + perror n = error $ "toFold: parser backtracks in SPartial: " ++ show n + cerror n = error $ "toFold: parser backtracks in SContinue: " ++ show n + derror n = error $ "toFold: parser backtracks in SDone: " ++ show n + eerror err = error $ "toFold: parser throws error: " ++ err + + step st a = do + r <- pstep st a + case r of + SPartial 1 s -> return $ FL.Partial s + SContinue 1 s -> return $ FL.Partial s + SDone 1 b -> return $ FL.Done b + SPartial n _ -> perror n + SContinue n _ -> cerror n + SDone n _ -> derror n + SError err -> eerror err + + extract = error "toFold: parser cannot be used for scanning" + + final st = do + r <- pextract st + case r of + FDone 0 b -> return b + FContinue n _ -> cerror n + FDone n _ -> derror n + FError err -> eerror err + +------------------------------------------------------------------------------- +-- Upgrade folds to parses +------------------------------------------------------------------------------- + +-- | Make a 'Parser' from a 'Fold'. This parser sends all of its input to the +-- fold. +-- +{-# INLINE fromFold #-} +fromFold :: Monad m => Fold m a b -> Parser a m b +fromFold (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + initial = do + res <- finitial + return + $ case res of + FL.Partial s1 -> IPartial s1 + FL.Done b -> IDone b + + step s a = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SPartial 1 s1 + FL.Done b -> SDone 1 b + + extract = fmap (FDone 0) . ffinal + +-- | Convert a Maybe returning fold to an error returning parser. The first +-- argument is the error message that the parser would return when the fold +-- returns Nothing. +-- +-- /Pre-release/ +-- +{-# INLINE fromFoldMaybe #-} +fromFoldMaybe :: Monad m => String -> Fold m a (Maybe b) -> Parser a m b +fromFoldMaybe errMsg (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + initial = do + res <- finitial + return + $ case res of + FL.Partial s1 -> IPartial s1 + FL.Done b -> + case b of + Just x -> IDone x + Nothing -> IError errMsg + + step s a = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SPartial 1 s1 + FL.Done b -> + case b of + Just x -> SDone 1 x + Nothing -> SError errMsg + + extract s = do + res <- ffinal s + case res of + Just x -> return $ FDone 0 x + Nothing -> return $ FError errMsg + +------------------------------------------------------------------------------- +-- Failing Parsers +------------------------------------------------------------------------------- + +-- | Peek the head element of a stream, without consuming it. Fails if it +-- encounters end of input. +-- +-- >>> Stream.parse ((,) <$> Parser.peek <*> Parser.satisfy (> 0)) $ Stream.fromList [1] +-- Right (1,1) +-- +-- @ +-- peek = lookAhead (satisfy True) +-- @ +-- +{-# INLINE peek #-} +peek :: Monad m => Parser a m a +peek = Parser step initial extract + + where + + initial = return $ IPartial () + + step () a = return $ SDone 0 a + + extract () = return $ FError "peek: end of input" + +-- | Succeeds if we are at the end of input, fails otherwise. +-- +-- >>> Stream.parse ((,) <$> Parser.satisfy (> 0) <*> Parser.eof) $ Stream.fromList [1] +-- Right (1,()) +-- +{-# INLINE eof #-} +eof :: Monad m => Parser a m () +eof = Parser step initial extract + + where + + initial = return $ IPartial () + + step () _ = return $ SError "eof: not at end of input" + + extract () = return $ FDone 0 () + +-- | Return the next element of the input. Returns 'Nothing' +-- on end of input. Also known as 'head'. +-- +-- /Pre-release/ +-- +{-# DEPRECATED next "Please use \"fromFold Fold.one\" instead" #-} +{-# INLINE next #-} +next :: Monad m => Parser a m (Maybe a) +next = Parser step initial extract + + where + + initial = pure $ IPartial () + + step () a = pure $ SDone 1 (Just a) + + extract () = pure $ FDone 0 Nothing + +-- | Map an 'Either' returning function on the next element in the stream. If +-- the function returns 'Left err', the parser fails with the error message +-- @err@ otherwise returns the 'Right' value. +-- +-- /Pre-release/ +-- +{-# INLINE either #-} +either :: Monad m => (a -> Either String b) -> Parser a m b +either f = Parser step initial extract + + where + + initial = return $ IPartial () + + step () a = return $ + case f a of + Right b -> SDone 1 b + Left err -> SError err + + extract () = return $ FError "end of input" + +-- | Map a 'Maybe' returning function on the next element in the stream. The +-- parser fails if the function returns 'Nothing' otherwise returns the 'Just' +-- value. +-- +-- >>> toEither = Maybe.maybe (Left "maybe: predicate failed") Right +-- >>> maybe f = Parser.either (toEither . f) +-- +-- >>> maybe f = Parser.fromFoldMaybe "maybe: predicate failed" (Fold.maybe f) +-- +-- /Pre-release/ +-- +{-# INLINE maybe #-} +maybe :: Monad m => (a -> Maybe b) -> Parser a m b +-- maybe f = either (Maybe.maybe (Left "maybe: predicate failed") Right . f) +maybe parserF = Parser step initial extract + + where + + initial = return $ IPartial () + + step () a = return $ + case parserF a of + Just b -> SDone 1 b + Nothing -> SError "maybe: predicate failed" + + extract () = return $ FError "maybe: end of input" + +-- | Returns the next element if it passes the predicate, fails otherwise. +-- +-- >>> Stream.parse (Parser.satisfy (== 1)) $ Stream.fromList [1,0,1] +-- Right 1 +-- +-- >>> toMaybe f x = if f x then Just x else Nothing +-- >>> satisfy f = Parser.maybe (toMaybe f) +-- +{-# INLINE satisfy #-} +satisfy :: Monad m => (a -> Bool) -> Parser a m a +-- satisfy predicate = maybe (\a -> if predicate a then Just a else Nothing) +satisfy predicate = Parser step initial extract + + where + + initial = return $ IPartial () + + step () a = return $ + if predicate a + then SDone 1 a + else SError "satisfy: predicate failed" + + extract () = return $ FError "satisfy: end of input" + +-- | Consume one element from the head of the stream. Fails if it encounters +-- end of input. +-- +-- >>> one = Parser.satisfy $ const True +-- +{-# INLINE one #-} +one :: Monad m => Parser a m a +one = satisfy $ const True + +-- Alternate names: "only", "onlyThis". + +-- | Match a specific element. +-- +-- >>> oneEq x = Parser.satisfy (== x) +-- +{-# INLINE oneEq #-} +oneEq :: (Monad m, Eq a) => a -> Parser a m a +oneEq x = satisfy (== x) + +-- Alternate names: "exclude", "notThis". + +-- | Match anything other than the supplied element. +-- +-- >>> oneNotEq x = Parser.satisfy (/= x) +-- +{-# INLINE oneNotEq #-} +oneNotEq :: (Monad m, Eq a) => a -> Parser a m a +oneNotEq x = satisfy (/= x) + +-- | Match any one of the elements in the supplied list. +-- +-- >>> oneOf xs = Parser.satisfy (`Foldable.elem` xs) +-- +-- When performance matters a pattern matching predicate could be more +-- efficient than a 'Foldable' datatype: +-- +-- @ +-- let p x = +-- case x of +-- 'a' -> True +-- 'e' -> True +-- _ -> False +-- in satisfy p +-- @ +-- +-- GHC may use a binary search instead of linear search in the list. +-- Alternatively, you can also use an array instead of list for storage and +-- search. +-- +{-# INLINE oneOf #-} +oneOf :: (Monad m, Eq a, Foldable f) => f a -> Parser a m a +oneOf xs = satisfy (`Foldable.elem` xs) + +-- | See performance notes in 'oneOf'. +-- +-- >>> noneOf xs = Parser.satisfy (`Foldable.notElem` xs) +-- +{-# INLINE noneOf #-} +noneOf :: (Monad m, Eq a, Foldable f) => f a -> Parser a m a +noneOf xs = satisfy (`Foldable.notElem` xs) + +------------------------------------------------------------------------------- +-- Taking elements +------------------------------------------------------------------------------- + +-- Required to fuse "take" with "many" in "chunksOf", for ghc-9.x +{-# ANN type Tuple'Fused Fuse #-} +data Tuple'Fused a b = Tuple'Fused !a !b deriving Show + +-- | @takeBetween m n@ takes a minimum of @m@ and a maximum of @n@ input +-- elements and folds them using the supplied fold. +-- +-- Stops after @n@ elements. +-- Fails if the stream ends before @m@ elements could be taken. +-- +-- Examples: - +-- +-- @ +-- >>> :{ +-- takeBetween' low high ls = Stream.parsePos prsr (Stream.fromList ls) +-- where prsr = Parser.takeBetween low high Fold.toList +-- :} +-- +-- @ +-- +-- >>> takeBetween' 2 4 [1, 2, 3, 4, 5] +-- Right [1,2,3,4] +-- +-- >>> takeBetween' 2 4 [1, 2] +-- Right [1,2] +-- +-- >>> takeBetween' 2 4 [1] +-- Left (ParseErrorPos 1 "takeBetween: Expecting alteast 2 elements, got 1") +-- +-- >>> takeBetween' 0 0 [1, 2] +-- Right [] +-- +-- >>> takeBetween' 0 1 [] +-- Right [] +-- +-- @takeBetween@ is the most general take operation, other take operations can +-- be defined in terms of takeBetween. For example: +-- +-- >>> take n = Parser.takeBetween 0 n +-- >>> takeEQ n = Parser.takeBetween n n +-- >>> takeGE n = Parser.takeBetween n maxBound +-- +-- /Pre-release/ +-- +{-# INLINE takeBetween #-} +takeBetween :: Monad m => Int -> Int -> Fold m a b -> Parser a m b +takeBetween low high (Fold fstep finitial _ ffinal) = + + Parser step initial (extract streamErr) + + where + + streamErr i = + "takeBetween: Expecting alteast " ++ show low + ++ " elements, got " ++ show i + + invalidRange = + "takeBetween: lower bound - " ++ show low + ++ " is greater than higher bound - " ++ show high + + foldErr :: Int -> String + foldErr i = + "takeBetween: the collecting fold terminated after" + ++ " consuming" ++ show i ++ " elements" + ++ " minimum" ++ show low ++ " elements needed" + + -- Exactly the same as snext except different constructors, we can possibly + -- deduplicate the two. + {-# INLINE inext #-} + inext i res = + let i1 = i + 1 + in case res of + FL.Partial s -> do + let s1 = Tuple'Fused i1 s + if i1 < high + -- XXX ideally this should be a Continue instead + then return $ IPartial s1 + else iextract foldErr s1 + FL.Done b -> + return + $ if i1 >= low + then IDone b + else IError (foldErr i1) + + -- In the case of Identity monad + -- @ + -- when True (error invalidRange) + -- @ + -- does not evaluate the @error invalidRange@ due to which no error occurs. + initial = + if low >= 0 && high >= 0 && low > high + then error invalidRange + else finitial >>= inext (-1) + + -- Keep the impl same as inext + {-# INLINE snext #-} + snext i res = + let i1 = i + 1 + in case res of + FL.Partial s -> do + let s1 = Tuple'Fused i1 s + if i1 < low + then return $ SContinue 1 s1 + else if i1 < high + then return $ SPartial 1 s1 + else fmap (SDone 1) (ffinal s) + FL.Done b -> + return + $ if i1 >= low + then SDone 1 b + else SError (foldErr i1) + + step (Tuple'Fused i s) a = fstep s a >>= snext i + + extract f (Tuple'Fused i s) + | i >= low && i <= high = fmap (FDone 0) (ffinal s) + | otherwise = return $ FError (f i) + + -- XXX Need to make Initial return type Step to deduplicate this + iextract f (Tuple'Fused i s) + | i >= low && i <= high = fmap IDone (ffinal s) + | otherwise = return $ IError (f i) + +-- | Stops after taking exactly @n@ input elements. +-- +-- * Stops - after consuming @n@ elements. +-- * Fails - if the stream or the collecting fold ends before it can collect +-- exactly @n@ elements. +-- +-- >>> Stream.parsePos (Parser.takeEQ 2 Fold.toList) $ Stream.fromList [1,0,1] +-- Right [1,0] +-- +-- >>> Stream.parsePos (Parser.takeEQ 4 Fold.toList) $ Stream.fromList [1,0,1] +-- Left (ParseErrorPos 3 "takeEQ: Expecting exactly 4 elements, input terminated on 3") +-- +{-# INLINE takeEQ #-} +takeEQ :: Monad m => Int -> Fold m a b -> Parser a m b +takeEQ n (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + initial = do + res <- finitial + case res of + FL.Partial s -> + if n > 0 + then return $ IPartial $ Tuple'Fused 1 s + else fmap IDone (ffinal s) + FL.Done b -> return $ + if n > 0 + then IError + $ "takeEQ: Expecting exactly " ++ show n + ++ " elements, fold terminated without" + ++ " consuming any elements" + else IDone b + + step (Tuple'Fused i1 r) a = do + res <- fstep r a + if n > i1 + then + return + $ case res of + FL.Partial s -> SContinue 1 $ Tuple'Fused (i1 + 1) s + FL.Done _ -> + SError + $ "takeEQ: Expecting exactly " ++ show n + ++ " elements, fold terminated on " ++ show i1 + else + -- assert (n == i1) + SDone 1 + <$> case res of + FL.Partial s -> ffinal s + FL.Done b -> return b + + extract (Tuple'Fused i _) = + -- Using the count "i" in the message below causes large performance + -- regression unless we use Fuse annotation on Tuple. + return + $ FError + $ "takeEQ: Expecting exactly " ++ show n + ++ " elements, input terminated on " ++ show (i - 1) + +{-# ANN type TakeGEState Fuse #-} +data TakeGEState s = + TakeGELT !Int !s + | TakeGEGE !s + +-- | Take at least @n@ input elements, but can collect more. +-- +-- * Stops - when the collecting fold stops. +-- * Fails - if the stream or the collecting fold ends before producing @n@ +-- elements. +-- +-- >>> Stream.parsePos (Parser.takeGE 4 Fold.toList) $ Stream.fromList [1,0,1] +-- Left (ParseErrorPos 3 "takeGE: Expecting at least 4 elements, input terminated on 3") +-- +-- >>> Stream.parse (Parser.takeGE 4 Fold.toList) $ Stream.fromList [1,0,1,0,1] +-- Right [1,0,1,0,1] +-- +-- /Pre-release/ +-- +{-# INLINE takeGE #-} +takeGE :: Monad m => Int -> Fold m a b -> Parser a m b +takeGE n (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + initial = do + res <- finitial + case res of + FL.Partial s -> + if n > 0 + then return $ IPartial $ TakeGELT 1 s + else return $ IPartial $ TakeGEGE s + FL.Done b -> return $ + if n > 0 + then IError + $ "takeGE: Expecting at least " ++ show n + ++ " elements, fold terminated without" + ++ " consuming any elements" + else IDone b + + step (TakeGELT i1 r) a = do + res <- fstep r a + if n > i1 + then + return + $ case res of + FL.Partial s -> SContinue 1 $ TakeGELT (i1 + 1) s + FL.Done _ -> + SError + $ "takeGE: Expecting at least " ++ show n + ++ " elements, fold terminated on " ++ show i1 + else + -- assert (n <= i1) + return + $ case res of + FL.Partial s -> SPartial 1 $ TakeGEGE s + FL.Done b -> SDone 1 b + step (TakeGEGE r) a = do + res <- fstep r a + return + $ case res of + FL.Partial s -> SPartial 1 $ TakeGEGE s + FL.Done b -> SDone 1 b + + extract (TakeGELT i _) = + return + $ FError + $ "takeGE: Expecting at least " ++ show n + ++ " elements, input terminated on " ++ show (i - 1) + extract (TakeGEGE r) = fmap (FDone 0) $ ffinal r + +------------------------------------------------------------------------------- +-- Conditional splitting +------------------------------------------------------------------------------- + +-- XXX We should perhaps use only takeWhileP and rename it to takeWhile. + +-- | Like 'takeWhile' but uses a 'Parser' instead of a 'Fold' to collect the +-- input. The combinator stops when the condition fails or if the collecting +-- parser stops. +-- +-- Other interesting parsers can be implemented in terms of this parser: +-- +-- >>> takeWhile1 cond p = Parser.takeWhileP cond (Parser.takeBetween 1 maxBound p) +-- >>> takeWhileBetween cond m n p = Parser.takeWhileP cond (Parser.takeBetween m n p) +-- +-- Stops: when the condition fails or the collecting parser stops. +-- Fails: when the collecting parser fails. +-- +-- /Pre-release/ +-- +{-# INLINE takeWhileP #-} +takeWhileP :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b +takeWhileP predicate (Parser pstep pinitial pextract) = + Parser step pinitial pextract + + where + + step s a = + if predicate a + then pstep s a + else do + -- In this case when converting Final to Step we don't add 1 as we + -- don't consume the current element. + r <- pextract s + case r of + FError err -> return $ SError err + FDone n s1 -> return $ SDone n s1 + FContinue n s1 -> return $ SContinue n s1 + +-- | Collect stream elements until an element fails the predicate. The element +-- on which the predicate fails is returned back to the input stream. +-- +-- * Stops - when the predicate fails or the collecting fold stops. +-- * Fails - never. +-- +-- >>> Stream.parse (Parser.takeWhile (== 0) Fold.toList) $ Stream.fromList [0,0,1,0,1] +-- Right [0,0] +-- +-- >>> takeWhile cond f = Parser.takeWhileP cond (Parser.fromFold f) +-- +-- We can implement a @breakOn@ using 'takeWhile': +-- +-- @ +-- breakOn p = takeWhile (not p) +-- @ +-- +{-# INLINE takeWhile #-} +takeWhile :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b +-- takeWhile cond f = takeWhileP cond (fromFold f) +takeWhile predicate (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + initial = do + res <- finitial + return $ case res of + FL.Partial s -> IPartial s + FL.Done b -> IDone b + + step s a = + if predicate a + then do + fres <- fstep s a + return + $ case fres of + FL.Partial s1 -> SPartial 1 s1 + FL.Done b -> SDone 1 b + else SDone 0 <$> ffinal s + + extract s = fmap (FDone 0) (ffinal s) + +{- +-- XXX This may not be composable because of the b argument. We can instead +-- return a "Reparse b a m b" so that those can be composed. +{-# INLINE takeWhile1X #-} +takeWhile1 :: Monad m => b -> (a -> Bool) -> Refold m b a b -> Parser a m b +-- We can implement this using satisfy and takeWhile. We can use "satisfy +-- p", fold the result with the refold and then use the "takeWhile p" and +-- fold that using the refold. +takeWhile1 acc cond f = undefined +-} + +-- | Like 'takeWhile' but takes at least one element otherwise fails. +-- +-- >>> takeWhile1 cond p = Parser.takeWhileP cond (Parser.takeBetween 1 maxBound p) +-- +{-# INLINE takeWhile1 #-} +takeWhile1 :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b +-- takeWhile1 cond f = takeWhileP cond (takeBetween 1 maxBound f) +takeWhile1 predicate (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + initial = do + res <- finitial + return $ case res of + FL.Partial s -> IPartial (Left' s) + FL.Done _ -> + IError + $ "takeWhile1: fold terminated without consuming:" + ++ " any element" + + {-# INLINE process #-} + process s a = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SPartial 1 (Right' s1) + FL.Done b -> SDone 1 b + + step (Left' s) a = + if predicate a + then process s a + else return $ SError "takeWhile1: predicate failed on first element" + step (Right' s) a = + if predicate a + then process s a + else do + b <- ffinal s + return $ SDone 0 b + + extract (Left' _) = return $ FError "takeWhile1: end of input" + extract (Right' s) = fmap (FDone 0) (ffinal s) + +-- | Drain the input as long as the predicate succeeds, running the effects and +-- discarding the results. +-- +-- This is also called @skipWhile@ in some parsing libraries. +-- +-- >>> dropWhile p = Parser.takeWhile p Fold.drain +-- +{-# INLINE dropWhile #-} +dropWhile :: Monad m => (a -> Bool) -> Parser a m () +dropWhile p = takeWhile p FL.drain + +------------------------------------------------------------------------------- +-- Separators +------------------------------------------------------------------------------- + +{-# ANN type FramedEscState Fuse #-} +data FramedEscState s = + FrameEscInit !s | FrameEscGo !s !Int | FrameEscEsc !s !Int + +-- XXX We can remove Maybe from esc +{-# INLINE takeFramedByGeneric #-} +takeFramedByGeneric :: Monad m => + Maybe (a -> Bool) -- is escape char? + -> Maybe (a -> Bool) -- is frame begin? + -> Maybe (a -> Bool) -- is frame end? + -> Fold m a b + -> Parser a m b +takeFramedByGeneric esc begin end (Fold fstep finitial _ ffinal) = + + Parser step initial extract + + where + + initial = do + res <- finitial + return $ + case res of + FL.Partial s -> IPartial (FrameEscInit s) + FL.Done _ -> + error "takeFramedByGeneric: fold done without input" + + {-# INLINE process #-} + process s a n = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SContinue 1 (FrameEscGo s1 n) + FL.Done b -> SDone 1 b + + {-# INLINE processNoEsc #-} + processNoEsc s a n = + case end of + Just isEnd -> + case begin of + Just isBegin -> + -- takeFramedBy case + if isEnd a + then + if n == 0 + then SDone 1 <$> ffinal s + else process s a (n - 1) + else + let n1 = if isBegin a then n + 1 else n + in process s a n1 + Nothing -> -- takeEndBy case + if isEnd a + then SDone 1 <$> ffinal s + else process s a n + Nothing -> -- takeBeginBy case + case begin of + Just isBegin -> + if isBegin a + then SDone 1 <$> ffinal s + else process s a n + Nothing -> + error $ "takeFramedByGeneric: " + ++ "Both begin and end frame predicate missing" + + {-# INLINE processCheckEsc #-} + processCheckEsc s a n = + case esc of + Just isEsc -> + if isEsc a + then return $ SPartial 1 $ FrameEscEsc s n + else processNoEsc s a n + Nothing -> processNoEsc s a n + + step (FrameEscInit s) a = + case begin of + Just isBegin -> + if isBegin a + then return $ SPartial 1 (FrameEscGo s 0) + else return $ SError "takeFramedByGeneric: missing frame start" + Nothing -> + case end of + Just isEnd -> + if isEnd a + then SDone 1 <$> ffinal s + else processCheckEsc s a 0 + Nothing -> + error "Both begin and end frame predicate missing" + step (FrameEscGo s n) a = processCheckEsc s a n + step (FrameEscEsc s n) a = process s a n + + err = return . FError + + extract (FrameEscInit _) = + err "takeFramedByGeneric: empty token" + extract (FrameEscGo s _) = + case begin of + Just _ -> + case end of + Nothing -> fmap (FDone 0) $ ffinal s + Just _ -> err "takeFramedByGeneric: missing frame end" + Nothing -> err "takeFramedByGeneric: missing closing frame" + extract (FrameEscEsc _ _) = err "takeFramedByGeneric: trailing escape" + +data BlockParseState s = + BlockInit !s + | BlockUnquoted !Int !s + | BlockQuoted !Int !s + | BlockQuotedEsc !Int !s + +-- Blocks can be of different types e.g. {} or (). We only parse from the +-- perspective of the outermost block type. The nesting of that block are +-- checked. Any other block types nested inside it are opaque to us and can be +-- parsed when the contents of the block are parsed. + +-- XXX Put a limit on nest level to keep the API safe. + +-- | Parse a block enclosed within open, close brackets. Block contents may be +-- quoted, brackets inside quotes are ignored. Quoting characters can be used +-- within quotes if escaped. A block can have a nested block inside it. +-- +-- Quote begin and end chars are the same. Block brackets and quote chars must +-- not overlap. Block start and end brackets must be different for nesting +-- blocks within blocks. +-- +-- >>> p = Parser.blockWithQuotes (== '\\') (== '"') '{' '}' Fold.toList +-- >>> Stream.parse p $ Stream.fromList "{msg: \"hello world\"}" +-- Right "msg: \"hello world\"" +-- +{-# INLINE blockWithQuotes #-} +blockWithQuotes :: (Monad m, Eq a) => + (a -> Bool) -- ^ escape char + -> (a -> Bool) -- ^ quote char, to quote inside brackets + -> a -- ^ Block opening bracket + -> a -- ^ Block closing bracket + -> Fold m a b + -> Parser a m b +blockWithQuotes isEsc isQuote bopen bclose + (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + initial = do + res <- finitial + return $ + case res of + FL.Partial s -> IPartial (BlockInit s) + FL.Done _ -> + error "blockWithQuotes: fold finished without input" + + {-# INLINE process #-} + process s a nextState = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SContinue 1 (nextState s1) + FL.Done b -> SDone 1 b + + step (BlockInit s) a = + return + $ if a == bopen + then SContinue 1 $ BlockUnquoted 1 s + else SError "blockWithQuotes: missing block start" + step (BlockUnquoted level s) a + | a == bopen = process s a (BlockUnquoted (level + 1)) + | a == bclose = + if level == 1 + then fmap (SDone 1) (ffinal s) + else process s a (BlockUnquoted (level - 1)) + | isQuote a = process s a (BlockQuoted level) + | otherwise = process s a (BlockUnquoted level) + step (BlockQuoted level s) a + | isEsc a = process s a (BlockQuotedEsc level) + | otherwise = + if isQuote a + then process s a (BlockUnquoted level) + else process s a (BlockQuoted level) + step (BlockQuotedEsc level s) a = process s a (BlockQuoted level) + + err = return . FError + + extract (BlockInit s) = fmap (FDone 0) $ ffinal s + extract (BlockUnquoted level _) = + err $ "blockWithQuotes: finished at block nest level " ++ show level + extract (BlockQuoted level _) = + err $ "blockWithQuotes: finished, inside an unfinished quote, " + ++ "at block nest level " ++ show level + extract (BlockQuotedEsc level _) = + err $ "blockWithQuotes: finished, inside an unfinished quote, " + ++ "after an escape char, at block nest level " ++ show level + +{-# INLINE takeEndByDone #-} +takeEndByDone :: Monad f => (s -> f (Final s b)) -> Step s b -> f (Step s b) +takeEndByDone pextract res = + -- If the parser is backtracking we let it backtrack even if the + -- predicate is true. + case res of + SPartial 1 s1 -> do + res1 <- pextract s1 + pure $ case res1 of + FDone n b -> SDone (1 + n) b + FContinue n s -> SPartial (1 + n) s + FError err -> SError err + SContinue 1 s1 -> do + res1 <- pextract s1 + pure $ case res1 of + FDone n b -> SDone (1 + n) b + FContinue n s -> SContinue (1 + n) s + FError err -> SError err + SPartial _ _ -> return res + SContinue _ _ -> return res + SDone n b -> return $ SDone n b + SError n -> return $ SError n + +-- | @takeEndBy cond parser@ parses a token that ends by a separator chosen by +-- the supplied predicate. The separator is also taken with the token. +-- +-- This can be combined with other parsers to implement other interesting +-- parsers as follows: +-- +-- >>> takeEndByLE cond n p = Parser.takeEndBy cond (Parser.fromFold $ Fold.take n p) +-- >>> takeEndByBetween cond m n p = Parser.takeEndBy cond (Parser.takeBetween m n p) +-- +-- >>> takeEndBy = Parser.takeEndByEsc (const False) +-- +-- See also "Streamly.Data.Fold.takeEndBy". Unlike the fold, the collecting +-- parser in the takeEndBy parser can decide whether to fail or not if the +-- stream does not end with separator. +-- +-- /Pre-release/ +-- +{-# INLINE takeEndBy #-} +takeEndBy :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b +-- takeEndBy = takeEndByEsc (const False) +takeEndBy cond (Parser pstep pinitial pextract) = + + Parser step initial pextract + + where + + initial = pinitial + + step s a = do + res <- pstep s a + if not (cond a) + then return res + else takeEndByDone pextract res + +-- | Like 'takeEndBy' but the separator elements can be escaped using an +-- escape char determined by the first predicate. The escape characters are +-- removed. +-- +-- /pre-release/ +{-# INLINE takeEndByEsc #-} +takeEndByEsc :: Monad m => + (a -> Bool) -> (a -> Bool) -> Parser a m b -> Parser a m b +takeEndByEsc isEsc isSep (Parser pstep pinitial pextract) = + + Parser step initial extract + + where + + initial = first Left' <$> pinitial + + step (Left' s) a = do + if isEsc a + then return $ SPartial 1 $ Right' s + else do + res <- pstep s a + if not (isSep a) + then return $ first Left' res + else fmap (first Left') $ takeEndByDone pextract res + + step (Right' s) a = do + res <- pstep s a + return $ first Left' res + + extract (Left' s) = fmap (first Left') $ pextract s + extract (Right' _) = + return $ FError "takeEndByEsc: trailing escape" + +-- | Like 'takeEndBy' but the separator is dropped. +-- +-- See also "Streamly.Data.Fold.takeEndBy_". +-- +-- /Pre-release/ +-- +{-# INLINE takeEndBy_ #-} +takeEndBy_ :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b +{- +takeEndBy_ isEnd p = + takeFramedByGeneric Nothing Nothing (Just isEnd) (toFold p) +-} +takeEndBy_ cond (Parser pstep pinitial pextract) = + + Parser step pinitial pextract + + where + + step s a = + if cond a + then do + res <- pextract s + pure $ case res of + FDone n b -> SDone (n + 1) b + FContinue n s1 -> SPartial (n + 1) s1 + FError err -> SError err + else pstep s a + +-- | Take either the separator or the token. Separator is a Left value and +-- token is Right value. +-- +-- /Unimplemented/ +{-# INLINE takeEitherSepBy #-} +takeEitherSepBy :: -- Monad m => + (a -> Bool) -> Fold m (Either a b) c -> Parser a m c +takeEitherSepBy _cond = undefined -- D.toParserK . D.takeEitherSepBy cond + +-- | Parse a token that starts with an element chosen by the predicate. The +-- parser fails if the input does not start with the selected element. +-- +-- * Stops - when the predicate succeeds in non-leading position. +-- * Fails - when the predicate fails in the leading position. +-- +-- >>> splitWithPrefix p f = Stream.parseMany (Parser.takeBeginBy p f) +-- +-- Examples: - +-- +-- >>> p = Parser.takeBeginBy (== ',') Fold.toList +-- >>> leadingComma = Stream.parsePos p . Stream.fromList +-- >>> leadingComma "a,b" +-- Left (ParseErrorPos 1 "takeBeginBy: missing frame start") +-- ... +-- >>> leadingComma ",," +-- Right "," +-- >>> leadingComma ",a,b" +-- Right ",a" +-- >>> leadingComma "" +-- Right "" +-- +-- /Pre-release/ +-- +{-# INLINE takeBeginBy #-} +takeBeginBy, takeStartBy :: Monad m => + (a -> Bool) -> Fold m a b -> Parser a m b +takeBeginBy cond (Fold fstep finitial _ ffinal) = + + Parser step initial extract + + where + + initial = do + res <- finitial + return $ + case res of + FL.Partial s -> IPartial (Left' s) + FL.Done _ -> IError "takeBeginBy: fold done without input" + + {-# INLINE process #-} + process s a = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SPartial 1 (Right' s1) + FL.Done b -> SDone 1 b + + step (Left' s) a = + if cond a + then process s a + else return $ SError "takeBeginBy: missing frame start" + step (Right' s) a = + if not (cond a) + then process s a + else SDone 0 <$> ffinal s + + extract (Left' s) = fmap (FDone 0) $ ffinal s + extract (Right' s) = fmap (FDone 0) $ ffinal s + +RENAME(takeStartBy,takeBeginBy) + +-- | Like 'takeBeginBy' but drops the separator. +-- +-- >>> takeBeginBy_ isBegin = Parser.takeFramedByGeneric Nothing (Just isBegin) Nothing +-- +{-# INLINE takeBeginBy_ #-} +takeBeginBy_, takeStartBy_ :: Monad m => + (a -> Bool) -> Fold m a b -> Parser a m b +takeBeginBy_ isBegin = takeFramedByGeneric Nothing (Just isBegin) Nothing + +RENAME(takeStartBy_,takeBeginBy_) + +-- | @takeFramedByEsc_ isEsc isBegin isEnd fold@ parses a token framed using a +-- begin and end predicate, and an escape character. The frame begin and end +-- characters lose their special meaning if preceded by the escape character. +-- +-- Nested frames are allowed if begin and end markers are different, nested +-- frames must be balanced unless escaped, nested frame markers are emitted as +-- it is. +-- +-- For example, +-- +-- >>> p = Parser.takeFramedByEsc_ (== '\\') (== '{') (== '}') Fold.toList +-- >>> Stream.parse p $ Stream.fromList "{hello}" +-- Right "hello" +-- >>> Stream.parse p $ Stream.fromList "{hello {world}}" +-- Right "hello {world}" +-- >>> Stream.parse p $ Stream.fromList "{hello \\{world}" +-- Right "hello {world" +-- >>> Stream.parsePos p $ Stream.fromList "{hello {world}" +-- Left (ParseErrorPos 14 "takeFramedByEsc_: missing frame end") +-- +-- /Pre-release/ +{-# INLINE takeFramedByEsc_ #-} +takeFramedByEsc_ :: Monad m => + (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser a m b +-- takeFramedByEsc_ isEsc isEnd p = +-- takeFramedByGeneric (Just isEsc) Nothing (Just isEnd) (toFold p) +takeFramedByEsc_ isEsc isBegin isEnd (Fold fstep finitial _ ffinal ) = + + Parser step initial extract + + where + + initial = do + res <- finitial + return $ + case res of + FL.Partial s -> IPartial (FrameEscInit s) + FL.Done _ -> + error "takeFramedByEsc_: fold done without input" + + {-# INLINE process #-} + process s a n = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SContinue 1 (FrameEscGo s1 n) + FL.Done b -> SDone 1 b + + step (FrameEscInit s) a = + if isBegin a + then return $ SPartial 1 (FrameEscGo s 0) + else return $ SError "takeFramedByEsc_: missing frame start" + step (FrameEscGo s n) a = + if isEsc a + then return $ SPartial 1 $ FrameEscEsc s n + else do + if not (isEnd a) + then + let n1 = if isBegin a then n + 1 else n + in process s a n1 + else + if n == 0 + then SDone 1 <$> ffinal s + else process s a (n - 1) + step (FrameEscEsc s n) a = process s a n + + err = return . FError + + extract (FrameEscInit _) = err "takeFramedByEsc_: empty token" + extract (FrameEscGo _ _) = err "takeFramedByEsc_: missing frame end" + extract (FrameEscEsc _ _) = err "takeFramedByEsc_: trailing escape" + +data FramedState s = FrameInit !s | FrameGo !s Int + +-- | @takeFramedBy_ isBegin isEnd fold@ parses a token framed by a begin and an +-- end predicate. +-- +-- >>> takeFramedBy_ = Parser.takeFramedByEsc_ (const False) +-- +{-# INLINE takeFramedBy_ #-} +takeFramedBy_ :: Monad m => + (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser a m b +-- takeFramedBy_ isBegin isEnd = +-- takeFramedByGeneric (Just (const False)) (Just isBegin) (Just isEnd) +takeFramedBy_ isBegin isEnd (Fold fstep finitial _ ffinal) = + + Parser step initial extract + + where + + initial = do + res <- finitial + return $ + case res of + FL.Partial s -> IPartial (FrameInit s) + FL.Done _ -> + error "takeFramedBy_: fold done without input" + + {-# INLINE process #-} + process s a n = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SContinue 1 (FrameGo s1 n) + FL.Done b -> SDone 1 b + + step (FrameInit s) a = + if isBegin a + then return $ SContinue 1 (FrameGo s 0) + else return $ SError "takeFramedBy_: missing frame start" + step (FrameGo s n) a + | not (isEnd a) = + let n1 = if isBegin a then n + 1 else n + in process s a n1 + | n == 0 = SDone 1 <$> ffinal s + | otherwise = process s a (n - 1) + + err = return . FError + + extract (FrameInit _) = err "takeFramedBy_: empty token" + extract (FrameGo _ _) = err "takeFramedBy_: missing frame end" + +------------------------------------------------------------------------------- +-- Grouping and words +------------------------------------------------------------------------------- + +data WordByState s b = WBLeft !s | WBWord !s | WBRight !b + +-- Note we can also get words using something like: +-- sepBy FL.toList (takeWhile (not . p) Fold.toList) (dropWhile p) +-- +-- But that won't be as efficient and ergonomic. + +-- | Like 'splitOn' but strips leading, trailing, and repeated separators. +-- Therefore, @".a..b."@ having '.' as the separator would be parsed as +-- @["a","b"]@. In other words, its like parsing words from whitespace +-- separated text. +-- +-- * Stops - when it finds a word separator after a non-word element +-- * Fails - never. +-- +-- >>> wordBy = Parser.wordFramedBy (const False) (const False) (const False) +-- +-- @ +-- S.wordsBy pred f = S.parseMany (PR.wordBy pred f) +-- @ +-- +{-# INLINE wordBy #-} +wordBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b +wordBy predicate (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + {-# INLINE worder #-} + worder s a = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SPartial 1 $ WBWord s1 + FL.Done b -> SDone 1 b + + initial = do + res <- finitial + return + $ case res of + FL.Partial s -> IPartial $ WBLeft s + FL.Done b -> IDone b + + step (WBLeft s) a = + if not (predicate a) + then worder s a + else return $ SPartial 1 $ WBLeft s + step (WBWord s) a = + if not (predicate a) + then worder s a + else do + b <- ffinal s + return $ SPartial 1 $ WBRight b + step (WBRight b) a = + return + $ if not (predicate a) + then SDone 0 b + else SPartial 1 $ WBRight b + + extract (WBLeft s) = fmap (FDone 0) $ ffinal s + extract (WBWord s) = fmap (FDone 0) $ ffinal s + extract (WBRight b) = return (FDone 0 b) + +data WordFramedState s b = + WordFramedSkipPre !s + | WordFramedWord !s !Int + | WordFramedEsc !s !Int + | WordFramedSkipPost !b + +-- | Like 'wordBy' but treats anything inside a pair of quotes as a single +-- word, the quotes can be escaped by an escape character. Recursive quotes +-- are possible if quote begin and end characters are different, quotes must be +-- balanced. Outermost quotes are stripped. +-- +-- >>> braces = Parser.wordFramedBy (== '\\') (== '{') (== '}') isSpace Fold.toList +-- >>> Stream.parse braces $ Stream.fromList "{ab} cd" +-- Right "ab" +-- >>> Stream.parse braces $ Stream.fromList "{ab}{cd}" +-- Right "abcd" +-- >>> Stream.parse braces $ Stream.fromList "a{b} cd" +-- Right "ab" +-- >>> Stream.parse braces $ Stream.fromList "a{{b}} cd" +-- Right "a{b}" +-- +-- >>> quotes = Parser.wordFramedBy (== '\\') (== '"') (== '"') isSpace Fold.toList +-- >>> Stream.parse quotes $ Stream.fromList "\"a\"\"b\"" +-- Right "ab" +-- +{-# INLINE wordFramedBy #-} +wordFramedBy :: Monad m => + (a -> Bool) -- ^ Matches escape elem? + -> (a -> Bool) -- ^ Matches left quote? + -> (a -> Bool) -- ^ matches right quote? + -> (a -> Bool) -- ^ matches word separator? + -> Fold m a b + -> Parser a m b +wordFramedBy isEsc isBegin isEnd isSep + (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + initial = do + res <- finitial + return $ + case res of + FL.Partial s -> IPartial (WordFramedSkipPre s) + FL.Done _ -> + error "wordFramedBy: fold done without input" + + {-# INLINE process #-} + process s a n = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SContinue 1 (WordFramedWord s1 n) + FL.Done b -> SDone 1 b + + step (WordFramedSkipPre s) a + | isEsc a = return $ SContinue 1 $ WordFramedEsc s 0 + | isSep a = return $ SPartial 1 $ WordFramedSkipPre s + | isBegin a = return $ SContinue 1 $ WordFramedWord s 1 + | isEnd a = + return $ SError "wordFramedBy: missing frame start" + | otherwise = process s a 0 + step (WordFramedWord s n) a + | isEsc a = return $ SContinue 1 $ WordFramedEsc s n + | n == 0 && isSep a = do + b <- ffinal s + return $ SPartial 1 $ WordFramedSkipPost b + | otherwise = do + -- We need to use different order for checking begin and end for + -- the n == 0 and n == 1 case so that when the begin and end + -- character is the same we treat the one after begin as end. + if n == 0 + then + -- Need to check isBegin first + if isBegin a + then return $ SContinue 1 $ WordFramedWord s 1 + else if isEnd a + then return $ SError "wordFramedBy: missing frame start" + else process s a n + else + -- Need to check isEnd first + if isEnd a + then + if n == 1 + then return $ SContinue 1 $ WordFramedWord s 0 + else process s a (n - 1) + else if isBegin a + then process s a (n + 1) + else process s a n + step (WordFramedEsc s n) a = process s a n + step (WordFramedSkipPost b) a = + return + $ if not (isSep a) + then SDone 0 b + else SPartial 1 $ WordFramedSkipPost b + + err = return . FError + + extract (WordFramedSkipPre s) = fmap (FDone 0) $ ffinal s + extract (WordFramedWord s n) = + if n == 0 + then fmap (FDone 0) $ ffinal s + else err "wordFramedBy: missing frame end" + extract (WordFramedEsc _ _) = + err "wordFramedBy: trailing escape" + extract (WordFramedSkipPost b) = return (FDone 0 b) + +data WordQuotedState s b a = + WordQuotedSkipPre !s + | WordUnquotedWord !s + | WordQuotedWord !s !Int !a !a + | WordUnquotedEsc !s + | WordQuotedEsc !s !Int !a !a + | WordQuotedSkipPost !b + +-- | Quote and bracket aware word splitting with escaping. Like 'wordBy' but +-- word separators within specified quotes or brackets are ignored. Quotes and +-- escape characters can be processed. If the end quote is different from the +-- start quote it is called a bracket. The following quoting rules apply: +-- +-- * In an unquoted string a character may be preceded by an escape character. +-- The escape character is removed and the character following it is treated +-- literally with no special meaning e.g. e.g. h\ e\ l\ l\ o is a single word, +-- \n is same as n. +-- * Any part of the word can be placed within quotes. Inside quotes all +-- characters are treated literally with no special meaning. Quoting character +-- itself cannot be used within quotes unless escape processing within quotes +-- is applied to allow it. +-- * Optionally escape processing for quoted part can be specified. Escape +-- character has no special meaning inside quotes unless it is followed by a +-- character that has a escape translation specified, in that case the escape +-- character is removed, and the specified translation is applied to the +-- character following it. This can be used to escape the quoting character +-- itself within quotes. +-- * There can be multiple quoting characters, when a quote starts, all other +-- quoting characters within that quote lose any special meaning until the +-- quote is closed. +-- * A starting quote char without an ending char generates a parse error. An +-- ending bracket char without a corresponding bracket begin is ignored. +-- * Brackets can be nested. +-- +-- We should note that unquoted and quoted escape processing are different. In +-- unquoted part escape character is always removed. In quoted part it is +-- removed only if followed by a special meaning character. This is consistent +-- with how shell performs escape processing. + +-- Examples of quotes - "double quotes", 'single quotes', (parens), {braces}, +-- ((nested) brackets). +-- +-- Example: +-- +-- >>> :{ +-- >>> q x = +-- >>> case x of +-- >>> '"' -> Just x +-- >>> '\'' -> Just x +-- >>> _ -> Nothing +-- >>> :} +-- +-- >>> p = Parser.wordKeepQuotes (== '\\') q isSpace Fold.toList +-- >>> Stream.parse p $ Stream.fromList "a\"b'c\";'d\"e'f ghi" +-- Right "a\"b'c\";'d\"e'f" +-- +-- Note that outer quotes and backslashes from the input string are consumed by +-- Haskell, therefore, the actual input string passed to the parser is: +-- a"b'c";'d"e'f ghi +-- +-- Similarly, when printing, double quotes are escaped by Haskell. +-- +-- Limitations: +-- +-- Shell like quote processing can be performed by using quote char specific +-- escape processing, single quotes with no escapes, and double quotes with +-- escapes. +-- +-- JSON string processing can also be achieved except the "\uXXXX" style +-- escaping for Unicode characters. +-- +{-# INLINE wordWithQuotes #-} +wordWithQuotes :: (Monad m, Eq a) => + Bool -- ^ Retain the quotes and escape chars in the output + -> (a -> a -> Maybe a) -- ^ quote char -> escaped char -> translated char + -> a -- ^ Matches an escape elem? + -> (a -> Maybe a) -- ^ If left quote, return right quote, else Nothing. + -> (a -> Bool) -- ^ Matches a word separator? + -> Fold m a b + -> Parser a m b +wordWithQuotes keepQuotes tr escChar toRight isSep + (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + -- Can be used to generate parse error for a bracket end without a bracket + -- begin. + isInvalid = const False + + isEsc = (== escChar) + + initial = do + res <- finitial + return $ + case res of + FL.Partial s -> IPartial (WordQuotedSkipPre s) + FL.Done _ -> + error "wordKeepQuotes: fold done without input" + + {-# INLINE processQuoted #-} + processQuoted s a n ql qr = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SContinue 1 (WordQuotedWord s1 n ql qr) + FL.Done b -> SDone 1 b + + {-# INLINE processUnquoted #-} + processUnquoted s a = do + res <- fstep s a + return + $ case res of + FL.Partial s1 -> SContinue 1 (WordUnquotedWord s1) + FL.Done b -> SDone 1 b + + {-# INLINE checkRightQuoteAndProcess #-} + checkRightQuoteAndProcess s a n ql qr + | a == qr = + if n == 1 + then if keepQuotes + then processUnquoted s a + else return $ SContinue 1 $ WordUnquotedWord s + else processQuoted s a (n - 1) ql qr + | a == ql = processQuoted s a (n + 1) ql qr + | otherwise = processQuoted s a n ql qr + + step (WordQuotedSkipPre s) a + | isEsc a = return $ SContinue 1 $ WordUnquotedEsc s + | isSep a = return $ SPartial 1 $ WordQuotedSkipPre s + | otherwise = + case toRight a of + Just qr -> + if keepQuotes + then processQuoted s a 1 a qr + else return $ SContinue 1 $ WordQuotedWord s 1 a qr + Nothing + | isInvalid a -> + return $ SError "wordKeepQuotes: invalid unquoted char" + | otherwise -> processUnquoted s a + step (WordUnquotedWord s) a + | isEsc a = return $ SContinue 1 $ WordUnquotedEsc s + | isSep a = do + b <- ffinal s + return $ SPartial 1 $ WordQuotedSkipPost b + | otherwise = do + case toRight a of + Just qr -> + if keepQuotes + then processQuoted s a 1 a qr + else return $ SContinue 1 $ WordQuotedWord s 1 a qr + Nothing -> + if isInvalid a + then return $ SError "wordKeepQuotes: invalid unquoted char" + else processUnquoted s a + step (WordQuotedWord s n ql qr) a + | isEsc a = return $ SContinue 1 $ WordQuotedEsc s n ql qr + {- + -- XXX Will this ever occur? Will n ever be 0? + | n == 0 && isSep a = do + b <- fextract s + return $ SPartial 1 $ WordQuotedSkipPost b + -} + | otherwise = checkRightQuoteAndProcess s a n ql qr + step (WordUnquotedEsc s) a = processUnquoted s a + step (WordQuotedEsc s n ql qr) a = + case tr ql a of + Nothing -> do + res <- fstep s escChar + case res of + FL.Partial s1 -> checkRightQuoteAndProcess s1 a n ql qr + FL.Done b -> return $ SDone 1 b + Just x -> processQuoted s x n ql qr + step (WordQuotedSkipPost b) a = + return + $ if not (isSep a) + then SDone 0 b + else SPartial 1 $ WordQuotedSkipPost b + + err = return . FError + + extract (WordQuotedSkipPre s) = fmap (FDone 0) $ ffinal s + extract (WordUnquotedWord s) = fmap (FDone 0) $ ffinal s + extract (WordQuotedWord s n _ _) = + if n == 0 + then fmap (FDone 0) $ ffinal s + else err "wordWithQuotes: missing frame end" + extract WordQuotedEsc {} = + err "wordWithQuotes: trailing escape" + extract (WordUnquotedEsc _) = + err "wordWithQuotes: trailing escape" + extract (WordQuotedSkipPost b) = return (FDone 0 b) + +-- | 'wordWithQuotes' without processing the quotes and escape function +-- supplied to escape the quote char within a quote. Can be used to parse words +-- keeping the quotes and escapes intact. +-- +-- >>> wordKeepQuotes = Parser.wordWithQuotes True (\_ _ -> Nothing) +-- +{-# INLINE wordKeepQuotes #-} +wordKeepQuotes :: (Monad m, Eq a) => + a -- ^ Escape char + -> (a -> Maybe a) -- ^ If left quote, return right quote, else Nothing. + -> (a -> Bool) -- ^ Matches a word separator? + -> Fold m a b + -> Parser a m b +wordKeepQuotes = + -- Escape the quote char itself + wordWithQuotes True (\q x -> if q == x then Just x else Nothing) + +-- See the "Quoting Rules" section in the "bash" manual page for a primer on +-- how quotes are used by shells. + +-- | 'wordWithQuotes' with quote processing applied and escape function +-- supplied to escape the quote char within a quote. Can be ysed to parse words +-- and processing the quoting and escaping at the same time. +-- +-- >>> wordProcessQuotes = Parser.wordWithQuotes False (\_ _ -> Nothing) +-- +{-# INLINE wordProcessQuotes #-} +wordProcessQuotes :: (Monad m, Eq a) => + a -- ^ Escape char + -> (a -> Maybe a) -- ^ If left quote, return right quote, else Nothing. + -> (a -> Bool) -- ^ Matches a word separator? + -> Fold m a b + -> Parser a m b +wordProcessQuotes = + -- Escape the quote char itself + wordWithQuotes False (\q x -> if q == x then Just x else Nothing) + +{-# ANN type GroupByState Fuse #-} +data GroupByState a s + = GroupByInit !s + | GroupByGrouping !a !s + +-- | Given an input stream @[a,b,c,...]@ and a comparison function @cmp@, the +-- parser assigns the element @a@ to the first group, then if @a \`cmp` b@ is +-- 'True' @b@ is also assigned to the same group. If @a \`cmp` c@ is 'True' +-- then @c@ is also assigned to the same group and so on. When the comparison +-- fails the parser is terminated. Each group is folded using the 'Fold' @f@ and +-- the result of the fold is the result of the parser. +-- +-- * Stops - when the comparison fails. +-- * Fails - never. +-- +-- >>> :{ +-- runGroupsBy eq = +-- Stream.fold Fold.toList +-- . Stream.parseMany (Parser.groupBy eq Fold.toList) +-- . Stream.fromList +-- :} +-- +-- >>> runGroupsBy (<) [] +-- [] +-- +-- >>> runGroupsBy (<) [1] +-- [Right [1]] +-- +-- >>> runGroupsBy (<) [3, 5, 4, 1, 2, 0] +-- [Right [3,5,4],Right [1,2],Right [0]] +-- +{-# INLINE groupBy #-} +groupBy :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser a m b +groupBy eq (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + {-# INLINE grouper #-} + grouper s a0 a = do + res <- fstep s a + return + $ case res of + FL.Done b -> SDone 1 b + FL.Partial s1 -> SPartial 1 (GroupByGrouping a0 s1) + + initial = do + res <- finitial + return + $ case res of + FL.Partial s -> IPartial $ GroupByInit s + FL.Done b -> IDone b + + step (GroupByInit s) a = grouper s a a + step (GroupByGrouping a0 s) a = + if eq a0 a + then grouper s a0 a + else SDone 0 <$> ffinal s + + extract (GroupByInit s) = fmap (FDone 0) $ ffinal s + extract (GroupByGrouping _ s) = fmap (FDone 0) $ ffinal s + +-- | Unlike 'groupBy' this combinator performs a rolling comparison of two +-- successive elements in the input stream. Assuming the input stream +-- is @[a,b,c,...]@ and the comparison function is @cmp@, the parser +-- first assigns the element @a@ to the first group, then if @a \`cmp` b@ is +-- 'True' @b@ is also assigned to the same group. If @b \`cmp` c@ is 'True' +-- then @c@ is also assigned to the same group and so on. When the comparison +-- fails the parser is terminated. Each group is folded using the 'Fold' @f@ and +-- the result of the fold is the result of the parser. +-- +-- * Stops - when the comparison fails. +-- * Fails - never. +-- +-- >>> :{ +-- runGroupsByRolling eq = +-- Stream.fold Fold.toList +-- . Stream.parseMany (Parser.groupByRolling eq Fold.toList) +-- . Stream.fromList +-- :} +-- +-- >>> runGroupsByRolling (<) [] +-- [] +-- +-- >>> runGroupsByRolling (<) [1] +-- [Right [1]] +-- +-- >>> runGroupsByRolling (<) [3, 5, 4, 1, 2, 0] +-- [Right [3,5],Right [4],Right [1,2],Right [0]] +-- +-- /Pre-release/ +-- +{-# INLINE groupByRolling #-} +groupByRolling :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser a m b +groupByRolling eq (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + {-# INLINE grouper #-} + grouper s a = do + res <- fstep s a + return + $ case res of + FL.Done b -> SDone 1 b + FL.Partial s1 -> SPartial 1 (GroupByGrouping a s1) + + initial = do + res <- finitial + return + $ case res of + FL.Partial s -> IPartial $ GroupByInit s + FL.Done b -> IDone b + + step (GroupByInit s) a = grouper s a + step (GroupByGrouping a0 s) a = + if eq a0 a + then grouper s a + else SDone 0 <$> ffinal s + + extract (GroupByInit s) = fmap (FDone 0) $ ffinal s + extract (GroupByGrouping _ s) = fmap (FDone 0) $ ffinal s + +{-# ANN type GroupByStatePair Fuse #-} +data GroupByStatePair a s1 s2 + = GroupByInitPair !s1 !s2 + | GroupByGroupingPair !a !s1 !s2 + | GroupByGroupingPairL !a !s1 !s2 + | GroupByGroupingPairR !a !s1 !s2 + +-- | Like 'groupByRolling', but if the predicate is 'True' then collects using +-- the first fold as long as the predicate holds 'True', if the predicate is +-- 'False' collects using the second fold as long as it remains 'False'. +-- Returns 'Left' for the first case and 'Right' for the second case. +-- +-- For example, if we want to detect sorted sequences in a stream, both +-- ascending and descending cases we can use 'groupByRollingEither (<=) +-- Fold.toList Fold.toList'. +-- +-- /Pre-release/ +{-# INLINE groupByRollingEither #-} +groupByRollingEither :: Monad m => + (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (Either b c) +groupByRollingEither + eq + (Fold fstep1 finitial1 _ ffinal1) + (Fold fstep2 finitial2 _ ffinal2) = Parser step initial extract + + where + + {-# INLINE grouper #-} + grouper s1 s2 a = do + return $ SContinue 1 (GroupByGroupingPair a s1 s2) + + {-# INLINE grouperL2 #-} + grouperL2 s1 s2 a = do + res <- fstep1 s1 a + return + $ case res of + FL.Done b -> SDone 1 (Left b) + FL.Partial s11 -> SPartial 1 (GroupByGroupingPairL a s11 s2) + + {-# INLINE grouperL #-} + grouperL s1 s2 a0 a = do + res <- fstep1 s1 a0 + case res of + FL.Done b -> return $ SDone 1 (Left b) + FL.Partial s11 -> grouperL2 s11 s2 a + + {-# INLINE grouperR2 #-} + grouperR2 s1 s2 a = do + res <- fstep2 s2 a + return + $ case res of + FL.Done b -> SDone 1 (Right b) + FL.Partial s21 -> SPartial 1 (GroupByGroupingPairR a s1 s21) + + {-# INLINE grouperR #-} + grouperR s1 s2 a0 a = do + res <- fstep2 s2 a0 + case res of + FL.Done b -> return $ SDone 1 (Right b) + FL.Partial s21 -> grouperR2 s1 s21 a + + initial = do + res1 <- finitial1 + res2 <- finitial2 + return + $ case res1 of + FL.Partial s1 -> + case res2 of + FL.Partial s2 -> IPartial $ GroupByInitPair s1 s2 + FL.Done b -> IDone (Right b) + FL.Done b -> IDone (Left b) + + step (GroupByInitPair s1 s2) a = grouper s1 s2 a + + step (GroupByGroupingPair a0 s1 s2) a = + if not (eq a0 a) + then grouperL s1 s2 a0 a + else grouperR s1 s2 a0 a + + step (GroupByGroupingPairL a0 s1 s2) a = + if not (eq a0 a) + then grouperL2 s1 s2 a + else SDone 0 . Left <$> ffinal1 s1 + + step (GroupByGroupingPairR a0 s1 s2) a = + if eq a0 a + then grouperR2 s1 s2 a + else SDone 0 . Right <$> ffinal2 s2 + + extract (GroupByInitPair s1 _) = FDone 0 . Left <$> ffinal1 s1 + extract (GroupByGroupingPairL _ s1 _) = FDone 0 . Left <$> ffinal1 s1 + extract (GroupByGroupingPairR _ _ s2) = FDone 0 . Right <$> ffinal2 s2 + extract (GroupByGroupingPair a s1 _) = do + res <- fstep1 s1 a + case res of + FL.Done b -> return $ FDone 0 (Left b) + FL.Partial s11 -> FDone 0 . Left <$> ffinal1 s11 + +-- XXX use an Unfold instead of a list? +-- XXX custom combinators for matching list, array and stream? +-- XXX rename to listBy? + +-- | Match the given sequence of elements using the given comparison function. +-- Returns the original sequence if successful. +-- +-- Definition: +-- +-- >>> listEqBy cmp xs = Parser.streamEqBy cmp (Stream.fromList xs) *> Parser.fromPure xs +-- +-- Examples: +-- +-- >>> Stream.parse (Parser.listEqBy (==) "string") $ Stream.fromList "string" +-- Right "string" +-- +-- >>> Stream.parsePos (Parser.listEqBy (==) "mismatch") $ Stream.fromList "match" +-- Left (ParseErrorPos 2 "streamEqBy: mismtach occurred") +-- +{-# INLINE listEqBy #-} +listEqBy :: Monad m => (a -> a -> Bool) -> [a] -> Parser a m [a] +listEqBy cmp xs = streamEqByInternal cmp (D.fromList xs) *> fromPure xs +{- +listEqBy cmp str = Parser step initial extract + + where + + -- XXX Should return IDone in initial for [] case + initial = return $ IPartial str + + step [] _ = return $ SDone 1 str + step [x] a = + return + $ if x `cmp` a + then SDone 1 str + else SError "listEqBy: failed, yet to match the last element" + step (x:xs) a = + return + $ if x `cmp` a + then SContinue 1 xs + else SError + $ "listEqBy: failed, yet to match " + ++ show (length xs + 1) ++ " elements" + + extract xs = + return + $ SError + $ "listEqBy: end of input, yet to match " + ++ show (length xs) ++ " elements" +-} + +{-# INLINE streamEqByInternal #-} +streamEqByInternal :: Monad m => (a -> a -> Bool) -> D.Stream m a -> Parser a m () +streamEqByInternal cmp (D.Stream sstep state) = Parser step initial extract + + where + + initial = do + r <- sstep defState state + case r of + D.Yield x s -> return $ IPartial (Just' x, s) + D.Stop -> return $ IDone () + -- Need Skip/Continue in initial to loop right here + D.Skip s -> return $ IPartial (Nothing', s) + + step (Just' x, st) a = + if x `cmp` a + then do + r <- sstep defState st + return + $ case r of + D.Yield x1 s -> SContinue 1 (Just' x1, s) + D.Stop -> SDone 1 () + D.Skip s -> SContinue 0 (Nothing', s) + else return $ SError "streamEqBy: mismtach occurred" + step (Nothing', st) a = do + r <- sstep defState st + return + $ case r of + D.Yield x s -> do + if x `cmp` a + then SContinue 1 (Nothing', s) + else SError "streamEqBy: mismatch occurred" + D.Stop -> SDone 0 () + D.Skip s -> SContinue 0 (Nothing', s) + + extract _ = return $ FError "streamEqBy: end of input" + +-- | Like 'listEqBy' but uses a stream instead of a list and does not return +-- the stream. +-- +{-# INLINE streamEqBy #-} +streamEqBy :: Monad m => (a -> a -> Bool) -> D.Stream m a -> Parser a m () +-- XXX Somehow composing this with "*>" is much faster on the microbenchmark. +-- Need to investigate why. +streamEqBy cmp stream = streamEqByInternal cmp stream *> fromPure () + +-- Rename to "list". +-- | Match the input sequence with the supplied list and return it if +-- successful. +-- +-- >>> listEq = Parser.listEqBy (==) +-- +{-# INLINE listEq #-} +listEq :: (Monad m, Eq a) => [a] -> Parser a m [a] +listEq = listEqBy (==) + +-- | Match if the input stream is a subsequence of the argument stream i.e. all +-- the elements of the input stream occur, in order, in the argument stream. +-- The elements do not have to occur consecutively. A sequence is considered a +-- subsequence of itself. +{-# INLINE subsequenceBy #-} +subsequenceBy :: -- Monad m => + (a -> a -> Bool) -> Stream m a -> Parser a m () +subsequenceBy = undefined + +{- +-- Should go in Data.Parser.Regex in streamly package so that it can depend on +-- regex backends. +{-# INLINE regexPosix #-} +regexPosix :: -- Monad m => + Regex -> Parser m a (Maybe (Array (MatchOffset, MatchLength))) +regexPosix = undefined + +{-# INLINE regexPCRE #-} +regexPCRE :: -- Monad m => + Regex -> Parser m a (Maybe (Array (MatchOffset, MatchLength))) +regexPCRE = undefined +-} + +------------------------------------------------------------------------------- +-- Transformations on input +------------------------------------------------------------------------------- + +-- Initial needs a "Continue" constructor to implement scans on parsers. As a +-- parser can always return a Continue in initial when we feed the fold's +-- initial result to it. We can work this around for postscan by introducing an +-- initial state and calling "initial" only on the first input. + +-- | Stateful scan on the input of a parser using a Fold. +-- +-- /Unimplemented/ +-- +{-# INLINE postscan #-} +postscan :: -- Monad m => + Fold m a b -> Parser b m c -> Parser a m c +postscan = undefined + +{-# INLINE zipWithM #-} +zipWithM :: Monad m => + (a -> b -> m c) -> D.Stream m a -> Fold m c x -> Parser b m x +zipWithM zf (D.Stream sstep state) (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + initial = do + fres <- finitial + case fres of + FL.Partial fs -> do + r <- sstep defState state + case r of + D.Yield x s -> return $ IPartial (Just' x, s, fs) + D.Stop -> do + x <- ffinal fs + return $ IDone x + -- Need Skip/Continue in initial to loop right here + D.Skip s -> return $ IPartial (Nothing', s, fs) + FL.Done x -> return $ IDone x + + step (Just' a, st, fs) b = do + c <- zf a b + fres <- fstep fs c + case fres of + FL.Partial fs1 -> do + r <- sstep defState st + case r of + D.Yield x1 s -> return $ SContinue 1 (Just' x1, s, fs1) + D.Stop -> do + x <- ffinal fs1 + return $ SDone 1 x + D.Skip s -> return $ SContinue 0 (Nothing', s, fs1) + FL.Done x -> return $ SDone 1 x + step (Nothing', st, fs) b = do + r <- sstep defState st + case r of + D.Yield a s -> do + c <- zf a b + fres <- fstep fs c + case fres of + FL.Partial fs1 -> + return $ SContinue 1 (Nothing', s, fs1) + FL.Done x -> return $ SDone 1 x + D.Stop -> do + x <- ffinal fs + return $ SDone 0 x + D.Skip s -> return $ SContinue 0 (Nothing', s, fs) + + extract _ = return $ FError "zipWithM: end of input" + +-- | Zip the input of a fold with a stream. +-- +-- /Pre-release/ +-- +{-# INLINE zip #-} +zip :: Monad m => D.Stream m a -> Fold m (a, b) x -> Parser b m x +zip = zipWithM (curry return) + +-- | Pair each element of a fold input with its index, starting from index 0. +-- +-- /Pre-release/ +{-# INLINE indexed #-} +indexed :: forall m a b. Monad m => Fold m (Int, a) b -> Parser a m b +indexed = zip (D.enumerateFromIntegral 0 :: D.Stream m Int) + +-- | @makeIndexFilter indexer filter predicate@ generates a fold filtering +-- function using a fold indexing function that attaches an index to each input +-- element and a filtering function that filters using @(index, element) -> +-- Bool) as predicate. +-- +-- For example: +-- +-- @ +-- filterWithIndex = makeIndexFilter indexed filter +-- filterWithAbsTime = makeIndexFilter timestamped filter +-- filterWithRelTime = makeIndexFilter timeIndexed filter +-- @ +-- +-- /Pre-release/ +{-# INLINE makeIndexFilter #-} +makeIndexFilter :: + (Fold m (s, a) b -> Parser a m b) + -> (((s, a) -> Bool) -> Fold m (s, a) b -> Fold m (s, a) b) + -> (((s, a) -> Bool) -> Fold m a b -> Parser a m b) +makeIndexFilter f comb g = f . comb g . FL.lmap snd + +-- | @sampleFromthen offset stride@ samples the element at @offset@ index and +-- then every element at strides of @stride@. +-- +-- /Pre-release/ +{-# INLINE sampleFromthen #-} +sampleFromthen :: Monad m => Int -> Int -> Fold m a b -> Parser a m b +sampleFromthen offset size = + makeIndexFilter indexed FL.filter (\(i, _) -> (i + offset) `mod` size == 0) + +-------------------------------------------------------------------------------- +--- Spanning +-------------------------------------------------------------------------------- + +-- | @span p f1 f2@ composes folds @f1@ and @f2@ such that @f1@ consumes the +-- input as long as the predicate @p@ is 'True'. @f2@ consumes the rest of the +-- input. +-- +-- @ +-- > let span_ p xs = Stream.parse (Parser.span p Fold.toList Fold.toList) $ Stream.fromList xs +-- +-- > span_ (< 1) [1,2,3] +-- ([],[1,2,3]) +-- +-- > span_ (< 2) [1,2,3] +-- ([1],[2,3]) +-- +-- > span_ (< 4) [1,2,3] +-- ([1,2,3],[]) +-- +-- @ +-- +-- /Pre-release/ +{-# INLINE span #-} +span :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (b, c) +span p f1 f2 = noErrorUnsafeSplitWith (,) (takeWhile p f1) (fromFold f2) + +-- | Break the input stream into two groups, the first group takes the input as +-- long as the predicate applied to the first element of the stream and next +-- input element holds 'True', the second group takes the rest of the input. +-- +-- /Pre-release/ +-- +{-# INLINE spanBy #-} +spanBy :: + Monad m + => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (b, c) +spanBy eq f1 f2 = noErrorUnsafeSplitWith (,) (groupBy eq f1) (fromFold f2) + +-- | Like 'spanBy' but applies the predicate in a rolling fashion i.e. +-- predicate is applied to the previous and the next input elements. +-- +-- /Pre-release/ +{-# INLINE spanByRolling #-} +spanByRolling :: + Monad m + => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (b, c) +spanByRolling eq f1 f2 = + noErrorUnsafeSplitWith (,) (groupByRolling eq f1) (fromFold f2) + +------------------------------------------------------------------------------- +-- nested parsers +------------------------------------------------------------------------------- + +-- | Takes at-most @n@ input elements. +-- +-- * Stops - when the collecting parser stops. +-- * Fails - when the collecting parser fails. +-- +-- >>> Stream.parse (Parser.takeP 4 (Parser.takeEQ 2 Fold.toList)) $ Stream.fromList [1, 2, 3, 4, 5] +-- Right [1,2] +-- +-- >>> Stream.parsePos (Parser.takeP 4 (Parser.takeEQ 5 Fold.toList)) $ Stream.fromList [1, 2, 3, 4, 5] +-- Left (ParseErrorPos 4 "takeEQ: Expecting exactly 5 elements, input terminated on 4") +-- +-- /Internal/ +{-# INLINE takeP #-} +takeP :: Monad m => Int -> Parser a m b -> Parser a m b +takeP lim (Parser pstep pinitial pextract) = Parser step initial extract + + where + + initial = do + res <- pinitial + case res of + IPartial s -> + if lim > 0 + then return $ IPartial $ Tuple' 0 s + else iextract s + IDone b -> return $ IDone b + IError e -> return $ IError e + + step (Tuple' cnt r) a = do + assertM(cnt < lim) + res <- pstep r a + case res of + SPartial 1 s -> do + let cnt1 = cnt + 1 + assertM(cnt1 >= 0) + if cnt1 < lim + then return $ SPartial 1 $ Tuple' cnt1 s + else do + r1 <- pextract s + return $ case r1 of + FDone n b -> SDone (n + 1) b + FContinue n s1 -> SContinue (n + 1) (Tuple' (cnt1 + n) s1) + FError err -> SError err + + SContinue 1 s -> do + let cnt1 = cnt + 1 + assertM(cnt1 >= 0) + if cnt1 < lim + then return $ SContinue 1 $ Tuple' cnt1 s + else do + r1 <- pextract s + return $ case r1 of + FDone n b -> SDone (n + 1) b + FContinue n s1 -> SContinue (n + 1) (Tuple' (cnt1 + n) s1) + FError err -> SError err + SPartial n s -> do + let taken = cnt + n + assertM(taken >= 0) + return $ SPartial n $ Tuple' taken s + SContinue n s -> do + let taken = cnt + n + assertM(taken >= 0) + return $ SContinue n $ Tuple' taken s + SDone n b -> return $ SDone n b + SError str -> return $ SError str + + extract (Tuple' cnt r) = do + r1 <- pextract r + return $ case r1 of + FDone n b -> FDone n b + FContinue n s1 -> FContinue n (Tuple' (cnt + n) s1) + FError err -> FError err + + -- XXX Need to make the Initial type Step to remove this + iextract s = do + r <- pextract s + return $ case r of + FDone _ b -> IDone b + FError err -> IError err + _ -> error "Bug: takeP invalid state in initial" + +-- | Run a parser without consuming the input. +-- +{-# INLINE lookAhead #-} +lookAhead :: Monad m => Parser a m b -> Parser a m b +lookAhead (Parser step1 initial1 _) = Parser step initial extract + + where + + initial = do + res <- initial1 + return $ case res of + IPartial s -> IPartial (Tuple'Fused 0 s) + IDone b -> IDone b + IError e -> IError e + + step (Tuple'Fused cnt st) a = do + r <- step1 st a + return + $ case r of + SPartial n s -> SContinue n (Tuple'Fused (cnt + n) s) + SContinue n s -> SContinue n (Tuple'Fused (cnt + n) s) + SDone _ b -> SDone (- cnt) b + SError err -> SError err + + -- XXX returning an error let's us backtrack. To implement it in a way so + -- that it terminates on eof without an error then we need a way to + -- backtrack on eof, that will require extract to return 'Step' type. + extract (Tuple'Fused n _) = + return + $ FError + $ "lookAhead: end of input after consuming " + ++ show n ++ " elements" + +------------------------------------------------------------------------------- +-- Interleaving +------------------------------------------------------------------------------- +-- +-- To deinterleave we can chain two parsers one behind the other. The input is +-- given to the first parser and the input definitively rejected by the first +-- parser is given to the second parser. +-- +-- We can either have the parsers themselves buffer the input or use the shared +-- global buffer to hold it until none of the parsers need it. When the first +-- parser returns Skip (i.e. rewind) we let the second parser consume the +-- rejected input and when it is done we move the cursor forward to the first +-- parser again. This will require a "move forward" command as well. +-- +-- To implement grep we can use three parsers, one to find the pattern, one +-- to store the context behind the pattern and one to store the context in +-- front of the pattern. When a match occurs we need to emit the accumulator of +-- all the three parsers. One parser can count the line numbers to provide the +-- line number info. + +{-# ANN type DeintercalateAllState Fuse #-} +data DeintercalateAllState fs sp ss = + DeintercalateAllInitL !fs + | DeintercalateAllL !fs !sp + | DeintercalateAllInitR !fs + | DeintercalateAllR !fs !ss + +-- XXX rename this to intercalate + +-- Having deintercalateAll for accepting or rejecting entire input could be +-- useful. For example, in case of JSON parsing we get an entire block of +-- key-value pairs which we need to verify. This version may be simpler, more +-- efficient. We could implement this as a stream operation like parseMany. +-- +-- XXX Also, it may be a good idea to provide a parse driver for a fold. For +-- example, in case of csv parsing as we are feeding a line to a fold we can +-- parse it. + +-- | Like 'deintercalate' but the entire input must satisfy the pattern +-- otherwise the parser fails. This is many times faster than deintercalate. +-- +-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList +-- >>> p2 = Parser.satisfy (== '+') +-- >>> p = Parser.deintercalateAll p1 p2 Fold.toList +-- >>> Stream.parse p $ Stream.fromList "" +-- Right [] +-- >>> Stream.parse p $ Stream.fromList "1" +-- Right [Left "1"] +-- >>> Stream.parsePos p $ Stream.fromList "1+" +-- Left (ParseErrorPos 2 "takeWhile1: end of input") +-- >>> Stream.parse p $ Stream.fromList "1+2+3" +-- Right [Left "1",Right '+',Left "2",Right '+',Left "3"] +-- +-- See also 'Streamly.Internal.Data.ParserK.chainl1'. +-- +{-# INLINE deintercalateAll #-} +deintercalateAll :: Monad m => + Parser a m x + -> Parser a m y + -> Fold m (Either x y) z + -> Parser a m z +deintercalateAll + (Parser stepL initialL extractL) + (Parser stepR initialR _) + (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + errMsg p status = + error $ "deintercalate: " ++ p ++ " parser cannot " + ++ status ++ " without input" + + initial = do + res <- finitial + case res of + FL.Partial fs -> return $ IPartial $ DeintercalateAllInitL fs + FL.Done c -> return $ IDone c + + {-# INLINE processL #-} + processL foldAction n nextState = do + fres <- foldAction + case fres of + FL.Partial fs1 -> return $ SPartial n (nextState fs1) + FL.Done c -> return $ SDone n c + + {-# INLINE runStepL #-} + runStepL fs sL a = do + r <- stepL sL a + case r of + SPartial n s -> return $ SPartial n (DeintercalateAllL fs s) + SContinue n s -> return $ SContinue n (DeintercalateAllL fs s) + SDone n b -> + processL (fstep fs (Left b)) n DeintercalateAllInitR + SError err -> return $ SError err + + {-# INLINE processR #-} + processR foldAction n = do + fres <- foldAction + case fres of + FL.Partial fs1 -> do + res <- initialL + case res of + IPartial ps -> return $ SPartial n (DeintercalateAllL fs1 ps) + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + FL.Done c -> return $ SDone n c + + {-# INLINE runStepR #-} + runStepR fs sR a = do + r <- stepR sR a + case r of + SPartial n s -> return $ SPartial n (DeintercalateAllR fs s) + SContinue n s -> return $ SContinue n (DeintercalateAllR fs s) + SDone n b -> processR (fstep fs (Right b)) n + SError err -> return $ SError err + + step (DeintercalateAllInitL fs) a = do + res <- initialL + case res of + IPartial s -> runStepL fs s a + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + step (DeintercalateAllL fs sL) a = runStepL fs sL a + step (DeintercalateAllInitR fs) a = do + res <- initialR + case res of + IPartial s -> runStepR fs s a + IDone _ -> errMsg "right" "succeed" + IError _ -> errMsg "right" "fail" + step (DeintercalateAllR fs sR) a = runStepR fs sR a + + {-# INLINE extractResult #-} + extractResult n fs r = do + res <- fstep fs r + case res of + FL.Partial fs1 -> fmap (FDone n) $ ffinal fs1 + FL.Done c -> return (FDone n c) + extract (DeintercalateAllInitL fs) = fmap (FDone 0) $ ffinal fs + extract (DeintercalateAllL fs sL) = do + r <- extractL sL + case r of + FDone n b -> extractResult n fs (Left b) + FError err -> return $ FError err + FContinue n s -> return $ FContinue n (DeintercalateAllL fs s) + extract (DeintercalateAllInitR fs) = fmap (FDone 0) $ ffinal fs + extract (DeintercalateAllR _ _) = + return $ FError "deintercalateAll: input ended at 'Right' value" + +{-# ANN type DeintercalateState Fuse #-} +data DeintercalateState b fs sp ss = + DeintercalateInitL !fs + | DeintercalateL !Int !fs !sp + | DeintercalateInitR !fs + | DeintercalateR !Int !fs !ss + | DeintercalateRL !Int !b !fs !sp + +-- XXX Add tests that the next character that we take after running a parser is +-- correct. Especially for the parsers that maintain a count. In the stream +-- finished case (extract) as well as not finished case. + +-- | Apply two parsers alternately to an input stream. The input stream is +-- considered an interleaving of two patterns. The two parsers represent the +-- two patterns. Parsing starts at the first parser and stops at the first +-- parser. It can be used to parse a infix style pattern e.g. p1 p2 p1 . Empty +-- input or single parse of the first parser is accepted. +-- +-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList +-- >>> p2 = Parser.satisfy (== '+') +-- >>> p = Parser.deintercalate p1 p2 Fold.toList +-- >>> Stream.parse p $ Stream.fromList "" +-- Right [] +-- >>> Stream.parse p $ Stream.fromList "1" +-- Right [Left "1"] +-- >>> Stream.parse p $ Stream.fromList "1+" +-- Right [Left "1"] +-- >>> Stream.parse p $ Stream.fromList "1+2+3" +-- Right [Left "1",Right '+',Left "2",Right '+',Left "3"] +-- +-- See also 'Streamly.Internal.Data.ParserK.chainl1'. +-- +{-# INLINE deintercalate #-} +deintercalate :: Monad m => + Parser a m x + -> Parser a m y + -> Fold m (Either x y) z + -> Parser a m z +deintercalate + (Parser stepL initialL extractL) + (Parser stepR initialR _) + (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + errMsg p status = + error $ "deintercalate: " ++ p ++ " parser cannot " + ++ status ++ " without input" + + initial = do + res <- finitial + case res of + FL.Partial fs -> return $ IPartial $ DeintercalateInitL fs + FL.Done c -> return $ IDone c + + {-# INLINE processL #-} + processL foldAction n nextState = do + fres <- foldAction + case fres of + FL.Partial fs1 -> return $ SPartial n (nextState fs1) + FL.Done c -> return $ SDone n c + + {-# INLINE runStepL #-} + runStepL cnt fs sL a = do + r <- stepL sL a + case r of + -- XXX If we subtract instead of adding we do not need to negate + -- when returning cnt. + SPartial n s -> return $ SContinue n (DeintercalateL (cnt + n) fs s) + SContinue n s -> return $ SContinue n (DeintercalateL (cnt + n) fs s) + SDone n b -> + processL (fstep fs (Left b)) n DeintercalateInitR + SError _ -> do + xs <- ffinal fs + return $ SDone (-cnt) xs + + {-# INLINE processR #-} + processR cnt b fs n = do + res <- initialL + case res of + IPartial ps -> return $ SContinue n (DeintercalateRL cnt b fs ps) + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + + {-# INLINE runStepR #-} + runStepR cnt fs sR a = do + r <- stepR sR a + case r of + SPartial n s -> return $ SContinue n (DeintercalateR (cnt + n) fs s) + SContinue n s -> return $ SContinue n (DeintercalateR (cnt + n) fs s) + SDone n b -> processR (cnt + n) b fs n + SError _ -> do + xs <- ffinal fs + return $ SDone (- cnt) xs + + step (DeintercalateInitL fs) a = do + res <- initialL + case res of + IPartial s -> runStepL 0 fs s a + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + step (DeintercalateL cnt fs sL) a = runStepL cnt fs sL a + step (DeintercalateInitR fs) a = do + res <- initialR + case res of + IPartial s -> runStepR 0 fs s a + IDone _ -> errMsg "right" "succeed" + IError _ -> errMsg "right" "fail" + step (DeintercalateR cnt fs sR) a = runStepR cnt fs sR a + step (DeintercalateRL cnt bR fs sL) a = do + r <- stepL sL a + case r of + SPartial n s -> return $ SContinue n (DeintercalateRL (cnt + n) bR fs s) + SContinue n s -> return $ SContinue n (DeintercalateRL (cnt + n) bR fs s) + SDone n bL -> do + res <- fstep fs (Right bR) + case res of + FL.Partial fs1 -> do + fres <- fstep fs1 (Left bL) + case fres of + FL.Partial fs2 -> + return $ SPartial n (DeintercalateInitR fs2) + FL.Done c -> return $ SDone n c + -- XXX We could have the fold accept pairs of (bR, bL) + FL.Done _ -> error "Fold terminated consuming partial input" + SError _ -> do + xs <- ffinal fs + return $ SDone (- cnt) xs + + {-# INLINE extractResult #-} + extractResult n fs r = do + res <- fstep fs r + case res of + FL.Partial fs1 -> fmap (FDone n) $ ffinal fs1 + FL.Done c -> return (FDone n c) + + extract (DeintercalateInitL fs) = fmap (FDone 0) $ ffinal fs + extract (DeintercalateL cnt fs sL) = do + r <- extractL sL + case r of + FDone n b -> extractResult n fs (Left b) + FContinue n s -> return $ FContinue n (DeintercalateL (cnt + n) fs s) + FError _ -> do + xs <- ffinal fs + return $ FDone (- cnt) xs + extract (DeintercalateInitR fs) = fmap (FDone 0) $ ffinal fs + extract (DeintercalateR cnt fs _) = fmap (FDone (- cnt)) $ ffinal fs + extract (DeintercalateRL cnt bR fs sL) = do + r <- extractL sL + case r of + FDone n bL -> do + res <- fstep fs (Right bR) + case res of + FL.Partial fs1 -> extractResult n fs1 (Left bL) + FL.Done _ -> error "Fold terminated consuming partial input" + FContinue n s -> return $ FContinue n (DeintercalateRL (cnt + n) bR fs s) + FError _ -> do + xs <- ffinal fs + return $ FDone (- cnt) xs + +{-# ANN type Deintercalate1State Fuse #-} +data Deintercalate1State b fs sp ss = + Deintercalate1InitL !Int !fs !sp + | Deintercalate1InitR !fs + | Deintercalate1R !Int !fs !ss + | Deintercalate1RL !Int !b !fs !sp + +-- | Apply two parsers alternately to an input stream. The input stream is +-- considered an interleaving of two patterns. The two parsers represent the +-- two patterns. Parsing starts at the first parser and stops at the first +-- parser. It can be used to parse a infix style pattern e.g. p1 p2 p1 . Empty +-- input or single parse of the first parser is accepted. +-- +-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList +-- >>> p2 = Parser.satisfy (== '+') +-- >>> p = Parser.deintercalate1 p1 p2 Fold.toList +-- >>> Stream.parsePos p $ Stream.fromList "" +-- Left (ParseErrorPos 0 "takeWhile1: end of input") +-- >>> Stream.parse p $ Stream.fromList "1" +-- Right [Left "1"] +-- >>> Stream.parse p $ Stream.fromList "1+" +-- Right [Left "1"] +-- >>> Stream.parse p $ Stream.fromList "1+2+3" +-- Right [Left "1",Right '+',Left "2",Right '+',Left "3"] +-- +{-# INLINE deintercalate1 #-} +deintercalate1 :: Monad m => + Parser a m x + -> Parser a m y + -> Fold m (Either x y) z + -> Parser a m z +deintercalate1 + (Parser stepL initialL extractL) + (Parser stepR initialR _) + (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + errMsg p status = + error $ "deintercalate: " ++ p ++ " parser cannot " + ++ status ++ " without input" + + initial = do + res <- finitial + case res of + FL.Partial fs -> do + pres <- initialL + case pres of + IPartial s -> return $ IPartial $ Deintercalate1InitL 0 fs s + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + FL.Done c -> return $ IDone c + + {-# INLINE processL #-} + processL foldAction n nextState = do + fres <- foldAction + case fres of + FL.Partial fs1 -> return $ SPartial n (nextState fs1) + FL.Done c -> return $ SDone n c + + {-# INLINE runStepInitL #-} + runStepInitL cnt fs sL a = do + r <- stepL sL a + case r of + SPartial n s -> return $ SContinue n (Deintercalate1InitL (cnt + n) fs s) + SContinue n s -> return $ SContinue n (Deintercalate1InitL (cnt + n) fs s) + SDone n b -> + processL (fstep fs (Left b)) n Deintercalate1InitR + SError err -> return $ SError err + + {-# INLINE processR #-} + processR cnt b fs n = do + res <- initialL + case res of + IPartial ps -> return $ SContinue n (Deintercalate1RL cnt b fs ps) + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + + {-# INLINE runStepR #-} + runStepR cnt fs sR a = do + r <- stepR sR a + case r of + SPartial n s -> return $ SContinue n (Deintercalate1R (cnt + n) fs s) + SContinue n s -> return $ SContinue n (Deintercalate1R (cnt + n) fs s) + SDone n b -> processR (cnt + n) b fs n + SError _ -> do + xs <- ffinal fs + return $ SDone (- cnt) xs + + step (Deintercalate1InitL cnt fs sL) a = runStepInitL cnt fs sL a + step (Deintercalate1InitR fs) a = do + res <- initialR + case res of + IPartial s -> runStepR 0 fs s a + IDone _ -> errMsg "right" "succeed" + IError _ -> errMsg "right" "fail" + step (Deintercalate1R cnt fs sR) a = runStepR cnt fs sR a + step (Deintercalate1RL cnt bR fs sL) a = do + r <- stepL sL a + case r of + SPartial n s -> return $ SContinue n (Deintercalate1RL (cnt + n) bR fs s) + SContinue n s -> return $ SContinue n (Deintercalate1RL (cnt + n) bR fs s) + SDone n bL -> do + res <- fstep fs (Right bR) + case res of + FL.Partial fs1 -> do + fres <- fstep fs1 (Left bL) + case fres of + FL.Partial fs2 -> + return $ SPartial n (Deintercalate1InitR fs2) + FL.Done c -> return $ SDone n c + -- XXX We could have the fold accept pairs of (bR, bL) + FL.Done _ -> error "Fold terminated consuming partial input" + SError _ -> do + xs <- ffinal fs + return $ SDone (- cnt) xs + + {-# INLINE extractResult #-} + extractResult n fs r = do + res <- fstep fs r + case res of + FL.Partial fs1 -> fmap (FDone n) $ ffinal fs1 + FL.Done c -> return (FDone n c) + + extract (Deintercalate1InitL cnt fs sL) = do + r <- extractL sL + case r of + FDone n b -> extractResult n fs (Left b) + FContinue n s -> return $ FContinue n (Deintercalate1InitL (cnt + n) fs s) + FError err -> return $ FError err + extract (Deintercalate1InitR fs) = fmap (FDone 0) $ ffinal fs + extract (Deintercalate1R cnt fs _) = fmap (FDone (- cnt)) $ ffinal fs + extract (Deintercalate1RL cnt bR fs sL) = do + r <- extractL sL + case r of + FDone n bL -> do + res <- fstep fs (Right bR) + case res of + FL.Partial fs1 -> extractResult n fs1 (Left bL) + FL.Done _ -> error "Fold terminated consuming partial input" + FContinue n s -> return $ FContinue n (Deintercalate1RL (cnt + n) bR fs s) + FError _ -> do + xs <- ffinal fs + return $ FDone (- cnt) xs + +{-# ANN type SepByState Fuse #-} +data SepByState fs sp ss = + SepByInitL !fs + | SepByL !Int !fs !sp + | SepByInitR !fs + | SepByR !Int !fs !ss + +-- | Apply two parsers alternately to an input stream. Parsing starts at the +-- first parser and stops at the first parser. The output of the first parser +-- is emiited and the output of the second parser is discarded. It can be used +-- to parse a infix style pattern e.g. p1 p2 p1 . Empty input or single parse +-- of the first parser is accepted. +-- +-- Definitions: +-- +-- >>> sepBy p1 p2 f = Parser.deintercalate p1 p2 (Fold.catLefts f) +-- >>> sepBy p1 p2 f = Parser.sepBy1 p1 p2 f <|> Parser.fromEffect (Fold.finalM f) +-- +-- Examples: +-- +-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList +-- >>> p2 = Parser.satisfy (== '+') +-- >>> p = Parser.sepBy p1 p2 Fold.toList +-- >>> Stream.parse p $ Stream.fromList "" +-- Right [] +-- >>> Stream.parse p $ Stream.fromList "1" +-- Right ["1"] +-- >>> Stream.parse p $ Stream.fromList "1+" +-- Right ["1"] +-- >>> Stream.parse p $ Stream.fromList "1+2+3" +-- Right ["1","2","3"] +-- +{-# INLINE sepBy #-} +sepBy :: Monad m => + Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c +-- This has similar performance as the custom impl below. +-- sepBy p1 p2 f = deintercalate p1 p2 (FL.catLefts f) +sepBy + (Parser stepL initialL extractL) + (Parser stepR initialR _) + (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + errMsg p status = + error $ "sepBy: " ++ p ++ " parser cannot " + ++ status ++ " without input" + + initial = do + res <- finitial + case res of + FL.Partial fs -> return $ IPartial $ SepByInitL fs + FL.Done c -> return $ IDone c + + {-# INLINE processL #-} + processL foldAction n nextState = do + fres <- foldAction + case fres of + FL.Partial fs1 -> return $ SPartial n (nextState fs1) + FL.Done c -> return $ SDone n c + + {-# INLINE runStepL #-} + runStepL cnt fs sL a = do + r <- stepL sL a + case r of + SPartial n s -> return $ SContinue n (SepByL (cnt + n) fs s) + SContinue n s -> return $ SContinue n (SepByL (cnt + n) fs s) + SDone n b -> + processL (fstep fs b) n SepByInitR + SError _ -> do + xs <- ffinal fs + return $ SDone (- cnt) xs + + {-# INLINE processR #-} + processR cnt fs n = do + res <- initialL + case res of + IPartial ps -> return $ SContinue n (SepByL cnt fs ps) + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + + {-# INLINE runStepR #-} + runStepR cnt fs sR a = do + r <- stepR sR a + case r of + SPartial n s -> return $ SContinue n (SepByR (cnt + n) fs s) + SContinue n s -> return $ SContinue n (SepByR (cnt + n) fs s) + SDone n _ -> processR (cnt + n) fs n + SError _ -> do + xs <- ffinal fs + return $ SDone (- cnt) xs + + step (SepByInitL fs) a = do + res <- initialL + case res of + IPartial s -> runStepL 0 fs s a + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + step (SepByL cnt fs sL) a = runStepL cnt fs sL a + step (SepByInitR fs) a = do + res <- initialR + case res of + IPartial s -> runStepR 0 fs s a + IDone _ -> errMsg "right" "succeed" + IError _ -> errMsg "right" "fail" + step (SepByR cnt fs sR) a = runStepR cnt fs sR a + + {-# INLINE extractResult #-} + extractResult n fs r = do + res <- fstep fs r + case res of + FL.Partial fs1 -> fmap (FDone n) $ ffinal fs1 + FL.Done c -> return (FDone n c) + + extract (SepByInitL fs) = fmap (FDone 0) $ ffinal fs + extract (SepByL cnt fs sL) = do + r <- extractL sL + case r of + FDone n b -> extractResult n fs b + FContinue n s -> return $ FContinue n (SepByL (cnt + n) fs s) + FError _ -> do + xs <- ffinal fs + return $ FDone (- cnt) xs + extract (SepByInitR fs) = fmap (FDone 0) $ ffinal fs + extract (SepByR cnt fs _) = fmap (FDone (- cnt)) $ ffinal fs + +-- | Non-backtracking version of sepBy. Several times faster. +{-# INLINE sepByAll #-} +sepByAll :: Monad m => + Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c +sepByAll p1 p2 f = deintercalateAll p1 p2 (FL.catLefts f) + +-- XXX This can be implemented using refold, parse one and then continue +-- collecting the rest in that. + +{-# ANN type SepBy1State Fuse #-} +data SepBy1State fs sp ss = + SepBy1InitL !Int !fs sp + | SepBy1L !Int !fs !sp + | SepBy1InitR !fs + | SepBy1R !Int !fs !ss + +{- +{-# INLINE sepBy1 #-} +sepBy1 :: Monad m => + Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c +sepBy1 p sep sink = do + x <- p + f <- fromEffect $ FL.reduce sink + f1 <- fromEffect $ FL.snoc f x + many (sep >> p) f1 +-} + +-- | Like 'sepBy' but requires at least one successful parse. +-- +-- Definition: +-- +-- >>> sepBy1 p1 p2 f = Parser.deintercalate1 p1 p2 (Fold.catLefts f) +-- +-- Examples: +-- +-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList +-- >>> p2 = Parser.satisfy (== '+') +-- >>> p = Parser.sepBy1 p1 p2 Fold.toList +-- >>> Stream.parsePos p $ Stream.fromList "" +-- Left (ParseErrorPos 0 "takeWhile1: end of input") +-- >>> Stream.parse p $ Stream.fromList "1" +-- Right ["1"] +-- >>> Stream.parse p $ Stream.fromList "1+" +-- Right ["1"] +-- >>> Stream.parse p $ Stream.fromList "1+2+3" +-- Right ["1","2","3"] +-- +{-# INLINE sepBy1 #-} +sepBy1 :: Monad m => + Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c +sepBy1 + (Parser stepL initialL extractL) + (Parser stepR initialR _) + (Fold fstep finitial _ ffinal) = Parser step initial extract + + where + + errMsg p status = + error $ "sepBy: " ++ p ++ " parser cannot " + ++ status ++ " without input" + + initial = do + res <- finitial + case res of + FL.Partial fs -> do + pres <- initialL + case pres of + IPartial s -> return $ IPartial $ SepBy1InitL 0 fs s + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + FL.Done c -> return $ IDone c + + {-# INLINE processL #-} + processL foldAction n nextState = do + fres <- foldAction + case fres of + FL.Partial fs1 -> return $ SPartial n (nextState fs1) + FL.Done c -> return $ SDone n c + + {-# INLINE runStepInitL #-} + runStepInitL cnt fs sL a = do + r <- stepL sL a + case r of + SPartial n s -> return $ SContinue n (SepBy1InitL (cnt + n) fs s) + SContinue n s -> return $ SContinue n (SepBy1InitL (cnt + n) fs s) + SDone n b -> + processL (fstep fs b) n SepBy1InitR + SError err -> return $ SError err + + {-# INLINE runStepL #-} + runStepL cnt fs sL a = do + r <- stepL sL a + case r of + SPartial n s -> return $ SContinue n (SepBy1L (cnt + n) fs s) + SContinue n s -> return $ SContinue n (SepBy1L (cnt + n) fs s) + SDone n b -> + processL (fstep fs b) n SepBy1InitR + SError _ -> do + xs <- ffinal fs + return $ SDone (- cnt) xs + + {-# INLINE processR #-} + processR cnt fs n = do + res <- initialL + case res of + IPartial ps -> return $ SContinue n (SepBy1L cnt fs ps) + IDone _ -> errMsg "left" "succeed" + IError _ -> errMsg "left" "fail" + + {-# INLINE runStepR #-} + runStepR cnt fs sR a = do + r <- stepR sR a + case r of + SPartial n s -> return $ SContinue n (SepBy1R (cnt + n) fs s) + SContinue n s -> return $ SContinue n (SepBy1R (cnt + n) fs s) + -- XXX review, need tests for sepBy1 + SDone n _ -> processR (cnt + n) fs n + SError _ -> do + xs <- ffinal fs + return $ SDone (-cnt) xs + + step (SepBy1InitL cnt fs sL) a = runStepInitL cnt fs sL a + step (SepBy1L cnt fs sL) a = runStepL cnt fs sL a + step (SepBy1InitR fs) a = do + res <- initialR + case res of + IPartial s -> runStepR 0 fs s a + IDone _ -> errMsg "right" "succeed" + IError _ -> errMsg "right" "fail" + step (SepBy1R cnt fs sR) a = runStepR cnt fs sR a + + {-# INLINE extractResult #-} + extractResult n fs r = do + res <- fstep fs r + case res of + FL.Partial fs1 -> fmap (FDone n) $ ffinal fs1 + FL.Done c -> return (FDone n c) + + extract (SepBy1InitL cnt fs sL) = do + r <- extractL sL + case r of + FDone n b -> extractResult n fs b + FContinue n s -> return $ FContinue n (SepBy1InitL (cnt + n) fs s) + FError err -> return $ FError err + extract (SepBy1L cnt fs sL) = do + r <- extractL sL + case r of + FDone n b -> extractResult n fs b + FContinue n s -> return $ FContinue n (SepBy1L (cnt + n) fs s) + FError _ -> do + xs <- ffinal fs + return $ FDone (- cnt) xs + extract (SepBy1InitR fs) = fmap (FDone 0) $ ffinal fs + extract (SepBy1R cnt fs _) = fmap (FDone (- cnt)) $ ffinal fs + +------------------------------------------------------------------------------- +-- Interleaving a collection of parsers +------------------------------------------------------------------------------- +-- +-- | Apply a collection of parsers to an input stream in a round robin fashion. +-- Each parser is applied until it stops and then we repeat starting with the +-- the first parser again. +-- +-- /Unimplemented/ +-- +{-# INLINE roundRobin #-} +roundRobin :: -- (Foldable t, Monad m) => + t (Parser a m b) -> Fold m b c -> Parser a m c +roundRobin _ps _f = undefined + +------------------------------------------------------------------------------- +-- Sequential Collection +------------------------------------------------------------------------------- + +-- | @sequence f p@ collects sequential parses of parsers in a +-- serial stream @p@ using the fold @f@. Fails if the input ends or any +-- of the parsers fail. +-- +-- /Pre-release/ +-- +{-# INLINE sequence #-} +sequence :: Monad m => + D.Stream m (Parser a m b) -> Fold m b c -> Parser a m c +sequence (D.Stream sstep sstate) (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + initial = do + fres <- finitial + case fres of + FL.Partial fs -> return $ IPartial (Nothing', sstate, fs) + FL.Done c -> return $ IDone c + + -- state does not contain any parser + -- yield a new parser from the stream + step (Nothing', ss, fs) _ = do + sres <- sstep defState ss + case sres of + D.Yield p ss1 -> return $ SContinue 0 (Just' p, ss1, fs) + D.Stop -> do + c <- ffinal fs + return $ SDone 0 c + D.Skip ss1 -> return $ SContinue 0 (Nothing', ss1, fs) + + -- state holds a parser that may or may not have been + -- initialized. pinit holds the initial parser state + -- or modified parser state respectively + step (Just' (Parser pstep pinit pextr), ss, fs) a = do + ps <- pinit + case ps of + IPartial ps1 -> do + pres <- pstep ps1 a + case pres of + SPartial n ps2 -> + let newP = + Just' $ Parser pstep (return $ IPartial ps2) pextr + in return $ SPartial n (newP, ss, fs) + SContinue n ps2 -> + let newP = + Just' $ Parser pstep (return $ IPartial ps2) pextr + in return $ SContinue n (newP, ss, fs) + SDone n b -> do + fres <- fstep fs b + case fres of + FL.Partial fs1 -> + return $ SPartial n (Nothing', ss, fs1) + FL.Done c -> return $ SDone n c + SError msg -> return $ SError msg + IDone b -> do + fres <- fstep fs b + case fres of + FL.Partial fs1 -> + return $ SPartial 0 (Nothing', ss, fs1) + FL.Done c -> return $ SDone 0 c + IError err -> return $ SError err + + extract (Nothing', _, fs) = fmap (FDone 0) $ ffinal fs + extract (Just' (Parser pstep pinit pextr), ss, fs) = do + ps <- pinit + case ps of + IPartial ps1 -> do + r <- pextr ps1 + case r of + FDone n b -> do + res <- fstep fs b + case res of + FL.Partial fs1 -> fmap (FDone n) $ ffinal fs1 + FL.Done c -> return (FDone n c) + FError err -> return $ FError err + FContinue n s -> return $ FContinue n (Just' (Parser pstep (return (IPartial s)) pextr), ss, fs) + IDone b -> do + fres <- fstep fs b + case fres of + FL.Partial fs1 -> fmap (FDone 0) $ ffinal fs1 + FL.Done c -> return (FDone 0 c) + IError err -> return $ FError err + +------------------------------------------------------------------------------- +-- Alternative Collection +------------------------------------------------------------------------------- + +{- +-- | @choice parsers@ applies the @parsers@ in order and returns the first +-- successful parse. +-- +-- This is same as 'asum' but more efficient. +-- +-- /Broken/ +-- +{-# INLINE choice #-} +choice :: (MonadCatch m, Foldable t) => t (Parser a m b) -> Parser a m b +choice = foldl1 shortest +-} + +------------------------------------------------------------------------------- +-- Sequential Repetition +------------------------------------------------------------------------------- + +-- | Like 'many' but uses a 'Parser' instead of a 'Fold' to collect the +-- results. Parsing stops or fails if the collecting parser stops or fails. +-- +-- /Unimplemented/ +-- +{-# INLINE manyP #-} +manyP :: -- MonadCatch m => + Parser a m b -> Parser b m c -> Parser a m c +manyP _p _f = undefined + +-- | Collect zero or more parses. Apply the supplied parser repeatedly on the +-- input stream and push the parse results to a downstream fold. +-- +-- Stops: when the downstream fold stops or the parser fails. +-- Fails: never, produces zero or more results. +-- +-- >>> many = Parser.countBetween 0 maxBound +-- +-- Compare with 'Control.Applicative.many'. +-- +{-# INLINE many #-} +many :: Monad m => Parser a m b -> Fold m b c -> Parser a m c +many = splitMany +-- many = countBetween 0 maxBound + +-- Note: many1 would perhaps be a better name for this and consistent with +-- other names like takeWhile1. But we retain the name "some" for +-- compatibility. + +-- | Collect one or more parses. Apply the supplied parser repeatedly on the +-- input stream and push the parse results to a downstream fold. +-- +-- Stops: when the downstream fold stops or the parser fails. +-- Fails: if it stops without producing a single result. +-- +-- >>> some p f = Parser.manyP p (Parser.takeGE 1 f) +-- >>> some = Parser.countBetween 1 maxBound +-- +-- Compare with 'Control.Applicative.some'. +-- +{-# INLINE some #-} +some :: Monad m => Parser a m b -> Fold m b c -> Parser a m c +some = splitSome +-- some p f = manyP p (takeGE 1 f) +-- some = countBetween 1 maxBound + +-- | @countBetween m n f p@ collects between @m@ and @n@ sequential parses of +-- parser @p@ using the fold @f@. Stop after collecting @n@ results. Fails if +-- the input ends or the parser fails before @m@ results are collected. +-- +-- >>> countBetween m n p f = Parser.manyP p (Parser.takeBetween m n f) +-- +-- /Unimplemented/ +-- +{-# INLINE countBetween #-} +countBetween :: -- MonadCatch m => + Int -> Int -> Parser a m b -> Fold m b c -> Parser a m c +countBetween _m _n _p = undefined +-- countBetween m n p f = manyP p (takeBetween m n f) + +-- | @count n f p@ collects exactly @n@ sequential parses of parser @p@ using +-- the fold @f@. Fails if the input ends or the parser fails before @n@ +-- results are collected. +-- +-- >>> count n = Parser.countBetween n n +-- >>> count n p f = Parser.manyP p (Parser.takeEQ n f) +-- +-- /Unimplemented/ +-- +{-# INLINE count #-} +count :: -- MonadCatch m => + Int -> Parser a m b -> Fold m b c -> Parser a m c +count n = countBetween n n +-- count n p f = manyP p (takeEQ n f) + +-- | Like 'manyTill' but uses a 'Parser' to collect the results instead of a +-- 'Fold'. Parsing stops or fails if the collecting parser stops or fails. +-- +-- We can implemnent parsers like the following using 'manyTillP': +-- +-- @ +-- countBetweenTill m n f p = manyTillP (takeBetween m n f) p +-- @ +-- +-- /Unimplemented/ +-- +{-# INLINE manyTillP #-} +manyTillP :: -- Monad m => + Parser a m b -> Parser a m x -> Parser b m c -> Parser a m c +manyTillP _p1 _p2 _f = undefined + -- D.toParserK $ D.manyTillP (D.fromParserK p1) (D.fromParserK p2) f + +{-# ANN type ManyTillState Fuse #-} +data ManyTillState fs sr sl + = ManyTillR !Int !fs !sr + | ManyTillL !fs !sl + +-- | @manyTill p test f@ tries the parser @test@ on the input, if @test@ +-- fails it backtracks and tries @p@, after @p@ succeeds @test@ is +-- tried again and so on. The parser stops when @test@ succeeds. The output of +-- @test@ is discarded and the output of @p@ is accumulated by the +-- supplied fold. The parser fails if @p@ fails. +-- +-- Stops when the fold @f@ stops. +-- +{-# INLINE manyTill #-} +manyTill :: Monad m + => Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c +manyTill (Parser stepL initialL extractL) + (Parser stepR initialR _) + (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + -- Caution: Mutual recursion + + scrutL fs p c d e = do + resL <- initialL + case resL of + IPartial sl -> return $ c (ManyTillL fs sl) + IDone bl -> do + fr <- fstep fs bl + case fr of + FL.Partial fs1 -> scrutR fs1 p c d e + FL.Done fb -> return $ d fb + IError err -> return $ e err + + scrutR fs p c d e = do + resR <- initialR + case resR of + IPartial sr -> return $ p (ManyTillR 0 fs sr) + IDone _ -> d <$> ffinal fs + IError _ -> scrutL fs p c d e + + initial = do + res <- finitial + case res of + FL.Partial fs -> scrutR fs IPartial IPartial IDone IError + FL.Done b -> return $ IDone b + + step (ManyTillR cnt fs st) a = do + r <- stepR st a + case r of + SPartial n s -> return $ SPartial n (ManyTillR 0 fs s) + SContinue n s -> do + assertM(cnt + n >= 0) + return $ SContinue n (ManyTillR (cnt + n) fs s) + SDone n _ -> do + b <- ffinal fs + return $ SDone n b + SError _ -> do + resL <- initialL + case resL of + IPartial sl -> + return $ SContinue (negate cnt) (ManyTillL fs sl) + IDone bl -> do + fr <- fstep fs bl + -- XXX review, need tests for manyTill + case fr of + FL.Partial fs1 -> + scrutR + fs1 + (SPartial (-cnt)) + (SContinue (-cnt)) + (SDone (-cnt)) + SError + FL.Done fb -> return $ SDone (-cnt) fb + IError err -> return $ SError err + step (ManyTillL fs st) a = do + r <- stepL st a + case r of + SPartial n s -> return $ SPartial n (ManyTillL fs s) + SContinue n s -> return $ SContinue n (ManyTillL fs s) + SDone n b -> do + fs1 <- fstep fs b + case fs1 of + FL.Partial s -> + scrutR s (SPartial n) (SContinue n) (SDone n) SError + FL.Done b1 -> return $ SDone n b1 + SError err -> return $ SError err + + extract (ManyTillL fs sR) = do + res <- extractL sR + case res of + FDone n b -> do + r <- fstep fs b + case r of + FL.Partial fs1 -> fmap (FDone n) $ ffinal fs1 + FL.Done c -> return (FDone n c) + FError err -> return $ FError err + FContinue n s -> return $ FContinue n (ManyTillL fs s) + extract (ManyTillR _ fs _) = fmap (FDone 0) $ ffinal fs + +-- | @manyThen f collect recover@ repeats the parser @collect@ on the input and +-- collects the output in the supplied fold. If the the parser @collect@ fails, +-- parser @recover@ is run until it stops and then we start repeating the +-- parser @collect@ again. The parser fails if the recovery parser fails. +-- +-- For example, this can be used to find a key frame in a video stream after an +-- error. +-- +-- /Unimplemented/ +-- +{-# INLINE manyThen #-} +manyThen :: -- (Foldable t, Monad m) => + Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c +manyThen _parser _recover _f = undefined + +------------------------------------------------------------------------------- +-- Repeated Alternatives +------------------------------------------------------------------------------- + +-- | Keep trying a parser up to a maximum of @n@ failures. When the parser +-- fails the input consumed till now is dropped and the new instance is tried +-- on the fresh input. +-- +-- /Unimplemented/ +-- +{-# INLINE retryMaxTotal #-} +retryMaxTotal :: -- (Monad m) => + Int -> Parser a m b -> Fold m b c -> Parser a m c +retryMaxTotal _n _p _f = undefined + +-- | Like 'retryMaxTotal' but aborts after @n@ successive failures. +-- +-- /Unimplemented/ +-- +{-# INLINE retryMaxSuccessive #-} +retryMaxSuccessive :: -- (Monad m) => + Int -> Parser a m b -> Fold m b c -> Parser a m c +retryMaxSuccessive _n _p _f = undefined + +-- | Keep trying a parser until it succeeds. When the parser fails the input +-- consumed till now is dropped and the new instance is tried on the fresh +-- input. +-- +-- /Unimplemented/ +-- +{-# INLINE retry #-} +retry :: -- (Monad m) => + Parser a m b -> Parser a m b +retry _p = undefined diff --git a/src/Streamly/Internal/Data/Parser/ParserD.hs b/src/Streamly/Internal/Data/Parser/ParserD.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Parser/ParserD.hs +++ /dev/null @@ -1,3629 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Parser.ParserD --- Copyright : (c) 2020 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Parser.ParserD - ( - -- * Setup - -- $setup - - -- * Types - Parser (..) - , ParseError (..) - , Step (..) - , Initial (..) - - -- * Downgrade to Fold - , toFold - - -- First order parsers - -- * Accumulators - , fromFold - , fromFoldMaybe - , fromPure - , fromEffect - , die - , dieM - - -- * Map on input - , lmap - , lmapM - , postscan - , filter - - -- * Map on output - , rmapM - - -- * Element parsers - , peek - - -- All of these can be expressed in terms of either - , one - , oneEq - , oneNotEq - , oneOf - , noneOf - , eof - , satisfy - , maybe - , either - - -- * Sequence parsers (tokenizers) - -- - -- | Parsers chained in series, if one parser terminates the composition - -- terminates. Currently we are using folds to collect the output of the - -- parsers but we can use Parsers instead of folds to make the composition - -- more powerful. For example, we can do: - -- - -- takeEndByOrMax cond n p = takeEndBy cond (take n p) - -- takeEndByBetween cond m n p = takeEndBy cond (takeBetween m n p) - -- takeWhileBetween cond m n p = takeWhile cond (takeBetween m n p) - , lookAhead - - -- ** By length - -- | Grab a sequence of input elements without inspecting them - , takeBetween - -- , take -- takeBetween 0 n - , takeEQ -- takeBetween n n - , takeGE -- takeBetween n maxBound - -- , takeGE1 -- take1 -- takeBetween 1 n - , takeP - - -- Grab a sequence of input elements by inspecting them - -- ** Exact match - , listEq - , listEqBy - , streamEqBy - , subsequenceBy - - -- ** By predicate - , takeWhile - , takeWhileP - , takeWhile1 - , dropWhile - - -- ** Separated by elements - -- | Separator could be in prefix postion ('takeStartBy'), or suffix - -- position ('takeEndBy'). See 'deintercalate', 'sepBy' etc for infix - -- separator parsing, also see 'intersperseQuotedBy' fold. - - -- These can be implemented modularly with refolds, using takeWhile and - -- satisfy. - , takeEndBy - , takeEndBy_ - , takeEndByEsc - -- , takeEndByEsc_ - , takeStartBy - , takeStartBy_ - , takeEitherSepBy - , wordBy - - -- ** Grouped by element comparison - , groupBy - , groupByRolling - , groupByRollingEither - - -- ** Framed by elements - -- | Also see 'intersperseQuotedBy' fold. - -- Framed by a one or more ocurrences of a separator around a word like - -- spaces or quotes. No nesting. - , wordFramedBy -- XXX Remove this? Covered by wordWithQuotes? - , wordWithQuotes - , wordKeepQuotes - , wordProcessQuotes - - -- Framed by separate start and end characters, potentially nested. - -- blockWithQuotes allows quotes inside a block. However, - -- takeFramedByGeneric can be used to express takeStartBy, takeEndBy and - -- block with escaping. - -- , takeFramedBy - , takeFramedBy_ - , takeFramedByEsc_ - , takeFramedByGeneric - , blockWithQuotes - - -- Matching strings - -- , prefixOf -- match any prefix of a given string - -- , suffixOf -- match any suffix of a given string - -- , infixOf -- match any substring of a given string - - -- ** Spanning - , span - , spanBy - , spanByRolling - - -- Second order parsers (parsers using parsers) - -- * Binary Combinators - - -- ** Sequential Applicative - , splitWith - , split_ - - {- - -- ** Parallel Applicatives - , teeWith - , teeWithFst - , teeWithMin - -- , teeTill -- like manyTill but parallel - -} - - -- ** Sequential Alternative - , alt - - {- - -- ** Parallel Alternatives - , shortest - , longest - -- , fastest - -} - - -- * N-ary Combinators - -- ** Sequential Collection - , sequence - , concatMap - - -- ** Sequential Repetition - , count - , countBetween - -- , countBetweenTill - , manyP - , many - , some - - -- ** Interleaved Repetition - -- Use two folds, run a primary parser, its rejected values go to the - -- secondary parser. - , deintercalate - , deintercalate1 - , deintercalateAll - -- , deintercalatePrefix - -- , deintercalateSuffix - - -- *** Special cases - -- | TODO: traditional implmentations of these may be of limited use. For - -- example, consider parsing lines separated by @\\r\\n@. The main parser - -- will have to detect and exclude the sequence @\\r\\n@ anyway so that we - -- can apply the "sep" parser. - -- - -- We can instead implement these as special cases of deintercalate. - -- - -- @ - -- , endBy - -- , sepEndBy - -- , beginBy - -- , sepBeginBy - -- , sepAroundBy - -- @ - , sepBy1 - , sepBy - , sepByAll - - , manyTillP - , manyTill - , manyThen - - -- -- * Distribution - -- - -- A simple and stupid impl would be to just convert the stream to an array - -- and give the array reference to all consumers. The array can be grown on - -- demand by any consumer and truncated when nonbody needs it. - -- - -- -- ** Distribute to collection - -- -- ** Distribute to repetition - - -- ** Interleaved collection - -- | - -- - -- 1. Round robin - -- 2. Priority based - , roundRobin - - -- -- ** Interleaved repetition - -- repeat one parser and when it fails run an error recovery parser - -- e.g. to find a key frame in the stream after an error - - -- ** Collection of Alternatives - -- | Unimplemented - -- - -- @ - -- , shortestN - -- , longestN - -- , fastestN -- first N successful in time - -- , choiceN -- first N successful in position - -- @ - -- , choice -- first successful in position - - -- ** Repeated Alternatives - , retryMaxTotal - , retryMaxSuccessive - , retry - - -- ** Zipping Input - , zipWithM - , zip - , indexed - , makeIndexFilter - , sampleFromthen - - -- * Deprecated - , next - ) -where - -#include "inline.hs" -#include "assert.hs" - -import Control.Monad (when) -import Data.Bifunctor (first) -import Fusion.Plugin.Types (Fuse(..)) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.SVar.Type (defState) -import Streamly.Internal.Data.Either.Strict (Either'(..)) -import Streamly.Internal.Data.Maybe.Strict (Maybe'(..)) -import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) - -import qualified Data.Foldable as Foldable -import qualified Streamly.Internal.Data.Fold.Type as FL -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamD.Generate as D - -import Prelude hiding - (any, all, take, takeWhile, sequence, concatMap, maybe, either, span - , zip, filter, dropWhile) --- import Streamly.Internal.Data.Parser.ParserD.Tee -import Streamly.Internal.Data.Parser.ParserD.Type - -#include "DocTestDataParser.hs" - -------------------------------------------------------------------------------- --- Downgrade a parser to a Fold -------------------------------------------------------------------------------- - --- | Make a 'Fold' from a 'Parser'. The fold just throws an exception if the --- parser fails or tries to backtrack. --- --- This can be useful in combinators that accept a Fold and we know that a --- Parser cannot fail or failure exception is acceptable as there is no way to --- recover. --- --- /Pre-release/ --- -{-# INLINE toFold #-} -toFold :: Monad m => Parser a m b -> Fold m a b -toFold (Parser pstep pinitial pextract) = Fold step initial extract - - where - - initial = do - r <- pinitial - case r of - IPartial s -> return $ FL.Partial s - IDone b -> return $ FL.Done b - IError err -> - error $ "toFold: parser throws error in initial" ++ err - - perror n = error $ "toFold: parser backtracks in Partial: " ++ show n - cerror n = error $ "toFold: parser backtracks in Continue: " ++ show n - derror n = error $ "toFold: parser backtracks in Done: " ++ show n - eerror err = error $ "toFold: parser throws error: " ++ err - - step st a = do - r <- pstep st a - case r of - Partial 0 s -> return $ FL.Partial s - Continue 0 s -> return $ FL.Partial s - Done 0 b -> return $ FL.Done b - Partial n _ -> perror n - Continue n _ -> cerror n - Done n _ -> derror n - Error err -> eerror err - - extract st = do - r <- pextract st - case r of - Done 0 b -> return b - Partial n _ -> perror n - Continue n _ -> cerror n - Done n _ -> derror n - Error err -> eerror err - -------------------------------------------------------------------------------- --- Upgrade folds to parses -------------------------------------------------------------------------------- - --- | Make a 'Parser' from a 'Fold'. This parser sends all of its input to the --- fold. --- -{-# INLINE fromFold #-} -fromFold :: Monad m => Fold m a b -> Parser a m b -fromFold (Fold fstep finitial fextract) = Parser step initial extract - - where - - initial = do - res <- finitial - return - $ case res of - FL.Partial s1 -> IPartial s1 - FL.Done b -> IDone b - - step s a = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Partial 0 s1 - FL.Done b -> Done 0 b - - extract = fmap (Done 0) . fextract - --- | Convert a Maybe returning fold to an error returning parser. The first --- argument is the error message that the parser would return when the fold --- returns Nothing. --- --- /Pre-release/ --- -{-# INLINE fromFoldMaybe #-} -fromFoldMaybe :: Monad m => String -> Fold m a (Maybe b) -> Parser a m b -fromFoldMaybe errMsg (Fold fstep finitial fextract) = - Parser step initial extract - - where - - initial = do - res <- finitial - return - $ case res of - FL.Partial s1 -> IPartial s1 - FL.Done b -> - case b of - Just x -> IDone x - Nothing -> IError errMsg - - step s a = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Partial 0 s1 - FL.Done b -> - case b of - Just x -> Done 0 x - Nothing -> Error errMsg - - extract s = do - res <- fextract s - case res of - Just x -> return $ Done 0 x - Nothing -> return $ Error errMsg - -------------------------------------------------------------------------------- --- Failing Parsers -------------------------------------------------------------------------------- - --- | Peek the head element of a stream, without consuming it. Fails if it --- encounters end of input. --- --- >>> Stream.parse ((,) <$> Parser.peek <*> Parser.satisfy (> 0)) $ Stream.fromList [1] --- Right (1,1) --- --- @ --- peek = lookAhead (satisfy True) --- @ --- -{-# INLINE peek #-} -peek :: Monad m => Parser a m a -peek = Parser step initial extract - - where - - initial = return $ IPartial () - - step () a = return $ Done 1 a - - extract () = return $ Error "peek: end of input" - --- | Succeeds if we are at the end of input, fails otherwise. --- --- >>> Stream.parse ((,) <$> Parser.satisfy (> 0) <*> Parser.eof) $ Stream.fromList [1] --- Right (1,()) --- -{-# INLINE eof #-} -eof :: Monad m => Parser a m () -eof = Parser step initial extract - - where - - initial = return $ IPartial () - - step () _ = return $ Error "eof: not at end of input" - - extract () = return $ Done 0 () - --- | Return the next element of the input. Returns 'Nothing' --- on end of input. Also known as 'head'. --- --- /Pre-release/ --- -{-# DEPRECATED next "Please use \"fromFold Fold.one\" instead" #-} -{-# INLINE next #-} -next :: Monad m => Parser a m (Maybe a) -next = Parser step initial extract - - where - - initial = pure $ IPartial () - - step () a = pure $ Done 0 (Just a) - - extract () = pure $ Done 0 Nothing - --- | Map an 'Either' returning function on the next element in the stream. If --- the function returns 'Left err', the parser fails with the error message --- @err@ otherwise returns the 'Right' value. --- --- /Pre-release/ --- -{-# INLINE either #-} -either :: Monad m => (a -> Either String b) -> Parser a m b -either f = Parser step initial extract - - where - - initial = return $ IPartial () - - step () a = return $ - case f a of - Right b -> Done 0 b - Left err -> Error err - - extract () = return $ Error "end of input" - --- | Map a 'Maybe' returning function on the next element in the stream. The --- parser fails if the function returns 'Nothing' otherwise returns the 'Just' --- value. --- --- >>> toEither = Maybe.maybe (Left "maybe: predicate failed") Right --- >>> maybe f = Parser.either (toEither . f) --- --- >>> maybe f = Parser.fromFoldMaybe "maybe: predicate failed" (Fold.maybe f) --- --- /Pre-release/ --- -{-# INLINE maybe #-} -maybe :: Monad m => (a -> Maybe b) -> Parser a m b --- maybe f = either (Maybe.maybe (Left "maybe: predicate failed") Right . f) -maybe parserF = Parser step initial extract - - where - - initial = return $ IPartial () - - step () a = return $ - case parserF a of - Just b -> Done 0 b - Nothing -> Error "maybe: predicate failed" - - extract () = return $ Error "maybe: end of input" - --- | Returns the next element if it passes the predicate, fails otherwise. --- --- >>> Stream.parse (Parser.satisfy (== 1)) $ Stream.fromList [1,0,1] --- Right 1 --- --- >>> toMaybe f x = if f x then Just x else Nothing --- >>> satisfy f = Parser.maybe (toMaybe f) --- -{-# INLINE satisfy #-} -satisfy :: Monad m => (a -> Bool) -> Parser a m a --- satisfy predicate = maybe (\a -> if predicate a then Just a else Nothing) -satisfy predicate = Parser step initial extract - - where - - initial = return $ IPartial () - - step () a = return $ - if predicate a - then Done 0 a - else Error "satisfy: predicate failed" - - extract () = return $ Error "satisfy: end of input" - --- | Consume one element from the head of the stream. Fails if it encounters --- end of input. --- --- >>> one = Parser.satisfy $ const True --- -{-# INLINE one #-} -one :: Monad m => Parser a m a -one = satisfy $ const True - --- Alternate names: "only", "onlyThis". - --- | Match a specific element. --- --- >>> oneEq x = Parser.satisfy (== x) --- -{-# INLINE oneEq #-} -oneEq :: (Monad m, Eq a) => a -> Parser a m a -oneEq x = satisfy (== x) - --- Alternate names: "exclude", "notThis". - --- | Match anything other than the supplied element. --- --- >>> oneNotEq x = Parser.satisfy (/= x) --- -{-# INLINE oneNotEq #-} -oneNotEq :: (Monad m, Eq a) => a -> Parser a m a -oneNotEq x = satisfy (/= x) - --- | Match any one of the elements in the supplied list. --- --- >>> oneOf xs = Parser.satisfy (`Foldable.elem` xs) --- --- When performance matters a pattern matching predicate could be more --- efficient than a 'Foldable' datatype: --- --- @ --- let p x = --- case x of --- 'a' -> True --- 'e' -> True --- _ -> False --- in satisfy p --- @ --- --- GHC may use a binary search instead of linear search in the list. --- Alternatively, you can also use an array instead of list for storage and --- search. --- -{-# INLINE oneOf #-} -oneOf :: (Monad m, Eq a, Foldable f) => f a -> Parser a m a -oneOf xs = satisfy (`Foldable.elem` xs) - --- | See performance notes in 'oneOf'. --- --- >>> noneOf xs = Parser.satisfy (`Foldable.notElem` xs) --- -{-# INLINE noneOf #-} -noneOf :: (Monad m, Eq a, Foldable f) => f a -> Parser a m a -noneOf xs = satisfy (`Foldable.notElem` xs) - -------------------------------------------------------------------------------- --- Taking elements -------------------------------------------------------------------------------- - --- Required to fuse "take" with "many" in "chunksOf", for ghc-9.x -{-# ANN type Tuple'Fused Fuse #-} -data Tuple'Fused a b = Tuple'Fused !a !b deriving Show - --- | @takeBetween m n@ takes a minimum of @m@ and a maximum of @n@ input --- elements and folds them using the supplied fold. --- --- Stops after @n@ elements. --- Fails if the stream ends before @m@ elements could be taken. --- --- Examples: - --- --- @ --- >>> :{ --- takeBetween' low high ls = Stream.parse prsr (Stream.fromList ls) --- where prsr = Parser.takeBetween low high Fold.toList --- :} --- --- @ --- --- >>> takeBetween' 2 4 [1, 2, 3, 4, 5] --- Right [1,2,3,4] --- --- >>> takeBetween' 2 4 [1, 2] --- Right [1,2] --- --- >>> takeBetween' 2 4 [1] --- Left (ParseError "takeBetween: Expecting alteast 2 elements, got 1") --- --- >>> takeBetween' 0 0 [1, 2] --- Right [] --- --- >>> takeBetween' 0 1 [] --- Right [] --- --- @takeBetween@ is the most general take operation, other take operations can --- be defined in terms of takeBetween. For example: --- --- >>> take n = Parser.takeBetween 0 n --- >>> takeEQ n = Parser.takeBetween n n --- >>> takeGE n = Parser.takeBetween n maxBound --- --- /Pre-release/ --- -{-# INLINE takeBetween #-} -takeBetween :: Monad m => Int -> Int -> Fold m a b -> Parser a m b -takeBetween low high (Fold fstep finitial fextract) = - - Parser step initial (extract streamErr) - - where - - streamErr i = - "takeBetween: Expecting alteast " ++ show low - ++ " elements, got " ++ show i - - invalidRange = - "takeBetween: lower bound - " ++ show low - ++ " is greater than higher bound - " ++ show high - - foldErr :: Int -> String - foldErr i = - "takeBetween: the collecting fold terminated after" - ++ " consuming" ++ show i ++ " elements" - ++ " minimum" ++ show low ++ " elements needed" - - -- Exactly the same as snext except different constructors, we can possibly - -- deduplicate the two. - {-# INLINE inext #-} - inext i res = - let i1 = i + 1 - in case res of - FL.Partial s -> do - let s1 = Tuple'Fused i1 s - if i1 < high - -- XXX ideally this should be a Continue instead - then return $ IPartial s1 - else iextract foldErr s1 - FL.Done b -> - return - $ if i1 >= low - then IDone b - else IError (foldErr i1) - - initial = do - when (low >= 0 && high >= 0 && low > high) - $ error invalidRange - - finitial >>= inext (-1) - - -- Keep the impl same as inext - {-# INLINE snext #-} - snext i res = - let i1 = i + 1 - in case res of - FL.Partial s -> do - let s1 = Tuple'Fused i1 s - if i1 < high - then return $ Continue 0 s1 - else extract foldErr s1 - FL.Done b -> - return - $ if i1 >= low - then Done 0 b - else Error (foldErr i1) - - step (Tuple'Fused i s) a = fstep s a >>= snext i - - extract f (Tuple'Fused i s) - | i >= low && i <= high = fmap (Done 0) (fextract s) - | otherwise = return $ Error (f i) - - -- XXX Need to make Initial return type Step to deduplicate this - iextract f (Tuple'Fused i s) - | i >= low && i <= high = fmap IDone (fextract s) - | otherwise = return $ IError (f i) - --- | Stops after taking exactly @n@ input elements. --- --- * Stops - after consuming @n@ elements. --- * Fails - if the stream or the collecting fold ends before it can collect --- exactly @n@ elements. --- --- >>> Stream.parse (Parser.takeEQ 2 Fold.toList) $ Stream.fromList [1,0,1] --- Right [1,0] --- --- >>> Stream.parse (Parser.takeEQ 4 Fold.toList) $ Stream.fromList [1,0,1] --- Left (ParseError "takeEQ: Expecting exactly 4 elements, input terminated on 3") --- -{-# INLINE takeEQ #-} -takeEQ :: Monad m => Int -> Fold m a b -> Parser a m b -takeEQ n (Fold fstep finitial fextract) = Parser step initial extract - - where - - initial = do - res <- finitial - case res of - FL.Partial s -> - if n > 0 - then return $ IPartial $ Tuple'Fused 1 s - else fmap IDone (fextract s) - FL.Done b -> return $ - if n > 0 - then IError - $ "takeEQ: Expecting exactly " ++ show n - ++ " elements, fold terminated without" - ++ " consuming any elements" - else IDone b - - step (Tuple'Fused i1 r) a = do - res <- fstep r a - if n > i1 - then - return - $ case res of - FL.Partial s -> Continue 0 $ Tuple'Fused (i1 + 1) s - FL.Done _ -> - Error - $ "takeEQ: Expecting exactly " ++ show n - ++ " elements, fold terminated on " ++ show i1 - else - -- assert (n == i1) - Done 0 - <$> case res of - FL.Partial s -> fextract s - FL.Done b -> return b - - extract (Tuple'Fused i _) = - -- Using the count "i" in the message below causes large performance - -- regression unless we use Fuse annotation on Tuple. - return - $ Error - $ "takeEQ: Expecting exactly " ++ show n - ++ " elements, input terminated on " ++ show (i - 1) - -{-# ANN type TakeGEState Fuse #-} -data TakeGEState s = - TakeGELT !Int !s - | TakeGEGE !s - --- | Take at least @n@ input elements, but can collect more. --- --- * Stops - when the collecting fold stops. --- * Fails - if the stream or the collecting fold ends before producing @n@ --- elements. --- --- >>> Stream.parse (Parser.takeGE 4 Fold.toList) $ Stream.fromList [1,0,1] --- Left (ParseError "takeGE: Expecting at least 4 elements, input terminated on 3") --- --- >>> Stream.parse (Parser.takeGE 4 Fold.toList) $ Stream.fromList [1,0,1,0,1] --- Right [1,0,1,0,1] --- --- /Pre-release/ --- -{-# INLINE takeGE #-} -takeGE :: Monad m => Int -> Fold m a b -> Parser a m b -takeGE n (Fold fstep finitial fextract) = Parser step initial extract - - where - - initial = do - res <- finitial - case res of - FL.Partial s -> - if n > 0 - then return $ IPartial $ TakeGELT 1 s - else return $ IPartial $ TakeGEGE s - FL.Done b -> return $ - if n > 0 - then IError - $ "takeGE: Expecting at least " ++ show n - ++ " elements, fold terminated without" - ++ " consuming any elements" - else IDone b - - step (TakeGELT i1 r) a = do - res <- fstep r a - if n > i1 - then - return - $ case res of - FL.Partial s -> Continue 0 $ TakeGELT (i1 + 1) s - FL.Done _ -> - Error - $ "takeGE: Expecting at least " ++ show n - ++ " elements, fold terminated on " ++ show i1 - else - -- assert (n <= i1) - return - $ case res of - FL.Partial s -> Partial 0 $ TakeGEGE s - FL.Done b -> Done 0 b - step (TakeGEGE r) a = do - res <- fstep r a - return - $ case res of - FL.Partial s -> Partial 0 $ TakeGEGE s - FL.Done b -> Done 0 b - - extract (TakeGELT i _) = - return - $ Error - $ "takeGE: Expecting at least " ++ show n - ++ " elements, input terminated on " ++ show (i - 1) - extract (TakeGEGE r) = fmap (Done 0) $ fextract r - -------------------------------------------------------------------------------- --- Conditional splitting -------------------------------------------------------------------------------- - --- XXX We should perhaps use only takeWhileP and rename it to takeWhile. - --- | Like 'takeWhile' but uses a 'Parser' instead of a 'Fold' to collect the --- input. The combinator stops when the condition fails or if the collecting --- parser stops. --- --- Other interesting parsers can be implemented in terms of this parser: --- --- >>> takeWhile1 cond p = Parser.takeWhileP cond (Parser.takeBetween 1 maxBound p) --- >>> takeWhileBetween cond m n p = Parser.takeWhileP cond (Parser.takeBetween m n p) --- --- Stops: when the condition fails or the collecting parser stops. --- Fails: when the collecting parser fails. --- --- /Pre-release/ --- -{-# INLINE takeWhileP #-} -takeWhileP :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b -takeWhileP predicate (Parser pstep pinitial pextract) = - Parser step pinitial pextract - - where - - step s a = - if predicate a - then pstep s a - else do - r <- pextract s - -- XXX need a map on count - case r of - Error err -> return $ Error err - Done n s1 -> return $ Done (n + 1) s1 - Partial _ _ -> error "Bug: takeWhileP: Partial in extract" - Continue n s1 -> return $ Continue (n + 1) s1 - --- | Collect stream elements until an element fails the predicate. The element --- on which the predicate fails is returned back to the input stream. --- --- * Stops - when the predicate fails or the collecting fold stops. --- * Fails - never. --- --- >>> Stream.parse (Parser.takeWhile (== 0) Fold.toList) $ Stream.fromList [0,0,1,0,1] --- Right [0,0] --- --- >>> takeWhile cond f = Parser.takeWhileP cond (Parser.fromFold f) --- --- We can implement a @breakOn@ using 'takeWhile': --- --- @ --- breakOn p = takeWhile (not p) --- @ --- -{-# INLINE takeWhile #-} -takeWhile :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b --- takeWhile cond f = takeWhileP cond (fromFold f) -takeWhile predicate (Fold fstep finitial fextract) = - Parser step initial extract - - where - - initial = do - res <- finitial - return $ case res of - FL.Partial s -> IPartial s - FL.Done b -> IDone b - - step s a = - if predicate a - then do - fres <- fstep s a - return - $ case fres of - FL.Partial s1 -> Partial 0 s1 - FL.Done b -> Done 0 b - else Done 1 <$> fextract s - - extract s = fmap (Done 0) (fextract s) - -{- --- XXX This may not be composable because of the b argument. We can instead --- return a "Reparse b a m b" so that those can be composed. -{-# INLINE takeWhile1X #-} -takeWhile1 :: Monad m => b -> (a -> Bool) -> Refold m b a b -> Parser a m b --- We can implement this using satisfy and takeWhile. We can use "satisfy --- p", fold the result with the refold and then use the "takeWhile p" and --- fold that using the refold. -takeWhile1 acc cond f = undefined --} - --- | Like 'takeWhile' but takes at least one element otherwise fails. --- --- >>> takeWhile1 cond p = Parser.takeWhileP cond (Parser.takeBetween 1 maxBound p) --- -{-# INLINE takeWhile1 #-} -takeWhile1 :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b --- takeWhile1 cond f = takeWhileP cond (takeBetween 1 maxBound f) -takeWhile1 predicate (Fold fstep finitial fextract) = - Parser step initial extract - - where - - initial = do - res <- finitial - return $ case res of - FL.Partial s -> IPartial (Left' s) - FL.Done _ -> - IError - $ "takeWhile1: fold terminated without consuming:" - ++ " any element" - - {-# INLINE process #-} - process s a = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Partial 0 (Right' s1) - FL.Done b -> Done 0 b - - step (Left' s) a = - if predicate a - then process s a - else return $ Error "takeWhile1: predicate failed on first element" - step (Right' s) a = - if predicate a - then process s a - else do - b <- fextract s - return $ Done 1 b - - extract (Left' _) = return $ Error "takeWhile1: end of input" - extract (Right' s) = fmap (Done 0) (fextract s) - --- | Drain the input as long as the predicate succeeds, running the effects and --- discarding the results. --- --- This is also called @skipWhile@ in some parsing libraries. --- --- >>> dropWhile p = Parser.takeWhile p Fold.drain --- -{-# INLINE dropWhile #-} -dropWhile :: Monad m => (a -> Bool) -> Parser a m () -dropWhile p = takeWhile p FL.drain - -------------------------------------------------------------------------------- --- Separators -------------------------------------------------------------------------------- - -{-# ANN type FramedEscState Fuse #-} -data FramedEscState s = - FrameEscInit !s | FrameEscGo !s !Int | FrameEscEsc !s !Int - --- XXX We can remove Maybe from esc -{-# INLINE takeFramedByGeneric #-} -takeFramedByGeneric :: Monad m => - Maybe (a -> Bool) -- is escape char? - -> Maybe (a -> Bool) -- is frame begin? - -> Maybe (a -> Bool) -- is frame end? - -> Fold m a b - -> Parser a m b -takeFramedByGeneric esc begin end (Fold fstep finitial fextract) = - - Parser step initial extract - - where - - initial = do - res <- finitial - return $ - case res of - FL.Partial s -> IPartial (FrameEscInit s) - FL.Done _ -> - error "takeFramedByGeneric: fold done without input" - - {-# INLINE process #-} - process s a n = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Continue 0 (FrameEscGo s1 n) - FL.Done b -> Done 0 b - - {-# INLINE processNoEsc #-} - processNoEsc s a n = - case end of - Just isEnd -> - case begin of - Just isBegin -> - -- takeFramedBy case - if isEnd a - then - if n == 0 - then Done 0 <$> fextract s - else process s a (n - 1) - else - let n1 = if isBegin a then n + 1 else n - in process s a n1 - Nothing -> -- takeEndBy case - if isEnd a - then Done 0 <$> fextract s - else process s a n - Nothing -> -- takeStartBy case - case begin of - Just isBegin -> - if isBegin a - then Done 0 <$> fextract s - else process s a n - Nothing -> - error $ "takeFramedByGeneric: " - ++ "Both begin and end frame predicate missing" - - {-# INLINE processCheckEsc #-} - processCheckEsc s a n = - case esc of - Just isEsc -> - if isEsc a - then return $ Partial 0 $ FrameEscEsc s n - else processNoEsc s a n - Nothing -> processNoEsc s a n - - step (FrameEscInit s) a = - case begin of - Just isBegin -> - if isBegin a - then return $ Partial 0 (FrameEscGo s 0) - else return $ Error "takeFramedByGeneric: missing frame start" - Nothing -> - case end of - Just isEnd -> - if isEnd a - then Done 0 <$> fextract s - else processCheckEsc s a 0 - Nothing -> - error "Both begin and end frame predicate missing" - step (FrameEscGo s n) a = processCheckEsc s a n - step (FrameEscEsc s n) a = process s a n - - err = return . Error - - extract (FrameEscInit _) = - err "takeFramedByGeneric: empty token" - extract (FrameEscGo s _) = - case begin of - Just _ -> - case end of - Nothing -> fmap (Done 0) $ fextract s - Just _ -> err "takeFramedByGeneric: missing frame end" - Nothing -> err "takeFramedByGeneric: missing closing frame" - extract (FrameEscEsc _ _) = err "takeFramedByGeneric: trailing escape" - -data BlockParseState s = - BlockInit !s - | BlockUnquoted !Int !s - | BlockQuoted !Int !s - | BlockQuotedEsc !Int !s - --- Blocks can be of different types e.g. {} or (). We only parse from the --- perspective of the outermost block type. The nesting of that block are --- checked. Any other block types nested inside it are opaque to us and can be --- parsed when the contents of the block are parsed. - --- XXX Put a limit on nest level to keep the API safe. - --- | Parse a block enclosed within open, close brackets. Block contents may be --- quoted, brackets inside quotes are ignored. Quoting characters can be used --- within quotes if escaped. A block can have a nested block inside it. --- --- Quote begin and end chars are the same. Block brackets and quote chars must --- not overlap. Block start and end brackets must be different for nesting --- blocks within blocks. --- --- >>> p = Parser.blockWithQuotes (== '\\') (== '"') '{' '}' Fold.toList --- >>> Stream.parse p $ Stream.fromList "{msg: \"hello world\"}" --- Right "msg: \"hello world\"" --- -{-# INLINE blockWithQuotes #-} -blockWithQuotes :: (Monad m, Eq a) => - (a -> Bool) -- ^ escape char - -> (a -> Bool) -- ^ quote char, to quote inside brackets - -> a -- ^ Block opening bracket - -> a -- ^ Block closing bracket - -> Fold m a b - -> Parser a m b -blockWithQuotes isEsc isQuote bopen bclose - (Fold fstep finitial fextract) = - Parser step initial extract - - where - - initial = do - res <- finitial - return $ - case res of - FL.Partial s -> IPartial (BlockInit s) - FL.Done _ -> - error "blockWithQuotes: fold finished without input" - - {-# INLINE process #-} - process s a nextState = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Continue 0 (nextState s1) - FL.Done b -> Done 0 b - - step (BlockInit s) a = - return - $ if a == bopen - then Continue 0 $ BlockUnquoted 1 s - else Error "blockWithQuotes: missing block start" - step (BlockUnquoted level s) a - | a == bopen = process s a (BlockUnquoted (level + 1)) - | a == bclose = - if level == 1 - then fmap (Done 0) (fextract s) - else process s a (BlockUnquoted (level - 1)) - | isQuote a = process s a (BlockQuoted level) - | otherwise = process s a (BlockUnquoted level) - step (BlockQuoted level s) a - | isEsc a = process s a (BlockQuotedEsc level) - | otherwise = - if isQuote a - then process s a (BlockUnquoted level) - else process s a (BlockQuoted level) - step (BlockQuotedEsc level s) a = process s a (BlockQuoted level) - - err = return . Error - - extract (BlockInit s) = fmap (Done 0) $ fextract s - extract (BlockUnquoted level _) = - err $ "blockWithQuotes: finished at block nest level " ++ show level - extract (BlockQuoted level _) = - err $ "blockWithQuotes: finished, inside an unfinished quote, " - ++ "at block nest level " ++ show level - extract (BlockQuotedEsc level _) = - err $ "blockWithQuotes: finished, inside an unfinished quote, " - ++ "after an escape char, at block nest level " ++ show level - --- | @takeEndBy cond parser@ parses a token that ends by a separator chosen by --- the supplied predicate. The separator is also taken with the token. --- --- This can be combined with other parsers to implement other interesting --- parsers as follows: --- --- >>> takeEndByLE cond n p = Parser.takeEndBy cond (Parser.fromFold $ Fold.take n p) --- >>> takeEndByBetween cond m n p = Parser.takeEndBy cond (Parser.takeBetween m n p) --- --- >>> takeEndBy = Parser.takeEndByEsc (const False) --- --- See also "Streamly.Data.Fold.takeEndBy". Unlike the fold, the collecting --- parser in the takeEndBy parser can decide whether to fail or not if the --- stream does not end with separator. --- --- /Pre-release/ --- -{-# INLINE takeEndBy #-} -takeEndBy :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b --- takeEndBy = takeEndByEsc (const False) -takeEndBy cond (Parser pstep pinitial pextract) = - - Parser step initial pextract - - where - - initial = pinitial - - step s a = do - res <- pstep s a - if not (cond a) - then return res - else extractStep pextract res - --- | Like 'takeEndBy' but the separator elements can be escaped using an --- escape char determined by the first predicate. The escape characters are --- removed. --- --- /pre-release/ -{-# INLINE takeEndByEsc #-} -takeEndByEsc :: Monad m => - (a -> Bool) -> (a -> Bool) -> Parser a m b -> Parser a m b -takeEndByEsc isEsc isSep (Parser pstep pinitial pextract) = - - Parser step initial extract - - where - - initial = first Left' <$> pinitial - - step (Left' s) a = do - if isEsc a - then return $ Partial 0 $ Right' s - else do - res <- pstep s a - if not (isSep a) - then return $ first Left' res - else fmap (first Left') $ extractStep pextract res - - step (Right' s) a = do - res <- pstep s a - return $ first Left' res - - extract (Left' s) = fmap (first Left') $ pextract s - extract (Right' _) = - return $ Error "takeEndByEsc: trailing escape" - --- | Like 'takeEndBy' but the separator is dropped. --- --- See also "Streamly.Data.Fold.takeEndBy_". --- --- /Pre-release/ --- -{-# INLINE takeEndBy_ #-} -takeEndBy_ :: (a -> Bool) -> Parser a m b -> Parser a m b -{- -takeEndBy_ isEnd p = - takeFramedByGeneric Nothing Nothing (Just isEnd) (toFold p) --} -takeEndBy_ cond (Parser pstep pinitial pextract) = - - Parser step pinitial pextract - - where - - step s a = - if cond a - then pextract s - else pstep s a - --- | Take either the separator or the token. Separator is a Left value and --- token is Right value. --- --- /Unimplemented/ -{-# INLINE takeEitherSepBy #-} -takeEitherSepBy :: -- Monad m => - (a -> Bool) -> Fold m (Either a b) c -> Parser a m c -takeEitherSepBy _cond = undefined -- D.toParserK . D.takeEitherSepBy cond - --- | Parse a token that starts with an element chosen by the predicate. The --- parser fails if the input does not start with the selected element. --- --- * Stops - when the predicate succeeds in non-leading position. --- * Fails - when the predicate fails in the leading position. --- --- >>> splitWithPrefix p f = Stream.parseMany (Parser.takeStartBy p f) --- --- Examples: - --- --- >>> p = Parser.takeStartBy (== ',') Fold.toList --- >>> leadingComma = Stream.parse p . Stream.fromList --- >>> leadingComma "a,b" --- Left (ParseError "takeStartBy: missing frame start") --- ... --- >>> leadingComma ",," --- Right "," --- >>> leadingComma ",a,b" --- Right ",a" --- >>> leadingComma "" --- Right "" --- --- /Pre-release/ --- -{-# INLINE takeStartBy #-} -takeStartBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b -takeStartBy cond (Fold fstep finitial fextract) = - - Parser step initial extract - - where - - initial = do - res <- finitial - return $ - case res of - FL.Partial s -> IPartial (Left' s) - FL.Done _ -> IError "takeStartBy: fold done without input" - - {-# INLINE process #-} - process s a = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Partial 0 (Right' s1) - FL.Done b -> Done 0 b - - step (Left' s) a = - if cond a - then process s a - else return $ Error "takeStartBy: missing frame start" - step (Right' s) a = - if not (cond a) - then process s a - else Done 1 <$> fextract s - - extract (Left' s) = fmap (Done 0) $ fextract s - extract (Right' s) = fmap (Done 0) $ fextract s - --- | Like 'takeStartBy' but drops the separator. --- --- >>> takeStartBy_ isBegin = Parser.takeFramedByGeneric Nothing (Just isBegin) Nothing --- -{-# INLINE takeStartBy_ #-} -takeStartBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b -takeStartBy_ isBegin = takeFramedByGeneric Nothing (Just isBegin) Nothing - --- | @takeFramedByEsc_ isEsc isBegin isEnd fold@ parses a token framed using a --- begin and end predicate, and an escape character. The frame begin and end --- characters lose their special meaning if preceded by the escape character. --- --- Nested frames are allowed if begin and end markers are different, nested --- frames must be balanced unless escaped, nested frame markers are emitted as --- it is. --- --- For example, --- --- >>> p = Parser.takeFramedByEsc_ (== '\\') (== '{') (== '}') Fold.toList --- >>> Stream.parse p $ Stream.fromList "{hello}" --- Right "hello" --- >>> Stream.parse p $ Stream.fromList "{hello {world}}" --- Right "hello {world}" --- >>> Stream.parse p $ Stream.fromList "{hello \\{world}" --- Right "hello {world" --- >>> Stream.parse p $ Stream.fromList "{hello {world}" --- Left (ParseError "takeFramedByEsc_: missing frame end") --- --- /Pre-release/ -{-# INLINE takeFramedByEsc_ #-} -takeFramedByEsc_ :: Monad m => - (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser a m b --- takeFramedByEsc_ isEsc isEnd p = --- takeFramedByGeneric (Just isEsc) Nothing (Just isEnd) (toFold p) -takeFramedByEsc_ isEsc isBegin isEnd (Fold fstep finitial fextract) = - - Parser step initial extract - - where - - initial = do - res <- finitial - return $ - case res of - FL.Partial s -> IPartial (FrameEscInit s) - FL.Done _ -> - error "takeFramedByEsc_: fold done without input" - - {-# INLINE process #-} - process s a n = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Continue 0 (FrameEscGo s1 n) - FL.Done b -> Done 0 b - - step (FrameEscInit s) a = - if isBegin a - then return $ Partial 0 (FrameEscGo s 0) - else return $ Error "takeFramedByEsc_: missing frame start" - step (FrameEscGo s n) a = - if isEsc a - then return $ Partial 0 $ FrameEscEsc s n - else do - if not (isEnd a) - then - let n1 = if isBegin a then n + 1 else n - in process s a n1 - else - if n == 0 - then Done 0 <$> fextract s - else process s a (n - 1) - step (FrameEscEsc s n) a = process s a n - - err = return . Error - - extract (FrameEscInit _) = err "takeFramedByEsc_: empty token" - extract (FrameEscGo _ _) = err "takeFramedByEsc_: missing frame end" - extract (FrameEscEsc _ _) = err "takeFramedByEsc_: trailing escape" - -data FramedState s = FrameInit !s | FrameGo !s Int - --- | @takeFramedBy_ isBegin isEnd fold@ parses a token framed by a begin and an --- end predicate. --- --- >>> takeFramedBy_ = Parser.takeFramedByEsc_ (const False) --- -{-# INLINE takeFramedBy_ #-} -takeFramedBy_ :: Monad m => - (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser a m b --- takeFramedBy_ isBegin isEnd = --- takeFramedByGeneric (Just (const False)) (Just isBegin) (Just isEnd) -takeFramedBy_ isBegin isEnd (Fold fstep finitial fextract) = - - Parser step initial extract - - where - - initial = do - res <- finitial - return $ - case res of - FL.Partial s -> IPartial (FrameInit s) - FL.Done _ -> - error "takeFramedBy_: fold done without input" - - {-# INLINE process #-} - process s a n = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Continue 0 (FrameGo s1 n) - FL.Done b -> Done 0 b - - step (FrameInit s) a = - if isBegin a - then return $ Continue 0 (FrameGo s 0) - else return $ Error "takeFramedBy_: missing frame start" - step (FrameGo s n) a - | not (isEnd a) = - let n1 = if isBegin a then n + 1 else n - in process s a n1 - | n == 0 = Done 0 <$> fextract s - | otherwise = process s a (n - 1) - - err = return . Error - - extract (FrameInit _) = err "takeFramedBy_: empty token" - extract (FrameGo _ _) = err "takeFramedBy_: missing frame end" - -------------------------------------------------------------------------------- --- Grouping and words -------------------------------------------------------------------------------- - -data WordByState s b = WBLeft !s | WBWord !s | WBRight !b - --- Note we can also get words using something like: --- sepBy FL.toList (takeWhile (not . p) Fold.toList) (dropWhile p) --- --- But that won't be as efficient and ergonomic. - --- | Like 'splitOn' but strips leading, trailing, and repeated separators. --- Therefore, @".a..b."@ having '.' as the separator would be parsed as --- @["a","b"]@. In other words, its like parsing words from whitespace --- separated text. --- --- * Stops - when it finds a word separator after a non-word element --- * Fails - never. --- --- >>> wordBy = Parser.wordFramedBy (const False) (const False) (const False) --- --- @ --- S.wordsBy pred f = S.parseMany (PR.wordBy pred f) --- @ --- -{-# INLINE wordBy #-} -wordBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b -wordBy predicate (Fold fstep finitial fextract) = Parser step initial extract - - where - - {-# INLINE worder #-} - worder s a = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Partial 0 $ WBWord s1 - FL.Done b -> Done 0 b - - initial = do - res <- finitial - return - $ case res of - FL.Partial s -> IPartial $ WBLeft s - FL.Done b -> IDone b - - step (WBLeft s) a = - if not (predicate a) - then worder s a - else return $ Partial 0 $ WBLeft s - step (WBWord s) a = - if not (predicate a) - then worder s a - else do - b <- fextract s - return $ Partial 0 $ WBRight b - step (WBRight b) a = - return - $ if not (predicate a) - then Done 1 b - else Partial 0 $ WBRight b - - extract (WBLeft s) = fmap (Done 0) $ fextract s - extract (WBWord s) = fmap (Done 0) $ fextract s - extract (WBRight b) = return (Done 0 b) - -data WordFramedState s b = - WordFramedSkipPre !s - | WordFramedWord !s !Int - | WordFramedEsc !s !Int - | WordFramedSkipPost !b - --- | Like 'wordBy' but treats anything inside a pair of quotes as a single --- word, the quotes can be escaped by an escape character. Recursive quotes --- are possible if quote begin and end characters are different, quotes must be --- balanced. Outermost quotes are stripped. --- --- >>> braces = Parser.wordFramedBy (== '\\') (== '{') (== '}') isSpace Fold.toList --- >>> Stream.parse braces $ Stream.fromList "{ab} cd" --- Right "ab" --- >>> Stream.parse braces $ Stream.fromList "{ab}{cd}" --- Right "abcd" --- >>> Stream.parse braces $ Stream.fromList "a{b} cd" --- Right "ab" --- >>> Stream.parse braces $ Stream.fromList "a{{b}} cd" --- Right "a{b}" --- --- >>> quotes = Parser.wordFramedBy (== '\\') (== '"') (== '"') isSpace Fold.toList --- >>> Stream.parse quotes $ Stream.fromList "\"a\"\"b\"" --- Right "ab" --- -{-# INLINE wordFramedBy #-} -wordFramedBy :: Monad m => - (a -> Bool) -- ^ Matches escape elem? - -> (a -> Bool) -- ^ Matches left quote? - -> (a -> Bool) -- ^ matches right quote? - -> (a -> Bool) -- ^ matches word separator? - -> Fold m a b - -> Parser a m b -wordFramedBy isEsc isBegin isEnd isSep - (Fold fstep finitial fextract) = - Parser step initial extract - - where - - initial = do - res <- finitial - return $ - case res of - FL.Partial s -> IPartial (WordFramedSkipPre s) - FL.Done _ -> - error "wordFramedBy: fold done without input" - - {-# INLINE process #-} - process s a n = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Continue 0 (WordFramedWord s1 n) - FL.Done b -> Done 0 b - - step (WordFramedSkipPre s) a - | isEsc a = return $ Continue 0 $ WordFramedEsc s 0 - | isSep a = return $ Partial 0 $ WordFramedSkipPre s - | isBegin a = return $ Continue 0 $ WordFramedWord s 1 - | isEnd a = - return $ Error "wordFramedBy: missing frame start" - | otherwise = process s a 0 - step (WordFramedWord s n) a - | isEsc a = return $ Continue 0 $ WordFramedEsc s n - | n == 0 && isSep a = do - b <- fextract s - return $ Partial 0 $ WordFramedSkipPost b - | otherwise = do - -- We need to use different order for checking begin and end for - -- the n == 0 and n == 1 case so that when the begin and end - -- character is the same we treat the one after begin as end. - if n == 0 - then - -- Need to check isBegin first - if isBegin a - then return $ Continue 0 $ WordFramedWord s 1 - else if isEnd a - then return $ Error "wordFramedBy: missing frame start" - else process s a n - else - -- Need to check isEnd first - if isEnd a - then - if n == 1 - then return $ Continue 0 $ WordFramedWord s 0 - else process s a (n - 1) - else if isBegin a - then process s a (n + 1) - else process s a n - step (WordFramedEsc s n) a = process s a n - step (WordFramedSkipPost b) a = - return - $ if not (isSep a) - then Done 1 b - else Partial 0 $ WordFramedSkipPost b - - err = return . Error - - extract (WordFramedSkipPre s) = fmap (Done 0) $ fextract s - extract (WordFramedWord s n) = - if n == 0 - then fmap (Done 0) $ fextract s - else err "wordFramedBy: missing frame end" - extract (WordFramedEsc _ _) = - err "wordFramedBy: trailing escape" - extract (WordFramedSkipPost b) = return (Done 0 b) - -data WordQuotedState s b a = - WordQuotedSkipPre !s - | WordUnquotedWord !s - | WordQuotedWord !s !Int !a !a - | WordUnquotedEsc !s - | WordQuotedEsc !s !Int !a !a - | WordQuotedSkipPost !b - --- | Quote and bracket aware word splitting with escaping. Like 'wordBy' but --- word separators within specified quotes or brackets are ignored. Quotes and --- escape characters can be processed. If the end quote is different from the --- start quote it is called a bracket. The following quoting rules apply: --- --- * In an unquoted string a character may be preceded by an escape character. --- The escape character is removed and the character following it is treated --- literally with no special meaning e.g. e.g. h\ e\ l\ l\ o is a single word, --- \n is same as n. --- * Any part of the word can be placed within quotes. Inside quotes all --- characters are treated literally with no special meaning. Quoting character --- itself cannot be used within quotes unless escape processing within quotes --- is applied to allow it. --- * Optionally escape processing for quoted part can be specified. Escape --- character has no special meaning inside quotes unless it is followed by a --- character that has a escape translation specified, in that case the escape --- character is removed, and the specified translation is applied to the --- character following it. This can be used to escape the quoting character --- itself within quotes. --- * There can be multiple quoting characters, when a quote starts, all other --- quoting characters within that quote lose any special meaning until the --- quote is closed. --- * A starting quote char without an ending char generates a parse error. An --- ending bracket char without a corresponding bracket begin is ignored. --- * Brackets can be nested. --- --- We should note that unquoted and quoted escape processing are different. In --- unquoted part escape character is always removed. In quoted part it is --- removed only if followed by a special meaning character. This is consistent --- with how shell performs escape processing. - --- Examples of quotes - "double quotes", 'single quotes', (parens), {braces}, --- ((nested) brackets). --- --- Example: --- --- >>> :{ --- >>> q x = --- >>> case x of --- >>> '"' -> Just x --- >>> '\'' -> Just x --- >>> _ -> Nothing --- >>> :} --- --- >>> p = Parser.wordKeepQuotes (== '\\') q isSpace Fold.toList --- >>> Stream.parse p $ Stream.fromList "a\"b'c\";'d\"e'f ghi" --- Right "a\"b'c\";'d\"e'f" --- --- Note that outer quotes and backslashes from the input string are consumed by --- Haskell, therefore, the actual input string passed to the parser is: --- a"b'c";'d"e'f ghi --- --- Similarly, when printing, double quotes are escaped by Haskell. --- --- Limitations: --- --- Shell like quote processing can be performed by using quote char specific --- escape processing, single quotes with no escapes, and double quotes with --- escapes. --- --- JSON string processing can also be achieved except the "\uXXXX" style --- escaping for Unicode characters. --- -{-# INLINE wordWithQuotes #-} -wordWithQuotes :: (Monad m, Eq a) => - Bool -- ^ Retain the quotes and escape chars in the output - -> (a -> a -> Maybe a) -- ^ quote char -> escaped char -> translated char - -> a -- ^ Matches an escape elem? - -> (a -> Maybe a) -- ^ If left quote, return right quote, else Nothing. - -> (a -> Bool) -- ^ Matches a word separator? - -> Fold m a b - -> Parser a m b -wordWithQuotes keepQuotes tr escChar toRight isSep - (Fold fstep finitial fextract) = - Parser step initial extract - - where - - -- Can be used to generate parse error for a bracket end without a bracket - -- begin. - isInvalid = const False - - isEsc = (== escChar) - - initial = do - res <- finitial - return $ - case res of - FL.Partial s -> IPartial (WordQuotedSkipPre s) - FL.Done _ -> - error "wordKeepQuotes: fold done without input" - - {-# INLINE processQuoted #-} - processQuoted s a n ql qr = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Continue 0 (WordQuotedWord s1 n ql qr) - FL.Done b -> Done 0 b - - {-# INLINE processUnquoted #-} - processUnquoted s a = do - res <- fstep s a - return - $ case res of - FL.Partial s1 -> Continue 0 (WordUnquotedWord s1) - FL.Done b -> Done 0 b - - step (WordQuotedSkipPre s) a - | isEsc a = return $ Continue 0 $ WordUnquotedEsc s - | isSep a = return $ Partial 0 $ WordQuotedSkipPre s - | otherwise = - case toRight a of - Just qr -> - if keepQuotes - then processQuoted s a 1 a qr - else return $ Continue 0 $ WordQuotedWord s 1 a qr - Nothing - | isInvalid a -> - return $ Error "wordKeepQuotes: invalid unquoted char" - | otherwise -> processUnquoted s a - step (WordUnquotedWord s) a - | isEsc a = return $ Continue 0 $ WordUnquotedEsc s - | isSep a = do - b <- fextract s - return $ Partial 0 $ WordQuotedSkipPost b - | otherwise = do - case toRight a of - Just qr -> - if keepQuotes - then processQuoted s a 1 a qr - else return $ Continue 0 $ WordQuotedWord s 1 a qr - Nothing -> - if isInvalid a - then return $ Error "wordKeepQuotes: invalid unquoted char" - else processUnquoted s a - step (WordQuotedWord s n ql qr) a - | isEsc a = return $ Continue 0 $ WordQuotedEsc s n ql qr - {- - -- XXX Will this ever occur? Will n ever be 0? - | n == 0 && isSep a = do - b <- fextract s - return $ Partial 0 $ WordQuotedSkipPost b - -} - | otherwise = do - if a == qr - then - if n == 1 - then if keepQuotes - then processUnquoted s a - else return $ Continue 0 $ WordUnquotedWord s - else processQuoted s a (n - 1) ql qr - else if a == ql - then processQuoted s a (n + 1) ql qr - else processQuoted s a n ql qr - step (WordUnquotedEsc s) a = processUnquoted s a - step (WordQuotedEsc s n ql qr) a = - case tr ql a of - Nothing -> do - res <- fstep s escChar - case res of - FL.Partial s1 -> processQuoted s1 a n ql qr - FL.Done b -> return $ Done 0 b - Just x -> processQuoted s x n ql qr - step (WordQuotedSkipPost b) a = - return - $ if not (isSep a) - then Done 1 b - else Partial 0 $ WordQuotedSkipPost b - - err = return . Error - - extract (WordQuotedSkipPre s) = fmap (Done 0) $ fextract s - extract (WordUnquotedWord s) = fmap (Done 0) $ fextract s - extract (WordQuotedWord s n _ _) = - if n == 0 - then fmap (Done 0) $ fextract s - else err "wordWithQuotes: missing frame end" - extract WordQuotedEsc {} = - err "wordWithQuotes: trailing escape" - extract (WordUnquotedEsc _) = - err "wordWithQuotes: trailing escape" - extract (WordQuotedSkipPost b) = return (Done 0 b) - --- | 'wordWithQuotes' without processing the quotes and escape function --- supplied to escape the quote char within a quote. Can be used to parse words --- keeping the quotes and escapes intact. --- --- >>> wordKeepQuotes = Parser.wordWithQuotes True (\_ _ -> Nothing) --- -{-# INLINE wordKeepQuotes #-} -wordKeepQuotes :: (Monad m, Eq a) => - a -- ^ Escape char - -> (a -> Maybe a) -- ^ If left quote, return right quote, else Nothing. - -> (a -> Bool) -- ^ Matches a word separator? - -> Fold m a b - -> Parser a m b -wordKeepQuotes = - -- Escape the quote char itself - wordWithQuotes True (\q x -> if q == x then Just x else Nothing) - --- See the "Quoting Rules" section in the "bash" manual page for a primer on --- how quotes are used by shells. - --- | 'wordWithQuotes' with quote processing applied and escape function --- supplied to escape the quote char within a quote. Can be ysed to parse words --- and processing the quoting and escaping at the same time. --- --- >>> wordProcessQuotes = Parser.wordWithQuotes False (\_ _ -> Nothing) --- -{-# INLINE wordProcessQuotes #-} -wordProcessQuotes :: (Monad m, Eq a) => - a -- ^ Escape char - -> (a -> Maybe a) -- ^ If left quote, return right quote, else Nothing. - -> (a -> Bool) -- ^ Matches a word separator? - -> Fold m a b - -> Parser a m b -wordProcessQuotes = - -- Escape the quote char itself - wordWithQuotes False (\q x -> if q == x then Just x else Nothing) - -{-# ANN type GroupByState Fuse #-} -data GroupByState a s - = GroupByInit !s - | GroupByGrouping !a !s - --- | Given an input stream @[a,b,c,...]@ and a comparison function @cmp@, the --- parser assigns the element @a@ to the first group, then if @a \`cmp` b@ is --- 'True' @b@ is also assigned to the same group. If @a \`cmp` c@ is 'True' --- then @c@ is also assigned to the same group and so on. When the comparison --- fails the parser is terminated. Each group is folded using the 'Fold' @f@ and --- the result of the fold is the result of the parser. --- --- * Stops - when the comparison fails. --- * Fails - never. --- --- >>> :{ --- runGroupsBy eq = --- Stream.fold Fold.toList --- . Stream.parseMany (Parser.groupBy eq Fold.toList) --- . Stream.fromList --- :} --- --- >>> runGroupsBy (<) [] --- [] --- --- >>> runGroupsBy (<) [1] --- [Right [1]] --- --- >>> runGroupsBy (<) [3, 5, 4, 1, 2, 0] --- [Right [3,5,4],Right [1,2],Right [0]] --- -{-# INLINE groupBy #-} -groupBy :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser a m b -groupBy eq (Fold fstep finitial fextract) = Parser step initial extract - - where - - {-# INLINE grouper #-} - grouper s a0 a = do - res <- fstep s a - return - $ case res of - FL.Done b -> Done 0 b - FL.Partial s1 -> Partial 0 (GroupByGrouping a0 s1) - - initial = do - res <- finitial - return - $ case res of - FL.Partial s -> IPartial $ GroupByInit s - FL.Done b -> IDone b - - step (GroupByInit s) a = grouper s a a - step (GroupByGrouping a0 s) a = - if eq a0 a - then grouper s a0 a - else Done 1 <$> fextract s - - extract (GroupByInit s) = fmap (Done 0) $ fextract s - extract (GroupByGrouping _ s) = fmap (Done 0) $ fextract s - --- | Unlike 'groupBy' this combinator performs a rolling comparison of two --- successive elements in the input stream. Assuming the input stream --- is @[a,b,c,...]@ and the comparison function is @cmp@, the parser --- first assigns the element @a@ to the first group, then if @a \`cmp` b@ is --- 'True' @b@ is also assigned to the same group. If @b \`cmp` c@ is 'True' --- then @c@ is also assigned to the same group and so on. When the comparison --- fails the parser is terminated. Each group is folded using the 'Fold' @f@ and --- the result of the fold is the result of the parser. --- --- * Stops - when the comparison fails. --- * Fails - never. --- --- >>> :{ --- runGroupsByRolling eq = --- Stream.fold Fold.toList --- . Stream.parseMany (Parser.groupByRolling eq Fold.toList) --- . Stream.fromList --- :} --- --- >>> runGroupsByRolling (<) [] --- [] --- --- >>> runGroupsByRolling (<) [1] --- [Right [1]] --- --- >>> runGroupsByRolling (<) [3, 5, 4, 1, 2, 0] --- [Right [3,5],Right [4],Right [1,2],Right [0]] --- --- /Pre-release/ --- -{-# INLINE groupByRolling #-} -groupByRolling :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser a m b -groupByRolling eq (Fold fstep finitial fextract) = Parser step initial extract - - where - - {-# INLINE grouper #-} - grouper s a = do - res <- fstep s a - return - $ case res of - FL.Done b -> Done 0 b - FL.Partial s1 -> Partial 0 (GroupByGrouping a s1) - - initial = do - res <- finitial - return - $ case res of - FL.Partial s -> IPartial $ GroupByInit s - FL.Done b -> IDone b - - step (GroupByInit s) a = grouper s a - step (GroupByGrouping a0 s) a = - if eq a0 a - then grouper s a - else Done 1 <$> fextract s - - extract (GroupByInit s) = fmap (Done 0) $ fextract s - extract (GroupByGrouping _ s) = fmap (Done 0) $ fextract s - -{-# ANN type GroupByStatePair Fuse #-} -data GroupByStatePair a s1 s2 - = GroupByInitPair !s1 !s2 - | GroupByGroupingPair !a !s1 !s2 - | GroupByGroupingPairL !a !s1 !s2 - | GroupByGroupingPairR !a !s1 !s2 - --- | Like 'groupByRolling', but if the predicate is 'True' then collects using --- the first fold as long as the predicate holds 'True', if the predicate is --- 'False' collects using the second fold as long as it remains 'False'. --- Returns 'Left' for the first case and 'Right' for the second case. --- --- For example, if we want to detect sorted sequences in a stream, both --- ascending and descending cases we can use 'groupByRollingEither (<=) --- Fold.toList Fold.toList'. --- --- /Pre-release/ -{-# INLINE groupByRollingEither #-} -groupByRollingEither :: Monad m => - (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (Either b c) -groupByRollingEither - eq - (Fold fstep1 finitial1 fextract1) - (Fold fstep2 finitial2 fextract2) = Parser step initial extract - - where - - {-# INLINE grouper #-} - grouper s1 s2 a = do - return $ Continue 0 (GroupByGroupingPair a s1 s2) - - {-# INLINE grouperL2 #-} - grouperL2 s1 s2 a = do - res <- fstep1 s1 a - return - $ case res of - FL.Done b -> Done 0 (Left b) - FL.Partial s11 -> Partial 0 (GroupByGroupingPairL a s11 s2) - - {-# INLINE grouperL #-} - grouperL s1 s2 a0 a = do - res <- fstep1 s1 a0 - case res of - FL.Done b -> return $ Done 0 (Left b) - FL.Partial s11 -> grouperL2 s11 s2 a - - {-# INLINE grouperR2 #-} - grouperR2 s1 s2 a = do - res <- fstep2 s2 a - return - $ case res of - FL.Done b -> Done 0 (Right b) - FL.Partial s21 -> Partial 0 (GroupByGroupingPairR a s1 s21) - - {-# INLINE grouperR #-} - grouperR s1 s2 a0 a = do - res <- fstep2 s2 a0 - case res of - FL.Done b -> return $ Done 0 (Right b) - FL.Partial s21 -> grouperR2 s1 s21 a - - initial = do - res1 <- finitial1 - res2 <- finitial2 - return - $ case res1 of - FL.Partial s1 -> - case res2 of - FL.Partial s2 -> IPartial $ GroupByInitPair s1 s2 - FL.Done b -> IDone (Right b) - FL.Done b -> IDone (Left b) - - step (GroupByInitPair s1 s2) a = grouper s1 s2 a - - step (GroupByGroupingPair a0 s1 s2) a = - if not (eq a0 a) - then grouperL s1 s2 a0 a - else grouperR s1 s2 a0 a - - step (GroupByGroupingPairL a0 s1 s2) a = - if not (eq a0 a) - then grouperL2 s1 s2 a - else Done 1 . Left <$> fextract1 s1 - - step (GroupByGroupingPairR a0 s1 s2) a = - if eq a0 a - then grouperR2 s1 s2 a - else Done 1 . Right <$> fextract2 s2 - - extract (GroupByInitPair s1 _) = Done 0 . Left <$> fextract1 s1 - extract (GroupByGroupingPairL _ s1 _) = Done 0 . Left <$> fextract1 s1 - extract (GroupByGroupingPairR _ _ s2) = Done 0 . Right <$> fextract2 s2 - extract (GroupByGroupingPair a s1 _) = do - res <- fstep1 s1 a - case res of - FL.Done b -> return $ Done 0 (Left b) - FL.Partial s11 -> Done 0 . Left <$> fextract1 s11 - --- XXX use an Unfold instead of a list? --- XXX custom combinators for matching list, array and stream? --- XXX rename to listBy? - --- | Match the given sequence of elements using the given comparison function. --- Returns the original sequence if successful. --- --- Definition: --- --- >>> listEqBy cmp xs = Parser.streamEqBy cmp (Stream.fromList xs) *> Parser.fromPure xs --- --- Examples: --- --- >>> Stream.parse (Parser.listEqBy (==) "string") $ Stream.fromList "string" --- Right "string" --- --- >>> Stream.parse (Parser.listEqBy (==) "mismatch") $ Stream.fromList "match" --- Left (ParseError "streamEqBy: mismtach occurred") --- -{-# INLINE listEqBy #-} -listEqBy :: Monad m => (a -> a -> Bool) -> [a] -> Parser a m [a] -listEqBy cmp xs = streamEqByInternal cmp (D.fromList xs) *> fromPure xs -{- -listEqBy cmp str = Parser step initial extract - - where - - -- XXX Should return IDone in initial for [] case - initial = return $ IPartial str - - step [] _ = return $ Done 0 str - step [x] a = - return - $ if x `cmp` a - then Done 0 str - else Error "listEqBy: failed, yet to match the last element" - step (x:xs) a = - return - $ if x `cmp` a - then Continue 0 xs - else Error - $ "listEqBy: failed, yet to match " - ++ show (length xs + 1) ++ " elements" - - extract xs = - return - $ Error - $ "listEqBy: end of input, yet to match " - ++ show (length xs) ++ " elements" --} - -{-# INLINE streamEqByInternal #-} -streamEqByInternal :: Monad m => (a -> a -> Bool) -> D.Stream m a -> Parser a m () -streamEqByInternal cmp (D.Stream sstep state) = Parser step initial extract - - where - - initial = do - r <- sstep defState state - case r of - D.Yield x s -> return $ IPartial (Just' x, s) - D.Stop -> return $ IDone () - -- Need Skip/Continue in initial to loop right here - D.Skip s -> return $ IPartial (Nothing', s) - - step (Just' x, st) a = - if x `cmp` a - then do - r <- sstep defState st - return - $ case r of - D.Yield x1 s -> Continue 0 (Just' x1, s) - D.Stop -> Done 0 () - D.Skip s -> Continue 1 (Nothing', s) - else return $ Error "streamEqBy: mismtach occurred" - step (Nothing', st) a = do - r <- sstep defState st - return - $ case r of - D.Yield x s -> do - if x `cmp` a - then Continue 0 (Nothing', s) - else Error "streamEqBy: mismatch occurred" - D.Stop -> Done 1 () - D.Skip s -> Continue 1 (Nothing', s) - - extract _ = return $ Error "streamEqBy: end of input" - --- | Like 'listEqBy' but uses a stream instead of a list and does not return --- the stream. --- -{-# INLINE streamEqBy #-} -streamEqBy :: Monad m => (a -> a -> Bool) -> D.Stream m a -> Parser a m () --- XXX Somehow composing this with "*>" is much faster on the microbenchmark. --- Need to investigate why. -streamEqBy cmp stream = streamEqByInternal cmp stream *> fromPure () - --- Rename to "list". --- | Match the input sequence with the supplied list and return it if --- successful. --- --- >>> listEq = Parser.listEqBy (==) --- -{-# INLINE listEq #-} -listEq :: (Monad m, Eq a) => [a] -> Parser a m [a] -listEq = listEqBy (==) - --- | Match if the input stream is a subsequence of the argument stream i.e. all --- the elements of the input stream occur, in order, in the argument stream. --- The elements do not have to occur consecutively. A sequence is considered a --- subsequence of itself. -{-# INLINE subsequenceBy #-} -subsequenceBy :: -- Monad m => - (a -> a -> Bool) -> Stream m a -> Parser a m () -subsequenceBy = undefined - -{- --- Should go in Data.Parser.Regex in streamly package so that it can depend on --- regex backends. -{-# INLINE regexPosix #-} -regexPosix :: -- Monad m => - Regex -> Parser m a (Maybe (Array (MatchOffset, MatchLength))) -regexPosix = undefined - -{-# INLINE regexPCRE #-} -regexPCRE :: -- Monad m => - Regex -> Parser m a (Maybe (Array (MatchOffset, MatchLength))) -regexPCRE = undefined --} - -------------------------------------------------------------------------------- --- Transformations on input -------------------------------------------------------------------------------- - --- Initial needs a "Continue" constructor to implement scans on parsers. As a --- parser can always return a Continue in initial when we feed the fold's --- initial result to it. We can work this around for postscan by introducing an --- initial state and calling "initial" only on the first input. - --- | Stateful scan on the input of a parser using a Fold. --- --- /Unimplemented/ --- -{-# INLINE postscan #-} -postscan :: -- Monad m => - Fold m a b -> Parser b m c -> Parser a m c -postscan = undefined - -{-# INLINE zipWithM #-} -zipWithM :: Monad m => - (a -> b -> m c) -> D.Stream m a -> Fold m c x -> Parser b m x -zipWithM zf (D.Stream sstep state) (Fold fstep finitial fextract) = - Parser step initial extract - - where - - initial = do - fres <- finitial - case fres of - FL.Partial fs -> do - r <- sstep defState state - case r of - D.Yield x s -> return $ IPartial (Just' x, s, fs) - D.Stop -> do - x <- fextract fs - return $ IDone x - -- Need Skip/Continue in initial to loop right here - D.Skip s -> return $ IPartial (Nothing', s, fs) - FL.Done x -> return $ IDone x - - step (Just' a, st, fs) b = do - c <- zf a b - fres <- fstep fs c - case fres of - FL.Partial fs1 -> do - r <- sstep defState st - case r of - D.Yield x1 s -> return $ Continue 0 (Just' x1, s, fs1) - D.Stop -> do - x <- fextract fs1 - return $ Done 0 x - D.Skip s -> return $ Continue 1 (Nothing', s, fs1) - FL.Done x -> return $ Done 0 x - step (Nothing', st, fs) b = do - r <- sstep defState st - case r of - D.Yield a s -> do - c <- zf a b - fres <- fstep fs c - case fres of - FL.Partial fs1 -> - return $ Continue 0 (Nothing', s, fs1) - FL.Done x -> return $ Done 0 x - D.Stop -> do - x <- fextract fs - return $ Done 1 x - D.Skip s -> return $ Continue 1 (Nothing', s, fs) - - extract _ = return $ Error "zipWithM: end of input" - --- | Zip the input of a fold with a stream. --- --- /Pre-release/ --- -{-# INLINE zip #-} -zip :: Monad m => D.Stream m a -> Fold m (a, b) x -> Parser b m x -zip = zipWithM (curry return) - --- | Pair each element of a fold input with its index, starting from index 0. --- --- /Pre-release/ -{-# INLINE indexed #-} -indexed :: forall m a b. Monad m => Fold m (Int, a) b -> Parser a m b -indexed = zip (D.enumerateFromIntegral 0 :: D.Stream m Int) - --- | @makeIndexFilter indexer filter predicate@ generates a fold filtering --- function using a fold indexing function that attaches an index to each input --- element and a filtering function that filters using @(index, element) -> --- Bool) as predicate. --- --- For example: --- --- @ --- filterWithIndex = makeIndexFilter indexed filter --- filterWithAbsTime = makeIndexFilter timestamped filter --- filterWithRelTime = makeIndexFilter timeIndexed filter --- @ --- --- /Pre-release/ -{-# INLINE makeIndexFilter #-} -makeIndexFilter :: - (Fold m (s, a) b -> Parser a m b) - -> (((s, a) -> Bool) -> Fold m (s, a) b -> Fold m (s, a) b) - -> (((s, a) -> Bool) -> Fold m a b -> Parser a m b) -makeIndexFilter f comb g = f . comb g . FL.lmap snd - --- | @sampleFromthen offset stride@ samples the element at @offset@ index and --- then every element at strides of @stride@. --- --- /Pre-release/ -{-# INLINE sampleFromthen #-} -sampleFromthen :: Monad m => Int -> Int -> Fold m a b -> Parser a m b -sampleFromthen offset size = - makeIndexFilter indexed FL.filter (\(i, _) -> (i + offset) `mod` size == 0) - --------------------------------------------------------------------------------- ---- Spanning --------------------------------------------------------------------------------- - --- | @span p f1 f2@ composes folds @f1@ and @f2@ such that @f1@ consumes the --- input as long as the predicate @p@ is 'True'. @f2@ consumes the rest of the --- input. --- --- @ --- > let span_ p xs = Stream.parse (Parser.span p Fold.toList Fold.toList) $ Stream.fromList xs --- --- > span_ (< 1) [1,2,3] --- ([],[1,2,3]) --- --- > span_ (< 2) [1,2,3] --- ([1],[2,3]) --- --- > span_ (< 4) [1,2,3] --- ([1,2,3],[]) --- --- @ --- --- /Pre-release/ -{-# INLINE span #-} -span :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (b, c) -span p f1 f2 = noErrorUnsafeSplitWith (,) (takeWhile p f1) (fromFold f2) - --- | Break the input stream into two groups, the first group takes the input as --- long as the predicate applied to the first element of the stream and next --- input element holds 'True', the second group takes the rest of the input. --- --- /Pre-release/ --- -{-# INLINE spanBy #-} -spanBy :: - Monad m - => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (b, c) -spanBy eq f1 f2 = noErrorUnsafeSplitWith (,) (groupBy eq f1) (fromFold f2) - --- | Like 'spanBy' but applies the predicate in a rolling fashion i.e. --- predicate is applied to the previous and the next input elements. --- --- /Pre-release/ -{-# INLINE spanByRolling #-} -spanByRolling :: - Monad m - => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser a m (b, c) -spanByRolling eq f1 f2 = - noErrorUnsafeSplitWith (,) (groupByRolling eq f1) (fromFold f2) - -------------------------------------------------------------------------------- --- nested parsers -------------------------------------------------------------------------------- - --- | Takes at-most @n@ input elements. --- --- * Stops - when the collecting parser stops. --- * Fails - when the collecting parser fails. --- --- >>> Stream.parse (Parser.takeP 4 (Parser.takeEQ 2 Fold.toList)) $ Stream.fromList [1, 2, 3, 4, 5] --- Right [1,2] --- --- >>> Stream.parse (Parser.takeP 4 (Parser.takeEQ 5 Fold.toList)) $ Stream.fromList [1, 2, 3, 4, 5] --- Left (ParseError "takeEQ: Expecting exactly 5 elements, input terminated on 4") --- --- /Internal/ -{-# INLINE takeP #-} -takeP :: Monad m => Int -> Parser a m b -> Parser a m b -takeP lim (Parser pstep pinitial pextract) = Parser step initial extract - - where - - initial = do - res <- pinitial - case res of - IPartial s -> - if lim > 0 - then return $ IPartial $ Tuple' 0 s - else iextract s - IDone b -> return $ IDone b - IError e -> return $ IError e - - step (Tuple' cnt r) a = do - assertM(cnt < lim) - res <- pstep r a - let cnt1 = cnt + 1 - case res of - Partial 0 s -> do - assertM(cnt1 >= 0) - if cnt1 < lim - then return $ Partial 0 $ Tuple' cnt1 s - else do - r1 <- pextract s - return $ case r1 of - Done n b -> Done n b - Continue n s1 -> Continue n (Tuple' (cnt1 - n) s1) - Error err -> Error err - Partial _ _ -> error "takeP: Partial in extract" - - Continue 0 s -> do - assertM(cnt1 >= 0) - if cnt1 < lim - then return $ Continue 0 $ Tuple' cnt1 s - else do - r1 <- pextract s - return $ case r1 of - Done n b -> Done n b - Continue n s1 -> Continue n (Tuple' (cnt1 - n) s1) - Error err -> Error err - Partial _ _ -> error "takeP: Partial in extract" - Partial n s -> do - let taken = cnt1 - n - assertM(taken >= 0) - return $ Partial n $ Tuple' taken s - Continue n s -> do - let taken = cnt1 - n - assertM(taken >= 0) - return $ Continue n $ Tuple' taken s - Done n b -> return $ Done n b - Error str -> return $ Error str - - extract (Tuple' cnt r) = do - r1 <- pextract r - return $ case r1 of - Done n b -> Done n b - Continue n s1 -> Continue n (Tuple' (cnt - n) s1) - Error err -> Error err - Partial _ _ -> error "takeP: Partial in extract" - - -- XXX Need to make the Initial type Step to remove this - iextract s = do - r <- pextract s - return $ case r of - Done _ b -> IDone b - Error err -> IError err - _ -> error "Bug: takeP invalid state in initial" - --- | Run a parser without consuming the input. --- -{-# INLINE lookAhead #-} -lookAhead :: Monad m => Parser a m b -> Parser a m b -lookAhead (Parser step1 initial1 _) = Parser step initial extract - - where - - initial = do - res <- initial1 - return $ case res of - IPartial s -> IPartial (Tuple'Fused 0 s) - IDone b -> IDone b - IError e -> IError e - - step (Tuple'Fused cnt st) a = do - r <- step1 st a - let cnt1 = cnt + 1 - return - $ case r of - Partial n s -> Continue n (Tuple'Fused (cnt1 - n) s) - Continue n s -> Continue n (Tuple'Fused (cnt1 - n) s) - Done _ b -> Done cnt1 b - Error err -> Error err - - -- XXX returning an error let's us backtrack. To implement it in a way so - -- that it terminates on eof without an error then we need a way to - -- backtrack on eof, that will require extract to return 'Step' type. - extract (Tuple'Fused n _) = - return - $ Error - $ "lookAhead: end of input after consuming " - ++ show n ++ " elements" - -------------------------------------------------------------------------------- --- Interleaving -------------------------------------------------------------------------------- --- --- To deinterleave we can chain two parsers one behind the other. The input is --- given to the first parser and the input definitively rejected by the first --- parser is given to the second parser. --- --- We can either have the parsers themselves buffer the input or use the shared --- global buffer to hold it until none of the parsers need it. When the first --- parser returns Skip (i.e. rewind) we let the second parser consume the --- rejected input and when it is done we move the cursor forward to the first --- parser again. This will require a "move forward" command as well. --- --- To implement grep we can use three parsers, one to find the pattern, one --- to store the context behind the pattern and one to store the context in --- front of the pattern. When a match occurs we need to emit the accumulator of --- all the three parsers. One parser can count the line numbers to provide the --- line number info. - -{-# ANN type DeintercalateAllState Fuse #-} -data DeintercalateAllState fs sp ss = - DeintercalateAllInitL !fs - | DeintercalateAllL !fs !sp - | DeintercalateAllInitR !fs - | DeintercalateAllR !fs !ss - --- XXX rename this to intercalate - --- Having deintercalateAll for accepting or rejecting entire input could be --- useful. For example, in case of JSON parsing we get an entire block of --- key-value pairs which we need to verify. This version may be simpler, more --- efficient. We could implement this as a stream operation like parseMany. --- --- XXX Also, it may be a good idea to provide a parse driver for a fold. For --- example, in case of csv parsing as we are feeding a line to a fold we can --- parse it. - --- | Like 'deintercalate' but the entire input must satisfy the pattern --- otherwise the parser fails. This is many times faster than deintercalate. --- --- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList --- >>> p2 = Parser.satisfy (== '+') --- >>> p = Parser.deintercalateAll p1 p2 Fold.toList --- >>> Stream.parse p $ Stream.fromList "" --- Right [] --- >>> Stream.parse p $ Stream.fromList "1" --- Right [Left "1"] --- >>> Stream.parse p $ Stream.fromList "1+" --- Left (ParseError "takeWhile1: end of input") --- >>> Stream.parse p $ Stream.fromList "1+2+3" --- Right [Left "1",Right '+',Left "2",Right '+',Left "3"] --- -{-# INLINE deintercalateAll #-} -deintercalateAll :: Monad m => - Parser a m x - -> Parser a m y - -> Fold m (Either x y) z - -> Parser a m z -deintercalateAll - (Parser stepL initialL extractL) - (Parser stepR initialR _) - (Fold fstep finitial fextract) = Parser step initial extract - - where - - errMsg p status = - error $ "deintercalate: " ++ p ++ " parser cannot " - ++ status ++ " without input" - - initial = do - res <- finitial - case res of - FL.Partial fs -> return $ IPartial $ DeintercalateAllInitL fs - FL.Done c -> return $ IDone c - - {-# INLINE processL #-} - processL foldAction n nextState = do - fres <- foldAction - case fres of - FL.Partial fs1 -> return $ Partial n (nextState fs1) - FL.Done c -> return $ Done n c - - {-# INLINE runStepL #-} - runStepL fs sL a = do - r <- stepL sL a - case r of - Partial n s -> return $ Partial n (DeintercalateAllL fs s) - Continue n s -> return $ Continue n (DeintercalateAllL fs s) - Done n b -> - processL (fstep fs (Left b)) n DeintercalateAllInitR - Error err -> return $ Error err - - {-# INLINE processR #-} - processR foldAction n = do - fres <- foldAction - case fres of - FL.Partial fs1 -> do - res <- initialL - case res of - IPartial ps -> return $ Partial n (DeintercalateAllL fs1 ps) - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - FL.Done c -> return $ Done n c - - {-# INLINE runStepR #-} - runStepR fs sR a = do - r <- stepR sR a - case r of - Partial n s -> return $ Partial n (DeintercalateAllR fs s) - Continue n s -> return $ Continue n (DeintercalateAllR fs s) - Done n b -> processR (fstep fs (Right b)) n - Error err -> return $ Error err - - step (DeintercalateAllInitL fs) a = do - res <- initialL - case res of - IPartial s -> runStepL fs s a - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - step (DeintercalateAllL fs sL) a = runStepL fs sL a - step (DeintercalateAllInitR fs) a = do - res <- initialR - case res of - IPartial s -> runStepR fs s a - IDone _ -> errMsg "right" "succeed" - IError _ -> errMsg "right" "fail" - step (DeintercalateAllR fs sR) a = runStepR fs sR a - - {-# INLINE extractResult #-} - extractResult n fs r = do - res <- fstep fs r - case res of - FL.Partial fs1 -> fmap (Done n) $ fextract fs1 - FL.Done c -> return (Done n c) - extract (DeintercalateAllInitL fs) = fmap (Done 0) $ fextract fs - extract (DeintercalateAllL fs sL) = do - r <- extractL sL - case r of - Done n b -> extractResult n fs (Left b) - Error err -> return $ Error err - Continue n s -> return $ Continue n (DeintercalateAllL fs s) - Partial _ _ -> error "Partial in extract" - extract (DeintercalateAllInitR fs) = fmap (Done 0) $ fextract fs - extract (DeintercalateAllR _ _) = - return $ Error "deintercalateAll: input ended at 'Right' value" - -{-# ANN type DeintercalateState Fuse #-} -data DeintercalateState b fs sp ss = - DeintercalateInitL !fs - | DeintercalateL !Int !fs !sp - | DeintercalateInitR !fs - | DeintercalateR !Int !fs !ss - | DeintercalateRL !Int !b !fs !sp - --- XXX Add tests that the next character that we take after running a parser is --- correct. Especially for the parsers that maintain a count. In the stream --- finished case (extract) as well as not finished case. - --- | Apply two parsers alternately to an input stream. The input stream is --- considered an interleaving of two patterns. The two parsers represent the --- two patterns. Parsing starts at the first parser and stops at the first --- parser. It can be used to parse a infix style pattern e.g. p1 p2 p1 . Empty --- input or single parse of the first parser is accepted. --- --- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList --- >>> p2 = Parser.satisfy (== '+') --- >>> p = Parser.deintercalate p1 p2 Fold.toList --- >>> Stream.parse p $ Stream.fromList "" --- Right [] --- >>> Stream.parse p $ Stream.fromList "1" --- Right [Left "1"] --- >>> Stream.parse p $ Stream.fromList "1+" --- Right [Left "1"] --- >>> Stream.parse p $ Stream.fromList "1+2+3" --- Right [Left "1",Right '+',Left "2",Right '+',Left "3"] --- -{-# INLINE deintercalate #-} -deintercalate :: Monad m => - Parser a m x - -> Parser a m y - -> Fold m (Either x y) z - -> Parser a m z -deintercalate - (Parser stepL initialL extractL) - (Parser stepR initialR _) - (Fold fstep finitial fextract) = Parser step initial extract - - where - - errMsg p status = - error $ "deintercalate: " ++ p ++ " parser cannot " - ++ status ++ " without input" - - initial = do - res <- finitial - case res of - FL.Partial fs -> return $ IPartial $ DeintercalateInitL fs - FL.Done c -> return $ IDone c - - {-# INLINE processL #-} - processL foldAction n nextState = do - fres <- foldAction - case fres of - FL.Partial fs1 -> return $ Partial n (nextState fs1) - FL.Done c -> return $ Done n c - - {-# INLINE runStepL #-} - runStepL cnt fs sL a = do - let cnt1 = cnt + 1 - r <- stepL sL a - case r of - Partial n s -> return $ Continue n (DeintercalateL (cnt1 - n) fs s) - Continue n s -> return $ Continue n (DeintercalateL (cnt1 - n) fs s) - Done n b -> - processL (fstep fs (Left b)) n DeintercalateInitR - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - {-# INLINE processR #-} - processR cnt b fs n = do - res <- initialL - case res of - IPartial ps -> return $ Continue n (DeintercalateRL cnt b fs ps) - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - - {-# INLINE runStepR #-} - runStepR cnt fs sR a = do - let cnt1 = cnt + 1 - r <- stepR sR a - case r of - Partial n s -> return $ Continue n (DeintercalateR (cnt1 - n) fs s) - Continue n s -> return $ Continue n (DeintercalateR (cnt1 - n) fs s) - Done n b -> processR (cnt1 - n) b fs n - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - step (DeintercalateInitL fs) a = do - res <- initialL - case res of - IPartial s -> runStepL 0 fs s a - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - step (DeintercalateL cnt fs sL) a = runStepL cnt fs sL a - step (DeintercalateInitR fs) a = do - res <- initialR - case res of - IPartial s -> runStepR 0 fs s a - IDone _ -> errMsg "right" "succeed" - IError _ -> errMsg "right" "fail" - step (DeintercalateR cnt fs sR) a = runStepR cnt fs sR a - step (DeintercalateRL cnt bR fs sL) a = do - let cnt1 = cnt + 1 - r <- stepL sL a - case r of - Partial n s -> return $ Continue n (DeintercalateRL (cnt1 - n) bR fs s) - Continue n s -> return $ Continue n (DeintercalateRL (cnt1 - n) bR fs s) - Done n bL -> do - res <- fstep fs (Right bR) - case res of - FL.Partial fs1 -> do - fres <- fstep fs1 (Left bL) - case fres of - FL.Partial fs2 -> - return $ Partial n (DeintercalateInitR fs2) - FL.Done c -> return $ Done n c - -- XXX We could have the fold accept pairs of (bR, bL) - FL.Done _ -> error "Fold terminated consuming partial input" - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - {-# INLINE extractResult #-} - extractResult n fs r = do - res <- fstep fs r - case res of - FL.Partial fs1 -> fmap (Done n) $ fextract fs1 - FL.Done c -> return (Done n c) - - extract (DeintercalateInitL fs) = fmap (Done 0) $ fextract fs - extract (DeintercalateL cnt fs sL) = do - r <- extractL sL - case r of - Done n b -> extractResult n fs (Left b) - Continue n s -> return $ Continue n (DeintercalateL (cnt - n) fs s) - Partial _ _ -> error "Partial in extract" - Error _ -> do - xs <- fextract fs - return $ Done cnt xs - extract (DeintercalateInitR fs) = fmap (Done 0) $ fextract fs - extract (DeintercalateR cnt fs _) = fmap (Done cnt) $ fextract fs - extract (DeintercalateRL cnt bR fs sL) = do - r <- extractL sL - case r of - Done n bL -> do - res <- fstep fs (Right bR) - case res of - FL.Partial fs1 -> extractResult n fs1 (Left bL) - FL.Done _ -> error "Fold terminated consuming partial input" - Continue n s -> return $ Continue n (DeintercalateRL (cnt - n) bR fs s) - Partial _ _ -> error "Partial in extract" - Error _ -> do - xs <- fextract fs - return $ Done cnt xs - -{-# ANN type Deintercalate1State Fuse #-} -data Deintercalate1State b fs sp ss = - Deintercalate1InitL !Int !fs !sp - | Deintercalate1InitR !fs - | Deintercalate1R !Int !fs !ss - | Deintercalate1RL !Int !b !fs !sp - --- | Apply two parsers alternately to an input stream. The input stream is --- considered an interleaving of two patterns. The two parsers represent the --- two patterns. Parsing starts at the first parser and stops at the first --- parser. It can be used to parse a infix style pattern e.g. p1 p2 p1 . Empty --- input or single parse of the first parser is accepted. --- --- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList --- >>> p2 = Parser.satisfy (== '+') --- >>> p = Parser.deintercalate1 p1 p2 Fold.toList --- >>> Stream.parse p $ Stream.fromList "" --- Left (ParseError "takeWhile1: end of input") --- >>> Stream.parse p $ Stream.fromList "1" --- Right [Left "1"] --- >>> Stream.parse p $ Stream.fromList "1+" --- Right [Left "1"] --- >>> Stream.parse p $ Stream.fromList "1+2+3" --- Right [Left "1",Right '+',Left "2",Right '+',Left "3"] --- -{-# INLINE deintercalate1 #-} -deintercalate1 :: Monad m => - Parser a m x - -> Parser a m y - -> Fold m (Either x y) z - -> Parser a m z -deintercalate1 - (Parser stepL initialL extractL) - (Parser stepR initialR _) - (Fold fstep finitial fextract) = Parser step initial extract - - where - - errMsg p status = - error $ "deintercalate: " ++ p ++ " parser cannot " - ++ status ++ " without input" - - initial = do - res <- finitial - case res of - FL.Partial fs -> do - pres <- initialL - case pres of - IPartial s -> return $ IPartial $ Deintercalate1InitL 0 fs s - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - FL.Done c -> return $ IDone c - - {-# INLINE processL #-} - processL foldAction n nextState = do - fres <- foldAction - case fres of - FL.Partial fs1 -> return $ Partial n (nextState fs1) - FL.Done c -> return $ Done n c - - {-# INLINE runStepInitL #-} - runStepInitL cnt fs sL a = do - let cnt1 = cnt + 1 - r <- stepL sL a - case r of - Partial n s -> return $ Continue n (Deintercalate1InitL (cnt1 - n) fs s) - Continue n s -> return $ Continue n (Deintercalate1InitL (cnt1 - n) fs s) - Done n b -> - processL (fstep fs (Left b)) n Deintercalate1InitR - Error err -> return $ Error err - - {-# INLINE processR #-} - processR cnt b fs n = do - res <- initialL - case res of - IPartial ps -> return $ Continue n (Deintercalate1RL cnt b fs ps) - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - - {-# INLINE runStepR #-} - runStepR cnt fs sR a = do - let cnt1 = cnt + 1 - r <- stepR sR a - case r of - Partial n s -> return $ Continue n (Deintercalate1R (cnt1 - n) fs s) - Continue n s -> return $ Continue n (Deintercalate1R (cnt1 - n) fs s) - Done n b -> processR (cnt1 - n) b fs n - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - step (Deintercalate1InitL cnt fs sL) a = runStepInitL cnt fs sL a - step (Deintercalate1InitR fs) a = do - res <- initialR - case res of - IPartial s -> runStepR 0 fs s a - IDone _ -> errMsg "right" "succeed" - IError _ -> errMsg "right" "fail" - step (Deintercalate1R cnt fs sR) a = runStepR cnt fs sR a - step (Deintercalate1RL cnt bR fs sL) a = do - let cnt1 = cnt + 1 - r <- stepL sL a - case r of - Partial n s -> return $ Continue n (Deintercalate1RL (cnt1 - n) bR fs s) - Continue n s -> return $ Continue n (Deintercalate1RL (cnt1 - n) bR fs s) - Done n bL -> do - res <- fstep fs (Right bR) - case res of - FL.Partial fs1 -> do - fres <- fstep fs1 (Left bL) - case fres of - FL.Partial fs2 -> - return $ Partial n (Deintercalate1InitR fs2) - FL.Done c -> return $ Done n c - -- XXX We could have the fold accept pairs of (bR, bL) - FL.Done _ -> error "Fold terminated consuming partial input" - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - {-# INLINE extractResult #-} - extractResult n fs r = do - res <- fstep fs r - case res of - FL.Partial fs1 -> fmap (Done n) $ fextract fs1 - FL.Done c -> return (Done n c) - - extract (Deintercalate1InitL cnt fs sL) = do - r <- extractL sL - case r of - Done n b -> extractResult n fs (Left b) - Continue n s -> return $ Continue n (Deintercalate1InitL (cnt - n) fs s) - Partial _ _ -> error "Partial in extract" - Error err -> return $ Error err - extract (Deintercalate1InitR fs) = fmap (Done 0) $ fextract fs - extract (Deintercalate1R cnt fs _) = fmap (Done cnt) $ fextract fs - extract (Deintercalate1RL cnt bR fs sL) = do - r <- extractL sL - case r of - Done n bL -> do - res <- fstep fs (Right bR) - case res of - FL.Partial fs1 -> extractResult n fs1 (Left bL) - FL.Done _ -> error "Fold terminated consuming partial input" - Continue n s -> return $ Continue n (Deintercalate1RL (cnt - n) bR fs s) - Partial _ _ -> error "Partial in extract" - Error _ -> do - xs <- fextract fs - return $ Done cnt xs - -{-# ANN type SepByState Fuse #-} -data SepByState fs sp ss = - SepByInitL !fs - | SepByL !Int !fs !sp - | SepByInitR !fs - | SepByR !Int !fs !ss - --- | Apply two parsers alternately to an input stream. Parsing starts at the --- first parser and stops at the first parser. The output of the first parser --- is emiited and the output of the second parser is discarded. It can be used --- to parse a infix style pattern e.g. p1 p2 p1 . Empty input or single parse --- of the first parser is accepted. --- --- Definitions: --- --- >>> sepBy p1 p2 f = Parser.deintercalate p1 p2 (Fold.catLefts f) --- >>> sepBy p1 p2 f = Parser.sepBy1 p1 p2 f <|> Parser.fromEffect (Fold.extractM f) --- --- Examples: --- --- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList --- >>> p2 = Parser.satisfy (== '+') --- >>> p = Parser.sepBy p1 p2 Fold.toList --- >>> Stream.parse p $ Stream.fromList "" --- Right [] --- >>> Stream.parse p $ Stream.fromList "1" --- Right ["1"] --- >>> Stream.parse p $ Stream.fromList "1+" --- Right ["1"] --- >>> Stream.parse p $ Stream.fromList "1+2+3" --- Right ["1","2","3"] --- -{-# INLINE sepBy #-} -sepBy :: Monad m => - Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c --- This has similar performance as the custom impl below. --- sepBy p1 p2 f = deintercalate p1 p2 (FL.catLefts f) -sepBy - (Parser stepL initialL extractL) - (Parser stepR initialR _) - (Fold fstep finitial fextract) = Parser step initial extract - - where - - errMsg p status = - error $ "sepBy: " ++ p ++ " parser cannot " - ++ status ++ " without input" - - initial = do - res <- finitial - case res of - FL.Partial fs -> return $ IPartial $ SepByInitL fs - FL.Done c -> return $ IDone c - - {-# INLINE processL #-} - processL foldAction n nextState = do - fres <- foldAction - case fres of - FL.Partial fs1 -> return $ Partial n (nextState fs1) - FL.Done c -> return $ Done n c - - {-# INLINE runStepL #-} - runStepL cnt fs sL a = do - let cnt1 = cnt + 1 - r <- stepL sL a - case r of - Partial n s -> return $ Continue n (SepByL (cnt1 - n) fs s) - Continue n s -> return $ Continue n (SepByL (cnt1 - n) fs s) - Done n b -> - processL (fstep fs b) n SepByInitR - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - {-# INLINE processR #-} - processR cnt fs n = do - res <- initialL - case res of - IPartial ps -> return $ Continue n (SepByL cnt fs ps) - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - - {-# INLINE runStepR #-} - runStepR cnt fs sR a = do - let cnt1 = cnt + 1 - r <- stepR sR a - case r of - Partial n s -> return $ Continue n (SepByR (cnt1 - n) fs s) - Continue n s -> return $ Continue n (SepByR (cnt1 - n) fs s) - Done n _ -> processR (cnt1 - n) fs n - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - step (SepByInitL fs) a = do - res <- initialL - case res of - IPartial s -> runStepL 0 fs s a - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - step (SepByL cnt fs sL) a = runStepL cnt fs sL a - step (SepByInitR fs) a = do - res <- initialR - case res of - IPartial s -> runStepR 0 fs s a - IDone _ -> errMsg "right" "succeed" - IError _ -> errMsg "right" "fail" - step (SepByR cnt fs sR) a = runStepR cnt fs sR a - - {-# INLINE extractResult #-} - extractResult n fs r = do - res <- fstep fs r - case res of - FL.Partial fs1 -> fmap (Done n) $ fextract fs1 - FL.Done c -> return (Done n c) - - extract (SepByInitL fs) = fmap (Done 0) $ fextract fs - extract (SepByL cnt fs sL) = do - r <- extractL sL - case r of - Done n b -> extractResult n fs b - Continue n s -> return $ Continue n (SepByL (cnt - n) fs s) - Partial _ _ -> error "Partial in extract" - Error _ -> do - xs <- fextract fs - return $ Done cnt xs - extract (SepByInitR fs) = fmap (Done 0) $ fextract fs - extract (SepByR cnt fs _) = fmap (Done cnt) $ fextract fs - --- | Non-backtracking version of sepBy. Several times faster. -{-# INLINE sepByAll #-} -sepByAll :: Monad m => - Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c -sepByAll p1 p2 f = deintercalateAll p1 p2 (FL.catLefts f) - --- XXX This can be implemented using refold, parse one and then continue --- collecting the rest in that. - -{-# ANN type SepBy1State Fuse #-} -data SepBy1State fs sp ss = - SepBy1InitL !Int !fs sp - | SepBy1L !Int !fs !sp - | SepBy1InitR !fs - | SepBy1R !Int !fs !ss - -{- -{-# INLINE sepBy1 #-} -sepBy1 :: Monad m => - Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c -sepBy1 p sep sink = do - x <- p - f <- fromEffect $ FL.reduce sink - f1 <- fromEffect $ FL.snoc f x - many (sep >> p) f1 --} - --- | Like 'sepBy' but requires at least one successful parse. --- --- Definition: --- --- >>> sepBy1 p1 p2 f = Parser.deintercalate1 p1 p2 (Fold.catLefts f) --- --- Examples: --- --- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList --- >>> p2 = Parser.satisfy (== '+') --- >>> p = Parser.sepBy1 p1 p2 Fold.toList --- >>> Stream.parse p $ Stream.fromList "" --- Left (ParseError "takeWhile1: end of input") --- >>> Stream.parse p $ Stream.fromList "1" --- Right ["1"] --- >>> Stream.parse p $ Stream.fromList "1+" --- Right ["1"] --- >>> Stream.parse p $ Stream.fromList "1+2+3" --- Right ["1","2","3"] --- -{-# INLINE sepBy1 #-} -sepBy1 :: Monad m => - Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c -sepBy1 - (Parser stepL initialL extractL) - (Parser stepR initialR _) - (Fold fstep finitial fextract) = Parser step initial extract - - where - - errMsg p status = - error $ "sepBy: " ++ p ++ " parser cannot " - ++ status ++ " without input" - - initial = do - res <- finitial - case res of - FL.Partial fs -> do - pres <- initialL - case pres of - IPartial s -> return $ IPartial $ SepBy1InitL 0 fs s - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - FL.Done c -> return $ IDone c - - {-# INLINE processL #-} - processL foldAction n nextState = do - fres <- foldAction - case fres of - FL.Partial fs1 -> return $ Partial n (nextState fs1) - FL.Done c -> return $ Done n c - - {-# INLINE runStepInitL #-} - runStepInitL cnt fs sL a = do - let cnt1 = cnt + 1 - r <- stepL sL a - case r of - Partial n s -> return $ Continue n (SepBy1InitL (cnt1 - n) fs s) - Continue n s -> return $ Continue n (SepBy1InitL (cnt1 - n) fs s) - Done n b -> - processL (fstep fs b) n SepBy1InitR - Error err -> return $ Error err - - {-# INLINE runStepL #-} - runStepL cnt fs sL a = do - let cnt1 = cnt + 1 - r <- stepL sL a - case r of - Partial n s -> return $ Continue n (SepBy1L (cnt1 - n) fs s) - Continue n s -> return $ Continue n (SepBy1L (cnt1 - n) fs s) - Done n b -> - processL (fstep fs b) n SepBy1InitR - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - {-# INLINE processR #-} - processR cnt fs n = do - res <- initialL - case res of - IPartial ps -> return $ Continue n (SepBy1L cnt fs ps) - IDone _ -> errMsg "left" "succeed" - IError _ -> errMsg "left" "fail" - - {-# INLINE runStepR #-} - runStepR cnt fs sR a = do - let cnt1 = cnt + 1 - r <- stepR sR a - case r of - Partial n s -> return $ Continue n (SepBy1R (cnt1 - n) fs s) - Continue n s -> return $ Continue n (SepBy1R (cnt1 - n) fs s) - Done n _ -> processR (cnt1 - n) fs n - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - step (SepBy1InitL cnt fs sL) a = runStepInitL cnt fs sL a - step (SepBy1L cnt fs sL) a = runStepL cnt fs sL a - step (SepBy1InitR fs) a = do - res <- initialR - case res of - IPartial s -> runStepR 0 fs s a - IDone _ -> errMsg "right" "succeed" - IError _ -> errMsg "right" "fail" - step (SepBy1R cnt fs sR) a = runStepR cnt fs sR a - - {-# INLINE extractResult #-} - extractResult n fs r = do - res <- fstep fs r - case res of - FL.Partial fs1 -> fmap (Done n) $ fextract fs1 - FL.Done c -> return (Done n c) - - extract (SepBy1InitL cnt fs sL) = do - r <- extractL sL - case r of - Done n b -> extractResult n fs b - Continue n s -> return $ Continue n (SepBy1InitL (cnt - n) fs s) - Partial _ _ -> error "Partial in extract" - Error err -> return $ Error err - extract (SepBy1L cnt fs sL) = do - r <- extractL sL - case r of - Done n b -> extractResult n fs b - Continue n s -> return $ Continue n (SepBy1L (cnt - n) fs s) - Partial _ _ -> error "Partial in extract" - Error _ -> do - xs <- fextract fs - return $ Done cnt xs - extract (SepBy1InitR fs) = fmap (Done 0) $ fextract fs - extract (SepBy1R cnt fs _) = fmap (Done cnt) $ fextract fs - -------------------------------------------------------------------------------- --- Interleaving a collection of parsers -------------------------------------------------------------------------------- --- --- | Apply a collection of parsers to an input stream in a round robin fashion. --- Each parser is applied until it stops and then we repeat starting with the --- the first parser again. --- --- /Unimplemented/ --- -{-# INLINE roundRobin #-} -roundRobin :: -- (Foldable t, Monad m) => - t (Parser a m b) -> Fold m b c -> Parser a m c -roundRobin _ps _f = undefined - -------------------------------------------------------------------------------- --- Sequential Collection -------------------------------------------------------------------------------- - --- | @sequence f p@ collects sequential parses of parsers in a --- serial stream @p@ using the fold @f@. Fails if the input ends or any --- of the parsers fail. --- --- /Pre-release/ --- -{-# INLINE sequence #-} -sequence :: Monad m => - D.Stream m (Parser a m b) -> Fold m b c -> Parser a m c -sequence (D.Stream sstep sstate) (Fold fstep finitial fextract) = - Parser step initial extract - - where - - initial = do - fres <- finitial - case fres of - FL.Partial fs -> return $ IPartial (Nothing', sstate, fs) - FL.Done c -> return $ IDone c - - -- state does not contain any parser - -- yield a new parser from the stream - step (Nothing', ss, fs) _ = do - sres <- sstep defState ss - case sres of - D.Yield p ss1 -> return $ Continue 1 (Just' p, ss1, fs) - D.Stop -> do - c <- fextract fs - return $ Done 1 c - D.Skip ss1 -> return $ Continue 1 (Nothing', ss1, fs) - - -- state holds a parser that may or may not have been - -- initialized. pinit holds the initial parser state - -- or modified parser state respectively - step (Just' (Parser pstep pinit pextr), ss, fs) a = do - ps <- pinit - case ps of - IPartial ps1 -> do - pres <- pstep ps1 a - case pres of - Partial n ps2 -> - let newP = - Just' $ Parser pstep (return $ IPartial ps2) pextr - in return $ Partial n (newP, ss, fs) - Continue n ps2 -> - let newP = - Just' $ Parser pstep (return $ IPartial ps2) pextr - in return $ Continue n (newP, ss, fs) - Done n b -> do - fres <- fstep fs b - case fres of - FL.Partial fs1 -> - return $ Partial n (Nothing', ss, fs1) - FL.Done c -> return $ Done n c - Error msg -> return $ Error msg - IDone b -> do - fres <- fstep fs b - case fres of - FL.Partial fs1 -> - return $ Partial 1 (Nothing', ss, fs1) - FL.Done c -> return $ Done 1 c - IError err -> return $ Error err - - extract (Nothing', _, fs) = fmap (Done 0) $ fextract fs - extract (Just' (Parser pstep pinit pextr), ss, fs) = do - ps <- pinit - case ps of - IPartial ps1 -> do - r <- pextr ps1 - case r of - Done n b -> do - res <- fstep fs b - case res of - FL.Partial fs1 -> fmap (Done n) $ fextract fs1 - FL.Done c -> return (Done n c) - Error err -> return $ Error err - Continue n s -> return $ Continue n (Just' (Parser pstep (return (IPartial s)) pextr), ss, fs) - Partial _ _ -> error "Partial in extract" - IDone b -> do - fres <- fstep fs b - case fres of - FL.Partial fs1 -> fmap (Done 0) $ fextract fs1 - FL.Done c -> return (Done 0 c) - IError err -> return $ Error err - -------------------------------------------------------------------------------- --- Alternative Collection -------------------------------------------------------------------------------- - -{- --- | @choice parsers@ applies the @parsers@ in order and returns the first --- successful parse. --- --- This is same as 'asum' but more efficient. --- --- /Broken/ --- -{-# INLINE choice #-} -choice :: (MonadCatch m, Foldable t) => t (Parser a m b) -> Parser a m b -choice = foldl1 shortest --} - -------------------------------------------------------------------------------- --- Sequential Repetition -------------------------------------------------------------------------------- - --- | Like 'many' but uses a 'Parser' instead of a 'Fold' to collect the --- results. Parsing stops or fails if the collecting parser stops or fails. --- --- /Unimplemented/ --- -{-# INLINE manyP #-} -manyP :: -- MonadCatch m => - Parser a m b -> Parser b m c -> Parser a m c -manyP _p _f = undefined - --- | Collect zero or more parses. Apply the supplied parser repeatedly on the --- input stream and push the parse results to a downstream fold. --- --- Stops: when the downstream fold stops or the parser fails. --- Fails: never, produces zero or more results. --- --- >>> many = Parser.countBetween 0 maxBound --- --- Compare with 'Control.Applicative.many'. --- -{-# INLINE many #-} -many :: Monad m => Parser a m b -> Fold m b c -> Parser a m c -many = splitMany --- many = countBetween 0 maxBound - --- Note: many1 would perhaps be a better name for this and consistent with --- other names like takeWhile1. But we retain the name "some" for --- compatibility. - --- | Collect one or more parses. Apply the supplied parser repeatedly on the --- input stream and push the parse results to a downstream fold. --- --- Stops: when the downstream fold stops or the parser fails. --- Fails: if it stops without producing a single result. --- --- >>> some p f = Parser.manyP p (Parser.takeGE 1 f) --- >>> some = Parser.countBetween 1 maxBound --- --- Compare with 'Control.Applicative.some'. --- -{-# INLINE some #-} -some :: Monad m => Parser a m b -> Fold m b c -> Parser a m c -some = splitSome --- some p f = manyP p (takeGE 1 f) --- some = countBetween 1 maxBound - --- | @countBetween m n f p@ collects between @m@ and @n@ sequential parses of --- parser @p@ using the fold @f@. Stop after collecting @n@ results. Fails if --- the input ends or the parser fails before @m@ results are collected. --- --- >>> countBetween m n p f = Parser.manyP p (Parser.takeBetween m n f) --- --- /Unimplemented/ --- -{-# INLINE countBetween #-} -countBetween :: -- MonadCatch m => - Int -> Int -> Parser a m b -> Fold m b c -> Parser a m c -countBetween _m _n _p = undefined --- countBetween m n p f = manyP p (takeBetween m n f) - --- | @count n f p@ collects exactly @n@ sequential parses of parser @p@ using --- the fold @f@. Fails if the input ends or the parser fails before @n@ --- results are collected. --- --- >>> count n = Parser.countBetween n n --- >>> count n p f = Parser.manyP p (Parser.takeEQ n f) --- --- /Unimplemented/ --- -{-# INLINE count #-} -count :: -- MonadCatch m => - Int -> Parser a m b -> Fold m b c -> Parser a m c -count n = countBetween n n --- count n p f = manyP p (takeEQ n f) - --- | Like 'manyTill' but uses a 'Parser' to collect the results instead of a --- 'Fold'. Parsing stops or fails if the collecting parser stops or fails. --- --- We can implemnent parsers like the following using 'manyTillP': --- --- @ --- countBetweenTill m n f p = manyTillP (takeBetween m n f) p --- @ --- --- /Unimplemented/ --- -{-# INLINE manyTillP #-} -manyTillP :: -- Monad m => - Parser a m b -> Parser a m x -> Parser b m c -> Parser a m c -manyTillP _p1 _p2 _f = undefined - -- D.toParserK $ D.manyTillP (D.fromParserK p1) (D.fromParserK p2) f - -{-# ANN type ManyTillState Fuse #-} -data ManyTillState fs sr sl - = ManyTillR !Int !fs !sr - | ManyTillL !fs !sl - --- | @manyTill chunking test f@ tries the parser @test@ on the input, if @test@ --- fails it backtracks and tries @chunking@, after @chunking@ succeeds @test@ is --- tried again and so on. The parser stops when @test@ succeeds. The output of --- @test@ is discarded and the output of @chunking@ is accumulated by the --- supplied fold. The parser fails if @chunking@ fails. --- --- Stops when the fold @f@ stops. --- -{-# INLINE manyTill #-} -manyTill :: Monad m - => Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c -manyTill (Parser stepL initialL extractL) - (Parser stepR initialR _) - (Fold fstep finitial fextract) = - Parser step initial extract - - where - - -- Caution: Mutual recursion - - scrutL fs p c d e = do - resL <- initialL - case resL of - IPartial sl -> return $ c (ManyTillL fs sl) - IDone bl -> do - fr <- fstep fs bl - case fr of - FL.Partial fs1 -> scrutR fs1 p c d e - FL.Done fb -> return $ d fb - IError err -> return $ e err - - scrutR fs p c d e = do - resR <- initialR - case resR of - IPartial sr -> return $ p (ManyTillR 0 fs sr) - IDone _ -> d <$> fextract fs - IError _ -> scrutL fs p c d e - - initial = do - res <- finitial - case res of - FL.Partial fs -> scrutR fs IPartial IPartial IDone IError - FL.Done b -> return $ IDone b - - step (ManyTillR cnt fs st) a = do - r <- stepR st a - case r of - Partial n s -> return $ Partial n (ManyTillR 0 fs s) - Continue n s -> do - assertM(cnt + 1 - n >= 0) - return $ Continue n (ManyTillR (cnt + 1 - n) fs s) - Done n _ -> do - b <- fextract fs - return $ Done n b - Error _ -> do - resL <- initialL - case resL of - IPartial sl -> - return $ Continue (cnt + 1) (ManyTillL fs sl) - IDone bl -> do - fr <- fstep fs bl - let cnt1 = cnt + 1 - case fr of - FL.Partial fs1 -> - scrutR - fs1 - (Partial cnt1) - (Continue cnt1) - (Done cnt1) - Error - FL.Done fb -> return $ Done cnt1 fb - IError err -> return $ Error err - step (ManyTillL fs st) a = do - r <- stepL st a - case r of - Partial n s -> return $ Partial n (ManyTillL fs s) - Continue n s -> return $ Continue n (ManyTillL fs s) - Done n b -> do - fs1 <- fstep fs b - case fs1 of - FL.Partial s -> - scrutR s (Partial n) (Continue n) (Done n) Error - FL.Done b1 -> return $ Done n b1 - Error err -> return $ Error err - - extract (ManyTillL fs sR) = do - res <- extractL sR - case res of - Done n b -> do - r <- fstep fs b - case r of - FL.Partial fs1 -> fmap (Done n) $ fextract fs1 - FL.Done c -> return (Done n c) - Error err -> return $ Error err - Continue n s -> return $ Continue n (ManyTillL fs s) - Partial _ _ -> error "Partial in extract" - extract (ManyTillR _ fs _) = fmap (Done 0) $ fextract fs - --- | @manyThen f collect recover@ repeats the parser @collect@ on the input and --- collects the output in the supplied fold. If the the parser @collect@ fails, --- parser @recover@ is run until it stops and then we start repeating the --- parser @collect@ again. The parser fails if the recovery parser fails. --- --- For example, this can be used to find a key frame in a video stream after an --- error. --- --- /Unimplemented/ --- -{-# INLINE manyThen #-} -manyThen :: -- (Foldable t, Monad m) => - Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c -manyThen _parser _recover _f = undefined - -------------------------------------------------------------------------------- --- Repeated Alternatives -------------------------------------------------------------------------------- - --- | Keep trying a parser up to a maximum of @n@ failures. When the parser --- fails the input consumed till now is dropped and the new instance is tried --- on the fresh input. --- --- /Unimplemented/ --- -{-# INLINE retryMaxTotal #-} -retryMaxTotal :: -- (Monad m) => - Int -> Parser a m b -> Fold m b c -> Parser a m c -retryMaxTotal _n _p _f = undefined - --- | Like 'retryMaxTotal' but aborts after @n@ successive failures. --- --- /Unimplemented/ --- -{-# INLINE retryMaxSuccessive #-} -retryMaxSuccessive :: -- (Monad m) => - Int -> Parser a m b -> Fold m b c -> Parser a m c -retryMaxSuccessive _n _p _f = undefined - --- | Keep trying a parser until it succeeds. When the parser fails the input --- consumed till now is dropped and the new instance is tried on the fresh --- input. --- --- /Unimplemented/ --- -{-# INLINE retry #-} -retry :: -- (Monad m) => - Parser a m b -> Parser a m b -retry _p = undefined diff --git a/src/Streamly/Internal/Data/Parser/ParserD/Tee.hs b/src/Streamly/Internal/Data/Parser/ParserD/Tee.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Parser/ParserD/Tee.hs +++ /dev/null @@ -1,617 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -#include "inline.hs" - --- | --- Module : Streamly.Internal.Data.Parser.ParserD.Tee --- Copyright : (c) 2020 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Parallel parsers. Distributing the input to multiple parsers at the same --- time. --- --- For simplicity, we are using code where a particular state is unreachable --- but it is not prevented by types. Somehow uni-pattern match using "let" --- produces better optimized code compared to using @case@ match and using --- explicit error messages in unreachable cases. --- --- There seem to be no way to silence individual warnings so we use a global --- incomplete uni-pattern match warning suppression option for the file. --- Disabling the warning for other code as well has the potential to mask off --- some legit warnings, therefore, we have segregated only the code that uses --- uni-pattern matches in this module. - -module Streamly.Internal.Data.Parser.ParserD.Tee - ( - {- - -- Parallel zipped - teeWith - , teeWithFst - , teeWithMin - - -- Parallel alternatives - , shortest - , longest - -} - ) -where - -{- -import Control.Exception (assert) -import Control.Monad.Catch (MonadCatch, try) -import Prelude - hiding (any, all, takeWhile) - -import Fusion.Plugin.Types (Fuse(..)) -import Streamly.Internal.Data.Parser.ParserD.Type - (Initial(..), Parser(..), Step(..), ParseError) - -------------------------------------------------------------------------------- --- Distribute input to two parsers and collect both results -------------------------------------------------------------------------------- - --- When the input stream is distributed to two parsers, both the parsers can --- backtrack independently. Therefore, we need separate buffer state for each --- parser. --- --- ParserK --- --- We can keep the state of each parser in the zipper and pass around that --- zipper to the parsers. Each parser can consume from the zipper and then pass --- around the zipper to the other parser. --- --- ParserD --- --- In the approach we have taken here, the driver pushes one element at a time --- to the tee and each of the parsers in the tee may buffer it independently --- for backtracking. So they do not need to depend on the original stream --- source for individual parser backtracking. Problem arises when both the --- parsers backtrack and they do not need any input from the driver rather they --- must consume from their buffers. For such situation we may need a --- "Continue" style driver command from the tee so that the driver runs --- the tee without providing it any input. Or we may need a local driver loop --- until new input is to be demanded from the input stream. --- --- When the tee errors out or stops, the tee driver may have to backtrack by --- the specified amount (or the tee must return the leftover input). Therefore, --- the tee driver also has to buffer, this leads to triple buffering. --- --- When the tee stops we need to determine the backtracking amount from the --- leftover of both the parsers. Since both the parsers may have consumed --- different lengths of the stream we consider the maximum of the two as --- consumed. --- - -- XXX We can use Initial instead of StepState -{-# ANN type StepState Fuse #-} -data StepState s a = StepState s | StepResult a - --- | State of the pair of parsers in a tee composition --- Note: strictness annotation is important for fusing the constructors -{-# ANN type TeeState Fuse #-} -data TeeState sL sR x a b = --- @TeePair (past buffer, parser state, future-buffer1, future-buffer2) ...@ - TeePair !([x], StepState sL a, [x], [x]) !([x], StepState sR b, [x], [x]) - -{-# ANN type Res Fuse #-} -data Res = Yld Int | Stp Int | Skp | Err String - --- | See 'Streamly.Internal.Data.Parser.teeWith'. --- --- /Broken/ --- -{-# INLINE teeWith #-} -teeWith :: Monad m - => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c -teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) = - Parser step initial extract - - where - - {-# INLINE_LATE initial #-} - initial = do - resL <- initialL - resR <- initialR - return $ case resL of - IPartial sl -> - case resR of - IPartial sr -> IPartial $ TeePair ([], StepState sl, [], []) - ([], StepState sr, [], []) - IDone br -> IPartial $ TeePair ([], StepState sl, [], []) - ([], StepResult br, [], []) - IError err -> IError err - IDone bl -> - case resR of - IPartial sr -> - IPartial $ TeePair ([], StepResult bl, [], []) - ([], StepState sr, [], []) - IDone br -> IDone $ zf bl br - IError err -> IError err - IError err -> IError err - - {-# INLINE consume #-} - consume buf inp1 inp2 stp st y = do - let (x, inp11, inp21) = - case inp1 of - [] -> (y, [], []) - z : [] -> (z, reverse (x:inp2), []) - z : zs -> (z, zs, x:inp2) - r <- stp st x - let buf1 = x:buf - return (buf1, r, inp11, inp21) - - -- XXX This is currently broken, even though both the parsers need to - -- consume from their buffers after backtracking the driver would still be - -- pushing more input to the buffers. - -- - -- consume one input item and return the next state of the fold - {-# INLINE useStream #-} - useStream buf inp1 inp2 stp st y = do - (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y - case r of - Partial 0 s -> - let state = ([], StepState s, inp11, inp21) - in return (state, Yld 0) - Partial n s -> - let src0 = Prelude.take n buf1 - src = Prelude.reverse src0 - state = ([], StepState s, src ++ inp11, inp21) - in assert (n <= length buf1) (return (state, Yld n)) - Done n b -> - let state = (Prelude.take n buf1, StepResult b, inp11, inp21) - in assert (n <= length buf1) (return (state, Stp n)) - -- Continue 0 s -> (buf1, Right s, inp11, inp21) - Continue n s -> - let (src0, buf2) = splitAt n buf1 - src = Prelude.reverse src0 - state = (buf2, StepState s, src ++ inp11, inp21) - in assert (n <= length buf1) (return (state, Skp)) - Error err -> return (undefined, Err err) - - {-# INLINE_LATE step #-} - step (TeePair (bufL, StepState sL, inpL1, inpL2) - (bufR, StepState sR, inpR1, inpR2)) x = do - (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x - (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x - let next = TeePair l r - return $ case (stL,stR) of - (Yld n1, Yld n2) -> Partial (min n1 n2) next - (Yld n1, Stp n2) -> Partial (min n1 n2) next - (Stp n1, Yld n2) -> Partial (min n1 n2) next - (Stp n1, Stp n2) -> - -- Uni-pattern match results in better optimized code compared - -- to a case match. - let (_, StepResult rL, _, _) = l - (_, StepResult rR, _, _) = r - in Done (min n1 n2) (zf rL rR) - (Err err, _) -> Error err - (_, Err err) -> Error err - _ -> Continue 0 next - - step (TeePair (bufL, StepState sL, inpL1, inpL2) - r@(_, StepResult rR, _, _)) x = do - (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x - let next = TeePair l r - -- XXX If the unused count of this stream is lower than the unused - -- count of the stopped stream, only then this will be correct. We need - -- to fix the other case. We need to keep incrementing the unused count - -- of the stopped stream and take the min of the two. - return $ case stL of - Yld n -> Partial n next - Stp n -> - let (_, StepResult rL, _, _) = l - in Done n (zf rL rR) - Skp -> Continue 0 next - Err err -> Error err - - step (TeePair l@(_, StepResult rL, _, _) - (bufR, StepState sR, inpR1, inpR2)) x = do - (r, stR) <- useStream bufR inpR1 inpR2 stepR sR x - let next = TeePair l r - -- XXX If the unused count of this stream is lower than the unused - -- count of the stopped stream, only then this will be correct. We need - -- to fix the other case. We need to keep incrementing the unused count - -- of the stopped stream and take the min of the two. - return $ case stR of - Yld n -> Partial n next - Stp n -> - let (_, StepResult rR, _, _) = r - in Done n (zf rL rR) - Skp -> Continue 0 next - Err err -> Error err - - step _ _ = undefined - - {-# INLINE_LATE extract #-} - extract st = - case st of - TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do - rL <- extractL sL - rR <- extractR sR - return $ zf rL rR - TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do - rL <- extractL sL - return $ zf rL rR - TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do - rR <- extractR sR - return $ zf rL rR - TeePair (_, StepResult rL, _, _) (_, StepResult rR, _, _) -> - return $ zf rL rR - --- | See 'Streamly.Internal.Data.Parser.teeWithFst'. --- --- /Broken/ --- -{-# INLINE teeWithFst #-} -teeWithFst :: Monad m - => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c -teeWithFst zf (Parser stepL initialL extractL) - (Parser stepR initialR extractR) = - Parser step initial extract - - where - - {-# INLINE_LATE initial #-} - initial = do - resL <- initialL - resR <- initialR - case resL of - IPartial sl -> - return $ case resR of - IPartial sr -> IPartial $ TeePair ([], StepState sl, [], []) - ([], StepState sr, [], []) - IDone br -> IPartial $ TeePair ([], StepState sl, [], []) - ([], StepResult br, [], []) - IError err -> IError err - IDone bl -> - case resR of - IPartial sr -> IDone . zf bl <$> extractR sr - IDone br -> return $ IDone $ zf bl br - IError err -> return $ IError err - IError err -> return $ IError err - - {-# INLINE consume #-} - consume buf inp1 inp2 stp st y = do - let (x, inp11, inp21) = - case inp1 of - [] -> (y, [], []) - z : [] -> (z, reverse (x:inp2), []) - z : zs -> (z, zs, x:inp2) - r <- stp st x - let buf1 = x:buf - return (buf1, r, inp11, inp21) - - -- consume one input item and return the next state of the fold - {-# INLINE useStream #-} - useStream buf inp1 inp2 stp st y = do - (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y - case r of - Partial 0 s -> - let state = ([], StepState s, inp11, inp21) - in return (state, Yld 0) - Partial n _ -> return (undefined, Yld n) -- Not implemented - Done n b -> - let state = (Prelude.take n buf1, StepResult b, inp11, inp21) - in assert (n <= length buf1) (return (state, Stp n)) - -- Continue 0 s -> (buf1, Right s, inp11, inp21) - Continue n s -> - let (src0, buf2) = splitAt n buf1 - src = Prelude.reverse src0 - state = (buf2, StepState s, src ++ inp11, inp21) - in assert (n <= length buf1) (return (state, Skp)) - Error err -> return (undefined, Err err) - - {-# INLINE_LATE step #-} - step (TeePair (bufL, StepState sL, inpL1, inpL2) - (bufR, StepState sR, inpR1, inpR2)) x = do - (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x - (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x - let next = TeePair l r - case (stL,stR) of - -- XXX what if the first parser returns an unused count which is - -- more than the second parser's unused count? It does not make - -- sense for the second parser to consume more than the first - -- parser. We reset the input cursor based on the first parser. - -- Error out if the second one has consumed more then the first? - (Stp n1, Stp _) -> - -- Uni-pattern match results in better optimized code compared - -- to a case match. - let (_, StepResult rL, _, _) = l - (_, StepResult rR, _, _) = r - in return $ Done n1 (zf rL rR) - (Stp n1, Yld _) -> - let (_, StepResult rL, _, _) = l - (_, StepState ssR, _, _) = r - in do - rR <- extractR ssR - return $ Done n1 (zf rL rR) - (Yld n1, Yld n2) -> return $ Partial (min n1 n2) next - (Yld n1, Stp n2) -> return $ Partial (min n1 n2) next - (Err err, _) -> return $ Error err - (_, Err err) -> return $ Error err - _ -> return $ Continue 0 next - - step (TeePair (bufL, StepState sL, inpL1, inpL2) - r@(_, StepResult rR, _, _)) x = do - (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x - let next = TeePair l r - -- XXX If the unused count of this stream is lower than the unused - -- count of the stopped stream, only then this will be correct. We need - -- to fix the other case. We need to keep incrementing the unused count - -- of the stopped stream and take the min of the two. - return $ case stL of - Yld n -> Partial n next - Stp n -> - let (_, StepResult rL, _, _) = l - in Done n (zf rL rR) - Skp -> Continue 0 next - Err err -> Error err - - step _ _ = undefined - - {-# INLINE_LATE extract #-} - extract st = - case st of - TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do - rL <- extractL sL - rR <- extractR sR - return $ zf rL rR - TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do - rL <- extractL sL - return $ zf rL rR - _ -> error "unreachable" - --- | See 'Streamly.Internal.Data.Parser.teeWithMin'. --- --- /Unimplemented/ --- -{-# INLINE teeWithMin #-} -teeWithMin :: - -- Monad m => - (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c -teeWithMin = undefined - -------------------------------------------------------------------------------- --- Distribute input to two parsers and choose one result -------------------------------------------------------------------------------- - --- | See 'Streamly.Internal.Data.Parser.shortest'. --- --- /Broken/ --- -{-# INLINE shortest #-} -shortest :: Monad m => Parser x m a -> Parser x m a -> Parser x m a -shortest (Parser stepL initialL extractL) (Parser stepR initialR _) = - Parser step initial extract - - where - - {-# INLINE_LATE initial #-} - initial = do - resL <- initialL - resR <- initialR - return $ case resL of - IPartial sl -> - case resR of - IPartial sr -> IPartial $ TeePair ([], StepState sl, [], []) - ([], StepState sr, [], []) - IDone br -> IDone br - IError err -> IError err - IDone bl -> IDone bl - IError errL -> - case resR of - IPartial _ -> IError errL - IDone br -> IDone br - IError errR -> IError errR - - {-# INLINE consume #-} - consume buf inp1 inp2 stp st y = do - let (x, inp11, inp21) = - case inp1 of - [] -> (y, [], []) - z : [] -> (z, reverse (x:inp2), []) - z : zs -> (z, zs, x:inp2) - r <- stp st x - let buf1 = x:buf - return (buf1, r, inp11, inp21) - - -- consume one input item and return the next state of the fold - {-# INLINE useStream #-} - useStream buf inp1 inp2 stp st y = do - (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y - case r of - Partial 0 s -> - let state = ([], StepState s, inp11, inp21) - in return (state, Yld 0) - Partial n _ -> return (undefined, Yld n) -- Not implemented - Done n b -> - let state = (Prelude.take n buf1, StepResult b, inp11, inp21) - in assert (n <= length buf1) (return (state, Stp n)) - -- Continue 0 s -> (buf1, Right s, inp11, inp21) - Continue n s -> - let (src0, buf2) = splitAt n buf1 - src = Prelude.reverse src0 - state = (buf2, StepState s, src ++ inp11, inp21) - in assert (n <= length buf1) (return (state, Skp)) - Error err -> return (undefined, Err err) - - -- XXX Even if a parse finished earlier it may not be shortest if the other - -- parser finishes later but returns a lot of unconsumed input. Our current - -- criterion of shortest is whichever parse decided to stop earlier. - {-# INLINE_LATE step #-} - step (TeePair (bufL, StepState sL, inpL1, inpL2) - (bufR, StepState sR, inpR1, inpR2)) x = do - (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x - (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x - let next = TeePair l r - return $ case (stL,stR) of - (Stp n1, _) -> - let (_, StepResult rL, _, _) = l - in Done n1 rL - (_, Stp n2) -> - let (_, StepResult rR, _, _) = r - in Done n2 rR - (Yld n1, Yld n2) -> Partial (min n1 n2) next - (Err err, _) -> Error err - (_, Err err) -> Error err - _ -> Continue 0 next - - step _ _ = undefined - - {-# INLINE_LATE extract #-} - extract st = - case st of - TeePair (_, StepState sL, _, _) _ -> extractL sL - _ -> error "unreachable" - --- | See 'Streamly.Internal.Data.Parser.longest'. --- --- /Broken/ --- -{-# INLINE longest #-} -longest :: MonadCatch m => Parser x m a -> Parser x m a -> Parser x m a -longest (Parser stepL initialL extractL) (Parser stepR initialR extractR) = - Parser step initial extract - - where - - - {-# INLINE_LATE initial #-} - initial = do - resL <- initialL - resR <- initialR - return $ case resL of - IPartial sl -> - case resR of - IPartial sr -> IPartial $ TeePair ([], StepState sl, [], []) - ([], StepState sr, [], []) - IDone br -> IPartial $ TeePair ([], StepState sl, [], []) - ([], StepResult br, [], []) - IError _ -> - IPartial $ TeePair ([], StepState sl, [], []) - ([], StepResult undefined, [], []) - IDone bl -> - case resR of - IPartial sr -> - IPartial $ TeePair ([], StepResult bl, [], []) - ([], StepState sr, [], []) - IDone _ -> IDone bl - IError _ -> IDone bl - IError _ -> - case resR of - IPartial sr -> - IPartial $ TeePair ([], StepResult undefined, [], []) - ([], StepState sr, [], []) - IDone br -> IDone br - IError err -> IError err - - {-# INLINE consume #-} - consume buf inp1 inp2 stp st y = do - let (x, inp11, inp21) = - case inp1 of - [] -> (y, [], []) - z : [] -> (z, reverse (x:inp2), []) - z : zs -> (z, zs, x:inp2) - r <- stp st x - let buf1 = x:buf - return (buf1, r, inp11, inp21) - - -- consume one input item and return the next state of the fold - {-# INLINE useStream #-} - useStream buf inp1 inp2 stp st y = do - (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y - case r of - Partial 0 s -> - let state = ([], StepState s, inp11, inp21) - in return (state, Yld 0) - Partial n _ -> return (undefined, Yld n) -- Not implemented - Done n b -> - let state = (Prelude.take n buf1, StepResult b, inp11, inp21) - in assert (n <= length buf1) (return (state, Stp n)) - -- Continue 0 s -> (buf1, Right s, inp11, inp21) - Continue n s -> - let (src0, buf2) = splitAt n buf1 - src = Prelude.reverse src0 - state = (buf2, StepState s, src ++ inp11, inp21) - in assert (n <= length buf1) (return (state, Skp)) - Error err -> return (undefined, Err err) - - {-# INLINE_LATE step #-} - step (TeePair (bufL, StepState sL, inpL1, inpL2) - (bufR, StepState sR, inpR1, inpR2)) x = do - (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x - (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x - let next = TeePair l r - return $ case (stL,stR) of - (Yld n1, Yld n2) -> Partial (min n1 n2) next - (Yld n1, Stp n2) -> Partial (min n1 n2) next - (Stp n1, Yld n2) -> Partial (min n1 n2) next - (Stp n1, Stp n2) -> - let (_, StepResult rL, _, _) = l - (_, StepResult rR, _, _) = r - in Done (max n1 n2) (if n1 >= n2 then rL else rR) - (Err err, _) -> Error err - (_, Err err) -> Error err - _ -> Continue 0 next - - -- XXX the parser that finishes last may not be the longest because it may - -- return a lot of unused input which makes it shorter. Our current - -- criterion of deciding longest is based on whoever decides to finish - -- last and not whoever consumed more input. - -- - -- To actually know who made more progress we need to keep an account of - -- how many items are unconsumed since the last yield. - -- - step (TeePair (bufL, StepState sL, inpL1, inpL2) - r@(_, StepResult _, _, _)) x = do - (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x - let next = TeePair l r - return $ case stL of - Yld n -> Partial n next - Stp n -> - let (_, StepResult rL, _, _) = l - in Done n rL - Skp -> Continue 0 next - Err err -> Error err - - step (TeePair l@(_, StepResult _, _, _) - (bufR, StepState sR, inpR1, inpR2)) x = do - (r, stR) <- useStream bufR inpR1 inpR2 stepR sR x - let next = TeePair l r - return $ case stR of - Yld n -> Partial n next - Stp n -> - let (_, StepResult rR, _, _) = r - in Done n rR - Skp -> Continue 0 next - Err err -> Error err - - step _ _ = undefined - - {-# INLINE_LATE extract #-} - extract st = - -- XXX When results are partial we may not be able to precisely compare - -- which parser has made more progress till now. One way to do that is - -- to figure out the actually consumed input up to the last yield. - -- - case st of - TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do - r <- try $ extractL sL - case r of - Left (_ :: ParseError) -> extractR sR - Right b -> return b - TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do - r <- try $ extractL sL - case r of - Left (_ :: ParseError) -> return rR - Right b -> return b - TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do - r <- try $ extractR sR - case r of - Left (_ :: ParseError) -> return rL - Right b -> return b - TeePair (_, StepResult _, _, _) (_, StepResult _, _, _) -> - error "unreachable" --} diff --git a/src/Streamly/Internal/Data/Parser/ParserD/Type.hs b/src/Streamly/Internal/Data/Parser/ParserD/Type.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Parser/ParserD/Type.hs +++ /dev/null @@ -1,1429 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Parser.ParserD.Type --- Copyright : (c) 2020 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Streaming and backtracking parsers. --- --- Parsers just extend folds. Please read the 'Fold' design notes in --- "Streamly.Internal.Data.Fold.Type" for background on the design. --- --- = Parser Design --- --- The 'Parser' type or a parsing fold is a generalization of the 'Fold' type. --- The 'Fold' type /always/ succeeds on each input. Therefore, it does not need --- to buffer the input. In contrast, a 'Parser' may fail and backtrack to --- replay the input again to explore another branch of the parser. Therefore, --- it needs to buffer the input. Therefore, a 'Parser' is a fold with some --- additional requirements. To summarize, unlike a 'Fold', a 'Parser': --- --- 1. may not generate a new value of the accumulator on every input, it may --- generate a new accumulator only after consuming multiple input elements --- (e.g. takeEQ). --- 2. on success may return some unconsumed input (e.g. takeWhile) --- 3. may fail and return all input without consuming it (e.g. satisfy) --- 4. backtrack and start inspecting the past input again (e.g. alt) --- --- These use cases require buffering and replaying of input. To facilitate --- this, the step function of the 'Fold' is augmented to return the next state --- of the fold along with a command tag using a 'Step' functor, the tag tells --- the fold driver to manipulate the future input as the parser wishes. The --- 'Step' functor provides the following commands to the fold driver --- corresponding to the use cases outlined in the previous para: --- --- 1. 'Continue': buffer the current input and optionally go back to a previous --- position in the stream --- 2. 'Partial': buffer the current input and optionally go back to a previous --- position in the stream, drop the buffer before that position. --- 3. 'Done': parser succeeded, returns how much input was leftover --- 4. 'Error': indicates that the parser has failed without a result --- --- = How a Parser Works? --- --- A parser is just like a fold, it keeps consuming inputs from the stream and --- accumulating them in an accumulator. The accumulator of the parser could be --- a singleton value or it could be a collection of values e.g. a list. --- --- The parser may build a new output value from multiple input items. When it --- consumes an input item but needs more input to build a complete output item --- it uses @Continue 0 s@, yielding the intermediate state @s@ and asking the --- driver to provide more input. When the parser determines that a new output --- value is complete it can use a @Done n b@ to terminate the parser with @n@ --- items of input unused and the final value of the accumulator returned as --- @b@. If at any time the parser determines that the parse has failed it can --- return @Error err@. --- --- A parser building a collection of values (e.g. a list) can use the @Partial@ --- constructor whenever a new item in the output collection is generated. If a --- parser building a collection of values has yielded at least one value then --- it is considered successful and cannot fail after that. In the current --- implementation, this is not automatically enforced, there is a rule that the --- parser MUST use only @Done@ for termination after the first @Partial@, it --- cannot use @Error@. It may be possible to change the implementation so that --- this rule is not required, but there may be some performance cost to it. --- --- 'Streamly.Internal.Data.Parser.takeWhile' and --- 'Streamly.Internal.Data.Parser.some' combinators are good examples of --- efficient implementations using all features of this representation. It is --- possible to idiomatically build a collection of parsed items using a --- singleton parser and @Alternative@ instance instead of using a --- multi-yield parser. However, this implementation is amenable to stream --- fusion and can therefore be much faster. --- --- = Error Handling --- --- When a parser's @step@ function is invoked it may terminate by either a --- 'Done' or an 'Error' return value. In an 'Alternative' composition an error --- return can make the composed parser backtrack and try another parser. --- --- If the stream stops before a parser could terminate then we use the --- @extract@ function of the parser to retrieve the last yielded value of the --- parser. If the parser has yielded at least one value then @extract@ MUST --- return a value without throwing an error, otherwise it uses the 'ParseError' --- exception to throw an error. --- --- We chose the exception throwing mechanism for @extract@ instead of using an --- explicit error return via an 'Either' type for keeping the interface simple --- as most of the time we do not need to catch the error in intermediate --- layers. Note that we cannot use exception throwing mechanism in @step@ --- function because of performance reasons. 'Error' constructor in that case --- allows loop fusion and better performance. --- --- = Optimizing backtracking --- --- == Applicative Composition --- --- If a parser once returned 'Partial' it can never fail after that. This is --- used to reduce the buffering. A 'Partial' results in dropping the buffer and --- we cannot backtrack before that point. --- --- Parsers can be composed using an Alternative, if we are in an alternative --- composition we may have to backtrack to try the other branch. When we --- compose two parsers using applicative @f <$> p1 <*> p2@ we can return a --- 'Partial' result only after both the parsers have succeeded. While running --- @p1@ we have to ensure that the input is not dropped until we have run @p2@, --- therefore we have to return a Continue instead of a Partial. --- --- However, if we know they both cannot fail then we know that the composed --- parser can never fail. For this reason we should have "backtracking folds" --- as a separate type so that we can compose them in an efficient manner. In p1 --- itself we can drop the buffer as soon as a 'Partial' result arrives. In --- fact, there is no Alternative composition for folds because they cannot --- fail. --- --- == Alternative Composition --- --- In @p1 <|> p2@ as soon as the parser p1 returns 'Partial' we know that it --- will not fail and we can immediately drop the buffer. --- --- If we are not using the parser in an alternative composition we can --- downgrade the parser to a backtracking fold and use the "backtracking --- fold"'s applicative for more efficient implementation. To downgrade we can --- translate the "Error" of parser to an exception. This gives us best of both --- worlds, the applicative as well as alternative would have optimal --- backtracking buffer. --- --- The "many" for parsers would be different than "many" for folds. In case of --- folds an error would be propagated. In case of parsers the error would be --- ignored. --- --- = Implementation Approach --- --- Backtracking folds have an issue with tee style composition because each --- fold can backtrack independently, we will need independent buffers. Though --- this may be possible to implement it may not be efficient especially for --- folds that do not backtrack at all. Three types are possible, optimized for --- different use cases: --- --- * Non-backtracking folds: efficient Tee --- * Backtracking folds: efficient applicative --- * Parsers: alternative --- --- Downgrade parsers to backtracking folds for applicative used without --- alternative. Upgrade backtracking folds to parsers when we have to use them --- as the last alternative. --- --- = Future Work --- --- It may make sense to move "takeWhile" type of parsers, which cannot fail but --- need some lookahead, to splitting folds. This will allow such combinators --- to be accepted where we need an unfailing "Fold" type. --- --- Based on application requirements it should be possible to design even a --- richer interface to manipulate the input stream/buffer. For example, we --- could randomly seek into the stream in the forward or reverse directions or --- we can even seek to the end or from the end or seek from the beginning. --- --- We can distribute and scan/parse a stream using both folds and parsers and --- merge the resulting streams using different merge strategies (e.g. --- interleaving or serial). --- --- == Naming --- --- As far as possible, try that the names of the combinators in this module are --- consistent with: --- --- * --- * --- * --- * --- * - -module Streamly.Internal.Data.Parser.ParserD.Type - ( - -- * Setup - -- $setup - - -- * Types - Initial (..) - , Step (..) - , extractStep - , bimapOverrideCount - , Parser (..) - , ParseError (..) - , rmapM - - -- * Constructors - - , fromPure - , fromEffect - , splitWith - , split_ - - , die - , dieM - , splitSome -- parseSome? - , splitMany -- parseMany? - , splitManyPost - , alt - , concatMap - - -- * Input transformation - , lmap - , lmapM - , filter - - , noErrorUnsafeSplitWith - , noErrorUnsafeSplit_ - , noErrorUnsafeConcatMap - ) -where - -#include "inline.hs" -#include "assert.hs" - -import Control.Applicative (Alternative(..), liftA2) -import Control.Exception (Exception(..)) --- import Control.Monad (MonadPlus(..), (>=>)) -import Control.Monad ((>=>)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Bifunctor (Bifunctor(..)) -import Fusion.Plugin.Types (Fuse(..)) -import Streamly.Internal.Data.Fold.Type (Fold(..), toList) - -import qualified Control.Monad.Fail as Fail -import qualified Streamly.Internal.Data.Fold.Type as FL - -import Prelude hiding (concatMap, filter) - -#include "DocTestDataParser.hs" - --- XXX The only differences between Initial and Step types are: --- --- * There are no backtracking counts in Initial --- * Continue and Partial are the same. Ideally Partial should mean that an --- empty result is valid and can be extracted; and Continue should mean that --- empty would result in an error on extraction. We can possibly distinguish --- the two cases. --- --- If we ignore the backtracking counts we can represent the Initial type using --- Step itself. That will also simplify the implementation of various parsers --- where the processing in intiial is just a sepcial case of step, see --- takeBetween for example. - --- | The type of a 'Parser''s initial action. --- --- /Internal/ --- -{-# ANN type Initial Fuse #-} -data Initial s b - = IPartial !s -- ^ Wait for step function to be called with state @s@. - | IDone !b -- ^ Return a result right away without an input. - | IError !String -- ^ Return an error right away without an input. - --- | @first@ maps on 'IPartial' and @second@ maps on 'IDone'. --- --- /Internal/ --- -instance Bifunctor Initial where - {-# INLINE bimap #-} - bimap f _ (IPartial a) = IPartial (f a) - bimap _ g (IDone b) = IDone (g b) - bimap _ _ (IError err) = IError err - --- | Maps a function over the result held by 'IDone'. --- --- >>> fmap = second --- --- /Internal/ --- -instance Functor (Initial s) where - {-# INLINE fmap #-} - fmap = second - --- We can simplify the Step type as follows: --- --- Partial Int (Either s (s, b)) -- Left continue, right partial result --- Done Int (Either String b) --- --- In this case Error may also have a "leftover" return. This means that after --- several successful partial results the last segment parsing failed and we --- are returning the leftover of that. The driver may choose to restart from --- the last segment where this parser failed or from the beginning. --- --- Folds can only return the right values. Parsers can also return lefts. - --- | The return type of a 'Parser' step. --- --- The parse operation feeds the input stream to the parser one element at a --- time, representing a parse 'Step'. The parser may or may not consume the --- item and returns a result. If the result is 'Partial' we can either extract --- the result or feed more input to the parser. If the result is 'Continue', we --- must feed more input in order to get a result. If the parser returns 'Done' --- then the parser can no longer take any more input. --- --- If the result is 'Continue', the parse operation retains the input in a --- backtracking buffer, in case the parser may ask to backtrack in future. --- Whenever a 'Partial n' result is returned we first backtrack by @n@ elements --- in the input and then release any remaining backtracking buffer. Similarly, --- 'Continue n' backtracks to @n@ elements before the current position and --- starts feeding the input from that point for future invocations of the --- parser. --- --- If parser is not yet done, we can use the @extract@ operation on the @state@ --- of the parser to extract a result. If the parser has not yet yielded a --- result, the operation fails with a 'ParseError' exception. If the parser --- yielded a 'Partial' result in the past the last partial result is returned. --- Therefore, if a parser yields a partial result once it cannot fail later on. --- --- The parser can never backtrack beyond the position where the last partial --- result left it at. The parser must ensure that the backtrack position is --- always after that. --- --- /Pre-release/ --- -{-# ANN type Step Fuse #-} -data Step s b = - Partial !Int !s - -- ^ @Partial count state@. The following hold on Partial result: - -- - -- 1. @extract@ on @state@ would succeed and give a result. - -- 2. Input stream position is reset to @current position - count@. - -- 3. All input before the new position is dropped. The parser can - -- never backtrack beyond this position. - - | Continue !Int !s - -- ^ @Continue count state@. The following hold on a Continue result: - -- - -- 1. If there was a 'Partial' result in past, @extract@ on @state@ would - -- give that result as 'Done' otherwise it may return 'Error' or - -- 'Continue'. - -- 2. Input stream position is reset to @current position - count@. - -- 3. the input is retained in a backtrack buffer. - - | Done !Int !b - -- ^ Done with leftover input count and result. - -- - -- @Done count result@ means the parser has finished, it will accept no - -- more input, last @count@ elements from the input are unused and the - -- result of the parser is in @result@. - - | Error !String - -- ^ Parser failed without generating any output. - -- - -- The parsing operation may backtrack to the beginning and try another - -- alternative. - --- | Map first function over the state and second over the result. -instance Bifunctor Step where - {-# INLINE bimap #-} - bimap f g step = - case step of - Partial n s -> Partial n (f s) - Continue n s -> Continue n (f s) - Done n b -> Done n (g b) - Error err -> Error err - --- | Bimap discarding the count, and using the supplied count instead. -bimapOverrideCount :: Int -> (s -> s1) -> (b -> b1) -> Step s b -> Step s1 b1 -bimapOverrideCount n f g step = - case step of - Partial _ s -> Partial n (f s) - Continue _ s -> Continue n (f s) - Done _ b -> Done n (g b) - Error err -> Error err - --- | fmap = second -instance Functor (Step s) where - {-# INLINE fmap #-} - fmap = second - -{-# INLINE assertStepCount #-} -assertStepCount :: Int -> Step s b -> Step s b -assertStepCount i step = - case step of - Partial n _ -> assert (i == n) step - Continue n _ -> assert (i == n) step - Done n _ -> assert (i == n) step - Error _ -> step - --- | Map an extract function over the state of Step --- -{-# INLINE extractStep #-} -extractStep :: Monad m => (s -> m (Step s1 b)) -> Step s b -> m (Step s1 b) -extractStep f res = - case res of - Partial n s1 -> assertStepCount n <$> f s1 - Done n b -> return $ Done n b - Continue n s1 -> assertStepCount n <$> f s1 - Error err -> return $ Error err - --- | Map a monadic function over the result @b@ in @Step s b@. --- --- /Internal/ -{-# INLINE mapMStep #-} -mapMStep :: Applicative m => (a -> m b) -> Step s a -> m (Step s b) -mapMStep f res = - case res of - Partial n s -> pure $ Partial n s - Done n b -> Done n <$> f b - Continue n s -> pure $ Continue n s - Error err -> pure $ Error err - --- | A parser is a fold that can fail and is represented as @Parser step --- initial extract@. Before we drive a parser we call the @initial@ action to --- retrieve the initial state of the fold. The parser driver invokes @step@ --- with the state returned by the previous step and the next input element. It --- results into a new state and a command to the driver represented by 'Step' --- type. The driver keeps invoking the step function until it stops or fails. --- At any point of time the driver can call @extract@ to inspect the result of --- the fold. If the parser hits the end of input 'extract' is called. --- It may result in an error or an output value. --- --- /Pre-release/ --- -data Parser a m b = - forall s. Parser - (s -> a -> m (Step s b)) - -- Initial cannot return "Partial/Done n" or "Continue". Continue 0 is - -- same as Partial 0. In other words it cannot backtrack. - (m (Initial s b)) - -- Extract can only return Partial or Continue n. In other words it can - -- only backtrack or return partial result/error. But we do not return - -- result in Partial, therefore, we have to use Done instead of Partial. - (s -> m (Step s b)) - --- | This exception is used when a parser ultimately fails, the user of the --- parser is intimated via this exception. --- --- /Pre-release/ --- -newtype ParseError = ParseError String - deriving Show - -instance Exception ParseError where - displayException (ParseError err) = err - -instance Functor m => Functor (Parser a m) where - {-# INLINE fmap #-} - fmap f (Parser step1 initial1 extract) = - Parser step initial (fmap3 f extract) - - where - - initial = fmap2 f initial1 - step s b = fmap2 f (step1 s b) - fmap2 g = fmap (fmap g) - fmap3 g = fmap2 (fmap g) - ------------------------------------------------------------------------------- --- Mapping on the output ------------------------------------------------------------------------------- - --- | @rmapM f parser@ maps the monadic function @f@ on the output of the parser. --- --- >>> rmap = fmap -{-# INLINE rmapM #-} -rmapM :: Monad m => (b -> m c) -> Parser a m b -> Parser a m c -rmapM f (Parser step initial extract) = - Parser step1 initial1 (extract >=> mapMStep f) - - where - - initial1 = do - res <- initial - -- this is mapM f over result - case res of - IPartial x -> return $ IPartial x - IDone a -> IDone <$> f a - IError err -> return $ IError err - step1 s a = step s a >>= mapMStep f - --- | A parser that always yields a pure value without consuming any input. --- -{-# INLINE_NORMAL fromPure #-} -fromPure :: Monad m => b -> Parser a m b -fromPure b = Parser undefined (pure $ IDone b) undefined - --- | A parser that always yields the result of an effectful action without --- consuming any input. --- -{-# INLINE fromEffect #-} -fromEffect :: Monad m => m b -> Parser a m b -fromEffect b = Parser undefined (IDone <$> b) undefined - -------------------------------------------------------------------------------- --- Sequential applicative -------------------------------------------------------------------------------- - -{-# ANN type SeqParseState Fuse #-} -data SeqParseState sl f sr = SeqParseL !sl | SeqParseR !f !sr - --- Note: this implementation of splitWith is fast because of stream fusion but --- has quadratic time complexity, because each composition adds a new branch --- that each subsequent parse's input element has to go through, therefore, it --- cannot scale to a large number of compositions. After around 100 --- compositions the performance starts dipping rapidly beyond a CPS style --- unfused implementation. --- --- Note: This is a parsing dual of appending streams using --- 'Streamly.Data.Stream.append', it splits the streams using two parsers and --- zips the results. - --- | Sequential parser application. --- --- Apply two parsers sequentially to an input stream. The first parser runs and --- processes the input, the remaining input is then passed to the second --- parser. If both parsers succeed, their outputs are combined using the --- supplied function. If either parser fails, the operation fails. --- --- This implementation is strict in the second argument, therefore, the --- following will fail: --- --- >>> Stream.parse (Parser.splitWith const (Parser.satisfy (> 0)) undefined) $ Stream.fromList [1] --- *** Exception: Prelude.undefined --- ... --- --- Although this implementation allows stream fusion, it has quadratic --- complexity, making it suitable only for a small number of compositions. --- As a thumb rule use it for less than 8 compositions, use ParserK otherwise. --- --- Below are some common idioms that can be expressed using 'splitWith' and --- other parser primitives: --- --- >>> span p f1 f2 = Parser.splitWith (,) (Parser.takeWhile p f1) (Parser.fromFold f2) --- >>> spanBy eq f1 f2 = Parser.splitWith (,) (Parser.groupBy eq f1) (Parser.fromFold f2) --- --- /Pre-release/ --- -{-# INLINE splitWith #-} -splitWith :: Monad m - => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c -splitWith func (Parser stepL initialL extractL) - (Parser stepR initialR extractR) = - Parser step initial extract - - where - - initial = do - -- XXX We can use bimap here if we make this a Step type - resL <- initialL - case resL of - IPartial sl -> return $ IPartial $ SeqParseL sl - IDone bl -> do - resR <- initialR - -- XXX We can use bimap here if we make this a Step type - return $ case resR of - IPartial sr -> IPartial $ SeqParseR (func bl) sr - IDone br -> IDone (func bl br) - IError err -> IError err - IError err -> return $ IError err - - -- Note: For the composed parse to terminate, the left parser has to be - -- a terminating parser returning a Done at some point. - step (SeqParseL st) a = do - -- Important: Please do not use Applicative here. See - -- https://github.com/composewell/streamly/issues/1033 and the problem - -- defined in split_ for more info. - -- XXX Use bimap - resL <- stepL st a - case resL of - -- Note: We need to buffer the input for a possible Alternative - -- e.g. in ((,) <$> p1 <*> p2) <|> p3, if p2 fails we have to - -- backtrack and start running p3. So we need to keep the input - -- buffered until we know that the applicative cannot fail. - Partial n s -> return $ Continue n (SeqParseL s) - Continue n s -> return $ Continue n (SeqParseL s) - Done n b -> do - -- XXX Use bimap if we make this a Step type - -- fmap (bimap (SeqParseR (func b)) (func b)) initialR - initR <- initialR - return $ case initR of - IPartial sr -> Continue n $ SeqParseR (func b) sr - IDone br -> Done n (func b br) - IError err -> Error err - Error err -> return $ Error err - - step (SeqParseR f st) a = fmap (bimap (SeqParseR f) f) (stepR st a) - - extract (SeqParseR f sR) = fmap (bimap (SeqParseR f) f) (extractR sR) - extract (SeqParseL sL) = do - -- XXX Use bimap here - rL <- extractL sL - case rL of - Done n bL -> do - -- XXX Use bimap here if we use Step type in Initial - iR <- initialR - case iR of - IPartial sR -> do - fmap - (bimap (SeqParseR (func bL)) (func bL)) - (extractR sR) - IDone bR -> return $ Done n $ func bL bR - IError err -> return $ Error err - Error err -> return $ Error err - Partial _ _ -> error "Bug: splitWith extract 'Partial'" - Continue n s -> return $ Continue n (SeqParseL s) - -------------------------------------------------------------------------------- --- Sequential applicative for backtracking folds -------------------------------------------------------------------------------- - --- XXX Create a newtype for nonfailing parsers and downgrade the parser to that --- type before this operation and then upgrade. --- --- We can do an inspection testing to reject unwanted constructors at compile --- time. --- --- We can use the compiler to automatically annotate accumulators, terminating --- folds, non-failing parsers and failing parsers. - --- | Works correctly only if both the parsers are guaranteed to never fail. -{-# INLINE noErrorUnsafeSplitWith #-} -noErrorUnsafeSplitWith :: Monad m - => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c -noErrorUnsafeSplitWith func (Parser stepL initialL extractL) - (Parser stepR initialR extractR) = - Parser step initial extract - - where - - errMsg e = error $ "noErrorUnsafeSplitWith: unreachable: " ++ e - - initial = do - resL <- initialL - case resL of - IPartial sl -> return $ IPartial $ SeqParseL sl - IDone bl -> do - resR <- initialR - return $ bimap (SeqParseR (func bl)) (func bl) resR - IError err -> errMsg err - - -- Note: For the composed parse to terminate, the left parser has to be - -- a terminating parser returning a Done at some point. - step (SeqParseL st) a = do - r <- stepL st a - case r of - -- Assume that the parser can never fail, therefore, we do not - -- need to keep the input for backtracking. - Partial n s -> return $ Partial n (SeqParseL s) - Continue n s -> return $ Continue n (SeqParseL s) - Done n b -> do - res <- initialR - return - $ case res of - IPartial sr -> Partial n $ SeqParseR (func b) sr - IDone br -> Done n (func b br) - IError err -> errMsg err - Error err -> errMsg err - - step (SeqParseR f st) a = fmap (bimap (SeqParseR f) f) (stepR st a) - - extract (SeqParseR f sR) = fmap (bimap (SeqParseR f) f) (extractR sR) - - extract (SeqParseL sL) = do - rL <- extractL sL - case rL of - Done n bL -> do - iR <- initialR - case iR of - IPartial sR -> do - rR <- extractR sR - return - $ bimapOverrideCount - n (SeqParseR (func bL)) (func bL) rR - IDone bR -> return $ Done n $ func bL bR - IError err -> errMsg err - Error err -> errMsg err - Partial _ _ -> errMsg "Partial" - Continue n s -> return $ Continue n (SeqParseL s) - -{-# ANN type SeqAState Fuse #-} -data SeqAState sl sr = SeqAL !sl | SeqAR !sr - --- This turns out to be slightly faster than splitWith - --- | Sequential parser application ignoring the output of the first parser. --- Apply two parsers sequentially to an input stream. The input is provided to --- the first parser, when it is done the remaining input is provided to the --- second parser. The output of the parser is the output of the second parser. --- The operation fails if any of the parsers fail. --- --- This implementation is strict in the second argument, therefore, the --- following will fail: --- --- >>> Stream.parse (Parser.split_ (Parser.satisfy (> 0)) undefined) $ Stream.fromList [1] --- *** Exception: Prelude.undefined --- ... --- --- Although this implementation allows stream fusion, it has quadratic --- complexity, making it suitable only for a small number of compositions. --- As a thumb rule use it for less than 8 compositions, use ParserK otherwise. --- --- /Pre-release/ --- -{-# INLINE split_ #-} -split_ :: Monad m => Parser x m a -> Parser x m b -> Parser x m b -split_ (Parser stepL initialL extractL) (Parser stepR initialR extractR) = - Parser step initial extract - - where - - initial = do - resL <- initialL - case resL of - IPartial sl -> return $ IPartial $ SeqAL sl - IDone _ -> do - resR <- initialR - return $ first SeqAR resR - IError err -> return $ IError err - - -- Note: For the composed parse to terminate, the left parser has to be - -- a terminating parser returning a Done at some point. - step (SeqAL st) a = do - -- Important: Do not use Applicative here. Applicative somehow caused - -- the right action to run many times, not sure why though. - resL <- stepL st a - case resL of - -- Note: this leads to buffering even if we are not in an - -- Alternative composition. - Partial n s -> return $ Continue n (SeqAL s) - Continue n s -> return $ Continue n (SeqAL s) - Done n _ -> do - initR <- initialR - return $ case initR of - IPartial s -> Continue n (SeqAR s) - IDone b -> Done n b - IError err -> Error err - Error err -> return $ Error err - - step (SeqAR st) a = first SeqAR <$> stepR st a - - extract (SeqAR sR) = fmap (first SeqAR) (extractR sR) - extract (SeqAL sL) = do - rL <- extractL sL - case rL of - Done n _ -> do - iR <- initialR - -- XXX For initial we can have a bimap with leftover. - case iR of - IPartial sR -> - fmap (bimapOverrideCount n SeqAR id) (extractR sR) - IDone bR -> return $ Done n bR - IError err -> return $ Error err - Error err -> return $ Error err - Partial _ _ -> error "split_: Partial" - Continue n s -> return $ Continue n (SeqAL s) - --- For backtracking folds -{-# INLINE noErrorUnsafeSplit_ #-} -noErrorUnsafeSplit_ :: Monad m => Parser x m a -> Parser x m b -> Parser x m b -noErrorUnsafeSplit_ - (Parser stepL initialL extractL) (Parser stepR initialR extractR) = - Parser step initial extract - - where - - errMsg e = error $ "noErrorUnsafeSplit_: unreachable: " ++ e - - initial = do - resL <- initialL - case resL of - IPartial sl -> return $ IPartial $ SeqAL sl - IDone _ -> do - resR <- initialR - return $ first SeqAR resR - IError err -> errMsg err - - -- Note: For the composed parse to terminate, the left parser has to be - -- a terminating parser returning a Done at some point. - step (SeqAL st) a = do - -- Important: Please do not use Applicative here. Applicative somehow - -- caused the next action to run many times in the "tar" parsing code, - -- not sure why though. - resL <- stepL st a - case resL of - Partial n s -> return $ Partial n (SeqAL s) - Continue n s -> return $ Continue n (SeqAL s) - Done n _ -> do - initR <- initialR - return $ case initR of - IPartial s -> Partial n (SeqAR s) - IDone b -> Done n b - IError err -> errMsg err - Error err -> errMsg err - - step (SeqAR st) a = first SeqAR <$> stepR st a - - extract (SeqAR sR) = fmap (first SeqAR) (extractR sR) - extract (SeqAL sL) = do - rL <- extractL sL - case rL of - Done n _ -> do - iR <- initialR - case iR of - IPartial sR -> do - fmap (bimapOverrideCount n SeqAR id) (extractR sR) - IDone bR -> return $ Done n bR - IError err -> errMsg err - Error err -> errMsg err - Partial _ _ -> error "split_: Partial" - Continue n s -> return $ Continue n (SeqAL s) - --- | 'Applicative' form of 'splitWith'. -instance Monad m => Applicative (Parser a m) where - {-# INLINE pure #-} - pure = fromPure - - {-# INLINE (<*>) #-} - (<*>) = splitWith id - - {-# INLINE (*>) #-} - (*>) = split_ - - {-# INLINE liftA2 #-} - liftA2 f x = (<*>) (fmap f x) - -------------------------------------------------------------------------------- --- Sequential Alternative -------------------------------------------------------------------------------- - -{-# ANN type AltParseState Fuse #-} -data AltParseState sl sr = AltParseL !Int !sl | AltParseR !sr - --- Note: this implementation of alt is fast because of stream fusion but has --- quadratic time complexity, because each composition adds a new branch that --- each subsequent alternative's input element has to go through, therefore, it --- cannot scale to a large number of compositions - --- | Sequential alternative. The input is first passed to the first parser, and --- if it succeeds, the result is returned. However, if the first parser fails, --- the parser driver backtracks and tries the same input on the second parser, --- returning the result if it succeeds. --- --- Note: This implementation is not lazy in the second argument. The following --- will fail: --- --- >> Stream.parse (Parser.satisfy (> 0) `Parser.alt` undefined) $ Stream.fromList [1..10] --- *** Exception: Prelude.undefined --- --- Although this implementation allows stream fusion, it has quadratic --- complexity, making it suitable only for a small number of compositions. --- As a thumb rule use it for less than 8 compositions, use ParserK otherwise. --- --- /Time Complexity:/ O(n^2) where n is the number of compositions. --- --- /Pre-release/ --- -{-# INLINE alt #-} -alt :: Monad m => Parser x m a -> Parser x m a -> Parser x m a -alt (Parser stepL initialL extractL) (Parser stepR initialR extractR) = - Parser step initial extract - - where - - initial = do - resL <- initialL - case resL of - IPartial sl -> return $ IPartial $ AltParseL 0 sl - IDone bl -> return $ IDone bl - IError _ -> do - resR <- initialR - return $ case resR of - IPartial sr -> IPartial $ AltParseR sr - IDone br -> IDone br - IError err -> IError err - - -- Once a parser yields at least one value it cannot fail. This - -- restriction helps us make backtracking more efficient, as we do not need - -- to keep the consumed items buffered after a yield. Note that we do not - -- enforce this and if a misbehaving parser does not honor this then we can - -- get unexpected results. XXX Can we detect and flag this? - step (AltParseL cnt st) a = do - r <- stepL st a - case r of - Partial n s -> return $ Partial n (AltParseL 0 s) - Continue n s -> do - assertM(cnt + 1 - n >= 0) - return $ Continue n (AltParseL (cnt + 1 - n) s) - Done n b -> return $ Done n b - Error _ -> do - res <- initialR - return - $ case res of - IPartial rR -> Continue (cnt + 1) (AltParseR rR) - IDone b -> Done (cnt + 1) b - IError err -> Error err - - step (AltParseR st) a = do - r <- stepR st a - return $ case r of - Partial n s -> Partial n (AltParseR s) - Continue n s -> Continue n (AltParseR s) - Done n b -> Done n b - Error err -> Error err - - extract (AltParseR sR) = fmap (first AltParseR) (extractR sR) - - extract (AltParseL cnt sL) = do - rL <- extractL sL - case rL of - Done n b -> return $ Done n b - Error _ -> do - res <- initialR - return - $ case res of - IPartial rR -> Continue cnt (AltParseR rR) - IDone b -> Done cnt b - IError err -> Error err - Partial _ _ -> error "Bug: alt: extractL 'Partial'" - Continue n s -> do - assertM(n == cnt) - return $ Continue n (AltParseL 0 s) - -{-# ANN type Fused3 Fuse #-} -data Fused3 a b c = Fused3 !a !b !c - --- | See documentation of 'Streamly.Internal.Data.Parser.many'. --- --- /Pre-release/ --- -{-# INLINE splitMany #-} -splitMany :: Monad m => Parser a m b -> Fold m b c -> Parser a m c -splitMany (Parser step1 initial1 extract1) (Fold fstep finitial fextract) = - Parser step initial extract - - where - - -- Caution! There is mutual recursion here, inlining the right functions is - -- important. - - handleCollect partial done fres = - case fres of - FL.Partial fs -> do - pres <- initial1 - case pres of - IPartial ps -> return $ partial $ Fused3 ps 0 fs - IDone pb -> - runCollectorWith (handleCollect partial done) fs pb - IError _ -> done <$> fextract fs - FL.Done fb -> return $ done fb - - runCollectorWith cont fs pb = fstep fs pb >>= cont - - -- See notes in Fold.many for the reason why the parser must be initialized - -- right away instead of on first input. - initial = finitial >>= handleCollect IPartial IDone - - {-# INLINE step #-} - step (Fused3 st cnt fs) a = do - r <- step1 st a - let cnt1 = cnt + 1 - case r of - Partial n s -> do - assertM(cnt1 - n >= 0) - return $ Continue n (Fused3 s (cnt1 - n) fs) - Continue n s -> do - assertM(cnt1 - n >= 0) - return $ Continue n (Fused3 s (cnt1 - n) fs) - Done n b -> do - assertM(cnt1 - n >= 0) - fstep fs b >>= handleCollect (Partial n) (Done n) - Error _ -> do - xs <- fextract fs - return $ Done cnt xs - - extract (Fused3 _ 0 fs) = fmap (Done 0) (fextract fs) - extract (Fused3 s cnt fs) = do - r <- extract1 s - case r of - Error _ -> fmap (Done cnt) (fextract fs) - Done n b -> do - assertM(n <= cnt) - fs1 <- fstep fs b - case fs1 of - FL.Partial s1 -> fmap (Done n) (fextract s1) - FL.Done b1 -> return (Done n b1) - Partial _ _ -> error "splitMany: Partial in extract" - Continue n s1 -> do - assertM(n == cnt) - return (Continue n (Fused3 s1 0 fs)) - --- | Like splitMany, but inner fold emits an output at the end even if no input --- is received. --- --- /Internal/ --- -{-# INLINE splitManyPost #-} -splitManyPost :: Monad m => Parser a m b -> Fold m b c -> Parser a m c -splitManyPost (Parser step1 initial1 extract1) (Fold fstep finitial fextract) = - Parser step initial extract - - where - - -- Caution! There is mutual recursion here, inlining the right functions is - -- important. - - handleCollect partial done fres = - case fres of - FL.Partial fs -> do - pres <- initial1 - case pres of - IPartial ps -> return $ partial $ Fused3 ps 0 fs - IDone pb -> - runCollectorWith (handleCollect partial done) fs pb - IError _ -> done <$> fextract fs - FL.Done fb -> return $ done fb - - runCollectorWith cont fs pb = fstep fs pb >>= cont - - initial = finitial >>= handleCollect IPartial IDone - - {-# INLINE step #-} - step (Fused3 st cnt fs) a = do - r <- step1 st a - let cnt1 = cnt + 1 - case r of - Partial n s -> do - assertM(cnt1 - n >= 0) - return $ Continue n (Fused3 s (cnt1 - n) fs) - Continue n s -> do - assertM(cnt1 - n >= 0) - return $ Continue n (Fused3 s (cnt1 - n) fs) - Done n b -> do - assertM(cnt1 - n >= 0) - fstep fs b >>= handleCollect (Partial n) (Done n) - Error _ -> do - xs <- fextract fs - return $ Done cnt1 xs - - extract (Fused3 s cnt fs) = do - r <- extract1 s - case r of - Error _ -> fmap (Done cnt) (fextract fs) - Done n b -> do - assertM(n <= cnt) - fs1 <- fstep fs b - case fs1 of - FL.Partial s1 -> fmap (Done n) (fextract s1) - FL.Done b1 -> return (Done n b1) - Partial _ _ -> error "splitMany: Partial in extract" - Continue n s1 -> do - assertM(n == cnt) - return (Continue n (Fused3 s1 0 fs)) - --- | See documentation of 'Streamly.Internal.Data.Parser.some'. --- --- /Pre-release/ --- -{-# INLINE splitSome #-} -splitSome :: Monad m => Parser a m b -> Fold m b c -> Parser a m c -splitSome (Parser step1 initial1 extract1) (Fold fstep finitial fextract) = - Parser step initial extract - - where - - -- Caution! There is mutual recursion here, inlining the right functions is - -- important. - - handleCollect partial done fres = - case fres of - FL.Partial fs -> do - pres <- initial1 - case pres of - IPartial ps -> return $ partial $ Fused3 ps 0 $ Right fs - IDone pb -> - runCollectorWith (handleCollect partial done) fs pb - IError _ -> done <$> fextract fs - FL.Done fb -> return $ done fb - - runCollectorWith cont fs pb = fstep fs pb >>= cont - - initial = do - fres <- finitial - case fres of - FL.Partial fs -> do - pres <- initial1 - case pres of - IPartial ps -> return $ IPartial $ Fused3 ps 0 $ Left fs - IDone pb -> - runCollectorWith (handleCollect IPartial IDone) fs pb - IError err -> return $ IError err - FL.Done _ -> - return - $ IError - $ "splitSome: The collecting fold terminated without" - ++ " consuming any elements." - - {-# INLINE step #-} - step (Fused3 st cnt (Left fs)) a = do - r <- step1 st a - -- In the Left state, count is used only for the assert - let cnt1 = cnt + 1 - case r of - Partial n s -> do - assertM(cnt1 - n >= 0) - return $ Continue n (Fused3 s (cnt1 - n) (Left fs)) - Continue n s -> do - assertM(cnt1 - n >= 0) - return $ Continue n (Fused3 s (cnt1 - n) (Left fs)) - Done n b -> do - assertM(cnt1 - n >= 0) - fstep fs b >>= handleCollect (Partial n) (Done n) - Error err -> return $ Error err - step (Fused3 st cnt (Right fs)) a = do - r <- step1 st a - let cnt1 = cnt + 1 - case r of - Partial n s -> do - assertM(cnt1 - n >= 0) - return $ Partial n (Fused3 s (cnt1 - n) (Right fs)) - Continue n s -> do - assertM(cnt1 - n >= 0) - return $ Continue n (Fused3 s (cnt1 - n) (Right fs)) - Done n b -> do - assertM(cnt1 - n >= 0) - fstep fs b >>= handleCollect (Partial n) (Done n) - Error _ -> Done cnt1 <$> fextract fs - - extract (Fused3 s cnt (Left fs)) = do - r <- extract1 s - case r of - Error err -> return (Error err) - Done n b -> do - assertM(n <= cnt) - fs1 <- fstep fs b - case fs1 of - FL.Partial s1 -> fmap (Done n) (fextract s1) - FL.Done b1 -> return (Done n b1) - Partial _ _ -> error "splitSome: Partial in extract" - Continue n s1 -> do - assertM(n == cnt) - return (Continue n (Fused3 s1 0 (Left fs))) - extract (Fused3 s cnt (Right fs)) = do - r <- extract1 s - case r of - Error _ -> fmap (Done cnt) (fextract fs) - Done n b -> do - assertM(n <= cnt) - fs1 <- fstep fs b - case fs1 of - FL.Partial s1 -> fmap (Done n) (fextract s1) - FL.Done b1 -> return (Done n b1) - Partial _ _ -> error "splitSome: Partial in extract" - Continue n s1 -> do - assertM(n == cnt) - return (Continue n (Fused3 s1 0 (Right fs))) - --- | A parser that always fails with an error message without consuming --- any input. --- -{-# INLINE_NORMAL die #-} -die :: Monad m => String -> Parser a m b -die err = Parser undefined (pure (IError err)) undefined - --- | A parser that always fails with an effectful error message and without --- consuming any input. --- --- /Pre-release/ --- -{-# INLINE dieM #-} -dieM :: Monad m => m String -> Parser a m b -dieM err = Parser undefined (IError <$> err) undefined - --- Note: The default implementations of "some" and "many" loop infinitely --- because of the strict pattern match on both the arguments in applicative and --- alternative. With the direct style parser type we cannot use the mutually --- recursive definitions of "some" and "many". --- --- Note: With the direct style parser type, the list in "some" and "many" is --- accumulated strictly, it cannot be consumed lazily. - --- | Sequential alternative. The input is first passed to the first parser, and --- if it succeeds, the result is returned. However, if the first parser fails, --- the parser driver backtracks and tries the same input on the second parser, --- returning the result if it succeeds. --- --- Note: The implementation of '<|>' is not lazy in the second --- argument. The following code will fail: --- --- >>> Stream.parse (Parser.satisfy (> 0) <|> undefined) $ Stream.fromList [1..10] --- *** Exception: Prelude.undefined --- ... --- --- WARNING! this is not suitable for large scale use. As a thumb rule stream --- fusion works well for less than 8 compositions of this operation, otherwise --- consider using 'ParserK'. Do not use recursive parser implementations based --- on this Alternative instance. - -instance Monad m => Alternative (Parser a m) where - {-# INLINE empty #-} - empty = die "empty" - - {-# INLINE (<|>) #-} - (<|>) = alt - - {-# INLINE many #-} - many = flip splitMany toList - - {-# INLINE some #-} - some = flip splitSome toList - -{-# ANN type ConcatParseState Fuse #-} -data ConcatParseState sl m a b = - ConcatParseL !sl - | forall s. ConcatParseR (s -> a -> m (Step s b)) s (s -> m (Step s b)) - --- | Map a 'Parser' returning function on the result of a 'Parser'. --- --- /Pre-release/ --- -{-# INLINE concatMap #-} -concatMap :: Monad m => - (b -> Parser a m c) -> Parser a m b -> Parser a m c -concatMap func (Parser stepL initialL extractL) = Parser step initial extract - - where - - {-# INLINE initializeR #-} - initializeR (Parser stepR initialR extractR) = do - resR <- initialR - return $ case resR of - IPartial sr -> IPartial $ ConcatParseR stepR sr extractR - IDone br -> IDone br - IError err -> IError err - - initial = do - res <- initialL - case res of - IPartial s -> return $ IPartial $ ConcatParseL s - IDone b -> initializeR (func b) - IError err -> return $ IError err - - {-# INLINE initializeRL #-} - initializeRL n (Parser stepR initialR extractR) = do - resR <- initialR - return $ case resR of - IPartial sr -> Continue n $ ConcatParseR stepR sr extractR - IDone br -> Done n br - IError err -> Error err - - step (ConcatParseL st) a = do - r <- stepL st a - case r of - Partial n s -> return $ Continue n (ConcatParseL s) - Continue n s -> return $ Continue n (ConcatParseL s) - Done n b -> initializeRL n (func b) - Error err -> return $ Error err - - step (ConcatParseR stepR st extractR) a = do - r <- stepR st a - return $ case r of - Partial n s -> Partial n $ ConcatParseR stepR s extractR - Continue n s -> Continue n $ ConcatParseR stepR s extractR - Done n b -> Done n b - Error err -> Error err - - {-# INLINE extractP #-} - extractP n (Parser stepR initialR extractR) = do - res <- initialR - case res of - IPartial s -> - fmap - (first (\s1 -> ConcatParseR stepR s1 extractR)) - (extractR s) - IDone b -> return (Done n b) - IError err -> return $ Error err - - extract (ConcatParseR stepR s extractR) = - fmap (first (\s1 -> ConcatParseR stepR s1 extractR)) (extractR s) - extract (ConcatParseL sL) = do - rL <- extractL sL - case rL of - Error err -> return $ Error err - Done n b -> extractP n $ func b - Partial _ _ -> error "concatMap: extract Partial" - Continue n s -> return $ Continue n (ConcatParseL s) - -{-# INLINE noErrorUnsafeConcatMap #-} -noErrorUnsafeConcatMap :: Monad m => - (b -> Parser a m c) -> Parser a m b -> Parser a m c -noErrorUnsafeConcatMap func (Parser stepL initialL extractL) = - Parser step initial extract - - where - - {-# INLINE initializeR #-} - initializeR (Parser stepR initialR extractR) = do - resR <- initialR - return $ case resR of - IPartial sr -> IPartial $ ConcatParseR stepR sr extractR - IDone br -> IDone br - IError err -> IError err - - initial = do - res <- initialL - case res of - IPartial s -> return $ IPartial $ ConcatParseL s - IDone b -> initializeR (func b) - IError err -> return $ IError err - - {-# INLINE initializeRL #-} - initializeRL n (Parser stepR initialR extractR) = do - resR <- initialR - return $ case resR of - IPartial sr -> Partial n $ ConcatParseR stepR sr extractR - IDone br -> Done n br - IError err -> Error err - - step (ConcatParseL st) a = do - r <- stepL st a - case r of - Partial n s -> return $ Partial n (ConcatParseL s) - Continue n s -> return $ Continue n (ConcatParseL s) - Done n b -> initializeRL n (func b) - Error err -> return $ Error err - - step (ConcatParseR stepR st extractR) a = do - r <- stepR st a - return $ case r of - Partial n s -> Partial n $ ConcatParseR stepR s extractR - Continue n s -> Continue n $ ConcatParseR stepR s extractR - Done n b -> Done n b - Error err -> Error err - - {-# INLINE extractP #-} - extractP n (Parser stepR initialR extractR) = do - res <- initialR - case res of - IPartial s -> - fmap - (first (\s1 -> ConcatParseR stepR s1 extractR)) - (extractR s) - IDone b -> return (Done n b) - IError err -> return $ Error err - - extract (ConcatParseR stepR s extractR) = - fmap (first (\s1 -> ConcatParseR stepR s1 extractR)) (extractR s) - extract (ConcatParseL sL) = do - rL <- extractL sL - case rL of - Error err -> return $ Error err - Done n b -> extractP n $ func b - Partial _ _ -> error "concatMap: extract Partial" - Continue n s -> return $ Continue n (ConcatParseL s) - --- Note: The monad instance has quadratic performance complexity. It works fine --- for small number of compositions but for a scalable implementation we need a --- CPS version. - --- | See documentation of 'Streamly.Internal.Data.Parser.ParserK.Type.Parser'. --- --- Although this implementation allows stream fusion, it has quadratic --- complexity, making it suitable only for a small number of compositions. As a --- thumb rule use it for less than 8 compositions, use 'ParserK' otherwise. --- -instance Monad m => Monad (Parser a m) where - {-# INLINE return #-} - return = pure - - {-# INLINE (>>=) #-} - (>>=) = flip concatMap - - {-# INLINE (>>) #-} - (>>) = (*>) - -instance Monad m => Fail.MonadFail (Parser a m) where - {-# INLINE fail #-} - fail = die - -{- --- | See documentation of 'Streamly.Internal.Data.Parser.ParserK.Type.Parser'. --- -instance Monad m => MonadPlus (Parser a m) where - {-# INLINE mzero #-} - mzero = die "mzero" - - {-# INLINE mplus #-} - mplus = alt --} - -instance (Monad m, MonadIO m) => MonadIO (Parser a m) where - {-# INLINE liftIO #-} - liftIO = fromEffect . liftIO - ------------------------------------------------------------------------------- --- Mapping on input ------------------------------------------------------------------------------- - --- | @lmap f parser@ maps the function @f@ on the input of the parser. --- --- >>> Stream.parse (Parser.lmap (\x -> x * x) (Parser.fromFold Fold.sum)) (Stream.enumerateFromTo 1 100) --- Right 338350 --- --- > lmap = Parser.lmapM return --- -{-# INLINE lmap #-} -lmap :: (a -> b) -> Parser b m r -> Parser a m r -lmap f (Parser step begin done) = Parser step1 begin done - - where - - step1 x a = step x (f a) - --- | @lmapM f parser@ maps the monadic function @f@ on the input of the parser. --- -{-# INLINE lmapM #-} -lmapM :: Monad m => (a -> m b) -> Parser b m r -> Parser a m r -lmapM f (Parser step begin done) = Parser step1 begin done - - where - - step1 x a = f a >>= step x - --- | Include only those elements that pass a predicate. --- --- >>> Stream.parse (Parser.filter (> 5) (Parser.fromFold Fold.sum)) $ Stream.fromList [1..10] --- Right 40 --- -{-# INLINE filter #-} -filter :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b -filter f (Parser step initial extract) = Parser step1 initial extract - - where - - step1 x a = if f a then step x a else return $ Partial 0 x diff --git a/src/Streamly/Internal/Data/Parser/ParserK/Type.hs b/src/Streamly/Internal/Data/Parser/ParserK/Type.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Parser/ParserK/Type.hs +++ /dev/null @@ -1,545 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Parser.ParserK.Type --- Copyright : (c) 2020 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- CPS style implementation of parsers. --- --- The CPS representation allows linear performance for Applicative, sequence, --- Monad, Alternative, and choice operations compared to the quadratic --- complexity of the corresponding direct style operations. However, direct --- style operations allow fusion with ~10x better performance than CPS. --- --- The direct style representation does not allow for recursive definitions of --- "some" and "many" whereas CPS allows that. --- --- 'Applicative' and 'Control.Applicative.Alternative' type class based --- combinators from the --- --- package can also be used with the 'ParserK' type. - -module Streamly.Internal.Data.Parser.ParserK.Type - ( - Step (..) - , Input (..) - , ParseResult (..) - , ParserK (..) - , fromParser - -- , toParser - , fromPure - , fromEffect - , die - ) -where - -#include "ArrayMacros.h" -#include "assert.hs" -#include "inline.hs" - -import Control.Applicative (Alternative(..), liftA2) -import Control.Monad (MonadPlus(..), ap) -import Control.Monad.IO.Class (MonadIO, liftIO) --- import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.Proxy (Proxy(..)) -import GHC.Types (SPEC(..)) -import Streamly.Internal.Data.Array.Type (Array(..)) -import Streamly.Internal.Data.Unboxed (peekWith, sizeOf, Unbox) -import Streamly.Internal.System.IO (unsafeInlineIO) - -import qualified Control.Monad.Fail as Fail -import qualified Streamly.Internal.Data.Array.Type as Array -import qualified Streamly.Internal.Data.Parser.ParserD.Type as ParserD - -data Input a = None | Chunk {-# UNPACK #-} !(Array a) - --- | The intermediate result of running a parser step. The parser driver may --- stop with a final result, pause with a continuation to resume, or fail with --- an error. --- --- See ParserD docs. This is the same as the ParserD Step except that it uses a --- continuation in Partial and Continue constructors instead of a state in case --- of ParserD. --- --- /Pre-release/ --- -data Step a m r = - -- The Int is the current stream position index wrt to the start of the - -- array. - Done !Int r - -- XXX we can use a "resume" and a "stop" continuations instead of Maybe. - -- measure if that works any better. - -- Array a -> m (Step a m r), m (Step a m r) - | Partial !Int (Input a -> m (Step a m r)) - | Continue !Int (Input a -> m (Step a m r)) - | Error !Int String - -instance Functor m => Functor (Step a m) where - fmap f (Done n r) = Done n (f r) - fmap f (Partial n k) = Partial n (fmap (fmap f) . k) - fmap f (Continue n k) = Continue n (fmap (fmap f) . k) - fmap _ (Error n e) = Error n e - --- Note: Passing position index separately instead of passing it with the --- result causes huge regression in expression parsing becnhmarks. - --- | The parser's result. --- --- Int is the position index into the current input array. Could be negative. --- Cannot be beyond the input array max bound. --- --- /Pre-release/ --- -data ParseResult b = - Success !Int !b -- Position index, result - | Failure !Int !String -- Position index, error - --- | Map a function over 'Success'. -instance Functor ParseResult where - fmap f (Success n b) = Success n (f b) - fmap _ (Failure n e) = Failure n e - --- XXX Change the type to the shape (a -> m r -> m r) -> (m r -> m r) -> m r --- --- The parse continuation would be: Array a -> m (Step a m r) -> m (Step a m r) --- The extract continuation would be: m (Step a m r) -> m (Step a m r) --- --- Use Step itself in place of ParseResult. - --- | A continuation passing style parser representation. A continuation of --- 'Step's, each step passes a state and a parse result to the next 'Step'. The --- resulting 'Step' may carry a continuation that consumes input 'a' and --- results in another 'Step'. Essentially, the continuation may either consume --- input without a result or return a result with no further input to be --- consumed. --- -newtype ParserK a m b = MkParser - { runParser :: forall r. - -- Using "Input" in runParser is not necessary but it avoids making - -- one more function call to get the input. This could be helpful - -- for cases where we process just one element per call. - -- - -- Do not eta reduce the applications of this continuation. - -- - (ParseResult b -> Int -> Input a -> m (Step a m r)) - -- XXX Maintain and pass the original position in the stream. that - -- way we can also report better errors. Use a Context structure for - -- passing the state. - - -- Stream position index wrt to the current input array start. If - -- negative then backtracking is required before using the array. - -- The parser should use "Continue -n" in this case if it needs to - -- consume input. Negative value cannot be beyond the current - -- backtrack buffer. Positive value cannot be beyond array length. - -- If the parser needs to advance beyond the array length it should - -- use "Continue +n". - -> Int - -- used elem count, a count of elements consumed by the parser. If - -- an Alternative fails we need to backtrack by this amount. - -> Int - -- The second argument is the used count as described above. The - -- current input position is carried as part of 'Success' - -- constructor of 'ParseResult'. - -- XXX Use Array a, determine eof by using a nil array - -> Input a - -> m (Step a m r) - } - -------------------------------------------------------------------------------- --- Functor -------------------------------------------------------------------------------- - --- XXX rewrite this using ParserD, expose rmapM from ParserD. --- | Maps a function over the output of the parser. --- -instance Functor m => Functor (ParserK a m) where - {-# INLINE fmap #-} - fmap f parser = MkParser $ \k n st arr -> - let k1 res = k (fmap f res) - in runParser parser k1 n st arr - -------------------------------------------------------------------------------- --- Sequential applicative -------------------------------------------------------------------------------- - --- This is the dual of stream "fromPure". --- --- | A parser that always yields a pure value without consuming any input. --- --- /Pre-release/ --- -{-# INLINE fromPure #-} -fromPure :: b -> ParserK a m b -fromPure b = MkParser $ \k n st arr -> k (Success n b) st arr - --- | See 'Streamly.Internal.Data.Parser.fromEffect'. --- --- /Pre-release/ --- -{-# INLINE fromEffect #-} -fromEffect :: Monad m => m b -> ParserK a m b -fromEffect eff = - MkParser $ \k n st arr -> eff >>= \b -> k (Success n b) st arr - --- | 'Applicative' form of 'Streamly.Internal.Data.Parser.splitWith'. Note that --- this operation does not fuse, use 'Streamly.Internal.Data.Parser.splitWith' --- when fusion is important. --- -instance Monad m => Applicative (ParserK a m) where - {-# INLINE pure #-} - pure = fromPure - - {-# INLINE (<*>) #-} - (<*>) = ap - - {-# INLINE (*>) #-} - p1 *> p2 = MkParser $ \k n st arr -> - let k1 (Success n1 _) s input = runParser p2 k n1 s input - k1 (Failure n1 e) s input = k (Failure n1 e) s input - in runParser p1 k1 n st arr - - {-# INLINE (<*) #-} - p1 <* p2 = MkParser $ \k n st arr -> - let k1 (Success n1 b) s1 input = - let k2 (Success n2 _) s2 input2 = k (Success n2 b) s2 input2 - k2 (Failure n2 e) s2 input2 = k (Failure n2 e) s2 input2 - in runParser p2 k2 n1 s1 input - k1 (Failure n1 e) s1 input = k (Failure n1 e) s1 input - in runParser p1 k1 n st arr - - {-# INLINE liftA2 #-} - liftA2 f p = (<*>) (fmap f p) - -------------------------------------------------------------------------------- --- Monad -------------------------------------------------------------------------------- - --- This is the dual of "nil". --- --- | A parser that always fails with an error message without consuming --- any input. --- --- /Pre-release/ --- -{-# INLINE die #-} -die :: String -> ParserK a m b -die err = MkParser (\k n st arr -> k (Failure n err) st arr) - --- | Monad composition can be used for lookbehind parsers, we can make the --- future parses depend on the previously parsed values. --- --- If we have to parse "a9" or "9a" but not "99" or "aa" we can use the --- following parser: --- --- @ --- backtracking :: MonadCatch m => PR.Parser Char m String --- backtracking = --- sequence [PR.satisfy isDigit, PR.satisfy isAlpha] --- '<|>' --- sequence [PR.satisfy isAlpha, PR.satisfy isDigit] --- @ --- --- We know that if the first parse resulted in a digit at the first place then --- the second parse is going to fail. However, we waste that information and --- parse the first character again in the second parse only to know that it is --- not an alphabetic char. By using lookbehind in a 'Monad' composition we can --- avoid redundant work: --- --- @ --- data DigitOrAlpha = Digit Char | Alpha Char --- --- lookbehind :: MonadCatch m => PR.Parser Char m String --- lookbehind = do --- x1 \<- Digit '<$>' PR.satisfy isDigit --- '<|>' Alpha '<$>' PR.satisfy isAlpha --- --- -- Note: the parse depends on what we parsed already --- x2 <- case x1 of --- Digit _ -> PR.satisfy isAlpha --- Alpha _ -> PR.satisfy isDigit --- --- return $ case x1 of --- Digit x -> [x,x2] --- Alpha x -> [x,x2] --- @ --- --- See also 'Streamly.Internal.Data.Parser.concatMap'. This monad instance --- does not fuse, use 'Streamly.Internal.Data.Parser.concatMap' when you need --- fusion. --- -instance Monad m => Monad (ParserK a m) where - {-# INLINE return #-} - return = pure - - {-# INLINE (>>=) #-} - p >>= f = MkParser $ \k n st arr -> - let k1 (Success n1 b) s1 inp = runParser (f b) k n1 s1 inp - k1 (Failure n1 e) s1 inp = k (Failure n1 e) s1 inp - in runParser p k1 n st arr - - {-# INLINE (>>) #-} - (>>) = (*>) - -#if !(MIN_VERSION_base(4,13,0)) - -- This is redefined instead of just being Fail.fail to be - -- compatible with base 4.8. - {-# INLINE fail #-} - fail = die -#endif -instance Monad m => Fail.MonadFail (ParserK a m) where - {-# INLINE fail #-} - fail = die - -instance MonadIO m => MonadIO (ParserK a m) where - {-# INLINE liftIO #-} - liftIO = fromEffect . liftIO - -------------------------------------------------------------------------------- --- Alternative -------------------------------------------------------------------------------- - --- | 'Alternative' form of 'Streamly.Internal.Data.Parser.alt'. Backtrack and --- run the second parser if the first one fails. --- --- The "some" and "many" operations of alternative accumulate results in a pure --- list which is not scalable and streaming. Instead use --- 'Streamly.Internal.Data.Parser.some' and --- 'Streamly.Internal.Data.Parser.many' for fusible operations with composable --- accumulation of results. --- --- See also 'Streamly.Internal.Data.Parser.alt'. This 'Alternative' instance --- does not fuse, use 'Streamly.Internal.Data.Parser.alt' when you need --- fusion. --- -instance Monad m => Alternative (ParserK a m) where - {-# INLINE empty #-} - empty = die "empty" - - {-# INLINE (<|>) #-} - p1 <|> p2 = MkParser $ \k n _ arr -> - let - k1 (Failure pos _) used input = runParser p2 k (pos - used) 0 input - k1 success _ input = k success 0 input - in runParser p1 k1 n 0 arr - - -- some and many are implemented here instead of using default definitions - -- so that we can use INLINE on them. It gives 50% performance improvement. - - {-# INLINE many #-} - many v = many_v - - where - - many_v = some_v <|> pure [] - some_v = (:) <$> v <*> many_v - - {-# INLINE some #-} - some v = some_v - - where - - many_v = some_v <|> pure [] - some_v = (:) <$> v <*> many_v - --- | 'mzero' is same as 'empty', it aborts the parser. 'mplus' is same as --- '<|>', it selects the first succeeding parser. --- -instance Monad m => MonadPlus (ParserK a m) where - {-# INLINE mzero #-} - mzero = die "mzero" - - {-# INLINE mplus #-} - mplus = (<|>) - -{- -instance MonadTrans (ParserK a) where - {-# INLINE lift #-} - lift = fromEffect --} - -------------------------------------------------------------------------------- --- Convert ParserD to ParserK -------------------------------------------------------------------------------- - -{-# INLINE parseDToK #-} -parseDToK - :: forall m a s b r. (Monad m, Unbox a) - => (s -> a -> m (ParserD.Step s b)) - -> m (ParserD.Initial s b) - -> (s -> m (ParserD.Step s b)) - -> (ParseResult b -> Int -> Input a -> m (Step a m r)) - -> Int - -> Int - -> Input a - -> m (Step a m r) -parseDToK pstep initial extract cont !offset0 !usedCount !input = do - res <- initial - case res of - ParserD.IPartial pst -> do - case input of - Chunk arr -> parseContChunk usedCount offset0 pst arr - None -> parseContNothing usedCount pst - ParserD.IDone b -> cont (Success offset0 b) usedCount input - ParserD.IError err -> cont (Failure offset0 err) usedCount input - - where - - -- XXX We can maintain an absolute position instead of relative that will - -- help in reporting of error location in the stream. - {-# NOINLINE parseContChunk #-} - parseContChunk !count !offset !state arr@(Array contents start end) = do - if offset >= 0 - then go SPEC (start + offset * SIZE_OF(a)) state - else return $ Continue offset (parseCont count state) - - where - - {-# INLINE onDone #-} - onDone n b = - assert (n <= Array.length arr) - (cont (Success n b) (count + n - offset) (Chunk arr)) - - {-# INLINE callParseCont #-} - callParseCont constr n pst1 = - assert (n < 0 || n >= Array.length arr) - (return $ constr n (parseCont (count + n - offset) pst1)) - - {-# INLINE onPartial #-} - onPartial = callParseCont Partial - - {-# INLINE onContinue #-} - onContinue = callParseCont Continue - - {-# INLINE onError #-} - onError n err = - cont (Failure n err) (count + n - offset) (Chunk arr) - - {-# INLINE onBack #-} - onBack offset1 elemSize constr pst = do - let pos = offset1 - start - in if pos >= 0 - then go SPEC offset1 pst - else constr (pos `div` elemSize) pst - - -- Note: div may be expensive but the alternative is to maintain an element - -- offset in addition to a byte offset or just the element offset and use - -- multiplication to get the byte offset every time, both these options - -- turned out to be more expensive than using div. - go !_ !cur !pst | cur >= end = - onContinue ((end - start) `div` SIZE_OF(a)) pst - go !_ !cur !pst = do - let !x = unsafeInlineIO $ peekWith contents cur - pRes <- pstep pst x - let elemSize = SIZE_OF(a) - next = INDEX_NEXT(cur,a) - back n = next - n * elemSize - curOff = (cur - start) `div` elemSize - nextOff = (next - start) `div` elemSize - -- The "n" here is stream position index wrt the array start, and - -- not the backtrack count as returned by byte stream parsers. - case pRes of - ParserD.Done 0 b -> - onDone nextOff b - ParserD.Done 1 b -> - onDone curOff b - ParserD.Done n b -> - onDone ((back n - start) `div` elemSize) b - ParserD.Partial 0 pst1 -> - go SPEC next pst1 - ParserD.Partial 1 pst1 -> - go SPEC cur pst1 - ParserD.Partial n pst1 -> - onBack (back n) elemSize onPartial pst1 - ParserD.Continue 0 pst1 -> - go SPEC next pst1 - ParserD.Continue 1 pst1 -> - go SPEC cur pst1 - ParserD.Continue n pst1 -> - onBack (back n) elemSize onContinue pst1 - ParserD.Error err -> - onError curOff err - - {-# NOINLINE parseContNothing #-} - parseContNothing !count !pst = do - r <- extract pst - case r of - -- IMPORTANT: the n here is from the byte stream parser, that means - -- it is the backtrack element count and not the stream position - -- index into the current input array. - ParserD.Done n b -> - assert (n >= 0) - (cont (Success (- n) b) (count - n) None) - ParserD.Continue n pst1 -> - assert (n >= 0) - (return $ Continue (- n) (parseCont (count - n) pst1)) - ParserD.Error err -> - -- XXX It is called only when there is no input arr. So using 0 - -- as the position is correct? - cont (Failure 0 err) count None - ParserD.Partial _ _ -> error "Bug: parseDToK Partial unreachable" - - -- XXX Maybe we can use two separate continuations instead of using - -- Just/Nothing cases here. That may help in avoiding the parseContJust - -- function call. - {-# INLINE parseCont #-} - parseCont !cnt !pst (Chunk arr) = parseContChunk cnt 0 pst arr - parseCont !cnt !pst None = parseContNothing cnt pst - --- | Convert a raw byte 'Parser' to a chunked 'ParserK'. --- --- /Pre-release/ --- -{-# INLINE_LATE fromParser #-} -fromParser :: (Monad m, Unbox a) => ParserD.Parser a m b -> ParserK a m b -fromParser (ParserD.Parser step initial extract) = - MkParser $ parseDToK step initial extract - -{- -------------------------------------------------------------------------------- --- Convert CPS style 'Parser' to direct style 'D.Parser' -------------------------------------------------------------------------------- - --- | A continuation to extract the result when a CPS parser is done. -{-# INLINE parserDone #-} -parserDone :: Monad m => ParseResult b -> Int -> Input a -> m (Step a m b) -parserDone (Success n b) _ None = return $ Done n b -parserDone (Failure n e) _ None = return $ Error n e -parserDone _ _ _ = error "Bug: toParser: called with input" - --- | Convert a CPS style 'ParserK' to a direct style 'ParserD.Parser'. --- --- /Pre-release/ --- -{-# INLINE_LATE toParser #-} -toParser :: Monad m => ParserK a m b -> ParserD.Parser a m b -toParser parser = ParserD.Parser step initial extract - - where - - initial = pure (ParserD.IPartial (\x -> runParser parser 0 0 x parserDone)) - - step cont a = do - r <- cont (Single a) - return $ case r of - Done n b -> ParserD.Done n b - Error _ e -> ParserD.Error e - Partial n cont1 -> ParserD.Partial n cont1 - Continue n cont1 -> ParserD.Continue n cont1 - - extract cont = do - r <- cont None - case r of - Done n b -> return $ ParserD.Done n b - Error _ e -> return $ ParserD.Error e - Partial _ cont1 -> extract cont1 - Continue n cont1 -> return $ ParserD.Continue n cont1 - -#ifndef DISABLE_FUSION -{-# RULES "fromParser/toParser fusion" [2] - forall s. toParser (fromParser s) = s #-} -{-# RULES "toParser/fromParser fusion" [2] - forall s. fromParser (toParser s) = s #-} -#endif --} diff --git a/src/Streamly/Internal/Data/Parser/Tee.hs b/src/Streamly/Internal/Data/Parser/Tee.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser/Tee.hs @@ -0,0 +1,617 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Parser.ParserD.Tee +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Parallel parsers. Distributing the input to multiple parsers at the same +-- time. +-- +-- For simplicity, we are using code where a particular state is unreachable +-- but it is not prevented by types. Somehow uni-pattern match using "let" +-- produces better optimized code compared to using @case@ match and using +-- explicit error messages in unreachable cases. +-- +-- There seem to be no way to silence individual warnings so we use a global +-- incomplete uni-pattern match warning suppression option for the file. +-- Disabling the warning for other code as well has the potential to mask off +-- some legit warnings, therefore, we have segregated only the code that uses +-- uni-pattern matches in this module. + +module Streamly.Internal.Data.Parser.Tee + ( + {- + -- Parallel zipped + teeWith + , teeWithFst + , teeWithMin + + -- Parallel alternatives + , shortest + , longest + -} + ) +where + +{- +import Control.Exception (assert) +import Control.Monad.Catch (MonadCatch, try) +import Prelude + hiding (any, all, takeWhile) + +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Parser.ParserD.Type + (Initial(..), Parser(..), Step(..), ParseError) + +------------------------------------------------------------------------------- +-- Distribute input to two parsers and collect both results +------------------------------------------------------------------------------- + +-- When the input stream is distributed to two parsers, both the parsers can +-- backtrack independently. Therefore, we need separate buffer state for each +-- parser. +-- +-- ParserK +-- +-- We can keep the state of each parser in the zipper and pass around that +-- zipper to the parsers. Each parser can consume from the zipper and then pass +-- around the zipper to the other parser. +-- +-- ParserD +-- +-- In the approach we have taken here, the driver pushes one element at a time +-- to the tee and each of the parsers in the tee may buffer it independently +-- for backtracking. So they do not need to depend on the original stream +-- source for individual parser backtracking. Problem arises when both the +-- parsers backtrack and they do not need any input from the driver rather they +-- must consume from their buffers. For such situation we may need a +-- "Continue" style driver command from the tee so that the driver runs +-- the tee without providing it any input. Or we may need a local driver loop +-- until new input is to be demanded from the input stream. +-- +-- When the tee errors out or stops, the tee driver may have to backtrack by +-- the specified amount (or the tee must return the leftover input). Therefore, +-- the tee driver also has to buffer, this leads to triple buffering. +-- +-- When the tee stops we need to determine the backtracking amount from the +-- leftover of both the parsers. Since both the parsers may have consumed +-- different lengths of the stream we consider the maximum of the two as +-- consumed. +-- + -- XXX We can use Initial instead of StepState +{-# ANN type StepState Fuse #-} +data StepState s a = StepState s | StepResult a + +-- | State of the pair of parsers in a tee composition +-- Note: strictness annotation is important for fusing the constructors +{-# ANN type TeeState Fuse #-} +data TeeState sL sR x a b = +-- @TeePair (past buffer, parser state, future-buffer1, future-buffer2) ...@ + TeePair !([x], StepState sL a, [x], [x]) !([x], StepState sR b, [x], [x]) + +{-# ANN type Res Fuse #-} +data Res = Yld Int | Stp Int | Skp | Err String + +-- | See 'Streamly.Internal.Data.Parser.teeWith'. +-- +-- /Broken/ +-- +{-# INLINE teeWith #-} +teeWith :: Monad m + => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c +teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) = + Parser step initial extract + + where + + {-# INLINE_LATE initial #-} + initial = do + resL <- initialL + resR <- initialR + return $ case resL of + IPartial sl -> + case resR of + IPartial sr -> IPartial $ TeePair ([], StepState sl, [], []) + ([], StepState sr, [], []) + IDone br -> IPartial $ TeePair ([], StepState sl, [], []) + ([], StepResult br, [], []) + IError err -> IError err + IDone bl -> + case resR of + IPartial sr -> + IPartial $ TeePair ([], StepResult bl, [], []) + ([], StepState sr, [], []) + IDone br -> IDone $ zf bl br + IError err -> IError err + IError err -> IError err + + {-# INLINE consume #-} + consume buf inp1 inp2 stp st y = do + let (x, inp11, inp21) = + case inp1 of + [] -> (y, [], []) + z : [] -> (z, reverse (x:inp2), []) + z : zs -> (z, zs, x:inp2) + r <- stp st x + let buf1 = x:buf + return (buf1, r, inp11, inp21) + + -- XXX This is currently broken, even though both the parsers need to + -- consume from their buffers after backtracking the driver would still be + -- pushing more input to the buffers. + -- + -- consume one input item and return the next state of the fold + {-# INLINE useStream #-} + useStream buf inp1 inp2 stp st y = do + (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y + case r of + Partial 0 s -> + let state = ([], StepState s, inp11, inp21) + in return (state, Yld 0) + Partial n s -> + let src0 = Prelude.take n buf1 + src = Prelude.reverse src0 + state = ([], StepState s, src ++ inp11, inp21) + in assert (n <= length buf1) (return (state, Yld n)) + Done n b -> + let state = (Prelude.take n buf1, StepResult b, inp11, inp21) + in assert (n <= length buf1) (return (state, Stp n)) + -- Continue 0 s -> (buf1, Right s, inp11, inp21) + Continue n s -> + let (src0, buf2) = splitAt n buf1 + src = Prelude.reverse src0 + state = (buf2, StepState s, src ++ inp11, inp21) + in assert (n <= length buf1) (return (state, Skp)) + SError err -> return (undefined, Err err) + + {-# INLINE_LATE step #-} + step (TeePair (bufL, StepState sL, inpL1, inpL2) + (bufR, StepState sR, inpR1, inpR2)) x = do + (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x + (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x + let next = TeePair l r + return $ case (stL,stR) of + (Yld n1, Yld n2) -> Partial (min n1 n2) next + (Yld n1, Stp n2) -> Partial (min n1 n2) next + (Stp n1, Yld n2) -> Partial (min n1 n2) next + (Stp n1, Stp n2) -> + -- Uni-pattern match results in better optimized code compared + -- to a case match. + let (_, StepResult rL, _, _) = l + (_, StepResult rR, _, _) = r + in Done (min n1 n2) (zf rL rR) + (Err err, _) -> SError err + (_, Err err) -> SError err + _ -> Continue 0 next + + step (TeePair (bufL, StepState sL, inpL1, inpL2) + r@(_, StepResult rR, _, _)) x = do + (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x + let next = TeePair l r + -- XXX If the unused count of this stream is lower than the unused + -- count of the stopped stream, only then this will be correct. We need + -- to fix the other case. We need to keep incrementing the unused count + -- of the stopped stream and take the min of the two. + return $ case stL of + Yld n -> Partial n next + Stp n -> + let (_, StepResult rL, _, _) = l + in Done n (zf rL rR) + Skp -> Continue 0 next + Err err -> SError err + + step (TeePair l@(_, StepResult rL, _, _) + (bufR, StepState sR, inpR1, inpR2)) x = do + (r, stR) <- useStream bufR inpR1 inpR2 stepR sR x + let next = TeePair l r + -- XXX If the unused count of this stream is lower than the unused + -- count of the stopped stream, only then this will be correct. We need + -- to fix the other case. We need to keep incrementing the unused count + -- of the stopped stream and take the min of the two. + return $ case stR of + Yld n -> Partial n next + Stp n -> + let (_, StepResult rR, _, _) = r + in Done n (zf rL rR) + Skp -> Continue 0 next + Err err -> SError err + + step _ _ = undefined + + {-# INLINE_LATE extract #-} + extract st = + case st of + TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do + rL <- extractL sL + rR <- extractR sR + return $ zf rL rR + TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do + rL <- extractL sL + return $ zf rL rR + TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do + rR <- extractR sR + return $ zf rL rR + TeePair (_, StepResult rL, _, _) (_, StepResult rR, _, _) -> + return $ zf rL rR + +-- | See 'Streamly.Internal.Data.Parser.teeWithFst'. +-- +-- /Broken/ +-- +{-# INLINE teeWithFst #-} +teeWithFst :: Monad m + => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c +teeWithFst zf (Parser stepL initialL extractL) + (Parser stepR initialR extractR) = + Parser step initial extract + + where + + {-# INLINE_LATE initial #-} + initial = do + resL <- initialL + resR <- initialR + case resL of + IPartial sl -> + return $ case resR of + IPartial sr -> IPartial $ TeePair ([], StepState sl, [], []) + ([], StepState sr, [], []) + IDone br -> IPartial $ TeePair ([], StepState sl, [], []) + ([], StepResult br, [], []) + IError err -> IError err + IDone bl -> + case resR of + IPartial sr -> IDone . zf bl <$> extractR sr + IDone br -> return $ IDone $ zf bl br + IError err -> return $ IError err + IError err -> return $ IError err + + {-# INLINE consume #-} + consume buf inp1 inp2 stp st y = do + let (x, inp11, inp21) = + case inp1 of + [] -> (y, [], []) + z : [] -> (z, reverse (x:inp2), []) + z : zs -> (z, zs, x:inp2) + r <- stp st x + let buf1 = x:buf + return (buf1, r, inp11, inp21) + + -- consume one input item and return the next state of the fold + {-# INLINE useStream #-} + useStream buf inp1 inp2 stp st y = do + (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y + case r of + Partial 0 s -> + let state = ([], StepState s, inp11, inp21) + in return (state, Yld 0) + Partial n _ -> return (undefined, Yld n) -- Not implemented + Done n b -> + let state = (Prelude.take n buf1, StepResult b, inp11, inp21) + in assert (n <= length buf1) (return (state, Stp n)) + -- Continue 0 s -> (buf1, Right s, inp11, inp21) + Continue n s -> + let (src0, buf2) = splitAt n buf1 + src = Prelude.reverse src0 + state = (buf2, StepState s, src ++ inp11, inp21) + in assert (n <= length buf1) (return (state, Skp)) + SError err -> return (undefined, Err err) + + {-# INLINE_LATE step #-} + step (TeePair (bufL, StepState sL, inpL1, inpL2) + (bufR, StepState sR, inpR1, inpR2)) x = do + (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x + (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x + let next = TeePair l r + case (stL,stR) of + -- XXX what if the first parser returns an unused count which is + -- more than the second parser's unused count? It does not make + -- sense for the second parser to consume more than the first + -- parser. We reset the input cursor based on the first parser. + -- SError out if the second one has consumed more then the first? + (Stp n1, Stp _) -> + -- Uni-pattern match results in better optimized code compared + -- to a case match. + let (_, StepResult rL, _, _) = l + (_, StepResult rR, _, _) = r + in return $ Done n1 (zf rL rR) + (Stp n1, Yld _) -> + let (_, StepResult rL, _, _) = l + (_, StepState ssR, _, _) = r + in do + rR <- extractR ssR + return $ Done n1 (zf rL rR) + (Yld n1, Yld n2) -> return $ Partial (min n1 n2) next + (Yld n1, Stp n2) -> return $ Partial (min n1 n2) next + (Err err, _) -> return $ SError err + (_, Err err) -> return $ SError err + _ -> return $ Continue 0 next + + step (TeePair (bufL, StepState sL, inpL1, inpL2) + r@(_, StepResult rR, _, _)) x = do + (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x + let next = TeePair l r + -- XXX If the unused count of this stream is lower than the unused + -- count of the stopped stream, only then this will be correct. We need + -- to fix the other case. We need to keep incrementing the unused count + -- of the stopped stream and take the min of the two. + return $ case stL of + Yld n -> Partial n next + Stp n -> + let (_, StepResult rL, _, _) = l + in Done n (zf rL rR) + Skp -> Continue 0 next + Err err -> SError err + + step _ _ = undefined + + {-# INLINE_LATE extract #-} + extract st = + case st of + TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do + rL <- extractL sL + rR <- extractR sR + return $ zf rL rR + TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do + rL <- extractL sL + return $ zf rL rR + _ -> error "unreachable" + +-- | See 'Streamly.Internal.Data.Parser.teeWithMin'. +-- +-- /Unimplemented/ +-- +{-# INLINE teeWithMin #-} +teeWithMin :: + -- Monad m => + (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c +teeWithMin = undefined + +------------------------------------------------------------------------------- +-- Distribute input to two parsers and choose one result +------------------------------------------------------------------------------- + +-- | See 'Streamly.Internal.Data.Parser.shortest'. +-- +-- /Broken/ +-- +{-# INLINE shortest #-} +shortest :: Monad m => Parser x m a -> Parser x m a -> Parser x m a +shortest (Parser stepL initialL extractL) (Parser stepR initialR _) = + Parser step initial extract + + where + + {-# INLINE_LATE initial #-} + initial = do + resL <- initialL + resR <- initialR + return $ case resL of + IPartial sl -> + case resR of + IPartial sr -> IPartial $ TeePair ([], StepState sl, [], []) + ([], StepState sr, [], []) + IDone br -> IDone br + IError err -> IError err + IDone bl -> IDone bl + IError errL -> + case resR of + IPartial _ -> IError errL + IDone br -> IDone br + IError errR -> IError errR + + {-# INLINE consume #-} + consume buf inp1 inp2 stp st y = do + let (x, inp11, inp21) = + case inp1 of + [] -> (y, [], []) + z : [] -> (z, reverse (x:inp2), []) + z : zs -> (z, zs, x:inp2) + r <- stp st x + let buf1 = x:buf + return (buf1, r, inp11, inp21) + + -- consume one input item and return the next state of the fold + {-# INLINE useStream #-} + useStream buf inp1 inp2 stp st y = do + (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y + case r of + Partial 0 s -> + let state = ([], StepState s, inp11, inp21) + in return (state, Yld 0) + Partial n _ -> return (undefined, Yld n) -- Not implemented + Done n b -> + let state = (Prelude.take n buf1, StepResult b, inp11, inp21) + in assert (n <= length buf1) (return (state, Stp n)) + -- Continue 0 s -> (buf1, Right s, inp11, inp21) + Continue n s -> + let (src0, buf2) = splitAt n buf1 + src = Prelude.reverse src0 + state = (buf2, StepState s, src ++ inp11, inp21) + in assert (n <= length buf1) (return (state, Skp)) + SError err -> return (undefined, Err err) + + -- XXX Even if a parse finished earlier it may not be shortest if the other + -- parser finishes later but returns a lot of unconsumed input. Our current + -- criterion of shortest is whichever parse decided to stop earlier. + {-# INLINE_LATE step #-} + step (TeePair (bufL, StepState sL, inpL1, inpL2) + (bufR, StepState sR, inpR1, inpR2)) x = do + (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x + (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x + let next = TeePair l r + return $ case (stL,stR) of + (Stp n1, _) -> + let (_, StepResult rL, _, _) = l + in Done n1 rL + (_, Stp n2) -> + let (_, StepResult rR, _, _) = r + in Done n2 rR + (Yld n1, Yld n2) -> Partial (min n1 n2) next + (Err err, _) -> SError err + (_, Err err) -> SError err + _ -> Continue 0 next + + step _ _ = undefined + + {-# INLINE_LATE extract #-} + extract st = + case st of + TeePair (_, StepState sL, _, _) _ -> extractL sL + _ -> error "unreachable" + +-- | See 'Streamly.Internal.Data.Parser.longest'. +-- +-- /Broken/ +-- +{-# INLINE longest #-} +longest :: MonadCatch m => Parser x m a -> Parser x m a -> Parser x m a +longest (Parser stepL initialL extractL) (Parser stepR initialR extractR) = + Parser step initial extract + + where + + + {-# INLINE_LATE initial #-} + initial = do + resL <- initialL + resR <- initialR + return $ case resL of + IPartial sl -> + case resR of + IPartial sr -> IPartial $ TeePair ([], StepState sl, [], []) + ([], StepState sr, [], []) + IDone br -> IPartial $ TeePair ([], StepState sl, [], []) + ([], StepResult br, [], []) + IError _ -> + IPartial $ TeePair ([], StepState sl, [], []) + ([], StepResult undefined, [], []) + IDone bl -> + case resR of + IPartial sr -> + IPartial $ TeePair ([], StepResult bl, [], []) + ([], StepState sr, [], []) + IDone _ -> IDone bl + IError _ -> IDone bl + IError _ -> + case resR of + IPartial sr -> + IPartial $ TeePair ([], StepResult undefined, [], []) + ([], StepState sr, [], []) + IDone br -> IDone br + IError err -> IError err + + {-# INLINE consume #-} + consume buf inp1 inp2 stp st y = do + let (x, inp11, inp21) = + case inp1 of + [] -> (y, [], []) + z : [] -> (z, reverse (x:inp2), []) + z : zs -> (z, zs, x:inp2) + r <- stp st x + let buf1 = x:buf + return (buf1, r, inp11, inp21) + + -- consume one input item and return the next state of the fold + {-# INLINE useStream #-} + useStream buf inp1 inp2 stp st y = do + (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y + case r of + Partial 0 s -> + let state = ([], StepState s, inp11, inp21) + in return (state, Yld 0) + Partial n _ -> return (undefined, Yld n) -- Not implemented + Done n b -> + let state = (Prelude.take n buf1, StepResult b, inp11, inp21) + in assert (n <= length buf1) (return (state, Stp n)) + -- Continue 0 s -> (buf1, Right s, inp11, inp21) + Continue n s -> + let (src0, buf2) = splitAt n buf1 + src = Prelude.reverse src0 + state = (buf2, StepState s, src ++ inp11, inp21) + in assert (n <= length buf1) (return (state, Skp)) + SError err -> return (undefined, Err err) + + {-# INLINE_LATE step #-} + step (TeePair (bufL, StepState sL, inpL1, inpL2) + (bufR, StepState sR, inpR1, inpR2)) x = do + (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x + (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x + let next = TeePair l r + return $ case (stL,stR) of + (Yld n1, Yld n2) -> Partial (min n1 n2) next + (Yld n1, Stp n2) -> Partial (min n1 n2) next + (Stp n1, Yld n2) -> Partial (min n1 n2) next + (Stp n1, Stp n2) -> + let (_, StepResult rL, _, _) = l + (_, StepResult rR, _, _) = r + in Done (max n1 n2) (if n1 >= n2 then rL else rR) + (Err err, _) -> SError err + (_, Err err) -> SError err + _ -> Continue 0 next + + -- XXX the parser that finishes last may not be the longest because it may + -- return a lot of unused input which makes it shorter. Our current + -- criterion of deciding longest is based on whoever decides to finish + -- last and not whoever consumed more input. + -- + -- To actually know who made more progress we need to keep an account of + -- how many items are unconsumed since the last yield. + -- + step (TeePair (bufL, StepState sL, inpL1, inpL2) + r@(_, StepResult _, _, _)) x = do + (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x + let next = TeePair l r + return $ case stL of + Yld n -> Partial n next + Stp n -> + let (_, StepResult rL, _, _) = l + in Done n rL + Skp -> Continue 0 next + Err err -> SError err + + step (TeePair l@(_, StepResult _, _, _) + (bufR, StepState sR, inpR1, inpR2)) x = do + (r, stR) <- useStream bufR inpR1 inpR2 stepR sR x + let next = TeePair l r + return $ case stR of + Yld n -> Partial n next + Stp n -> + let (_, StepResult rR, _, _) = r + in Done n rR + Skp -> Continue 0 next + Err err -> SError err + + step _ _ = undefined + + {-# INLINE_LATE extract #-} + extract st = + -- XXX When results are partial we may not be able to precisely compare + -- which parser has made more progress till now. One way to do that is + -- to figure out the actually consumed input up to the last yield. + -- + case st of + TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do + r <- try $ extractL sL + case r of + Left (_ :: ParseError) -> extractR sR + Right b -> return b + TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do + r <- try $ extractL sL + case r of + Left (_ :: ParseError) -> return rR + Right b -> return b + TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do + r <- try $ extractR sR + case r of + Left (_ :: ParseError) -> return rL + Right b -> return b + TeePair (_, StepResult _, _, _) (_, StepResult _, _, _) -> + error "unreachable" +-} diff --git a/src/Streamly/Internal/Data/Parser/Type.hs b/src/Streamly/Internal/Data/Parser/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser/Type.hs @@ -0,0 +1,1548 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Streamly.Internal.Data.Parser.ParserD.Type +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Streaming and backtracking parsers. +-- +-- Parsers just extend folds. Please read the 'Fold' design notes in +-- "Streamly.Internal.Data.Fold.Type" for background on the design. +-- +-- = Parser Design +-- +-- The 'Parser' type or a parsing fold is a generalization of the 'Fold' type. +-- The 'Fold' type /always/ succeeds on each input. Therefore, it does not need +-- to buffer the input. In contrast, a 'Parser' may fail and backtrack to +-- replay the input again to explore another branch of the parser. Therefore, +-- it needs to buffer the input. Therefore, a 'Parser' is a fold with some +-- additional requirements. To summarize, unlike a 'Fold', a 'Parser': +-- +-- 1. may not generate a new value of the accumulator on every input, it may +-- generate a new accumulator only after consuming multiple input elements +-- (e.g. takeEQ). +-- 2. on success may return some unconsumed input (e.g. takeWhile) +-- 3. may fail and return all input without consuming it (e.g. satisfy) +-- 4. backtrack and start inspecting the past input again (e.g. alt) +-- +-- These use cases require buffering and replaying of input. To facilitate +-- this, the step function of the 'Fold' is augmented to return the next state +-- of the fold along with a command tag using a 'Step' functor, the tag tells +-- the fold driver to manipulate the future input as the parser wishes. The +-- 'Step' functor provides the following commands to the fold driver +-- corresponding to the use cases outlined in the previous para: +-- +-- 1. 'Continue': buffer the current input and optionally go back to a previous +-- position in the stream +-- 2. 'Partial': buffer the current input and optionally go back to a previous +-- position in the stream, drop the buffer before that position. +-- 3. 'Done': parser succeeded, returns how much input was leftover +-- 4. 'SError': indicates that the parser has failed without a result +-- +-- = How a Parser Works? +-- +-- A parser is just like a fold, it keeps consuming inputs from the stream and +-- accumulating them in an accumulator. The accumulator of the parser could be +-- a singleton value or it could be a collection of values e.g. a list. +-- +-- The parser may build a new output value from multiple input items. When it +-- consumes an input item but needs more input to build a complete output item +-- it uses @Continue 0 s@, yielding the intermediate state @s@ and asking the +-- driver to provide more input. When the parser determines that a new output +-- value is complete it can use a @Done n b@ to terminate the parser with @n@ +-- items of input unused and the final value of the accumulator returned as +-- @b@. If at any time the parser determines that the parse has failed it can +-- return @SError err@. +-- +-- A parser building a collection of values (e.g. a list) can use the @Partial@ +-- constructor whenever a new item in the output collection is generated. If a +-- parser building a collection of values has yielded at least one value then +-- it is considered successful and cannot fail after that. In the current +-- implementation, this is not automatically enforced, there is a rule that the +-- parser MUST use only @Done@ for termination after the first @Partial@, it +-- cannot use @SError@. It may be possible to change the implementation so that +-- this rule is not required, but there may be some performance cost to it. +-- +-- 'Streamly.Internal.Data.Parser.takeWhile' and +-- 'Streamly.Internal.Data.Parser.some' combinators are good examples of +-- efficient implementations using all features of this representation. It is +-- possible to idiomatically build a collection of parsed items using a +-- singleton parser and @Alternative@ instance instead of using a +-- multi-yield parser. However, this implementation is amenable to stream +-- fusion and can therefore be much faster. +-- +-- = SError Handling +-- +-- When a parser's @step@ function is invoked it may terminate by either a +-- 'Done' or an 'SError' return value. In an 'Alternative' composition an error +-- return can make the composed parser backtrack and try another parser. +-- +-- If the stream stops before a parser could terminate then we use the +-- @extract@ function of the parser to retrieve the last yielded value of the +-- parser. If the parser has yielded at least one value then @extract@ MUST +-- return a value without throwing an error, otherwise it uses the 'ParseError' +-- exception to throw an error. +-- +-- We chose the exception throwing mechanism for @extract@ instead of using an +-- explicit error return via an 'Either' type for keeping the interface simple +-- as most of the time we do not need to catch the error in intermediate +-- layers. Note that we cannot use exception throwing mechanism in @step@ +-- function because of performance reasons. 'SError' constructor in that case +-- allows loop fusion and better performance. +-- +-- = Optimizing backtracking +-- +-- == Applicative Composition +-- +-- If a parser once returned 'Partial' it can never fail after that. This is +-- used to reduce the buffering. A 'Partial' results in dropping the buffer and +-- we cannot backtrack before that point. +-- +-- Parsers can be composed using an Alternative, if we are in an alternative +-- composition we may have to backtrack to try the other branch. When we +-- compose two parsers using applicative @f <$> p1 <*> p2@ we can return a +-- 'Partial' result only after both the parsers have succeeded. While running +-- @p1@ we have to ensure that the input is not dropped until we have run @p2@, +-- therefore we have to return a Continue instead of a Partial. +-- +-- However, if we know they both cannot fail then we know that the composed +-- parser can never fail. For this reason we should have "backtracking folds" +-- as a separate type so that we can compose them in an efficient manner. In p1 +-- itself we can drop the buffer as soon as a 'Partial' result arrives. In +-- fact, there is no Alternative composition for folds because they cannot +-- fail. +-- +-- == Alternative Composition +-- +-- In @p1 <|> p2@ as soon as the parser p1 returns 'Partial' we know that it +-- will not fail and we can immediately drop the buffer. +-- +-- If we are not using the parser in an alternative composition we can +-- downgrade the parser to a backtracking fold and use the "backtracking +-- fold"'s applicative for more efficient implementation. To downgrade we can +-- translate the "SError" of parser to an exception. This gives us best of both +-- worlds, the applicative as well as alternative would have optimal +-- backtracking buffer. +-- +-- The "many" for parsers would be different than "many" for folds. In case of +-- folds an error would be propagated. In case of parsers the error would be +-- ignored. +-- +-- = Implementation Approach +-- +-- Backtracking folds have an issue with tee style composition because each +-- fold can backtrack independently, we will need independent buffers. Though +-- this may be possible to implement it may not be efficient especially for +-- folds that do not backtrack at all. Three types are possible, optimized for +-- different use cases: +-- +-- * Non-backtracking folds: efficient Tee +-- * Backtracking folds: efficient applicative +-- * Parsers: alternative +-- +-- Downgrade parsers to backtracking folds for applicative used without +-- alternative. Upgrade backtracking folds to parsers when we have to use them +-- as the last alternative. +-- +-- = Future Work +-- +-- It may make sense to move "takeWhile" type of parsers, which cannot fail but +-- need some lookahead, to splitting folds. This will allow such combinators +-- to be accepted where we need an unfailing "Fold" type. +-- +-- Based on application requirements it should be possible to design even a +-- richer interface to manipulate the input stream/buffer. For example, we +-- could randomly seek into the stream in the forward or reverse directions or +-- we can even seek to the end or from the end or seek from the beginning. +-- +-- We can distribute and scan/parse a stream using both folds and parsers and +-- merge the resulting streams using different merge strategies (e.g. +-- interleaving or serial). +-- +-- == Naming +-- +-- As far as possible, try that the names of the combinators in this module are +-- consistent with: +-- +-- * +-- * +-- * +-- * +-- * + +module Streamly.Internal.Data.Parser.Type + ( + -- * Types + Initial (..) + -- (..) does not seem to export patterns yet the compiler complains it does. + , Step(Partial, Continue, Done, Error, SPartial, SContinue, SDone, SError) + , Final(..) + , mapCount + , bimapOverrideCount + , bimapMorphOverrideCount + , Parser (..) + , ParseError (..) + , ParseErrorPos (..) + , rmapM + + -- * Constructors + + , fromPure + , fromEffect + , splitWith + , split_ + + , die + , dieM + , splitSome -- parseSome? + , splitMany -- parseMany? + , splitManyPost + , alt + , concatMap + + -- * Input transformation + , lmap + , lmapM + , filter + + , noErrorUnsafeSplitWith + , noErrorUnsafeSplit_ + , noErrorUnsafeConcatMap + + , localReaderT + ) +where + +#include "inline.hs" +#include "assert.hs" + +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import Control.Applicative (Alternative(..)) +import Control.Exception (Exception(..)) +-- import Control.Monad (MonadPlus(..), (>=>)) +import Control.Monad ((>=>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Reader (ReaderT, local) +import Data.Bifunctor (Bifunctor(..)) +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..), toList) + +import qualified Control.Monad.Fail as Fail +import qualified Streamly.Internal.Data.Fold.Type as FL + +import Prelude hiding (concatMap, filter) + +#include "DocTestDataParser.hs" + +-- XXX The only differences between Initial and Step types are: +-- +-- * There are no backtracking counts in Initial +-- * Continue and Partial are the same. Ideally Partial should mean that an +-- empty result is valid and can be extracted; and Continue should mean that +-- empty would result in an error on extraction. We can possibly distinguish +-- the two cases. +-- +-- If we ignore the backtracking counts we can represent the Initial type using +-- Step itself. That will also simplify the implementation of various parsers +-- where the processing in intiial is just a sepcial case of step, see +-- takeBetween for example. + +-- XXX IPartial indicates that the parser has a default result and cannot fail. +-- Such parsers should rather be written as Parslets? We should use IContinue +-- in initial. + +-- | The type of a 'Parser''s initial action. +-- +-- /Internal/ +-- +{-# ANN type Initial Fuse #-} +data Initial s b + = IPartial !s -- ^ Wait for step function to be called with state @s@. + | IDone !b -- ^ Return a result right away without an input. + | IError !String -- ^ Return an error right away without an input. + +-- | @first@ maps on 'IPartial' and @second@ maps on 'IDone'. +-- +-- /Internal/ +-- +instance Bifunctor Initial where + {-# INLINE bimap #-} + bimap f _ (IPartial a) = IPartial (f a) + bimap _ g (IDone b) = IDone (g b) + bimap _ _ (IError err) = IError err + +-- | Maps a function over the result held by 'IDone'. +-- +-- >>> fmap = second +-- +-- /Internal/ +-- +instance Functor (Initial s) where + {-# INLINE fmap #-} + fmap = second + +-- We can simplify the Step type as follows: +-- +-- Partial Int (Either s (s, b)) -- Left continue, right partial result +-- Done Int (Either String b) +-- +-- In this case SError may also have a "leftover" return. This means that after +-- several successful partial results the last segment parsing failed and we +-- are returning the leftover of that. The driver may choose to restart from +-- the last segment where this parser failed or from the beginning. +-- +-- Folds can only return the right values. Parsers can also return lefts. + +-- | The return type of a 'Parser' step. +-- +-- /Result types/: The parser driver feeds the input stream to the parser one +-- element at a time, representing a parse 'Step'. If the step result +-- 'SPartial' indicates that a parse result is available and the parser can +-- accept more input, we can extract the result using the parser's extract +-- function and feed more input to the parser. If the result is 'SContinue', we +-- must feed more input in order to get a result. If the parser returns 'SDone' +-- then a result is available and the parser can no longer take any more input. +-- +-- /Stream position/: The @n@ in @SPartial n@, @Scontinue n@ and @SDone n@ is a +-- count by which we adjust the current stream position after this step. If the +-- count is positive we move forward in the stream, if it is 0 then we stay +-- where we are, if it is negative then we move backward in the stream. +-- Essentially, if the input stream position was @pos@ before processing the +-- current element then the new stream position after processing the element +-- would be @pos + n@. +-- +-- We can also think of this count as the number of items consumed by the +-- parser. If the current input item is consumed then n is 1, if the current +-- input item should be presented to the next parser step then n is 0. If @n@ +-- is less than 0 then the parser backtracks by n elements before the current +-- element before the next parsing step is invoked. @n@ is not allowed to be +-- greater than 1 in the regular stream parsers, but it can be more than 1 in +-- an array parser because it can consume more than one elements from the +-- array. +-- +-- /Backtracking/: If the parser result is 'SContinue', the parser driver +-- retains the input in a backtracking buffer, in case of failure the parser +-- can backtrack maximum up to the length of the backtracking buffer. Whenever +-- the result is `SPartial` the current backtracking buffer is discarded; this +-- means that we cannot backtrack beyond the currrent position in the stream. +-- The parser must ensure that the backtrack position is always within the +-- bounds of the backtracking buffer, otherwise a runtime error will occur. +-- +-- /Failure/: If the parser is not yet done, we can use the @extract@ operation +-- on the @state@ of the parser to extract a result. If the parser never +-- yielded a result in the past, @extract@ fails with a 'ParseError' exception. +-- If the parser yielded a 'Partial' result in the past then extract returns +-- the latest partial result. Therefore, if a parser yields a partial result +-- once then it cannot fail later on. +-- +-- /Pre-release/ +-- +{-# ANN type Step Fuse #-} +data Step s b = + SPartial !Int !s + -- ^ @SPartial count state@. The following statements hold on an SPartial + -- result: + -- + -- 1. @extract@ on @state@ would succeed and give a result. + -- 2. Input stream position is updated to @current position + count@. + -- 3. All buffered input before the new position is dropped. The parser can + -- never backtrack before this position. + + | SContinue !Int !s + -- ^ @SContinue count state@. The following statements hold on an SContinue + -- result: + -- + -- 1. If 'SPartial' result was returned in the past, @extract@ on @state@ + -- would give that result otherwise it will return 'SError' or 'SContinue'. + -- 2. Input stream position is updated to @current position + count@. + -- 3. the previous input is retained in a backtrack buffer. + + | SDone !Int !b + -- ^ Done with leftover input count and result. + -- + -- @SDone count result@ means the parser has finished, it will not accept + -- any more input, the final stream position must be set to @current + -- position + count@ and the result of the parser is in @result@. + + | SError !String + -- ^ Parser failed without generating any output. + -- + -- The parsing operation may backtrack to the beginning and try another + -- alternative. + deriving (Show) + +{-# ANN type Final Fuse #-} +data Final s b + = FDone !Int !b -- ^ Return a result right away without an input. + | FContinue !Int !s + | FError !String -- ^ Return an error right away without an input. + +-------------------------------------------------------------------------------- +-- Custom Patterns +-------------------------------------------------------------------------------- + +negateDirection :: Step s b -> Step s b +negateDirection (SPartial i s) = SPartial (1 - i) s +negateDirection (SContinue i s) = SContinue (1 - i) s +negateDirection (SDone i b) = SDone (1 - i) b +negateDirection (SError s) = SError s + +{-# DEPRECATED Error "Use @SError@ instead of @Error@" #-} +pattern Error :: String -> Step s b +pattern Error s = SError s + +{-# DEPRECATED Partial "Use @SPartial (1 - n)@ instead of @Partial n@" #-} +pattern Partial :: Int -> s -> Step s b +pattern Partial i s <- (negateDirection -> SPartial i s) + where Partial i s = SPartial (1 - i) s + +{-# DEPRECATED Continue "Replace @Continue n@ with @SContinue (1 - n)@ in parser step and with @FContinue (-n)@ in parser extract" #-} +pattern Continue :: Int -> s -> Step s b +pattern Continue i s <- (negateDirection -> SContinue i s) + where Continue i s = SContinue (1 - i) s + +{-# DEPRECATED Done "Replace @Done n@ with @SDone (1 - n)@ in parser step and with @FDone (-n)@ in parser extract" #-} +pattern Done :: Int -> b -> Step s b +pattern Done i b <- (negateDirection -> SDone i b) + where Done i b = SDone (1 - i) b + +-------------------------------------------------------------------------------- +-- Code +-------------------------------------------------------------------------------- + +-- | Map first function over the state and second over the result. +instance Bifunctor Step where + {-# INLINE bimap #-} + bimap f g step = + case step of + SPartial n s -> SPartial n (f s) + SContinue n s -> SContinue n (f s) + SDone n b -> SDone n (g b) + SError err -> SError err + +instance Bifunctor Final where + {-# INLINE bimap #-} + bimap f g step = + case step of + FContinue n s -> FContinue n (f s) + FDone n b -> FDone n (g b) + FError err -> FError err + +-- | Bimap discarding the count, and using the supplied count instead. +bimapOverrideCount :: Int -> (s -> s1) -> (b -> b1) -> Step s b -> Step s1 b1 +bimapOverrideCount n f g step = + case step of + SPartial _ s -> SPartial n (f s) + SContinue _ s -> SContinue n (f s) + SDone _ b -> SDone n (g b) + SError err -> SError err + +bimapMorphOverrideCount :: Int -> (s -> s1) -> (b -> b1) -> Final s b -> Step s1 b1 +bimapMorphOverrideCount n f g step = + case step of + FDone _ b -> SDone n (g b) + FContinue _ s -> SContinue n (f s) + FError err -> SError err + +bimapFinalOverrideCount :: Int -> (s -> s1) -> (b -> b1) -> Final s b -> Final s1 b1 +bimapFinalOverrideCount n f g step = + case step of + FContinue _ s -> FContinue n (f s) + FDone _ b -> FDone n (g b) + FError err -> FError err + +-- | fmap = second +instance Functor (Step s) where + {-# INLINE fmap #-} + fmap = second + +instance Functor (Final s) where + {-# INLINE fmap #-} + fmap = second + +-- | Map a function over the count. +-- +{-# INLINE mapCount #-} +mapCount :: (Int -> Int) -> Step s b -> Step s b +mapCount f res = + case res of + SPartial n s -> SPartial (f n) s + SDone n b -> SDone (f n) b + SContinue n s -> SContinue (f n) s + SError err -> SError err + +-- | Map a monadic function over the result @b@ in @Step s b@. +-- +-- /Internal/ +{-# INLINE mapMStep #-} +mapMStep :: Applicative m => (a -> m b) -> Step s a -> m (Step s b) +mapMStep f res = + case res of + SPartial n s -> pure $ SPartial n s + SDone n b -> SDone n <$> f b + SContinue n s -> pure $ SContinue n s + SError err -> pure $ SError err + +{-# INLINE mapMFinal #-} +mapMFinal :: Applicative m => (a -> m b) -> Final s a -> m (Final s b) +mapMFinal f res = + case res of + FDone n b -> FDone n <$> f b + FContinue n s -> pure $ FContinue n s + FError err -> pure $ FError err + +-- | A parser is a fold that can fail and is represented as @Parser step +-- initial extract@. Before we drive a parser we call the @initial@ action to +-- retrieve the initial state of the fold. The parser driver invokes @step@ +-- with the state returned by the previous step and the next input element. It +-- results into a new state and a command to the driver represented by 'Step' +-- type. The driver keeps invoking the step function until it stops or fails. +-- At any point of time the driver can call @extract@ to inspect the result of +-- the fold. If the parser hits the end of input 'extract' is called. +-- It may result in an error or an output value. +-- +-- /Pre-release/ +-- +data Parser a m b = + forall s. Parser + (s -> a -> m (Step s b)) + (m (Initial s b)) + (s -> m (Final s b)) + +-- | This exception is used when a parser ultimately fails, the user of the +-- parser is intimated via this exception. +-- +newtype ParseError = ParseError String + deriving (Eq, Show) + +instance Exception ParseError where + displayException (ParseError err) = err + +-- | Like 'ParseError' but reports the stream position where the error ocurred. +-- The @Int@ is the position in the stream where the error ocurred. This +-- exception is used by position reporting parser drivers. +data ParseErrorPos = ParseErrorPos Int String + deriving (Eq, Show) + +instance Exception ParseErrorPos where + displayException (ParseErrorPos pos err) = + concat ["At ", show pos, ":", err] + +-- | Map a function on the result i.e. on @b@ in @Parser a m b@. +instance Functor m => Functor (Parser a m) where + {-# INLINE fmap #-} + fmap f (Parser step1 initial1 extract) = + Parser step initial (fmap3 f extract) + + where + + initial = fmap2 f initial1 + step s b = fmap2 f (step1 s b) + fmap2 g = fmap (fmap g) + fmap3 g = fmap (fmap (fmap g)) + +------------------------------------------------------------------------------ +-- Mapping on the output +------------------------------------------------------------------------------ + +-- | @rmapM f parser@ maps the monadic function @f@ on the output of the parser. +-- +-- >>> rmap = fmap +{-# INLINE rmapM #-} +rmapM :: Monad m => (b -> m c) -> Parser a m b -> Parser a m c +rmapM f (Parser step initial extract) = + Parser step1 initial1 (extract >=> mapMFinal f) + + where + + initial1 = do + res <- initial + -- this is mapM f over result + case res of + IPartial x -> return $ IPartial x + IDone a -> IDone <$> f a + IError err -> return $ IError err + step1 s a = step s a >>= mapMStep f + +-- | A parser that always yields a pure value without consuming any input. +-- +{-# INLINE_NORMAL fromPure #-} +fromPure :: Monad m => b -> Parser a m b +fromPure b = Parser undefined (pure $ IDone b) undefined + +-- | A parser that always yields the result of an effectful action without +-- consuming any input. +-- +{-# INLINE fromEffect #-} +fromEffect :: Monad m => m b -> Parser a m b +fromEffect b = Parser undefined (IDone <$> b) undefined + +------------------------------------------------------------------------------- +-- Sequential applicative +------------------------------------------------------------------------------- + +{-# ANN type SeqParseState Fuse #-} +data SeqParseState sl f sr = SeqParseL !sl | SeqParseR !f !sr + +-- Note: this implementation of splitWith is fast because of stream fusion but +-- has quadratic time complexity, because each composition adds a new branch +-- that each subsequent parse's input element has to go through, therefore, it +-- cannot scale to a large number of compositions. After around 100 +-- compositions the performance starts dipping rapidly beyond a CPS style +-- unfused implementation. +-- +-- Note: This is a parsing dual of appending streams using +-- 'Streamly.Data.Stream.append', it splits the streams using two parsers and +-- zips the results. + +-- | Sequential parser application. Apply two parsers sequentially to an input +-- stream. The first parser runs and processes the input, the remaining input +-- is then passed to the second parser. If both parsers succeed, their outputs +-- are combined using the supplied function. If either parser fails, the +-- operation fails. +-- +-- This combinator delivers high performance by stream fusion but it comes with +-- some limitations. For those cases use the 'Applicative' instance of +-- 'Streamly.Data.ParserK.ParserK'. +-- +-- CAVEAT 1: NO RECURSION. This function is strict in both arguments. As a +-- result, if a parser is defined recursively using this, it may cause an +-- infintie loop. The following example checks the strictness: +-- +-- >>> p = Parser.splitWith const (Parser.satisfy (> 0)) undefined +-- >>> Stream.parse p $ Stream.fromList [1] +-- *** Exception: Prelude.undefined +-- ... +-- +-- CAVEAT 2: QUADRATIC TIME COMPLEXITY. Static composition is fast due to +-- stream fusion, but it works well only for limited (e.g. up to 8) +-- compositions, use "Streamly.Data.ParserK" for larger compositions. +-- +-- Below are some common idioms that can be expressed using 'splitWith': +-- +-- >>> span p f1 f2 = Parser.splitWith (,) (Parser.takeWhile p f1) (Parser.fromFold f2) +-- >>> spanBy eq f1 f2 = Parser.splitWith (,) (Parser.groupBy eq f1) (Parser.fromFold f2) +-- +-- /Pre-release/ +-- +{-# INLINE splitWith #-} +splitWith :: Monad m + => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c +splitWith func (Parser stepL initialL extractL) + (Parser stepR initialR extractR) = + Parser step initial extract + + where + + initial = do + -- XXX We can use bimap here if we make this a Step type + resL <- initialL + case resL of + IPartial sl -> return $ IPartial $ SeqParseL sl + IDone bl -> do + resR <- initialR + -- XXX We can use bimap here if we make this a Step type + return $ case resR of + IPartial sr -> IPartial $ SeqParseR (func bl) sr + IDone br -> IDone (func bl br) + IError err -> IError err + IError err -> return $ IError err + + -- Note: For the composed parse to terminate, the left parser has to be + -- a terminating parser returning a Done at some point. + step (SeqParseL st) a = do + -- Important: Please do not use Applicative here. See + -- https://github.com/composewell/streamly/issues/1033 and the problem + -- defined in split_ for more info. + -- XXX Use bimap + resL <- stepL st a + case resL of + -- Note: We need to buffer the input for a possible Alternative + -- e.g. in ((,) <$> p1 <*> p2) <|> p3, if p2 fails we have to + -- backtrack and start running p3. So we need to keep the input + -- buffered until we know that the applicative cannot fail. + SPartial n s -> return $ SContinue n (SeqParseL s) + SContinue n s -> return $ SContinue n (SeqParseL s) + SDone n b -> do + -- XXX Use bimap if we make this a Step type + -- fmap (bimap (SeqParseR (func b)) (func b)) initialR + initR <- initialR + return $ case initR of + IPartial sr -> SContinue n $ SeqParseR (func b) sr + IDone br -> SDone n (func b br) + IError err -> SError err + SError err -> return $ SError err + + step (SeqParseR f st) a = fmap (bimap (SeqParseR f) f) (stepR st a) + + extract (SeqParseR f sR) = fmap (bimap (SeqParseR f) f) (extractR sR) + extract (SeqParseL sL) = do + -- XXX Use bimap here + rL <- extractL sL + case rL of + FDone n bL -> do + -- XXX Use bimap here if we use Step type in Initial + iR <- initialR + case iR of + IPartial sR -> do + fmap + (bimap (SeqParseR (func bL)) (func bL)) + (extractR sR) + IDone bR -> return $ FDone n $ func bL bR + IError err -> return $ FError err + FError err -> return $ FError err + FContinue n s -> return $ FContinue n (SeqParseL s) + +------------------------------------------------------------------------------- +-- Sequential applicative for backtracking folds +------------------------------------------------------------------------------- + +-- XXX Create a newtype for nonfailing parsers and downgrade the parser to that +-- type before this operation and then upgrade. +-- +-- We can do an inspection testing to reject unwanted constructors at compile +-- time. +-- +-- We can use the compiler to automatically annotate accumulators, terminating +-- folds, non-failing parsers and failing parsers. + +-- | Better performance 'splitWith' for non-failing parsers. +-- +-- Does not work correctly for parsers that can fail. +-- +-- ALL THE CAVEATS IN 'splitWith' APPLY HERE AS WELL. +-- +{-# INLINE noErrorUnsafeSplitWith #-} +noErrorUnsafeSplitWith :: Monad m + => (a -> b -> c) -> Parser x m a -> Parser x m b -> Parser x m c +noErrorUnsafeSplitWith func (Parser stepL initialL extractL) + (Parser stepR initialR extractR) = + Parser step initial extract + + where + + errMsg e = error $ "noErrorUnsafeSplitWith: unreachable: " ++ e + + initial = do + resL <- initialL + case resL of + IPartial sl -> return $ IPartial $ SeqParseL sl + IDone bl -> do + resR <- initialR + return $ bimap (SeqParseR (func bl)) (func bl) resR + IError err -> errMsg err + + -- Note: For the composed parse to terminate, the left parser has to be + -- a terminating parser returning a SDone at some point. + step (SeqParseL st) a = do + r <- stepL st a + case r of + -- Assume that the parser can never fail, therefore, we do not + -- need to keep the input for backtracking. + SPartial n s -> return $ SPartial n (SeqParseL s) + SContinue n s -> return $ SContinue n (SeqParseL s) + SDone n b -> do + res <- initialR + return + $ case res of + IPartial sr -> SPartial n $ SeqParseR (func b) sr + IDone br -> SDone n (func b br) + IError err -> errMsg err + SError err -> errMsg err + + step (SeqParseR f st) a = fmap (bimap (SeqParseR f) f) (stepR st a) + + extract (SeqParseR f sR) = fmap (bimap (SeqParseR f) f) (extractR sR) + + extract (SeqParseL sL) = do + rL <- extractL sL + case rL of + FDone n bL -> do + iR <- initialR + case iR of + IPartial sR -> do + rR <- extractR sR + return + $ bimapFinalOverrideCount + n (SeqParseR (func bL)) (func bL) rR + IDone bR -> return $ FDone n $ func bL bR + IError err -> errMsg err + FError err -> errMsg err + FContinue n s -> return $ FContinue n (SeqParseL s) + +{-# ANN type SeqAState Fuse #-} +data SeqAState sl sr = SeqAL !sl | SeqAR !sr + +-- This turns out to be slightly faster than splitWith + +-- | Sequential parser application ignoring the output of the first parser. +-- Apply two parsers sequentially to an input stream. The input is provided to +-- the first parser, when it is done the remaining input is provided to the +-- second parser. The output of the parser is the output of the second parser. +-- The operation fails if any of the parsers fail. +-- +-- ALL THE CAVEATS IN 'splitWith' APPLY HERE AS WELL. +-- +-- This implementation is strict in the second argument, therefore, the +-- following will fail: +-- +-- >>> Stream.parse (Parser.split_ (Parser.satisfy (> 0)) undefined) $ Stream.fromList [1] +-- *** Exception: Prelude.undefined +-- ... +-- +-- /Pre-release/ +-- +{-# INLINE split_ #-} +split_ :: Monad m => Parser x m a -> Parser x m b -> Parser x m b +split_ (Parser stepL initialL extractL) (Parser stepR initialR extractR) = + Parser step initial extract + + where + + initial = do + resL <- initialL + case resL of + IPartial sl -> return $ IPartial $ SeqAL sl + IDone _ -> do + resR <- initialR + return $ first SeqAR resR + IError err -> return $ IError err + + -- Note: For the composed parse to terminate, the left parser has to be + -- a terminating parser returning a SDone at some point. + step (SeqAL st) a = do + -- Important: Do not use Applicative here. Applicative somehow caused + -- the right action to run many times, not sure why though. + resL <- stepL st a + case resL of + -- Note: this leads to buffering even if we are not in an + -- Alternative composition. + SPartial n s -> return $ SContinue n (SeqAL s) + SContinue n s -> return $ SContinue n (SeqAL s) + SDone n _ -> do + initR <- initialR + return $ case initR of + IPartial s -> SContinue n (SeqAR s) + IDone b -> SDone n b + IError err -> SError err + SError err -> return $ SError err + + step (SeqAR st) a = first SeqAR <$> stepR st a + + extract (SeqAR sR) = fmap (first SeqAR) (extractR sR) + extract (SeqAL sL) = do + rL <- extractL sL + case rL of + FDone n _ -> do + iR <- initialR + -- XXX For initial we can have a bimap with leftover. + case iR of + IPartial sR -> + fmap (bimapFinalOverrideCount n SeqAR id) (extractR sR) + IDone bR -> return $ FDone n bR + IError err -> return $ FError err + FError err -> return $ FError err + FContinue n s -> return $ FContinue n (SeqAL s) + +-- | Better performance 'split_' for non-failing parsers. +-- +-- Does not work correctly for parsers that can fail. +-- +-- ALL THE CAVEATS IN 'splitWith' APPLY HERE AS WELL. +-- +{-# INLINE noErrorUnsafeSplit_ #-} +noErrorUnsafeSplit_ :: Monad m => Parser x m a -> Parser x m b -> Parser x m b +noErrorUnsafeSplit_ + (Parser stepL initialL extractL) (Parser stepR initialR extractR) = + Parser step initial extract + + where + + errMsg e = error $ "noErrorUnsafeSplit_: unreachable: " ++ e + + initial = do + resL <- initialL + case resL of + IPartial sl -> return $ IPartial $ SeqAL sl + IDone _ -> do + resR <- initialR + return $ first SeqAR resR + IError err -> errMsg err + + -- Note: For the composed parse to terminate, the left parser has to be + -- a terminating parser returning a SDone at some point. + step (SeqAL st) a = do + -- Important: Please do not use Applicative here. Applicative somehow + -- caused the next action to run many times in the "tar" parsing code, + -- not sure why though. + resL <- stepL st a + case resL of + SPartial n s -> return $ SPartial n (SeqAL s) + SContinue n s -> return $ SContinue n (SeqAL s) + SDone n _ -> do + initR <- initialR + return $ case initR of + IPartial s -> SPartial n (SeqAR s) + IDone b -> SDone n b + IError err -> errMsg err + SError err -> errMsg err + + step (SeqAR st) a = first SeqAR <$> stepR st a + + extract (SeqAR sR) = fmap (first SeqAR) (extractR sR) + extract (SeqAL sL) = do + rL <- extractL sL + case rL of + FDone n _ -> do + iR <- initialR + case iR of + IPartial sR -> do + fmap (bimapFinalOverrideCount n SeqAR id) (extractR sR) + IDone bR -> return $ FDone n bR + IError err -> errMsg err + FError err -> errMsg err + FContinue n s -> return $ FContinue n (SeqAL s) + +-- | READ THE CAVEATS in 'splitWith' before using this instance. +-- +-- >>> pure = Parser.fromPure +-- >>> (<*>) = Parser.splitWith id +-- >>> (*>) = Parser.split_ +instance Monad m => Applicative (Parser a m) where + {-# INLINE pure #-} + pure = fromPure + + {-# INLINE (<*>) #-} + (<*>) = splitWith id + + {-# INLINE (*>) #-} + (*>) = split_ + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + +------------------------------------------------------------------------------- +-- Sequential Alternative +------------------------------------------------------------------------------- + +{-# ANN type AltParseState Fuse #-} +data AltParseState sl sr = AltParseL !Int !sl | AltParseR !sr + +-- Note: this implementation of alt is fast because of stream fusion but has +-- quadratic time complexity, because each composition adds a new branch that +-- each subsequent alternative's input element has to go through, therefore, it +-- cannot scale to a large number of compositions + +-- | Sequential alternative. The input is first passed to the first parser, +-- if it succeeds, the result is returned. However, if the first parser fails, +-- the parser driver backtracks and tries the same input on the second +-- (alternative) parser, returning the result if it succeeds. +-- +-- This combinator delivers high performance by stream fusion but it comes with +-- some limitations. For those cases use the 'Alternative' instance of +-- 'Streamly.Data.ParserK.ParserK'. +-- +-- CAVEAT 1: NO RECURSION. This function is strict in both arguments. As a +-- result, if a parser is defined recursively using this, it may cause an +-- infintie loop. The following example checks the strictness: +-- +-- >> p = Parser.satisfy (> 0) `Parser.alt` undefined +-- >> Stream.parse p $ Stream.fromList [1..10] +-- *** Exception: Prelude.undefined +-- +-- CAVEAT 2: QUADRATIC TIME COMPLEXITY. Static composition is fast due to +-- stream fusion, but it works well only for limited (e.g. up to 8) +-- compositions, use "Streamly.Data.ParserK" for larger compositions. +-- +-- /Time Complexity:/ O(n^2) where n is the number of compositions. +-- +-- /Pre-release/ +-- +{-# INLINE alt #-} +alt :: Monad m => Parser x m a -> Parser x m a -> Parser x m a +alt (Parser stepL initialL extractL) (Parser stepR initialR extractR) = + Parser step initial extract + + where + + initial = do + resL <- initialL + case resL of + IPartial sl -> return $ IPartial $ AltParseL 0 sl + IDone bl -> return $ IDone bl + IError _ -> do + resR <- initialR + return $ case resR of + IPartial sr -> IPartial $ AltParseR sr + IDone br -> IDone br + IError err -> IError err + + -- Once a parser yields at least one value it cannot fail. This + -- restriction helps us make backtracking more efficient, as we do not need + -- to keep the consumed items buffered after a yield. Note that we do not + -- enforce this and if a misbehaving parser does not honor this then we can + -- get unexpected results. XXX Can we detect and flag this? + step (AltParseL cnt st) a = do + r <- stepL st a + case r of + SPartial n s -> return $ SPartial n (AltParseL 0 s) + SContinue n s -> do + assertM(cnt + n >= 0) + return $ SContinue n (AltParseL (cnt + n) s) + SDone n b -> return $ SDone n b + SError _ -> do + res <- initialR + return + $ case res of + IPartial rR -> SContinue (negate cnt) (AltParseR rR) + IDone b -> SDone (negate cnt) b + IError err -> SError err + + step (AltParseR st) a = do + r <- stepR st a + return $ case r of + SPartial n s -> SPartial n (AltParseR s) + SContinue n s -> SContinue n (AltParseR s) + SDone n b -> SDone n b + SError err -> SError err + + extract (AltParseR sR) = fmap (first AltParseR) (extractR sR) + + extract (AltParseL cnt sL) = do + rL <- extractL sL + case rL of + FDone n b -> return $ FDone n b + FError _ -> do + res <- initialR + return + $ case res of + IPartial rR -> FContinue (- cnt) (AltParseR rR) + IDone b -> FDone (- cnt) b + IError err -> FError err + FContinue n s -> do + assertM(n == (- cnt)) + return $ FContinue n (AltParseL 0 s) + +{-# ANN type Fused3 Fuse #-} +data Fused3 a b c = Fused3 !a !b !c + +-- | See documentation of 'Streamly.Internal.Data.Parser.many'. +-- +-- /Pre-release/ +-- +{-# INLINE splitMany #-} +splitMany :: Monad m => Parser a m b -> Fold m b c -> Parser a m c +splitMany (Parser step1 initial1 extract1) (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + -- Caution! There is mutual recursion here, inlining the right functions is + -- important. + + handleCollect partial done fres = + case fres of + FL.Partial fs -> do + pres <- initial1 + case pres of + IPartial ps -> return $ partial $ Fused3 ps 0 fs + IDone pb -> + runCollectorWith (handleCollect partial done) fs pb + IError _ -> done <$> ffinal fs + FL.Done fb -> return $ done fb + + runCollectorWith cont fs pb = fstep fs pb >>= cont + + -- See notes in Fold.many for the reason why the parser must be initialized + -- right away instead of on first input. + initial = finitial >>= handleCollect IPartial IDone + + {-# INLINE step #-} + step (Fused3 st cnt fs) a = do + r <- step1 st a + case r of + SPartial n s -> do + assertM(cnt + n >= 0) + return $ SContinue n (Fused3 s (cnt + n) fs) + SContinue n s -> do + assertM(cnt + n >= 0) + return $ SContinue n (Fused3 s (cnt + n) fs) + SDone n b -> do + assertM(cnt + n >= 0) + fstep fs b >>= handleCollect (SPartial n) (SDone n) + SError _ -> do + xs <- ffinal fs + -- XXX review, need a test for this + return $ SDone (- cnt) xs + + extract (Fused3 _ 0 fs) = fmap (FDone 0) (ffinal fs) + extract (Fused3 s cnt fs) = do + r <- extract1 s + case r of + FError _ -> fmap (FDone (- cnt)) (ffinal fs) + FDone n b -> do + assertM((- n) <= cnt) + fs1 <- fstep fs b + case fs1 of + FL.Partial s1 -> fmap (FDone n) (ffinal s1) + FL.Done b1 -> return (FDone n b1) + FContinue n s1 -> do + assertM((- n) == cnt) + return (FContinue n (Fused3 s1 0 fs)) + +-- | Like splitMany, but inner fold emits an output at the end even if no input +-- is received. +-- +-- /Internal/ +-- +{-# INLINE splitManyPost #-} +splitManyPost :: Monad m => Parser a m b -> Fold m b c -> Parser a m c +splitManyPost (Parser step1 initial1 extract1) (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + -- Caution! There is mutual recursion here, inlining the right functions is + -- important. + + handleCollect partial done fres = + case fres of + FL.Partial fs -> do + pres <- initial1 + case pres of + IPartial ps -> return $ partial $ Fused3 ps 0 fs + IDone pb -> + runCollectorWith (handleCollect partial done) fs pb + IError _ -> done <$> ffinal fs + FL.Done fb -> return $ done fb + + runCollectorWith cont fs pb = fstep fs pb >>= cont + + initial = finitial >>= handleCollect IPartial IDone + + {-# INLINE step #-} + step (Fused3 st cnt fs) a = do + r <- step1 st a + case r of + SPartial n s -> do + assertM(cnt + n >= 0) + return $ SContinue n (Fused3 s (cnt + n) fs) + SContinue n s -> do + assertM(cnt + n >= 0) + return $ SContinue n (Fused3 s (cnt + n) fs) + SDone n b -> do + assertM(cnt + n >= 0) + fstep fs b >>= handleCollect (SPartial n) (SDone n) + SError _ -> do + xs <- ffinal fs + return $ SDone (- cnt) xs + + extract (Fused3 s cnt fs) = do + r <- extract1 s + case r of + FError _ -> fmap (FDone (- cnt)) (ffinal fs) + FDone n b -> do + assertM((- n) <= cnt) + fs1 <- fstep fs b + case fs1 of + FL.Partial s1 -> fmap (FDone n) (ffinal s1) + FL.Done b1 -> return (FDone n b1) + FContinue n s1 -> do + assertM((- n) == cnt) + return (FContinue n (Fused3 s1 0 fs)) + +-- | See documentation of 'Streamly.Internal.Data.Parser.some'. +-- +-- /Pre-release/ +-- +{-# INLINE splitSome #-} +splitSome :: Monad m => Parser a m b -> Fold m b c -> Parser a m c +splitSome (Parser step1 initial1 extract1) (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + -- Caution! There is mutual recursion here, inlining the right functions is + -- important. + + handleCollect partial done fres = + case fres of + FL.Partial fs -> do + pres <- initial1 + case pres of + IPartial ps -> return $ partial $ Fused3 ps 0 $ Right fs + IDone pb -> + runCollectorWith (handleCollect partial done) fs pb + IError _ -> done <$> ffinal fs + FL.Done fb -> return $ done fb + + runCollectorWith cont fs pb = fstep fs pb >>= cont + + initial = do + fres <- finitial + case fres of + FL.Partial fs -> do + pres <- initial1 + case pres of + IPartial ps -> return $ IPartial $ Fused3 ps 0 $ Left fs + IDone pb -> + runCollectorWith (handleCollect IPartial IDone) fs pb + IError err -> return $ IError err + FL.Done _ -> + return + $ IError + $ "splitSome: The collecting fold terminated without" + ++ " consuming any elements." + + {-# INLINE step #-} + step (Fused3 st cnt (Left fs)) a = do + r <- step1 st a + -- In the Left state, count is used only for the assert + case r of + SPartial n s -> do + assertM(cnt + n >= 0) + return $ SContinue n (Fused3 s (cnt + n) (Left fs)) + SContinue n s -> do + assertM(cnt + n >= 0) + return $ SContinue n (Fused3 s (cnt + n) (Left fs)) + SDone n b -> do + assertM(cnt + n >= 0) + fstep fs b >>= handleCollect (SPartial n) (SDone n) + SError err -> return $ SError err + step (Fused3 st cnt (Right fs)) a = do + r <- step1 st a + case r of + SPartial n s -> do + assertM(cnt + n >= 0) + return $ SPartial n (Fused3 s (cnt + n) (Right fs)) + SContinue n s -> do + assertM(cnt + n >= 0) + return $ SContinue n (Fused3 s (cnt + n) (Right fs)) + SDone n b -> do + assertM(cnt + n >= 0) + fstep fs b >>= handleCollect (SPartial n) (SDone n) + SError _ -> SDone (- cnt) <$> ffinal fs + + extract (Fused3 s cnt (Left fs)) = do + r <- extract1 s + case r of + FError err -> return (FError err) + FDone n b -> do + assertM((- n) <= cnt) + fs1 <- fstep fs b + case fs1 of + FL.Partial s1 -> fmap (FDone n) (ffinal s1) + FL.Done b1 -> return (FDone n b1) + FContinue n s1 -> do + assertM((- n) == cnt) + return (FContinue n (Fused3 s1 0 (Left fs))) + extract (Fused3 s cnt (Right fs)) = do + r <- extract1 s + case r of + FError _ -> fmap (FDone (- cnt)) (ffinal fs) + FDone n b -> do + assertM((- n) <= cnt) + fs1 <- fstep fs b + case fs1 of + FL.Partial s1 -> fmap (FDone n) (ffinal s1) + FL.Done b1 -> return (FDone n b1) + FContinue n s1 -> do + assertM((- n) == cnt) + return (FContinue n (Fused3 s1 0 (Right fs))) + +-- | A parser that always fails with an error message without consuming +-- any input. +-- +{-# INLINE_NORMAL die #-} +die :: Monad m => String -> Parser a m b +die err = Parser undefined (pure (IError err)) undefined + +-- | A parser that always fails with an effectful error message and without +-- consuming any input. +-- +-- /Pre-release/ +-- +{-# INLINE dieM #-} +dieM :: Monad m => m String -> Parser a m b +dieM err = Parser undefined (IError <$> err) undefined + +-- Note: The default implementations of "some" and "many" loop infinitely +-- because of the strict pattern match on both the arguments in applicative and +-- alternative. With the direct style parser type we cannot use the mutually +-- recursive definitions of "some" and "many". +-- +-- Note: With the direct style parser type, the list in "some" and "many" is +-- accumulated strictly, it cannot be consumed lazily. + +-- | READ THE CAVEATS in 'alt' before using this instance. +-- +-- >>> empty = Parser.die "empty" +-- >>> (<|>) = Parser.alt +-- >>> many = flip Parser.many Fold.toList +-- >>> some = flip Parser.some Fold.toList +instance Monad m => Alternative (Parser a m) where + {-# INLINE empty #-} + empty = die "empty" + + {-# INLINE (<|>) #-} + (<|>) = alt + + {-# INLINE many #-} + many = flip splitMany toList + + {-# INLINE some #-} + some = flip splitSome toList + +{-# ANN type ConcatParseState Fuse #-} +data ConcatParseState sl m a b = + ConcatParseL !sl + | forall s. ConcatParseR (s -> a -> m (Step s b)) s (s -> m (Final s b)) + +-- XXX Does it fuse completely? Check and update, it cannot fuse the +-- dynamically generated parser. + +-- | Map a 'Parser' returning function on the result of a 'Parser'. +-- +-- ALL THE CAVEATS IN 'splitWith' APPLY HERE AS WELL. +-- +-- /Pre-release/ +-- +{-# INLINE concatMap #-} +concatMap :: Monad m => + (b -> Parser a m c) -> Parser a m b -> Parser a m c +concatMap func (Parser stepL initialL extractL) = Parser step initial extract + + where + + {-# INLINE initializeR #-} + initializeR (Parser stepR initialR extractR) = do + resR <- initialR + return $ case resR of + IPartial sr -> IPartial $ ConcatParseR stepR sr extractR + IDone br -> IDone br + IError err -> IError err + + initial = do + res <- initialL + case res of + IPartial s -> return $ IPartial $ ConcatParseL s + IDone b -> initializeR (func b) + IError err -> return $ IError err + + {-# INLINE initializeRL #-} + initializeRL n (Parser stepR initialR extractR) = do + resR <- initialR + return $ case resR of + IPartial sr -> SContinue n $ ConcatParseR stepR sr extractR + IDone br -> SDone n br + IError err -> SError err + + step (ConcatParseL st) a = do + r <- stepL st a + case r of + SPartial n s -> return $ SContinue n (ConcatParseL s) + SContinue n s -> return $ SContinue n (ConcatParseL s) + SDone n b -> initializeRL n (func b) + SError err -> return $ SError err + + step (ConcatParseR stepR st extractR) a = do + r <- stepR st a + return $ case r of + SPartial n s -> SPartial n $ ConcatParseR stepR s extractR + SContinue n s -> SContinue n $ ConcatParseR stepR s extractR + SDone n b -> SDone n b + SError err -> SError err + + {-# INLINE extractP #-} + extractP n (Parser stepR initialR extractR) = do + res <- initialR + case res of + IPartial s -> + fmap + (first (\s1 -> ConcatParseR stepR s1 extractR)) + (extractR s) + IDone b -> return (FDone n b) + IError err -> return $ FError err + + extract (ConcatParseR stepR s extractR) = + fmap (first (\s1 -> ConcatParseR stepR s1 extractR)) (extractR s) + extract (ConcatParseL sL) = do + rL <- extractL sL + case rL of + FError err -> return $ FError err + FDone n b -> extractP n $ func b + FContinue n s -> return $ FContinue n (ConcatParseL s) + +-- | Better performance 'concatMap' for non-failing parsers. +-- +-- Does not work correctly for parsers that can fail. +-- +-- ALL THE CAVEATS IN 'splitWith' APPLY HERE AS WELL. +-- +{-# INLINE noErrorUnsafeConcatMap #-} +noErrorUnsafeConcatMap :: Monad m => + (b -> Parser a m c) -> Parser a m b -> Parser a m c +noErrorUnsafeConcatMap func (Parser stepL initialL extractL) = + Parser step initial extract + + where + + {-# INLINE initializeR #-} + initializeR (Parser stepR initialR extractR) = do + resR <- initialR + return $ case resR of + IPartial sr -> IPartial $ ConcatParseR stepR sr extractR + IDone br -> IDone br + IError err -> IError err + + initial = do + res <- initialL + case res of + IPartial s -> return $ IPartial $ ConcatParseL s + IDone b -> initializeR (func b) + IError err -> return $ IError err + + {-# INLINE initializeRL #-} + initializeRL n (Parser stepR initialR extractR) = do + resR <- initialR + return $ case resR of + IPartial sr -> SPartial n $ ConcatParseR stepR sr extractR + IDone br -> SDone n br + IError err -> SError err + + step (ConcatParseL st) a = do + r <- stepL st a + case r of + SPartial n s -> return $ SPartial n (ConcatParseL s) + SContinue n s -> return $ SContinue n (ConcatParseL s) + SDone n b -> initializeRL n (func b) + SError err -> return $ SError err + + step (ConcatParseR stepR st extractR) a = do + r <- stepR st a + return $ case r of + SPartial n s -> SPartial n $ ConcatParseR stepR s extractR + SContinue n s -> SContinue n $ ConcatParseR stepR s extractR + SDone n b -> SDone n b + SError err -> SError err + + {-# INLINE extractP #-} + extractP n (Parser stepR initialR extractR) = do + res <- initialR + case res of + IPartial s -> + fmap + (first (\s1 -> ConcatParseR stepR s1 extractR)) + (extractR s) + IDone b -> return (FDone n b) + IError err -> return $ FError err + + extract (ConcatParseR stepR s extractR) = + fmap (first (\s1 -> ConcatParseR stepR s1 extractR)) (extractR s) + extract (ConcatParseL sL) = do + rL <- extractL sL + case rL of + FError err -> return $ FError err + FDone n b -> extractP n $ func b + FContinue n s -> return $ FContinue n (ConcatParseL s) + +-- Note: The monad instance has quadratic performance complexity. It works fine +-- for small number of compositions but for a scalable implementation we need a +-- CPS version. + +-- | READ THE CAVEATS in 'concatMap' before using this instance. +-- +-- >>> (>>=) = flip Parser.concatMap +-- +instance Monad m => Monad (Parser a m) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + (>>=) = flip concatMap + + {-# INLINE (>>) #-} + (>>) = (*>) + +-- | >>> fail = Parser.die +instance Monad m => Fail.MonadFail (Parser a m) where + {-# INLINE fail #-} + fail = die + +{- +-- | See documentation of 'Streamly.Internal.Data.Parser.ParserK.Type.Parser'. +-- +instance Monad m => MonadPlus (Parser a m) where + {-# INLINE mzero #-} + mzero = die "mzero" + + {-# INLINE mplus #-} + mplus = alt +-} + +-- | >>> liftIO = Parser.fromEffect . liftIO +instance (MonadIO m) => MonadIO (Parser a m) where + {-# INLINE liftIO #-} + liftIO = fromEffect . liftIO + +------------------------------------------------------------------------------ +-- Mapping on input +------------------------------------------------------------------------------ + +-- | @lmap f parser@ maps the function @f@ on the input of the parser. +-- +-- >>> Stream.parse (Parser.lmap (\x -> x * x) (Parser.fromFold Fold.sum)) (Stream.enumerateFromTo 1 100) +-- Right 338350 +-- +-- > lmap = Parser.lmapM return +-- +{-# INLINE lmap #-} +lmap :: (a -> b) -> Parser b m r -> Parser a m r +lmap f (Parser step begin done) = Parser step1 begin done + + where + + step1 x a = step x (f a) + +-- | @lmapM f parser@ maps the monadic function @f@ on the input of the parser. +-- +{-# INLINE lmapM #-} +lmapM :: Monad m => (a -> m b) -> Parser b m r -> Parser a m r +lmapM f (Parser step begin done) = Parser step1 begin done + + where + + step1 x a = f a >>= step x + +-- | Include only those elements that pass a predicate. +-- +-- >>> Stream.parse (Parser.filter (> 5) (Parser.fromFold Fold.sum)) $ Stream.fromList [1..10] +-- Right 40 +-- +{-# INLINE filter #-} +filter :: Monad m => (a -> Bool) -> Parser a m b -> Parser a m b +filter f (Parser step initial extract) = Parser step1 initial extract + + where + + step1 x a = if f a then step x a else return $ SPartial 1 x + +-- XXX move this to ParserD.Transformer + +-- | Modify the environment of the underlying ReaderT monad. +{-# INLINE localReaderT #-} +localReaderT :: + (r -> r) -> Parser a (ReaderT r m) b -> Parser a (ReaderT r m) b +localReaderT f (Parser step initial extract) = + Parser + ((local f .) . step) + (local f initial) + (local f . extract) diff --git a/src/Streamly/Internal/Data/ParserDrivers.h b/src/Streamly/Internal/Data/ParserDrivers.h new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/ParserDrivers.h @@ -0,0 +1,1100 @@ +#ifndef PARSER_WITH_POS +#define PARSE_BREAK parseBreak +#define PARSE_BREAK_STREAMK parseBreakStreamK +#define PARSE_BREAK_CHUNKS parseBreakChunks +#define PARSE_BREAK_CHUNKS_GENERIC parseBreakChunksGeneric +#define PARSE_MANY parseMany +#define PARSE_ITERATE parseIterate +#define OPTIONAL(x) +#define PARSE_ERROR(x) ParseError +#define PARSE_ERROR_TYPE ParseError +#else +#undef PARSE_BREAK +#define PARSE_BREAK parseBreakPos +#undef PARSE_BREAK_STREAMK +#define PARSE_BREAK_STREAMK parseBreakStreamKPos +#undef PARSE_BREAK_CHUNKS +#define PARSE_BREAK_CHUNKS parseBreakChunksPos +#undef PARSE_BREAK_CHUNKS_GENERIC +#define PARSE_BREAK_CHUNKS_GENERIC parseBreakChunksGenericPos + +#define ParseChunksState ParseChunksStatePos +#define ParseChunksInit ParseChunksInitPos +#define ParseChunksInitBuf ParseChunksInitBufPos +#define ParseChunksInitLeftOver ParseChunksInitLeftOverPos +#define ParseChunksStream ParseChunksStreamPos +#define ParseChunksStop ParseChunksStopPos +#define ParseChunksBuf ParseChunksBufPos +#define ParseChunksExtract ParseChunksExtractPos +#define ParseChunksYield ParseChunksYieldPos + +#undef PARSE_MANY +#define PARSE_MANY parseManyPos + +#define ConcatParseState ConcatParseStatePos +#define ConcatParseInit ConcatParseInitPos +#define ConcatParseInitBuf ConcatParseInitBufPos +#define ConcatParseInitLeftOver ConcatParseInitLeftOverPos +#define ConcatParseStop ConcatParseStopPos +#define ConcatParseStream ConcatParseStreamPos +#define ConcatParseBuf ConcatParseBufPos +#define ConcatParseExtract ConcatParseExtractPos +#define ConcatParseYield ConcatParseYieldPos + +#undef PARSE_ITERATE +#define PARSE_ITERATE parseIteratePos +#undef OPTIONAL +#define OPTIONAL(x) (x) +#undef PARSE_ERROR +#define PARSE_ERROR(x) ParseErrorPos (x) +#undef PARSE_ERROR_TYPE +#define PARSE_ERROR_TYPE ParseErrorPos +#endif + +{- HLINT ignore -} + +{-# ANN type ParseChunksState Fuse #-} +data ParseChunksState x inpBuf st pst = + ParseChunksInit OPTIONAL(Int) inpBuf st + | ParseChunksInitBuf OPTIONAL(Int) inpBuf + | ParseChunksInitLeftOver OPTIONAL(Int) inpBuf + | ParseChunksStream OPTIONAL(Int) st inpBuf !pst + | ParseChunksStop OPTIONAL(Int) inpBuf !pst + | ParseChunksBuf OPTIONAL(Int) inpBuf st inpBuf !pst + | ParseChunksExtract OPTIONAL(Int) inpBuf inpBuf !pst + | ParseChunksYield x (ParseChunksState x inpBuf st pst) + +-- XXX return the remaining stream as part of the error. +{-# INLINE_NORMAL PARSE_MANY #-} +PARSE_MANY + :: Monad m + => PRD.Parser a m b + -> Stream m a + -> Stream m (Either PARSE_ERROR_TYPE b) +PARSE_MANY (PRD.Parser pstep initial extract) (Stream step state) = + Stream stepOuter (ParseChunksInit OPTIONAL(0) [] state) + + where + + {-# INLINE splitAt #-} + splitAt = Stream.splitAt "Data.StreamK.parseMany" + + {-# INLINE_LATE stepOuter #-} + -- Buffer is empty, get the first element from the stream, initialize the + -- fold and then go to stream processing loop. + stepOuter gst (ParseChunksInit OPTIONAL(i) [] st) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + res <- initial + case res of + PRD.IPartial ps -> + return $ Skip $ ParseChunksBuf OPTIONAL(i) [x] s [] ps + PRD.IDone pb -> + let next = ParseChunksInit OPTIONAL(i) [x] s + in return $ Skip $ ParseChunksYield (Right pb) next + PRD.IError err -> + return + $ Skip + $ ParseChunksYield + (Left (PARSE_ERROR(i) err)) + (ParseChunksInitLeftOver OPTIONAL(i) []) + Skip s -> return $ Skip $ ParseChunksInit OPTIONAL(i) [] s + Stop -> return Stop + + -- Buffer is not empty, go to buffered processing loop + stepOuter _ (ParseChunksInit OPTIONAL(i) src st) = do + res <- initial + case res of + PRD.IPartial ps -> + return $ Skip $ ParseChunksBuf OPTIONAL(i) src st [] ps + PRD.IDone pb -> + let next = ParseChunksInit OPTIONAL(i) src st + in return $ Skip $ ParseChunksYield (Right pb) next + PRD.IError err -> + return + $ Skip + $ ParseChunksYield + (Left (PARSE_ERROR(i) err)) + (ParseChunksInitLeftOver OPTIONAL(i) []) + + -- This is simplified ParseChunksInit + stepOuter _ (ParseChunksInitBuf OPTIONAL(i) src) = do + res <- initial + case res of + PRD.IPartial ps -> + return $ Skip $ ParseChunksExtract OPTIONAL(i) src [] ps + PRD.IDone pb -> + let next = ParseChunksInitBuf OPTIONAL(i) src + in return $ Skip $ ParseChunksYield (Right pb) next + PRD.IError err -> + return + $ Skip + $ ParseChunksYield + (Left (PARSE_ERROR(i) err)) + (ParseChunksInitLeftOver OPTIONAL(i) []) + + -- XXX we just discard any leftover input at the end + stepOuter _ (ParseChunksInitLeftOver OPTIONAL(_) _) = return Stop + + -- Buffer is empty, process elements from the stream + stepOuter gst (ParseChunksStream OPTIONAL(i) st buf pst) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> + return $ Skip $ ParseChunksStream OPTIONAL(i + 1) s [] pst1 + PR.SPartial m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 + return $ Skip $ ParseChunksBuf OPTIONAL(i + m) src s [] pst1 + PR.SContinue 1 pst1 -> + return $ Skip $ ParseChunksStream OPTIONAL(i + 1) s (x:buf) pst1 + PR.SContinue m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let (src0, buf1) = splitAt n (x:buf) + src = Prelude.reverse src0 + return $ Skip $ ParseChunksBuf OPTIONAL(i + m) src s buf1 pst1 + PR.SDone 1 b -> do + return $ Skip $ + ParseChunksYield + (Right b) (ParseChunksInit OPTIONAL(i + 1) [] s) + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src = Prelude.reverse (Prelude.take n (x:buf)) + return $ Skip $ + ParseChunksYield + (Right b) (ParseChunksInit OPTIONAL(i + m) src s) + PR.SError err -> + return + $ Skip + $ ParseChunksYield + (Left (PARSE_ERROR(i + 1) err)) + (ParseChunksInitLeftOver OPTIONAL(i + 1) []) + Skip s -> return $ Skip $ ParseChunksStream OPTIONAL(i) s buf pst + Stop -> return $ Skip $ ParseChunksStop OPTIONAL(i) buf pst + + -- go back to stream processing mode + stepOuter _ (ParseChunksBuf OPTIONAL(i) [] s buf pst) = + return $ Skip $ ParseChunksStream OPTIONAL(i) s buf pst + + -- buffered processing loop + stepOuter _ (ParseChunksBuf OPTIONAL(i) (x:xs) s buf pst) = do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> + return $ Skip $ ParseChunksBuf OPTIONAL(i + 1) xs s [] pst1 + PR.SPartial m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 ++ xs + return $ Skip $ ParseChunksBuf OPTIONAL(i + m) src s [] pst1 + PR.SContinue 1 pst1 -> + return $ Skip $ ParseChunksBuf OPTIONAL(i + 1) xs s (x:buf) pst1 + PR.SContinue m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let (src0, buf1) = splitAt n (x:buf) + src = Prelude.reverse src0 ++ xs + return $ Skip $ ParseChunksBuf OPTIONAL(i + m) src s buf1 pst1 + PR.SDone 1 b -> + return + $ Skip + $ ParseChunksYield (Right b) (ParseChunksInit OPTIONAL(i + 1) xs s) + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs + return $ Skip + $ ParseChunksYield + (Right b) (ParseChunksInit OPTIONAL(i + m) src s) + PR.SError err -> + return + $ Skip + $ ParseChunksYield + (Left (PARSE_ERROR(i + 1) err)) + (ParseChunksInitLeftOver OPTIONAL(i + 1) []) + + -- This is simplified ParseChunksBuf + stepOuter _ (ParseChunksExtract OPTIONAL(i) [] buf pst) = + return $ Skip $ ParseChunksStop OPTIONAL(i) buf pst + + stepOuter _ (ParseChunksExtract OPTIONAL(i) (x:xs) buf pst) = do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> + return $ Skip $ ParseChunksExtract OPTIONAL(i + 1) xs [] pst1 + PR.SPartial m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 ++ xs + return $ Skip $ ParseChunksExtract OPTIONAL(i + m) src [] pst1 + PR.SContinue 1 pst1 -> + return $ Skip $ ParseChunksExtract OPTIONAL(i + 1) xs (x:buf) pst1 + PR.SContinue m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let (src0, buf1) = splitAt n (x:buf) + src = Prelude.reverse src0 ++ xs + return $ Skip $ ParseChunksExtract OPTIONAL(i + m) src buf1 pst1 + PR.SDone 1 b -> + return + $ Skip + $ ParseChunksYield (Right b) (ParseChunksInitBuf OPTIONAL(i + 1) xs) + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs + return + $ Skip + $ ParseChunksYield + (Right b) (ParseChunksInitBuf OPTIONAL(i + m) src) + PR.SError err -> + return + $ Skip + $ ParseChunksYield + (Left (PARSE_ERROR(i + 1) err)) + (ParseChunksInitLeftOver OPTIONAL(i + 1) []) + + -- This is simplified ParseChunksExtract + stepOuter _ (ParseChunksStop OPTIONAL(i) buf pst) = do + pRes <- extract pst + case pRes of + PR.FContinue 0 pst1 -> + return $ Skip $ ParseChunksStop OPTIONAL(i) buf pst1 + PR.FContinue m pst1 -> do + let n = (- m) + assert (n <= length buf) (return ()) + let (src0, buf1) = splitAt n buf + src = Prelude.reverse src0 + return $ Skip $ ParseChunksExtract OPTIONAL(i + m) src buf1 pst1 + PR.FDone 0 b -> do + return $ Skip $ + ParseChunksYield (Right b) (ParseChunksInitLeftOver OPTIONAL(i) []) + PR.FDone m b -> do + let n = (- m) + assert (n <= length buf) (return ()) + let src = Prelude.reverse (Prelude.take n buf) + return $ Skip $ + ParseChunksYield (Right b) (ParseChunksInitBuf OPTIONAL(i + m) src) + PR.FError err -> + return + $ Skip + $ ParseChunksYield + (Left (PARSE_ERROR(i) err)) + (ParseChunksInitLeftOver OPTIONAL(i) []) + + stepOuter _ (ParseChunksYield a next) = return $ Yield a next + +{-# ANN type ConcatParseState Fuse #-} +data ConcatParseState c b inpBuf st p m a = + ConcatParseInit OPTIONAL(Int) inpBuf st p + | ConcatParseInitBuf OPTIONAL(Int) inpBuf p + | ConcatParseInitLeftOver OPTIONAL(Int) inpBuf + | forall s. ConcatParseStop OPTIONAL(Int) + inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m (PRD.Final s b)) + | forall s. ConcatParseStream OPTIONAL(Int) + st inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m (PRD.Final s b)) + | forall s. ConcatParseBuf OPTIONAL(Int) + inpBuf st inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m (PRD.Final s b)) + | forall s. ConcatParseExtract OPTIONAL(Int) + inpBuf inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m (PRD.Final s b)) + | ConcatParseYield c (ConcatParseState c b inpBuf st p m a) + +{-# INLINE_NORMAL PARSE_ITERATE #-} +PARSE_ITERATE + :: Monad m + => (b -> PRD.Parser a m b) + -> b + -> Stream m a + -> Stream m (Either PARSE_ERROR_TYPE b) +PARSE_ITERATE func seed (Stream step state) = + Stream stepOuter (ConcatParseInit OPTIONAL(0) [] state (func seed)) + + where + + {-# INLINE splitAt #-} + splitAt = Stream.splitAt "Data.StreamK.parseIterate" + + {-# INLINE_LATE stepOuter #-} + -- Buffer is empty, go to stream processing loop + stepOuter _ (ConcatParseInit OPTIONAL(i) [] st (PRD.Parser pstep initial extract)) = do + res <- initial + case res of + PRD.IPartial ps -> + return $ Skip $ ConcatParseStream OPTIONAL(i) st [] pstep ps extract + PRD.IDone pb -> + let next = ConcatParseInit OPTIONAL(i) [] st (func pb) + in return $ Skip $ ConcatParseYield (Right pb) next + PRD.IError err -> + return + $ Skip + $ ConcatParseYield + (Left (PARSE_ERROR(i) err)) + (ConcatParseInitLeftOver OPTIONAL(i) []) + + -- Buffer is not empty, go to buffered processing loop + stepOuter _ (ConcatParseInit OPTIONAL(i) src st + (PRD.Parser pstep initial extract)) = do + res <- initial + case res of + PRD.IPartial ps -> + return $ Skip $ ConcatParseBuf OPTIONAL(i) src st [] pstep ps extract + PRD.IDone pb -> + let next = ConcatParseInit OPTIONAL(i) src st (func pb) + in return $ Skip $ ConcatParseYield (Right pb) next + PRD.IError err -> + return + $ Skip + $ ConcatParseYield + (Left (PARSE_ERROR(i) err)) + (ConcatParseInitLeftOver OPTIONAL(i) []) + + -- This is simplified ConcatParseInit + stepOuter _ (ConcatParseInitBuf OPTIONAL(i) src + (PRD.Parser pstep initial extract)) = do + res <- initial + case res of + PRD.IPartial ps -> + return $ Skip $ ConcatParseExtract OPTIONAL(i) src [] pstep ps extract + PRD.IDone pb -> + let next = ConcatParseInitBuf OPTIONAL(i) src (func pb) + in return $ Skip $ ConcatParseYield (Right pb) next + PRD.IError err -> + return + $ Skip + $ ConcatParseYield + (Left (PARSE_ERROR(i) err)) + (ConcatParseInitLeftOver OPTIONAL(i) []) + + -- XXX we just discard any leftover input at the end + stepOuter _ (ConcatParseInitLeftOver OPTIONAL(_) _) = return Stop + + -- Buffer is empty process elements from the stream + stepOuter gst (ConcatParseStream OPTIONAL(i) st buf pstep pst extract) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> + return $ Skip + $ ConcatParseStream OPTIONAL(i + 1) s [] pstep pst1 extract + PR.SPartial m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 + return $ Skip + $ ConcatParseBuf + OPTIONAL(i + m) src s [] pstep pst1 extract + -- PR.SContinue 1 pst1 -> + -- return $ Skip $ ConcatParseStream s (x:buf) pst1 + PR.SContinue m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let (src0, buf1) = splitAt n (x:buf) + src = Prelude.reverse src0 + return $ Skip + $ ConcatParseBuf + OPTIONAL(i + m) src s buf1 pstep pst1 extract + -- XXX Specialize for Stop 0 common case? + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src = Prelude.reverse (Prelude.take n (x:buf)) + return $ Skip + $ ConcatParseYield + (Right b) + (ConcatParseInit OPTIONAL(i + m) src s (func b)) + PR.SError err -> + return + $ Skip + $ ConcatParseYield + (Left (PARSE_ERROR(i + 1) err)) + (ConcatParseInitLeftOver OPTIONAL(i + 1) []) + Skip s -> + return $ Skip $ ConcatParseStream OPTIONAL(i) s buf pstep pst extract + Stop -> return $ Skip $ ConcatParseStop OPTIONAL(i) buf pstep pst extract + + -- go back to stream processing mode + stepOuter _ (ConcatParseBuf OPTIONAL(i) [] s buf pstep ps extract) = + return $ Skip $ ConcatParseStream OPTIONAL(i) s buf pstep ps extract + + -- buffered processing loop + stepOuter _ (ConcatParseBuf OPTIONAL(i) (x:xs) s buf pstep pst extract) = do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> + return $ Skip + $ ConcatParseBuf OPTIONAL(i + 1) xs s [] pstep pst1 extract + PR.SPartial m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 ++ xs + return $ Skip + $ ConcatParseBuf OPTIONAL(i + m) src s [] pstep pst1 extract + -- PR.SContinue 1 pst1 -> return $ Skip $ ConcatParseBuf xs s (x:buf) pst1 + PR.SContinue m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let (src0, buf1) = splitAt n (x:buf) + src = Prelude.reverse src0 ++ xs + return $ Skip + $ ConcatParseBuf OPTIONAL(i + m) src s buf1 pstep pst1 extract + -- XXX Specialize for Stop 0 common case? + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs + return $ Skip + $ ConcatParseYield + (Right b) (ConcatParseInit OPTIONAL(i + m) src s (func b)) + PR.SError err -> + return + $ Skip + $ ConcatParseYield + (Left (PARSE_ERROR(i + 1) err)) + (ConcatParseInitLeftOver OPTIONAL(i + 1) []) + + -- This is simplified ConcatParseBuf + stepOuter _ (ConcatParseExtract OPTIONAL(i) [] buf pstep pst extract) = + return $ Skip $ ConcatParseStop OPTIONAL(i) buf pstep pst extract + + stepOuter _ (ConcatParseExtract OPTIONAL(i) (x:xs) buf pstep pst extract) = do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> + return $ Skip + $ ConcatParseExtract OPTIONAL(i + 1) xs [] pstep pst1 extract + PR.SPartial m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 ++ xs + return $ Skip + $ ConcatParseExtract OPTIONAL(i + m) src [] pstep pst1 extract + PR.SContinue 1 pst1 -> + return $ Skip + $ ConcatParseExtract OPTIONAL(i + 1) xs (x:buf) pstep pst1 extract + PR.SContinue m pst1 -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let (src0, buf1) = splitAt n (x:buf) + src = Prelude.reverse src0 ++ xs + return $ Skip + $ ConcatParseExtract OPTIONAL(i + m) src buf1 pstep pst1 extract + PR.SDone 1 b -> + return $ Skip + $ ConcatParseYield + (Right b) (ConcatParseInitBuf OPTIONAL(i + 1) xs (func b)) + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs + return $ Skip + $ ConcatParseYield + (Right b) (ConcatParseInitBuf OPTIONAL(i + m) src (func b)) + PR.SError err -> + return + $ Skip + $ ConcatParseYield + (Left (PARSE_ERROR(i + 1) err)) + (ConcatParseInitLeftOver OPTIONAL(i + 1) []) + + -- This is simplified ConcatParseExtract + stepOuter _ (ConcatParseStop OPTIONAL(i) buf pstep pst extract) = do + pRes <- extract pst + case pRes of + PR.FContinue 0 pst1 -> + return $ Skip $ ConcatParseStop OPTIONAL(i) buf pstep pst1 extract + PR.FContinue m pst1 -> do + let n = (- m) + assert (n <= length buf) (return ()) + let (src0, buf1) = splitAt n buf + src = Prelude.reverse src0 + return $ Skip + $ ConcatParseExtract OPTIONAL(i + m) src buf1 pstep pst1 extract + PR.FDone 0 b -> do + return $ Skip $ + ConcatParseYield (Right b) (ConcatParseInitLeftOver OPTIONAL(i) []) + PR.FDone m b -> do + let n = (- m) + assert (n <= length buf) (return ()) + let src = Prelude.reverse (Prelude.take n buf) + return $ Skip $ + ConcatParseYield + (Right b) (ConcatParseInitBuf OPTIONAL(i + m) src (func b)) + PR.FError err -> + return + $ Skip + $ ConcatParseYield + (Left (PARSE_ERROR(i) err)) + (ConcatParseInitLeftOver OPTIONAL(i) []) + + stepOuter _ (ConcatParseYield a next) = return $ Yield a next + +{-# INLINE PARSE_BREAK #-} +PARSE_BREAK :: Monad m => + PR.Parser a m b -> Stream m a -> m (Either PARSE_ERROR_TYPE b, Stream m a) +PARSE_BREAK (PRD.Parser pstep initial extract) stream@(Stream step state) = do + res <- initial + case res of + PRD.IPartial s -> + go SPEC state (List []) s OPTIONAL(0) + -- Using go0 does improve alt and manyTill benchmarks dramatically + -- but also degrades the split/monad benchmarks equally. Needs more + -- investigation. + -- go0 SPEC state s COUNT(0) + PRD.IDone b -> return (Right b, stream) + PRD.IError err -> return (Left (PARSE_ERROR(0) err), stream) + + where + + {-# INLINE splitAt #-} + splitAt = Stream.splitAt "Data.Stream.parseBreak" + + -- "buf" contains last few items in the stream that we may have to + -- backtrack to. + -- + -- XXX currently we are using a dumb list based approach for backtracking + -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. + -- That will allow us more efficient random back and forth movement. + go !_ st buf !pst OPTIONAL(i) = do + r <- step defState st + case r of + Yield x s -> do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> go SPEC s (List []) pst1 OPTIONAL(i+1) + -- go0 SPEC s pst1 (i + 1) + PR.SPartial 0 pst1 -> go1 SPEC s x pst1 OPTIONAL(i) + PR.SPartial m pst1 -> do + let n = 1 - m + assert (n <= length (x:getList buf)) (return ()) + let src0 = Prelude.take n (x:getList buf) + src = Prelude.reverse src0 + gobuf SPEC s (List []) (List src) pst1 OPTIONAL(i+m) + PR.SContinue 1 pst1 -> + go SPEC s (List (x:getList buf)) pst1 OPTIONAL(i+1) + PR.SContinue 0 pst1 -> gobuf SPEC s buf (List [x]) pst1 OPTIONAL(i) + PR.SContinue m pst1 -> do + let n = 1 - m + assert (n <= length (x:getList buf)) (return ()) + let (src0, buf1) = splitAt n (x:getList buf) + src = Prelude.reverse src0 + gobuf SPEC s (List buf1) (List src) pst1 OPTIONAL(i+m) + PR.SDone 1 b -> return (Right b, Stream step s) + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:getList buf)) (return ()) + let src0 = Prelude.take n (x:getList buf) + src = Prelude.reverse src0 + -- XXX This would make it quadratic. We should probably + -- use StreamK if we have to append many times. + return + ( Right b, + Nesting.append (fromList src) (Stream step s)) + PR.SError err -> do + let src = Prelude.reverse $ x:getList buf + return + ( Left (PARSE_ERROR(i+1) err) + , Nesting.append (fromList src) (Stream step s) + ) + + Skip s -> go SPEC s buf pst OPTIONAL(i) + Stop -> goStop SPEC buf pst OPTIONAL(i) + + {- + go0 !_ st !pst i = do + r <- step defState st + case r of + Yield x s -> do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> go0 SPEC s pst1 (i + 1) + PR.SPartial 0 pst1 -> go1 SPEC s x pst1 i + PR.SPartial _ _ -> error "Unreachable" + PR.SContinue 1 pst1 -> go SPEC s (List [x]) pst1 (i + 1) + PR.SContinue 0 pst1 -> go1 SPEC s x pst1 i + PR.SContinue _ _ -> error "Unreachable" + PR.SDone 1 b -> return (Right b, Stream step s) + PR.SDone 0 b -> + return ( Right b, StreamD.cons x (Stream step s)) + PR.SDone _ _ -> error "Unreachable" + PR.SError err -> do + return + ( Left (PARSE_ERROR(i + 1) err) + , StreamD.cons x (Stream step s) + ) + + Skip s -> go0 SPEC s pst i + Stop -> goStop SPEC (List []) pst i + -} + + go1 !_ s x !pst OPTIONAL(i) = do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> + -- go0 SPEC s pst1 OPTIONAL(i + 1) + go SPEC s (List []) pst1 OPTIONAL(i + 1) + PR.SPartial 0 pst1 -> do + go1 SPEC s x pst1 OPTIONAL(i) + PR.SPartial m _ -> + error $ "parseBreak: parser bug, go1: Partial m = " ++ show m + PR.SContinue 1 pst1 -> + go SPEC s (List [x]) pst1 OPTIONAL(i + 1) + PR.SContinue 0 pst1 -> + go1 SPEC s x pst1 OPTIONAL(i) + PR.SContinue m _ -> do + error $ "parseBreak: parser bug, go1: Continue m = " ++ show m + PR.SDone 1 b -> do + return (Right b, Stream step s) + PR.SDone 0 b -> do + return (Right b, StreamD.cons x (Stream step s)) + PR.SDone m _ -> do + error $ "parseBreak: parser bug, go1: SDone m = " ++ show m + PR.SError err -> + return + ( Left (PARSE_ERROR(i + 1) err) + , Nesting.append (fromPure x) (Stream step s) + ) + + -- gobuf !_ s (List []) (List []) !pst i = go0 SPEC s pst i + gobuf !_ s buf (List []) !pst OPTIONAL(i) = go SPEC s buf pst OPTIONAL(i) + gobuf !_ s buf (List (x:xs)) !pst OPTIONAL(i) = do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> + gobuf SPEC s (List []) (List xs) pst1 OPTIONAL(i + 1) + PR.SPartial m pst1 -> do + let n = 1 - m + assert (n <= length (x:getList buf)) (return ()) + let src0 = Prelude.take n (x:getList buf) + src = Prelude.reverse src0 ++ xs + gobuf SPEC s (List []) (List src) pst1 OPTIONAL(i + m) + PR.SContinue 1 pst1 -> + gobuf SPEC s (List (x:getList buf)) (List xs) pst1 OPTIONAL(i + 1) + PR.SContinue 0 pst1 -> + gobuf SPEC s buf (List (x:xs)) pst1 OPTIONAL(i) + PR.SContinue m pst1 -> do + let n = 1 - m + assert (n <= length (x:getList buf)) (return ()) + let (src0, buf1) = splitAt n (x:getList buf) + src = Prelude.reverse src0 ++ xs + gobuf SPEC s (List buf1) (List src) pst1 OPTIONAL(i + m) + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:getList buf)) (return ()) + let src0 = Prelude.take n (x:getList buf) + src = Prelude.reverse src0 ++ xs + return (Right b, Nesting.append (fromList src) (Stream step s)) + PR.SError err -> do + let src = Prelude.reverse (getList buf) ++ x:xs + return + ( Left (PARSE_ERROR(i + 1) err) + , Nesting.append (fromList src) (Stream step s) + ) + + -- This is simplified gobuf + goExtract !_ buf (List []) !pst OPTIONAL(i) = goStop SPEC buf pst OPTIONAL(i) + goExtract !_ buf (List (x:xs)) !pst OPTIONAL(i) = do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 pst1 -> + goExtract SPEC (List []) (List xs) pst1 OPTIONAL(i + 1) + PR.SPartial m pst1 -> do + let n = 1 - m + assert (n <= length (x:getList buf)) (return ()) + let src0 = Prelude.take n (x:getList buf) + src = Prelude.reverse src0 ++ xs + goExtract SPEC (List []) (List src) pst1 OPTIONAL(i + m) + PR.SContinue 1 pst1 -> + goExtract SPEC (List (x:getList buf)) (List xs) pst1 OPTIONAL(i + 1) + PR.SContinue 0 pst1 -> + goExtract SPEC buf (List (x:xs)) pst1 OPTIONAL(i) + PR.SContinue m pst1 -> do + let n = 1 - m + assert (n <= length (x:getList buf)) (return ()) + let (src0, buf1) = splitAt n (x:getList buf) + src = Prelude.reverse src0 ++ xs + goExtract SPEC (List buf1) (List src) pst1 OPTIONAL(i + m) + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:getList buf)) (return ()) + let src0 = Prelude.take n (x:getList buf) + src = Prelude.reverse src0 ++ xs + return (Right b, fromList src) + PR.SError err -> do + let src = Prelude.reverse (getList buf) ++ x:xs + return (Left (PARSE_ERROR(i + 1) err), fromList src) + + -- This is simplified goExtract + {-# INLINE goStop #-} + goStop _ buf pst OPTIONAL(i) = do + pRes <- extract pst + case pRes of + PR.FContinue 0 pst1 -> goStop SPEC buf pst1 OPTIONAL(i) + PR.FContinue m pst1 -> do + let n = (- m) + assert (n <= length (getList buf)) (return ()) + let (src0, buf1) = splitAt n (getList buf) + src = Prelude.reverse src0 + goExtract SPEC (List buf1) (List src) pst1 OPTIONAL(i + m) + PR.FDone 0 b -> return (Right b, StreamD.nil) + PR.FDone m b -> do + let n = (- m) + assert (n <= length (getList buf)) (return ()) + let src0 = Prelude.take n (getList buf) + src = Prelude.reverse src0 + return (Right b, fromList src) + PR.FError err -> do + let src = Prelude.reverse $ getList buf + return (Left (PARSE_ERROR(i) err), fromList src) + +{-# INLINE_NORMAL PARSE_BREAK_STREAMK #-} +PARSE_BREAK_STREAMK + :: forall m a b. Monad m + => ParserK.ParserK a m b + -> StreamK m a + -> m (Either PARSE_ERROR_TYPE b, StreamK m a) +PARSE_BREAK_STREAMK parser input = do + let parserk = ParserK.runParser parser ParserK.parserDone 0 0 + in go OPTIONAL(0) [] parserk input + + where + + {-# INLINE backtrck #-} + -- backtrck :: Int -> [a] -> StreamK m a -> (StreamK m a, [a]) + backtrck n xs stream = + let (pre, post) = Stream.splitAt "Data.StreamK.parseBreak" n xs + in (StreamK.append (StreamK.fromList (Prelude.reverse pre)) stream, post) + + {-# INLINE goStop #-} + {- + goStop + :: OPTIONAL(Int ->) + [a] + -> (ParserK.Input a -> m (ParserK.Step a m b)) + -> m (Either PARSE_ERROR_TYPE b, StreamK m a) + -} + goStop OPTIONAL(pos) backBuf parserk = do + pRes <- parserk ParserK.None + case pRes of + -- If we stop in an alternative, it will try calling the next + -- parser, the next parser may call initial returning Partial and + -- then immediately we have to call extract on it. + ParserK.Partial 0 cont1 -> + go OPTIONAL(pos) [] cont1 StreamK.nil + ParserK.Partial n cont1 -> do + let n1 = negate n + assertM(n1 >= 0 && n1 <= length backBuf) + let (s1, backBuf1) = backtrck n1 backBuf StreamK.nil + in go OPTIONAL(pos + n) backBuf1 cont1 s1 + ParserK.Continue 0 cont1 -> + go OPTIONAL(pos) backBuf cont1 StreamK.nil + ParserK.Continue n cont1 -> do + let n1 = negate n + assertM(n1 >= 0 && n1 <= length backBuf) + let (s1, backBuf1) = backtrck n1 backBuf StreamK.nil + in go OPTIONAL(pos + n) backBuf1 cont1 s1 + ParserK.Done 0 b -> + return (Right b, StreamK.nil) + ParserK.Done n b -> do + let n1 = negate n + assertM(n1 >= 0 && n1 <= length backBuf) + let (s1, _) = backtrck n1 backBuf StreamK.nil + in return (Right b, s1) + ParserK.Error _n err -> + let strm = StreamK.fromList (Prelude.reverse backBuf) + in return (Left (PARSE_ERROR(pos + _n) err), strm) + + {- + yieldk + :: OPTIONAL(Int ->) + [a] + -> (ParserK.Input a -> m (ParserK.Step a m b)) + -> a + -> StreamK m a + -> m (Either PPARSE_ERROR_TYPE b, StreamK m a) + -} + yieldk OPTIONAL(pos) backBuf parserk element stream = do + pRes <- parserk (ParserK.Chunk element) + -- NOTE: factoring out "StreamK.cons element stream" in a let statement here + -- cause big alloc regression. + case pRes of + ParserK.Partial 1 cont1 -> go OPTIONAL(pos + 1) [] cont1 stream + ParserK.Partial 0 cont1 -> go OPTIONAL(pos) [] cont1 (StreamK.cons element stream) + ParserK.Partial n cont1 -> do -- n < 0 case + let n1 = negate n + bufLen = length backBuf + s = StreamK.cons element stream + assertM(n1 >= 0 && n1 <= bufLen) + let (s1, _) = backtrck n1 backBuf s + go OPTIONAL(pos + n) [] cont1 s1 + ParserK.Continue 1 cont1 -> go OPTIONAL(pos + 1) (element:backBuf) cont1 stream + ParserK.Continue 0 cont1 -> + go OPTIONAL(pos) backBuf cont1 (StreamK.cons element stream) + ParserK.Continue n cont1 -> do + let n1 = negate n + bufLen = length backBuf + s = StreamK.cons element stream + assertM(n1 >= 0 && n1 <= bufLen) + let (s1, backBuf1) = backtrck n1 backBuf s + go OPTIONAL(pos + n) backBuf1 cont1 s1 + ParserK.Done 1 b -> pure (Right b, stream) + ParserK.Done 0 b -> pure (Right b, StreamK.cons element stream) + ParserK.Done n b -> do + let n1 = negate n + bufLen = length backBuf + s = StreamK.cons element stream + assertM(n1 >= 0 && n1 <= bufLen) + let (s1, _) = backtrck n1 backBuf s + pure (Right b, s1) + ParserK.Error _n err -> + let strm = + StreamK.append + (StreamK.fromList (Prelude.reverse backBuf)) + (StreamK.cons element stream) + -- XXX Need to test if the +1 is correct. + in return (Left (PARSE_ERROR(pos + _n + 1) err), strm) + + {- + go + :: OPTIONAL(Int ->) + [a] + -> (ParserK.Input a -> m (ParserK.Step a m b)) + -> StreamK m a + -> m (Either PARSE_ERROR_TYPE b, StreamK m a) + -} + go OPTIONAL(pos) backBuf parserk stream = do + let stop = goStop OPTIONAL(pos) backBuf parserk + single a = yieldk OPTIONAL(pos) backBuf parserk a StreamK.nil + in StreamK.foldStream + defState (yieldk OPTIONAL(pos) backBuf parserk) single stop stream + +{-# INLINE_NORMAL PARSE_BREAK_CHUNKS #-} +PARSE_BREAK_CHUNKS + :: (Monad m, Unbox a) + => ParserK (Array a) m b + -> StreamK m (Array a) + -> m (Either PARSE_ERROR_TYPE b, StreamK m (Array a)) +PARSE_BREAK_CHUNKS parser input = do + let parserk = ParserK.runParser parser ParserK.parserDone 0 0 + in go OPTIONAL(0) [] parserk input + + where + + {-# INLINE goStop #-} + goStop OPTIONAL(pos) backBuf parserk = do + pRes <- parserk ParserK.None + case pRes of + -- If we stop in an alternative, it will try calling the next + -- parser, the next parser may call initial returning Partial and + -- then immediately we have to call extract on it. + ParserK.Partial 0 cont1 -> + go OPTIONAL(pos) [] cont1 StreamK.nil + ParserK.Partial n cont1 -> do + let n1 = negate n + assertM(n1 >= 0 && n1 <= sum (Prelude.map Array.length backBuf)) + let (s1, backBuf1) = backtrack n1 backBuf StreamK.nil + in go OPTIONAL(pos + n) backBuf1 cont1 s1 + ParserK.Continue 0 cont1 -> + go OPTIONAL(pos) backBuf cont1 StreamK.nil + ParserK.Continue n cont1 -> do + let n1 = negate n + assertM(n1 >= 0 && n1 <= sum (Prelude.map Array.length backBuf)) + let (s1, backBuf1) = backtrack n1 backBuf StreamK.nil + in go OPTIONAL(pos + n) backBuf1 cont1 s1 + ParserK.Done 0 b -> + return (Right b, StreamK.nil) + ParserK.Done n b -> do + let n1 = negate n + assertM(n1 >= 0 && n1 <= sum (Prelude.map Array.length backBuf)) + let (s1, _) = backtrack n1 backBuf StreamK.nil + in return (Right b, s1) + ParserK.Error _n err -> do + let s1 = Prelude.foldl (flip StreamK.cons) StreamK.nil backBuf + return (Left (PARSE_ERROR(pos + _n) err), s1) + + seekErr n len = + error $ "parseBreak: Partial: forward seek not implemented n = " + ++ show n ++ " len = " ++ show len + + yieldk OPTIONAL(pos) backBuf parserk arr stream = do + pRes <- parserk (ParserK.Chunk arr) + let len = Array.length arr + case pRes of + ParserK.Partial n cont1 -> + case compare n len of + EQ -> go OPTIONAL(pos + n) [] cont1 stream + LT -> do + if n >= 0 + then yieldk OPTIONAL(pos + n) [] cont1 arr stream + else do + let n1 = negate n + bufLen = sum (Prelude.map Array.length backBuf) + s = StreamK.cons arr stream + assertM(n1 >= 0 && n1 <= bufLen) + let (s1, _) = backtrack n1 backBuf s + go OPTIONAL(pos + n) [] cont1 s1 + GT -> seekErr n len + ParserK.Continue n cont1 -> + case compare n len of + EQ -> go OPTIONAL(pos + n) (arr:backBuf) cont1 stream + LT -> do + if n >= 0 + then yieldk OPTIONAL(pos + n) backBuf cont1 arr stream + else do + let n1 = negate n + bufLen = sum (Prelude.map Array.length backBuf) + s = StreamK.cons arr stream + assertM(n1 >= 0 && n1 <= bufLen) + let (s1, backBuf1) = backtrack n1 backBuf s + go OPTIONAL(pos + n) backBuf1 cont1 s1 + GT -> seekErr n len + ParserK.Done n b -> do + let n1 = len - n + assertM(n1 <= sum (Prelude.map Array.length (arr:backBuf))) + let (s1, _) = backtrack n1 (arr:backBuf) stream + in return (Right b, s1) + ParserK.Error _n err -> do + let s1 = Prelude.foldl (flip StreamK.cons) stream (arr:backBuf) + return (Left (PARSE_ERROR(pos + _n + 1) err), s1) + + go OPTIONAL(pos) backBuf parserk stream = do + let stop = goStop OPTIONAL(pos) backBuf parserk + single a = yieldk OPTIONAL(pos) backBuf parserk a StreamK.nil + in StreamK.foldStream + defState (yieldk OPTIONAL(pos) backBuf parserk) single stop stream + +{-# INLINE_NORMAL PARSE_BREAK_CHUNKS_GENERIC #-} +PARSE_BREAK_CHUNKS_GENERIC + :: forall m a b. Monad m + => ParserK.ParserK (GArray.Array a) m b + -> StreamK m (GArray.Array a) + -> m (Either PARSE_ERROR_TYPE b, StreamK m (GArray.Array a)) +PARSE_BREAK_CHUNKS_GENERIC parser input = do + let parserk = ParserK.runParser parser ParserK.parserDone 0 0 + in go OPTIONAL(0) [] parserk input + + where + + {-# INLINE goStop #-} + {- + goStop + :: OPTIONAL(Int ->) + [GArray.Array a] + -> (ParserK.Input (GArray.Array a) + -> m (ParserK.Step (GArray.Array a) m b)) + -> m (Either PARSE_ERROR_TYPE b, StreamK m (GArray.Array a)) + -} + goStop OPTIONAL(pos) backBuf parserk = do + pRes <- parserk ParserK.None + case pRes of + -- If we stop in an alternative, it will try calling the next + -- parser, the next parser may call initial returning Partial and + -- then immediately we have to call extract on it. + ParserK.Partial 0 cont1 -> + go OPTIONAL(pos) [] cont1 StreamK.nil + ParserK.Partial n cont1 -> do + let n1 = negate n + assertM(n1 >= 0 && n1 <= sum (Prelude.map GArray.length backBuf)) + let (s1, backBuf1) = backtrackGeneric n1 backBuf StreamK.nil + in go OPTIONAL(pos + n) backBuf1 cont1 s1 + ParserK.Continue 0 cont1 -> + go OPTIONAL(pos) backBuf cont1 StreamK.nil + ParserK.Continue n cont1 -> do + let n1 = negate n + assertM(n1 >= 0 && n1 <= sum (Prelude.map GArray.length backBuf)) + let (s1, backBuf1) = backtrackGeneric n1 backBuf StreamK.nil + in go OPTIONAL(pos + n) backBuf1 cont1 s1 + ParserK.Done 0 b -> + return (Right b, StreamK.nil) + ParserK.Done n b -> do + let n1 = negate n + assertM(n1 >= 0 && n1 <= sum (Prelude.map GArray.length backBuf)) + let (s1, _) = backtrackGeneric n1 backBuf StreamK.nil + in return (Right b, s1) + ParserK.Error _n err -> + let strm = Prelude.foldl (flip StreamK.cons) StreamK.nil backBuf + in return (Left (PARSE_ERROR(pos + _n) err), strm) + + seekErr n len = + error $ "parseBreak: Partial: forward seek not implemented n = " + ++ show n ++ " len = " ++ show len + + {- + yieldk + :: OPTIONAL(Int ->) + [GArray.Array a] + -> (ParserK.Input (GArray.Array a) + -> m (ParserK.Step (GArray.Array a) m b)) + -> Array a + -> StreamK m (GArray.Array a) + -> m (Either PARSE_ERROR_TYPE b, StreamK m (GArray.Array a)) + -} + yieldk OPTIONAL(pos) backBuf parserk arr stream = do + pRes <- parserk (ParserK.Chunk arr) + let len = GArray.length arr + case pRes of + ParserK.Partial n cont1 -> + case compare n len of + EQ -> go OPTIONAL(pos + n) [] cont1 stream + LT -> do + if n >= 0 + then yieldk OPTIONAL(pos + n) [] cont1 arr stream + else do + let n1 = negate n + bufLen = sum (Prelude.map GArray.length backBuf) + s = StreamK.cons arr stream + assertM(n1 >= 0 && n1 <= bufLen) + let (s1, _) = backtrackGeneric n1 backBuf s + go OPTIONAL(pos + n) [] cont1 s1 + GT -> seekErr n len + ParserK.Continue n cont1 -> + case compare n len of + EQ -> go OPTIONAL(pos + n) (arr:backBuf) cont1 stream + LT -> do + if n >= 0 + then yieldk OPTIONAL(pos + n) backBuf cont1 arr stream + else do + let n1 = negate n + bufLen = sum (Prelude.map GArray.length backBuf) + s = StreamK.cons arr stream + assertM(n1 >= 0 && n1 <= bufLen) + let (s1, backBuf1) = backtrackGeneric n1 backBuf s + go OPTIONAL(pos + n) backBuf1 cont1 s1 + GT -> seekErr n len + ParserK.Done n b -> do + let n1 = len - n + assertM(n1 <= sum (Prelude.map GArray.length (arr:backBuf))) + let (s1, _) = backtrackGeneric n1 (arr:backBuf) stream + in return (Right b, s1) + ParserK.Error _n err -> + let strm = Prelude.foldl (flip StreamK.cons) stream (arr:backBuf) + in return (Left (PARSE_ERROR(pos + _n + 1) err), strm) + + {- + go + :: OPTIONAL(Int ->) + [GArray.Array a] + -> (ParserK.Input (GArray.Array a) + -> m (ParserK.Step (GArray.Array a) m b)) + -> StreamK m (GArray.Array a) + -> m (Either PARSE_ERROR_TYPE b, StreamK m (GArray.Array a)) + -} + go OPTIONAL(pos) backBuf parserk stream = do + let stop = goStop OPTIONAL(pos) backBuf parserk + single a = yieldk OPTIONAL(pos) backBuf parserk a StreamK.nil + in StreamK.foldStream + defState (yieldk OPTIONAL(pos) backBuf parserk) single stop stream diff --git a/src/Streamly/Internal/Data/ParserDrivers.hs b/src/Streamly/Internal/Data/ParserDrivers.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/ParserDrivers.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.ParserDrivers +-- Copyright : (c) 2018 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.ParserDrivers + ( + -- * Running a Parser + parseBreak + , parseBreakPos + , parseBreakStreamK + , parseBreakStreamKPos + , parseBreakChunks + , parseBreakChunksPos + , parseBreakChunksGeneric + , parseBreakChunksGenericPos + , parseMany + , parseManyPos + , parseIterate + , parseIteratePos + ) + where + +#include "assert.hs" +#include "inline.hs" +#include "ArrayMacros.h" + +import Data.Proxy (Proxy(..)) +import Fusion.Plugin.Types (Fuse(..)) +import GHC.Exts (SpecConstrAnnotation(..)) +import GHC.Types (SPEC(..)) +import Streamly.Internal.Data.Array.Type (Array(..)) +import Streamly.Internal.Data.Parser (ParseError(..), ParseErrorPos(..)) +import Streamly.Internal.Data.ParserK.Type (ParserK) +import Streamly.Internal.Data.StreamK.Type (StreamK) +import Streamly.Internal.Data.SVar.Type (adaptState, defState) +import Streamly.Internal.Data.Unbox (Unbox(..)) + +import qualified Streamly.Internal.Data.Array.Type as Array +import qualified Streamly.Internal.Data.Array.Generic.Type as GArray +import qualified Streamly.Internal.Data.Parser as PR +import qualified Streamly.Internal.Data.Parser as PRD +import qualified Streamly.Internal.Data.ParserK.Type as ParserK +import qualified Streamly.Internal.Data.Stream.Type as Nesting +import qualified Streamly.Internal.Data.Stream.Type as Stream +import qualified Streamly.Internal.Data.Stream.Generate as StreamD +import qualified Streamly.Internal.Data.StreamK.Type as StreamK + +import Streamly.Internal.Data.Stream.Type hiding (splitAt) +import Prelude hiding (splitAt) + +-- GHC parser does not accept {-# ANN type [] NoSpecConstr #-}, so we need +-- to make a newtype. +{-# ANN type List NoSpecConstr #-} +newtype List a = List {getList :: [a]} + +-- The backracking buffer consists of arrays in the most-recent-first order. We +-- want to take a total of n array elements from this buffer. Note: when we +-- have to take an array partially, we must take the last part of the array. +{-# INLINE backtrack #-} +backtrack :: forall m a. Unbox a => + Int + -> [Array a] + -> StreamK m (Array a) + -> (StreamK m (Array a), [Array a]) +backtrack count buf inp + | count < 0 = seekOver count + -- XXX this is handled at the call site, so we can assert that here. + | count == 0 = (inp, buf) + | otherwise = go count buf inp + + where + + go n [] _ = seekUnder count n + go n (x:xs) stream = + let len = Array.length x + in if n > len + then go (n - len) xs (StreamK.cons x stream) + else if n == len + then (StreamK.cons x stream, xs) + else let !(Array contents start end) = x + !start1 = end - (n * SIZE_OF(a)) + arr1 = Array contents start1 end + arr2 = Array contents start start1 + in (StreamK.cons arr1 stream, arr2:xs) + + seekOver x = + error $ "Array.parseBreak: bug in parser, seeking [" + ++ show (negate x) + ++ "] elements in future" + + seekUnder x y = + error $ "Array.parseBreak: bug in parser, backtracking [" + ++ show x + ++ "] elements. Goes [" + ++ show y + ++ "] elements beyond backtrack buffer" + +{-# INLINE backtrackGeneric #-} +backtrackGeneric :: + Int + -> [GArray.Array a] + -> StreamK m (GArray.Array a) + -> (StreamK m (GArray.Array a), [GArray.Array a]) +backtrackGeneric count buf inp + | count < 0 = seekOver count + | count == 0 = (inp, buf) + | otherwise = go count buf inp + + where + + go n [] _ = seekUnder count n + go n (x:xs) stream = + let len = GArray.length x + in if n > len + then go (n - len) xs (StreamK.cons x stream) + else if n == len + then (StreamK.cons x stream, xs) + else let arr1 = GArray.unsafeSliceOffLen (len - n) n x + arr2 = GArray.unsafeSliceOffLen 0 (len - n) x + in (StreamK.cons arr1 stream, arr2:xs) + + seekOver x = + error $ "Array.Generic.parseBreak: bug in parser, seeking [" + ++ show (negate x) + ++ "] elements in future" + + seekUnder x y = + error $ "Array.Generic.parseBreak: bug in parser, backtracking [" + ++ show x + ++ "] elements. Goes [" + ++ show y + ++ "] elements beyond backtrack buffer" + +#include "ParserDrivers.h" +#define PARSER_WITH_POS +#include "ParserDrivers.h" diff --git a/src/Streamly/Internal/Data/ParserK.hs b/src/Streamly/Internal/Data/ParserK.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/ParserK.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.ParserK +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.ParserK + ( + module Streamly.Internal.Data.ParserK.Type + + -- * Deprecated + , adaptC + , adaptCG + ) +where + +import Streamly.Internal.Data.Parser (Parser) +import Streamly.Internal.Data.Array (Array) +import Streamly.Internal.Data.Unbox (Unbox) +import Streamly.Internal.Data.ParserK.Type + +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.Array.Generic as GenArray + +#include "inline.hs" + +{-# DEPRECATED adaptC "Use Streamly.Data.Array.toParserK" #-} +{-# INLINE_LATE adaptC #-} +adaptC :: (Monad m, Unbox a) => Parser a m b -> ParserK (Array a) m b +adaptC = Array.toParserK + +{-# DEPRECATED adaptCG "Use Streamly.Data.Array.Generic.toParserK" #-} +{-# INLINE_LATE adaptCG #-} +adaptCG :: + Monad m => Parser a m b -> ParserK (GenArray.Array a) m b +adaptCG = GenArray.toParserK diff --git a/src/Streamly/Internal/Data/ParserK/Type.hs b/src/Streamly/Internal/Data/ParserK/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/ParserK/Type.hs @@ -0,0 +1,629 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Parser.ParserK.Type +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- CPS style implementation of parsers. +-- +-- The CPS representation allows linear performance for Applicative, sequence, +-- Monad, Alternative, and choice operations compared to the quadratic +-- complexity of the corresponding direct style operations. However, direct +-- style operations allow fusion with ~10x better performance than CPS. +-- +-- The direct style representation does not allow for recursive definitions of +-- "some" and "many" whereas CPS allows that. +-- +module Streamly.Internal.Data.ParserK.Type + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Types + Step (..) + , Input (..) + , ParseResult (..) + , ParserK (..) + + -- * Adapting from Parser + , parserDone + , toParserK -- XXX move to StreamK module + , toParser -- XXX unParserK, unK, unPK + + -- * Basic Parsers + , fromPure + , fromEffect + , die + + -- * Expression Parsers + , chainl + , chainl1 + , chainr + , chainr1 + + -- * Deprecated + , adapt + ) +where + +#include "ArrayMacros.h" +#include "assert.hs" +#include "deprecation.h" +#include "inline.hs" + +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import Control.Applicative (Alternative(..)) +import Control.Monad (MonadPlus(..), ap) +import Control.Monad.IO.Class (MonadIO, liftIO) +-- import Control.Monad.Trans.Class (MonadTrans(lift)) +import GHC.Types (SPEC(..)) + +import qualified Control.Monad.Fail as Fail +import qualified Streamly.Internal.Data.Parser.Type as ParserD + +#include "DocTestDataParserK.hs" + +------------------------------------------------------------------------------- +-- Developer Notes +------------------------------------------------------------------------------- + +-- MonadReader cannot be implemented using continuations for ParserK +-- +-- "local" (and hence "MonadReader") cannot be implemented for ParserK because +-- there is no way to override all continuations. +-- +-- We can implement `MonadReader` for ParserK via ParserD: +-- +-- @ +-- instance (Show r, MonadReader r m) => MonadReader r (Parser a m) where +-- {-# INLINE ask #-} +-- ask = Parser.fromEffect ask +-- {-# INLINE local #-} +-- local f (Parser step initial extract) = +-- Parser +-- ((local f .) . step) +-- (local f initial) +-- (local f . extract) +-- +-- instance (Show r, MonadReader r m) => MonadReader r (ParserK a m) where +-- {-# INLINE ask #-} +-- ask = ParserK.fromEffect ask +-- {-# INLINE local #-} +-- local f parser = ParserK.adapt $ local f $ ParserK.toParser parser +-- @ + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- Note: We cannot use an Array directly as input because we need to identify +-- the end of input case using None. We cannot do that using nil Array as nil +-- Arrays can be encountered in normal input as well. +-- +-- We could specialize the ParserK type to use an Array directly, that provides +-- some performance improvement. The best advantage of that is when we consume +-- one element at a time from the array. If we really want that perf +-- improvement we can use a special ParserK type with the following Input. +-- +-- data Input a = None | Chunk {-# UNPACK #-} !(Array a) +-- +-- XXX Rename Chunk to Some. +data Input a = None | Chunk a + +-- Note: Step should ideally be called StepResult and StepParser should be just +-- Step, but then it will not be consistent with Parser/Stream. + +-- Using "Input" in runParser is not necessary but it avoids making +-- one more function call to get the input. This could be helpful +-- for cases where we process just one element per call. + +-- | A parsing function that parses a single input object. +type StepParser a m r = Input a -> m (Step a m r) + +-- | The intermediate result of running a parser step. The parser driver may +-- (1) stop with a final result ('Done') with no more inputs to be accepted, +-- (2) generate an intermediate result ('Partial') and accept more inputs, (3) +-- generate no result but wait for more input ('Continue'), (4) or fail with an +-- error ('Error'). +-- +-- The Int is a count by which the current stream position should be adjusted +-- before calling the next parsing step. +-- +-- See the documentation of 'Streamly.Data.Parser.Step' for more details, this +-- has the same semantics. +-- +-- /Pre-release/ +-- +data Step a m r = + Done !Int r + | Partial !Int (StepParser a m r) + | Continue !Int (StepParser a m r) + -- The Error constructor in ParserK Step carries a count, but the 'Parser' + -- Step does not carry a count - this is because in ParserK we can have + -- chunked drivers which can consume multiple inputs before returning a + -- result or error. In such cases, if an error occurs the parser has to + -- tell us the offset where the error occurred. In case of 'Parser' type we + -- do not have chunked drivers, we always drive it one element at a time, + -- therefore, the offset is not required on Error, the driver already knows + -- where we are. However, if we ever build a chunked driver for 'Parser' we + -- will need this argument in Parser Step as well. + | Error !Int String + +instance Functor m => Functor (Step a m) where + fmap f (Done n r) = Done n (f r) + fmap f (Partial n k) = Partial n (fmap (fmap f) . k) + fmap f (Continue n k) = Continue n (fmap (fmap f) . k) + fmap _ (Error n e) = Error n e + +-- Note: Passing position index separately instead of passing it with the +-- result causes huge regression in expression parsing becnhmarks. + +-- | The parser's result. +-- +-- Int is the position index in the stream relative to the position on entry +-- i.e. when the parser started running. When the parser enters the position +-- index is zero. If the parser consumed n elements then the new position index +-- would be n. If the parser is backtracking then the position index would be +-- negative. +-- +-- /Pre-release/ +-- +data ParseResult b = + Success !Int !b -- Position index, result + | Failure !Int !String -- Position index, error + +-- | Map a function over 'Success'. +instance Functor ParseResult where + fmap f (Success n b) = Success n (f b) + fmap _ (Failure n e) = Failure n e + +-- XXX Change the type to the shape (a -> m r -> m r) -> (m r -> m r) -> m r +-- +-- The parse continuation would be: Array a -> m (Step a m r) -> m (Step a m r) +-- The extract continuation would be: m (Step a m r) -> m (Step a m r) +-- +-- Use Step itself in place of ParseResult. + +-- | A continuation passing style parser representation. + +-- A parser is a continuation of 'Step's, each step passes a state and a parse +-- result to the next 'Step'. The resulting 'Step' may carry a continuation +-- that consumes input 'a' and results in another 'Step'. Essentially, the +-- continuation may either consume input without a result or return a result +-- with no further input to be consumed. +-- +-- The first argument of runParser is a continuation to be invoked after the +-- parser is done, it is of the following shape: +-- +-- >>> type Cont = ParseResult b -> Int -> StepParser a m r +-- +-- First argument of the continuation is the 'ParseResult'. The current stream +-- position is carried as part of the 'Success' or 'Failure' constructors of +-- 'ParseResult'. The second argument of the continuation is a count of the +-- elements used in the current alterantive in an alternative composition, if +-- the alternative fails we need to backtrack by this amount before invoking +-- the next alternative. +-- +-- The second argument of runParser is the incoming stream position adjustment. +-- The parser driver needs to adjust the current position of the stream by this +-- amount before consuming further input. A positive value means move forward +-- by that much in the stream and a negative value means backward. See the +-- 'Step' and 'Streamly.Data.Parser.Step' documentation for more details. +-- +-- The third argument is the incoming cumulative used element count for the +-- current alternative, same as described for the continuation above. +-- +newtype ParserK a m b = MkParser + { runParser :: forall r. + -- Do not eta reduce the applications of this continuation. + -- Continuation to be invoked after the parser is done + (ParseResult b -> Int -> StepParser a m r) + -- stream position adjustment before the parser starts. + -> Int + -- initial used count for the current alternative. + -> Int + -- final parse result, when the last continuation is done. + -> StepParser a m r + } + +------------------------------------------------------------------------------- +-- Functor +------------------------------------------------------------------------------- + +-- XXX rewrite this using ParserD, expose rmapM from ParserD. + +-- | Map a function on the result i.e. on @b@ in @Parser a m b@. +instance Functor m => Functor (ParserK a m) where + {-# INLINE fmap #-} + fmap f parser = MkParser $ \k pos used inp -> + let k1 res = k (fmap f res) + in runParser parser k1 pos used inp + +------------------------------------------------------------------------------- +-- Sequential applicative +------------------------------------------------------------------------------- + +-- This is the dual of stream "fromPure". + +-- | A parser that always yields a pure value without consuming any input. +-- +-- /Pre-release/ +-- +{-# INLINE fromPure #-} +fromPure :: b -> ParserK a m b +fromPure b = MkParser $ \k pos used inp -> k (Success pos b) used inp + +-- | See 'Streamly.Internal.Data.Parser.fromEffect'. +-- +-- /Pre-release/ +-- +{-# INLINE fromEffect #-} +fromEffect :: Monad m => m b -> ParserK a m b +fromEffect eff = + MkParser $ \k pos used inp -> eff >>= \b -> k (Success pos b) used inp + +-- | @f \<$> p1 \<*> p2@ applies parsers p1 and p2 sequentially to an input +-- stream. The first parser runs and processes the input, the remaining input +-- is then passed to the second parser. If both parsers succeed, their outputs +-- are applied to the function @f@. If either parser fails, the operation +-- fails. +-- +instance Monad m => Applicative (ParserK a m) where + {-# INLINE pure #-} + pure = fromPure + + {-# INLINE (<*>) #-} + (<*>) = ap + + {-# INLINE (*>) #-} + p1 *> p2 = MkParser $ \k pos used input -> + let k1 (Success pos1 _) u inp = runParser p2 k pos1 u inp + k1 (Failure pos1 e) u inp = k (Failure pos1 e) u inp + in runParser p1 k1 pos used input + + {-# INLINE (<*) #-} + p1 <* p2 = MkParser $ \k pos used input -> + let k1 (Success pos1 b) u1 inp = + let k2 (Success pos2 _) u2 inp2 = k (Success pos2 b) u2 inp2 + k2 (Failure pos2 e) u2 inp2 = k (Failure pos2 e) u2 inp2 + in runParser p2 k2 pos1 u1 inp + k1 (Failure pos1 e) u1 inp = k (Failure pos1 e) u1 inp + in runParser p1 k1 pos used input + + {-# INLINE liftA2 #-} + liftA2 f p = (<*>) (fmap f p) + +------------------------------------------------------------------------------- +-- Monad +------------------------------------------------------------------------------- + +-- This is the dual of "nil". +-- +-- | A parser that always fails with an error message without consuming +-- any input. +-- +-- /Pre-release/ +-- +{-# INLINE die #-} +die :: String -> ParserK a m b +die err = MkParser (\k pos used inp -> k (Failure pos err) used inp) + +-- | Monad composition can be used for lookbehind parsers, we can dynamically +-- compose new parsers based on the results of the previously parsed values. +instance Monad m => Monad (ParserK a m) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + p >>= f = MkParser $ \k pos used input -> + let k1 (Success pos1 b) u1 inp = runParser (f b) k pos1 u1 inp + k1 (Failure pos1 e) u1 inp = k (Failure pos1 e) u1 inp + in runParser p k1 pos used input + + {-# INLINE (>>) #-} + (>>) = (*>) + +#if !(MIN_VERSION_base(4,13,0)) + -- This is redefined instead of just being Fail.fail to be + -- compatible with base 4.8. + {-# INLINE fail #-} + fail = die +#endif +instance Monad m => Fail.MonadFail (ParserK a m) where + {-# INLINE fail #-} + fail = die + +instance MonadIO m => MonadIO (ParserK a m) where + {-# INLINE liftIO #-} + liftIO = fromEffect . liftIO + +------------------------------------------------------------------------------- +-- Alternative +------------------------------------------------------------------------------- + +-- | @p1 \<|> p2@ passes the input to parser p1, if it succeeds, the result is +-- returned. However, if p1 fails, the parser driver backtracks and tries the +-- same input on the alternative parser p2, returning the result if it +-- succeeds. +-- +instance Monad m => Alternative (ParserK a m) where + {-# INLINE empty #-} + empty = die "empty" + + {-# INLINE (<|>) #-} + p1 <|> p2 = MkParser $ \k pos _ input -> + let + k1 (Failure pos1 _) used inp = runParser p2 k (pos1 - used) 0 inp + k1 success _ inp = k success 0 inp + in runParser p1 k1 pos 0 input + + -- some and many are implemented here instead of using default definitions + -- so that we can use INLINE on them. It gives 50% performance improvement. + + {-# INLINE many #-} + many v = many_v + + where + + many_v = some_v <|> pure [] + some_v = (:) <$> v <*> many_v + + {-# INLINE some #-} + some v = some_v + + where + + many_v = some_v <|> pure [] + some_v = (:) <$> v <*> many_v + +-- | 'mzero' is same as 'empty', it aborts the parser. 'mplus' is same as +-- '<|>', it selects the first succeeding parser. +-- +instance Monad m => MonadPlus (ParserK a m) where + {-# INLINE mzero #-} + mzero = die "mzero" + + {-# INLINE mplus #-} + mplus = (<|>) + +{- +instance MonadTrans (ParserK a) where + {-# INLINE lift #-} + lift = fromEffect +-} + +-------------------------------------------------------------------------------- +-- Make a ParserK from Parser +-------------------------------------------------------------------------------- + +{-# INLINE adaptWith #-} +adaptWith + :: forall m a s b r. (Monad m) + => (s -> a -> m (ParserD.Step s b)) + -> m (ParserD.Initial s b) + -> (s -> m (ParserD.Final s b)) + -> (ParseResult b -> Int -> Input a -> m (Step a m r)) + -> Int + -> Int + -> Input a + -> m (Step a m r) +adaptWith pstep initial extract cont !relPos !usedCount !input = do + res <- initial + case res of + ParserD.IPartial pst -> do + if relPos == 0 + then + case input of + -- In element parser case chunk is just one element + Chunk element -> parseContChunk usedCount pst element + None -> parseContNothing usedCount pst + -- XXX Previous code was using Continue in this case + else + -- We consumed previous input, need to fetch the next + -- input from the driver. + pure $ Partial relPos (parseCont usedCount pst) + ParserD.IDone b -> cont (Success relPos b) usedCount input + ParserD.IError err -> cont (Failure relPos err) usedCount input + + where + + {-# NOINLINE parseContChunk #-} + parseContChunk !count !state x = do + go SPEC state + + where + + go !_ !pst = do + r <- pstep pst x + case r of + -- Done, call the next continuation + ParserD.SDone 1 b -> + cont (Success 1 b) (count + 1) (Chunk x) + ParserD.SDone 0 b -> + cont (Success 0 b) count (Chunk x) + ParserD.SDone m b -> -- n > 1 + let n = 1 - m + in cont (Success (1 - n) b) (count + 1 - n) (Chunk x) + + -- Not done yet, return the parseCont continuation + ParserD.SPartial 1 pst1 -> + pure $ Partial 1 (parseCont (count + 1) pst1) + ParserD.SPartial 0 pst1 -> + -- XXX if we recurse we are not dropping backtrack buffer + -- on partial. + -- XXX recurse or call the driver? + go SPEC pst1 + ParserD.SPartial m pst1 -> -- n > 0 + let n = 1 - m + in pure $ Partial (1 - n) (parseCont (count + 1 - n) pst1) + ParserD.SContinue 1 pst1 -> + pure $ Continue 1 (parseCont (count + 1) pst1) + ParserD.SContinue 0 pst1 -> + -- XXX recurse or call the driver? + go SPEC pst1 + ParserD.SContinue m pst1 -> -- n > 0 + let n = 1 - m + in pure $ Continue (1 - n) (parseCont (count + 1 - n) pst1) + + -- SError case + ParserD.SError err -> + cont (Failure 0 err) count (Chunk x) + + {-# NOINLINE parseContNothing #-} + parseContNothing !count !pst = do + r <- extract pst + case r of + ParserD.FDone n b -> + assert (n <= 0) + (cont (Success n b) (count + n) None) + ParserD.FContinue n pst1 -> + assert (n <= 0) + (return $ Continue n (parseCont (count + n) pst1)) + ParserD.FError err -> + -- XXX It is called only when there is no input chunk. So using + -- 0 as the position is correct? + cont (Failure 0 err) count None + + -- XXX Maybe we can use two separate continuations instead of using + -- Just/Nothing cases here. That may help in avoiding the parseContJust + -- function call. + {-# INLINE parseCont #-} + parseCont !cnt !pst (Chunk element) = parseContChunk cnt pst element + parseCont !cnt !pst None = parseContNothing cnt pst + +-- | Convert a 'Parser' to 'ParserK'. +-- +-- /Pre-release/ +-- +{-# INLINE_LATE toParserK #-} +toParserK, adapt :: Monad m => ParserD.Parser a m b -> ParserK a m b +toParserK (ParserD.Parser step initial extract) = + MkParser $ adaptWith step initial extract + +RENAME(adapt,toParserK) + +------------------------------------------------------------------------------- +-- Convert CPS style 'Parser' to direct style 'D.Parser' +------------------------------------------------------------------------------- + +-- | A continuation to extract the result when a CPS parser is done. +{-# INLINE parserDone #-} +parserDone :: Applicative m => + ParseResult b -> Int -> Input a -> m (Step a m b) +parserDone (Success n b) _ _ = + -- trace ("parserDone Success n: " ++ show n) $ + assert(n <= 1) `seq` pure (Done n b) +parserDone (Failure n e) _ _ = + -- trace ("parserDone Failure n: " ++ show n) $ + assert(n <= 1) `seq` pure (Error n e) + +-- XXX Note that this works only for single element parsers and not for Array +-- input parsers. The asserts will fail for array parsers. +-- XXX We should move this to StreamK module along with toParserK + +-- | Convert a CPS style 'ParserK' to a direct style 'Parser'. +-- +-- /Pre-release/ +-- +{-# INLINE_LATE toParser #-} +toParser :: Monad m => ParserK a m b -> ParserD.Parser a m b +toParser parser = ParserD.Parser step initial extract + + where + + initial = pure (ParserD.IPartial (runParser parser parserDone 0 0)) + + step cont a = do + r <- cont (Chunk a) + return $ case r of + Done n b -> assert (n <= 1) (ParserD.SDone n b) + Error _ e -> ParserD.SError e + Partial n cont1 -> assert (n <= 1) (ParserD.SPartial n cont1) + Continue n cont1 -> assert (n <= 1) (ParserD.SContinue n cont1) + + extract cont = do + r <- cont None + case r of + Done n b -> assert (n <= 0) (return $ ParserD.FDone n b) + Error _ e -> return $ ParserD.FError e + Partial _ cont1 -> extract cont1 + Continue n cont1 -> + assert (n <= 0) (return $ ParserD.FContinue n cont1) + +{-# RULES "toParserK/toParser fusion" [2] + forall s. toParser (toParserK s) = s #-} +{-# RULES "toParser/toParserK fusion" [2] + forall s. toParserK (toParser s) = s #-} + +-- | @chainl1 p op x@ parses /one/ or more occurrences of @p@, separated by +-- @op@. Returns a value obtained by a /left/ associative application of all +-- functions returned by @op@ to the values returned by @p@. +-- +-- >>> num = Parser.decimal +-- >>> plus = Parser.char '+' *> pure (+) +-- >>> expr = ParserK.chainl1 (StreamK.toParserK num) (StreamK.toParserK plus) +-- >>> StreamK.parse expr $ StreamK.fromStream $ Stream.fromList "1+2+3" +-- Right 6 +-- +-- If you're building full expression parsers with operator precedence and +-- associativity, consider using @makeExprParser@ from the @parser-combinators@ +-- package. +-- +-- See also 'Streamly.Internal.Data.Parser.deintercalate'. +-- +{-# INLINE chainl1 #-} +chainl1 :: ParserK b IO a -> ParserK b IO (a -> a -> a) -> ParserK b IO a +chainl1 p op = p >>= go + + where + + go l = step l <|> pure l + + step l = do + f <- op + r <- p + go (f l r) + +-- | @chainl p op x@ is like 'chainl1' but allows /zero/ or more occurrences of +-- @p@, separated by @op@. If there are zero occurrences of @p@, the value @x@ +-- is returned. +{-# INLINE chainl #-} +chainl :: ParserK b IO a -> ParserK b IO (a -> a -> a) -> a -> ParserK b IO a +chainl p op x = chainl1 p op <|> pure x + +-- | Like chainl1 but parses right associative application of the operator +-- instead of left associative. +-- +-- >>> num = Parser.decimal +-- >>> pow = Parser.char '^' *> pure (^) +-- >>> expr = ParserK.chainr1 (StreamK.toParserK num) (StreamK.toParserK pow) +-- >>> StreamK.parse expr $ StreamK.fromStream $ Stream.fromList "2^3^2" +-- Right 512 +-- +{-# INLINE chainr1 #-} +chainr1 :: ParserK b IO a -> ParserK b IO (a -> a -> a) -> ParserK b IO a +chainr1 p op = p >>= go + + where + + go l = step l <|> pure l + + step l = do + f <- op + r <- chainr1 p op + return (f l r) + +-- | @chainr p op x@ is like 'chainr1' but allows /zero/ or more occurrences of +-- @p@, separated by @op@. If there are zero occurrences of @p@, the value @x@ +-- is returned. +{-# INLINE chainr #-} +chainr :: ParserK b IO a -> ParserK b IO (a -> a -> a) -> a -> ParserK b IO a +chainr p op x = chainr1 p op <|> pure x diff --git a/src/Streamly/Internal/Data/Path.hs b/src/Streamly/Internal/Data/Path.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Path.hs @@ -0,0 +1,58 @@ +-- | +-- Module : Streamly.Internal.Data.Path +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +module Streamly.Internal.Data.Path + ( + -- * Exceptions + PathException (..) + + -- * Conversions + , IsPath (..) + ) +where + +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow(..)) + +------------------------------------------------------------------------------ +-- Exceptions +------------------------------------------------------------------------------ + +-- | Exceptions thrown by path operations. +newtype PathException = + InvalidPath String + deriving (Show, Eq) + +instance Exception PathException + +------------------------------------------------------------------------------ +-- Conversions +------------------------------------------------------------------------------ + +-- XXX Swap the order of IsPath arguments? +-- XXX rename to fromBase, fromBasePath, fromOsPath? + +-- | If the type @a b@ is a member of 'IsPath' it means we know how to convert +-- the type @b@ to and from the base type @a@. +-- +class IsPath a b where + -- | Like 'fromPath' but does not check the properties of 'Path'. The user + -- is responsible to maintain the invariants enforced by the type @b@ + -- otherwise surprising behavior may result. + -- + -- This operation provides performance and simplicity when we know that the + -- properties of the path are already verified, for example, when we get + -- the path from the file system or from the OS APIs. + unsafeFromPath :: a -> b + + -- | Convert a base path type to other forms of well-typed paths. It may + -- fail if the path does not satisfy the properties of the target type. + -- + fromPath :: MonadThrow m => a -> m b + + -- | Convert a well-typed path to the base path type. Never fails. + toPath :: b -> a diff --git a/src/Streamly/Internal/Data/Pipe.hs b/src/Streamly/Internal/Data/Pipe.hs --- a/src/Streamly/Internal/Data/Pipe.hs +++ b/src/Streamly/Internal/Data/Pipe.hs @@ -6,271 +6,34 @@ -- Stability : experimental -- Portability : GHC -- --- There are three fundamental types in streamly. They are streams --- ("Streamly.Data.Stream"), pipes ("Streamly.Internal.Data.Pipe") and folds ("Streamly.Data.Fold"). +-- There are three fundamental types that make up a stream pipeline: +-- +-- * Stream: sources +-- * Scan: transformations +-- * Fold: sinks +-- -- Streams are sources or producers of values, multiple sources can be merged -- into a single source but a source cannot be split into multiple stream -- sources. Folds are sinks or consumers, a stream can be split and -- distributed to multiple folds but the results cannot be merged back into a --- stream source again. Pipes are transformations, a stream source can be split --- and distributed to multiple pipes each pipe can apply its own transform on --- the stream and the results can be merged back into a single pipe. Pipes can --- be attached to a source to produce a source or they can be attached to a --- fold to produce a fold, or multiple pipes can be merged or zipped into a --- single pipe. +-- stream source again. Scans are simple one-to-one transformations with +-- filtering. One element cannot be transformed to multiple elements. -- +-- The Pipe type is a super type of all the above, it is the most complex type. +-- All of these can be represented by a pipe. A pipe can act as a source or a +-- sink or a transformation, dynamically. A stream source can be split and +-- distributed to multiple pipes each pipe can apply its own transform on the +-- stream and the results can be merged back into a single pipe. Pipes can be +-- attached to a source to produce a source or they can be attached to a fold +-- to produce a fold, or multiple pipes can be merged or zipped into a single +-- pipe. +-- -- > import qualified Streamly.Internal.Data.Pipe as Pipe module Streamly.Internal.Data.Pipe ( - -- * Pipe Type - Pipe - - -- * Pipes - -- ** Mapping - , map - , mapM - - {- - -- ** Filtering - , lfilter - , lfilterM - -- , ldeleteBy - -- , luniq - - {- - -- ** Mapping Filters - , lmapMaybe - , lmapMaybeM - - -- ** Scanning Filters - , lfindIndices - , lelemIndices - - -- ** Insertion - -- | Insertion adds more elements to the stream. - - , linsertBy - , lintersperseM - - -- ** Reordering - , lreverse - -} - - -- * Parsing - -- ** Trimming - , ltake - -- , lrunFor -- time - , ltakeWhile - {- - , ltakeWhileM - , ldrop - , ldropWhile - , ldropWhileM - -} - - -- ** Splitting - -- | Streams can be split into segments in space or in time. We use the - -- term @chunk@ to refer to a spatial length of the stream (spatial window) - -- and the term @session@ to refer to a length in time (time window). - - -- In imperative terms, grouped folding can be considered as a nested loop - -- where we loop over the stream to group elements and then loop over - -- individual groups to fold them to a single value that is yielded in the - -- output stream. - - -- *** By Chunks - , chunksOf - , sessionsOf - - -- *** By Elements - , splitBy - , splitSuffixBy - , splitSuffixBy' - -- , splitPrefixBy - , wordsBy - - -- *** By Sequences - , splitOn - , splitSuffixOn - -- , splitPrefixOn - -- , wordsOn - - -- Keeping the delimiters - , splitOn' - , splitSuffixOn' - -- , splitPrefixOn' - - -- Splitting by multiple sequences - -- , splitOnAny - -- , splitSuffixOnAny - -- , splitPrefixOnAny - - -- ** Grouping - , groups - , groupsBy - , groupsRollingBy - -} - - -- * Composing Pipes - , tee - , zipWith - , compose - - {- - -- * Distributing - -- | - -- The 'Applicative' instance of a distributing 'Fold' distributes one copy - -- of the stream to each fold and combines the results using a function. - -- - -- @ - -- - -- |-------Fold m a b--------| - -- ---stream m a---| |---m (b,c,...) - -- |-------Fold m a c--------| - -- | | - -- ... - -- @ - -- - -- To compute the average of numbers in a stream without going through the - -- stream twice: - -- - -- >>> let avg = (/) <$> FL.sum <*> fmap fromIntegral FL.length - -- >>> FL.foldl' avg (S.enumerateFromTo 1.0 100.0) - -- 50.5 - -- - -- The 'Semigroup' and 'Monoid' instances of a distributing fold distribute - -- the input to both the folds and combines the outputs using Monoid or - -- Semigroup instances of the output types: - -- - -- >>> import Data.Monoid (Sum) - -- >>> FL.foldl' (FL.head <> FL.last) (fmap Sum $ S.enumerateFromTo 1.0 100.0) - -- Just (Sum {getSum = 101.0}) - -- - -- The 'Num', 'Floating', and 'Fractional' instances work in the same way. - - , tee - , distribute - - -- * Partitioning - -- | - -- Direct items in the input stream to different folds using a function to - -- select the fold. This is useful to demultiplex the input stream. - -- , partitionByM - -- , partitionBy - , partition - - -- * Demultiplexing - , demux - -- , demuxWith - , demux_ - -- , demuxWith_ - - -- * Classifying - , classify - -- , classifyWith - - -- * Unzipping - , unzip - -- These can be expressed using lmap/lmapM and unzip - -- , unzipWith - -- , unzipWithM - - -- * Nested Folds - -- , concatMap - -- , chunksOf - , duplicate -- experimental - - -- * Windowed Classification - -- | Split the stream into windows or chunks in space or time. Each window - -- can be associated with a key, all events associated with a particular - -- key in the window can be folded to a single result. The stream is split - -- into windows of specified size, the window can be terminated early if - -- the closing flag is specified in the input stream. - -- - -- The term "chunk" is used for a space window and the term "session" is - -- used for a time window. - - -- ** Tumbling Windows - -- | A new window starts after the previous window is finished. - -- , classifyChunksOf - , classifySessionsOf - - -- ** Keep Alive Windows - -- | The window size is extended if an event arrives within the specified - -- window size. This can represent sessions with idle or inactive timeout. - -- , classifyKeepAliveChunks - , classifyKeepAliveSessions - - {- - -- ** Sliding Windows - -- | A new window starts after the specified slide from the previous - -- window. Therefore windows can overlap. - , classifySlidingChunks - , classifySlidingSessions - -} - -- ** Sliding Window Buffers - -- , slidingChunkBuffer - -- , slidingSessionBuffer --} + module Streamly.Internal.Data.Pipe.Type ) where --- import Control.Concurrent (threadDelay, forkIO, killThread) --- import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar) --- import Control.Exception (SomeException(..), catch, mask) --- import Control.Monad (void) --- import Control.Monad.Catch (throwM) --- import Control.Monad.IO.Class (MonadIO(..)) --- import Control.Monad.Trans (lift) --- import Control.Monad.Trans.Control (control) --- import Data.Functor.Identity (Identity) --- import Data.Heap (Entry(..)) --- import Data.Map.Strict (Map) --- import Data.Maybe (fromJust, isJust, isNothing) - --- import Foreign.Storable (Storable(..)) -import Prelude - hiding (id, filter, drop, dropWhile, take, takeWhile, zipWith, foldr, - foldl, map, mapM_, sequence, all, any, sum, product, elem, - notElem, maximum, minimum, head, last, tail, length, null, - reverse, iterate, init, and, or, lookup, foldr1, (!!), - scanl, scanl1, replicate, concatMap, mconcat, foldMap, unzip, - span, splitAt, break, mapM) - --- import qualified Data.Heap as H --- import qualified Data.Map.Strict as Map --- import qualified Prelude - --- import Streamly.Data.Fold.Types (Fold(..)) import Streamly.Internal.Data.Pipe.Type - (Pipe(..), PipeState(..), Step(..), zipWith, tee, map, compose) --- import Streamly.Internal.Data.Array.Type (Array) --- import Streamly.Internal.Data.Ring.Unboxed (Ring) --- import Streamly.Internal.Data.Stream (Stream) --- import Streamly.Internal.Data.Time.Units --- (AbsTime, MilliSecond64(..), addToAbsTime, diffAbsTime, toRelTime, --- toAbsTime) - --- import Streamly.Internal.Data.Strict - --- import qualified Streamly.Internal.Data.Array.Type as A --- import qualified Streamly.Data.Stream as S --- import qualified Streamly.Internal.Data.Stream.StreamD as D --- import qualified Streamly.Internal.Data.Stream.StreamK as K --- import qualified Streamly.Internal.Data.Stream.Common as P - ------------------------------------------------------------------------------- --- Pipes ------------------------------------------------------------------------------- - --- | Lift a monadic function to a 'Pipe'. --- --- @since 0.7.0 -{-# INLINE mapM #-} -mapM :: Monad m => (a -> m b) -> Pipe m a b -mapM f = Pipe consume undefined () - where - consume _ a = do - r <- f a - return $ Yield r (Consume ()) diff --git a/src/Streamly/Internal/Data/Pipe/Type.hs b/src/Streamly/Internal/Data/Pipe/Type.hs --- a/src/Streamly/Internal/Data/Pipe/Type.hs +++ b/src/Streamly/Internal/Data/Pipe/Type.hs @@ -1,5 +1,3 @@ -#include "inline.hs" - -- | -- Module : Streamly.Internal.Data.Pipe.Type -- Copyright : (c) 2019 Composewell Technologies @@ -9,99 +7,413 @@ -- Portability : GHC module Streamly.Internal.Data.Pipe.Type - ( Step (..) + ( + -- * Type + Step (..) , Pipe (..) - , PipeState (..) - , zipWith - , tee - , map + + -- * From folds + , fromStream + , fromScanr + , fromFold + , scanFold + + -- * Primitive Pipes + , identity + , map -- function? + , mapM -- functionM? + , filter + , filterM + + -- * Combinators , compose + , teeMerge + -- , zipWith -- teeZip ) where -import Control.Arrow (Arrow(..)) +#include "inline.hs" +-- import Control.Arrow (Arrow(..)) import Control.Category (Category(..)) -import Data.Maybe (isJust) -import Prelude hiding (zipWith, map, id, unzip, null) -import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..)) +import Data.Functor ((<&>)) +#if __GLASGOW_HASKELL__ >= 810 +import Data.Kind (Type) +#endif +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Scanr (Scanr(..)) +import Streamly.Internal.Data.Stream.Type (Stream(..)) +-- import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..)) +import Streamly.Internal.Data.SVar.Type (defState) import qualified Prelude +import qualified Streamly.Internal.Data.Fold.Type as Fold +import qualified Streamly.Internal.Data.Stream.Type as Stream +import Prelude hiding (filter, zipWith, map, mapM, id, unzip, null) + +-- $setup +-- >>> :m +-- >>> :set -XFlexibleContexts +-- >>> import Control.Category +-- +-- >>> import qualified Streamly.Internal.Data.Fold as Fold +-- >>> import qualified Streamly.Internal.Data.Pipe as Pipe +-- >>> import qualified Streamly.Internal.Data.Stream as Stream + ------------------------------------------------------------------------------ -- Pipes ------------------------------------------------------------------------------ --- A scan is a much simpler version of pipes. A scan always produces an output --- on an input whereas a pipe does not necessarily produce an output on an --- input, it might consume multiple inputs before producing an output. That way --- it can implement filtering. Similarly, it can produce more than one output --- on an single input. +-- XXX If we do not want to change Streams, we should use "Yield b s" instead +-- of "Yield s b". Though "Yield s b" is sometimes better when using curried +-- "Yield s". "Yield b" sounds better because the verb applies to "b". -- --- Therefore when two pipes are composed in parallel formation, one may run --- slower or faster than the other. If all of them are being fed from the same --- source, we may have to buffer the input to match the speeds. In case of --- scans we do not have that problem. +-- Note: We could reduce the number of constructors by using Consume | Produce +-- wrapper around the state. But when fusion does not occur, it may be better +-- to use a flat structure rather than nested to avoid more allocations. In a +-- flat structure the pointer tag from the Step constructor itself can identiy +-- any of the 5 constructors. -- --- We may also need a "Stop" constructor to indicate that we are not generating --- any more values and we can have a "Done" constructor to indicate that we are --- not consuming any more values. Similarly we can have a stop with error or --- exception and a done with error or leftover values. +{-# ANN type Step Fuse #-} +data Step cs ps b = + YieldC cs b -- ^ Yield and consume + | SkipC cs -- ^ Skip and consume + | Stop -- ^ when consuming, Stop means input remains unused + -- Therefore, Stop should not be used when we are processing an input, + -- instead use YieldP and then Stop. + | YieldP ps b -- ^ Yield and produce + | SkipP ps -- ^ Skip and produce + +instance Functor (Step cs ps) where + {-# INLINE fmap #-} + fmap f (YieldC s b) = YieldC s (f b) + fmap f (YieldP s b) = YieldP s (f b) + fmap _ (SkipC s) = SkipC s + fmap _ (SkipP s) = SkipP s + fmap _ Stop = Stop + +-- A pipe uses a consume function and a produce function. It can dynamically +-- switch from consume/fold mode to a produce/source mode. -- --- In generator mode, Continue means no output/continue. In fold mode Continue means --- need more input to produce result. we can perhaps call it Continue instead. +-- We can upgrade a stream, fold or scan into a pipe. However, the simpler +-- types should be preferred because they can be more efficient and fuse +-- better. -- -data Step s a = - Yield a s - | Continue s +-- The design of the Pipe type is such that the pipe decides whether it wants +-- to consume or produce, not the driver. The driver has to do what the pipe +-- dictates, if it can. The starting state of the pipe could either be +-- consuming or producing. Current implementation starts with a consuming +-- state. If the default state of the pipe is consumption state and there is no +-- input, the driver can call finalC :: cs -> m (Step cs ps b) to switch the +-- pipe to production state. The pipe can use SkipP to switch to production +-- state. If the default state of the pipe is producing state, the pipe can use +-- SkipC to switch to the consumer state. The driver can use finalP to switch +-- to consuming state. -- | Represents a stateful transformation over an input stream of values of -- type @a@ to outputs of type @b@ in 'Monad' @m@. +-- +-- The constructor is @Pipe consume produce initial@. +data Pipe m a b = + forall cs ps. Pipe + (cs -> a -> m (Step cs ps b)) + (ps -> m (Step cs ps b)) + -- (cs -> m (Step cs ps b)) -- finalC + -- (ps -> m (Step cs ps b)) -- finalP + cs -- Either cs ps --- A pipe uses a consume function and a produce function. It can switch from --- consume/fold mode to a produce/source mode. The first step function is a --- fold function while the seocnd one is a stream generator function. +------------------------------------------------------------------------------ +-- Functor: Mapping on the output +------------------------------------------------------------------------------ + +-- | 'fmap' maps a pure function on a scan output. -- --- We can upgrade a stream or a fold into a pipe. However, streams are more --- efficient in generation and folds are more efficient in consumption. +-- >>> Stream.toList $ Stream.pipe (fmap (+1) Pipe.identity) $ Stream.fromList [1..5::Int] +-- [2,3,4,5,6] -- --- For pure transformation we can have a 'Scan' type. A Scan would be more --- efficient in zipping whereas pipes are useful for merging and zipping where --- we know buffering can occur. A Scan type can be upgraded to a pipe. +instance Functor m => Functor (Pipe m a) where + {-# INLINE_NORMAL fmap #-} + fmap f (Pipe consume produce cinitial) = + Pipe consume1 produce1 cinitial + + where + + {-# INLINE_LATE consume1 #-} + consume1 s b = fmap (fmap f) (consume s b) + {-# INLINE_LATE produce1 #-} + produce1 s = fmap (fmap f) (produce s) + +------------------------------------------------------------------------------- +-- Category +------------------------------------------------------------------------------- + +{-# ANN type ComposeConsume Fuse #-} +#if __GLASGOW_HASKELL__ >= 810 +type ComposeConsume :: Type -> Type -> Type -> Type +#endif +data ComposeConsume csL psL csR = + ComposeConsume csL csR + +{-# ANN type ComposeProduce Fuse #-} +data ComposeProduce csL psL csR psR = + ComposeProduceR csL psR + | ComposeProduceL psL csR + | ComposeProduceLR psL psR + +-- | Series composition. Compose two pipes such that the output of the second +-- pipe is attached to the input of the first pipe. -- --- XXX In general the starting state could either be for generation or for --- consumption. Currently we are only starting with a consumption state. +-- >>> Stream.toList $ Stream.pipe (Pipe.map (+1) >>> Pipe.map (+1)) $ Stream.fromList [1..5::Int] +-- [3,4,5,6,7] -- --- An explicit either type for better readability of the code -data PipeState s1 s2 = Consume s1 | Produce s2 +{-# INLINE_NORMAL compose #-} +compose :: Monad m => Pipe m b c -> Pipe m a b -> Pipe m a c +compose + (Pipe consumeR produceR initialR) + (Pipe consumeL produceL initialL) = + Pipe consume produce (ComposeConsume initialL initialR) -isProduce :: PipeState s1 s2 -> Bool -isProduce s = - case s of - Produce _ -> True - Consume _ -> False + where -data Pipe m a b = - forall s1 s2. Pipe (s1 -> a -> m (Step (PipeState s1 s2) b)) - (s2 -> m (Step (PipeState s1 s2) b)) s1 + {-# INLINE consumeLFeedR #-} + consumeLFeedR csL csR bL = do + rR <- consumeR csR bL + return + $ case rR of + YieldC csR1 br -> YieldC (ComposeConsume csL csR1) br + SkipC csR1 -> SkipC (ComposeConsume csL csR1) + Stop -> Stop + YieldP psR br -> YieldP (ComposeProduceR csL psR) br + SkipP psR -> SkipP (ComposeProduceR csL psR) -instance Monad m => Functor (Pipe m a) where - {-# INLINE_NORMAL fmap #-} - fmap f (Pipe consume produce initial) = Pipe consume' produce' initial - where - {-# INLINE_LATE consume' #-} - consume' st a = do - r <- consume st a - return $ case r of - Yield x s -> Yield (f x) s - Continue s -> Continue s + {-# INLINE produceLFeedR #-} + produceLFeedR psL csR bL = do + rR <- consumeR csR bL + return + $ case rR of + YieldC csR1 br -> YieldP (ComposeProduceL psL csR1) br + SkipC csR1 -> SkipP (ComposeProduceL psL csR1) + Stop -> Stop + YieldP psR br -> YieldP (ComposeProduceLR psL psR) br + SkipP psR -> SkipP (ComposeProduceLR psL psR) - {-# INLINE_LATE produce' #-} - produce' st = do - r <- produce st - return $ case r of - Yield x s -> Yield (f x) s - Continue s -> Continue s + consume (ComposeConsume csL csR) x = do + rL <- consumeL csL x + case rL of + YieldC csL1 bL -> + -- XXX Use SkipC instead? Flat may be better for fusion. + consumeLFeedR csL1 csR bL + SkipC csL1 -> return $ SkipC (ComposeConsume csL1 csR) + Stop -> return Stop + YieldP psL bL -> + -- XXX Use SkipC instead? + produceLFeedR psL csR bL + SkipP psL -> return $ SkipP (ComposeProduceL psL csR) + produce (ComposeProduceL psL csR) = do + rL <- produceL psL + case rL of + YieldC csL bL -> + -- XXX Use SkipC instead? + consumeLFeedR csL csR bL + SkipC csL -> return $ SkipC (ComposeConsume csL csR) + Stop -> return Stop + YieldP psL1 bL -> + -- XXX Use SkipC instead? + produceLFeedR psL1 csR bL + SkipP psL1 -> return $ SkipP (ComposeProduceL psL1 csR) + + produce (ComposeProduceR csL psR) = do + rR <- produceR psR + return + $ case rR of + YieldC csR1 br -> YieldC (ComposeConsume csL csR1) br + SkipC csR1 -> SkipC (ComposeConsume csL csR1) + Stop -> Stop + YieldP psR1 br -> YieldP (ComposeProduceR csL psR1) br + SkipP psR1 -> SkipP (ComposeProduceR csL psR1) + + produce (ComposeProduceLR psL psR) = do + rR <- produceR psR + return + $ case rR of + YieldC csR1 br -> YieldP (ComposeProduceL psL csR1) br + SkipC csR1 -> SkipP (ComposeProduceL psL csR1) + Stop -> Stop + YieldP psR1 br -> YieldP (ComposeProduceLR psL psR1) br + SkipP psR1 -> SkipP (ComposeProduceLR psL psR1) + +-- | A pipe representing mapping of a monadic action. +-- +-- >>> Stream.toList $ Stream.pipe (Pipe.mapM print) $ Stream.fromList [1..5::Int] +-- 1 +-- 2 +-- 3 +-- 4 +-- 5 +-- [(),(),(),(),()] +-- +{-# INLINE mapM #-} +mapM :: Monad m => (a -> m b) -> Pipe m a b +mapM f = Pipe (\() a -> f a <&> YieldC ()) undefined () + +-- | A pipe representing mapping of a pure function. +-- +-- >>> Stream.toList $ Stream.pipe (Pipe.map (+1)) $ Stream.fromList [1..5::Int] +-- [2,3,4,5,6] +-- +{-# INLINE map #-} +map :: Monad m => (a -> b) -> Pipe m a b +map f = mapM (return Prelude.. f) + +{- HLINT ignore "Redundant map" -} + +-- | An identity pipe producing the same output as input. +-- +-- >>> identity = Pipe.map Prelude.id +-- +-- >>> Stream.toList $ Stream.pipe (Pipe.identity) $ Stream.fromList [1..5::Int] +-- [1,2,3,4,5] +-- +{-# INLINE identity #-} +identity :: Monad m => Pipe m a a +identity = map Prelude.id + +-- | "." composes the pipes in series. +instance Monad m => Category (Pipe m) where + {-# INLINE id #-} + id = identity + + {-# INLINE (.) #-} + (.) = compose + +{-# ANN type TeeMergeConsume Fuse #-} +data TeeMergeConsume csL csR + = TeeMergeConsume !csL !csR + | TeeMergeConsumeOnlyL !csL + | TeeMergeConsumeOnlyR !csR + +{-# ANN type TeeMergeProduce Fuse #-} +data TeeMergeProduce csL csR psL psR x + = TeeMergeProduce !csL !csR !x + | TeeMergeProduceL !psL !csR !x + | TeeMergeProduceR !csL !psR + | TeeMergeProduceOnlyL !psL + | TeeMergeProduceOnlyR !psR + +-- | Parallel composition. Distribute the input across two pipes and merge +-- their outputs. +-- +-- >>> Stream.toList $ Stream.pipe (Pipe.teeMerge Pipe.identity (Pipe.map (\x -> x * x))) $ Stream.fromList [1..5::Int] +-- [1,1,2,4,3,9,4,16,5,25] +-- +{-# INLINE_NORMAL teeMerge #-} +teeMerge :: Monad m => Pipe m a b -> Pipe m a b -> Pipe m a b +teeMerge (Pipe consumeL produceL initialL) (Pipe consumeR produceR initialR) = + Pipe consume produce (TeeMergeConsume initialL initialR) + + where + + {-# INLINE feedRightOnly #-} + feedRightOnly csR a = do + resR <- consumeR csR a + return + $ case resR of + YieldC cs b -> YieldC (TeeMergeConsumeOnlyR cs) b + SkipC cs -> SkipC (TeeMergeConsumeOnlyR cs) + Stop -> Stop + YieldP ps b -> YieldP (TeeMergeProduceOnlyR ps) b + SkipP ps -> SkipP (TeeMergeProduceOnlyR ps) + + {-# INLINE_LATE consume #-} + consume (TeeMergeConsume csL csR) a = do + resL <- consumeL csL a + case resL of + YieldC cs b -> return $ YieldP (TeeMergeProduce cs csR a) b + SkipC cs -> return $ SkipP (TeeMergeProduce cs csR a) + Stop -> + -- XXX Skip to a state instead? + feedRightOnly csR a + YieldP ps b -> return $ YieldP (TeeMergeProduceL ps csR a) b + SkipP ps -> return $ SkipP (TeeMergeProduceL ps csR a) + + -- XXX Adding additional consume states causes 4x regression in + -- All.Data.Stream/o-1-space.pipesX4.tee benchmark (mapM 4 times). + -- Commenting these two states makes it 4x faster. Need to investigate why. + consume (TeeMergeConsumeOnlyL csL) a = do + resL <- consumeL csL a + return + $ case resL of + YieldC cs b -> YieldC (TeeMergeConsumeOnlyL cs) b + SkipC cs -> SkipC (TeeMergeConsumeOnlyL cs) + Stop -> Stop + YieldP ps b -> YieldP (TeeMergeProduceOnlyL ps) b + SkipP ps -> SkipP (TeeMergeProduceOnlyL ps) + consume (TeeMergeConsumeOnlyR csR) a = feedRightOnly csR a + + {-# INLINE_LATE produce #-} + produce (TeeMergeProduce csL csR a) = do + res <- consumeR csR a + return + $ case res of + YieldC cs b -> YieldC (TeeMergeConsume csL cs) b + SkipC cs -> SkipC (TeeMergeConsume csL cs) + Stop -> SkipC (TeeMergeConsumeOnlyL csL) + YieldP ps b -> YieldP (TeeMergeProduceR csL ps) b + SkipP ps -> SkipP (TeeMergeProduceR csL ps) + + produce (TeeMergeProduceL psL csR a) = do + res <- produceL psL + case res of + YieldC cs b -> return $ YieldP (TeeMergeProduce cs csR a) b + SkipC cs -> return $ SkipP (TeeMergeProduce cs csR a) + Stop -> feedRightOnly csR a + YieldP ps b -> return $ YieldP (TeeMergeProduceL ps csR a) b + SkipP ps -> return $ SkipP (TeeMergeProduceL ps csR a) + + produce (TeeMergeProduceR csL psR) = do + res <- produceR psR + return $ case res of + YieldC cs b -> YieldC (TeeMergeConsume csL cs) b + SkipC cs -> SkipC (TeeMergeConsume csL cs) + Stop -> SkipC (TeeMergeConsumeOnlyL csL) + YieldP ps b -> YieldP (TeeMergeProduceR csL ps) b + SkipP ps -> SkipP (TeeMergeProduceR csL ps) + + produce (TeeMergeProduceOnlyL psL) = do + resL <- produceL psL + return + $ case resL of + YieldC cs b -> YieldC (TeeMergeConsumeOnlyL cs) b + SkipC cs -> SkipC (TeeMergeConsumeOnlyL cs) + Stop -> Stop + YieldP ps b -> YieldP (TeeMergeProduceOnlyL ps) b + SkipP ps -> SkipP (TeeMergeProduceOnlyL ps) + + produce (TeeMergeProduceOnlyR psR) = do + resL <- produceR psR + return + $ case resL of + YieldC cs b -> YieldC (TeeMergeConsumeOnlyR cs) b + SkipC cs -> SkipC (TeeMergeConsumeOnlyR cs) + Stop -> Stop + YieldP ps b -> YieldP (TeeMergeProduceOnlyR ps) b + SkipP ps -> SkipP (TeeMergeProduceOnlyR ps) + +-- | '<>' composes the pipes in parallel. +instance Monad m => Semigroup (Pipe m a b) where + {-# INLINE (<>) #-} + (<>) = teeMerge + +------------------------------------------------------------------------------- +-- Arrow +------------------------------------------------------------------------------- + +{- +unzip :: Pipe m a x -> Pipe m b y -> Pipe m (a, b) (x, y) +unzip = undefined + -- XXX move this to a separate module data Deque a = Deque [a] [a] @@ -124,6 +436,8 @@ h : t -> Just (h, Deque [] t) _ -> Nothing +-- XXX This is old code retained for reference until rewritten. + -- | The composed pipe distributes the input to both the constituent pipes and -- zips the output of the two using a supplied zipping function. -- @@ -251,193 +565,164 @@ (<*>) = zipWith id --- | The composed pipe distributes the input to both the constituent pipes and --- merges the outputs of the two. --- --- @since 0.7.0 -{-# INLINE_NORMAL tee #-} -tee :: Monad m => Pipe m a b -> Pipe m a b -> Pipe m a b -tee (Pipe consumeL produceL stateL) (Pipe consumeR produceR stateR) = - Pipe consume produce state +instance Monad m => Arrow (Pipe m) where + {-# INLINE arr #-} + arr = map + + {-# INLINE (***) #-} + (***) = unzip + + {-# INLINE (&&&) #-} + -- (&&&) = zipWith (,) + (&&&) = undefined +-} + +------------------------------------------------------------------------------- +-- Primitive pipes +------------------------------------------------------------------------------- + +-- | A filtering pipe using a monadic predicate. +{-# INLINE filterM #-} +filterM :: Monad m => (a -> m Bool) -> Pipe m a a +filterM f = Pipe (\() a -> f a >>= g a) undefined () + where - state = Tuple' (Consume stateL) (Consume stateR) + {-# INLINE g #-} + g a b = + return + $ if b + then YieldC () a + else SkipC () - consume (Tuple' sL sR) a = - case sL of - Consume st -> do - r <- consumeL st a - return $ case r of - Yield x s -> Yield x (Produce (Tuple3' (Just a) s sR)) - Continue s -> Continue (Produce (Tuple3' (Just a) s sR)) - -- XXX we should never come here unless the initial state of the - -- first pipe is set to "Right". - Produce _st -> undefined -- do - {- - r <- produceL st - return $ case r of - Yield x s -> Yield x (Right (Tuple3' (Just a) s sR)) - Continue s -> Continue (Right (Tuple3' (Just a) s sR)) - -} +-- | A filtering pipe using a pure predicate. +-- +-- >>> Stream.toList $ Stream.pipe (Pipe.filter odd) $ Stream.fromList [1..5::Int] +-- [1,3,5] +-- +{-# INLINE filter #-} +filter :: Monad m => (a -> Bool) -> Pipe m a a +filter f = filterM (return Prelude.. f) - produce (Tuple3' (Just a) sL sR) = - case sL of - Consume _ -> - case sR of - Consume st -> do - r <- consumeR st a - let nextL s = Consume (Tuple' sL s) - let nextR s = Produce (Tuple3' Nothing sL s) - return $ case r of - Yield x s@(Consume _) -> Yield x (nextL s) - Yield x s@(Produce _) -> Yield x (nextR s) - Continue s@(Consume _) -> Continue (nextL s) - Continue s@(Produce _) -> Continue (nextR s) - -- We will never come here unless the initial state of - -- second pipe is set to "Right". - Produce _ -> undefined - Produce st -> do - r <- produceL st - let next s = Produce (Tuple3' (Just a) s sR) - return $ case r of - Yield x s -> Yield x (next s) - Continue s -> Continue (next s) +------------------------------------------------------------------------------- +-- Convert folds to pipes +------------------------------------------------------------------------------- - produce (Tuple3' Nothing sL sR) = - case sR of - Consume _ -> undefined -- should never occur - Produce st -> do - r <- produceR st - return $ case r of - Yield x s@(Consume _) -> - Yield x (Consume (Tuple' sL s)) - Yield x s@(Produce _) -> - Yield x (Produce (Tuple3' Nothing sL s)) - Continue s@(Consume _) -> - Continue (Consume (Tuple' sL s)) - Continue s@(Produce _) -> - Continue (Produce (Tuple3' Nothing sL s)) +-- Note when we have a separate Scan type then we can remove extract from +-- Folds. Then folds can only be used for foldMany or many and not for +-- scanning. This combinator has to be removed then. -instance Monad m => Semigroup (Pipe m a b) where - {-# INLINE (<>) #-} - (<>) = tee +-- XXX The way filter is implemented in Folds is that it discards the input and +-- on "extract" it will return the previous accumulator value only. Thus the +-- accumulator may repeat in the output stream when filter is used. Ideally the +-- output stream should not have a value corresponding to the filtered value. +-- With "Continue s" and "Partial s b" instead of using "extract" we can do +-- that. --- | Lift a pure function to a 'Pipe'. +{-# ANN type FromFoldConsume Fuse #-} +#if __GLASGOW_HASKELL__ >= 810 +type FromFoldConsume :: Type -> Type -> Type +#endif +data FromFoldConsume s x = FoldConsumeInit | FoldConsumeGo s + +{-# ANN type FromFoldProduce Fuse #-} +data FromFoldProduce s x = FoldProduceInit s x | FoldProduceStop + +-- XXX This should be removed once we remove "extract" from folds. + +-- | Pipes do not support finalization yet. This does not finalize the fold +-- when the stream stops before the fold terminates. So cannot be used on folds +-- that require finalization. -- --- @since 0.7.0 -{-# INLINE map #-} -map :: Monad m => (a -> b) -> Pipe m a b -map f = Pipe consume undefined () +-- >>> Stream.toList $ Stream.pipe (Pipe.scanFold Fold.sum) $ Stream.fromList [1..5::Int] +-- [1,3,6,10,15] +-- +{-# INLINE scanFold #-} +scanFold :: Monad m => Fold m a b -> Pipe m a b +scanFold (Fold fstep finitial fextract _) = + Pipe consume produce FoldConsumeInit + where - consume _ a = return $ Yield (f a) (Consume ()) -{- --- | A hollow or identity 'Pipe' passes through everything that comes in. --- --- @since 0.7.0 -{-# INLINE id #-} -id :: Monad m => Pipe m a a -id = map Prelude.id --} + -- XXX make the initial state Either type and start in produce mode + consume FoldConsumeInit x = do + r <- finitial + return $ case r of + Fold.Partial s -> SkipP (FoldProduceInit s x) + Fold.Done b -> YieldP FoldProduceStop b --- | Compose two pipes such that the output of the second pipe is attached to --- the input of the first pipe. + consume (FoldConsumeGo st) a = do + r <- fstep st a + case r of + Fold.Partial s -> do + b <- fextract s + return $ YieldC (FoldConsumeGo s) b + Fold.Done b -> return $ YieldP FoldProduceStop b + + produce (FoldProduceInit st x) = consume (FoldConsumeGo st) x + produce FoldProduceStop = return Stop + +-- XXX The doctest for Pipe.fromFold fails with "[]" as the result. + +-- | Create a singleton pipe from a fold. -- --- @since 0.7.0 -{-# INLINE_NORMAL compose #-} -compose :: Monad m => Pipe m b c -> Pipe m a b -> Pipe m a c -compose (Pipe consumeL produceL stateL) (Pipe consumeR produceR stateR) = - Pipe consume produce state +-- Pipes do not support finalization yet. This does not finalize the fold +-- when the stream stops before the fold terminates. So cannot be used on folds +-- that require such finalization. +-- +-- >> Stream.toList $ Stream.pipe (Pipe.fromFold Fold.sum) $ Stream.fromList [1..5::Int] +-- [15] +-- +{-# INLINE fromFold #-} +fromFold :: Monad m => Fold m a b -> Pipe m a b +fromFold (Fold fstep finitial _ _) = + Pipe consume produce FoldConsumeInit where - state = Tuple' (Consume stateL) (Consume stateR) + -- XXX make the initial state Either type and start in produce mode + consume FoldConsumeInit x = do + r <- finitial + return $ case r of + Fold.Partial s -> SkipP (FoldProduceInit s x) + Fold.Done b -> YieldP FoldProduceStop b - consume (Tuple' sL sR) a = - case sL of - Consume stt -> - case sR of - Consume st -> do - rres <- consumeR st a - case rres of - Yield x sR' -> do - let next s = - if isProduce sR' - then Produce s - else Consume s - lres <- consumeL stt x - return $ case lres of - Yield y s1@(Consume _) -> - Yield y (next $ Tuple' s1 sR') - Yield y s1@(Produce _) -> - Yield y (Produce $ Tuple' s1 sR') - Continue s1@(Consume _) -> - Continue (next $ Tuple' s1 sR') - Continue s1@(Produce _) -> - Continue (Produce $ Tuple' s1 sR') - Continue s1@(Consume _) -> - return $ Continue (Consume $ Tuple' sL s1) - Continue s1@(Produce _) -> - return $ Continue (Produce $ Tuple' sL s1) - Produce _ -> undefined - -- XXX we should never come here unless the initial state of the - -- first pipe is set to "Right". - Produce _ -> undefined + consume (FoldConsumeGo st) a = do + r <- fstep st a + return $ case r of + Fold.Partial s -> SkipC (FoldConsumeGo s) + Fold.Done b -> YieldP FoldProduceStop b - -- XXX we need to write the code in mor optimized fashion. Use Continue - -- more and less yield points. - produce (Tuple' sL sR) = - case sL of - Produce st -> do - r <- produceL st - let next s = if isProduce sR then Produce s else Consume s - return $ case r of - Yield x s@(Consume _) -> Yield x (next $ Tuple' s sR) - Yield x s@(Produce _) -> Yield x (Produce $ Tuple' s sR) - Continue s@(Consume _) -> Continue (next $ Tuple' s sR) - Continue s@(Produce _) -> Continue (Produce $ Tuple' s sR) - Consume stt -> - case sR of - Produce st -> do - rR <- produceR st - case rR of - Yield x sR' -> do - let next s = - if isProduce sR' - then Produce s - else Consume s - rL <- consumeL stt x - return $ case rL of - Yield y s1@(Consume _) -> - Yield y (next $ Tuple' s1 sR') - Yield y s1@(Produce _) -> - Yield y (Produce $ Tuple' s1 sR') - Continue s1@(Consume _) -> - Continue (next $ Tuple' s1 sR') - Continue s1@(Produce _) -> - Continue (Produce $ Tuple' s1 sR') - Continue s1@(Consume _) -> - return $ Continue (Consume $ Tuple' sL s1) - Continue s1@(Produce _) -> - return $ Continue (Produce $ Tuple' sL s1) - Consume _ -> return $ Continue (Consume $ Tuple' sL sR) + produce (FoldProduceInit st x) = consume (FoldConsumeGo st) x + produce FoldProduceStop = return Stop -instance Monad m => Category (Pipe m) where - {-# INLINE id #-} - id = map Prelude.id +-- | Produces the stream on consuming (). +-- +{-# INLINE fromStream #-} +fromStream :: Monad m => Stream m a -> Pipe m () a +fromStream (Stream step state) = Pipe consume produce () - {-# INLINE (.) #-} - (.) = compose + where -unzip :: Pipe m a x -> Pipe m b y -> Pipe m (a, b) (x, y) -unzip = undefined + -- XXX make the initial state Either type and start in produce mode + consume () () = return $ SkipP state -instance Monad m => Arrow (Pipe m) where - {-# INLINE arr #-} - arr = map + produce st = do + r <- step defState st + return $ case r of + Stream.Yield b s -> YieldP s b + Stream.Skip s -> SkipP s + Stream.Stop -> Stop - {-# INLINE (***) #-} - (***) = unzip +{-# INLINE fromScanr #-} +fromScanr :: Monad m => Scanr m a b -> Pipe m a b +fromScanr (Scanr step initial) = Pipe consume undefined initial - {-# INLINE (&&&) #-} - (&&&) = zipWith (,) + where + + consume st a = do + r <- step st a + return $ case r of + Stream.Yield b s -> YieldC s b + Stream.Skip s -> SkipC s + Stream.Stop -> Stop diff --git a/src/Streamly/Internal/Data/Producer.hs b/src/Streamly/Internal/Data/Producer.hs --- a/src/Streamly/Internal/Data/Producer.hs +++ b/src/Streamly/Internal/Data/Producer.hs @@ -24,31 +24,24 @@ -- unecessary function calls can be avoided. module Streamly.Internal.Data.Producer - ( Producer (..) + ( + module Streamly.Internal.Data.Producer.Source + , module Streamly.Internal.Data.Producer.Type -- * Converting , simplify - - -- * Producers - , nil - , nilM - , unfoldrM , fromStreamD - , fromList - - -- * Combinators - , NestedLoop (..) - , concat ) where #include "inline.hs" -import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream(..)) +import Streamly.Internal.Data.Stream.Step (Step(..)) +import Streamly.Internal.Data.Stream.Type (Stream(..)) import Streamly.Internal.Data.SVar.Type (defState) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.Data.Producer.Source import Streamly.Internal.Data.Producer.Type import Prelude hiding (concat) diff --git a/src/Streamly/Internal/Data/Producer/Source.hs b/src/Streamly/Internal/Data/Producer/Source.hs --- a/src/Streamly/Internal/Data/Producer/Source.hs +++ b/src/Streamly/Internal/Data/Producer/Source.hs @@ -36,11 +36,12 @@ import Control.Exception (assert) import GHC.Exts (SpecConstrAnnotation(..)) import GHC.Types (SPEC(..)) -import Streamly.Internal.Data.Parser.ParserD (ParseError(..), Step(..)) +import Streamly.Internal.Data.Parser + (ParseError(..), ParseErrorPos(..), Step(..), Final(..)) import Streamly.Internal.Data.Producer.Type (Producer(..)) -import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) +import Streamly.Internal.Data.Stream.Step (Step(..)) -import qualified Streamly.Internal.Data.Parser.ParserD as ParserD +import qualified Streamly.Internal.Data.Parser as ParserD -- import qualified Streamly.Internal.Data.Parser.ParserK.Type as ParserK import Prelude hiding (read) @@ -115,7 +116,7 @@ ParserD.Parser a m b -> Producer m (Source s a) a -> Source s a - -> m (Either ParseError b, Source s a) + -> m (Either ParseErrorPos b, Source s a) parse (ParserD.Parser pstep initial extract) (Producer ustep uinject uextract) @@ -125,121 +126,144 @@ case res of ParserD.IPartial s -> do state <- uinject seed - go SPEC state (List []) s + go SPEC state (List []) s 0 ParserD.IDone b -> return (Right b, seed) - ParserD.IError err -> return (Left (ParseError err), seed) + ParserD.IError err -> return (Left (ParseErrorPos 0 err), seed) where -- XXX currently we are using a dumb list based approach for backtracking -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. -- That will allow us more efficient random back and forth movement. - go !_ st buf !pst = do + go !_ st buf !pst i = do r <- ustep st case r of Yield x s -> do pRes <- pstep pst x case pRes of - Partial 0 pst1 -> go SPEC s (List []) pst1 - Partial n pst1 -> do + SPartial 1 pst1 -> go SPEC s (List []) pst1 i + SPartial m pst1 -> do + let n = 1 - m assert (n <= length (x:getList buf)) (return ()) let src0 = Prelude.take n (x:getList buf) src = Prelude.reverse src0 - gobuf SPEC s (List []) (List src) pst1 - Continue 0 pst1 -> go SPEC s (List (x:getList buf)) pst1 - Continue n pst1 -> do + gobuf SPEC s (List []) (List src) pst1 (i + 1 - n) + SContinue 1 pst1 -> go SPEC s (List (x:getList buf)) pst1 (i + 1) + SContinue m pst1 -> do + let n = 1 - m assert (n <= length (x:getList buf)) (return ()) let (src0, buf1) = splitAt n (x:getList buf) src = Prelude.reverse src0 - gobuf SPEC s (List buf1) (List src) pst1 - Done n b -> do + gobuf SPEC s (List buf1) (List src) pst1 (i + 1 - n) + SDone m b -> do + let n = 1 - m assert (n <= length (x:getList buf)) (return ()) let src0 = Prelude.take n (x:getList buf) src = Prelude.reverse src0 s1 <- uextract s return (Right b, unread src s1) - Error err -> do + SError err -> do s1 <- uextract s - return (Left (ParseError err), unread [x] s1) - Skip s -> go SPEC s buf pst - Stop -> goStop buf pst + let src = Prelude.reverse (getList buf) + return + ( Left (ParseErrorPos (i + 1) err) + , unread (src ++ [x]) s1 + ) + Skip s -> go SPEC s buf pst i + Stop -> goStop buf pst i - gobuf !_ s buf (List []) !pst = go SPEC s buf pst - gobuf !_ s buf (List (x:xs)) !pst = do + gobuf !_ s buf (List []) !pst i = go SPEC s buf pst i + gobuf !_ s buf (List (x:xs)) !pst i = do pRes <- pstep pst x case pRes of - Partial 0 pst1 -> - gobuf SPEC s (List []) (List xs) pst1 - Partial n pst1 -> do + SPartial 1 pst1 -> + gobuf SPEC s (List []) (List xs) pst1 (i + 1) + SPartial m pst1 -> do + let n = 1 - m assert (n <= length (x:getList buf)) (return ()) let src0 = Prelude.take n (x:getList buf) src = Prelude.reverse src0 ++ xs - gobuf SPEC s (List []) (List src) pst1 - Continue 0 pst1 -> - gobuf SPEC s (List (x:getList buf)) (List xs) pst1 - Continue n pst1 -> do + gobuf SPEC s (List []) (List src) pst1 (i + 1 - n) + SContinue 1 pst1 -> + gobuf SPEC s (List (x:getList buf)) (List xs) pst1 (i + 1) + SContinue m pst1 -> do + let n = 1 - m assert (n <= length (x:getList buf)) (return ()) let (src0, buf1) = splitAt n (x:getList buf) src = Prelude.reverse src0 ++ xs - gobuf SPEC s (List buf1) (List src) pst1 - Done n b -> do + gobuf SPEC s (List buf1) (List src) pst1 (i + 1 - n) + SDone m b -> do + let n = 1 - m assert (n <= length (x:getList buf)) (return ()) let src0 = Prelude.take n (x:getList buf) src = Prelude.reverse src0 s1 <- uextract s return (Right b, unread src s1) - Error err -> do + SError err -> do s1 <- uextract s - return (Left (ParseError err), unread (x:xs) s1) + let src = Prelude.reverse (getList buf) + return + ( Left (ParseErrorPos (i + 1) err) + , unread (src ++ (x:xs)) s1 + ) -- This is a simplified gobuf - goExtract !_ buf (List []) !pst = goStop buf pst - goExtract !_ buf (List (x:xs)) !pst = do + goExtract !_ buf (List []) !pst i = goStop buf pst i + goExtract !_ buf (List (x:xs)) !pst i = do pRes <- pstep pst x case pRes of - Partial 0 pst1 -> - goExtract SPEC (List []) (List xs) pst1 - Partial n pst1 -> do + SPartial 1 pst1 -> + goExtract SPEC (List []) (List xs) pst1 (i + 1) + SPartial m pst1 -> do + let n = 1 - m assert (n <= length (x:getList buf)) (return ()) let src0 = Prelude.take n (x:getList buf) src = Prelude.reverse src0 ++ xs - goExtract SPEC (List []) (List src) pst1 - Continue 0 pst1 -> - goExtract SPEC (List (x:getList buf)) (List xs) pst1 - Continue n pst1 -> do + goExtract SPEC (List []) (List src) pst1 (i + 1 - n) + SContinue 1 pst1 -> + goExtract SPEC (List (x:getList buf)) (List xs) pst1 (i + 1) + SContinue m pst1 -> do + let n = 1 - m assert (n <= length (x:getList buf)) (return ()) let (src0, buf1) = splitAt n (x:getList buf) src = Prelude.reverse src0 ++ xs - goExtract SPEC (List buf1) (List src) pst1 - Done n b -> do + goExtract SPEC (List buf1) (List src) pst1 (i + 1 - n) + SDone m b -> do + let n = 1 - m assert (n <= length (x:getList buf)) (return ()) let src0 = Prelude.take n (x:getList buf) src = Prelude.reverse src0 return (Right b, unread src (source Nothing)) - Error err -> - return (Left (ParseError err), unread (x:xs) (source Nothing)) + SError err -> do + let src = Prelude.reverse (getList buf) + return + ( Left (ParseErrorPos (i + 1) err) + , unread (src ++ (x:xs)) (source Nothing) + ) -- This is a simplified goExtract {-# INLINE goStop #-} - goStop buf pst = do + goStop buf pst i = do pRes <- extract pst case pRes of - Partial _ _ -> error "Bug: parseD: Partial in extract" - Continue 0 pst1 -> - goStop buf pst1 - Continue n pst1 -> do + FContinue 0 pst1 -> + goStop buf pst1 i + FContinue m pst1 -> do + let n = (- m) assert (n <= length (getList buf)) (return ()) let (src0, buf1) = splitAt n (getList buf) src = Prelude.reverse src0 - goExtract SPEC (List buf1) (List src) pst1 - Done 0 b -> return (Right b, source Nothing) - Done n b -> do + goExtract SPEC (List buf1) (List src) pst1 (i - n) + FDone 0 b -> return (Right b, source Nothing) + FDone m b -> do + let n = (- m) assert (n <= length (getList buf)) (return ()) let src0 = Prelude.take n (getList buf) src = Prelude.reverse src0 return (Right b, unread src (source Nothing)) - Error err -> - return (Left (ParseError err), source Nothing) + FError err -> do + let src = Prelude.reverse (getList buf) + return (Left (ParseErrorPos i err), unread src (source Nothing)) {- -- | Parse a buffered source using a parser, returning the parsed value and the diff --git a/src/Streamly/Internal/Data/Producer/Type.hs b/src/Streamly/Internal/Data/Producer/Type.hs --- a/src/Streamly/Internal/Data/Producer/Type.hs +++ b/src/Streamly/Internal/Data/Producer/Type.hs @@ -33,12 +33,16 @@ #include "inline.hs" import Fusion.Plugin.Types (Fuse(..)) -import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) +import Streamly.Internal.Data.Stream.Step (Step(..)) import Prelude hiding (concat, map) ------------------------------------------------------------------------------ -- Type ------------------------------------------------------------------------------ + +-- Note that this type cannot be made a Functor on the seed/result type because +-- that requires bi-directional mapping between the two types, see translate +-- and lmap below. -- | A @Producer m a b@ is a generator of a stream of values of type @b@ from a -- seed of type 'a' in 'Monad' @m@. diff --git a/src/Streamly/Internal/Data/Refold/Type.hs b/src/Streamly/Internal/Data/Refold/Type.hs --- a/src/Streamly/Internal/Data/Refold/Type.hs +++ b/src/Streamly/Internal/Data/Refold/Type.hs @@ -47,12 +47,12 @@ import Fusion.Plugin.Types (Fuse(..)) import Streamly.Internal.Data.Fold.Step (Step(..), mapMStep) -import Prelude hiding (take, iterate) +import Prelude hiding (Foldable(..), take, iterate) -- $setup -- >>> :m -- >>> import qualified Streamly.Internal.Data.Refold.Type as Refold --- >>> import qualified Streamly.Internal.Data.Fold.Type as Fold +-- >>> import qualified Streamly.Internal.Data.Fold as Fold -- >>> import qualified Streamly.Internal.Data.Stream as Stream -- All folds in the Fold module should be implemented using Refolds. diff --git a/src/Streamly/Internal/Data/Ring.hs b/src/Streamly/Internal/Data/Ring.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Ring.hs +++ /dev/null @@ -1,164 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Ring --- Copyright : (c) 2021 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- - -module Streamly.Internal.Data.Ring - ( Ring(..) - - -- * Generation - , createRing - , writeLastN - - -- * Modification - , seek - , unsafeInsertRingWith - - -- * Conversion - , toMutArray - , toStreamWith - ) where - -#include "assert.hs" - -import Control.Monad.IO.Class (liftIO, MonadIO) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Array.Generic.Mut.Type - ( MutArray(..) - , new - , uninit - , putIndexUnsafe - , putSliceUnsafe - ) --- import qualified Streamly.Internal.Data.Stream.StreamD.Type as Stream -import qualified Streamly.Internal.Data.Fold.Type as Fold - --- XXX Use MutableArray rather than keeping a MutArray here. -data Ring a = Ring - { ringArr :: MutArray a - -- XXX We can keep the current fill amount, Or we can keep a count of total - -- elements inserted and compute ring head as well using mod on that, - -- assuming it won't overflow. But mod could be expensive. - , ringHead :: !Int -- current index to be over-written - , ringMax :: !Int -- first index beyond allocated memory - } - -------------------------------------------------------------------------------- --- Generation -------------------------------------------------------------------------------- - --- XXX If we align the ringMax to nearest power of two then computation of the --- index to write could be cheaper. -{-# INLINE createRing #-} -createRing :: MonadIO m => Int -> m (Ring a) -createRing count = liftIO $ do - arr <- new count - arr1 <- uninit arr count - return (Ring - { ringArr = arr1 - , ringHead = 0 - , ringMax = count - }) - - -{-# INLINE writeLastN #-} -writeLastN :: MonadIO m => Int -> Fold m a (Ring a) -writeLastN n = Fold step initial extract - - where - - initial = do - if n <= 0 - then Fold.Done <$> createRing 0 - else do - rb <- createRing n - return $ Fold.Partial $ Tuple' rb (0 :: Int) - - step (Tuple' rb cnt) x = do - rh1 <- liftIO $ unsafeInsertRingWith rb x - return $ Fold.Partial $ Tuple' (rb {ringHead = rh1}) (cnt + 1) - - extract (Tuple' rb@Ring{..} cnt) = - return $ - if cnt < ringMax - then Ring ringArr 0 ringHead - else rb - -------------------------------------------------------------------------------- --- Modification -------------------------------------------------------------------------------- - --- XXX This is safe --- Take the ring head and return the new ring head. -{-# INLINE unsafeInsertRingWith #-} -unsafeInsertRingWith :: Ring a -> a -> IO Int -unsafeInsertRingWith Ring{..} x = do - assertM(ringMax >= 1) - assertM(ringHead < ringMax) - putIndexUnsafe ringHead ringArr x - let rh1 = ringHead + 1 - next = if rh1 == ringMax then 0 else rh1 - return next - --- | Move the ring head clockwise (+ve adj) or counter clockwise (-ve adj) by --- the given amount. -{-# INLINE seek #-} -seek :: MonadIO m => Int -> Ring a -> m (Ring a) -seek adj rng@Ring{..} - | ringMax > 0 = liftIO $ do - -- XXX try avoiding mod when in bounds - let idx1 = ringHead + adj - next = mod idx1 ringMax - return $ Ring ringArr next ringMax - | otherwise = pure rng - -------------------------------------------------------------------------------- --- Conversion -------------------------------------------------------------------------------- - --- | @toMutArray rignHeadAdjustment lengthToRead ring@. --- Convert the ring into a boxed mutable array. Note that the returned MutArray --- may share the same underlying memory as the Ring. -{-# INLINE toMutArray #-} -toMutArray :: MonadIO m => Int -> Int -> Ring a -> m (MutArray a) -toMutArray adj n Ring{..} = do - let len = min ringMax n - let idx = mod (ringHead + adj) ringMax - end = idx + len - if end <= ringMax - then - -- putSliceUnsafe ringArr idx arr1 0 len - return $ ringArr { arrStart = idx, arrLen = len } - else do - -- XXX Just swap the elements in the existing ring and return the - -- same array without reallocation. - arr <- liftIO $ new len - arr1 <- uninit arr len - putSliceUnsafe ringArr idx arr1 0 (ringMax - idx) - putSliceUnsafe ringArr 0 arr1 (ringMax - idx) (end - ringMax) - return arr1 - --- This would be theoretically slower than toMutArray because of a branch --- introduced for each element in the second half of the ring. - --- | Seek by n and then read the entire ring. Use 'take' on the stream to --- restrict the reads. -toStreamWith :: Int -> Ring a -> Stream m a -toStreamWith = undefined -{- -toStreamWith n Ring{..} - | ringMax > 0 = concatEffect $ liftIO $ do - idx <- readIORef ringHead - let idx1 = idx + adj - next = mod idx1 ringMax - s1 = undefined -- stream initial slice - s2 = undefined -- stream next slice - return (s1 `Stream.append` s2) - | otherwise = Stream.nil --} diff --git a/src/Streamly/Internal/Data/Ring/Unboxed.hs b/src/Streamly/Internal/Data/Ring/Unboxed.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Ring/Unboxed.hs +++ /dev/null @@ -1,615 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Ring.Unboxed --- Copyright : (c) 2019 Composewell Technologies --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- A ring array is a circular mutable array. - --- XXX Write benchmarks --- XXX Make the implementation similar to mutable array --- XXX Rename this module to Data.RingArray.Storable - -module Streamly.Internal.Data.Ring.Unboxed - ( Ring(..) - - -- * Construction - , new - , newRing - , writeN - - , advance - , moveBy - , startOf - - -- * Random writes - , unsafeInsert - , slide - , putIndex - , modifyIndex - - -- * Unfolds - , read - , readRev - - -- * Random reads - , getIndex - , getIndexUnsafe - , getIndexRev - - -- * Size - , length - , byteLength - -- , capacity - , byteCapacity - , bytesFree - - -- * Casting - , cast - , castUnsafe - , asBytes - , fromArray - - -- * Folds - , unsafeFoldRing - , unsafeFoldRingM - , unsafeFoldRingFullM - , unsafeFoldRingNM - - -- * Stream of Arrays - , ringsOf - - -- * Fast Byte Comparisons - , unsafeEqArray - , unsafeEqArrayN - - , slidingWindow - , slidingWindowWith - ) where - -#include "ArrayMacros.h" -#include "inline.hs" - -import Control.Exception (assert) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Word (Word8) -import Foreign.Storable -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import Foreign.Ptr (plusPtr, minusPtr, castPtr) -import Streamly.Internal.Data.Unboxed as Unboxed (Unbox, peekWith) -import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes) -import GHC.Ptr (Ptr(..)) -import Streamly.Internal.Data.Array.Mut.Type (MutArray) -import Streamly.Internal.Data.Fold.Type (Fold(..), Step(..), lmap) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Streamly.Internal.System.IO (unsafeInlineIO) - -import qualified Streamly.Internal.Data.Array.Mut.Type as MA -import qualified Streamly.Internal.Data.Array.Type as A - -import Prelude hiding (length, concat, read) - --- $setup --- >>> :m --- >>> import qualified Streamly.Internal.Data.Ring.Unboxed as Ring - --- | A ring buffer is a mutable array of fixed size. Initially the array is --- empty, with ringStart pointing at the start of allocated memory. We call the --- next location to be written in the ring as ringHead. Initially ringHead == --- ringStart. When the first item is added, ringHead points to ringStart + --- sizeof item. When the buffer becomes full ringHead would wrap around to --- ringStart. When the buffer is full, ringHead always points at the oldest --- item in the ring and the newest item added always overwrites the oldest --- item. --- --- When using it we should keep in mind that a ringBuffer is a mutable data --- structure. We should not leak out references to it for immutable use. --- -data Ring a = Ring - { ringStart :: {-# UNPACK #-} !(ForeignPtr a) -- first address - , ringBound :: {-# UNPACK #-} !(Ptr a) -- first address beyond allocated memory - } - -------------------------------------------------------------------------------- --- Construction -------------------------------------------------------------------------------- - --- | Get the first address of the ring as a pointer. -startOf :: Ring a -> Ptr a -startOf = unsafeForeignPtrToPtr . ringStart - --- | Create a new ringbuffer and return the ring buffer and the ringHead. --- Returns the ring and the ringHead, the ringHead is same as ringStart. -{-# INLINE new #-} -new :: forall a. Storable a => Int -> IO (Ring a, Ptr a) -new count = do - let size = count * max 1 (sizeOf (undefined :: a)) - fptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: a)) - let p = unsafeForeignPtrToPtr fptr - return (Ring - { ringStart = fptr - , ringBound = p `plusPtr` size - }, p) - --- XXX Rename this to "new". --- --- | @newRing count@ allocates an empty array that can hold 'count' items. The --- memory of the array is uninitialized and the allocation is aligned as per --- the 'Storable' instance of the type. --- --- /Unimplemented/ -{-# INLINE newRing #-} -newRing :: Int -> m (Ring a) -newRing = undefined - --- | Advance the ringHead by 1 item, wrap around if we hit the end of the --- array. -{-# INLINE advance #-} -advance :: forall a. Storable a => Ring a -> Ptr a -> Ptr a -advance Ring{..} ringHead = - let ptr = PTR_NEXT(ringHead,a) - in if ptr < ringBound - then ptr - else unsafeForeignPtrToPtr ringStart - --- | Move the ringHead by n items. The direction depends on the sign on whether --- n is positive or negative. Wrap around if we hit the beginning or end of the --- array. -{-# INLINE moveBy #-} -moveBy :: forall a. Storable a => Int -> Ring a -> Ptr a -> Ptr a -moveBy by Ring {..} ringHead = ringStartPtr `plusPtr` advanceFromHead - - where - - elemSize = STORABLE_SIZE_OF(a) - ringStartPtr = unsafeForeignPtrToPtr ringStart - lenInBytes = ringBound `minusPtr` ringStartPtr - offInBytes = ringHead `minusPtr` ringStartPtr - len = assert (lenInBytes `mod` elemSize == 0) $ lenInBytes `div` elemSize - off = assert (offInBytes `mod` elemSize == 0) $ offInBytes `div` elemSize - advanceFromHead = (off + by `mod` len) * elemSize - --- XXX Move the writeLastN from array module here. --- --- | @writeN n@ is a rolling fold that keeps the last n elements of the stream --- in a ring array. --- --- /Unimplemented/ -{-# INLINE writeN #-} -writeN :: -- (Storable a, MonadIO m) => - Int -> Fold m a (Ring a) -writeN = undefined - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - --- | Cast a mutable array to a ring array. -fromArray :: MutArray a -> Ring a -fromArray = undefined - -------------------------------------------------------------------------------- --- Conversion to/from array -------------------------------------------------------------------------------- - --- | Modify a given index of a ring array using a modifier function. --- --- /Unimplemented/ -modifyIndex :: -- forall m a b. (MonadIO m, Storable a) => - Ring a -> Int -> (a -> (a, b)) -> m b -modifyIndex = undefined - --- | /O(1)/ Write the given element at the given index in the ring array. --- Performs in-place mutation of the array. --- --- >>> putIndex arr ix val = Ring.modifyIndex arr ix (const (val, ())) --- --- /Unimplemented/ -{-# INLINE putIndex #-} -putIndex :: -- (MonadIO m, Storable a) => - Ring a -> Int -> a -> m () -putIndex = undefined - --- | Insert an item at the head of the ring, when the ring is full this --- replaces the oldest item in the ring with the new item. This is unsafe --- beause ringHead supplied is not verified to be within the Ring. Also, --- the ringStart foreignPtr must be guaranteed to be alive by the caller. -{-# INLINE unsafeInsert #-} -unsafeInsert :: Storable a => Ring a -> Ptr a -> a -> IO (Ptr a) -unsafeInsert rb ringHead newVal = do - poke ringHead newVal - -- touchForeignPtr (ringStart rb) - return $ advance rb ringHead - --- | Insert an item at the head of the ring, when the ring is full this --- replaces the oldest item in the ring with the new item. --- --- /Unimplemented/ -slide :: -- forall m a. (MonadIO m, Storable a) => - Ring a -> a -> m (Ring a) -slide = undefined - -------------------------------------------------------------------------------- --- Random reads -------------------------------------------------------------------------------- - --- | Return the element at the specified index without checking the bounds. --- --- Unsafe because it does not check the bounds of the ring array. -{-# INLINE_NORMAL getIndexUnsafe #-} -getIndexUnsafe :: -- forall m a. (MonadIO m, Storable a) => - Ring a -> Int -> m a -getIndexUnsafe = undefined - --- | /O(1)/ Lookup the element at the given index. Index starts from 0. --- -{-# INLINE getIndex #-} -getIndex :: -- (MonadIO m, Storable a) => - Ring a -> Int -> m a -getIndex = undefined - --- | /O(1)/ Lookup the element at the given index from the end of the array. --- Index starts from 0. --- --- Slightly faster than computing the forward index and using getIndex. --- -{-# INLINE getIndexRev #-} -getIndexRev :: -- (MonadIO m, Storable a) => - Ring a -> Int -> m a -getIndexRev = undefined - -------------------------------------------------------------------------------- --- Size -------------------------------------------------------------------------------- - --- | /O(1)/ Get the byte length of the array. --- --- /Unimplemented/ -{-# INLINE byteLength #-} -byteLength :: Ring a -> Int -byteLength = undefined - --- | /O(1)/ Get the length of the array i.e. the number of elements in the --- array. --- --- Note that 'byteLength' is less expensive than this operation, as 'length' --- involves a costly division operation. --- --- /Unimplemented/ -{-# INLINE length #-} -length :: -- forall a. Storable a => - Ring a -> Int -length = undefined - --- | Get the total capacity of an array. An array may have space reserved --- beyond the current used length of the array. --- --- /Pre-release/ -{-# INLINE byteCapacity #-} -byteCapacity :: Ring a -> Int -byteCapacity = undefined - --- | The remaining capacity in the array for appending more elements without --- reallocation. --- --- /Pre-release/ -{-# INLINE bytesFree #-} -bytesFree :: Ring a -> Int -bytesFree = undefined - -------------------------------------------------------------------------------- --- Unfolds -------------------------------------------------------------------------------- - --- XXX We can read the ring in a loop and use "take" to restrict the number of --- elements to be taken. --- --- | Read n elements from the ring starting at the supplied ring head. If n is --- more than the ring size it keeps reading the ring in a circular fashion. --- --- If the ring is not full the user must ensure than n is less than or equal to --- the number of valid elements in the ring. --- --- /Internal/ -{-# INLINE_NORMAL read #-} -read :: forall m a. (MonadIO m, Storable a) => Unfold m (Ring a, Ptr a, Int) a -read = Unfold step return - - where - - step (rb, rh, n) = do - if n <= 0 - then do - liftIO $ touchForeignPtr (ringStart rb) - return Stop - else do - x <- liftIO $ peek rh - let rh1 = advance rb rh - return $ Yield x (rb, rh1, n - 1) - --- | Unfold a ring array into a stream in reverse order. --- --- /Unimplemented/ -{-# INLINE_NORMAL readRev #-} -readRev :: -- forall m a. (MonadIO m, Storable a) => - Unfold m (MutArray a) a -readRev = undefined - -------------------------------------------------------------------------------- --- Stream of arrays -------------------------------------------------------------------------------- - --- XXX Move this module to a lower level Ring/Type module and move ringsOf to a --- higher level ring module where we can import "scan". - --- | @ringsOf n stream@ groups the input stream into a stream of --- ring arrays of size n. Each ring is a sliding window of size n. --- --- /Unimplemented/ -{-# INLINE_NORMAL ringsOf #-} -ringsOf :: -- forall m a. (MonadIO m, Storable a) => - Int -> Stream m a -> Stream m (MutArray a) -ringsOf = undefined -- Stream.scan (writeN n) - -------------------------------------------------------------------------------- --- Casting -------------------------------------------------------------------------------- - --- | Cast an array having elements of type @a@ into an array having elements of --- type @b@. The array size must be a multiple of the size of type @b@. --- --- /Unimplemented/ --- -castUnsafe :: Ring a -> Ring b -castUnsafe = undefined - --- | Cast an @Array a@ into an @Array Word8@. --- --- /Unimplemented/ --- -asBytes :: Ring a -> Ring Word8 -asBytes = castUnsafe - --- | Cast an array having elements of type @a@ into an array having elements of --- type @b@. The length of the array should be a multiple of the size of the --- target element otherwise 'Nothing' is returned. --- --- /Pre-release/ --- -cast :: forall a b. Storable b => Ring a -> Maybe (Ring b) -cast arr = - let len = byteLength arr - r = len `mod` STORABLE_SIZE_OF(b) - in if r /= 0 - then Nothing - else Just $ castUnsafe arr - -------------------------------------------------------------------------------- --- Equality -------------------------------------------------------------------------------- - --- XXX remove all usage of unsafeInlineIO --- --- | Like 'unsafeEqArray' but compares only N bytes instead of entire length of --- the ring buffer. This is unsafe because the ringHead Ptr is not checked to --- be in range. -{-# INLINE unsafeEqArrayN #-} -unsafeEqArrayN :: Ring a -> Ptr a -> A.Array a -> Int -> Bool -unsafeEqArrayN Ring{..} rh A.Array{..} nBytes - | nBytes < 0 = error "unsafeEqArrayN: n should be >= 0" - | nBytes == 0 = True - | otherwise = unsafeInlineIO $ check (castPtr rh) 0 - - where - - w8Contents = arrContents - - check p i = do - (relem :: Word8) <- peek p - aelem <- peekWith w8Contents i - if relem == aelem - then go (p `plusPtr` 1) (i + 1) - else return False - - go p i - | i == nBytes = return True - | castPtr p == ringBound = - go (castPtr (unsafeForeignPtrToPtr ringStart)) i - | castPtr p == rh = touchForeignPtr ringStart >> return True - | otherwise = check p i - --- XXX This is not modular. We should probably just convert the array and the --- ring buffer to streams and compare the two streams. Need to check perf --- though. - --- | Byte compare the entire length of ringBuffer with the given array, --- starting at the supplied ringHead pointer. Returns true if the Array and --- the ringBuffer have identical contents. --- --- This is unsafe because the ringHead Ptr is not checked to be in range. The --- supplied array must be equal to or bigger than the ringBuffer, ARRAY BOUNDS --- ARE NOT CHECKED. -{-# INLINE unsafeEqArray #-} -unsafeEqArray :: Ring a -> Ptr a -> A.Array a -> Bool -unsafeEqArray Ring{..} rh A.Array{..} = - unsafeInlineIO $ check (castPtr rh) 0 - - where - - w8Contents = arrContents - - check p i = do - (relem :: Word8) <- peek p - aelem <- peekWith w8Contents i - if relem == aelem - then go (p `plusPtr` 1) (i + 1) - else return False - - go p i - | castPtr p == - ringBound = go (castPtr (unsafeForeignPtrToPtr ringStart)) i - | castPtr p == rh = touchForeignPtr ringStart >> return True - | otherwise = check p i - -------------------------------------------------------------------------------- --- Folding -------------------------------------------------------------------------------- - --- XXX We can unfold it into a stream and fold the stream instead. --- XXX use MonadIO --- --- | Fold the buffer starting from ringStart up to the given 'Ptr' using a pure --- step function. This is useful to fold the items in the ring when the ring is --- not full. The supplied pointer is usually the end of the ring. --- --- Unsafe because the supplied Ptr is not checked to be in range. -{-# INLINE unsafeFoldRing #-} -unsafeFoldRing :: forall a b. Storable a - => Ptr a -> (b -> a -> b) -> b -> Ring a -> b -unsafeFoldRing ptr f z Ring{..} = - let !res = unsafeInlineIO $ withForeignPtr ringStart $ \p -> - go z p ptr - in res - where - go !acc !p !q - | p == q = return acc - | otherwise = do - x <- peek p - go (f acc x) (PTR_NEXT(p,a)) q - --- XXX Can we remove MonadIO here? -withForeignPtrM :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b -withForeignPtrM fp fn = do - r <- fn $ unsafeForeignPtrToPtr fp - liftIO $ touchForeignPtr fp - return r - --- | Like unsafeFoldRing but with a monadic step function. -{-# INLINE unsafeFoldRingM #-} -unsafeFoldRingM :: forall m a b. (MonadIO m, Storable a) - => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b -unsafeFoldRingM ptr f z Ring {..} = - withForeignPtrM ringStart $ \x -> go z x ptr - where - go !acc !start !end - | start == end = return acc - | otherwise = do - let !x = unsafeInlineIO $ peek start - acc1 <- f acc x - go acc1 (PTR_NEXT(start,a)) end - --- | Fold the entire length of a ring buffer starting at the supplied ringHead --- pointer. Assuming the supplied ringHead pointer points to the oldest item, --- this would fold the ring starting from the oldest item to the newest item in --- the ring. --- --- Note, this will crash on ring of 0 size. --- -{-# INLINE unsafeFoldRingFullM #-} -unsafeFoldRingFullM :: forall m a b. (MonadIO m, Storable a) - => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b -unsafeFoldRingFullM rh f z rb@Ring {..} = - withForeignPtrM ringStart $ \_ -> go z rh - where - go !acc !start = do - let !x = unsafeInlineIO $ peek start - acc' <- f acc x - let ptr = advance rb start - if ptr == rh - then return acc' - else go acc' ptr - --- | Fold @Int@ items in the ring starting at @Ptr a@. Won't fold more --- than the length of the ring. --- --- Note, this will crash on ring of 0 size. --- -{-# INLINE unsafeFoldRingNM #-} -unsafeFoldRingNM :: forall m a b. (MonadIO m, Storable a) - => Int -> Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b -unsafeFoldRingNM count rh f z rb@Ring {..} = - withForeignPtrM ringStart $ \_ -> go count z rh - - where - - go 0 acc _ = return acc - go !n !acc !start = do - let !x = unsafeInlineIO $ peek start - acc' <- f acc x - let ptr = advance rb start - if ptr == rh || n == 0 - then return acc' - else go (n - 1) acc' ptr - -data Tuple4' a b c d = Tuple4' !a !b !c !d deriving Show - --- | Like slidingWindow but also provides the entire ring contents as an Array. --- The array reflects the state of the ring after inserting the incoming --- element. --- --- IMPORTANT NOTE: The ring is mutable, therefore, the result of @(m (Array --- a))@ action depends on when it is executed. It does not capture the sanpshot --- of the ring at a particular time. -{-# INLINE slidingWindowWith #-} -slidingWindowWith :: forall m a b. (MonadIO m, Storable a, Unbox a) - => Int -> Fold m ((a, Maybe a), m (MutArray a)) b -> Fold m a b -slidingWindowWith n (Fold step1 initial1 extract1) = Fold step initial extract - - where - - initial = do - if n <= 0 - then error "Window size must be > 0" - else do - r <- initial1 - (rb, rh) <- liftIO $ new n - return $ - case r of - Partial s -> Partial $ Tuple4' rb rh (0 :: Int) s - Done b -> Done b - - toArray foldRing rb rh = do - arr <- liftIO $ MA.newPinned n - let snoc' b a = liftIO $ MA.snocUnsafe b a - foldRing rh snoc' arr rb - - step (Tuple4' rb rh i st) a - | i < n = do - rh1 <- liftIO $ unsafeInsert rb rh a - liftIO $ touchForeignPtr (ringStart rb) - let action = toArray unsafeFoldRingM rb (PTR_NEXT(rh, a)) - r <- step1 st ((a, Nothing), action) - return $ - case r of - Partial s -> Partial $ Tuple4' rb rh1 (i + 1) s - Done b -> Done b - | otherwise = do - old <- liftIO $ peek rh - rh1 <- liftIO $ unsafeInsert rb rh a - liftIO $ touchForeignPtr (ringStart rb) - r <- step1 st ((a, Just old), toArray unsafeFoldRingFullM rb rh1) - return $ - case r of - Partial s -> Partial $ Tuple4' rb rh1 (i + 1) s - Done b -> Done b - - extract (Tuple4' _ _ _ st) = extract1 st - --- | @slidingWindow collector@ is an incremental sliding window --- fold that does not require all the intermediate elements in a computation. --- This maintains @n@ elements in the window, when a new element comes it slides --- out the oldest element and the new element along with the old element are --- supplied to the collector fold. --- --- The 'Maybe' type is for the case when initially the window is filling and --- there is no old element. --- -{-# INLINE slidingWindow #-} -slidingWindow :: forall m a b. (MonadIO m, Storable a, Unbox a) - => Int -> Fold m (a, Maybe a) b -> Fold m a b -slidingWindow n f = slidingWindowWith n (lmap fst f) diff --git a/src/Streamly/Internal/Data/RingArray.hs b/src/Streamly/Internal/Data/RingArray.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/RingArray.hs @@ -0,0 +1,963 @@ +-- | +-- Module : Streamly.Internal.Data.RingArray +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Unboxed, mutable ring arrays of fixed size. In case you need to expand the +-- size of a ring, copy it to a MutArray, expand the array and cast it back to +-- ring. + +-- XXX Write benchmarks + +module Streamly.Internal.Data.RingArray + ( RingArray (..) + , Ring + + -- * Debugging + , showRing + + -- * Construction + , createOfLast + , castMutArray + , castMutArrayWith + , unsafeCastMutArray + , unsafeCastMutArrayWith + + -- * Moving the Head + , moveForward + , moveReverse + , moveBy + + -- * In-place Mutation + , insert + , replace + , replace_ + , putIndex + , modifyIndex + + -- * Random Access + , getIndex + , unsafeGetIndex + , unsafeGetHead + + -- * Conversion + , toList + , toMutArray + + -- * Streams + , read + , readRev + + -- * Unfolds + , reader + , readerRev + + -- * Size + , length + , byteLength + + -- * Casting + , cast + , unsafeCast + , asBytes + , asMutArray + , asMutArray_ + + -- * Folds + , foldlM' + , fold + + -- * Stream of Rings + , ringsOf + , scanRingsOf + , scanCustomFoldRingsBy + , scanFoldRingsBy + + -- * Fast Byte Comparisons + , eqArray + , eqArrayN + + -- * Deprecated + , unsafeFoldRing + , unsafeFoldRingM + , unsafeFoldRingNM + , unsafeFoldRingFullM + , slidingWindow + , slidingWindowWith + ) where + +#include "ArrayMacros.h" +#include "inline.hs" + +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Proxy (Proxy(..)) +import Data.Word (Word8) +import Fusion.Plugin.Types (Fuse(..)) +import GHC.Types (SPEC(..)) +import Streamly.Internal.Data.Array.Type (Array) +import Streamly.Internal.Data.MutArray.Type (MutArray(..)) +import Streamly.Internal.Data.MutByteArray.Type (MutByteArray) +import Streamly.Internal.Data.Fold.Type (Fold(..), Step(..), lmap) +import Streamly.Internal.Data.Scanl.Type (Scanl(..)) +import Streamly.Internal.Data.Stream.Step (Step(..)) +import Streamly.Internal.Data.Stream.Type (Stream) +import Streamly.Internal.Data.Tuple.Strict (Tuple3Fused'(..)) +import Streamly.Internal.Data.Unbox (Unbox(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) + +import qualified Streamly.Internal.Data.Array.Type as Array +import qualified Streamly.Internal.Data.Fold.Type as Fold +import qualified Streamly.Internal.Data.MutArray.Type as MutArray +import qualified Streamly.Internal.Data.MutByteArray.Type as MutByteArray +import qualified Streamly.Internal.Data.Scanl.Type as Scanl +import qualified Streamly.Internal.Data.Stream.Transform as Stream +import qualified Streamly.Internal.Data.Stream.Type as Stream +-- import qualified Streamly.Internal.Data.Unfold as Unfold +-- XXX check split benchmarks + +import Prelude hiding (length, concat, read) + +-- $setup +-- >>> :m +-- >>> import qualified Streamly.Internal.Data.Fold as Fold +-- >>> import qualified Streamly.Internal.Data.MutArray as MutArray +-- >>> import qualified Streamly.Internal.Data.RingArray as RingArray +-- >>> import qualified Streamly.Internal.Data.Stream as Stream + +-- XXX Need a feature in GHC to disable positional constructors for record +-- types, so that we can safely reorder the fields. +-- +-- Empty (zero-sized) rings are not allowed in construction routines though the +-- code supports it. We can allow it if there is a compelling use case. +-- +-- We could represent a ring as a tuple of array and ring head (MutArray a, +-- Int). The array never changes, only the head does so the array can be passed +-- as a constant in a loop. +-- +-- Performance notes: Replacing the oldest item with the newest is a very +-- common operation, during this operation the only thing that changes is the +-- ring head. Updating the RingArray constructor because of that could be expensive, +-- therefore, either the RingArray constructor should be eliminated via fusion or we +-- should unbox it manually where needed to allow for only the head to change. + +-- | A ring buffer is a circular buffer. A new element is inserted at a +-- position called the ring head which points to the oldest element in the +-- ring, an insert overwrites the oldest element. After inserting, the head is +-- moved to point to the next element which is now the oldest element. +-- +-- Elements in the ring are indexed relative to the head. RingArray head is +-- designated as the index 0 of the ring buffer, it points to the oldest or the +-- first element in the buffer. Higher positive indices point to the newer +-- elements in the buffer. Index @-1@ points to the newest or the last element +-- in the buffer. Higher negative indices point to older elements. +-- +-- The ring is of fixed size and cannot be expanded or reduced after creation. +-- Creation of zero sized rings is not allowed. +-- +-- This module provides an unboxed implementation of ring buffers for best +-- performance. +-- +data RingArray a = RingArray + { ringContents :: {-# UNPACK #-} !MutByteArray + , ringSize :: {-# UNPACK #-} !Int -- size of array in bytes + , ringHead :: {-# UNPACK #-} !Int -- byte index in the array + } + +{-# DEPRECATED Ring "Please use RingArray instead." #-} +type Ring = RingArray + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +-- | Given byte offset relative to the ring head, compute the linear byte +-- offset in the array. Offset can be positive or negative. Invariants: +-- +-- * RingArray size cannot be zero, this won't work correctly if so. +-- * Absolute value of offset must be less than or equal to the ring size. +-- * Offset must be integer multiple of element size. +{-# INLINE unsafeChangeHeadByOffset #-} +unsafeChangeHeadByOffset :: Int -> Int -> Int -> Int +unsafeChangeHeadByOffset rh rs i = + let i1 = rh + i + in if i1 >= rs + then i1 - rs + else if i1 < 0 + then i1 + rs + else i1 + +-- | Convert a byte offset relative to the ring head to a byte offset in the +-- underlying mutable array. Offset can be positive or negative. +-- +-- Throws an error if the offset is greater than or equal to the ring size. +{-# INLINE changeHeadByOffset #-} +changeHeadByOffset :: Int -> Int -> Int -> Int +changeHeadByOffset rh rs i = + if i < rs && i > -rs + then unsafeChangeHeadByOffset rh rs i + else error $ "changeHeadByOffset: absolute value of offset must be less " + ++ "than the ring size" + +-- | Move the ring head forward or backward by n slots. Moves forward if the +-- argument is positive and backward if it is negative. +-- +-- Throws an error if the absolute value of count is more than or euqal to the +-- ring size. +{-# INLINE moveBy #-} +moveBy :: forall a. Unbox a => Int -> RingArray a -> RingArray a +moveBy n rb = + let i = changeHeadByOffset (ringHead rb) (ringSize rb) (n * SIZE_OF(a)) + in rb {ringHead = i} + +-- | the offset must be exactly the element size in bytes. +{-# INLINE incrHeadByOffset #-} +incrHeadByOffset :: Int -> Int -> Int -> Int +incrHeadByOffset rh rs n = + -- Note: This works even if the ring size is 0. + let rh1 = rh + n + -- greater than is needed when rs = 0 + in if rh1 >= rs + then 0 + else rh1 + +-- | Advance the ring head forward by 1 slot, the ring head will now point to +-- the next (newer) item, and the old ring head position will become the latest +-- or the newest item position. +-- +-- >>> moveForward = RingArray.moveBy 1 +-- +{-# INLINE moveForward #-} +moveForward :: forall a. Unbox a => RingArray a -> RingArray a +moveForward rb@RingArray{..} = + rb { ringHead = incrHeadByOffset ringHead ringSize (SIZE_OF(a)) } + +-- | the offset must be exactly the element size in bytes. +{-# INLINE decrHeadByOffset #-} +decrHeadByOffset :: Int -> Int -> Int -> Int +decrHeadByOffset rh rs n = + -- Note: This works even if the ring size is 0. + -- Though the head should never be accessed when ring size is 0, so it + -- should not matter what it is. + if rs /= 0 + then (if rh == 0 then rs else rh) - n + else 0 + +-- | Move the ring head backward by 1 slot, the ring head will now point to +-- the prev (older) item, when the ring head is at the oldest item it will move +-- to the newest item. +-- +-- >>> moveForward = RingArray.moveBy (-1) +-- +{-# INLINE moveReverse #-} +moveReverse :: forall a. Unbox a => RingArray a -> RingArray a +moveReverse rb@RingArray{..} = + rb { ringHead = decrHeadByOffset ringHead ringSize (SIZE_OF(a)) } + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +-- | The array must not be a slice, and the index must be within the bounds of +-- the array otherwise unpredictable behavior will occur. +{-# INLINE unsafeCastMutArrayWith #-} +unsafeCastMutArrayWith :: forall a. Unbox a => Int -> MutArray a -> RingArray a +unsafeCastMutArrayWith i arr = + RingArray + { ringContents = arrContents arr + , ringSize = arrEnd arr + , ringHead = i * SIZE_OF(a) + } + +-- | Cast a MutArray to a ring sharing the same memory without copying. The +-- ring head is at index 0 of the array. The array must not be a slice. +-- +-- >>> unsafeCastMutArray = RingArray.unsafeCastMutArrayWith 0 +-- +{-# INLINE unsafeCastMutArray #-} +unsafeCastMutArray :: forall a. Unbox a => MutArray a -> RingArray a +unsafeCastMutArray = unsafeCastMutArrayWith 0 + +-- XXX To avoid the failure we can either copy the array or have a ringStart +-- field in the ring. For copying we can have another API though. + +-- XXX castMutArray is called unsafeFreeze in the Array module. Make the naming +-- consistent? + +-- | @castMutArrayWith index arr@ casts a mutable array to a ring array, and +-- positions the ring head at the given @index@ in the array. +-- +-- A MutArray can be a slice which means its memory starts from some offset in +-- the underlying MutableByteArray, and not from 0 offset. RingArray always +-- uses the memory from offset zero in the MutableByteArray, therefore, it +-- refuses to cast if it finds the array does not start from offset zero i.e. +-- if the array was created from some slicing operation over another array. In +-- such cases it returns 'Nothing'. +-- +-- To create a RingArray from a sliced MutArray use 'createOfLast', or clone +-- the MutArray and then cast it. +-- +-- This operation throws an error if the index is not within the array bounds. +-- +{-# INLINE castMutArrayWith #-} +castMutArrayWith :: forall a. Unbox a => Int -> MutArray a -> Maybe (RingArray a) +castMutArrayWith i arr + | i < 0 || i >= MutArray.length arr + = error "castMutArray: index must not be negative or >= array size" + | arrStart arr == 0 + = Just $ unsafeCastMutArrayWith i arr + | otherwise = Nothing + +-- | Cast a MutArray to a ring sharing the same memory without copying. The +-- ring head is positioned at index 0 of the array. The size of the ring is +-- equal to the MutArray length. +-- +-- See 'castMutArrayWith' for failure scenarios. +-- +-- >>> castMutArray = RingArray.castMutArrayWith 0 +-- +{-# INLINE castMutArray #-} +castMutArray :: forall a. Unbox a => MutArray a -> Maybe (RingArray a) +castMutArray = castMutArrayWith 0 + +------------------------------------------------------------------------------- +-- Conversion to/from array +------------------------------------------------------------------------------- + +-- | Modify a given index of a ring array using a modifier function. +-- +-- /Unimplemented/ +modifyIndex :: -- forall m a b. (MonadIO m, Unbox a) => + Int -> RingArray a -> (a -> (a, b)) -> m b +modifyIndex = undefined + +-- | /O(1)/ Write the given element at the given index relative to the current +-- position of the ring head. Index starts at 0, could be positive or negative. +-- +-- Throws an error if the index is more than or equal to the size of the ring. +-- +-- Performs in-place mutation of the array. +-- +{-# INLINE putIndex #-} +putIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> a -> m () +-- putIndex ix ring val = modifyIndex ix ring (const (val, ())) +putIndex i ring x = + -- Note: ring must be of non-zero size. + let j = changeHeadByOffset (ringHead ring) (ringSize ring) (i * SIZE_OF(a)) + in liftIO $ pokeAt j (ringContents ring) x + +-- XXX Expand the ring by inserting the newest element before the head. If the +-- number of elements before the head are lesser than the ones after it then +-- shift them all by one place to the left, moving the first element at the end +-- of the ring. Otherwise, shift the elements after the head by one place to +-- the right. Note this requires adding a capacity field to the ring. Also, +-- like mutarray we can reallocate the ring to expand the capacity. + +-- | Insert a new element without replacing an old one. Expands the size of the +-- ring. This is similar to the snoc operation for MutArray. +-- +-- /Unimplemented/ +{-# INLINE insert #-} +insert :: -- (MonadIO m, Unbox a) => + RingArray a -> a -> m (RingArray a) +insert = undefined + +-- | Like 'replace' but does not return the old value of overwritten element. +-- +-- Same as: +-- +-- >>> replace_ rb x = RingArray.putIndex 0 rb x >> pure (RingArray.moveForward rb) +-- +{-# INLINE replace_ #-} +replace_ :: forall m a. (MonadIO m, Unbox a) => RingArray a -> a -> m (RingArray a) +replace_ rb newVal = do + -- Note poke will corrupt memory if the ring size is 0. + when (ringSize rb /= 0) + $ liftIO $ pokeAt (ringHead rb) (ringContents rb) newVal + pure $ moveForward rb + +-- | Return the element at the specified index without checking the bounds. +-- +-- Unsafe because it does not check the bounds of the ring array. +{-# INLINE unsafeGetRawIndex #-} +unsafeGetRawIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> m a +unsafeGetRawIndex i ring = liftIO $ peekAt i (ringContents ring) + +-- | Replace the oldest item in the ring (the item at the ring head) with a new +-- item and move the ring head to the remaining oldest item. +-- +-- Throws an error if the ring is empty. +-- +{-# INLINE replace #-} +replace :: forall m a. (MonadIO m, Unbox a) => RingArray a -> a -> m (RingArray a, a) +replace rb newVal = do + -- Note: ring size cannot be zero. + when (ringSize rb == 0) $ + error "insert: cannot insert in 0 sized ring" + old <- unsafeGetRawIndex (ringHead rb) rb + liftIO $ pokeAt (ringHead rb) (ringContents rb) newVal + pure (moveForward rb, old) + +------------------------------------------------------------------------------- +-- Random reads +------------------------------------------------------------------------------- + +-- | Like 'getIndex' but does not check the bounds. Unpredictable behavior +-- occurs if the index is more than or equal to the ring size. +{-# INLINE unsafeGetIndex #-} +unsafeGetIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> m a +unsafeGetIndex i ring = + let rs = ringSize ring + j = unsafeChangeHeadByOffset (ringHead ring) rs (i * SIZE_OF(a)) + in unsafeGetRawIndex j ring + +-- | /O(1)/ Lookup the element at the given index relative to the ring head. +-- Index starts from 0, could be positive or negative. Returns Nothing if the +-- index is more than or equal to the size of the ring. +-- +{-# INLINE getIndex #-} +getIndex :: forall m a. (MonadIO m, Unbox a) => Int -> RingArray a -> m (Maybe a) +getIndex i ring = + let rs = ringSize ring + in if i < rs && i > -rs + then Just <$> unsafeGetIndex i ring + else return Nothing + +-- | /O(1)/ Lookup the element at the head position. +-- +-- Prefer this over @unsafeGetIndex 0@ as it does not have have to perform an +-- index rollover check. +-- +{-# INLINE unsafeGetHead #-} +unsafeGetHead :: (MonadIO m, Unbox a) => RingArray a -> m a +unsafeGetHead ring = unsafeGetRawIndex (ringHead ring) ring + +------------------------------------------------------------------------------- +-- Size +------------------------------------------------------------------------------- + +-- | /O(1)/ Get the byte length of the ring. +-- +{-# INLINE byteLength #-} +byteLength :: RingArray a -> Int +byteLength = ringSize + +-- | /O(1)/ Get the length of the ring. i.e. the number of elements in the +-- ring. +-- +{-# INLINE length #-} +length :: forall a. Unbox a => RingArray a -> Int +length rb = ringSize rb `div` SIZE_OF(a) + +------------------------------------------------------------------------------- +-- Unfolds +------------------------------------------------------------------------------- + +-- | Read the entire ring, starting at the ring head i.e. from oldest to +-- newest. +-- +{-# INLINE_NORMAL reader #-} +reader :: forall m a. (MonadIO m, Unbox a) => Unfold m (RingArray a) a +reader = Unfold step inject + + where + + inject rb = return (rb, ringSize rb) + + step (rb, n) = do + if n <= 0 + then return Stop + else do + x <- unsafeGetHead rb + return $ Yield x (moveForward rb, n - SIZE_OF(a)) + +-- | Read the entire ring in reverse order, starting at the item before the +-- ring head i.e. from newest to oldest +-- +{-# INLINE_NORMAL readerRev #-} +readerRev :: forall m a. (MonadIO m, Unbox a) => Unfold m (RingArray a) a +readerRev = Unfold step inject + + where + + inject rb = return (moveReverse rb, ringSize rb) + + step (rb, n) = do + if n <= 0 + then return Stop + else do + x <- unsafeGetHead rb + return $ Yield x (moveReverse rb, n - SIZE_OF(a)) + +-- | Read the entire ring as a stream, starting at the ring head i.e. from +-- oldest to newest. +-- +{-# INLINE_NORMAL read #-} +read :: forall m a. (MonadIO m, Unbox a) => RingArray a -> Stream m a +read = Stream.unfold reader + +-- | Read the entire ring as a stream, starting from newest to oldest elements. +-- +{-# INLINE_NORMAL readRev #-} +readRev :: forall m a. (MonadIO m, Unbox a) => RingArray a -> Stream m a +readRev = Stream.unfold readerRev + +------------------------------------------------------------------------------- +-- Stream of arrays +------------------------------------------------------------------------------- + +-- | @scanRingsOf n@ groups the input stream into a stream of ring arrays of +-- size up to @n@. The first ring would be of size 1, then 2, and so on up to +-- size n, when size n is reached the ring starts sliding out the oldest +-- elements and keeps the newest n elements. +-- +-- Note that the ring emitted is a mutable reference, therefore, should not be +-- retained without copying otherwise the contents will change in the next +-- iteration of the stream. +-- +{-# INLINE scanRingsOf #-} +scanRingsOf :: forall m a. (MonadIO m, Unbox a) => Int -> Scanl m a (RingArray a) +scanRingsOf n = Scanl step initial extract extract + + where + + rSize = n * SIZE_OF(a) + + initial = + if n <= 0 + then error "scanRingsOf: window size must be > 0" + else do + mba <- liftIO $ MutByteArray.new rSize + return $ Partial $ Tuple3Fused' mba 0 0 + + step (Tuple3Fused' mba rh offset) a = do + RingArray _ _ rh1 <- replace_ (RingArray mba rSize rh) a + let offset1 = offset + SIZE_OF(a) + return $ Partial $ Tuple3Fused' mba rh1 offset1 + + -- XXX exitify optimization causes a problem here when modular folds are + -- used. Sometimes inlining "extract" is helpful. + {-# INLINE extract #-} + extract (Tuple3Fused' mba rh offset) = + let rs = min offset rSize + rh1 = if offset <= rSize then 0 else rh + in pure $ RingArray mba rs rh1 + +-- | @ringsOf n stream@ groups the input stream into a stream of ring arrays of +-- size up to n. See 'scanRingsOf' for more details. +-- +{-# INLINE_NORMAL ringsOf #-} +ringsOf :: forall m a. (MonadIO m, Unbox a) => + Int -> Stream m a -> Stream m (RingArray a) +ringsOf n = Stream.postscanl (scanRingsOf n) + +-- XXX to keep the order intact use RingArray.read. If order is not important for +-- the fold then we can use asMutArray which could be slightly faster. +-- f1 rb = Stream.fold f $ MutArray.read $ fst $ RingArray.asMutArray rb + +-- XXX the size and the array pointer are constant in the stream, only the head +-- changes on each tick. So we can just emit the head in the loop and keep the +-- size and pointer global. + +{-# INLINE_NORMAL scanCustomFoldRingsBy #-} +scanCustomFoldRingsBy :: forall m a b. (MonadIO m, Unbox a) => + (RingArray a -> m b) -> Int -> Scanl m a b +-- Custom RingArray.fold performs better than the idiomatic implementations below, +-- perhaps because of some GHC optimization effect. +scanCustomFoldRingsBy f = Scanl.rmapM f . scanRingsOf + +-- | Apply the given fold on sliding windows of the given size. Note that this +-- could be expensive because each operation goes through the entire window. +-- This should be used only if there is no efficient alternative way possible. +-- +-- Examples: +-- +-- >>> windowRange = RingArray.scanFoldRingsBy Fold.range +-- >>> windowMinimum = RingArray.scanFoldRingsBy Fold.minimum +-- >>> windowMaximum = RingArray.scanFoldRingsBy Fold.maximum +-- +{-# INLINE scanFoldRingsBy #-} +scanFoldRingsBy :: forall m a b. (MonadIO m, Unbox a) => + Fold m a b -> Int -> Scanl m a b +-- Custom RingArray.fold performs better than the idiomatic implementations below, +-- perhaps because of some GHC optimization effect. +scanFoldRingsBy f = scanCustomFoldRingsBy (fold f) +-- scanFoldRingsBy f = Scanl.rmapM (fold f) . scanRingsOf +-- scanFoldRingsBy f = Scanl.rmapM (Unfold.fold f reader) . scanRingsOf +-- scanFoldRingsBy f = Scanl.rmapM (Stream.fold f . read) . scanRingsOf + + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +-- | @createOfLast n@ returns the last n elements of the stream in a ring +-- array. @n@ must be non-zero. +-- +{-# INLINE createOfLast #-} +createOfLast :: (Unbox a, MonadIO m) => Int -> Fold m a (RingArray a) +createOfLast n = Fold.fromScanl $ scanRingsOf n + +------------------------------------------------------------------------------- +-- Casting +------------------------------------------------------------------------------- + +-- | Cast a ring having elements of type @a@ into a ring having elements of +-- type @b@. The ring size must be a multiple of the size of type @b@. +-- +{-# INLINE unsafeCast #-} +unsafeCast :: RingArray a -> RingArray b +unsafeCast RingArray{..} = + RingArray + { ringContents = ringContents + , ringHead = ringHead + , ringSize = ringSize + } + +-- | Cast a @RingArray a@ into a @RingArray Word8@. +-- +asBytes :: RingArray a -> RingArray Word8 +asBytes = unsafeCast + +-- | Cast a ring having elements of type @a@ into a ring having elements of +-- type @b@. The length of the ring should be a multiple of the size of the +-- target element otherwise 'Nothing' is returned. +-- +{-# INLINE cast #-} +cast :: forall a b. (Unbox b) => RingArray a -> Maybe (RingArray b) +cast ring = + let len = byteLength ring + r = len `mod` SIZE_OF(b) + in if r /= 0 + then Nothing + else Just $ unsafeCast ring + +------------------------------------------------------------------------------- +-- Equality +------------------------------------------------------------------------------- + +-- | Like 'eqArray' but compares only N bytes instead of entire length of the +-- ring buffer. If N is bigger than the ring or array size, it is treated as an +-- error. +-- +{-# INLINE eqArrayN #-} +eqArrayN :: RingArray a -> Array a -> Int -> IO Bool +eqArrayN RingArray{..} Array.Array{..} nBytes + | nBytes < 0 = error "eqArrayN: n should be >= 0" + | arrEnd - arrStart < nBytes = error "eqArrayN: array is shorter than n" + | ringSize < nBytes = error "eqArrayN: ring is shorter than n" + | nBytes == 0 = return True + | nBytes <= p1Len = do + part1 <- + MutByteArray.unsafeByteCmp + arrContents 0 ringContents ringHead nBytes + pure $ part1 == 0 + | otherwise = do + part1 <- + MutByteArray.unsafeByteCmp + arrContents 0 ringContents ringHead p1Len + part2 <- + MutByteArray.unsafeByteCmp arrContents p1Len ringContents 0 p2Len + pure $ part1 == 0 && part2 == 0 + where + p1Len = ringSize - ringHead + p2Len = nBytes - p1Len + +-- | Byte compare the entire length of ringBuffer with the given array, +-- starting at the supplied ring head index. Returns true if the Array and +-- the ring have identical contents. If the array is bigger checks only +-- up to the ring length. If array is shorter than then ring, it is treated as +-- an error. +-- +{-# INLINE eqArray #-} +eqArray :: RingArray a -> Array a -> IO Bool +eqArray RingArray{..} Array.Array{..} + | arrEnd - arrStart < ringSize = + error "eqArrayN: array is shorter than ring" + | otherwise = do + part1 <- + MutByteArray.unsafeByteCmp + arrContents 0 ringContents ringHead p1Len + part2 <- + MutByteArray.unsafeByteCmp + arrContents p1Len ringContents 0 p2Len + pure $ part1 == 0 && part2 == 0 + where + p1Len = ringSize - ringHead + p2Len = ringHead + +------------------------------------------------------------------------------- +-- Folding +------------------------------------------------------------------------------- + +-- Note: INLINE_NORMAL is important for use in scanFoldRingsBy + +-- | Fold the entire length of a ring buffer starting at the current ring head. +-- +{-# INLINE_NORMAL fold #-} +fold :: forall m a b. (MonadIO m, Unbox a) + => Fold m a b -> RingArray a -> m b +-- These are slower when used in a scan extract. One of the issues is the +-- exitify optimization, there could be others. +-- fold f rb = Unfold.fold f reader rb +-- fold f rb = Stream.fold f $ read rb +fold (Fold step initial _ final) rb = do + res <- initial + case res of + Fold.Partial fs -> go SPEC rh fs + Fold.Done b -> return b + + where + + rh = ringHead rb + + -- Note: Passing the SPEC arg seems to give better results in windowRange + -- benchmarks for larger windows, while worse results for smaller windows. + {-# INLINE go #-} + go !_ index !fs = do + x <- unsafeGetRawIndex index rb + r <- step fs x + case r of + Fold.Done b -> return b + Fold.Partial s -> do + let next = incrHeadByOffset index (ringSize rb) (SIZE_OF(a)) + if next == rh + then final s + else go SPEC next s + +-- XXX This was for folding when the ring is not full, now we do not support +-- that so this should not be needed. + +-- | Fold the buffer starting from ringStart up to the given index using a pure +-- step function. This is useful to fold the items in the ring when the ring is +-- not full. The supplied index is usually the end of the ring. +-- +-- Unsafe because the supplied index is not checked to be in range. +{-# DEPRECATED unsafeFoldRing "This function will be removed in future." #-} +{-# INLINE unsafeFoldRing #-} +unsafeFoldRing :: forall a b. Unbox a + => Int -> (b -> a -> b) -> b -> RingArray a -> IO b +unsafeFoldRing !len f z rb = go z 0 + + where + + go !acc !index + | index == len = return acc + | otherwise = do + x <- unsafeGetRawIndex index rb + go (f acc x) (index + SIZE_OF(a)) + +-- | Like unsafeFoldRing but with a monadic step function. +{-# DEPRECATED unsafeFoldRingM "This function will be removed in future." #-} +{-# INLINE unsafeFoldRingM #-} +unsafeFoldRingM :: forall m a b. (MonadIO m, Unbox a) + => Int -> (b -> a -> m b) -> b -> RingArray a -> m b +unsafeFoldRingM !len f z rb = go z 0 + + where + + go !acc !index + | index == len = return acc + | otherwise = do + x <- unsafeGetRawIndex index rb + acc1 <- f acc x + go acc1 (index + SIZE_OF(a)) + +-- | Fold the entire length of a ring buffer starting at the current ring head. +-- +-- Note, this will crash on ring of 0 size. +-- +{-# INLINE foldlM' #-} +foldlM' :: forall m a b. (MonadIO m, Unbox a) + => (b -> a -> m b) -> b -> RingArray a -> m b +foldlM' f z = fold (Fold.foldlM' f (pure z)) + +-- These are slower when used in a scan extract. One of the issues is the +-- exitify optimization, there could be others. +-- foldlM' f z rb = Unfold.fold (Fold.foldlM' f (pure z)) reader rb +-- foldlM' f z rb = Stream.fold (Fold.foldlM' f (pure z)) $ read rb + +{- +foldlM' f z rb = go z rh + + where + + rh = ringHead rb + + go !acc !index = do + x <- unsafeGetRawIndex index rb + acc' <- f acc x + let next = incrHeadByOffset index (ringSize rb) (SIZE_OF(a)) + if next == rh + then return acc' + else go acc' next +-} + +{-# DEPRECATED unsafeFoldRingFullM "This function will be removed in future." #-} +{-# INLINE unsafeFoldRingFullM #-} +unsafeFoldRingFullM :: forall m a b. (MonadIO m, Unbox a) + => (b -> a -> m b) -> b -> RingArray a -> m b +unsafeFoldRingFullM = foldlM' + +-- | Fold @n@ items in the ring starting at the ring head. Won't fold more +-- than the length of the ring even if @n@ is larger. +-- +-- Note, this will crash on ring of 0 size. +-- +{-# DEPRECATED unsafeFoldRingNM "This function will be removed in future." #-} +{-# INLINE unsafeFoldRingNM #-} +unsafeFoldRingNM :: forall m a b. (MonadIO m, Unbox a) + => Int -> (b -> a -> m b) -> b -> RingArray a -> m b +unsafeFoldRingNM count f z rb = go count z rh + + where + + rh = ringHead rb + + go 0 acc _ = return acc + go !n !acc !index = do + x <- unsafeGetRawIndex index rb + acc' <- f acc x + let next = unsafeChangeHeadByOffset index (ringSize rb) (SIZE_OF(a)) + if next == rh || n == 0 + then return acc' + else go (n - 1) acc' next + +-- | Cast the ring to a mutable array. Return the mutable array as well as the +-- current position of the ring head. Note that the array does not start with +-- the current ring head. The array refers to the same memory as the ring. +{-# INLINE asMutArray #-} +asMutArray :: RingArray a -> (MutArray a, Int) +asMutArray rb = + ( MutArray + { arrContents = ringContents rb + , arrStart = 0 + , arrEnd = ringSize rb + , arrBound = ringSize rb + } + , ringHead rb + ) + +-- | Like 'asMutArray' but does not return the ring head. +-- +-- >>> asMutArray_ = fst . RingArray.asMutArray +-- +{-# INLINE asMutArray_ #-} +asMutArray_ :: RingArray a -> MutArray a +asMutArray_ rb = + MutArray + { arrContents = ringContents rb + , arrStart = 0 + , arrEnd = ringSize rb + , arrBound = ringSize rb + } + +-- XXX We can use bulk copy using memcpy or at least a Word64 at a time. + +-- | Copy the ring to a MutArray, the first element of the MutArray is the +-- oldest element of the ring (i.e. ring head) and the last is the newest. +-- +-- >>> toMutArray rb = Stream.fold (MutArray.createOf (RingArray.length rb)) $ RingArray.read rb +-- +{-# INLINE toMutArray #-} +toMutArray :: (MonadIO m, Unbox a) => RingArray a -> m (MutArray a) +toMutArray rb = MutArray.fromStreamN (length rb) $ read rb +{- +toMutArray rb = do + -- Using unpinned array here instead of pinned + arr <- liftIO $ MutArray.emptyOf (length rb) + let snoc' b a = liftIO $ MutArray.unsafeSnoc b a + foldlM' snoc' arr rb +-} + +-- | Copy the ring to a list, the first element of the list is the oldest +-- element of the ring (i.e. ring head) and the last is the newest. +-- +-- >>> toList = Stream.toList . RingArray.read +-- +{-# INLINE toList #-} +toList :: (MonadIO m, Unbox a) => RingArray a -> m [a] +toList = Stream.toList . read + +-- | Show the contents of a RingArray as a list. +-- +-- >>> showRing rb = RingArray.toList rb >>= return . show +-- +showRing :: (Unbox a, Show a) => RingArray a -> IO String +showRing rb = show <$> toList rb + +{-# ANN type SlidingWindow Fuse #-} +data SlidingWindow a s = SWArray !a !Int !s !Int | SWRing !a !Int !s + +-- | Like slidingWindow but also provides the entire ring contents as an Array. +-- The array reflects the state of the ring after inserting the incoming +-- element. +-- +-- IMPORTANT NOTE: The ring is mutable, therefore, the result of @(m (Array +-- a))@ action depends on when it is executed. It does not capture the sanpshot +-- of the ring at a particular time. +{-# DEPRECATED slidingWindowWith "Please use Scanl.incrScanWith instead." #-} +{-# INLINE slidingWindowWith #-} +slidingWindowWith :: forall m a b. (MonadIO m, Unbox a) + => Int -> Fold m ((a, Maybe a), m (MutArray a)) b -> Fold m a b +slidingWindowWith n (Fold step1 initial1 extract1 final1) = + Fold step initial extract final + + where + + initial = do + if n <= 0 + then error "Window size must be > 0" + else do + r <- initial1 + arr :: MutArray.MutArray a <- liftIO $ MutArray.emptyOf n + return $ + case r of + Partial s -> Partial + $ SWArray (MutArray.arrContents arr) 0 s (n - 1) + Done b -> Done b + + step (SWArray mba rh st i) a = do + RingArray _ _ rh1 <- replace_ (RingArray mba (n * SIZE_OF(a)) rh) a + let size = (n - i) * SIZE_OF(a) + r <- step1 st ((a, Nothing), pure (MutArray mba 0 size size)) + return $ + case r of + Partial s -> + if i > 0 + then Partial $ SWArray mba rh1 s (i - 1) + else Partial $ SWRing mba rh1 s + Done b -> Done b + + step (SWRing mba rh st) a = do + (rb1@(RingArray _ _ rh1), old) <- + replace (RingArray mba (n * SIZE_OF(a)) rh) a + r <- step1 st ((a, Just old), toMutArray rb1) + return $ + case r of + Partial s -> Partial $ SWRing mba rh1 s + Done b -> Done b + + extract (SWArray _ _ st _) = extract1 st + extract (SWRing _ _ st) = extract1 st + + final (SWArray _ _ st _) = final1 st + final (SWRing _ _ st) = final1 st + +-- | @slidingWindow collector@ is an incremental sliding window +-- fold that does not require all the intermediate elements in a computation. +-- This maintains @n@ elements in the window, when a new element comes it slides +-- out the oldest element and the new element along with the old element are +-- supplied to the collector fold. +-- +-- The 'Maybe' type is for the case when initially the window is filling and +-- there is no old element. +-- +{-# DEPRECATED slidingWindow "Please use Scanl.incrScan instead." #-} +{-# INLINE slidingWindow #-} +slidingWindow :: forall m a b. (MonadIO m, Unbox a) + => Int -> Fold m (a, Maybe a) b -> Fold m a b +slidingWindow n f = slidingWindowWith n (lmap fst f) diff --git a/src/Streamly/Internal/Data/RingArray/Generic.hs b/src/Streamly/Internal/Data/RingArray/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/RingArray/Generic.hs @@ -0,0 +1,189 @@ +-- | +-- Module : Streamly.Internal.Data.RingArray.Generic +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Streamly.Internal.Data.RingArray.Generic + ( RingArray(..) + , Ring + + -- * Generation + , emptyOf + , createOf + + -- * Modification + , seek + , unsafeInsertRingWith + + -- * Conversion + , toMutArray + , copyToMutArray + , toStreamWith + ) where + +#include "assert.hs" + +import Control.Monad.IO.Class (liftIO, MonadIO) +import Streamly.Internal.Data.Stream.Type (Stream) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.MutArray.Generic (MutArray(..)) + +-- import qualified Streamly.Internal.Data.Stream.Type as Stream +import qualified Streamly.Internal.Data.Fold.Type as Fold +import qualified Streamly.Internal.Data.MutArray.Generic as MutArray + +-- XXX Use MutableArray rather than keeping a MutArray here. +data RingArray a = RingArray + { ringArr :: MutArray a + -- XXX We can keep the current fill amount, Or we can keep a count of total + -- elements inserted and compute ring head as well using mod on that, + -- assuming it won't overflow. But mod could be expensive. + , ringHead :: !Int -- current index to be over-written + , ringMax :: !Int -- first index beyond allocated memory + } + +{-# DEPRECATED Ring "Please use RingArray instead." #-} +type Ring = RingArray + +------------------------------------------------------------------------------- +-- Generation +------------------------------------------------------------------------------- + +-- XXX If we align the ringMax to nearest power of two then computation of the +-- index to write could be cheaper. +{-# INLINE emptyOf #-} +emptyOf :: MonadIO m => Int -> m (RingArray a) +emptyOf count = liftIO $ do + arr <- MutArray.emptyOf count + arr1 <- MutArray.uninit arr count + return (RingArray + { ringArr = arr1 + , ringHead = 0 + , ringMax = count + }) + + +-- | Note that it is not safe to return a reference to the mutable RingArray using a +-- scan as the RingArray is continuously getting mutated. You could however copy out +-- the RingArray. +{-# INLINE createOf #-} +createOf :: MonadIO m => Int -> Fold m a (RingArray a) +createOf n = Fold step initial extract extract + + where + + initial = do + if n <= 0 + then Fold.Done <$> emptyOf 0 + else do + rb <- emptyOf n + return $ Fold.Partial $ Tuple' rb (0 :: Int) + + step (Tuple' rb cnt) x = do + rh1 <- liftIO $ unsafeInsertRingWith rb x + return $ Fold.Partial $ Tuple' (rb {ringHead = rh1}) (cnt + 1) + + extract (Tuple' rb@RingArray{..} cnt) = + return $ + if cnt < ringMax + then RingArray ringArr 0 ringHead + else rb + +------------------------------------------------------------------------------- +-- Modification +------------------------------------------------------------------------------- + +-- XXX This is safe +-- Take the ring head and return the new ring head. +{-# INLINE unsafeInsertRingWith #-} +unsafeInsertRingWith :: RingArray a -> a -> IO Int +unsafeInsertRingWith RingArray{..} x = do + assertM(ringMax >= 1) + assertM(ringHead < ringMax) + MutArray.unsafePutIndex ringHead ringArr x + let rh1 = ringHead + 1 + next = if rh1 == ringMax then 0 else rh1 + return next + +-- | Move the ring head clockwise (+ve adj) or counter clockwise (-ve adj) by +-- the given amount. +{-# INLINE seek #-} +seek :: MonadIO m => Int -> RingArray a -> m (RingArray a) +seek adj rng@RingArray{..} + | ringMax > 0 = liftIO $ do + -- XXX try avoiding mod when in bounds + let idx1 = ringHead + adj + next = mod idx1 ringMax + return $ RingArray ringArr next ringMax + | otherwise = pure rng + +------------------------------------------------------------------------------- +-- Conversion +------------------------------------------------------------------------------- + +-- | @toMutArray rignHeadAdjustment lengthToRead ring@. +-- Convert the ring into a boxed mutable array. Note that the returned MutArray +-- shares the same underlying memory as the RingArray, the user of this API needs to +-- ensure that the ring is not mutated during and after the conversion. +-- +{-# INLINE toMutArray #-} +toMutArray :: MonadIO m => Int -> Int -> RingArray a -> m (MutArray a) +toMutArray adj n RingArray{..} = + -- XXX for empty RingArray it will raise an Exception: divide by zero + if ringMax <= 0 + then MutArray.nil + else do + let len = min ringMax n + let idx = mod (ringHead + adj) ringMax + end = idx + len + if end <= ringMax + then + return $ ringArr { arrStart = idx, arrEnd = end } + else do + -- XXX Just swap the elements in the existing ring and return the + -- same array without reallocation. + arr <- liftIO $ MutArray.emptyOf len + arr1 <- MutArray.uninit arr len + MutArray.unsafePutSlice ringArr idx arr1 0 (ringMax - idx) + MutArray.unsafePutSlice ringArr 0 arr1 (ringMax - idx) (end - ringMax) + return arr1 + +-- | Copy out the mutable ring to a mutable Array. +{-# INLINE copyToMutArray #-} +copyToMutArray :: MonadIO m => Int -> Int -> RingArray a -> m (MutArray a) +copyToMutArray adj n RingArray{..} = do + if ringMax <= 0 + then MutArray.nil + else do + let len = min ringMax n + let idx = mod (ringHead + adj) ringMax + end = idx + len + arr <- MutArray.emptyOf len + arr1 <- MutArray.uninit arr len + MutArray.unsafePutSlice ringArr idx arr1 0 (ringMax - idx) + MutArray.unsafePutSlice ringArr 0 arr1 (ringMax - idx) (end - ringMax) + return arr1 + +-- This would be theoretically slower than toMutArray because of a branch +-- introduced for each element in the second half of the ring. + +-- | Seek by n and then read the entire ring. Use 'take' on the stream to +-- restrict the reads. +toStreamWith :: Int -> RingArray a -> Stream m a +toStreamWith = undefined +{- +toStreamWith n RingArray{..} + | ringMax > 0 = concatEffect $ liftIO $ do + idx <- readIORef ringHead + let idx1 = idx + adj + next = mod idx1 ringMax + s1 = undefined -- stream initial slice + s2 = undefined -- stream next slice + return (s1 `Stream.append` s2) + | otherwise = Stream.nil +-} diff --git a/src/Streamly/Internal/Data/Scanl.hs b/src/Streamly/Internal/Data/Scanl.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Scanl.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Scanl +-- Copyright : (c) 2024 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Left scans. +-- +-- == Scanl vs Fold +-- +-- Folds and scans both are consumers of streams. A left scan is a +-- generalization of a fold. While the output of a fold is a singleton value, +-- the output of a scan is a stream. A fold is equivalent to a left scan which +-- produces only the final value in the output stream. +-- +-- Like folds, a scan has an internal state. Unlike a fold, a scan produces an +-- output on each input, the output is a function of the scan state and the +-- input. +-- +-- A @Scanl m a b@ can represent a @Fold m a b@ by discarding the intermediate +-- outputs and keeping only the final output of the scan. +-- +-- Since folds do not care about intermediate values, we do not need the +-- extract function for folds. Because folds do not have a requirement for +-- intermediate values, they can be used for implementing combinators like +-- splitWith where intermediate values are not meaningful and are expensive to +-- compute. Folds provide an applicative and monad behavior to consume the +-- stream in parts and compose the folded results. Scans provide Category like +-- composition and stream zip applicative behavior. The finalization function +-- of a fold would return a single value whereas for scan it may be a stream +-- draining the scan buffer. For these reasons, scans and folds are required as +-- independent abstractions. +-- +-- == Scanl vs Pipe +-- +-- A scan is a simpler version of the consumer side of pipes. A left scan +-- always produces an output whereas a pipe has an additional ability to skip +-- output. Scans are simpler abstractions to think about compared to pipes and +-- easier for the compiler to optimize and fuse. +-- +-- == Compositions +-- +-- Scans can be chained in the same way as function composition (Category) and +-- can distribute input (tee Applicative). Folds provide an applicative and +-- monad behavior to consume the stream in parts and compose the folded +-- results. Folds are also a special case of parsers. + +-- TBD: A scan can produce more than one output on an input, in other words, +-- it can produce output on its own. +-- +module Streamly.Internal.Data.Scanl + ( + -- * Imports + -- $setup + + module Streamly.Internal.Data.Scanl.Type + , module Streamly.Internal.Data.Scanl.Window + , module Streamly.Internal.Data.Scanl.Combinators + , module Streamly.Internal.Data.Scanl.Container + ) +where + +import Streamly.Internal.Data.Scanl.Window +import Streamly.Internal.Data.Scanl.Combinators +import Streamly.Internal.Data.Scanl.Container +import Streamly.Internal.Data.Scanl.Type + +#include "DocTestDataFold.hs" diff --git a/src/Streamly/Internal/Data/Scanl/Combinators.hs b/src/Streamly/Internal/Data/Scanl/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Scanl/Combinators.hs @@ -0,0 +1,2393 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Scanl.Combinators +-- Copyright : (c) 2024 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Streamly.Internal.Data.Scanl.Combinators + ( + -- * Scans + + -- ** Accumulators + -- *** Semigroups and Monoids + sconcat + , mconcat + , foldMap + , foldMapM + + -- *** Reducers + , drainMapM + , the + , mean + , rollingHash + , defaultSalt + , rollingHashWithSalt + , rollingHashFirstN + -- , rollingHashLastN + + -- *** Saturating Reducers + -- | 'product' terminates if it becomes 0. Other scans can theoretically + -- saturate on bounded types, and therefore terminate, however, they will + -- run forever on unbounded types like Integer/Double. + , sum + , product + + -- *** Collectors + -- | Avoid using these scans in scalable or performance critical + -- applications, they buffer all the input in GC memory which can be + -- detrimental to performance if the input is large. + , toListRev + -- $toListRev + , toStream + , toStreamRev + , topBy + , top + , bottomBy + , bottom + + -- *** Scanners + -- | Stateful transformation of the elements. Useful in combination with + -- the 'postscanlMaybe' combinator. For scanners the result of the scan is + -- usually a transformation of the current element rather than an + -- aggregation of all elements till now. + -- , nthLast -- using RingArray array + , indexingWith + , indexing + , indexingRev + , rollingMap + , rollingMapM + + -- *** Filters + -- | Useful in combination with the 'postscanlMaybe' combinator. + , deleteBy + , uniqBy + , uniq + , repeated + , findIndices + , elemIndices + + {- + -- *** Singleton scans + -- | Scans that terminate after consuming exactly one input element. All + -- these can be implemented in terms of the 'maybe' scan. + , one + , null -- XXX not very useful and could be problematic, remove it? + , satisfy + , maybe + -} + + -- *** Multi scans + -- | Terminate after consuming one or more elements. + , drainN + {- + -- , lastN + -- , (!!) + , genericIndex + , index + , findM + , find + , lookup + , findIndex + , elemIndex + , elem + , notElem + , all + , any + , and + , or + -} + + -- ** Trimmers + -- | Useful in combination with the 'postscanlMaybe' combinator. + , takingEndByM + , takingEndBy + , takingEndByM_ + , takingEndBy_ + , droppingWhileM + , droppingWhile + , prune + + -- -- * Running A Scanl + -- , drive + -- , breakStream + + -- -- * Building Incrementally + -- , addStream + + -- * Combinators + -- ** Utilities + , with + + -- -- ** Sliding Window + -- , slide2 + + -- ** Scanning Input + , scanl + , scanlMany + -- , runScan + , pipe + , indexed + + -- ** Zipping Input + , zipStreamWithM + , zipStream + + -- ** Filtering Input + , mapMaybeM + , mapMaybe + , sampleFromthen + + {- + -- ** Insertion + -- | Insertion adds more elements to the stream. + + , insertBy + , intersperseM + + -- ** Reordering + , reverse + -} + + -- -- ** Trimming + + -- By elements + -- , takeEndBySeq + -- , takeEndBySeq_ + {- + , drop + , dropWhile + , dropWhileM + -} + + -- -- ** Serial Append + -- , tail + -- , init + -- , splitAt -- spanN + -- , splitIn -- sessionN + + -- ** Parallel Distribution + , tee + , distribute + -- , distributeFst + -- , distributeMin + + -- ** Unzipping + , unzip + -- These two can be expressed using lmap/lmapM and unzip + , unzipWith + , unzipWithM + -- , unzipWithFstM + -- , unzipWithMaxM + + -- ** Partitioning + , partitionByM + -- , partitionByFstM + -- , partitionByMinM + , partitionBy + , partition + + -- -- ** Splitting + -- , chunksBetween + -- , intersperseWithQuotes + + -- ** Nesting + , unfoldMany + -- , concatSequence + ) +where + +#include "inline.hs" +#include "ArrayMacros.h" + +-- import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Bifunctor (first) +-- import Data.Bits (shiftL, shiftR, (.|.), (.&.)) +-- import Data.Either (isLeft, isRight, fromLeft, fromRight) +import Data.Int (Int64) +-- import Data.Proxy (Proxy(..)) +-- import Data.Word (Word32) +import Streamly.Internal.Data.Unbox (Unbox(..)) +import Streamly.Internal.Data.MutArray.Type (MutArray(..)) +import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) +import Streamly.Internal.Data.Pipe.Type (Pipe (..)) +-- import Streamly.Internal.Data.Scan (Scan (..)) +import Streamly.Internal.Data.Stream.Type (Stream) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) + +import qualified Prelude +import qualified Streamly.Internal.Data.MutArray.Type as MA +-- import qualified Streamly.Internal.Data.Array.Type as Array +import qualified Streamly.Internal.Data.Scanl.Window as Scanl +import qualified Streamly.Internal.Data.Pipe.Type as Pipe +-- import qualified Streamly.Internal.Data.RingArray as RingArray +import qualified Streamly.Internal.Data.Stream.Type as StreamD + +import Streamly.Internal.Data.Scanl.Type +import Prelude hiding + ( Foldable(..), filter, drop, dropWhile, take, takeWhile, zipWith + , map, mapM_, sequence, all, any + , notElem, head, last, tail + , reverse, iterate, init, and, or, lookup, (!!) + , scanl, scanl1, replicate, concatMap, mconcat, unzip + , span, splitAt, break, mapM, zip, maybe, const) + +#include "DocTestDataScanl.hs" + +------------------------------------------------------------------------------ +-- Running +------------------------------------------------------------------------------ + +{- +-- | Drive a fold using the supplied 'Stream', reducing the resulting +-- expression strictly at each step. +-- +-- Definition: +-- +-- >>> drive = flip Stream.toList $ Stream.scanl +-- +-- Example: +-- +-- >>> Fold.drive (Stream.enumerateFromTo 1 100) Fold.sum +-- 5050 +-- +{-# INLINE drive #-} +drive :: Monad m => Stream m a -> Fold m a b -> m b +drive = flip StreamD.fold + +{- +-- | Like 'drive' but also returns the remaining stream. The resulting stream +-- would be 'Stream.nil' if the stream finished before the fold. +-- +-- Definition: +-- +-- >>> breakStream = flip Stream.toList $ Stream.scanlBreak +-- +-- /CPS/ +-- +{-# INLINE breakStreamK #-} +breakStreamK :: Monad m => StreamK m a -> Fold m a b -> m (b, StreamK m a) +breakStreamK strm fl = fmap f $ K.foldBreak fl (Stream.toStreamK strm) + + where + + f (b, str) = (b, Stream.fromStreamK str) +-} + +-- | Append a stream to a fold to build the fold accumulator incrementally. We +-- can repeatedly call 'addStream' on the same fold to continue building the +-- fold and finally use 'drive' to finish the fold and extract the result. Also +-- see the 'Streamly.Data.Fold.addOne' operation which is a singleton version +-- of 'addStream'. +-- +-- Definitions: +-- +-- >>> addStream stream = Fold.drive stream . Fold.duplicate +-- +-- Example, build a list incrementally: +-- +-- >>> :{ +-- pure (Fold.toList :: Fold IO Int [Int]) +-- >>= Fold.addOne 1 +-- >>= Fold.addStream (Stream.enumerateFromTo 2 4) +-- >>= Fold.drive Stream.nil +-- >>= print +-- :} +-- [1,2,3,4] +-- +-- This can be used as an O(n) list append compared to the O(n^2) @++@ when +-- used for incrementally building a list. +-- +-- Example, build a stream incrementally: +-- +-- >>> :{ +-- pure (Fold.toStream :: Fold IO Int (Stream Identity Int)) +-- >>= Fold.addOne 1 +-- >>= Fold.addStream (Stream.enumerateFromTo 2 4) +-- >>= Fold.drive Stream.nil +-- >>= print +-- :} +-- fromList [1,2,3,4] +-- +-- This can be used as an O(n) stream append compared to the O(n^2) @<>@ when +-- used for incrementally building a stream. +-- +-- Example, build an array incrementally: +-- +-- >>> :{ +-- pure (Array.write :: Fold IO Int (Array Int)) +-- >>= Fold.addOne 1 +-- >>= Fold.addStream (Stream.enumerateFromTo 2 4) +-- >>= Fold.drive Stream.nil +-- >>= print +-- :} +-- fromList [1,2,3,4] +-- +-- Example, build an array stream incrementally: +-- +-- >>> :{ +-- let f :: Fold IO Int (Stream Identity (Array Int)) +-- f = Fold.groupsOf 2 (Array.writeN 3) Fold.toStream +-- in pure f +-- >>= Fold.addOne 1 +-- >>= Fold.addStream (Stream.enumerateFromTo 2 4) +-- >>= Fold.drive Stream.nil +-- >>= print +-- :} +-- fromList [fromList [1,2],fromList [3,4]] +-- +addStream :: Monad m => Stream m a -> Scanl m a b -> m (Scanl m a b) +addStream stream = drive stream . duplicate +-} + +------------------------------------------------------------------------------ +-- Transformations on fold inputs +------------------------------------------------------------------------------ + +-- | +-- >>> mapMaybeM f = Scanl.lmapM f . Scanl.catMaybes +-- +{-# INLINE mapMaybeM #-} +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Scanl m b r -> Scanl m a r +mapMaybeM f = lmapM f . catMaybes + +-- | @mapMaybe f scan@ maps a 'Maybe' returning function @f@ on the input of +-- the scan, filters out 'Nothing' elements, and return the values extracted +-- from 'Just'. +-- +-- >>> mapMaybe f = Scanl.lmap f . Scanl.catMaybes +-- >>> mapMaybe f = Scanl.mapMaybeM (return . f) +-- +-- >>> f x = if even x then Just x else Nothing +-- >>> scn = Scanl.mapMaybe f Scanl.toList +-- >>> Stream.toList $ Stream.scanl scn (Stream.enumerateFromTo 1 10) +-- [[],[],[2],[2],[2,4],[2,4],[2,4,6],[2,4,6],[2,4,6,8],[2,4,6,8],[2,4,6,8,10]] +-- +{-# INLINE mapMaybe #-} +mapMaybe :: Monad m => (a -> Maybe b) -> Scanl m b r -> Scanl m a r +mapMaybe f = lmap f . catMaybes + +------------------------------------------------------------------------------ +-- Transformations on scan inputs +------------------------------------------------------------------------------ + +-- XXX rather scanl the input of a pipe? And scanr the output? +-- pipe :: Monad m => Scanl m a b -> Pipe m b c -> Scanl m a c +-- Can we do this too (in the pipe module): +-- pipe :: Monad m => Scanl m a b -> Pipe m b c -> Pipe m a c + +-- | Attach a 'Pipe' on the input of a 'Scanl'. +-- +-- /Pre-release/ +{-# INLINE pipe #-} +pipe :: Monad m => Pipe m a b -> Scanl m b c -> Scanl m a c +pipe (Pipe consume produce pinitial) (Scanl fstep finitial fextract ffinal) = + Scanl step initial extract final + + where + + initial = first (Tuple' pinitial) <$> finitial + + step (Tuple' cs fs) x = do + r <- consume cs x + go fs r + + where + + -- XXX use SPEC? + go acc (Pipe.YieldC cs1 b) = do + acc1 <- fstep acc b + return + $ case acc1 of + Partial s -> Partial $ Tuple' cs1 s + Done b1 -> Done b1 + -- XXX this case is recursive may cause fusion issues. + -- To remove recursion we will need a produce mode in scans which makes + -- scans similar to pipes except that they do not yield intermediate + -- values. + go acc (Pipe.YieldP ps1 b) = do + acc1 <- fstep acc b + r <- produce ps1 + case acc1 of + Partial s -> go s r + Done b1 -> return $ Done b1 + go acc (Pipe.SkipC cs1) = + return $ Partial $ Tuple' cs1 acc + -- XXX this case is recursive may cause fusion issues. + go acc (Pipe.SkipP ps1) = do + r <- produce ps1 + go acc r + -- XXX a Stop in consumer means we dropped the input. + -- XXX Need to use a "Done b" in pipes as well to represent the same + -- behavior as scans. + go acc Pipe.Stop = Done <$> ffinal acc + + extract (Tuple' _ fs) = fextract fs + + final (Tuple' _ fs) = ffinal fs + +{- +{-# INLINE runScanWith #-} +runScanWith :: Monad m => Bool -> Scan m a b -> Fold m b c -> Scanl m a c +runScanWith isMany + (Scan stepL initialL) + (Fold stepR initialR extractR finalR) = + Fold step initial extract final + + where + + step (sL, sR) x = do + rL <- stepL sL x + case rL of + StreamD.Yield b sL1 -> do + rR <- stepR sR b + case rR of + Partial sR1 -> return $ Partial (sL1, sR1) + Done bR -> return (Done bR) + StreamD.Skip sL1 -> return $ Partial (sL1, sR) + -- XXX We have dropped the input. + -- XXX Need same behavior for Stop in Fold so that the driver can + -- consistently assume it is dropped. + StreamD.Stop -> + if isMany + then return $ Partial (initialL, sR) + else Done <$> finalR sR + + initial = do + r <- initialR + case r of + Partial sR -> return $ Partial (initialL, sR) + Done b -> return $ Done b + + extract = extractR . snd + + final = finalR . snd + +-- | Scan the input of a 'Fold' to change it in a stateful manner using a +-- 'Scan'. The scan stops as soon as the fold terminates. +-- +-- /Pre-release/ +{-# INLINE runScan #-} +runScan :: Monad m => Scan m a b -> Fold m b c -> Scanl m a c +runScan = runScanWith False +-} + +{-# INLINE scanWith #-} +scanWith :: Monad m => Bool -> Scanl m a b -> Scanl m b c -> Scanl m a c +scanWith isMany + (Scanl stepL initialL extractL finalL) + (Scanl stepR initialR extractR finalR) = + Scanl step initial extract final + + where + + {-# INLINE runStep #-} + runStep actionL sR = do + rL <- actionL + case rL of + Done bL -> do + rR <- stepR sR bL + case rR of + Partial sR1 -> + if isMany + -- XXX recursive call. If initialL returns Done then it + -- will not terminate. In that case we should return + -- error in the beginning itself. And we should remove + -- this recursion, assuming it won't return Done. + then runStep initialL sR1 + else Done <$> finalR sR1 + Done bR -> return $ Done bR + Partial sL -> do + !b <- extractL sL + rR <- stepR sR b + case rR of + Partial sR1 -> return $ Partial (sL, sR1) + Done bR -> finalL sL >> return (Done bR) + + initial = do + r <- initialR + case r of + Partial sR -> runStep initialL sR + Done b -> return $ Done b + + step (sL, sR) x = runStep (stepL sL x) sR + + extract = extractR . snd + + final (sL, sR) = finalL sL *> finalR sR + +-- | Scan the input of a 'Scanl' to change it in a stateful manner using +-- another 'Scanl'. The scan stops as soon as any of the scans terminates. +-- +-- This is basically an append operation. +-- +-- /Pre-release/ +{-# INLINE scanl #-} +scanl :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c +scanl = scanWith False + +-- XXX This does not fuse beacuse of the recursive step. Need to investigate. + +-- | Scan the input of a 'Scanl' to change it in a stateful manner using +-- another 'Scanl'. The scan restarts with a fresh state if it terminates. +-- +-- /Pre-release/ +{-# INLINE scanlMany #-} +scanlMany :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c +scanlMany = scanWith True + +------------------------------------------------------------------------------ +-- Filters +------------------------------------------------------------------------------ + +-- | Returns the latest element omitting the first occurrence that satisfies +-- the given equality predicate. +-- +-- Example: +-- +-- >>> input = Stream.fromList [1,3,3,5] +-- >>> Stream.toList $ Stream.postscanlMaybe (Scanl.deleteBy (==) 3) input +-- [1,3,5] +-- +{-# INLINE_NORMAL deleteBy #-} +deleteBy :: Monad m => (a -> a -> Bool) -> a -> Scanl m a (Maybe a) +deleteBy eq x0 = fmap extract $ mkScanl step (Tuple' False Nothing) + + where + + step (Tuple' False _) x = + if eq x x0 + then Tuple' True Nothing + else Tuple' False (Just x) + step (Tuple' True _) x = Tuple' True (Just x) + + extract (Tuple' _ x) = x + +{- +-- | Provide a sliding window of length 2 elements. +-- +-- See "Streamly.Internal.Data.Scanl.Window". +-- +{-# INLINE slide2 #-} +slide2 :: Monad m => Fold m (a, Maybe a) b -> Scanl m a b +slide2 (Fold step1 initial1 extract1 final1) = Fold step initial extract final + + where + + initial = + first (Tuple' Nothing) <$> initial1 + + step (Tuple' prev s) cur = + first (Tuple' (Just cur)) <$> step1 s (cur, prev) + + extract (Tuple' _ s) = extract1 s + + final (Tuple' _ s) = final1 s +-} + +-- XXX Compare this with the implementation in Scanl.Window, preferrably use the +-- latter if performance is good. + +-- | Apply a function on every two successive elements of a stream. The first +-- argument of the map function is the previous element and the second argument +-- is the current element. When processing the very first element in the +-- stream, the previous element is 'Nothing'. +-- +-- /Pre-release/ +-- +{-# INLINE rollingMapM #-} +rollingMapM :: Monad m => (Maybe a -> a -> m b) -> Scanl m a b +rollingMapM f = Scanl step initial extract extract + + where + + -- XXX We need just a postscan. We do not need an initial result here. + -- Or we can supply a default initial result as an argument to rollingMapM. + initial = return $ Partial (Nothing, error "Empty stream") + + step (prev, _) cur = do + x <- f prev cur + return $ Partial (Just cur, x) + + extract = return . snd + +-- | +-- >>> rollingMap f = Scanl.rollingMapM (\x y -> return $ f x y) +-- +{-# INLINE rollingMap #-} +rollingMap :: Monad m => (Maybe a -> a -> b) -> Scanl m a b +rollingMap f = rollingMapM (\x y -> return $ f x y) + +-- | Return the latest unique element using the supplied comparison function. +-- Returns 'Nothing' if the current element is same as the last element +-- otherwise returns 'Just'. +-- +-- Example, strip duplicate path separators: +-- +-- >>> input = Stream.fromList "//a//b" +-- >>> f x y = x == '/' && y == '/' +-- >>> Stream.toList $ Stream.postscanlMaybe (Scanl.uniqBy f) input +-- "/a/b" +-- +-- Space: @O(1)@ +-- +-- /Pre-release/ +-- +{-# INLINE uniqBy #-} +uniqBy :: Monad m => (a -> a -> Bool) -> Scanl m a (Maybe a) +uniqBy eq = rollingMap f + + where + + f pre curr = + case pre of + Nothing -> Just curr + Just x -> if x `eq` curr then Nothing else Just curr + +-- | See 'uniqBy'. +-- +-- Definition: +-- +-- >>> uniq = Scanl.uniqBy (==) +-- +{-# INLINE uniq #-} +uniq :: (Monad m, Eq a) => Scanl m a (Maybe a) +uniq = uniqBy (==) + +-- | Strip all leading and trailing occurrences of an element passing a +-- predicate and make all other consecutive occurrences uniq. +-- +-- >> prune p = Stream.dropWhileAround p $ Stream.uniqBy (x y -> p x && p y) +-- +-- @ +-- > Stream.prune isSpace (Stream.fromList " hello world! ") +-- "hello world!" +-- +-- @ +-- +-- Space: @O(1)@ +-- +-- /Unimplemented/ +{-# INLINE prune #-} +prune :: + -- (Monad m, Eq a) => + (a -> Bool) -> Scanl m a (Maybe a) +prune = error "Not implemented yet!" + +-- | Emit only repeated elements, once. +-- +-- /Unimplemented/ +repeated :: -- (Monad m, Eq a) => + Scanl m a (Maybe a) +repeated = error "Not implemented yet!" + +------------------------------------------------------------------------------ +-- Left scans +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Run Effects +------------------------------------------------------------------------------ + +-- | +-- Definitions: +-- +-- >>> drainMapM f = Scanl.lmapM f Scanl.drain +-- >>> drainMapM f = Scanl.foldMapM (void . f) +-- +-- Drain all input after passing it through a monadic function. This is the +-- dual of mapM_ on stream producers. +-- +{-# INLINE drainMapM #-} +drainMapM :: Monad m => (a -> m b) -> Scanl m a () +drainMapM f = lmapM f drain + +-- | Terminates with 'Nothing' as soon as it finds an element different than +-- the previous one, returns 'the' element if the entire input consists of the +-- same element. +-- +{-# INLINE the #-} +the :: (Monad m, Eq a) => Scanl m a (Maybe a) +the = mkScant step initial id + + where + + initial = Partial Nothing + + step Nothing x = Partial (Just x) + step old@(Just x0) x = + if x0 == x + then Partial old + else Done Nothing + +------------------------------------------------------------------------------ +-- To Summary +------------------------------------------------------------------------------ + +-- | Determine the sum of all elements of a stream of numbers. Returns additive +-- identity (@0@) when the stream is empty. Note that this is not numerically +-- stable for floating point numbers. +-- +-- >>> sum = Scanl.cumulativeScan Scanl.incrSum +-- +-- Same as following but numerically stable: +-- +-- >>> sum = Scanl.mkScanl (+) 0 +-- >>> sum = fmap Data.Monoid.getSum $ Scanl.foldMap Data.Monoid.Sum +-- +{-# INLINE sum #-} +sum :: (Monad m, Num a) => Scanl m a a +sum = Scanl.cumulativeScan Scanl.incrSum + +-- | Determine the product of all elements of a stream of numbers. Returns +-- multiplicative identity (@1@) when the stream is empty. The scan terminates +-- when it encounters (@0@) in its input. +-- +-- Same as the following but terminates on multiplication by @0@: +-- +-- >>> product = fmap Data.Monoid.getProduct $ Scanl.foldMap Data.Monoid.Product +-- +{-# INLINE product #-} +product :: (Monad m, Num a, Eq a) => Scanl m a a +product = mkScant step (Partial 1) id + + where + + step x a = + if a == 0 + then Done 0 + else Partial $ x * a + +------------------------------------------------------------------------------ +-- To Summary (Statistical) +------------------------------------------------------------------------------ + +-- | Compute a numerically stable arithmetic mean of all elements in the input +-- stream. +-- +{-# INLINE mean #-} +mean :: (Monad m, Fractional a) => Scanl m a a +mean = fmap done $ mkScanl step begin + + where + + begin = Tuple' 0 0 + + step (Tuple' x n) y = + let n1 = n + 1 + in Tuple' (x + (y - x) / n1) n1 + + done (Tuple' x _) = x + +-- | Compute an 'Int' sized polynomial rolling hash +-- +-- > H = salt * k ^ n + c1 * k ^ (n - 1) + c2 * k ^ (n - 2) + ... + cn * k ^ 0 +-- +-- Where @c1@, @c2@, @cn@ are the elements in the input stream and @k@ is a +-- constant. +-- +-- This hash is often used in Rabin-Karp string search algorithm. +-- +-- See https://en.wikipedia.org/wiki/Rolling_hash +-- +{-# INLINE rollingHashWithSalt #-} +rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Scanl m a Int64 +rollingHashWithSalt = mkScanl step + + where + + k = 2891336453 :: Int64 + + step cksum a = cksum * k + fromIntegral (fromEnum a) + +-- | A default salt used in the implementation of 'rollingHash'. +{-# INLINE defaultSalt #-} +defaultSalt :: Int64 +defaultSalt = -2578643520546668380 + +-- | Compute an 'Int' sized polynomial rolling hash of a stream. +-- +-- >>> rollingHash = Scanl.rollingHashWithSalt Scanl.defaultSalt +-- +{-# INLINE rollingHash #-} +rollingHash :: (Monad m, Enum a) => Scanl m a Int64 +rollingHash = rollingHashWithSalt defaultSalt + +-- | Compute an 'Int' sized polynomial rolling hash of the first n elements of +-- a stream. +-- +-- >>> rollingHashFirstN n = Scanl.take n Scanl.rollingHash +-- +-- /Pre-release/ +{-# INLINE rollingHashFirstN #-} +rollingHashFirstN :: (Monad m, Enum a) => Int -> Scanl m a Int64 +rollingHashFirstN n = take n rollingHash + +------------------------------------------------------------------------------ +-- Monoidal left scans +------------------------------------------------------------------------------ + +-- | Semigroup concat. Append the elements of an input stream to a provided +-- starting value. +-- +-- Definition: +-- +-- >>> sconcat = Scanl.mkScanl (<>) +-- +-- >>> semigroups = fmap Data.Monoid.Sum $ Stream.enumerateFromTo 1 3 +-- >>> Stream.toList $ Stream.scanl (Scanl.sconcat 3) semigroups +-- [Sum {getSum = 3},Sum {getSum = 4},Sum {getSum = 6},Sum {getSum = 9}] +-- +{-# INLINE sconcat #-} +sconcat :: (Monad m, Semigroup a) => a -> Scanl m a a +sconcat = mkScanl (<>) + +-- | Monoid concat. Scan an input stream consisting of monoidal elements using +-- 'mappend' and 'mempty'. +-- +-- Definition: +-- +-- >>> mconcat = Scanl.sconcat mempty +-- +-- >>> monoids = fmap Data.Monoid.Sum $ Stream.enumerateFromTo 1 3 +-- >>> Stream.toList $ Stream.scanl Scanl.mconcat monoids +-- [Sum {getSum = 0},Sum {getSum = 1},Sum {getSum = 3},Sum {getSum = 6}] +-- +{-# INLINE mconcat #-} +mconcat :: + ( Monad m + , Monoid a) => Scanl m a a +mconcat = sconcat mempty + +-- | +-- Definition: +-- +-- >>> foldMap f = Scanl.lmap f Scanl.mconcat +-- +-- Make a scan from a pure function that scans the output of the function +-- using 'mappend' and 'mempty'. +-- +-- >>> sum = Scanl.foldMap Data.Monoid.Sum +-- >>> Stream.toList $ Stream.scanl sum $ Stream.enumerateFromTo 1 3 +-- [Sum {getSum = 0},Sum {getSum = 1},Sum {getSum = 3},Sum {getSum = 6}] +-- +{-# INLINE foldMap #-} +foldMap :: (Monad m, Monoid b) => (a -> b) -> Scanl m a b +foldMap f = lmap f mconcat + +-- | +-- Definition: +-- +-- >>> foldMapM f = Scanl.lmapM f Scanl.mconcat +-- +-- Make a scan from a monadic function that scans the output of the function +-- using 'mappend' and 'mempty'. +-- +-- >>> sum = Scanl.foldMapM (return . Data.Monoid.Sum) +-- >>> Stream.toList $ Stream.scanl sum $ Stream.enumerateFromTo 1 3 +-- [Sum {getSum = 0},Sum {getSum = 1},Sum {getSum = 3},Sum {getSum = 6}] +-- +{-# INLINE foldMapM #-} +foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Scanl m a b +foldMapM act = mkScanlM step (pure mempty) + + where + + step m a = do + m' <- act a + return $! mappend m m' + +------------------------------------------------------------------------------ +-- To Containers +------------------------------------------------------------------------------ + +-- $toListRev +-- This is more efficient than 'Streamly.Internal.Data.Scanl.toList'. toList is +-- exactly the same as reversing the list after 'toListRev'. + +-- | Buffers the input stream to a list in the reverse order of the input. +-- +-- Definition: +-- +-- >>> toListRev = Scanl.mkScanl (flip (:)) [] +-- +-- /Warning!/ working on large lists accumulated as buffers in memory could be +-- very inefficient, consider using "Streamly.Array" instead. +-- + +-- xn : ... : x2 : x1 : [] +{-# INLINE toListRev #-} +toListRev :: Monad m => Scanl m a [a] +toListRev = mkScanl (flip (:)) [] + +------------------------------------------------------------------------------ +-- Partial Scans +------------------------------------------------------------------------------ + +-- | A scan that drains the first n elements of its input, running the effects +-- and discarding the results. +-- +-- Definition: +-- +-- >>> drainN n = Scanl.take n Scanl.drain +-- +-- /Pre-release/ +{-# INLINE drainN #-} +drainN :: Monad m => Int -> Scanl m a () +drainN n = take n drain + +{- +------------------------------------------------------------------------------ +-- To Elements +------------------------------------------------------------------------------ + +-- | Like 'index', except with a more general 'Integral' argument +-- +-- /Pre-release/ +{-# INLINE genericIndex #-} +genericIndex :: (Integral i, Monad m) => i -> Scanl m a (Maybe a) +genericIndex i = mkScant step (Partial 0) (const Nothing) + + where + + step j a = + if i == j + then Done $ Just a + else Partial (j + 1) + +-- | Return the element at the given index. +-- +-- Definition: +-- +-- >>> index = Scanl.genericIndex +-- +{-# INLINE index #-} +index :: Monad m => Int -> Scanl m a (Maybe a) +index = genericIndex + +-- | Consume a single input and transform it using the supplied 'Maybe' +-- returning function. +-- +-- /Pre-release/ +-- +{-# INLINE maybe #-} +maybe :: Monad m => (a -> Maybe b) -> Scanl m a (Maybe b) +maybe f = mkScant (const (Done . f)) (Partial Nothing) id + +-- | Consume a single element and return it if it passes the predicate else +-- return 'Nothing'. +-- +-- Definition: +-- +-- >>> satisfy f = Scanl.maybe (\a -> if f a then Just a else Nothing) +-- +-- /Pre-release/ +{-# INLINE satisfy #-} +satisfy :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) +satisfy f = maybe (\a -> if f a then Just a else Nothing) +{- +satisfy f = Fold step (return $ Partial ()) (const (return Nothing)) + + where + + step () a = return $ Done $ if f a then Just a else Nothing +-} + +-- Naming notes: +-- +-- "head" and "next" are two alternative names for the same API. head sounds +-- apt in the context of lists but next sounds more apt in the context of +-- streams where we think in terms of generating and consuming the next element +-- rather than taking the head of some static/persistent structure. +-- +-- We also want to keep the nomenclature consistent across folds and parsers, +-- "head" becomes even more unintuitive for parsers because there are two +-- possible variants viz. peek and next. +-- +-- Also, the "head" fold creates confusion in situations like +-- https://github.com/composewell/streamly/issues/1404 where intuitive +-- expectation from head is to consume the entire stream and just give us the +-- head. There we want to convey the notion that we consume one element from +-- the stream and stop. The name "one" already being used in parsers for this +-- purpose sounds more apt from this perspective. +-- +-- The source of confusion is perhaps due to the fact that some folds consume +-- the entire stream and others terminate early. It may have been clearer if we +-- had separate abstractions for the two use cases. + +-- XXX We can possibly use "head" for the purposes of reducing the entire +-- stream to the head element i.e. take the head and drain the rest. + +-- | Take one element from the stream and stop. +-- +-- Definition: +-- +-- >>> one = Scanl.maybe Just +-- +-- This is similar to the stream 'Stream.uncons' operation. +-- +{-# INLINE one #-} +one :: Monad m => Scanl m a (Maybe a) +one = maybe Just + +-- | Returns the first element that satisfies the given predicate. +-- +-- /Pre-release/ +{-# INLINE findM #-} +findM :: Monad m => (a -> m Bool) -> Scanl m a (Maybe a) +findM predicate = + Scanl step (return $ Partial ()) extract extract + + where + + step () a = + let f r = + if r + then Done (Just a) + else Partial () + in f <$> predicate a + + extract = const $ return Nothing + +-- | Returns the first element that satisfies the given predicate. +-- +{-# INLINE find #-} +find :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) +find p = findM (return . p) + +-- | In a stream of (key-value) pairs @(a, b)@, return the value @b@ of the +-- first pair where the key equals the given value @a@. +-- +-- Definition: +-- +-- >>> lookup x = fmap snd <$> Scanl.find ((== x) . fst) +-- +{-# INLINE lookup #-} +lookup :: (Eq a, Monad m) => a -> Scanl m (a,b) (Maybe b) +lookup a0 = mkScant step (Partial ()) (const Nothing) + + where + + step () (a, b) = + if a == a0 + then Done $ Just b + else Partial () + +-- | Returns the first index that satisfies the given predicate. +-- +{-# INLINE findIndex #-} +findIndex :: Monad m => (a -> Bool) -> Scanl m a (Maybe Int) +findIndex predicate = mkScant step (Partial 0) (const Nothing) + + where + + step i a = + if predicate a + then Done $ Just i + else Partial (i + 1) +-} + +-- | Returns the index of the latest element if the element satisfies the given +-- predicate. +-- +{-# INLINE findIndices #-} +findIndices :: Monad m => (a -> Bool) -> Scanl m a (Maybe Int) +findIndices predicate = + -- XXX implement by combining indexing and filtering scans + fmap (either (Prelude.const Nothing) Just) $ mkScanl step (Left (-1)) + + where + + step i a = + if predicate a + then Right (either id id i + 1) + else Left (either id id i + 1) + +-- | Returns the index of the latest element if the element matches the given +-- value. +-- +-- Definition: +-- +-- >>> elemIndices a = Scanl.findIndices (== a) +-- +{-# INLINE elemIndices #-} +elemIndices :: (Monad m, Eq a) => a -> Scanl m a (Maybe Int) +elemIndices a = findIndices (== a) + +{- +-- | Returns the first index where a given value is found in the stream. +-- +-- Definition: +-- +-- >>> elemIndex a = Scanl.findIndex (== a) +-- +{-# INLINE elemIndex #-} +elemIndex :: (Eq a, Monad m) => a -> Scanl m a (Maybe Int) +elemIndex a = findIndex (== a) + +------------------------------------------------------------------------------ +-- To Boolean +------------------------------------------------------------------------------ + +-- Similar to 'eof' parser, but the fold consumes and discards an input element +-- when not at eof. XXX Remove or Rename to "eof"? + +-- | Consume one element, return 'True' if successful else return 'False'. In +-- other words, test if the input is empty or not. +-- +-- WARNING! It consumes one element if the stream is not empty. If that is not +-- what you want please use the eof parser instead. +-- +-- Definition: +-- +-- >>> null = fmap isJust Scanl.one +-- +{-# INLINE null #-} +null :: Monad m => Scanl m a Bool +null = mkScant (\() _ -> Done False) (Partial ()) (const True) + +-- | Returns 'True' if any element of the input satisfies the predicate. +-- +-- Definition: +-- +-- >>> any p = Scanl.lmap p Scanl.or +-- +-- Example: +-- +-- >>> Stream.toList $ Stream.scanl (Scanl.any (== 0)) $ Stream.fromList [1,0,1] +-- True +-- +{-# INLINE any #-} +any :: Monad m => (a -> Bool) -> Scanl m a Bool +any predicate = mkScant step initial id + + where + + initial = Partial False + + step _ a = + if predicate a + then Done True + else Partial False + +-- | Return 'True' if the given element is present in the stream. +-- +-- Definition: +-- +-- >>> elem a = Scanl.any (== a) +-- +{-# INLINE elem #-} +elem :: (Eq a, Monad m) => a -> Scanl m a Bool +elem a = any (== a) + +-- | Returns 'True' if all elements of the input satisfy the predicate. +-- +-- Definition: +-- +-- >>> all p = Scanl.lmap p Scanl.and +-- +-- Example: +-- +-- >>> Stream.toList $ Stream.scanl (Scanl.all (== 0)) $ Stream.fromList [1,0,1] +-- False +-- +{-# INLINE all #-} +all :: Monad m => (a -> Bool) -> Scanl m a Bool +all predicate = mkScant step initial id + + where + + initial = Partial True + + step _ a = + if predicate a + then Partial True + else Done False + +-- | Returns 'True' if the given element is not present in the stream. +-- +-- Definition: +-- +-- >>> notElem a = Scanl.all (/= a) +-- +{-# INLINE notElem #-} +notElem :: (Eq a, Monad m) => a -> Scanl m a Bool +notElem a = all (/= a) + +-- | Returns 'True' if all elements are 'True', 'False' otherwise +-- +-- Definition: +-- +-- >>> and = Scanl.all (== True) +-- +{-# INLINE and #-} +and :: Monad m => Scanl m Bool Bool +and = all id + +-- | Returns 'True' if any element is 'True', 'False' otherwise +-- +-- Definition: +-- +-- >>> or = Scanl.any (== True) +-- +{-# INLINE or #-} +or :: Monad m => Scanl m Bool Bool +or = any id +-} + +------------------------------------------------------------------------------ +-- Grouping/Splitting +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Grouping without looking at elements +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Binary APIs +------------------------------------------------------------------------------ + +{- +-- | @splitAt n f1 f2@ composes folds @f1@ and @f2@ such that first @n@ +-- elements of its input are consumed by fold @f1@ and the rest of the stream +-- is consumed by fold @f2@. +-- +-- >>> let splitAt_ n xs = Stream.toList $ Stream.scanl (Fold.splitAt n Fold.toList Fold.toList) $ Stream.fromList xs +-- +-- >>> splitAt_ 6 "Hello World!" +-- ("Hello ","World!") +-- +-- >>> splitAt_ (-1) [1,2,3] +-- ([],[1,2,3]) +-- +-- >>> splitAt_ 0 [1,2,3] +-- ([],[1,2,3]) +-- +-- >>> splitAt_ 1 [1,2,3] +-- ([1],[2,3]) +-- +-- >>> splitAt_ 3 [1,2,3] +-- ([1,2,3],[]) +-- +-- >>> splitAt_ 4 [1,2,3] +-- ([1,2,3],[]) +-- +-- > splitAt n f1 f2 = Fold.splitWith (,) (Fold.take n f1) f2 +-- +-- /Internal/ + +{-# INLINE splitAt #-} +splitAt + :: Monad m + => Int + -> Scanl m a b + -> Scanl m a c + -> Scanl m a (b, c) +splitAt n fld = splitWith (,) (take n fld) +-} + +------------------------------------------------------------------------------ +-- Element Aware APIs +------------------------------------------------------------------------------ +-- +------------------------------------------------------------------------------ +-- Binary APIs +------------------------------------------------------------------------------ + +{-# INLINE takingEndByM #-} +takingEndByM :: Monad m => (a -> m Bool) -> Scanl m a (Maybe a) +takingEndByM p = Scanl step initial extract extract + + where + + initial = return $ Partial Nothing' + + step _ a = do + r <- p a + return + $ if r + then Done $ Just a + else Partial $ Just' a + + extract = return . toMaybe + +-- | +-- +-- >>> takingEndBy p = Scanl.takingEndByM (return . p) +-- +{-# INLINE takingEndBy #-} +takingEndBy :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) +takingEndBy p = takingEndByM (return . p) + +{-# INLINE takingEndByM_ #-} +takingEndByM_ :: Monad m => (a -> m Bool) -> Scanl m a (Maybe a) +takingEndByM_ p = Scanl step initial extract extract + + where + + initial = return $ Partial Nothing' + + step _ a = do + r <- p a + return + $ if r + then Done Nothing + else Partial $ Just' a + + extract = return . toMaybe + +-- | +-- +-- >>> takingEndBy_ p = Scanl.takingEndByM_ (return . p) +-- +{-# INLINE takingEndBy_ #-} +takingEndBy_ :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) +takingEndBy_ p = takingEndByM_ (return . p) + +{-# INLINE droppingWhileM #-} +droppingWhileM :: Monad m => (a -> m Bool) -> Scanl m a (Maybe a) +droppingWhileM p = Scanl step initial extract extract + + where + + initial = return $ Partial Nothing' + + step Nothing' a = do + r <- p a + return + $ Partial + $ if r + then Nothing' + else Just' a + step _ a = return $ Partial $ Just' a + + extract = return . toMaybe + +-- | +-- >>> droppingWhile p = Scanl.droppingWhileM (return . p) +-- +{-# INLINE droppingWhile #-} +droppingWhile :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) +droppingWhile p = droppingWhileM (return . p) + +------------------------------------------------------------------------------ +-- Binary splitting on a separator +------------------------------------------------------------------------------ + +{- +data SplitOnSeqState acc a rb rh w ck = + SplitOnSeqEmpty !acc + | SplitOnSeqSingle !acc !a + | SplitOnSeqWord !acc !Int !w + | SplitOnSeqWordLoop !acc !w + | SplitOnSeqKR !acc !Int !rb !rh + | SplitOnSeqKRLoop !acc !ck !rb !rh + +-- XXX Need to add tests for takeEndBySeq, we have tests for takeEndBySeq_ . + +-- | Continue taking the input until the input sequence matches the supplied +-- sequence, taking the supplied sequence as well. If the pattern is empty this +-- acts as an identity fold. +-- +-- >>> s = Stream.fromList "hello there. How are you?" +-- >>> f = Fold.takeEndBySeq (Array.fromList "re") Fold.toList +-- >>> Stream.toList $ Stream.scanl f s +-- "hello there" +-- +-- >>> Stream.toList $ Stream.scanl Fold.toList $ Stream.toList $ Stream.scanlMany f s +-- ["hello there",". How are"," you?"] +-- +-- /Pre-release/ +{-# INLINE takeEndBySeq #-} +takeEndBySeq :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => + Array.Array a + -> Scanl m a b + -> Scanl m a b +takeEndBySeq patArr (Fold fstep finitial fextract ffinal) = + Fold step initial extract final + + where + + patLen = Array.length patArr + + initial = do + res <- finitial + case res of + Partial acc + | patLen == 0 -> + -- XXX Should we match nothing or everything on empty + -- pattern? + -- Done <$> ffinal acc + return $ Partial $ SplitOnSeqEmpty acc + | patLen == 1 -> do + pat <- liftIO $ Array.unsafeGetIndexIO 0 patArr + return $ Partial $ SplitOnSeqSingle acc pat + | SIZE_OF(a) * patLen <= sizeOf (Proxy :: Proxy Word) -> + return $ Partial $ SplitOnSeqWord acc 0 0 + | otherwise -> do + rb <- liftIO $ RingArray.emptyOf patLen + return $ Partial $ SplitOnSeqKR acc 0 rb 0 + Done b -> return $ Done b + + -- Word pattern related + maxIndex = patLen - 1 + + elemBits = SIZE_OF(a) * 8 + + wordMask :: Word + wordMask = (1 `shiftL` (elemBits * patLen)) - 1 + + wordPat :: Word + wordPat = wordMask .&. Array.scanl' addToWord 0 patArr + + addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) + + -- For Rabin-Karp search + k = 2891336453 :: Word32 + coeff = k ^ patLen + + addCksum cksum a = cksum * k + fromIntegral (fromEnum a) + + deltaCksum cksum old new = + addCksum cksum new - coeff * fromIntegral (fromEnum old) + + -- XXX shall we use a random starting hash or 1 instead of 0? + -- XXX Need to keep this cached across fold calls in foldmany + -- XXX We may need refold to inject the cached state instead of + -- initializing the state every time. + -- XXX Allocation of ring buffer should also be done once + patHash = Array.scanl' addCksum 0 patArr + + step (SplitOnSeqEmpty s) x = do + res <- fstep s x + case res of + Partial s1 -> return $ Partial $ SplitOnSeqEmpty s1 + Done b -> return $ Done b + step (SplitOnSeqSingle s pat) x = do + res <- fstep s x + case res of + Partial s1 + | pat /= x -> return $ Partial $ SplitOnSeqSingle s1 pat + | otherwise -> Done <$> ffinal s1 + Done b -> return $ Done b + step (SplitOnSeqWord s idx wrd) x = do + res <- fstep s x + let wrd1 = addToWord wrd x + case res of + Partial s1 + | idx == maxIndex -> do + if wrd1 .&. wordMask == wordPat + then Done <$> ffinal s1 + else return $ Partial $ SplitOnSeqWordLoop s1 wrd1 + | otherwise -> + return $ Partial $ SplitOnSeqWord s1 (idx + 1) wrd1 + Done b -> return $ Done b + step (SplitOnSeqWordLoop s wrd) x = do + res <- fstep s x + let wrd1 = addToWord wrd x + case res of + Partial s1 + | wrd1 .&. wordMask == wordPat -> + Done <$> ffinal s1 + | otherwise -> + return $ Partial $ SplitOnSeqWordLoop s1 wrd1 + Done b -> return $ Done b + step (SplitOnSeqKR s idx rb rh) x = do + res <- fstep s x + case res of + Partial s1 -> do + rh1 <- liftIO $ RingArray.unsafeInsert rb rh x + if idx == maxIndex + then do + let fld = RingArray.unsafeFoldRing (RingArray.ringCapacity rb) + let !ringHash = fld addCksum 0 rb + if ringHash == patHash && RingArray.unsafeEqArray rb rh1 patArr + then Done <$> ffinal s1 + else return $ Partial $ SplitOnSeqKRLoop s1 ringHash rb rh1 + else + return $ Partial $ SplitOnSeqKR s1 (idx + 1) rb rh1 + Done b -> return $ Done b + step (SplitOnSeqKRLoop s cksum rb rh) x = do + res <- fstep s x + case res of + Partial s1 -> do + (old :: a) <- RingArray.unsafeGetIndex rh rb + rh1 <- liftIO $ RingArray.unsafeInsert rb rh x + let ringHash = deltaCksum cksum old x + if ringHash == patHash && RingArray.unsafeEqArray rb rh1 patArr + then Done <$> ffinal s1 + else return $ Partial $ SplitOnSeqKRLoop s1 ringHash rb rh1 + Done b -> return $ Done b + + extractFunc fex state = + let st = + case state of + SplitOnSeqEmpty s -> s + SplitOnSeqSingle s _ -> s + SplitOnSeqWord s _ _ -> s + SplitOnSeqWordLoop s _ -> s + SplitOnSeqKR s _ _ _ -> s + SplitOnSeqKRLoop s _ _ _ -> s + in fex st + + extract = extractFunc fextract + + final = extractFunc ffinal + +-- | Like 'takeEndBySeq' but discards the matched sequence. +-- +-- /Pre-release/ +-- +{-# INLINE takeEndBySeq_ #-} +takeEndBySeq_ :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) => + Array.Array a + -> Scanl m a b + -> Scanl m a b +takeEndBySeq_ patArr (Fold fstep finitial fextract ffinal) = + Fold step initial extract final + + where + + patLen = Array.length patArr + + initial = do + res <- finitial + case res of + Partial acc + | patLen == 0 -> + -- XXX Should we match nothing or everything on empty + -- pattern? + -- Done <$> ffinal acc + return $ Partial $ SplitOnSeqEmpty acc + | patLen == 1 -> do + pat <- liftIO $ Array.unsafeGetIndexIO 0 patArr + return $ Partial $ SplitOnSeqSingle acc pat + -- XXX Need to add tests for this case + | SIZE_OF(a) * patLen <= sizeOf (Proxy :: Proxy Word) -> + return $ Partial $ SplitOnSeqWord acc 0 0 + | otherwise -> do + rb <- liftIO $ RingArray.emptyOf patLen + return $ Partial $ SplitOnSeqKR acc 0 rb 0 + Done b -> return $ Done b + + -- Word pattern related + maxIndex = patLen - 1 + + elemBits = SIZE_OF(a) * 8 + + wordMask :: Word + wordMask = (1 `shiftL` (elemBits * patLen)) - 1 + + elemMask :: Word + elemMask = (1 `shiftL` elemBits) - 1 + + wordPat :: Word + wordPat = wordMask .&. Array.scanl' addToWord 0 patArr + + addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) + + -- For Rabin-Karp search + k = 2891336453 :: Word32 + coeff = k ^ patLen + + addCksum cksum a = cksum * k + fromIntegral (fromEnum a) + + deltaCksum cksum old new = + addCksum cksum new - coeff * fromIntegral (fromEnum old) + + -- XXX shall we use a random starting hash or 1 instead of 0? + -- XXX Need to keep this cached across fold calls in foldMany + -- XXX We may need refold to inject the cached state instead of + -- initializing the state every time. + -- XXX Allocation of ring buffer should also be done once + patHash = Array.scanl' addCksum 0 patArr + + step (SplitOnSeqEmpty s) x = do + res <- fstep s x + case res of + Partial s1 -> return $ Partial $ SplitOnSeqEmpty s1 + Done b -> return $ Done b + step (SplitOnSeqSingle s pat) x = do + if pat /= x + then do + res <- fstep s x + case res of + Partial s1 -> return $ Partial $ SplitOnSeqSingle s1 pat + Done b -> return $ Done b + else Done <$> ffinal s + step (SplitOnSeqWord s idx wrd) x = do + let wrd1 = addToWord wrd x + if idx == maxIndex + then do + if wrd1 .&. wordMask == wordPat + then Done <$> ffinal s + else return $ Partial $ SplitOnSeqWordLoop s wrd1 + else return $ Partial $ SplitOnSeqWord s (idx + 1) wrd1 + step (SplitOnSeqWordLoop s wrd) x = do + let wrd1 = addToWord wrd x + old = (wordMask .&. wrd) + `shiftR` (elemBits * (patLen - 1)) + res <- fstep s (toEnum $ fromIntegral old) + case res of + Partial s1 + | wrd1 .&. wordMask == wordPat -> + Done <$> ffinal s1 + | otherwise -> + return $ Partial $ SplitOnSeqWordLoop s1 wrd1 + Done b -> return $ Done b + step (SplitOnSeqKR s idx rb rh) x = do + rh1 <- liftIO $ RingArray.unsafeInsert rb rh x + if idx == maxIndex + then do + let fld = RingArray.unsafeFoldRing (RingArray.ringCapacity rb) + let !ringHash = fld addCksum 0 rb + if ringHash == patHash && RingArray.unsafeEqArray rb rh1 patArr + then Done <$> ffinal s + else return $ Partial $ SplitOnSeqKRLoop s ringHash rb rh1 + else return $ Partial $ SplitOnSeqKR s (idx + 1) rb rh1 + step (SplitOnSeqKRLoop s cksum rb rh) x = do + old <- RingArray.unsafeGetIndex rh rb + res <- fstep s old + case res of + Partial s1 -> do + rh1 <- liftIO $ RingArray.unsafeInsert rb rh x + let ringHash = deltaCksum cksum old x + if ringHash == patHash && RingArray.unsafeEqArray rb rh1 patArr + then Done <$> ffinal s1 + else return $ Partial $ SplitOnSeqKRLoop s1 ringHash rb rh1 + Done b -> return $ Done b + + -- XXX extract should return backtrack count as well. If the fold + -- terminates early inside extract, we may still have buffered data + -- remaining which will be lost if we do not communicate that to the + -- driver. + extractFunc fex state = do + let consumeWord s n wrd = do + if n == 0 + then fex s + else do + let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1))) + r <- fstep s (toEnum $ fromIntegral old) + case r of + Partial s1 -> consumeWord s1 (n - 1) wrd + Done b -> return b + + let consumeRing s n rb rh = + if n == 0 + then fex s + else do + old <- RingArray.unsafeGetIndex rh rb + let rh1 = RingArray.advance rb rh + r <- fstep s old + case r of + Partial s1 -> consumeRing s1 (n - 1) rb rh1 + Done b -> return b + + case state of + SplitOnSeqEmpty s -> fex s + SplitOnSeqSingle s _ -> fex s + SplitOnSeqWord s idx wrd -> consumeWord s idx wrd + SplitOnSeqWordLoop s wrd -> consumeWord s patLen wrd + SplitOnSeqKR s idx rb _ -> consumeRing s idx rb 0 + SplitOnSeqKRLoop s _ rb rh -> consumeRing s patLen rb rh + + extract = extractFunc fextract + + final = extractFunc ffinal + -} + +------------------------------------------------------------------------------ +-- Distributing +------------------------------------------------------------------------------ +-- +-- | Distribute one copy of the stream to each scan and zip the results. +-- +-- @ +-- |-------Scanl m a b--------| +-- ---stream m a---| |---m (b,c) +-- |-------Scanl m a c--------| +-- @ +-- +-- Definition: +-- +-- >>> tee = Scanl.teeWith (,) +-- +-- Example: +-- +-- >>> t = Scanl.tee Scanl.sum Scanl.length +-- >>> Stream.toList $ Stream.scanl t (Stream.enumerateFromTo 1.0 10.0) +-- [(0.0,0),(1.0,1),(3.0,2),(6.0,3),(10.0,4),(15.0,5),(21.0,6),(28.0,7),(36.0,8),(45.0,9),(55.0,10)] +-- +{-# INLINE tee #-} +tee :: Monad m => Scanl m a b -> Scanl m a c -> Scanl m a (b,c) +tee = teeWith (,) + +-- XXX use unboxed Array for output to scale it to a large number of consumers? + +-- | Distribute one copy of the stream to each scan and collect the results in +-- a container. +-- +-- @ +-- +-- |-------Scanl m a b--------| +-- ---stream m a---| |---m [b] +-- |-------Scanl m a b--------| +-- | | +-- ... +-- @ +-- +-- >>> Stream.toList $ Stream.scanl (Scanl.distribute [Scanl.sum, Scanl.length]) (Stream.enumerateFromTo 1 5) +-- [[0,0],[1,1],[3,2],[6,3],[10,4],[15,5]] +-- +-- >>> distribute = Prelude.foldr (Scanl.teeWith (:)) (Scanl.const []) +-- +-- This is the consumer side dual of the producer side 'sequence' operation. +-- +-- Stops as soon as any of the scans stop. +-- +{-# INLINE distribute #-} +distribute :: Monad m => [Scanl m a b] -> Scanl m a [b] +distribute = Prelude.foldr (teeWith (:)) (const []) + +------------------------------------------------------------------------------ +-- Partitioning +------------------------------------------------------------------------------ + +{- +{-# INLINE partitionByMUsing #-} +partitionByMUsing :: Monad m => + ( (x -> y -> (x, y)) + -> Scanl m (Either b c) x + -> Scanl m (Either b c) y + -> Scanl m (Either b c) (x, y) + ) + -> (a -> m (Either b c)) + -> Scanl m b x + -> Scanl m c y + -> Scanl m a (x, y) +partitionByMUsing t f fld1 fld2 = + let l = lmap (fromLeft undefined) fld1 -- :: Fold m (Either b c) x + r = lmap (fromRight undefined) fld2 -- :: Fold m (Either b c) y + in lmapM f (t (,) (filter isLeft l) (filter isRight r)) + -} + +data PartState sL sR = PartLeft !sL !sR | PartRight !sL !sR + +-- | Partition the input over two scans using an 'Either' partitioning +-- predicate. +-- +-- @ +-- +-- |-------Scanl b x--------| +-- -----stream m a --> (Either b c)----| |----(x,y) +-- |-------Scanl c y--------| +-- @ +-- +-- Example, send input to either scan randomly: +-- +-- >>> :set -package random +-- >>> import System.Random (randomIO) +-- >>> randomly a = randomIO >>= \x -> return $ if x then Left a else Right a +-- >>> f = Scanl.partitionByM randomly Scanl.length Scanl.length +-- >>> Stream.toList $ Stream.scanl f (Stream.enumerateFromTo 1 10) +-- ... +-- +-- Example, send input to the two scans in a proportion of 2:1: +-- +-- >>> :set -fno-warn-unrecognised-warning-flags +-- >>> :set -fno-warn-x-partial +-- >>> :{ +-- proportionately m n = do +-- ref <- newIORef $ cycle $ concat [replicate m Left, replicate n Right] +-- return $ \a -> do +-- r <- readIORef ref +-- writeIORef ref $ tail r +-- return $ Prelude.head r a +-- :} +-- +-- >>> :{ +-- main = do +-- g <- proportionately 2 1 +-- let f = Scanl.partitionByM g Scanl.length Scanl.length +-- r <- Stream.toList $ Stream.scanl f (Stream.enumerateFromTo (1 :: Int) 10) +-- print r +-- :} +-- +-- >>> main +-- ... +-- +-- +-- This is the consumer side dual of the producer side 'mergeBy' operation. +-- +-- Terminates as soon as any of the scans terminate. +-- +-- /Pre-release/ +{-# INLINE partitionByM #-} +partitionByM :: Monad m + => (a -> m (Either b c)) -> Scanl m b x -> Scanl m c x -> Scanl m a x +partitionByM f + (Scanl stepL initialL extractL finalL) + (Scanl stepR initialR extractR finalR) = + Scanl step initial extract final + + where + + initial = do + resL <- initialL + resR <- initialR + return + $ case resL of + Done bl -> Done bl + Partial sl -> + case resR of + Partial sr -> Partial $ PartLeft sl sr + Done br -> Done br + + runBoth sL sR a = do + pRes <- f a + case pRes of + Left b -> do + resL <- stepL sL b + case resL of + Partial s -> return $ Partial $ PartLeft s sR + Done x -> return $ Done x + Right c -> do + resR <- stepR sR c + case resR of + Partial s -> return $ Partial $ PartRight sL s + Done x -> return $ Done x + + step (PartLeft sL sR) = runBoth sL sR + step (PartRight sL sR) = runBoth sL sR + + extract (PartLeft sL _) = extractL sL + extract (PartRight _ sR) = extractR sR + + final (PartLeft sL sR) = finalR sR *> finalL sL + final (PartRight sL sR) = finalL sL *> finalR sR + +{- +-- | Similar to 'partitionByM' but terminates when the first fold terminates. +-- +{-# INLINE partitionByFstM #-} +partitionByFstM :: Monad m + => (a -> m (Either b c)) -> Scanl m b x -> Scanl m c y -> Scanl m a (x, y) +partitionByFstM = partitionByMUsing teeWithFst + +-- | Similar to 'partitionByM' but terminates when any fold terminates. +-- +{-# INLINE partitionByMinM #-} +partitionByMinM :: Monad m => + (a -> m (Either b c)) -> Scanl m b x -> Scanl m c y -> Scanl m a (x, y) +partitionByMinM = partitionByMUsing teeWithMin +-} + +-- Note: we could use (a -> Bool) instead of (a -> Either b c), but the latter +-- makes the signature clearer as to which case belongs to which scan. +-- XXX need to check the performance in both cases. + +-- | Same as 'partitionByM' but with a pure partition function. +-- +-- Example, count even and odd numbers in a stream: +-- +-- >>> :{ +-- let f = Scanl.partitionBy (\n -> if even n then Left n else Right n) +-- (fmap (("Even " ++) . show) Scanl.length) +-- (fmap (("Odd " ++) . show) Scanl.length) +-- in Stream.toList $ Stream.postscanl f (Stream.enumerateFromTo 1 10) +-- :} +-- ["Odd 1","Even 1","Odd 2","Even 2","Odd 3","Even 3","Odd 4","Even 4","Odd 5","Even 5"] +-- +-- /Pre-release/ +{-# INLINE partitionBy #-} +partitionBy :: Monad m + => (a -> Either b c) -> Scanl m b x -> Scanl m c x -> Scanl m a x +partitionBy f = partitionByM (return . f) + +-- | Compose two scans such that the combined scan accepts a stream of 'Either' +-- and routes the 'Left' values to the first scan and 'Right' values to the +-- second scan. +-- +-- Definition: +-- +-- >>> partition = Scanl.partitionBy id +-- +{-# INLINE partition #-} +partition :: Monad m + => Scanl m b x -> Scanl m c x -> Scanl m (Either b c) x +partition = partitionBy id + +{- +-- | Send one item to each fold in a round-robin fashion. This is the consumer +-- side dual of producer side 'mergeN' operation. +-- +-- partitionN :: Monad m => [Scanl m a b] -> Scanl m a [b] +-- partitionN fs = Fold step begin done +-} + +------------------------------------------------------------------------------ +-- Unzipping +------------------------------------------------------------------------------ + +{-# INLINE unzipWithMUsing #-} +unzipWithMUsing :: Monad m => + ( (x -> y -> (x, y)) + -> Scanl m (b, c) x + -> Scanl m (b, c) y + -> Scanl m (b, c) (x, y) + ) + -> (a -> m (b, c)) + -> Scanl m b x + -> Scanl m c y + -> Scanl m a (x, y) +unzipWithMUsing t f fld1 fld2 = + let f1 = lmap fst fld1 -- :: Scanl m (b, c) b + f2 = lmap snd fld2 -- :: Scanl m (b, c) c + in lmapM f (t (,) f1 f2) + +-- | Like 'unzipWith' but with a monadic splitter function. +-- +-- Definition: +-- +-- >>> unzipWithM k f1 f2 = Scanl.lmapM k (Scanl.unzip f1 f2) +-- +-- /Pre-release/ +{-# INLINE unzipWithM #-} +unzipWithM :: Monad m + => (a -> m (b,c)) -> Scanl m b x -> Scanl m c y -> Scanl m a (x,y) +unzipWithM = unzipWithMUsing teeWith + +{- +-- | Similar to 'unzipWithM' but terminates when the first fold terminates. +-- +{-# INLINE unzipWithFstM #-} +unzipWithFstM :: Monad m => + (a -> m (b, c)) -> Scanl m b x -> Scanl m c y -> Scanl m a (x, y) +unzipWithFstM = unzipWithMUsing teeWithFst + +-- | Similar to 'unzipWithM' but terminates when any fold terminates. +-- +{-# INLINE unzipWithMaxM #-} +unzipWithMaxM :: Monad m => + (a -> m (b,c)) -> Scanl m b x -> Scanl m c y -> Scanl m a (x,y) +unzipWithMaxM = unzipWithMUsing teeWithMax +-} + +-- | Split elements in the input stream into two parts using a pure splitter +-- function, direct each part to a different scan and zip the results. +-- +-- Definitions: +-- +-- >>> unzipWith f = Scanl.unzipWithM (return . f) +-- >>> unzipWith f fld1 fld2 = Scanl.lmap f (Scanl.unzip fld1 fld2) +-- +-- This scan terminates as soon as any of the input scans terminate. +-- +-- /Pre-release/ +{-# INLINE unzipWith #-} +unzipWith :: Monad m + => (a -> (b,c)) -> Scanl m b x -> Scanl m c y -> Scanl m a (x,y) +unzipWith f = unzipWithM (return . f) + +-- | Send the elements of tuples in a stream of tuples through two different +-- scans. +-- +-- @ +-- +-- |-------Scanl m a x--------| +-- ---------stream of (a,b)--| |----m (x,y) +-- |-------Scanl m b y--------| +-- +-- @ +-- +-- Definition: +-- +-- >>> unzip = Scanl.unzipWith id +-- +-- This is the consumer side dual of the producer side 'zip' operation. +-- +{-# INLINE unzip #-} +unzip :: Monad m => Scanl m a x -> Scanl m b y -> Scanl m (a,b) (x,y) +unzip = unzipWith id + +------------------------------------------------------------------------------ +-- Combining streams and scans - Zipping +------------------------------------------------------------------------------ + +-- XXX These can be implemented using the fold scan, using the stream as a +-- state. +-- XXX Stream Skip state cannot be efficiently handled in folds but can be +-- handled in parsers using the Continue facility. See zipWithM in the Parser +-- module. +-- +-- cmpBy, eqBy, isPrefixOf, isSubsequenceOf etc can be implemented using +-- zipStream. + +-- | Zip a stream with the input of a scan using the supplied function. +-- +-- /Unimplemented/ +-- +{-# INLINE zipStreamWithM #-} +zipStreamWithM :: -- Monad m => + (a -> b -> m c) -> Stream m a -> Scanl m c x -> Scanl m b x +zipStreamWithM = undefined + +-- | Zip a stream with the input of a scan. +-- +-- >>> zip = Scanl.zipStreamWithM (curry return) +-- +-- /Unimplemented/ +-- +{-# INLINE zipStream #-} +zipStream :: Monad m => Stream m a -> Scanl m (a, b) x -> Scanl m b x +zipStream = zipStreamWithM (curry return) + +-- | Pair each element of a scan input with its index, starting from index 0. +-- +{-# INLINE indexingWith #-} +indexingWith :: Monad m => Int -> (Int -> Int) -> Scanl m a (Maybe (Int, a)) +indexingWith i f = fmap toMaybe $ mkScanl step initial + + where + + initial = Nothing' + + step Nothing' a = Just' (i, a) + step (Just' (n, _)) a = Just' (f n, a) + +-- | +-- >>> indexing = Scanl.indexingWith 0 (+ 1) +-- +{-# INLINE indexing #-} +indexing :: Monad m => Scanl m a (Maybe (Int, a)) +indexing = indexingWith 0 (+ 1) + +-- | +-- >>> indexingRev n = Scanl.indexingWith n (subtract 1) +-- +{-# INLINE indexingRev #-} +indexingRev :: Monad m => Int -> Scanl m a (Maybe (Int, a)) +indexingRev n = indexingWith n (subtract 1) + +-- | Pair each element of a scan input with its index, starting from index 0. +-- +-- >>> indexed = Scanl.postscanlMaybe Scanl.indexing +-- +{-# INLINE indexed #-} +indexed :: Monad m => Scanl m (Int, a) b -> Scanl m a b +indexed = postscanlMaybe indexing + +-- | Change the predicate function of a Scanl from @a -> b@ to accept an +-- additional state input @(s, a) -> b@. Convenient to filter with an +-- addiitonal index or time input. +-- +-- >>> filterWithIndex = Scanl.with Scanl.indexed Scanl.filter +-- +-- @ +-- filterWithAbsTime = with timestamped filter +-- filterWithRelTime = with timeIndexed filter +-- @ +-- +-- /Pre-release/ +{-# INLINE with #-} +with :: + (Scanl m (s, a) b -> Scanl m a b) + -> (((s, a) -> c) -> Scanl m (s, a) b -> Scanl m (s, a) b) + -> (((s, a) -> c) -> Scanl m a b -> Scanl m a b) +with f comb g = f . comb g . lmap snd + +-- XXX Implement as a filter +-- sampleFromthen :: Monad m => Int -> Int -> Scanl m a (Maybe a) + +-- | @sampleFromthen offset stride@ samples the element at @offset@ index and +-- then every element at strides of @stride@. +-- +{-# INLINE sampleFromthen #-} +sampleFromthen :: Monad m => Int -> Int -> Scanl m a b -> Scanl m a b +sampleFromthen offset size = + with indexed filter (\(i, _) -> (i + offset) `mod` size == 0) + +------------------------------------------------------------------------------ +-- Nesting +------------------------------------------------------------------------------ + +{- +-- | @concatSequence f t@ applies folds from stream @t@ sequentially and +-- collects the results using the fold @f@. +-- +-- /Unimplemented/ +-- +{-# INLINE concatSequence #-} +concatSequence :: + -- IsStream t => + Fold m b c -> t (Scanl m a b) -> Scanl m a c +concatSequence _f _p = undefined + +-- | Group the input stream into groups of elements between @low@ and @high@. +-- Collection starts in chunks of @low@ and then keeps doubling until we reach +-- @high@. Each chunk is folded using the provided fold function. +-- +-- This could be useful, for example, when we are folding a stream of unknown +-- size to a stream of arrays and we want to minimize the number of +-- allocations. +-- +-- NOTE: this would be an application of "many" using a terminating fold. +-- +-- /Unimplemented/ +-- +{-# INLINE chunksBetween #-} +chunksBetween :: -- Monad m => + Int -> Int -> Scanl m a b -> Scanl m b c -> Scanl m a c +chunksBetween _low _high _f1 _f2 = undefined +-} + +-- | A scan that buffers its input to a pure stream. +-- +-- /Warning!/ working on large streams accumulated as buffers in memory could +-- be very inefficient, consider using "Streamly.Data.Array" instead. +-- +-- >>> toStream = fmap Stream.fromList Scanl.toList +-- +-- /Pre-release/ +{-# INLINE toStream #-} +toStream :: (Monad m, Monad n) => Scanl m a (Stream n a) +toStream = fmap StreamD.fromList toList + +-- This is more efficient than 'toStream'. toStream is exactly the same as +-- reversing the stream after toStreamRev. +-- +-- | Buffers the input stream to a pure stream in the reverse order of the +-- input. +-- +-- >>> toStreamRev = fmap Stream.fromList Scanl.toListRev +-- +-- /Warning!/ working on large streams accumulated as buffers in memory could +-- be very inefficient, consider using "Streamly.Data.Array" instead. +-- +-- /Pre-release/ + +-- xn : ... : x2 : x1 : [] +{-# INLINE toStreamRev #-} +toStreamRev :: (Monad m, Monad n) => Scanl m a (Stream n a) +toStreamRev = fmap StreamD.fromList toListRev + +-- XXX This does not fuse. It contains a recursive step function. We will need +-- a Skip input constructor in the fold type to make it fuse. + +-- | Unfold and flatten the input stream of a scan. +-- +-- @ +-- Stream.scanl (unfoldMany u f) == Stream.scanl f . Stream.unfoldMany u +-- @ +-- +-- /Pre-release/ +{-# INLINE unfoldMany #-} +unfoldMany :: Monad m => Unfold m a b -> Scanl m b c -> Scanl m a c +unfoldMany (Unfold ustep inject) (Scanl fstep initial extract final) = + Scanl consume initial extract final + + where + + {-# INLINE produce #-} + produce fs us = do + ures <- ustep us + case ures of + StreamD.Yield b us1 -> do + fres <- fstep fs b + case fres of + Partial fs1 -> produce fs1 us1 + -- XXX What to do with the remaining stream? + Done c -> return $ Done c + StreamD.Skip us1 -> produce fs us1 + StreamD.Stop -> return $ Partial fs + + {-# INLINE_LATE consume #-} + consume s a = inject a >>= produce s + +-- | Get the bottom most @n@ elements using the supplied comparison function. +-- +{-# INLINE bottomBy #-} +bottomBy :: (MonadIO m, Unbox a) => + (a -> a -> Ordering) + -> Int + -> Scanl m a (MutArray a) +bottomBy cmp n = Scanl step initial extract extract + + where + + initial = do + arr <- MA.emptyOf' n + if n <= 0 + then return $ Done arr + else return $ Partial (arr, 0) + + step (arr, i) x = + if i < n + then do + arr' <- MA.snoc arr x + MA.bubble cmp arr' + return $ Partial (arr', i + 1) + else do + x1 <- MA.unsafeGetIndex (i - 1) arr + case x `cmp` x1 of + LT -> do + MA.unsafePutIndex (i - 1) arr x + MA.bubble cmp arr + return $ Partial (arr, i) + _ -> return $ Partial (arr, i) + + extract = return . fst + +-- | Get the top @n@ elements using the supplied comparison function. +-- +-- To get bottom n elements instead: +-- +-- >>> bottomBy cmp = Scanl.topBy (flip cmp) +-- +-- Example: +-- +-- >>> stream = Stream.fromList [2::Int,7,9,3,1,5,6,11,17] +-- >>> Stream.toList (Stream.scanl (Scanl.topBy compare 3) stream) >>= mapM MutArray.toList +-- [[],[17],[17,11],[17,11,9],[17,11,9],[17,11,9],[17,11,9],[17,11,9],[17,11,9],[17,11,9]] +-- +-- /Pre-release/ +-- +{-# INLINE topBy #-} +topBy :: (MonadIO m, Unbox a) => + (a -> a -> Ordering) + -> Int + -> Scanl m a (MutArray a) +topBy cmp = bottomBy (flip cmp) + +-- | Scan the input stream to top n elements. +-- +-- Definition: +-- +-- >>> top = Scanl.topBy compare +-- +-- >>> stream = Stream.fromList [2::Int,7,9,3,1,5,6,11,17] +-- >>> Stream.toList (Stream.scanl (Scanl.top 3) stream) >>= mapM MutArray.toList +-- [[],[17],[17,11],[17,11,9],[17,11,9],[17,11,9],[17,11,9],[17,11,9],[17,11,9],[17,11,9]] +-- +-- /Pre-release/ +{-# INLINE top #-} +top :: (MonadIO m, Unbox a, Ord a) => Int -> Scanl m a (MutArray a) +top = bottomBy $ flip compare + +-- | Scan the input stream to bottom n elements. +-- +-- Definition: +-- +-- >>> bottom = Scanl.bottomBy compare +-- +-- >>> stream = Stream.fromList [2::Int,7,9,3,1,5,6,11,17] +-- >>> Stream.toList (Stream.scanl (Scanl.bottom 3) stream) >>= mapM MutArray.toList +-- [[],[1],[1,2],[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3]] +-- +-- /Pre-release/ +{-# INLINE bottom #-} +bottom :: (MonadIO m, Unbox a, Ord a) => Int -> Scanl m a (MutArray a) +bottom = bottomBy compare + +{- +------------------------------------------------------------------------------ +-- Interspersed parsing +------------------------------------------------------------------------------ + +data IntersperseQState fs ps = + IntersperseQUnquoted !fs !ps + | IntersperseQQuoted !fs !ps + | IntersperseQQuotedEsc !fs !ps + +-- Useful for parsing CSV with quoting and escaping +{-# INLINE intersperseWithQuotes #-} +intersperseWithQuotes :: (Monad m, Eq a) => + a -> a -> a -> Scanl m a b -> Scanl m b c -> Scanl m a c +intersperseWithQuotes + quote + esc + separator + (Scanl stepL initialL _ finalL) + (Scanl stepR initialR extractR finalR) = Scanl step initial extract final + + where + + errMsg p status = + error $ "intersperseWithQuotes: " ++ p ++ " parsing fold cannot " + ++ status ++ " without input" + + {-# INLINE initL #-} + initL mkState = do + resL <- initialL + case resL of + Partial sL -> + return $ Partial $ mkState sL + Done _ -> + errMsg "content" "succeed" + + initial = do + res <- initialR + case res of + Partial sR -> initL (IntersperseQUnquoted sR) + Done b -> return $ Done b + + {-# INLINE collect #-} + collect nextS sR b = do + res <- stepR sR b + case res of + Partial s -> + initL (nextS s) + Done c -> return (Done c) + + {-# INLINE process #-} + process a sL sR nextState = do + r <- stepL sL a + case r of + Partial s -> return $ Partial (nextState sR s) + Done b -> collect nextState sR b + + {-# INLINE processQuoted #-} + processQuoted a sL sR nextState = do + r <- stepL sL a + case r of + Partial s -> return $ Partial (nextState sR s) + Done _ -> do + _ <- finalR sR + error "Collecting fold finished inside quote" + + step (IntersperseQUnquoted sR sL) a + | a == separator = do + b <- finalL sL + collect IntersperseQUnquoted sR b + | a == quote = processQuoted a sL sR IntersperseQQuoted + | otherwise = process a sL sR IntersperseQUnquoted + + step (IntersperseQQuoted sR sL) a + | a == esc = processQuoted a sL sR IntersperseQQuotedEsc + | a == quote = process a sL sR IntersperseQUnquoted + | otherwise = processQuoted a sL sR IntersperseQQuoted + + step (IntersperseQQuotedEsc sR sL) a = + processQuoted a sL sR IntersperseQQuoted + + extract (IntersperseQUnquoted sR _) = extractR sR + extract (IntersperseQQuoted _ _) = + error "intersperseWithQuotes: finished inside quote" + extract (IntersperseQQuotedEsc _ _) = + error "intersperseWithQuotes: finished inside quote, at escape char" + + final (IntersperseQUnquoted sR sL) = finalL sL *> finalR sR + final (IntersperseQQuoted sR sL) = do + _ <- finalR sR + _ <- finalL sL + error "intersperseWithQuotes: finished inside quote" + final (IntersperseQQuotedEsc sR sL) = do + _ <- finalR sR + _ <- finalL sL + error "intersperseWithQuotes: finished inside quote, at escape char" +-} diff --git a/src/Streamly/Internal/Data/Scanl/Container.hs b/src/Streamly/Internal/Data/Scanl/Container.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Scanl/Container.hs @@ -0,0 +1,850 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Scanl.Container +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Streamly.Internal.Data.Scanl.Container + ( + -- * Set operations + toSet + , toIntSet + , countDistinct + , countDistinctInt + , nub + , nubInt + + -- * Map operations + -- , frequency + + -- ** Demultiplexing + -- | Direct values in the input stream to different scans using an n-ary + -- scan selector. 'demux' is a generalization of 'classify' (and + -- 'partition') where each key of the classifier can use a different scan. + -- + -- You need to see only 'demux' if you are looking to find the capabilities + -- of these combinators, all others are variants of that. + + {- + -- *** Output is a container + -- | The fold state snapshot returns the key-value container of in-progress + -- folds. + , demuxToContainer + , demuxToContainerIO + , demuxToMap + , demuxToMapIO + + -- *** Input is explicit key-value tuple + -- | Like above but inputs are in explicit key-value pair form. + , demuxKvToContainer + , demuxKvToMap + + -- *** Scan of finished fold results + -- | Like above, but the resulting fold state snapshot contains the key + -- value container as well as the finished key result if a fold in the + -- container finished. + -} + , demuxGeneric + , demux + , demuxGenericIO + , demuxIO + + -- TODO: These can be implemented using the above operations + -- , demuxSel -- Stop when the fold for the specified key stops + -- , demuxMin -- Stop when any of the folds stop + -- , demuxAll -- Stop when all the folds stop (run once) + + -- ** Classifying + -- | In an input stream of key value pairs fold values for different keys + -- in individual output buckets using the given fold. 'classify' is a + -- special case of 'demux' where all the branches of the demultiplexer use + -- the same scan. + -- + -- Different types of maps can be used with these combinators via the IsMap + -- type class. Hashmap performs better when there are more collisions, trie + -- Map performs better otherwise. Trie has an advantage of sorting the keys + -- at the same time. For example if we want to store a dictionary of words + -- and their meanings then trie Map would be better if we also want to + -- display them in sorted order. + + {- + , kvToMap + + , toContainer + , toContainerIO + , toMap + , toMapIO + -} + + , classifyGeneric + , classify + , classifyGenericIO + , classifyIO + -- , toContainerSel + -- , toContainerMin + ) +where + +#include "inline.hs" +#include "ArrayMacros.h" + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Map.Strict (Map) +import Data.IntSet (IntSet) +import Data.Set (Set) +import Streamly.Internal.Data.IsMap (IsMap(..)) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..)) + +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set +import qualified Streamly.Internal.Data.IsMap as IsMap + +import Prelude hiding (Foldable(..)) +import Streamly.Internal.Data.Scanl.Type +-- import Streamly.Internal.Data.Scanl.Combinators + +#include "DocTestDataScanl.hs" + +-- | Scan the input adding it to a set. +-- +-- Definition: +-- +-- >>> toSet = Scanl.mkScanl (flip Set.insert) Set.empty +-- +{-# INLINE toSet #-} +toSet :: (Monad m, Ord a) => Scanl m a (Set a) +toSet = mkScanl (flip Set.insert) Set.empty + +-- | Scan the input adding it to an int set. For integer inputs this performs +-- better than 'toSet'. +-- +-- Definition: +-- +-- >>> toIntSet = Scanl.mkScanl (flip IntSet.insert) IntSet.empty +-- +{-# INLINE toIntSet #-} +toIntSet :: Monad m => Scanl m Int IntSet +toIntSet = mkScanl (flip IntSet.insert) IntSet.empty + +-- XXX Name as nubOrd? Or write a nubGeneric + +-- | Returns 'Just' for the first occurrence of an element, returns 'Nothing' +-- for any other occurrences. +-- +-- Example: +-- +-- >>> stream = Stream.fromList [1::Int,1,2,3,4,4,5,1,5,7] +-- >>> Stream.toList $ Stream.postscanlMaybe Scanl.nub stream +-- [1,2,3,4,5,7] +-- +-- /Pre-release/ +{-# INLINE nub #-} +nub :: (Monad m, Ord a) => Scanl m a (Maybe a) +nub = fmap (\(Tuple' _ x) -> x) $ mkScanl step initial + + where + + initial = Tuple' Set.empty Nothing + + step (Tuple' set _) x = + if Set.member x set + then Tuple' set Nothing + else Tuple' (Set.insert x set) (Just x) + +-- | Like 'nub' but specialized to a stream of 'Int', for better performance. +-- +-- /Pre-release/ +{-# INLINE nubInt #-} +nubInt :: Monad m => Scanl m Int (Maybe Int) +nubInt = fmap (\(Tuple' _ x) -> x) $ mkScanl step initial + + where + + initial = Tuple' IntSet.empty Nothing + + step (Tuple' set _) x = + if IntSet.member x set + then Tuple' set Nothing + else Tuple' (IntSet.insert x set) (Just x) + +-- XXX Try Hash set +-- XXX Add a countDistinct window fold +-- XXX Add a bloom filter fold + +-- | Count non-duplicate elements in the stream. +-- +-- Definition: +-- +-- >>> countDistinct = fmap Set.size Scanl.toSet +-- >>> countDistinct = Scanl.postscanl Scanl.nub $ Scanl.catMaybes $ Scanl.length +-- +-- The memory used is proportional to the number of distinct elements in the +-- stream, to guard against using too much memory use it as a scan and +-- terminate if the count reaches more than a threshold. +-- +-- /Space/: \(\mathcal{O}(n)\) +-- +-- /Pre-release/ +-- +{-# INLINE countDistinct #-} +countDistinct :: (Monad m, Ord a) => Scanl m a Int +-- countDistinct = postscan nub $ catMaybes length +countDistinct = fmap Set.size toSet +{- +countDistinct = fmap (\(Tuple' _ n) -> n) $ foldl' step initial + + where + + initial = Tuple' Set.empty 0 + + step (Tuple' set n) x = do + if Set.member x set + then + Tuple' set n + else + let cnt = n + 1 + in Tuple' (Set.insert x set) cnt +-} + +-- | Like 'countDistinct' but specialized to a stream of 'Int', for better +-- performance. +-- +-- Definition: +-- +-- >>> countDistinctInt = fmap IntSet.size Scanl.toIntSet +-- >>> countDistinctInt = Scanl.postscanl Scanl.nubInt $ Scanl.catMaybes $ Scanl.length +-- +-- /Pre-release/ +{-# INLINE countDistinctInt #-} +countDistinctInt :: Monad m => Scanl m Int Int +-- countDistinctInt = postscan nubInt $ catMaybes length +countDistinctInt = fmap IntSet.size toIntSet +{- +countDistinctInt = fmap (\(Tuple' _ n) -> n) $ foldl' step initial + + where + + initial = Tuple' IntSet.empty 0 + + step (Tuple' set n) x = do + if IntSet.member x set + then + Tuple' set n + else + let cnt = n + 1 + in Tuple' (IntSet.insert x set) cnt + -} + +------------------------------------------------------------------------------ +-- demux: in a key value stream fold each key sub-stream with a different fold +------------------------------------------------------------------------------ + +-- TODO Demultiplex an input element into a number of typed variants. We want +-- to statically restrict the target values within a set of predefined types, +-- an enumeration of a GADT. +-- +-- This is the consumer side dual of the producer side 'mux' operation (XXX to +-- be implemented). +-- +-- XXX If we use Refold in it, it can perhaps fuse/be more efficient. For +-- example we can store just the result rather than storing the whole fold in +-- the Map. This would be similar to a refold based classify. +-- +-- Note: There are separate functions to determine Key and Fold from the input +-- because key is to be determined on each input whereas fold is to be +-- determined only once for a key. +-- +-- XXX If a scan terminates do not start it again? This can be easily done by +-- installing a drain fold after a fold is done. +-- +-- XXX We can use the Scan drain step to drain the buffered map in the end. + +-- | This is the most general of all demux, classify operations. +-- +-- The first component of the output tuple is a key-value Map of in-progress +-- scans. The scan returns the scan result as the second component of the +-- output tuple. +-- +-- See 'demux' for documentation. +{-# INLINE demuxGeneric #-} +demuxGeneric :: (Monad m, IsMap f, Traversable f) => + (a -> Key f) + -> (Key f -> m (Maybe (Scanl m a b))) + -> Scanl m a (m (f b), Maybe (Key f, b)) +demuxGeneric getKey getFold = + Scanl (\s a -> Partial <$> step s a) (Partial <$> initial) extract final + + where + + initial = return $ Tuple' IsMap.mapEmpty Nothing + + {-# INLINE runFold #-} + runFold kv (Scanl step1 initial1 extract1 final1) (k, a) = do + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + case res1 of + Partial ss -> do + b <- extract1 ss + let fld = Scanl step1 (return res1) extract1 final1 + return + $ Tuple' + (IsMap.mapInsert k fld kv) (Just (k, b)) + Done b -> + return + $ Tuple' (IsMap.mapDelete k kv) (Just (k, b)) + Done b -> + -- Done in "initial" is possible only for the very first time + -- the fold is initialized, and in that case we have not yet + -- inserted it in the Map, so we do not need to delete it. + return $ Tuple' kv (Just (k, b)) + + step (Tuple' kv _) a = do + let k = getKey a + case IsMap.mapLookup k kv of + Nothing -> do + mfld <- getFold k + case mfld of + Nothing -> pure $ Tuple' kv Nothing + Just fld -> runFold kv fld (k, a) + Just f -> runFold kv f (k, a) + + extract (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f (Scanl _ i e _) = do + r <- i + case r of + Partial s -> e s + _ -> error "demuxGeneric: unreachable code" + + final (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f (Scanl _ i _ fin) = do + r <- i + case r of + Partial s -> fin s + _ -> error "demuxGeneric: unreachable code" + +{-# INLINE demuxUsingMap #-} +demuxUsingMap :: (Monad m, Ord k) => + (a -> k) + -> (k -> m (Maybe (Scanl m a b))) + -> Scanl m a (m (Map k b), Maybe (k, b)) +demuxUsingMap = demuxGeneric + +-- | @demux getKey getScan@: In a key value stream, scan values corresponding +-- to each key using a key specific scan. @getScan@ is invoked to generate a +-- key specific scan when a key is encountered for the first time in the +-- stream. If a scan does not exist corresponding to the key then 'Nothing' is +-- returned otherwise the result of the scan is returned. +-- +-- If a scan terminates, another instance of the scan is started upon receiving +-- an input with that key, @getScan@ is invoked again whenever the key is +-- encountered again. +-- +-- This can be used to scan a stream, splitting it based on different keys. +-- +-- Since the scan generator function is monadic we can add scans dynamically. +-- For example, we can maintain a Map of keys to scans in an IORef and lookup +-- the scan from that corresponding to a key. This Map can be changed +-- dynamically, scans for new keys can be added or scans for old keys can be +-- deleted or modified. +-- +-- Compare with 'classify', the scan in 'classify' is a static scan. +-- +-- /Pre-release/ +-- +{-# INLINE demux #-} +demux :: (Monad m, Ord k) => + (a -> k) + -> (k -> m (Maybe (Scanl m a b))) + -> Scanl m a (Maybe (k, b)) +demux getKey = fmap snd . demuxUsingMap getKey + +-- XXX We can use the Scan drain step to drain the buffered map in the end. + +-- | This is specialized version of 'demuxGeneric' that uses mutable IO cells +-- as scan accumulators for better performance. +-- +-- Keep in mind that the values in the returned Map may be changed by the +-- ongoing scan if you are using those concurrently in another thread. +-- +{-# INLINE demuxGenericIO #-} +demuxGenericIO :: (MonadIO m, IsMap f, Traversable f) => + (a -> Key f) + -> (Key f -> m (Maybe (Scanl m a b))) + -> Scanl m a (m (f b), Maybe (Key f, b)) +demuxGenericIO getKey getFold = + Scanl (\s a -> Partial <$> step s a) (Partial <$> initial) extract final + + where + + initial = return $ Tuple' IsMap.mapEmpty Nothing + + {-# INLINE initFold #-} + initFold kv (Scanl step1 initial1 extract1 final1) (k, a) = do + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + case res1 of + Partial ss -> do + -- XXX Instead of using a Fold type here use a custom + -- type with an IORef (possibly unboxed) for the + -- accumulator. That will reduce the allocations. + let fld = Scanl step1 (return res1) extract1 final1 + ref <- liftIO $ newIORef fld + b <- extract1 ss + return + $ Tuple' (IsMap.mapInsert k ref kv) (Just (k, b)) + Done b -> return $ Tuple' kv (Just (k, b)) + Done b -> return $ Tuple' kv (Just (k, b)) + + {-# INLINE runFold #-} + runFold kv ref (Scanl step1 initial1 extract1 final1) (k, a) = do + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + case res1 of + Partial ss -> do + let fld = Scanl step1 (return res1) extract1 final1 + liftIO $ writeIORef ref fld + b <- extract1 ss + return $ Tuple' kv (Just (k, b)) + Done b -> + let kv1 = IsMap.mapDelete k kv + in return $ Tuple' kv1 (Just (k, b)) + Done _ -> error "demuxGenericIO: unreachable" + + step (Tuple' kv _) a = do + let k = getKey a + case IsMap.mapLookup k kv of + Nothing -> do + res <- getFold k + case res of + Nothing -> pure $ Tuple' kv Nothing + Just f -> initFold kv f (k, a) + Just ref -> do + f <- liftIO $ readIORef ref + runFold kv ref f (k, a) + + extract (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f ref = do + Scanl _ i e _ <- liftIO $ readIORef ref + r <- i + case r of + Partial s -> e s + _ -> error "demuxGenericIO: unreachable code" + + final (Tuple' kv x) = return (Prelude.mapM f kv, x) + + where + + f ref = do + Scanl _ i _ fin <- liftIO $ readIORef ref + r <- i + case r of + Partial s -> fin s + _ -> error "demuxGenericIO: unreachable code" + +{-# INLINE demuxUsingMapIO #-} +demuxUsingMapIO :: (MonadIO m, Ord k) => + (a -> k) + -> (k -> m (Maybe (Scanl m a b))) + -> Scanl m a (m (Map k b), Maybe (k, b)) +demuxUsingMapIO = demuxGenericIO + +-- | This is specialized version of 'demux' that uses mutable IO cells as scan +-- accumulators for better performance. +-- +{-# INLINE demuxIO #-} +demuxIO :: (MonadIO m, Ord k) => + (a -> k) + -> (k -> m (Maybe (Scanl m a b))) + -> Scanl m a (Maybe (k, b)) +demuxIO getKey = fmap snd . demuxUsingMapIO getKey + +{- +-- | Fold a key value stream to a key-value Map. If the same key appears +-- multiple times, only the last value is retained. +{-# INLINE kvToMapOverwriteGeneric #-} +kvToMapOverwriteGeneric :: (Monad m, IsMap f) => Scanl m (Key f, a) (f a) +kvToMapOverwriteGeneric = + mkScanl (\kv (k, v) -> IsMap.mapInsert k v kv) IsMap.mapEmpty + +{-# INLINE demuxToContainer #-} +demuxToContainer :: (Monad m, IsMap f, Traversable f) => + (a -> Key f) -> (Key f -> m (Scanl m a b)) -> Scanl m a (f b) +demuxToContainer getKey getFold = + let + classifier = demuxGeneric getKey getFold + getMap Nothing = pure IsMap.mapEmpty + getMap (Just action) = action + aggregator = + teeWith IsMap.mapUnion + (rmapM getMap $ lmap fst latest) + (lmap snd $ catMaybes kvToMapOverwriteGeneric) + in postscan classifier aggregator + +-- | This collects all the results of 'demux' in a Map. +-- +{-# INLINE demuxToMap #-} +demuxToMap :: (Monad m, Ord k) => + (a -> k) -> (k -> m (Scanl m a b)) -> Scanl m a (Map k b) +demuxToMap = demuxToContainer + +{-# INLINE demuxToContainerIO #-} +demuxToContainerIO :: (MonadIO m, IsMap f, Traversable f) => + (a -> Key f) -> (Key f -> m (Scanl m a b)) -> Scanl m a (f b) +demuxToContainerIO getKey getFold = + let + classifier = demuxGenericIO getKey getFold + getMap Nothing = pure IsMap.mapEmpty + getMap (Just action) = action + aggregator = + teeWith IsMap.mapUnion + (rmapM getMap $ lmap fst latest) + (lmap snd $ catMaybes kvToMapOverwriteGeneric) + in postscan classifier aggregator + +-- | Same as 'demuxToMap' but uses 'demuxIO' for better performance. +-- +{-# INLINE demuxToMapIO #-} +demuxToMapIO :: (MonadIO m, Ord k) => + (a -> k) -> (k -> m (Scanl m a b)) -> Scanl m a (Map k b) +demuxToMapIO = demuxToContainerIO + +{-# INLINE demuxKvToContainer #-} +demuxKvToContainer :: (Monad m, IsMap f, Traversable f) => + (Key f -> m (Scanl m a b)) -> Scanl m (Key f, a) (f b) +demuxKvToContainer f = demuxToContainer fst (fmap (lmap snd) . f) + +-- | Fold a stream of key value pairs using a function that maps keys to folds. +-- +-- Definition: +-- +-- >>> demuxKvToMap f = Fold.demuxToContainer fst (Fold.lmap snd . f) +-- +-- Example: +-- +-- >>> import Data.Map (Map) +-- >>> :{ +-- let f "SUM" = return Fold.sum +-- f _ = return Fold.product +-- input = Stream.fromList [("SUM",1),("PRODUCT",2),("SUM",3),("PRODUCT",4)] +-- in Stream.fold (Fold.demuxKvToMap f) input :: IO (Map String Int) +-- :} +-- fromList [("PRODUCT",8),("SUM",4)] +-- +-- /Pre-release/ +{-# INLINE demuxKvToMap #-} +demuxKvToMap :: (Monad m, Ord k) => + (k -> m (Scanl m a b)) -> Scanl m (k, a) (Map k b) +demuxKvToMap = demuxKvToContainer +-} + +------------------------------------------------------------------------------ +-- Classify: Like demux but uses the same fold for all keys. +------------------------------------------------------------------------------ + +-- XXX Change these to make the behavior similar to demux* variants. We can +-- implement this using classifyScanManyWith. Maintain a set of done folds in +-- the underlying monad, and when initial is called look it up, if the fold is +-- done then initial would set a flag in the state to ignore the input or +-- return an error. + +-- XXX Use a Refold m k a b so that we can make the fold key specifc. +-- XXX Is using a function (a -> k) better than using the input (k,a)? +-- +-- XXX We can use the Scan drain step to drain the buffered map in the end. + +{-# INLINE classifyGeneric #-} +classifyGeneric :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => + -- Note: we need to return the Map itself to display the in-progress values + -- e.g. to implement top. We could possibly create a separate abstraction + -- for that use case. We return an action because we want it to be lazy so + -- that the downstream consumers can choose to process or discard it. + (a -> Key f) -> Scanl m a b -> Scanl m a (m (f b), Maybe (Key f, b)) +classifyGeneric f (Scanl step1 initial1 extract1 final1) = + Scanl (\s a -> Partial <$> step s a) (Partial <$> initial) extract final + + where + + -- XXX Instead of keeping a Set, after a scan terminates just install a + -- scan that always returns Partial/Nothing. + initial = return $ Tuple3' IsMap.mapEmpty Set.empty Nothing + + {-# INLINE initFold #-} + initFold kv set k a = do + x <- initial1 + case x of + Partial s -> do + r <- step1 s a + case r of + Partial s1 -> do + b <- extract1 s1 + return + $ Tuple3' (IsMap.mapInsert k s1 kv) set (Just (k, b)) + Done b -> + return $ Tuple3' kv set (Just (k, b)) + Done b -> return (Tuple3' kv (Set.insert k set) (Just (k, b))) + + step (Tuple3' kv set _) a = do + let k = f a + case IsMap.mapLookup k kv of + Nothing -> do + if Set.member k set + then return (Tuple3' kv set Nothing) + else initFold kv set k a + Just s -> do + r <- step1 s a + case r of + Partial s1 -> do + b <- extract1 s1 + return $ Tuple3' (IsMap.mapInsert k s1 kv) set (Just (k,b)) + Done b -> + let kv1 = IsMap.mapDelete k kv + in return $ Tuple3' kv1 (Set.insert k set) (Just (k, b)) + + extract (Tuple3' kv _ x) = return (Prelude.mapM extract1 kv, x) + + final (Tuple3' kv set x) = return (IsMap.mapTraverseWithKey f1 kv, x) + + where + + f1 k s = do + if Set.member k set + -- XXX Why are we doing this? If it is in the set then it will not + -- be in the map and vice-versa. + then extract1 s + else final1 s + +{-# INLINE classifyUsingMap #-} +classifyUsingMap :: (Monad m, Ord k) => + (a -> k) -> Scanl m a b -> Scanl m a (m (Map k b), Maybe (k, b)) +classifyUsingMap = classifyGeneric + +-- XXX Make it consistent with denux. + +-- | Scans the values for each key using the supplied scan. +-- +-- Once the scan for a key terminates, any future values of the key are ignored. +-- +-- Equivalent to the following except that the scan is not restarted: +-- +-- >>> classify f fld = Scanl.demux f (const fld) +-- +{-# INLINE classify #-} +classify :: (MonadIO m, Ord k) => + (a -> k) -> Scanl m a b -> Scanl m a (Maybe (k, b)) +classify getKey = fmap snd . classifyUsingMap getKey + +-- XXX we can use a Prim IORef if we can constrain the state "s" to be Prim +-- +-- The code is almost the same as classifyGeneric except the IORef operations. +-- +-- XXX We can use the Scan drain step to drain the buffered map in the end. + +-- | Be aware that the values in the intermediate Maps would be mutable. +-- +{-# INLINE classifyGenericIO #-} +classifyGenericIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => + (a -> Key f) -> Scanl m a b -> Scanl m a (m (f b), Maybe (Key f, b)) +classifyGenericIO f (Scanl step1 initial1 extract1 final1) = + Scanl (\s a -> Partial <$> step s a) (Partial <$> initial) extract final + + where + + initial = return $ Tuple3' IsMap.mapEmpty Set.empty Nothing + + {-# INLINE initFold #-} + initFold kv set k a = do + x <- initial1 + case x of + Partial s -> do + r <- step1 s a + case r of + Partial s1 -> do + ref <- liftIO $ newIORef s1 + b <- extract1 s1 + return + $ Tuple3' + (IsMap.mapInsert k ref kv) set (Just (k, b)) + Done b -> + return $ Tuple3' kv set (Just (k, b)) + Done b -> return (Tuple3' kv (Set.insert k set) (Just (k, b))) + + step (Tuple3' kv set _) a = do + let k = f a + case IsMap.mapLookup k kv of + Nothing -> do + if Set.member k set + then return (Tuple3' kv set Nothing) + else initFold kv set k a + Just ref -> do + s <- liftIO $ readIORef ref + r <- step1 s a + case r of + Partial s1 -> do + liftIO $ writeIORef ref s1 + b <- extract1 s1 + return $ Tuple3' kv set (Just (k, b)) + Done b -> + let kv1 = IsMap.mapDelete k kv + in return + $ Tuple3' kv1 (Set.insert k set) (Just (k, b)) + + extract (Tuple3' kv _ x) = return (Prelude.mapM g kv, x) + + where + + g ref = liftIO (readIORef ref) >>= extract1 + + final (Tuple3' kv set x) = return (IsMap.mapTraverseWithKey g kv, x) + + where + + g k ref = do + s <- liftIO $ readIORef ref + if Set.member k set + then extract1 s + else final1 s + +{-# INLINE classifyUsingMapIO #-} +classifyUsingMapIO :: (MonadIO m, Ord k) => + (a -> k) -> Scanl m a b -> Scanl m a (m (Map k b), Maybe (k, b)) +classifyUsingMapIO = classifyGenericIO + +-- | Same as classify except that it uses mutable IORef cells in the +-- Map, providing better performance. +-- +-- Equivalent to the following except that the scan is not restarted: +-- +-- >>> classifyIO f fld = Scanl.demuxIO f (const fld) +-- +{-# INLINE classifyIO #-} +classifyIO :: (MonadIO m, Ord k) => + (a -> k) -> Scanl m a b -> Scanl m a (Maybe (k, b)) +classifyIO getKey = fmap snd . classifyUsingMapIO getKey + +{- +{-# INLINE toContainer #-} +toContainer :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => + (a -> Key f) -> Scanl m a b -> Scanl m a (f b) +toContainer f fld = + let + classifier = classifyGeneric f fld + getMap Nothing = pure IsMap.mapEmpty + getMap (Just action) = action + aggregator = + teeWith IsMap.mapUnion + (rmapM getMap $ lmap fst latest) + (lmap snd $ catMaybes kvToMapOverwriteGeneric) + in postscan classifier aggregator + +-- | Split the input stream based on a key field and fold each split using the +-- given fold. Useful for map/reduce, bucketizing the input in different bins +-- or for generating histograms. +-- +-- Example: +-- +-- >>> import Data.Map.Strict (Map) +-- >>> :{ +-- let input = Stream.fromList [("ONE",1),("ONE",1.1),("TWO",2), ("TWO",2.2)] +-- classify = Fold.toMap fst (Fold.lmap snd Fold.toList) +-- in Stream.fold classify input :: IO (Map String [Double]) +-- :} +-- fromList [("ONE",[1.0,1.1]),("TWO",[2.0,2.2])] +-- +-- Once the classifier fold terminates for a particular key any further inputs +-- in that bucket are ignored. +-- +-- Space used is proportional to the number of keys seen till now and +-- monotonically increases because it stores whether a key has been seen or +-- not. +-- +-- See 'demuxToMap' for a more powerful version where you can use a different +-- fold for each key. A simpler version of 'toMap' retaining only the last +-- value for a key can be written as: +-- +-- >>> toMap = Fold.foldl' (\kv (k, v) -> Map.insert k v kv) Map.empty +-- +-- /Stops: never/ +-- +-- /Pre-release/ +-- +{-# INLINE toMap #-} +toMap :: (Monad m, Ord k) => + (a -> k) -> Scanl m a b -> Scanl m a (Map k b) +toMap = toContainer + +{-# INLINE toContainerIO #-} +toContainerIO :: (MonadIO m, IsMap f, Traversable f, Ord (Key f)) => + (a -> Key f) -> Scanl m a b -> Scanl m a (f b) +toContainerIO f fld = + let + classifier = classifyGenericIO f fld + getMap Nothing = pure IsMap.mapEmpty + getMap (Just action) = action + aggregator = + teeWith IsMap.mapUnion + (rmapM getMap $ lmap fst latest) + (lmap snd $ catMaybes kvToMapOverwriteGeneric) + in postscan classifier aggregator + +-- | Same as 'toMap' but maybe faster because it uses mutable cells as +-- fold accumulators in the Map. +-- +{-# INLINE toMapIO #-} +toMapIO :: (MonadIO m, Ord k) => + (a -> k) -> Scanl m a b -> Scanl m a (Map k b) +toMapIO = toContainerIO + +-- | Given an input stream of key value pairs and a fold for values, fold all +-- the values belonging to each key. Useful for map/reduce, bucketizing the +-- input in different bins or for generating histograms. +-- +-- Definition: +-- +-- >>> kvToMap = Fold.toMap fst . Fold.lmap snd +-- +-- Example: +-- +-- >>> :{ +-- let input = Stream.fromList [("ONE",1),("ONE",1.1),("TWO",2), ("TWO",2.2)] +-- in Stream.fold (Fold.kvToMap Fold.toList) input +-- :} +-- fromList [("ONE",[1.0,1.1]),("TWO",[2.0,2.2])] +-- +-- /Pre-release/ +{-# INLINE kvToMap #-} +kvToMap :: (Monad m, Ord k) => Scanl m a b -> Scanl m (k, a) (Map k b) +kvToMap = toMap fst . lmap snd + +-- | Determine the frequency of each element in the stream. +-- +-- You can just collect the keys of the resulting map to get the unique +-- elements in the stream. +-- +-- Definition: +-- +-- >>> frequency = Fold.toMap id Fold.length +-- +{-# INLINE frequency #-} +frequency :: (Monad m, Ord a) => Scanl m a (Map a Int) +frequency = toMap id length +-} diff --git a/src/Streamly/Internal/Data/Scanl/Type.hs b/src/Streamly/Internal/Data/Scanl/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Scanl/Type.hs @@ -0,0 +1,2030 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Scanl.Type +-- Copyright : (c) 2019 Composewell Technologies +-- (c) 2013 Gabriel Gonzalez +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Scanl vs Pipe: +-- +-- A scanl is a simpler version of pipes. A scan always produces an output and +-- may or may not consume an input. It can consume at most one input on one +-- output. Whereas a pipe may consume input even without producing anything or +-- it can consume multiple inputs on a single output. Scans are simpler +-- abstractions to think about and easier for the compiler to optimize. +-- +-- Returning a stream on "extract": +-- +-- Make the extract function return a Step and call extract until Done or +-- alternatively if a fold wants to return multiple values during finalization +-- then we can make the fold output itself a list or stream (on each step). +-- +-- Maybe the extract function draining the buffer should be represented by a +-- pipe rather than a scan? It makes the scan behave like a pipe in the +-- finalization case. +-- +-- Scan type: +-- +-- We can represent the scan as: +-- +-- step :: +-- Partial s +-- Done b +-- extract :: s -> b +-- final :: s -> b +-- +-- This type allows the accumulator to be returned even if there is no input, +-- using final. This can implement "scanl" as well as "scanl1". +-- +-- We can call extract any time, means that it can always produce a valid +-- value. If the input is not last the driver can call "extract", if it is last +-- then it can call "final". +-- +-- This does not allow "id" to be implemented for Category instance. Because it +-- requires an output even if there is no input. +-- +-- How about the following type? +-- +-- step :: +-- Partial s b +-- Done b +-- final :: () +-- +-- This cannot produce output without an input. It can implement scanl1 but not +-- scanl. This can allow category instance, because "id" can be implemented. +-- But this cannot compose with Foldl type, as "final" does not return a value, +-- so the fold cannot return a value. +-- +-- How about the following type? +-- +-- step :: +-- Partial s b +-- Done b +-- final :: s -> b +-- +-- In this case we may not be able to avoid duplicate output. If the fold has +-- already consumed an input, Partial would have returned an output on the last +-- input, then we decide to stop the fold and use "final" on it, which will +-- again produce possibly the same output. +-- +module Streamly.Internal.Data.Scanl.Type + ( + module Streamly.Internal.Data.Fold.Step + + -- * Scanl Type + , Scanl (..) + + -- * Constructors + , mkScanl + , mkScanlM + , mkScanl1 + , mkScanl1M + , mkScant + , mkScantM + , mkScanr + , mkScanrM + + -- * Scans + , const + -- , fromPure + , constM + -- , fromEffect + , fromRefold + -- , fromScan + , drain + , latest + , functionM + , toList + , toStreamK + , toStreamKRev + , genericLength + , length -- call it "count"? + + , maximumBy + , maximum + , minimumBy + , minimum + , rangeBy + , range + + -- * Combinators + + -- ** Mapping output + , rmapM + + -- ** Mapping Input + , lmap + , lmapM + , postscanl + + -- ** Filtering + , catMaybes + , postscanlMaybe + , filter + , filtering + , filterM + , catLefts + , catRights + , catEithers + + -- ** Trimming + , take + , taking + , takeEndBy_ + , takeEndBy + , dropping + + {- + -- ** Sequential application + -- , splitWith -- rename to "append" + -- , split_ + + -- ** Repeated Application (Splitting) + , ManyState + , many + , manyPost + , groupsOf + , refoldMany + , refoldMany1 + + -- ** Nested Application + -- , concatMap + -- , duplicate + , refold + -} + + -- ** Parallel Distribution + , teeWith + -- , teeWithFst + -- , teeWithMax + + {- + -- ** Parallel Alternative + , shortest + , longest + + -- * Running A Fold + , extractM + , reduce + , snoc + , addOne + , snocM + , snocl + , snoclM + , close + , isClosed + -} + + -- * Transforming inner monad + , morphInner + , generalizeInner + ) +where + +#include "inline.hs" + +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import Control.Monad ((>=>)) +-- import Data.Bifunctor (Bifunctor(..)) +import Data.Either (fromLeft, fromRight, isLeft, isRight) +import Data.Functor ((<&>)) +import Data.Functor.Identity (Identity(..)) +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) +import Streamly.Internal.Data.Refold.Type (Refold(..)) +-- import Streamly.Internal.Data.Scan (Scan(..)) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) + +--import qualified Streamly.Internal.Data.Stream.Step as Stream +import qualified Streamly.Internal.Data.StreamK.Type as K + +import Prelude hiding (Foldable(..), concatMap, filter, map, take, const) + +-- Entire module is exported, do not import selectively +import Streamly.Internal.Data.Fold.Step + +#include "DocTestDataScanl.hs" + +------------------------------------------------------------------------------ +-- The Scanl type +------------------------------------------------------------------------------ + +-- An fold is akin to a writer. It is the streaming equivalent of a writer. +-- The type @b@ is the accumulator of the writer. That's the reason the +-- default folds in various modules are called "write". + +-- An alternative to using an "extract" function is to use "Partial s b" style +-- partial value so that we always emit the output value and there is no need +-- to extract. Then extract can be used for cleanup purposes. But in this case +-- in some cases we may need a "Continue" constructor where an output value is +-- not available, this was implicit earlier. Also, "b" should be lazy here so +-- that we do not always compute it even if we do not need it. +-- +-- Partial s b --> extract :: s -> b +-- Continue --> extract :: s -> Maybe b +-- +-- But keeping 'b' lazy does not let the fold optimize well. It leads to +-- significant regressions in the key-value folds. +-- +-- The "final" function complicates combinators that take other folds as +-- argument because we need to call their finalizers at right places. An +-- alternative to reduce this complexity where it is not required is to use a +-- separate type for bracketed folds but then we need to manage the complexity +-- of two different fold types. + +-- XXX The "final" function in a scan should not return an output. The output +-- from final would only be a duplicate of the last generated output. Since a +-- scan generates an ouput at each input, there should be nothing remaining to +-- be emitted during finalization. + +-- | The type @Scanl m a b@ represents a consumer of an input stream of values +-- of type @a@ and returning a final value of type @b@ in 'Monad' @m@. The +-- constructor of a scan is @Scanl step initial extract final@. +-- +-- The scan uses an internal state of type @s@. The initial value of the state +-- @s@ is created by @initial@. This function is called once and only once +-- before the scan starts consuming input. Any resource allocation can be done +-- in this function. +-- +-- The @step@ function is called on each input, it consumes an input and +-- returns the next intermediate state (see 'Step') or the final result @b@ if +-- the scan terminates. +-- +-- The @extract@ function is used by the scan +-- driver to map the current state @s@ of the scan to the scan result. Thus +-- @extract@ can be called multiple times. +-- +-- Before a scan terminates, @final@ is called once and only once (unless the +-- scan terminated in @initial@ itself). Any resources allocated by @initial@ +-- can be released in @final@. In scan that do not require any cleanup +-- @extract@ and @final@ are typically the same. +-- +-- When implementing scan combinators, care should be taken to cleanup any +-- state of the argument folds held by the fold by calling the respective +-- @final@ at all exit points of the scan. Also, @final@ should not be called +-- more than once. Note that if a scan terminates by 'Done' constructor, there +-- is no state to cleanup. +-- +-- NOTE: The constructor is not yet released, smart constructors are provided +-- to create scans. +-- +data Scanl m a b = + -- | @Scanl@ @step@ @initial@ @extract@ @final@ + forall s. Scanl (s -> a -> m (Step s b)) (m (Step s b)) (s -> m b) (s -> m b) + +{- +-- XXX Change the type to as follows. This takes care of the unfoldMany case +-- where we need to continue in produce mode. Though we need to see how it +-- impacts the key-value scans. +-- +data Step s b = + YieldC s b -- ^ Yield and consume + | YieldP s b -- ^ Yield and produce + | Stop b + +data Scanl m a b = + forall s. Scanl + (s -> a -> m (Step s b)) -- consume step + (m (Step s b)) -- initial + (s -> m (Step s b)) -- produce step + (s -> m (Step s b)) -- drain step +-} + +------------------------------------------------------------------------------ +-- Mapping on the output +------------------------------------------------------------------------------ + +-- | Map a monadic function on the output of a scan. +-- +{-# INLINE rmapM #-} +rmapM :: Monad m => (b -> m c) -> Scanl m a b -> Scanl m a c +rmapM f (Scanl step initial extract final) = + Scanl step1 initial1 (extract >=> f) (final >=> f) + + where + + initial1 = initial >>= mapMStep f + step1 s a = step s a >>= mapMStep f + +------------------------------------------------------------------------------ +-- Left fold constructors +------------------------------------------------------------------------------ + +-- | Make a scan from a left fold style pure step function and initial value of +-- the accumulator. +-- +-- If your 'Scanl' returns only 'Partial' (i.e. never returns a 'Done') then +-- you can use @mkScanl*@ constructors. +-- +{-# INLINE mkScanl #-} +mkScanl :: Monad m => (b -> a -> b) -> b -> Scanl m a b +mkScanl step initial = + Scanl + (\s a -> return $ Partial $ step s a) + (return (Partial initial)) + return + return + +-- | Make a scan from a left fold style monadic step function and initial value +-- of the accumulator. +-- +{-# INLINE mkScanlM #-} +mkScanlM :: Monad m => (b -> a -> m b) -> m b -> Scanl m a b +mkScanlM step initial = + Scanl (\s a -> Partial <$> step s a) (Partial <$> initial) return return + +-- | Maps a function on the output of the scan (the type @b@). +instance Functor m => Functor (Scanl m a) where + {-# INLINE fmap #-} + fmap f (Scanl step1 initial1 extract final) = + Scanl step initial (fmap2 f extract) (fmap2 f final) + + where + + initial = fmap2 f initial1 + step s b = fmap2 f (step1 s b) + fmap2 g = fmap (fmap g) + +-- | Make a strict left scan, for non-empty streams, using first element as the +-- starting value. Returns Nothing if the stream is empty. +-- +-- /Pre-release/ +{-# INLINE mkScanl1 #-} +mkScanl1 :: Monad m => (a -> a -> a) -> Scanl m a (Maybe a) +mkScanl1 step = fmap toMaybe $ mkScanl step1 Nothing' + + where + + step1 Nothing' a = Just' a + step1 (Just' x) a = Just' $ step x a + +-- | Like 'mkScanl1' but with a monadic step function. +-- +-- /Pre-release/ +{-# INLINE mkScanl1M #-} +mkScanl1M :: Monad m => (a -> a -> m a) -> Scanl m a (Maybe a) +mkScanl1M step = fmap toMaybe $ mkScanlM step1 (return Nothing') + + where + + step1 Nothing' a = return $ Just' a + step1 (Just' x) a = Just' <$> step x a + +{- +data FromScan s b = FromScanInit !s | FromScanGo !s !b + +-- XXX we can attach a scan on the last fold e.g. "runScan s last". Or run a +-- scan on a fold that supplies a default value? +-- +-- If we are pushing a value to a scan and the scan stops we will lose the +-- input. Only those scans that do not use the Stop constructor can be used as +-- folds or with folds? The Stop constructor makes them suitable to be composed +-- with pull based streams, push based folds cannot work with that. Do we need +-- two types of scans then, scans for streams and scans for folds? ScanR and +-- ScanL? + +-- | This does not work correctly yet. We lose the last input. +-- +{-# INLINE fromScan #-} +fromScan :: Monad m => Scan m a b -> Scanl m a (Maybe b) +fromScan (Scan consume initial) = + Fold fstep (return $ Partial (FromScanInit initial)) fextract fextract + + where + + fstep (FromScanInit ss) a = do + r <- consume ss a + return $ case r of + Stream.Yield b s -> Partial (FromScanGo s b) + Stream.Skip s -> Partial (FromScanInit s) + -- XXX We have lost the input here. + -- XXX Need to change folds to always return Done on the next input + Stream.Stop -> Done Nothing + fstep (FromScanGo ss acc) a = do + r <- consume ss a + return $ case r of + Stream.Yield b s -> Partial (FromScanGo s b) + Stream.Skip s -> Partial (FromScanGo s acc) + -- XXX We have lost the input here. + Stream.Stop -> Done (Just acc) + + fextract (FromScanInit _) = return Nothing + fextract (FromScanGo _ acc) = return (Just acc) +-} + +------------------------------------------------------------------------------ +-- Right fold constructors +------------------------------------------------------------------------------ + +-- | Make a scan using a right fold style step function and a terminal value. +-- It performs a strict right fold via a left fold using function composition. +-- Note that a strict right fold can only be useful for constructing strict +-- structures in memory. For reductions this will be very inefficient. +-- +-- Definitions: +-- +-- >>> mkScanr f z = fmap (flip appEndo z) $ Scanl.foldMap (Endo . f) +-- >>> mkScanr f z = fmap ($ z) $ Scanl.mkScanl (\g x -> g . f x) id +-- +-- Example: +-- +-- >>> Stream.toList $ Stream.scanl (Scanl.mkScanr (:) []) $ Stream.enumerateFromTo 1 5 +-- [[],[1],[1,2],[1,2,3],[1,2,3,4],[1,2,3,4,5]] +-- +{-# INLINE mkScanr #-} +mkScanr :: Monad m => (a -> b -> b) -> b -> Scanl m a b +mkScanr f z = fmap ($ z) $ mkScanl (\g x -> g . f x) id + +-- XXX we have not seen any use of this yet, not releasing until we have a use +-- case. + +-- | Like mkScanr but with a monadic step function. +-- +-- Example: +-- +-- >>> toList = Scanl.mkScanrM (\a xs -> return $ a : xs) (return []) +-- +-- /Pre-release/ +{-# INLINE mkScanrM #-} +mkScanrM :: Monad m => (a -> b -> m b) -> m b -> Scanl m a b +mkScanrM g z = + rmapM (z >>=) $ mkScanlM (\f x -> return $ g x >=> f) (return return) + +------------------------------------------------------------------------------ +-- General scan constructors +------------------------------------------------------------------------------ + +-- XXX If the Step yield gives the result each time along with the state then +-- we can make the type of this as +-- +-- mkFold :: Monad m => (s -> a -> Step s b) -> Step s b -> Scanl m a b +-- +-- Then similar to foldl' and foldr we can just fmap extract on it to extend +-- it to the version where an 'extract' function is required. Or do we even +-- need that? +-- +-- Until we investigate this we are not releasing these. +-- +-- XXX The above text would apply to +-- Streamly.Internal.Data.Parser.ParserD.Type.parser + +-- | Make a terminating scan using a pure step function, a pure initial state +-- and a pure state extraction function. +-- +-- /Pre-release/ +-- +{-# INLINE mkScant #-} +mkScant :: Monad m => (s -> a -> Step s b) -> Step s b -> (s -> b) -> Scanl m a b +mkScant step initial extract = + Scanl + (\s a -> return $ step s a) + (return initial) + (return . extract) + (return . extract) + +-- | Make a terminating scan with an effectful step function and initial state, +-- and a state extraction function. +-- +-- >>> mkScantM = Scanl.Scanl +-- +-- We can just use 'Scanl' but it is provided for completeness. +-- +-- /Pre-release/ +-- +{-# INLINE mkScantM #-} +mkScantM :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> Scanl m a b +mkScantM step initial extract = Scanl step initial extract extract + +------------------------------------------------------------------------------ +-- Refold +------------------------------------------------------------------------------ + +-- This is similar to how we run an Unfold to generate a Stream. A Fold is like +-- a Stream and a Fold2 is like an Unfold. + +-- | Make a scan from a consumer. +-- +-- /Internal/ +fromRefold :: Refold m c a b -> c -> Scanl m a b +fromRefold (Refold step inject extract) c = + Scanl step (inject c) extract extract + +------------------------------------------------------------------------------ +-- Basic Scans +------------------------------------------------------------------------------ + +-- | A scan that drains all its input, running the effects and discarding the +-- results. +-- +-- >>> drain = Scanl.drainMapM (const (return ())) +-- >>> drain = Scanl.mkScanl (\_ _ -> ()) () +-- +{-# INLINE drain #-} +drain :: Monad m => Scanl m a () +drain = mkScanl (\_ _ -> ()) () + +-- | Returns the latest element of the input stream, if any. +-- +-- >>> latest = Scanl.mkScanl1 (\_ x -> x) +-- >>> latest = fmap getLast $ Scanl.foldMap (Last . Just) +-- +{-# INLINE latest #-} +latest :: Monad m => Scanl m a (Maybe a) +latest = mkScanl1 (\_ x -> x) + +-- | Lift a Maybe returning function to a scan. +functionM :: Monad m => (a -> m (Maybe b)) -> Scanl m a (Maybe b) +functionM f = Scanl step initial return return + + where + + initial = return $ Partial Nothing + + step _ x = f x <&> Partial + +-- | Scans the input stream building a list. +-- +-- /Warning!/ working on large lists accumulated as buffers in memory could be +-- very inefficient, consider using "Streamly.Data.Array" +-- instead. +-- +-- >>> toList = Scanl.mkScanr (:) [] +-- +{-# INLINE toList #-} +toList :: Monad m => Scanl m a [a] +toList = mkScanr (:) [] + +-- | Buffers the input stream to a pure stream in the reverse order of the +-- input. +-- +-- This is more efficient than 'toStreamK'. toStreamK has exactly the same +-- performance as reversing the stream after toStreamKRev. +-- +-- /Pre-release/ + +-- xn : ... : x2 : x1 : [] +{-# INLINE toStreamKRev #-} +toStreamKRev :: Monad m => Scanl m a (K.StreamK n a) +toStreamKRev = mkScanl (flip K.cons) K.nil + +-- | Scans its input building a pure stream. +-- +-- >>> toStreamK = fmap StreamK.reverse Scanl.toStreamKRev +-- +-- /Internal/ +{-# INLINE toStreamK #-} +toStreamK :: Monad m => Scanl m a (K.StreamK n a) +toStreamK = mkScanr K.cons K.nil + +-- | Like 'length', except with a more general 'Num' return value +-- +-- Definition: +-- +-- >>> genericLength = fmap getSum $ Scanl.foldMap (Sum . const 1) +-- >>> genericLength = Scanl.mkScanl (\n _ -> n + 1) 0 +-- +-- /Pre-release/ +{-# INLINE genericLength #-} +genericLength :: (Monad m, Num b) => Scanl m a b +genericLength = mkScanl (\n _ -> n + 1) 0 + +-- | Determine the length of the input stream. +-- +-- Definition: +-- +-- >>> length = Scanl.genericLength +-- >>> length = fmap getSum $ Scanl.foldMap (Sum . const 1) +-- +{-# INLINE length #-} +length :: Monad m => Scanl m a Int +length = genericLength + +------------------------------------------------------------------------------ +-- To Summary (Maybe) +------------------------------------------------------------------------------ + +{-# INLINE maxBy #-} +maxBy :: (a -> a -> Ordering) -> a -> a -> a +maxBy cmp x y = + case cmp x y of + GT -> x + _ -> y + +-- | Determine the maximum element in a stream using the supplied comparison +-- function. +-- +{-# INLINE maximumBy #-} +maximumBy :: Monad m => (a -> a -> Ordering) -> Scanl m a (Maybe a) +maximumBy cmp = mkScanl1 (maxBy cmp) + +-- | Determine the maximum element in a stream. +-- +-- Definitions: +-- +-- >>> maximum = Scanl.maximumBy compare +-- >>> maximum = Scanl.mkScanl1 max +-- +-- Same as the following but without a default maximum. The 'Max' Monoid uses +-- the 'minBound' as the default maximum: +-- +-- >>> maximum = fmap Data.Semigroup.getMax $ Scanl.foldMap Data.Semigroup.Max +-- +{-# INLINE maximum #-} +maximum :: (Monad m, Ord a) => Scanl m a (Maybe a) +maximum = mkScanl1 max + +{-# INLINE minBy #-} +minBy :: (a -> a -> Ordering) -> a -> a -> a +minBy cmp x y = + case cmp x y of + GT -> y + _ -> x + +-- | Computes the minimum element with respect to the given comparison function +-- +{-# INLINE minimumBy #-} +minimumBy :: Monad m => (a -> a -> Ordering) -> Scanl m a (Maybe a) +minimumBy cmp = mkScanl1 (minBy cmp) + +-- | Determine the minimum element in a stream using the supplied comparison +-- function. +-- +-- Definitions: +-- +-- >>> minimum = Scanl.minimumBy compare +-- >>> minimum = Scanl.mkScanl1 min +-- +-- Same as the following but without a default minimum. The 'Min' Monoid uses the +-- 'maxBound' as the default maximum: +-- +-- >>> maximum = fmap Data.Semigroup.getMin $ Scanl.foldMap Data.Semigroup.Min +-- +{-# INLINE minimum #-} +minimum :: (Monad m, Ord a) => Scanl m a (Maybe a) +minimum = mkScanl1 min + +extractRange :: Range a -> Maybe (a, a) +extractRange RangeNone = Nothing +extractRange (Range mn mx) = Just (mn, mx) + +data Range a = RangeNone | Range !a !a + +-- | Find minimum and maximum element using the provided comparison function. +-- +{-# INLINE rangeBy #-} +rangeBy :: Monad m => (a -> a -> Ordering) -> Scanl m a (Maybe (a, a)) +rangeBy cmp = fmap extractRange $ mkScanl step RangeNone + + where + + step RangeNone x = Range x x + step (Range mn mx) x = Range (minBy cmp mn x) (maxBy cmp mx x) + +-- | Find minimum and maximum elements i.e. (min, max). +-- +{-# INLINE range #-} +range :: (Monad m, Ord a) => Scanl m a (Maybe (a, a)) +range = fmap extractRange $ mkScanl step RangeNone + + where + + step RangeNone x = Range x x + step (Range mn mx) x = Range (min mn x) (max mx x) + +------------------------------------------------------------------------------ +-- Instances +------------------------------------------------------------------------------ + +-- XXX These are singleton folds that are closed for input. The correspondence +-- to a nil stream would be a nil fold that returns "Done" in "initial" i.e. it +-- does not produce any accumulator value. However, we do not have a +-- representation of an empty value in folds, because the Done constructor +-- always produces a value (Done b). We can potentially use "Partial s b" and +-- "Done" to make the type correspond to the stream type. That may be possible +-- if we introduce the "Skip" constructor as well because after the last +-- "Partial s b" we have to emit a "Skip to Done" state to keep cranking the +-- fold until it is done. +-- +-- There is also the asymmetry between folds and streams because folds have an +-- "initial" to initialize the fold without any input. A similar concept is +-- possible in streams as well to stop the stream. That would be a "closing" +-- operation for the stream which can be called even without consuming any item +-- from the stream or when we are done consuming. +-- +-- However, the initial action in folds creates a discrepancy with the CPS +-- folds, and the same may be the case if we have a stop/cleanup operation in +-- streams. + +{- +-- | Make a scan that yields the supplied value without consuming any input. +-- +-- /Pre-release/ +-- +{-# INLINE fromPure #-} +fromPure :: Applicative m => b -> Scanl m a b +fromPure b = Scanl undefined (pure $ Done b) pure pure +-} + +-- | Make a scan that yields the supplied value on any input. +-- +-- /Pre-release/ +-- +{-# INLINE const #-} +const :: Applicative m => b -> Scanl m a b +const b = Scanl (\s _ -> pure $ Partial s) (pure $ Partial b) pure pure + +{- +-- | Make a scan that yields the result of the supplied effectful action +-- without consuming further input. +-- +-- /Pre-release/ +-- +{-# INLINE fromEffect #-} +fromEffect :: Applicative m => m b -> Scanl m a b +fromEffect b = Scanl undefined (Done <$> b) pure pure +-} + +-- | Make a scan that runs the supplied effect once and then yields the result +-- on any input. +-- +-- /Pre-release/ +-- +{-# INLINE constM #-} +constM :: Applicative m => m b -> Scanl m a b +constM b = Scanl (\s _ -> pure $ Partial s) (Partial <$> b) pure pure + +{- +{-# ANN type SeqFoldState Fuse #-} +data SeqFoldState sl f sr = SeqFoldL !sl | SeqFoldR !f !sr + +-- | Sequential fold application. Apply two folds sequentially to an input +-- stream. The input is provided to the first fold, when it is done - the +-- remaining input is provided to the second fold. When the second fold is done +-- or if the input stream is over, the outputs of the two folds are combined +-- using the supplied function. +-- +-- Example: +-- +-- >>> header = Scanl.take 8 Scanl.toList +-- >>> line = Scanl.takeEndBy (== '\n') Scanl.toList +-- >>> f = Scanl.splitWith (,) header line +-- >>> Stream.fold f $ Stream.fromList "header: hello\n" +-- ("header: ","hello\n") +-- +-- Note: This is dual to appending streams using 'Data.Stream.append'. +-- +-- Note: this implementation allows for stream fusion but has quadratic time +-- complexity, because each composition adds a new branch that each subsequent +-- fold's input element has to traverse, therefore, it cannot scale to a large +-- number of compositions. After around 100 compositions the performance starts +-- dipping rapidly compared to a CPS style implementation. +-- +-- For larger number of compositions you can convert the fold to a parser and +-- use ParserK. +-- +-- /Time: O(n^2) where n is the number of compositions./ +-- +{-# INLINE splitWith #-} +splitWith :: Monad m => + (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c +splitWith func + (Fold stepL initialL _ finalL) + (Fold stepR initialR _ finalR) = + Scanl step initial extract final + + where + + {-# INLINE runR #-} + runR action f = bimap (SeqFoldR f) f <$> action + + {-# INLINE runL #-} + runL action = do + resL <- action + chainStepM (return . SeqFoldL) (runR initialR . func) resL + + initial = runL initialL + + step (SeqFoldL st) a = runL (stepL st a) + step (SeqFoldR f st) a = runR (stepR st a) f + + -- XXX splitWith should not be used for scanning + -- It would rarely make sense and resource tracking and cleanup would be + -- expensive. especially when multiple splitWith are chained. + extract _ = error "splitWith: cannot be used for scanning" + + final (SeqFoldR f sR) = fmap f (finalR sR) + final (SeqFoldL sL) = do + rL <- finalL sL + res <- initialR + fmap (func rL) + $ case res of + Partial sR -> finalR sR + Done rR -> return rR + +{-# ANN type SeqFoldState_ Fuse #-} +data SeqFoldState_ sl sr = SeqFoldL_ !sl | SeqFoldR_ !sr + +-- | Same as applicative '*>'. Run two folds serially one after the other +-- discarding the result of the first. +-- +-- This was written in the hope that it might be faster than implementing it +-- using splitWith, but the current benchmarks show that it has the same +-- performance. So do not expose it unless some benchmark shows benefit. +-- +{-# INLINE split_ #-} +split_ :: Monad m => Fold m x a -> Fold m x b -> Fold m x b +split_ (Fold stepL initialL _ finalL) (Fold stepR initialR _ finalR) = + Scanl step initial extract final + + where + + initial = do + resL <- initialL + case resL of + Partial sl -> return $ Partial $ SeqFoldL_ sl + Done _ -> do + resR <- initialR + return $ first SeqFoldR_ resR + + step (SeqFoldL_ st) a = do + r <- stepL st a + case r of + Partial s -> return $ Partial (SeqFoldL_ s) + Done _ -> do + resR <- initialR + return $ first SeqFoldR_ resR + step (SeqFoldR_ st) a = do + resR <- stepR st a + return $ first SeqFoldR_ resR + + -- XXX split_ should not be used for scanning + -- See splitWith for more details. + extract _ = error "split_: cannot be used for scanning" + + final (SeqFoldR_ sR) = finalR sR + final (SeqFoldL_ sL) = do + _ <- finalL sL + res <- initialR + case res of + Partial sR -> finalR sR + Done rR -> return rR + +-- | 'Applicative' form of 'splitWith'. Split the input serially over two +-- folds. Note that this fuses but performance degrades quadratically with +-- respect to the number of compositions. It should be good to use for less +-- than 8 compositions. +instance Monad m => Applicative (Fold m a) where + {-# INLINE pure #-} + pure = fromPure + + {-# INLINE (<*>) #-} + (<*>) = splitWith id + + {-# INLINE (*>) #-} + (*>) = split_ + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + +{-# ANN type TeeState Fuse #-} +data TeeState sL sR bL bR + = TeeBoth !sL !sR + | TeeLeft !bR !sL + | TeeRight !bL !sR + +-- | @teeWithMax k f1 f2@ distributes its input to both @f1@ and @f2@ until +-- both of them terminate. The output of the two scans is combined using the +-- function @k@. +-- +-- XXX There are two choices: +-- +-- 1. If one of them terminates before the other, the final value of +-- the other is used in the zipping function. +-- 2. Use a (Maybe a -> Maybe b -> c) zipping function +-- +-- Which is better? We will find out based on the actual use cases. +-- +{-# INLINE teeWithMax #-} +teeWithMax :: Monad m => + (a -> b -> c) -> Scanl m x a -> Scanl m x b -> Scanl m x c +teeWithMax f + (Scanl stepL initialL extractL finalL) + (Scanl stepR initialR extractR finalR) = + Scanl step initial extract final + + where + + {-# INLINE runBoth #-} + runBoth actionL actionR = do + resL <- actionL + resR <- actionR + return + $ case resL of + Partial sl -> + Partial + $ case resR of + Partial sr -> TeeBoth sl sr + Done br -> TeeLeft br sl + Done bl -> bimap (TeeRight bl) (f bl) resR + + initial = runBoth initialL initialR + + step (TeeBoth sL sR) a = runBoth (stepL sL a) (stepR sR a) + step (TeeLeft bR sL) a = bimap (TeeLeft bR) (`f` bR) <$> stepL sL a + step (TeeRight bL sR) a = bimap (TeeRight bL) (f bL) <$> stepR sR a + + extract (TeeBoth sL sR) = f <$> extractL sL <*> extractR sR + extract (TeeLeft bR sL) = (`f` bR) <$> extractL sL + extract (TeeRight bL sR) = f bL <$> extractR sR + + final (TeeBoth sL sR) = f <$> finalL sL <*> finalR sR + final (TeeLeft bR sL) = (`f` bR) <$> finalL sL + final (TeeRight bL sR) = f bL <$> finalR sR + +{-# ANN type TeeFstState Fuse #-} +data TeeFstState sL sR b + = TeeFstBoth !sL !sR + | TeeFstLeft !b !sL + +-- | Like 'teeWith' but terminates only when the first scan terminates. If the +-- second scan terminates earlier then its final value is used in the zipping +-- function. +-- +-- /Pre-release/ +-- +{-# INLINE teeWithFst #-} +teeWithFst :: Monad m => + (b -> c -> d) -> Scanl m a b -> Scanl m a c -> Scanl m a d +teeWithFst f + (Scanl stepL initialL extractL finalL) + (Scanl stepR initialR extractR finalR) = + Scanl step initial extract final + + where + + {-# INLINE runBoth #-} + runBoth actionL actionR = do + resL <- actionL + resR <- actionR + + case resL of + Partial sl -> + return + $ Partial + $ case resR of + Partial sr -> TeeFstBoth sl sr + Done br -> TeeFstLeft br sl + Done bl -> do + Done . f bl <$> + case resR of + Partial sr -> finalR sr + Done br -> return br + + initial = runBoth initialL initialR + + step (TeeFstBoth sL sR) a = runBoth (stepL sL a) (stepR sR a) + step (TeeFstLeft bR sL) a = bimap (TeeFstLeft bR) (`f` bR) <$> stepL sL a + + extract (TeeFstBoth sL sR) = f <$> extractL sL <*> extractR sR + extract (TeeFstLeft bR sL) = (`f` bR) <$> extractL sL + + final (TeeFstBoth sL sR) = f <$> finalL sL <*> finalR sR + final (TeeFstLeft bR sL) = (`f` bR) <$> finalL sL +-} + +-- | @teeWith k f1 f2@ distributes its input to both @f1@ and @f2@ until any +-- one of them terminates. The outputs of the two scans are combined using the +-- function @k@. +-- +-- Definition: +-- +-- >>> teeWith k f1 f2 = fmap (uncurry k) (Scanl.tee f1 f2) +-- +-- Example: +-- +-- >>> avg = Scanl.teeWith (/) Scanl.sum (fmap fromIntegral Scanl.length) +-- >>> Stream.toList $ Stream.postscanl avg $ Stream.fromList [1.0..10.0] +-- [1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5] +-- +-- Note that nested applications of teeWith do not fuse. +-- +-- /Pre-release/ +-- +{-# INLINE teeWith #-} +teeWith :: Monad m => + (b -> c -> d) -> Scanl m a b -> Scanl m a c -> Scanl m a d +teeWith f + (Scanl stepL initialL extractL finalL) + (Scanl stepR initialR extractR finalR) = + Scanl step initial extract final + + where + + {-# INLINE runBoth #-} + runBoth actionL actionR = do + resL <- actionL + resR <- actionR + case resL of + Partial sl -> do + case resR of + Partial sr -> return $ Partial $ Tuple' sl sr + Done br -> Done . (`f` br) <$> finalL sl + + Done bl -> do + Done . f bl <$> + case resR of + Partial sr -> finalR sr + Done br -> return br + + initial = runBoth initialL initialR + + step (Tuple' sL sR) a = runBoth (stepL sL a) (stepR sR a) + + extract (Tuple' sL sR) = f <$> extractL sL <*> extractR sR + + final (Tuple' sL sR) = f <$> finalL sL <*> finalR sR + +instance Monad m => Applicative (Scanl m a) where + {-# INLINE pure #-} + pure = const + + (<*>) = teeWith id + +{- +-- XXX this does not make sense as a scan. +-- +-- | Shortest alternative. Apply both folds in parallel but choose the result +-- from the one which consumed least input i.e. take the shortest succeeding +-- fold. +-- +-- If both the folds finish at the same time or if the result is extracted +-- before any of the folds could finish then the left one is taken. +-- +-- /Pre-release/ +-- +{-# INLINE shortest #-} +shortest :: Monad m => Scanl m x a -> Scanl m x b -> Scanl m x (Either a b) +shortest (Scanl stepL initialL extractL finalL) (Scanl stepR initialR _ finalR) = + Scanl step initial extract final + + where + + {-# INLINE runBoth #-} + runBoth actionL actionR = do + resL <- actionL + resR <- actionR + case resL of + Partial sL -> + case resR of + Partial sR -> return $ Partial $ Tuple' sL sR + Done bR -> finalL sL >> return (Done (Right bR)) + Done bL -> do + case resR of + Partial sR -> void (finalR sR) + Done _ -> return () + return (Done (Left bL)) + + initial = runBoth initialL initialR + + step (Tuple' sL sR) a = runBoth (stepL sL a) (stepR sR a) + + extract (Tuple' sL _) = Left <$> extractL sL + + final (Tuple' sL sR) = Left <$> finalL sL <* finalR sR + +{-# ANN type LongestState Fuse #-} +data LongestState sL sR + = LongestBoth !sL !sR + | LongestLeft !sL + | LongestRight !sR + +-- | Longest alternative. Apply both folds in parallel but choose the result +-- from the one which consumed more input i.e. take the longest succeeding +-- fold. +-- +-- If both the folds finish at the same time or if the result is extracted +-- before any of the folds could finish then the left one is taken. +-- +-- /Pre-release/ +-- +{-# INLINE longest #-} +longest :: Monad m => Scanl m x a -> Scanl m x b -> Scanl m x (Either a b) +longest + (Scanl stepL initialL _ finalL) + (Scanl stepR initialR _ finalR) = + Scanl step initial extract final + + where + + {-# INLINE runBoth #-} + runBoth actionL actionR = do + resL <- actionL + resR <- actionR + return $ + case resL of + Partial sL -> + Partial $ + case resR of + Partial sR -> LongestBoth sL sR + Done _ -> LongestLeft sL + Done bL -> bimap LongestRight (const (Left bL)) resR + + initial = runBoth initialL initialR + + step (LongestBoth sL sR) a = runBoth (stepL sL a) (stepR sR a) + step (LongestLeft sL) a = bimap LongestLeft Left <$> stepL sL a + step (LongestRight sR) a = bimap LongestRight Right <$> stepR sR a + + -- XXX Scan with this may not make sense as we cannot determine the longest + -- until one of them have exhausted. + extract _ = error $ "longest: scan is not allowed as longest cannot be " + ++ "determined until one fold has exhausted." + + final (LongestLeft sL) = Left <$> finalL sL + final (LongestRight sR) = Right <$> finalR sR + final (LongestBoth sL sR) = Left <$> finalL sL <* finalR sR + +data ConcatMapState m sa a b c + = B !sa (sa -> m b) + | forall s. C (s -> a -> m (Step s c)) !s (s -> m c) (s -> m c) + +-- | Map a 'Fold' returning function on the result of a 'Fold' and run the +-- returned fold. This is akin to an n-ary version of 'splitWith' where the +-- next fold for splitting the input is decided dynamically using the previous +-- result. This operation can be used to express data dependencies +-- between fold operations. +-- +-- Let's say the first element in the stream is a count of the following +-- elements that we have to add, then: +-- +-- >>> import Data.Maybe (fromJust) +-- >>> count = fmap fromJust Scanl.one +-- >>> total n = Scanl.take n Scanl.sum +-- >>> Stream.fold (Scanl.concatMap total count) $ Stream.fromList [10,9..1] +-- 45 +-- +-- This does not fuse completely, see 'refold' for a fusible alternative. +-- +-- /Time: O(n^2) where @n@ is the number of compositions./ +-- +-- See also: 'Streamly.Internal.Data.Stream.foldIterateM', 'refold' +-- +{-# INLINE concatMap #-} +concatMap :: Monad m => (b -> Scanl m a c) -> Scanl m a b -> Scanl m a c +concatMap f (Fold stepa initiala _ finala) = + Fold stepc initialc extractc finalc + where + initialc = do + r <- initiala + case r of + Partial s -> return $ Partial (B s finala) + Done b -> initInnerFold (f b) + + stepc (B s fin) a = do + r <- stepa s a + case r of + Partial s1 -> return $ Partial (B s1 fin) + Done b -> initInnerFold (f b) + + stepc (C stepInner s extractInner fin) a = do + r <- stepInner s a + return $ case r of + Partial sc -> Partial (C stepInner sc extractInner fin) + Done c -> Done c + + -- XXX Cannot use for scanning + extractc _ = error "concatMap: cannot be used for scanning" + + initInnerFold (Scanl step i e fin) = do + r <- i + return $ case r of + Partial s -> Partial (C step s e fin) + Done c -> Done c + + initFinalize (Fold _ i _ fin) = do + r <- i + case r of + Partial s -> fin s + Done c -> return c + + finalc (B s fin) = do + r <- fin s + initFinalize (f r) + finalc (C _ sInner _ fin) = fin sInner +-} + +------------------------------------------------------------------------------ +-- Mapping on input +------------------------------------------------------------------------------ + +-- | @lmap f scan@ maps the function @f@ on the input of the scan. +-- +-- Definition: +-- +-- >>> lmap = Scanl.lmapM return +-- +-- Example: +-- +-- >>> sumSquared = Scanl.lmap (\x -> x * x) Scanl.sum +-- >>> Stream.toList $ Stream.scanl sumSquared (Stream.enumerateFromTo 1 10) +-- [0,1,5,14,30,55,91,140,204,285,385] +-- +{-# INLINE lmap #-} +lmap :: (a -> b) -> Scanl m b r -> Scanl m a r +lmap f (Scanl step begin done final) = Scanl step' begin done final + where + step' x a = step x (f a) + +-- | @lmapM f scan@ maps the monadic function @f@ on the input of the scan. +-- +{-# INLINE lmapM #-} +lmapM :: Monad m => (a -> m b) -> Scanl m b r -> Scanl m a r +lmapM f (Scanl step begin done final) = Scanl step' begin done final + where + step' x a = f a >>= step x + +-- | Postscan the input of a 'Scanl' to change it in a stateful manner using +-- another 'Scanl'. +-- +-- This is basically an append operation. +-- +-- /Pre-release/ +{-# INLINE postscanl #-} +postscanl :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c +postscanl + (Scanl stepL initialL extractL finalL) + (Scanl stepR initialR extractR finalR) = + Scanl step initial extract final + + where + + {-# INLINE runStep #-} + runStep actionL sR = do + rL <- actionL + case rL of + Done bL -> do + rR <- stepR sR bL + case rR of + Partial sR1 -> Done <$> finalR sR1 + Done bR -> return $ Done bR + Partial sL -> do + !b <- extractL sL + rR <- stepR sR b + case rR of + Partial sR1 -> return $ Partial (sL, sR1) + Done bR -> finalL sL >> return (Done bR) + + initial = do + rR <- initialR + case rR of + Partial sR -> do + rL <- initialL + case rL of + Done _ -> Done <$> finalR sR + Partial sL -> return $ Partial (sL, sR) + Done b -> return $ Done b + + -- XXX should use Tuple' + step (sL, sR) x = runStep (stepL sL x) sR + + extract = extractR . snd + + final (sL, sR) = finalL sL *> finalR sR + +------------------------------------------------------------------------------ +-- Filtering +------------------------------------------------------------------------------ + +-- | Modify a scan to receive a 'Maybe' input, the 'Just' values are unwrapped +-- and sent to the original scan, 'Nothing' values are discarded. +-- +-- >>> catMaybes = Scanl.mapMaybe id +-- >>> catMaybes = Scanl.filter isJust . Scanl.lmap fromJust +-- +{-# INLINE_NORMAL catMaybes #-} +catMaybes :: Monad m => Scanl m a b -> Scanl m (Maybe a) b +catMaybes (Scanl step initial extract final) = + Scanl step1 initial extract final + + where + + step1 s a = + case a of + Nothing -> return $ Partial s + Just x -> step s x + +-- | Scan using a 'Maybe' returning scan, filter out 'Nothing' values. +-- +-- >>> postscanlMaybe p f = Scanl.postscanl p (Scanl.catMaybes f) +-- +-- /Pre-release/ +{-# INLINE postscanlMaybe #-} +postscanlMaybe :: Monad m => Scanl m a (Maybe b) -> Scanl m b c -> Scanl m a c +postscanlMaybe f1 f2 = postscanl f1 (catMaybes f2) + +-- | A scan for filtering elements based on a predicate. +-- +{-# INLINE filtering #-} +filtering :: Monad m => (a -> Bool) -> Scanl m a (Maybe a) +filtering f = mkScanl step Nothing + + where + + step _ a = if f a then Just a else Nothing + +-- | Include only those elements that pass a predicate. +-- +-- >>> Stream.toList $ Stream.scanl (Scanl.filter (> 5) Scanl.sum) $ Stream.fromList [1..10] +-- [0,0,0,0,0,0,6,13,21,30,40] +-- +-- >>> filter p = Scanl.postscanlMaybe (Scanl.filtering p) +-- >>> filter p = Scanl.filterM (return . p) +-- >>> filter p = Scanl.mapMaybe (\x -> if p x then Just x else Nothing) +-- +{-# INLINE filter #-} +filter :: Monad m => (a -> Bool) -> Scanl m a r -> Scanl m a r +-- filter p = postscanlMaybe (filtering p) +filter f (Scanl step begin extract final) = Scanl step' begin extract final + where + step' x a = if f a then step x a else return $ Partial x + +-- | Like 'filter' but with a monadic predicate. +-- +-- >>> f p x = p x >>= \r -> return $ if r then Just x else Nothing +-- >>> filterM p = Scanl.mapMaybeM (f p) +-- +{-# INLINE filterM #-} +filterM :: Monad m => (a -> m Bool) -> Scanl m a r -> Scanl m a r +filterM f (Scanl step begin extract final) = Scanl step' begin extract final + where + step' x a = do + use <- f a + if use then step x a else return $ Partial x + +------------------------------------------------------------------------------ +-- Either streams +------------------------------------------------------------------------------ + +-- | Discard 'Right's and unwrap 'Left's in an 'Either' stream. +-- +-- /Pre-release/ +-- +{-# INLINE catLefts #-} +catLefts :: (Monad m) => Scanl m a c -> Scanl m (Either a b) c +catLefts = filter isLeft . lmap (fromLeft undefined) + +-- | Discard 'Left's and unwrap 'Right's in an 'Either' stream. +-- +-- /Pre-release/ +-- +{-# INLINE catRights #-} +catRights :: (Monad m) => Scanl m b c -> Scanl m (Either a b) c +catRights = filter isRight . lmap (fromRight undefined) + +-- | Remove the either wrapper and flatten both lefts and as well as rights in +-- the output stream. +-- +-- Definition: +-- +-- >>> catEithers = Scanl.lmap (either id id) +-- +-- /Pre-release/ +-- +{-# INLINE catEithers #-} +catEithers :: Scanl m a b -> Scanl m (Either a a) b +catEithers = lmap (either id id) + +------------------------------------------------------------------------------ +-- Parsing +------------------------------------------------------------------------------ + +-- Required to fuse "take" with "many" in "groupsOf", for ghc-9.x +{-# ANN type Tuple'Fused Fuse #-} +data Tuple'Fused a b = Tuple'Fused !a !b deriving Show + +{-# INLINE taking #-} +taking :: Monad m => Int -> Scanl m a (Maybe a) +taking n = mkScant step initial extract + + where + + initial = + if n <= 0 + then Done Nothing + else Partial (Tuple'Fused n Nothing) + + step (Tuple'Fused i _) a = + if i > 1 + then Partial (Tuple'Fused (i - 1) (Just a)) + else Done (Just a) + + extract (Tuple'Fused _ r) = r + +{-# INLINE dropping #-} +dropping :: Monad m => Int -> Scanl m a (Maybe a) +dropping n = mkScant step initial extract + + where + + initial = Partial (Tuple'Fused n Nothing) + + step (Tuple'Fused i _) a = + if i > 0 + then Partial (Tuple'Fused (i - 1) Nothing) + else Partial (Tuple'Fused i (Just a)) + + extract (Tuple'Fused _ r) = r + +-- | Take at most @n@ input elements and scan them using the supplied scan. A +-- negative count is treated as 0. +-- +-- >>> Stream.toList $ Stream.scanl (Scanl.take 2 Scanl.toList) $ Stream.fromList [1..10] +-- [[],[1],[1,2]] +-- +{-# INLINE take #-} +take :: Monad m => Int -> Scanl m a b -> Scanl m a b +-- take n = postscanlMaybe (taking n) +take n (Scanl fstep finitial fextract ffinal) = Scanl step initial extract final + + where + + {-# INLINE next #-} + next i res = + case res of + Partial s -> do + let i1 = i + 1 + s1 = Tuple'Fused i1 s + if i1 < n + then return $ Partial s1 + else Done <$> ffinal s + Done b -> return $ Done b + + initial = finitial >>= next (-1) + + step (Tuple'Fused i r) a = fstep r a >>= next i + + extract (Tuple'Fused _ r) = fextract r + + final (Tuple'Fused _ r) = ffinal r + +-- Note: Keep this consistent with S.splitOn. In fact we should eliminate +-- S.splitOn in favor of the fold. +-- +-- XXX Use Scanl.many instead once it is fixed. +-- > Stream.splitOnSuffix p f = Stream.foldMany (Scanl.takeEndBy_ p f) + +-- | Like 'takeEndBy' but drops the element on which the predicate succeeds. +-- +-- Example: +-- +-- >>> input = Stream.fromList "hello\nthere\n" +-- >>> line = Scanl.takeEndBy_ (== '\n') Scanl.toList +-- >>> Stream.toList $ Stream.scanl line input +-- ["","h","he","hel","hell","hello","hello"] +-- +{-# INLINE takeEndBy_ #-} +takeEndBy_ :: Monad m => (a -> Bool) -> Scanl m a b -> Scanl m a b +-- takeEndBy_ predicate = postscanlMaybe (takingEndBy_ predicate) +takeEndBy_ predicate (Scanl fstep finitial fextract ffinal) = + Scanl step finitial fextract ffinal + + where + + step s a = + if not (predicate a) + then fstep s a + else Done <$> ffinal s + +-- Note: +-- > Stream.splitWithSuffix p f = Stream.foldMany (Scanl.takeEndBy p f) + +-- | Take the input, stop when the predicate succeeds taking the succeeding +-- element as well. +-- +-- Example: +-- +-- >>> input = Stream.fromList "hello\nthere\n" +-- >>> line = Scanl.takeEndBy (== '\n') Scanl.toList +-- >>> Stream.toList $ Stream.scanl line input +-- ["","h","he","hel","hell","hello","hello\n"] +-- +{-# INLINE takeEndBy #-} +takeEndBy :: Monad m => (a -> Bool) -> Scanl m a b -> Scanl m a b +-- takeEndBy predicate = postscanlMaybe (takingEndBy predicate) +takeEndBy predicate (Scanl fstep finitial fextract ffinal) = + Scanl step finitial fextract ffinal + + where + + step s a = do + res <- fstep s a + if not (predicate a) + then return res + else do + case res of + Partial s1 -> Done <$> ffinal s1 + Done b -> return $ Done b + +------------------------------------------------------------------------------ +-- Nesting +------------------------------------------------------------------------------ + +-- Similar to the comonad "duplicate" operation. + +{- +-- | 'duplicate' provides the ability to run a fold in parts. The duplicated +-- fold consumes the input and returns the same fold as output instead of +-- returning the final result, the returned fold can be run later to consume +-- more input. +-- +-- 'duplicate' essentially appends a stream to the fold without finishing the +-- fold. Compare with 'snoc' which appends a singleton value to the fold. +-- +-- /Pre-release/ +{-# INLINE duplicate #-} +duplicate :: Monad m => Scanl m a b -> Scanl m a (Scanl m a b) +duplicate (Fold step1 initial1 extract1 final1) = + Scanl step initial extract final + + where + + initial = second fromPure <$> initial1 + + step s a = second fromPure <$> step1 s a + + -- Scanning may be problematic due to multiple finalizations. + extract = error "duplicate: scanning may be problematic" + + final s = pure $ Fold step1 (pure $ Partial s) extract1 final1 + +-- If there were a finalize/flushing action in the stream type that would be +-- equivalent to running initialize in Scanl. But we do not have a flushing +-- action in streams. + +-- | Evaluate the initialization effect of a fold. If we are building the fold +-- by chaining lazy actions in fold init this would reduce the actions to a +-- strict accumulator value. +-- +-- /Pre-release/ +{-# INLINE reduce #-} +reduce :: Monad m => Scanl m a b -> m (Scanl m a b) +reduce (Scanl step initial extract final) = do + i <- initial + return $ Scanl step (return i) extract final + +-- This is the dual of Stream @cons@. + +-- | Append an effect to the fold lazily, in other words run a single +-- step of the fold. +-- +-- /Pre-release/ +{-# INLINE snoclM #-} +snoclM :: Monad m => Scanl m a b -> m a -> Scanl m a b +snoclM (Scanl fstep finitial fextract ffinal) action = + Scanl fstep initial fextract ffinal + + where + + initial = do + res <- finitial + case res of + Partial fs -> action >>= fstep fs + Done b -> return $ Done b + +-- | Append a singleton value to the fold lazily, in other words run a single +-- step of the fold. +-- +-- Definition: +-- +-- >>> snocl f = Scanl.snoclM f . return +-- +-- Example: +-- +-- >>> import qualified Data.Foldable as Foldable +-- >>> Scanl.extractM $ Foldable.foldl Scanl.snocl Scanl.toList [1..3] +-- [1,2,3] +-- +-- /Pre-release/ +{-# INLINE snocl #-} +snocl :: Monad m => Scanl m a b -> a -> Scanl m a b +-- snocl f = snoclM f . return +snocl (Scanl fstep finitial fextract ffinal) a = + Scanl fstep initial fextract ffinal + + where + + initial = do + res <- finitial + case res of + Partial fs -> fstep fs a + Done b -> return $ Done b + +-- | Append a singleton value to the fold in other words run a single step of +-- the fold. +-- +-- Definition: +-- +-- >>> snocM f = Scanl.reduce . Scanl.snoclM f +-- +-- /Pre-release/ +{-# INLINE snocM #-} +snocM :: Monad m => Scanl m a b -> m a -> m (Scanl m a b) +snocM (Scanl step initial extract final) action = do + res <- initial + r <- case res of + Partial fs -> action >>= step fs + Done _ -> return res + return $ Scanl step (return r) extract final + +-- Definitions: +-- +-- >>> snoc f = Scanl.reduce . Scanl.snocl f +-- >>> snoc f = Scanl.snocM f . return + +-- | Append a singleton value to the fold, in other words run a single step of +-- the fold. +-- +-- Example: +-- +-- >>> import qualified Data.Foldable as Foldable +-- >>> Foldable.foldlM Scanl.snoc Scanl.toList [1..3] >>= Scanl.drive Stream.nil +-- [1,2,3] +-- +-- /Pre-release/ +{-# INLINE snoc #-} +snoc :: Monad m => Scanl m a b -> a -> m (Scanl m a b) +snoc (Scanl step initial extract final) a = do + res <- initial + r <- case res of + Partial fs -> step fs a + Done _ -> return res + return $ Scanl step (return r) extract final + +-- | Append a singleton value to the fold. +-- +-- See examples under 'addStream'. +-- +-- /Pre-release/ +{-# INLINE addOne #-} +addOne :: Monad m => a -> Scanl m a b -> m (Scanl m a b) +addOne = flip snoc + +-- Similar to the comonad "extract" operation. +-- XXX rename to extract. We can use "extr" for the fold extract function. + +-- | Extract the accumulated result of the fold. +-- +-- Definition: +-- +-- >>> extractM = Scanl.drive Stream.nil +-- +-- Example: +-- +-- >>> Scanl.extractM Scanl.toList +-- [] +-- +-- /Pre-release/ +{-# INLINE extractM #-} +extractM :: Monad m => Scanl m a b -> m b +extractM (Scanl _ initial extract _) = do + res <- initial + case res of + Partial fs -> extract fs + Done b -> return b + +-- | Close a fold so that it does not accept any more input. +{-# INLINE close #-} +close :: Monad m => Scanl m a b -> Scanl m a b +close (Scanl _ initial1 _ final1) = + Scanl undefined initial undefined undefined + + where + + initial = do + res <- initial1 + case res of + Partial s -> Done <$> final1 s + Done b -> return $ Done b + +-- Corresponds to the null check for streams. + +-- | Check if the fold has terminated and can take no more input. +-- +-- /Pre-release/ +{-# INLINE isClosed #-} +isClosed :: Monad m => Scanl m a b -> m Bool +isClosed (Scanl _ initial _ _) = do + res <- initial + return $ case res of + Partial _ -> False + Done _ -> True +-} + +------------------------------------------------------------------------------ +-- Parsing +------------------------------------------------------------------------------ + +-- All the grouping transformation that we apply to a stream can also be +-- applied to a fold input stream. groupBy et al can be written as terminating +-- folds and then we can apply "many" to use those repeatedly on a stream. + +-- XXX many should have the following signature: +-- many :: Monad m => Foldl m a b -> Scanl m b c -> Scanl m a (Maybe c) +-- Should return Nothing in the intermediate state and Just when the first fold +-- completes and is fed to the second fold. + +{- +{-# ANN type ManyState Fuse #-} +data ManyState s1 s2 + = ManyFirst !s1 !s2 + | ManyLoop !s1 !s2 + +-- | Collect zero or more applications of a fold. @many first second@ applies +-- the @first@ fold repeatedly on the input stream and accumulates it's results +-- using the @second@ fold. +-- +-- >>> two = Scanl.take 2 Scanl.toList +-- >>> twos = Scanl.many two Scanl.toList +-- >>> Stream.fold twos $ Stream.fromList [1..10] +-- [[1,2],[3,4],[5,6],[7,8],[9,10]] +-- +-- Stops when @second@ fold stops. +-- +-- See also: 'Data.Stream.concatMap', 'Data.Stream.foldMany' +-- +{-# INLINE many #-} +many :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c +many + (Scanl sstep sinitial sextract sfinal) + (Scanl cstep cinitial cextract cfinal) = + Scanl step initial extract final + + where + + -- cs = collect state + -- ss = split state + -- cres = collect state result + -- sres = split state result + -- cb = collect done + -- sb = split done + + -- Caution! There is mutual recursion here, inlining the right functions is + -- important. + + {-# INLINE split #-} + split f cs sres = + case sres of + Partial ss -> return $ Partial $ f ss cs + Done sb -> cstep cs sb >>= collect + + collect cres = + case cres of + Partial cs -> sinitial >>= split ManyFirst cs + Done cb -> return $ Done cb + + -- A fold may terminate even without accepting a single input. So we run + -- the split fold's initial action even if no input is received. However, + -- this means that if no input was ever received by "step" we discard the + -- fold's initial result which could have generated an effect. However, + -- note that if "sinitial" results in Done we do collect its output even + -- though the fold may not have received any input. XXX Is this + -- inconsistent? + initial = cinitial >>= collect + + {-# INLINE step_ #-} + step_ ss cs a = sstep ss a >>= split ManyLoop cs + + {-# INLINE step #-} + step (ManyFirst ss cs) a = step_ ss cs a + step (ManyLoop ss cs) a = step_ ss cs a + + -- Do not extract the split fold if no item was consumed. + extract (ManyFirst _ cs) = cextract cs + extract (ManyLoop ss cs) = do + cres <- sextract ss >>= cstep cs + case cres of + Partial s -> cextract s + Done b -> return b + + final (ManyFirst ss cs) = sfinal ss *> cfinal cs + final (ManyLoop ss cs) = do + cres <- sfinal ss >>= cstep cs + case cres of + Partial s -> cfinal s + Done b -> return b + +-- | Like many, but the "first" fold emits an output at the end even if no +-- input is received. +-- +-- /Internal/ +-- +-- See also: 'Data.Stream.concatMap', 'Data.Stream.foldMany' +-- +{-# INLINE manyPost #-} +manyPost :: Monad m => Scanl m a b -> Scanl m b c -> Scanl m a c +manyPost + (Scanl sstep sinitial sextract sfinal) + (Scanl cstep cinitial cextract cfinal) = + Scanl step initial extract final + + where + + -- cs = collect state + -- ss = split state + -- cres = collect state result + -- sres = split state result + -- cb = collect done + -- sb = split done + + -- Caution! There is mutual recursion here, inlining the right functions is + -- important. + + {-# INLINE split #-} + split cs sres = + case sres of + Partial ss1 -> return $ Partial $ Tuple' ss1 cs + Done sb -> cstep cs sb >>= collect + + collect cres = + case cres of + Partial cs -> sinitial >>= split cs + Done cb -> return $ Done cb + + initial = cinitial >>= collect + + {-# INLINE step #-} + step (Tuple' ss cs) a = sstep ss a >>= split cs + + extract (Tuple' ss cs) = do + cres <- sextract ss >>= cstep cs + case cres of + Partial s -> cextract s + Done b -> return b + + final (Tuple' ss cs) = do + cres <- sfinal ss >>= cstep cs + case cres of + Partial s -> cfinal s + Done b -> return b + +-- | @groupsOf n split collect@ repeatedly applies the @split@ fold to chunks +-- of @n@ items in the input stream and supplies the result to the @collect@ +-- fold. +-- +-- Definition: +-- +-- >>> groupsOf n split = Scanl.many (Scanl.take n split) +-- +-- Example: +-- +-- >>> twos = Scanl.groupsOf 2 Scanl.toList Scanl.toList +-- >>> Stream.fold twos $ Stream.fromList [1..10] +-- [[1,2],[3,4],[5,6],[7,8],[9,10]] +-- +-- Stops when @collect@ stops. +-- +{-# INLINE groupsOf #-} +groupsOf :: Monad m => Int -> Scanl m a b -> Scanl m b c -> Scanl m a c +groupsOf n split = many (take n split) + +------------------------------------------------------------------------------ +-- Refold and Fold Combinators +------------------------------------------------------------------------------ + +-- | Like 'many' but uses a 'Refold' for collecting. +-- +{-# INLINE refoldMany #-} +refoldMany :: Monad m => Scanl m a b -> Refold m x b c -> Refold m x a c +refoldMany + (Scanl sstep sinitial sextract _sfinal) + -- XXX We will need a "final" in refold as well + (Refold cstep cinject cextract) = + Refold step inject extract + + where + + -- cs = collect state + -- ss = split state + -- cres = collect state result + -- sres = split state result + -- cb = collect done + -- sb = split done + + -- Caution! There is mutual recursion here, inlining the right functions is + -- important. + + {-# INLINE split #-} + split cs f sres = + case sres of + Partial ss -> return $ Partial $ Tuple' cs (f ss) + Done sb -> cstep cs sb >>= collect + + collect cres = + case cres of + Partial cs -> sinitial >>= split cs Left + Done cb -> return $ Done cb + + inject x = cinject x >>= collect + + {-# INLINE step_ #-} + step_ ss cs a = sstep ss a >>= split cs Right + + {-# INLINE step #-} + step (Tuple' cs (Left ss)) a = step_ ss cs a + step (Tuple' cs (Right ss)) a = step_ ss cs a + + -- Do not extract the split fold if no item was consumed. + extract (Tuple' cs (Left _)) = cextract cs + extract (Tuple' cs (Right ss )) = do + cres <- sextract ss >>= cstep cs + case cres of + Partial s -> cextract s + Done b -> return b + +{-# ANN type ConsumeManyState Fuse #-} +data ConsumeManyState x cs ss = ConsumeMany x cs (Either ss ss) + +-- | Like 'many' but uses a 'Refold' for splitting. +-- +-- /Internal/ +{-# INLINE refoldMany1 #-} +refoldMany1 :: Monad m => Refold m x a b -> Scanl m b c -> Refold m x a c +refoldMany1 + (Refold sstep sinject sextract) + (Scanl cstep cinitial cextract _cfinal) = + Refold step inject extract + + where + + -- cs = collect state + -- ss = split state + -- cres = collect state result + -- sres = split state result + -- cb = collect done + -- sb = split done + + -- Caution! There is mutual recursion here, inlining the right functions is + -- important. + + {-# INLINE split #-} + split x cs f sres = + case sres of + Partial ss -> return $ Partial $ ConsumeMany x cs (f ss) + Done sb -> cstep cs sb >>= collect x + + collect x cres = + case cres of + Partial cs -> sinject x >>= split x cs Left + Done cb -> return $ Done cb + + inject x = cinitial >>= collect x + + {-# INLINE step_ #-} + step_ x ss cs a = sstep ss a >>= split x cs Right + + {-# INLINE step #-} + step (ConsumeMany x cs (Left ss)) a = step_ x ss cs a + step (ConsumeMany x cs (Right ss)) a = step_ x ss cs a + + -- Do not extract the split fold if no item was consumed. + extract (ConsumeMany _ cs (Left _)) = cextract cs + extract (ConsumeMany _ cs (Right ss )) = do + cres <- sextract ss >>= cstep cs + case cres of + Partial s -> cextract s + Done b -> return b + +-- | Extract the output of a fold and refold it using a 'Refold'. +-- +-- A fusible alternative to 'concatMap'. +-- +-- /Internal/ +{-# INLINE refold #-} +refold :: Monad m => Refold m b a c -> Scanl m a b -> Scanl m a c +refold (Refold step inject extract) f = + Scanl step (extractM f >>= inject) extract extract +-} + +------------------------------------------------------------------------------ +-- morphInner +------------------------------------------------------------------------------ + +-- | Change the underlying monad of a scan. Also known as hoist. +-- +-- /Pre-release/ +morphInner :: (forall x. m x -> n x) -> Scanl m a b -> Scanl n a b +morphInner f (Scanl step initial extract final) = + Scanl (\x a -> f $ step x a) (f initial) (f . extract) (f . final) + +-- | Adapt a pure scan to any monad. +-- +-- >>> generalizeInner = Scanl.morphInner (return . runIdentity) +-- +-- /Pre-release/ +generalizeInner :: Monad m => Scanl Identity a b -> Scanl m a b +generalizeInner = morphInner (return . runIdentity) diff --git a/src/Streamly/Internal/Data/Scanl/Window.hs b/src/Streamly/Internal/Data/Scanl/Window.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Scanl/Window.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Scanl.Window +-- Copyright : (c) 2020 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Simple incremental statistical measures over a stream of data. All +-- operations use numerically stable floating point arithmetic. +-- +-- Measurements can be performed over the entire input stream or on a sliding +-- window of fixed or variable size. Where possible, measures are computed +-- online without buffering the input stream. +-- +-- Currently there is no overflow detection. +-- +-- For more advanced statistical measures see the @streamly-statistics@ +-- package. + +-- XXX A window scan can be driven either using the RingArray.slidingWindow +-- combinator or by zipping nthLast scan and last scan. + +module Streamly.Internal.Data.Scanl.Window + ( + -- * Types + Incr (..) + + -- * Running Incremental Scans + -- | Scans of type @Scanl m (Incr a) b@ are incremental sliding-window + -- scans. Names of such scans are prefixed with @incr@. An input of type + -- @(Insert a)@ indicates that the input element @a@ is being inserted in + -- the window without ejecting an old value, increasing the window size by + -- 1. An input of type @(Replace a a)@ indicates that the first argument of + -- Replace is being removed from the window and the second argument is being + -- inserted in the window, the window size remains the same. The window + -- size can only increase and never decrease. + -- + -- You can compute the statistics over the entire stream using window scans + -- by always supplying input of type @Insert a@. + -- + -- The incremental scans are converted into scans over a window using the + -- 'incrScan' operation which maintains a sliding window and supplies the + -- new and/or exiting element of the window to the window scan in the form + -- of an incremental operation. The names of window scans are prefixed with + -- @window@. + -- + , cumulativeScan + , incrScan + , incrScanWith + + -- * Incremental Scans + , incrRollingMap -- XXX remove? + , incrRollingMapM -- XXX remove? + + -- ** Sums + , incrCount + , incrSum + , incrSumInt + , incrPowerSum + , incrPowerSumFrac + + -- ** Location + , windowRange + , windowMinimum + , windowMaximum + , incrMean + ) +where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Proxy (Proxy(..)) +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.RingArray (RingArray(..)) +import Streamly.Internal.Data.Scanl.Type (Scanl(..), Step(..)) +import Streamly.Internal.Data.Tuple.Strict + (Tuple'(..), Tuple3Fused' (Tuple3Fused')) +import Streamly.Internal.Data.Unbox (Unbox(..)) + +import qualified Streamly.Internal.Data.MutArray.Type as MutArray +import qualified Streamly.Internal.Data.RingArray as RingArray +import qualified Streamly.Internal.Data.Scanl.Type as Scanl + +import Prelude hiding (length, sum, minimum, maximum) + +#include "ArrayMacros.h" +#include "DocTestDataScanl.hs" + +------------------------------------------------------------------------------- +-- Incremental operations +------------------------------------------------------------------------------- + +-- The delete operation could be quite useful e.g. if we are computing stats +-- over last one hour of trades. The window would be growing when trade +-- frequency is increasing, the window would remain constant when the trade +-- frequency is steady, but it would shrink when the trade frequency reduces. +-- If no trades are happening our clock would still be ticking and to maintain +-- a 1 hour window we would be ejecting the oldest elements from the window +-- even without any other elements entering the window. In fact, it is required +-- for time based windows. +-- +-- Replace can be implemented using Insert and Delete. +-- + +-- | Represents incremental input for a scan. 'Insert' means a new element is +-- being added to the collection, 'Replace' means an old value in the +-- collection is being replaced with a new value. +data Incr a = + Insert !a + -- | Delete !a + | Replace !a !a -- ^ Replace old new + +instance Functor Incr where + fmap f (Insert x) = Insert (f x) + -- fmap f (Delete x) = Delete (f x) + fmap f (Replace x y) = Replace (f x) (f y) + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +{-# ANN type SlidingWindow Fuse #-} +data SlidingWindow a r s = SWArray !a !Int !s | SWRing !r !s +-- data SlidingWindow a s = SWArray !a !Int !s !Int | SWRing !a !Int !s + +-- | Like 'incrScan' but also provides the ring array to the scan. The ring +-- array reflects the state of the ring after inserting the incoming element. +-- +-- IMPORTANT NOTE: The ring is mutable, therefore, references to it should not +-- be stored and used later, the state would have changed by then. If you need +-- to store it then copy it to an array or another ring and store it. +{-# INLINE incrScanWith #-} +incrScanWith :: forall m a b. (MonadIO m, Unbox a) + => Int -> Scanl m (Incr a, RingArray a) b -> Scanl m a b +incrScanWith n (Scanl step1 initial1 extract1 final1) = + Scanl step initial extract final + + where + + initial = do + if n <= 0 + then error "Window size must be > 0" + else do + r <- initial1 + arr <- liftIO $ MutArray.emptyOf n + return $ + case r of + Partial s -> Partial $ SWArray arr (0 :: Int) s + Done b -> Done b + + step (SWArray arr i st) a = do + -- XXX compare this with the slidingWindow impl + arr1 <- liftIO $ MutArray.unsafeSnoc arr a + r <- step1 st (Insert a, RingArray.unsafeCastMutArray arr1) + return $ case r of + Partial s -> + let i1 = i + 1 + in if i1 < n + then Partial $ SWArray arr1 i1 s + else Partial $ SWRing (RingArray.unsafeCastMutArray arr1) s + Done b -> Done b + + step (SWRing rb st) a = do + (rb1, old) <- RingArray.replace rb a + r <- step1 st (Replace old a, rb1) + return $ + case r of + Partial s -> Partial $ SWRing rb1 s + Done b -> Done b + + extract (SWArray _ _ st) = extract1 st + extract (SWRing _ st) = extract1 st + + final (SWArray _ _ st) = final1 st + final (SWRing _ st) = final1 st + + -- Alternative implementation flattening the constructors + -- Improves some benchmarks, worsens some others, need more investigation. + {- + initial = do + if n <= 0 + then error "Window size must be > 0" + else do + r <- initial1 + arr :: MutArray.MutArray a <- liftIO $ MutArray.emptyOf n + return $ + case r of + Partial s -> Partial + $ SWArray (MutArray.arrContents arr) 0 s n + Done b -> Done b + + step (SWArray mba rh st i) a = do + RingArray _ _ rh1 <- RingArray.insert_ (RingArray mba (n * SIZE_OF(a)) rh) a + r <- step1 st (Insert a, RingArray mba ((n - i) * SIZE_OF(a)) rh1) + return $ + case r of + Partial s -> + if i > 0 + then Partial $ SWArray mba rh1 s (i-1) + else Partial $ SWRing mba rh1 s + Done b -> Done b + + step (SWRing mba rh st) a = do + (rb1@(RingArray _ _ rh1), old) <- + RingArray.insert (RingArray mba (n * SIZE_OF(a)) rh) a + r <- step1 st (Replace old a, rb1) + return $ + case r of + Partial s -> Partial $ SWRing mba rh1 s + Done b -> Done b + + extract (SWArray _ _ st _) = extract1 st + extract (SWRing _ _ st) = extract1 st + + final (SWArray _ _ st _) = final1 st + final (SWRing _ _ st) = final1 st + -} + +-- | @incrScan collector@ is an incremental sliding window scan that does not +-- require all the intermediate elements in each step of the scan computation. +-- This maintains @n@ elements in the window, when a new element comes it +-- slides out the oldest element. The new element along with the old element +-- are supplied to the collector scan. +-- +{-# INLINE incrScan #-} +incrScan :: forall m a b. (MonadIO m, Unbox a) + => Int -> Scanl m (Incr a) b -> Scanl m a b +incrScan n f = incrScanWith n (Scanl.lmap fst f) + +-- | Convert an incremental scan to a cumulative scan using the entire input +-- stream as a single window. +-- +-- >>> cumulativeScan = Scanl.lmap Scanl.Insert +-- +{-# INLINE cumulativeScan #-} +cumulativeScan :: Scanl m (Incr a) b -> Scanl m a b +cumulativeScan = Scanl.lmap Insert + +-- | Apply an effectful function on the entering and the exiting element of the +-- window. The first argument of the mapped function is the exiting element and +-- the second argument is the entering element. +{-# INLINE incrRollingMapM #-} +incrRollingMapM :: Monad m => + (Maybe a -> a -> m (Maybe b)) -> Scanl m (Incr a) (Maybe b) +incrRollingMapM f = Scanl.mkScanlM f1 initial + + where + + initial = return Nothing + + f1 _ (Insert a) = f Nothing a + -- f1 _ (Delete _) = return Nothing + f1 _ (Replace old new) = f (Just old) new + +-- | Apply a pure function on the latest and the oldest element of the window. +-- +-- >>> incrRollingMap f = Scanl.incrRollingMapM (\x y -> return $ f x y) +-- +{-# INLINE incrRollingMap #-} +incrRollingMap :: Monad m => + (Maybe a -> a -> Maybe b) -> Scanl m (Incr a) (Maybe b) +incrRollingMap f = Scanl.mkScanl f1 initial + + where + + initial = Nothing + + f1 _ (Insert a) = f Nothing a + -- f1 _ (Delete _) = Nothing + f1 _ (Replace old new) = f (Just old) new + +------------------------------------------------------------------------------- +-- Sum +------------------------------------------------------------------------------- + +-- XXX Overflow. + +-- | The sum of all the elements in a rolling window. The input elements are +-- required to be integral numbers. +-- +-- This was written in the hope that it would be a tiny bit faster than 'incrSum' +-- for 'Integral' values. But turns out that 'incrSum' is 2% faster than this even +-- for integral values! +-- +-- /Internal/ +-- +{-# INLINE incrSumInt #-} +incrSumInt :: forall m a. (Monad m, Integral a) => Scanl m (Incr a) a +incrSumInt = Scanl step initial extract extract + + where + + initial = return $ Partial (0 :: a) + + step s (Insert a) = return $ Partial (s + a) + -- step s (Delete a) = return $ Partial (s - a) + step s (Replace old new) = return $ Partial (s + new - old) + + extract = return + +-- XXX Overflow. + +-- | Sum of all the elements in a rolling window: +-- +-- \(S = \sum_{i=1}^n x_{i}\) +-- +-- This is the first power sum. +-- +-- >>> incrSum = Scanl.incrPowerSum 1 +-- +-- Uses Kahan-Babuska-Neumaier style summation for numerical stability of +-- floating precision arithmetic. +-- +-- /Space/: \(\mathcal{O}(1)\) +-- +-- /Time/: \(\mathcal{O}(n)\) +-- +{-# INLINE incrSum #-} +incrSum :: forall m a. (Monad m, Num a) => Scanl m (Incr a) a +incrSum = Scanl step initial extract extract + + where + + initial = + return + $ Partial + $ Tuple' + (0 :: a) -- running sum + (0 :: a) -- accumulated rounding error + + add total incr = + let + -- total is large and incr may be small, we may round incr here but + -- we will accumulate the rounding error in err1 in the next step. + total1 = total + incr + -- Accumulate any rounding error in err1 + -- XXX In the Insert case we may lose err, therefore we + -- should use ((total1 - total) - new) + err here. + -- Or even in the Replace case if (new - old) is large we may lose + -- err, so we should use ((total1 - total) + (old - new)) + err. + err1 = (total1 - total) - incr + in return $ Partial $ Tuple' total1 err1 + + step (Tuple' total err) (Insert new) = + -- XXX if new is large we may lose err + let incr = new - err + in add total incr + {- + step (Tuple' total err) (Delete new) = + -- XXX if new is large we may lose err + let incr = -new - err + in add total incr + -} + step (Tuple' total err) (Replace old new) = + -- XXX if (new - old) is large we may lose err + let incr = (new - old) - err + in add total incr + + extract (Tuple' total _) = return total + +-- | The number of elements in the rolling window. +-- +-- This is the \(0\)th power sum. +-- +-- >>> incrCount = Scanl.incrPowerSum 0 +-- +{-# INLINE incrCount #-} +incrCount :: (Monad m, Num b) => Scanl m (Incr a) b +incrCount = Scanl.mkScanl step 0 + + where + + step w (Insert _) = w + 1 + -- step w (Delete _) = w - 1 + step w (Replace _ _) = w + +-- | Sum of the \(k\)th power of all the elements in a rolling window: +-- +-- \(S_k = \sum_{i=1}^n x_{i}^k\) +-- +-- >>> incrPowerSum k = Scanl.lmap (fmap (^ k)) Scanl.incrSum +-- +-- /Space/: \(\mathcal{O}(1)\) +-- +-- /Time/: \(\mathcal{O}(n)\) +{-# INLINE incrPowerSum #-} +incrPowerSum :: (Monad m, Num a) => Int -> Scanl m (Incr a) a +incrPowerSum k = Scanl.lmap (fmap (^ k)) incrSum + +-- | Like 'incrPowerSum' but powers can be negative or fractional. This is +-- slower than 'incrPowerSum' for positive intergal powers. +-- +-- >>> incrPowerSumFrac p = Scanl.lmap (fmap (** p)) Scanl.incrSum +-- +{-# INLINE incrPowerSumFrac #-} +incrPowerSumFrac :: (Monad m, Floating a) => a -> Scanl m (Incr a) a +incrPowerSumFrac p = Scanl.lmap (fmap (** p)) incrSum + +------------------------------------------------------------------------------- +-- Location +------------------------------------------------------------------------------- + +{-# INLINE ringRange #-} +ringRange :: (MonadIO m, Unbox a, Ord a) => RingArray a -> m (Maybe (a, a)) +-- Ideally this should perform the same as the implementation below, but it is +-- 2x worse, need to investigate why. +-- ringRange = RingArray.fold (Fold.fromScanl Scanl.range) +ringRange rb@RingArray{..} = do + if ringSize == 0 + then return Nothing + else do + x <- liftIO $ peekAt 0 ringContents + let accum (mn, mx) a = return (min mn a, max mx a) + in fmap Just $ RingArray.foldlM' accum (x, x) rb + +-- | Determine the maximum and minimum in a rolling window. +-- +-- This implementation traverses the entire window buffer to compute the +-- range whenever we demand it. It performs better than the dequeue based +-- implementation in @streamly-statistics@ package when the window size is +-- small (< 30). +-- +-- If you want to compute the range of the entire stream +-- 'Streamly.Data.Scanl.range' would be much faster. +-- +-- /Space/: \(\mathcal{O}(n)\) where @n@ is the window size. +-- +-- /Time/: \(\mathcal{O}(n*w)\) where \(w\) is the window size. +-- +{-# INLINE windowRange #-} +windowRange :: forall m a. (MonadIO m, Unbox a, Ord a) => + Int -> Scanl m a (Maybe (a, a)) +-- windowRange = RingArray.scanFoldRingsBy (Fold.fromScanl Scanl.range) + +-- Ideally this should perform the same as the implementation below which is +-- just expanded form of this. Some inlining/exitify optimization makes this +-- perform much worse. Need to investigate and fix that. +-- windowRange = RingArray.scanCustomFoldRingsBy ringRange + +windowRange n = Scanl step initial extract extract + + where + + initial = + if n <= 0 + then error "ringsOf: window size must be > 0" + else do + arr :: MutArray.MutArray a <- liftIO $ MutArray.emptyOf n + return $ Partial $ Tuple3Fused' (MutArray.arrContents arr) 0 0 + + step (Tuple3Fused' mba rh i) a = do + RingArray _ _ rh1 <- RingArray.replace_ (RingArray mba (n * SIZE_OF(a)) rh) a + return $ Partial $ Tuple3Fused' mba rh1 (i + 1) + + -- XXX exitify optimization causes a problem here when modular scans are + -- used. Sometimes inlining "extract" is helpful. + -- {-# INLINE extract #-} + extract (Tuple3Fused' mba rh i) = + -- XXX If newest is lower than the current min than new is the min. + -- XXX Otherwise if exiting one was equal to min only then we need to find + -- new min + let rs = min i n * SIZE_OF(a) + rh1 = if i <= n then 0 else rh + in ringRange $ RingArray mba rs rh1 + +-- | Find the minimum element in a rolling window. +-- +-- See the performance related comments in 'windowRange'. +-- +-- If you want to compute the minimum of the entire stream +-- 'Streamly.Data.Scanl.minimum' is much faster. +-- +-- /Time/: \(\mathcal{O}(n*w)\) where \(w\) is the window size. +-- +{-# INLINE windowMinimum #-} +windowMinimum :: (MonadIO m, Unbox a, Ord a) => Int -> Scanl m a (Maybe a) +windowMinimum n = fmap (fmap fst) $ windowRange n +-- windowMinimum = RingArray.scanFoldRingsBy (Fold.fromScanl Scanl.minimum) + +-- | The maximum element in a rolling window. +-- +-- See the performance related comments in 'windowRange'. +-- +-- If you want to compute the maximum of the entire stream +-- 'Streamly.Data.Scanl.maximum' would be much faster. +-- +-- /Time/: \(\mathcal{O}(n*w)\) where \(w\) is the window size. +-- +{-# INLINE windowMaximum #-} +windowMaximum :: (MonadIO m, Unbox a, Ord a) => Int -> Scanl m a (Maybe a) +windowMaximum n = fmap (fmap snd) $ windowRange n +-- windowMaximum = RingArray.scanFoldRingsBy (Fold.fromScanl Scanl.maximum) + +-- XXX Returns NaN on empty stream. +-- XXX remove teeWith for better fusion? + +-- | Arithmetic mean of elements in a sliding window: +-- +-- \(\mu = \frac{\sum_{i=1}^n x_{i}}{n}\) +-- +-- This is also known as the Simple Moving Average (SMA) when used in the +-- sliding window and Cumulative Moving Avergae (CMA) when used on the entire +-- stream. +-- +-- >>> incrMean = Scanl.teeWith (/) Scanl.incrSum Scanl.incrCount +-- +-- /Space/: \(\mathcal{O}(1)\) +-- +-- /Time/: \(\mathcal{O}(n)\) +{-# INLINE incrMean #-} +incrMean :: forall m a. (Monad m, Fractional a) => Scanl m (Incr a) a +incrMean = Scanl.teeWith (/) incrSum incrCount diff --git a/src/Streamly/Internal/Data/Scanr.hs b/src/Streamly/Internal/Data/Scanr.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Scanr.hs @@ -0,0 +1,401 @@ +-- | +-- Module : Streamly.Internal.Data.Scanr +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Right scans. +-- +-- == Scanr vs Stream +-- +-- A scan is a generalization of a stream. Like streams, a scan has an internal +-- state. Unlike a stream, a scan produces an output only on an input, the +-- output is a function of the scan state and the input. A scan produces at +-- most one output on one input, in other words it is driven solely by the +-- input, it cannot produce output on its own. A @Scanr m () a@ can represent a +-- @Stream m a@ by supplying the scan with () inputs. +-- +-- == Scans vs pipes: +-- +-- A scan is a simpler version of pipes. It can produce at most one output on +-- one input. Whereas a pipe may produce output even without consuming anything +-- or it can produce multiple outputs on a single input. Scans are simpler +-- abstractions to think about compared to pipes and easier for the compiler to +-- optimize and fuse. +-- +-- == Compositions +-- +-- Append: this is the easiest. The behavior is simple even in presence of +-- filtering (Skip) and termination (Stop). Skip translates to Skip, Stop +-- translates to Stop. +-- +-- demux: we select one of n scans to run. Behaviour with Skip is straight +-- forward. Termination behavior has multiple options, stop when first one +-- stops, stop when the last one stops, or stop when a selected one stops. +-- +-- zip: run all and zip the outputs. If one of them Skips we Skip the output. +-- If one of them stops we stop. It may be possible to collect the outputs as +-- Just/Nothing values. +-- +-- Another option could be if a Scan terminates do we want to start it again or +-- not. + +module Streamly.Internal.Data.Scanr + ( + -- * Type + Scanr (..) + + -- * Primitive Scans + , identity + , function + , functionM + , filter + , filterM + + -- * Combinators + , compose + , teeWithMay + , teeWith + , tee + + -- * Scans + , length + , sum + ) +where + +#include "inline.hs" +import Control.Arrow (Arrow(..)) +import Control.Category (Category(..)) +import Data.Maybe (isJust, fromJust) +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) +import Streamly.Internal.Data.Stream.Step (Step (..)) + +import qualified Prelude + +import Prelude hiding + (filter, length, sum, zipWith, map, mapM, id, unzip, null) + +-- $setup +-- >>> :m +-- >>> :set -XFlexibleContexts +-- >>> import Control.Category +-- +-- >>> import qualified Streamly.Internal.Data.Fold as Fold +-- >>> import qualified Streamly.Internal.Data.Scanr as Scanr +-- >>> import qualified Streamly.Internal.Data.Stream as Stream + +------------------------------------------------------------------------------ +-- Scans +------------------------------------------------------------------------------ + +-- A core difference between the Scan type and the Fold type is that Scan can +-- stop without producing an output, this is required to represent an empty +-- stream. For this reason a Scan cannot be represented using a Fold because a +-- fold requires a value to be produced on Stop. + +-- A core difference between a Scan and a Stream is that a scan produces an +-- output only on an input while a stream can produce output without consuming +-- an input. +-- +-- XXX A scan may have buffered data which may have to be drained if the driver +-- has no more input to supply. So we need a finalizer which produces a +-- (possibly empty) stream. +-- +-- XXX We should add finalizer (and Error constructor?) to it before we +-- release it. + +-- | Represents a stateful transformation over an input stream of values of +-- type @a@ to outputs of type @b@ in 'Monad' @m@. +-- +-- The constructor is @Scan consume initial@. +data Scanr m a b = + forall s. Scanr + (s -> a -> m (Step s b)) + s + +------------------------------------------------------------------------------ +-- Functor: Mapping on the output +------------------------------------------------------------------------------ + +-- | 'fmap' maps a pure function on a scan output. +-- +-- >>> Stream.toList $ Stream.scanr (fmap (+1) Scanr.identity) $ Stream.fromList [1..5::Int] +-- [2,3,4,5,6] +-- +instance Functor m => Functor (Scanr m a) where + {-# INLINE_NORMAL fmap #-} + fmap f (Scanr consume initial) = Scanr consume1 initial + + where + + {-# INLINE_LATE consume1 #-} + consume1 s b = fmap (fmap f) (consume s b) + +------------------------------------------------------------------------------- +-- Category +------------------------------------------------------------------------------- + +-- XXX We can call this append, because corresponding operation in stream is +-- also append. + +-- | Connect two scans in series. Attach the first scan on the output of the +-- second scan. +-- +-- >>> import Control.Category +-- >>> Stream.toList $ Stream.scanr (Scanr.function (+1) >>> Scanr.function (+1)) $ Stream.fromList [1..5::Int] +-- [3,4,5,6,7] +-- +{-# INLINE_NORMAL compose #-} +compose :: Monad m => Scanr m b c -> Scanr m a b -> Scanr m a c +compose + (Scanr stepR initialR) + (Scanr stepL initialL) = Scanr step (initialL, initialR) + + where + + -- XXX Use strict tuple? + step (sL, sR) x = do + rL <- stepL sL x + case rL of + Yield bL sL1 -> do + rR <- stepR sR bL + return + $ case rR of + Yield br sR1 -> Yield br (sL1, sR1) + Skip sR1 -> Skip (sL1, sR1) + Stop -> Stop + Skip sL1 -> return $ Skip (sL1, sR) + Stop -> return Stop + +-- | A scan representing mapping of a monadic action. +-- +-- >>> Stream.toList $ Stream.scanr (Scanr.functionM print) $ Stream.fromList [1..5::Int] +-- 1 +-- 2 +-- 3 +-- 4 +-- 5 +-- [(),(),(),(),()] +-- +{-# INLINE functionM #-} +functionM :: Monad m => (a -> m b) -> Scanr m a b +functionM f = Scanr (\() a -> fmap (`Yield` ()) (f a)) () + +-- | A scan representing mapping of a pure function. +-- +-- >>> Stream.toList $ Stream.scanr (Scanr.function (+1)) $ Stream.fromList [1..5::Int] +-- [2,3,4,5,6] +-- +{-# INLINE function #-} +function :: Monad m => (a -> b) -> Scanr m a b +function f = functionM (return Prelude.. f) + +{- HLINT ignore "Redundant map" -} + +-- | An identity scan producing the same output as input. +-- +-- >>> identity = Scanr.function Prelude.id +-- +-- >>> Stream.toList $ Stream.scanr (Scanr.identity) $ Stream.fromList [1..5::Int] +-- [1,2,3,4,5] +-- +{-# INLINE identity #-} +identity :: Monad m => Scanr m a a +identity = function Prelude.id + +instance Monad m => Category (Scanr m) where + {-# INLINE id #-} + id = identity + + {-# INLINE (.) #-} + (.) = compose + +------------------------------------------------------------------------------- +-- Applicative Zip +------------------------------------------------------------------------------- + +{-# ANN type TeeWith Fuse #-} +data TeeWith sL sR = TeeWith !sL !sR + +-- XXX zipWith? + +-- | Connect two scans in parallel. Distribute the input across two scans and +-- zip their outputs. If the scan filters the output, 'Nothing' is emitted +-- otherwise 'Just' is emitted. The scan stops if any of the scans stop. +-- +-- >>> Stream.toList $ Stream.scanr (Scanr.teeWithMay (,) Scanr.identity (Scanr.function (\x -> x * x))) $ Stream.fromList [1..5::Int] +-- [(Just 1,Just 1),(Just 2,Just 4),(Just 3,Just 9),(Just 4,Just 16),(Just 5,Just 25)] +-- +{-# INLINE_NORMAL teeWithMay #-} +teeWithMay :: Monad m => + (Maybe b -> Maybe c -> d) -> Scanr m a b -> Scanr m a c -> Scanr m a d +teeWithMay f (Scanr stepL initialL) (Scanr stepR initialR) = + Scanr step (TeeWith initialL initialR) + + where + + step (TeeWith sL sR) a = do + resL <- stepL sL a + resR <- stepR sR a + return + $ case resL of + Yield bL sL1 -> + case resR of + Yield bR sR1 -> + Yield + (f (Just bL) (Just bR)) + (TeeWith sL1 sR1) + Skip sR1 -> + Yield + (f (Just bL) Nothing) + (TeeWith sL1 sR1) + Stop -> Stop + Skip sL1 -> + case resR of + Yield bR sR1 -> + Yield + (f Nothing (Just bR)) + (TeeWith sL1 sR1) + Skip sR1 -> + Yield + (f Nothing Nothing) + (TeeWith sL1 sR1) + Stop -> Stop + Stop -> Stop + +-- | Produces an output only when both the scans produce an output. If any of +-- the scans skips the output then the composed scan also skips. Stops when any +-- of the scans stop. +-- +-- >>> Stream.toList $ Stream.scanr (Scanr.teeWith (,) Scanr.identity (Scanr.function (\x -> x * x))) $ Stream.fromList [1..5::Int] +-- [(1,1),(2,4),(3,9),(4,16),(5,25)] +-- +{-# INLINE_NORMAL teeWith #-} +teeWith :: Monad m => + (b -> c -> d) -> Scanr m a b -> Scanr m a c -> Scanr m a d +teeWith f s1 s2 = + fmap fromJust + $ compose (filter isJust) + $ teeWithMay (\b c -> f <$> b <*> c) s1 s2 + +-- | Zips the outputs only when both scans produce outputs, discards otherwise. +instance Monad m => Applicative (Scanr m a) where + {-# INLINE pure #-} + pure b = Scanr (\_ _ -> pure $ Yield b ()) () + + (<*>) = teeWith id + +{-# INLINE_NORMAL tee #-} +tee :: Monad m => Scanr m a b -> Scanr m a c -> Scanr m a (b,c) +tee = teeWith (,) + +------------------------------------------------------------------------------- +-- Arrow +------------------------------------------------------------------------------- + +-- | Use the first scan for the first element of the tuple and second scan for +-- the second. Zip the outputs. Emits 'Nothing' if no output is generated by +-- the scan, otherwise emits 'Just'. Stops as soon as any one of the scans +-- stop. +-- +{-# INLINE_NORMAL unzipMay #-} +unzipMay :: Monad m => + Scanr m a x -> Scanr m b y -> Scanr m (a, b) (Maybe x, Maybe y) +unzipMay (Scanr stepL initialL) (Scanr stepR initialR) = + Scanr step (Tuple' initialL initialR) + + where + + step (Tuple' sL sR) (a, b) = do + resL <- stepL sL a + resR <- stepR sR b + return + $ case resL of + Yield bL sL1 -> + case resR of + Yield bR sR1 -> + Yield + (Just bL, Just bR) + (Tuple' sL1 sR1) + Skip sR1 -> + Yield + (Just bL, Nothing) + (Tuple' sL1 sR1) + Stop -> Stop + Skip sL1 -> + case resR of + Yield bR sR1 -> + Yield + (Nothing, Just bR) + (Tuple' sL1 sR1) + Skip sR1 -> + Yield + (Nothing, Nothing) + (Tuple' sL1 sR1) + Stop -> Stop + Stop -> Stop + +-- | Like 'unzipMay' but produces an output only when both the scans produce an +-- output. Other outputs are filtered out. +{-# INLINE_NORMAL unzip #-} +unzip :: Monad m => Scanr m a x -> Scanr m b y -> Scanr m (a, b) (x, y) +unzip s1 s2 = fmap (fromJust Prelude.. f) $ unzipMay s1 s2 + + where + + f (mx, my) = + case mx of + Just x -> + case my of + Just y -> Just (x, y) + Nothing -> Nothing + Nothing -> Nothing + +instance Monad m => Arrow (Scanr m) where + {-# INLINE arr #-} + arr = function + + {-# INLINE (***) #-} + (***) = unzip + + {-# INLINE (&&&) #-} + (&&&) = teeWith (,) + +------------------------------------------------------------------------------- +-- Primitive scans +------------------------------------------------------------------------------- + +-- | A filtering scan using a monadic predicate. +{-# INLINE filterM #-} +filterM :: Monad m => (a -> m Bool) -> Scanr m a a +filterM f = Scanr (\() a -> f a >>= g a) () + + where + + {-# INLINE g #-} + g a b = + return + $ if b + then Yield a () + else Skip () + +-- | A filtering scan using a pure predicate. +-- +-- >>> Stream.toList $ Stream.scanr (Scanr.filter odd) $ Stream.fromList [1..5::Int] +-- [1,3,5] +-- +{-# INLINE filter #-} +filter :: Monad m => (a -> Bool) -> Scanr m a a +filter f = filterM (return Prelude.. f) + +{-# INLINE length #-} +length :: Monad m => Scanr m a Int +length = Scanr (\acc _ -> pure $ let !n = acc + 1 in Yield n n) 0 + +{-# INLINE sum #-} +sum :: (Monad m, Num a) => Scanr m a a +sum = Scanr (\acc x -> pure $ let !n = acc + x in Yield n n) 0 diff --git a/src/Streamly/Internal/Data/Serialize/TH.hs b/src/Streamly/Internal/Data/Serialize/TH.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Serialize/TH.hs @@ -0,0 +1,529 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Streamly.Internal.Data.Serialize.TH +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +-- XXX Instead of applying the product constructor in one go can we apply it +-- one at a time in case of too many arguments, compiler may not have to save +-- them in local vars. + +module Streamly.Internal.Data.Serialize.TH + ( + -- Deriving + deriveSerialize + , deriveSerializeWith + + -- Utilities + , module Streamly.Internal.Data.Serialize.TH.Bottom + -- ** Common + , module Streamly.Internal.Data.Serialize.TH.Common + -- ** RecHeader + , module Streamly.Internal.Data.Serialize.TH.RecHeader + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Data.Foldable (length, foldMap) +import Data.List (foldl') +import Data.Word (Word16, Word32, Word64, Word8) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Streamly.Internal.Data.Serialize.Type + +import Streamly.Internal.Data.Unbox.TH + ( DataCon(..) + , DataType(..) + , reifyDataType + ) + +import qualified Streamly.Internal.Data.Serialize.TH.RecHeader as RecHeader + +import Streamly.Internal.Data.Serialize.TH.Bottom +import Streamly.Internal.Data.Serialize.TH.Common +import Streamly.Internal.Data.Serialize.TH.RecHeader +import Prelude hiding (Foldable(..)) + +-------------------------------------------------------------------------------- +-- Domain specific helpers +-------------------------------------------------------------------------------- + +exprGetSize :: Q Exp -> (Int, Type) -> Q Exp +exprGetSize acc (i, _) = [|addSizeTo $(acc) $(varE (mkFieldName i))|] + +getTagSize :: Int -> Int +getTagSize numConstructors + | numConstructors == 1 = 0 + | fromIntegral (maxBound :: Word8) >= numConstructors = 1 + | fromIntegral (maxBound :: Word16) >= numConstructors = 2 + | fromIntegral (maxBound :: Word32) >= numConstructors = 4 + | fromIntegral (maxBound :: Word64) >= numConstructors = 8 + | otherwise = error "Too many constructors" + +getTagType :: Int -> Name +getTagType numConstructors + | numConstructors == 1 = error "No tag for 1 constructor" + | fromIntegral (maxBound :: Word8) >= numConstructors = ''Word8 + | fromIntegral (maxBound :: Word16) >= numConstructors = ''Word16 + | fromIntegral (maxBound :: Word32) >= numConstructors = ''Word32 + | fromIntegral (maxBound :: Word64) >= numConstructors = ''Word64 + | otherwise = error "Too many constructors" + +-------------------------------------------------------------------------------- +-- Size +-------------------------------------------------------------------------------- + +getNameBaseLen :: Name -> Word8 +getNameBaseLen cname = + let x = length (nameBase cname) + in if x > 63 + then error "Max Constructor Len: 63 characters" + else fromIntegral x + +conEncLen :: Name -> Word8 +conEncLen cname = getNameBaseLen cname + 1 + +-------------------------------------------------------------------------------- +-- Size +-------------------------------------------------------------------------------- + +mkSizeOfExpr :: Bool -> Bool -> TypeOfType -> Q Exp +mkSizeOfExpr True False tyOfTy = + case tyOfTy of + UnitType cname -> + lamE + [varP _acc, wildP] + [|$(varE _acc) + $(litIntegral (conEncLen cname))|] + TheType con -> + lamE + [varP _acc, varP _x] + (caseE (varE _x) [matchCons (varE _acc) con]) + MultiType constructors -> sizeOfHeadDt constructors + + where + + sizeOfFields acc fields = + foldl' exprGetSize acc $ zip [0..] fields + + matchCons acc (SimpleDataCon cname fields) = + let a = litIntegral (conEncLen cname) + b = sizeOfFields acc (map snd fields) + expr = [|$(a) + $(b)|] + in matchConstructor cname (length fields) expr + + sizeOfHeadDt cons = + let acc = [|$(varE _acc)|] + in lamE + [varP _acc, varP _x] + (caseE (varE _x) (fmap (matchCons acc) cons)) + +mkSizeOfExpr False False tyOfTy = + case tyOfTy of + UnitType _ -> lamE [varP _acc, wildP] [|$(varE _acc) + 1|] + TheType con -> + lamE + [varP _acc, varP _x] + (caseE (varE _x) [matchCons (varE _acc) con]) + MultiType constructors -> sizeOfHeadDt constructors + + where + + tagSizeExp numConstructors = + litE (IntegerL (fromIntegral (getTagSize numConstructors))) + + -- XXX fields of the same type can be folded together, will reduce the code + -- size when there are many fields of the same type. + -- XXX const size fields can be calculated statically. + -- XXX This can result in large compilation times due to nesting when there + -- are many constructors. We can create a list and sum the list at run time + -- to avoid that depending on the number of constructors. Or using a let + -- statement for each case may help? + -- appE (varE 'sum) (listE (acc : map (exprGetSize (litE (IntegerL 0))) (zip [0..] fields))) + sizeOfFields acc fields = + foldl' exprGetSize acc $ zip [0..] fields + + matchCons acc (SimpleDataCon cname fields) = + let expr = sizeOfFields acc (map snd fields) + in matchConstructor cname (length fields) expr + + -- XXX We fix VarSize for simplicity. Should be changed later. + sizeOfHeadDt cons = + let numCons = length cons + acc = [|$(varE _acc) + $(tagSizeExp numCons)|] + in lamE + [varP _acc, varP _x] + (caseE (varE _x) (fmap (matchCons acc) cons)) + +mkSizeOfExpr False True (TheType con) = RecHeader.mkRecSizeOfExpr con + +mkSizeOfExpr _ _ _ = errorUnimplemented + +mkSizeDec :: SerializeConfig -> Type -> [DataCon] -> Q [Dec] +mkSizeDec (SerializeConfig {..}) headTy cons = do + -- INLINE on sizeOf actually worsens some benchmarks, and improves none + sizeOfMethod <- + mkSizeOfExpr + cfgConstructorTagAsString + cfgRecordSyntaxWithHeader + (typeOfType headTy cons) + pure + ( foldMap + (\x -> [PragmaD (InlineP 'addSizeTo x FunLike AllPhases)]) + cfgInlineSize + ++ [FunD 'addSizeTo [Clause [] (NormalB sizeOfMethod) []]] + ) + +-------------------------------------------------------------------------------- +-- Peek +-------------------------------------------------------------------------------- + +mkDeserializeExpr :: Bool -> Bool -> Type -> TypeOfType -> Q Exp +mkDeserializeExpr True False headTy tyOfTy = + case tyOfTy of + UnitType cname -> deserializeConsExpr [SimpleDataCon cname []] + TheType con -> deserializeConsExpr [con] + MultiType cons -> deserializeConsExpr cons + + where + + deserializeConsExpr cons = do + conLen <- newName "conLen" + off1 <- newName "off1" + [|do ($(varP off1), $(varP conLen) :: Word8) <- + deserializeAt + $(varE _initialOffset) + $(varE _arr) + $(varE _endOffset) + $(multiIfE (map (guardCon conLen off1) cons ++ [catchAll]))|] + + catchAll = + normalGE + [|True|] + [|error + ("Found invalid tag while peeking (" ++ + $(lift (pprint headTy)) ++ ")")|] + + guardCon conLen off con@(SimpleDataCon cname _) = do + let lenCname = getNameBaseLen cname + tag = map c2w (nameBase cname) + normalGE + [|($(litIntegral lenCname) == $(varE conLen)) + && $(xorCmp tag off _arr)|] + [|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname) + in $(mkDeserializeExprOne 'deserializeAt con)|] + +mkDeserializeExpr False False headTy tyOfTy = + case tyOfTy of + -- Unit constructor + -- XXX Should we peek and check if the byte value is 0? + UnitType cname -> + [|pure ($(varE _initialOffset) + 1, $(conE cname))|] + -- Product type + TheType con -> + letE + [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []] + (mkDeserializeExprOne 'deserializeAt con) + -- Sum type + MultiType cons -> do + let lenCons = length cons + tagType = getTagType lenCons + doE + [ bindS + (tupP [varP (mkName "i0"), varP _tag]) + [|deserializeAt $(varE _initialOffset) $(varE _arr) $(varE _endOffset)|] + , noBindS + (caseE + (sigE (varE _tag) (conT tagType)) + (fmap peekMatch (zip [0 ..] cons) ++ [peekErr])) + ] + where + peekMatch (i, con) = + match + (litP (IntegerL i)) + (normalB (mkDeserializeExprOne 'deserializeAt con)) [] + peekErr = + match + wildP + (normalB + -- XXX Print the tag + [|error + ("Found invalid tag while peeking (" ++ + $(lift (pprint headTy)) ++ ")")|]) + [] + +mkDeserializeExpr False True _ (TheType con@(SimpleDataCon _ fields)) = do + deserializeWithKeys <- newName "deserializeWithKeys" + updateFunc <- newName "updateFunc" + updateFuncDec <- RecHeader.conUpdateFuncDec updateFunc fields + deserializeWithKeysDec <- + RecHeader.mkDeserializeKeysDec deserializeWithKeys updateFunc con + letE + (pure <$> (deserializeWithKeysDec ++ updateFuncDec)) + (RecHeader.mkRecDeserializeExpr + _initialOffset + _endOffset + deserializeWithKeys + con) + +mkDeserializeExpr _ _ _ _ = errorUnimplemented + +mkDeserializeDec :: SerializeConfig -> Type -> [DataCon] -> Q [Dec] +mkDeserializeDec (SerializeConfig {..}) headTy cons = do + peekMethod <- + mkDeserializeExpr + cfgConstructorTagAsString + cfgRecordSyntaxWithHeader + headTy + (typeOfType headTy cons) + pure + ( foldMap + (\x -> [PragmaD (InlineP 'deserializeAt x FunLike AllPhases)]) + cfgInlineDeserialize + ++ + [ FunD + 'deserializeAt + [ Clause + (if isUnitType cons && not cfgConstructorTagAsString + then [VarP _initialOffset, WildP, WildP] + else [VarP _initialOffset, VarP _arr, VarP _endOffset]) + (NormalB peekMethod) + [] + ] + ] + ) + +-------------------------------------------------------------------------------- +-- Poke +-------------------------------------------------------------------------------- + +mkSerializeExprTag :: Name -> Int -> Q Exp +mkSerializeExprTag tagType tagVal = + [|serializeAt + $(varE _initialOffset) + $(varE _arr) + $(sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType))|] + +mkSerializeExpr :: Bool -> Bool -> TypeOfType -> Q Exp +mkSerializeExpr True False tyOfTy = + case tyOfTy of + -- Unit type + UnitType cname -> + caseE + (varE _val) + [serializeDataCon (SimpleDataCon cname [])] + -- Product type + (TheType con) -> + caseE + (varE _val) + [serializeDataCon con] + -- Sum type + (MultiType cons) -> + caseE + (varE _val) + (map serializeDataCon cons) + + where + + serializeDataCon (SimpleDataCon cname fields) = do + let tagLen8 = getNameBaseLen cname + conEnc = tagLen8 : map c2w (nameBase cname) + matchConstructor + cname + (length fields) + (doE [ bindS + (varP (mkName "i0")) + (serializeW8List _initialOffset _arr conEnc) + , noBindS (mkSerializeExprFields 'serializeAt fields) + ]) + +mkSerializeExpr False False tyOfTy = + case tyOfTy of + -- Unit type + UnitType _ -> + [|serializeAt $(varE _initialOffset) $(varE _arr) (0 :: Word8)|] + -- Product type + (TheType (SimpleDataCon cname fields)) -> + letE + [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []] + (caseE + (varE _val) + [ matchConstructor + cname + (length fields) + (mkSerializeExprFields 'serializeAt fields) + ]) + -- Sum type + (MultiType cons) -> do + let lenCons = length cons + tagType = getTagType lenCons + caseE + (varE _val) + (fmap (\(tagVal, SimpleDataCon cname fields) -> + matchConstructor + cname + (length fields) + (doE [ bindS + (varP (mkName "i0")) + (mkSerializeExprTag tagType tagVal) + , noBindS + (mkSerializeExprFields + 'serializeAt + fields) + ])) + (zip [0 ..] cons)) + +mkSerializeExpr False True (TheType con) = + RecHeader.mkRecSerializeExpr _initialOffset con + +mkSerializeExpr _ _ _ = errorUnimplemented + +mkSerializeDec :: SerializeConfig -> Type -> [DataCon] -> Q [Dec] +mkSerializeDec (SerializeConfig {..}) headTy cons = do + pokeMethod <- + mkSerializeExpr + cfgConstructorTagAsString + cfgRecordSyntaxWithHeader + (typeOfType headTy cons) + pure + ( foldMap + (\x -> [PragmaD (InlineP 'serializeAt x FunLike AllPhases)]) + cfgInlineSerialize + ++ + [FunD + 'serializeAt + [ Clause + (if isUnitType cons && not cfgConstructorTagAsString + then [VarP _initialOffset, VarP _arr, WildP] + else [VarP _initialOffset, VarP _arr, VarP _val]) + (NormalB pokeMethod) + [] + ] + ] + ) + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + +-- | A general function to derive Serialize instances where you can control +-- which Constructors of the datatype to consider and what the Context for the +-- 'Serialize' instance would be. +-- +-- Consider the datatype: +-- @ +-- data CustomDataType a b +-- = CDTConstructor1 +-- | CDTConstructor2 Bool +-- | CDTConstructor3 Bool b +-- deriving (Show, Eq) +-- @ +-- +-- Usage: +-- @ +-- $(deriveSerializeInternal +-- serializeConfig +-- [AppT (ConT ''Serialize) (VarT (mkName "b"))] +-- (AppT +-- (AppT (ConT ''CustomDataType) (VarT (mkName "a"))) +-- (VarT (mkName "b"))) +-- [ DataCon 'CDTConstructor1 [] [] [] +-- , DataCon 'CDTConstructor2 [] [] [(Nothing, (ConT ''Bool))] +-- , DataCon +-- 'CDTConstructor3 +-- [] +-- [] +-- [(Nothing, (ConT ''Bool)), (Nothing, (VarT (mkName "b")))] +-- ]) +-- @ +deriveSerializeInternal :: + SerializeConfig -> Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec] +deriveSerializeInternal conf headTy cons next = do + sizeDec <- mkSizeDec conf headTy cons + peekDec <- mkDeserializeDec conf headTy cons + pokeDec <- mkSerializeDec conf headTy cons + let methods = concat [sizeDec, peekDec, pokeDec] + next methods + +-- | @deriveSerializeWith config-modifier instance-dec@ generates a template +-- Haskell splice consisting of a declaration of a 'Serialize' instance. +-- @instance-dec@ is a template Haskell declaration splice consisting of a +-- standard Haskell instance declaration without the type class methods (e.g. +-- @[d|instance Serialize a => Serialize (Maybe a)|]@). +-- +-- The type class methods for the given instance are generated according to the +-- supplied @config-modifier@ parameter. See 'SerializeConfig' for default +-- configuration settings. +-- +-- Usage: +-- +-- @ +-- \$(deriveSerializeWith +-- ( inlineSerializeAt (Just NoInline) +-- . inlineDeserializeAt (Just NoInline) +-- ) +-- [d|instance Serialize a => Serialize (Maybe a)|]) +-- @ +deriveSerializeWith :: + (SerializeConfig -> SerializeConfig) -> Q [Dec] -> Q [Dec] +deriveSerializeWith modifier mDecs = do + dec <- mDecs + case dec of + [InstanceD mo preds headTyWC []] -> do + let headTy = unwrap dec headTyWC + dt <- reifyDataType (getMainTypeName dec headTy) + let cons = dtCons dt + deriveSerializeInternal + (modifier serializeConfig) headTy cons (next mo preds headTyWC) + _ -> errorMessage dec + + where + + next mo preds headTyWC methods = pure [InstanceD mo preds headTyWC methods] + + errorMessage dec = + error $ unlines + [ "Error: deriveSerializeWith:" + , "" + , ">> " ++ pprint dec + , "" + , "The supplied declaration is not a valid instance declaration." + , "Provide a valid Haskell instance declaration without a body." + , "" + , "Examples:" + , "instance Serialize (Proxy a)" + , "instance Serialize a => Serialize (Identity a)" + , "instance Serialize (TableT Identity)" + ] + + unwrap _ (AppT (ConT _) r) = r + unwrap dec _ = errorMessage dec + + getMainTypeName dec = go + + where + + go (ConT nm) = nm + go (AppT l _) = go l + go _ = errorMessage dec + +-- | Given an 'Serialize' instance declaration splice without the methods (e.g. +-- @[d|instance Serialize a => Serialize (Maybe a)|]@), generate an instance +-- declaration including all the type class method implementations. +-- +-- >>> deriveSerialize = deriveSerializeWith id +-- +-- Usage: +-- +-- @ +-- \$(deriveSerialize +-- [d|instance Serialize a => Serialize (Maybe a)|]) +-- @ +deriveSerialize :: Q [Dec] -> Q [Dec] +deriveSerialize = deriveSerializeWith id diff --git a/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs b/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Streamly.Internal.Data.Serialize.TH.Bottom +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Serialize.TH.Bottom + ( + -- ** Config + SerializeConfig(..) + , serializeConfig + , inlineAddSizeTo + , inlineSerializeAt + , inlineDeserializeAt + , encodeConstrNames + , encodeRecordFields + + -- ** Other Utilities + , TypeOfType(..) + , typeOfType + , SimpleDataCon(..) + , simplifyDataCon + , Field + , mkFieldName + , isUnitType + , isRecordSyntax + , c2w + , wListToString + , xorCmp + , serializeW8List + , litIntegral + , litProxy + , matchConstructor + , openConstructor + , makeI + , makeN + , makeA + , int_w8 + , int_w32 + , w32_int + , w8_int + , _acc + , _arr + , _endOffset + , _initialOffset + , _x + , _tag + , _val + , errorUnsupported + , errorUnimplemented + ) where + +import Data.Maybe (isJust) +import Data.Char (chr, ord) +import Data.Foldable (length) +import Data.List (foldl') +import Data.Word (Word16, Word32, Word64, Word8) +import Data.Bits (Bits, (.|.), shiftL, zeroBits, xor) +import Streamly.Internal.System.IO (unsafeInlineIO) +import Streamly.Internal.Data.Unbox (Unbox) +import Data.Proxy (Proxy) + +import Language.Haskell.TH +import Streamly.Internal.Data.Serialize.Type + +import qualified Streamly.Internal.Data.Unbox as Unbox + +import Streamly.Internal.Data.Unbox.TH (DataCon(..)) +import Prelude hiding (Foldable(..)) + +-------------------------------------------------------------------------------- +-- Config +-------------------------------------------------------------------------------- + +-- NOTE: 'Nothing' is not eqvivalant to 'Just Inlinable'. Ie. Having no inline +-- specific pragma and having an Inlinable pragma are different. Having an +-- Inlinable pragma makes GHC put the code in the interface file whereas having +-- no inline specific pragma let's GHC decide whether to put the code in +-- interface file or not. + +-- | Configuration to control how the 'Serialize' instance is generated. The +-- configuration is opaque and is modified by composing config modifier +-- functions, for example: +-- +-- >>> import Language.Haskell.TH (Inline(..)) +-- >>> configOpts = (inlineDeserializeAt (Just NoInline)) . (inlineSerializeAt (Just Inlinable)) +-- +-- The default configuration settings are: +-- +-- * 'inlineAddSizeTo' Nothing +-- * 'inlineSerializeAt' (Just Inline) +-- * 'inlineDeserializeAt' (Just Inline) +-- +-- The following experimental options are also available: +-- +-- * 'encodeConstrNames' False +-- * 'encodeRecordFields' False +-- +data SerializeConfig = + SerializeConfig + { cfgInlineSize :: Maybe Inline + , cfgInlineSerialize :: Maybe Inline + , cfgInlineDeserialize :: Maybe Inline + , cfgConstructorTagAsString :: Bool + , cfgRecordSyntaxWithHeader :: Bool + } + +-- | How should we inline the 'addSizeTo' function? The default is 'Nothing' +-- which means left to the compiler. Forcing inline on @addSizeTo@ function +-- actually worsens some benchmarks and improves none. +inlineAddSizeTo :: Maybe Inline -> SerializeConfig -> SerializeConfig +inlineAddSizeTo v cfg = cfg {cfgInlineSize = v} + +-- XXX Should we make the default Inlinable instead? + +-- | How should we inline the 'serialize' function? The default 'Just Inline'. +-- However, aggressive inlining can bloat the code and increase in compilation +-- times when there are big functions and too many nesting levels so you can +-- change it accordingly. A 'Nothing' value leaves the decision to the +-- compiler. +inlineSerializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig +inlineSerializeAt v cfg = cfg {cfgInlineSerialize = v} + +-- XXX Should we make the default Inlinable instead? + +-- | How should we inline the 'deserialize' function? See guidelines in +-- 'inlineSerializeAt'. +inlineDeserializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig +inlineDeserializeAt v cfg = cfg {cfgInlineDeserialize = v} + +-- | __Experimental__ +-- +-- In sum types, use Latin-1 encoded original constructor names rather than +-- binary values to identify constructors. This option is not applicable to +-- product types. +-- +-- This option enables the following behavior: +-- +-- * __Reordering__: Order of the fields can be changed without affecting +-- serialization. +-- * __Addition__: If a field is added in the new version, the old version of +-- the data type can still be deserialized by the new version. The new value +-- would never occur in the old one. +-- * __Deletion__: If a field is deleted in the new version, deserialization +-- of the old version will result in an error. TBD: We can possibly designate a +-- catch-all case to handle this scenario. +-- +-- Note that if you change a type, change the semantics of a type, or delete a +-- field and add a new field with the same name, deserialization of old data +-- may result in silent unexpected behavior. +-- +-- This option has to be the same on both encoding and decoding side. +-- +-- The default is 'False'. +-- +encodeConstrNames :: Bool -> SerializeConfig -> SerializeConfig +encodeConstrNames v cfg = cfg {cfgConstructorTagAsString = v} + +-- XXX We can deserialize each field to Either, so if there is a +-- deserialization error in any field it can handled independently. Also, a +-- unique type/version identifier of the field (based on the versions of the +-- packages, full module name space + type identifier) can be serialized along +-- with the value for stricter compatibility, semantics checking. Or we can +-- store a type hash. + +-- | __Experimental__ +-- +-- In explicit record types, use Latin-1 encoded record field names rather than +-- binary values to identify the record fields. Note that this option is not +-- applicable to sum types. Also, it does not work on a product type which is +-- not a record, because there are no field names to begin with. +-- +-- This option enables the following behavior: +-- +-- * __Reordering__: Order of the fields can be changed without affecting +-- serialization. +-- * __Addition__: If a 'Maybe' type field is added in the new version, the old +-- version of the data type can still be deserialized by the new version, the +-- field value in the older version is assumed to be 'Nothing'. If any other +-- type of field is added, deserialization of the older version results in an +-- error but only when that field is actually accessed in the deserialized +-- record. +-- * __Deletion__: If a field is deleted in the new version and it is +-- encountered in a previously serialized version then the field is discarded. +-- +-- This option has to be the same on both encoding and decoding side. +-- +-- There is a constant performance overhead proportional to the total length of +-- the record field names and the number of record fields. +-- +-- The default is 'False'. +-- +encodeRecordFields :: Bool -> SerializeConfig -> SerializeConfig +encodeRecordFields v cfg = cfg {cfgRecordSyntaxWithHeader = v} + +serializeConfig :: SerializeConfig +serializeConfig = + SerializeConfig + { cfgInlineSize = Nothing + , cfgInlineSerialize = Just Inline + , cfgInlineDeserialize = Just Inline + , cfgConstructorTagAsString = False + , cfgRecordSyntaxWithHeader = False + } + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +type Field = (Maybe Name, Type) + +_x :: Name +_x = mkName "x" + +_acc :: Name +_acc = mkName "acc" + +_arr :: Name +_arr = mkName "arr" + +_tag :: Name +_tag = mkName "tag" + +_initialOffset :: Name +_initialOffset = mkName "initialOffset" + +_endOffset :: Name +_endOffset = mkName "endOffset" + +_val :: Name +_val = mkName "val" + +mkFieldName :: Int -> Name +mkFieldName i = mkName ("field" ++ show i) + +makeI :: Int -> Name +makeI i = mkName $ "i" ++ show i + +makeN :: Int -> Name +makeN i = mkName $ "n" ++ show i + +makeA :: Int -> Name +makeA i = mkName $ "a" ++ show i + +-------------------------------------------------------------------------------- +-- Domain specific helpers +-------------------------------------------------------------------------------- + +openConstructor :: Name -> Int -> Q Pat +openConstructor cname numFields = + conP cname (map (varP. mkFieldName) [0 .. (numFields - 1)]) + +matchConstructor :: Name -> Int -> Q Exp -> Q Match +matchConstructor cname numFields exp0 = + match (openConstructor cname numFields) (normalB exp0) [] + +-------------------------------------------------------------------------------- +-- Constructor types +-------------------------------------------------------------------------------- + +data SimpleDataCon = + SimpleDataCon Name [Field] + deriving (Eq) + +simplifyDataCon :: DataCon -> SimpleDataCon +simplifyDataCon (DataCon cname _ _ fields) = SimpleDataCon cname fields + +data TypeOfType + = UnitType Name -- 1 constructor and 1 field + | TheType SimpleDataCon -- 1 constructor and 1+ fields + | MultiType [SimpleDataCon] -- 1+ constructors + deriving (Eq) + +typeOfType :: Type -> [DataCon] -> TypeOfType +typeOfType headTy [] = + error + ("Attempting to get size with no constructors (" ++ + pprint headTy ++ ")") +typeOfType _ [DataCon cname _ _ []] = UnitType cname +typeOfType _ [con@DataCon{}] = TheType $ simplifyDataCon con +typeOfType _ cons = MultiType $ map simplifyDataCon cons + +isUnitType :: [DataCon] -> Bool +isUnitType [DataCon _ _ _ []] = True +isUnitType _ = False + +isRecordSyntax :: SimpleDataCon -> Bool +isRecordSyntax (SimpleDataCon _ fields) = all (isJust . fst) fields + +-------------------------------------------------------------------------------- +-- Type casting +-------------------------------------------------------------------------------- + +int_w8 :: Int -> Word8 +int_w8 = fromIntegral + +int_w32 :: Int -> Word32 +int_w32 = fromIntegral + +w8_w16 :: Word8 -> Word16 +w8_w16 = fromIntegral + +w8_w32 :: Word8 -> Word32 +w8_w32 = fromIntegral + +w8_w64 :: Word8 -> Word64 +w8_w64 = fromIntegral + +w8_int :: Word8 -> Int +w8_int = fromIntegral + +w32_int :: Word32 -> Int +w32_int = fromIntegral + +c2w :: Char -> Word8 +c2w = fromIntegral . ord + +wListToString :: [Word8] -> String +wListToString = fmap (chr . fromIntegral) + +-------------------------------------------------------------------------------- +-- Bit manipulation +-------------------------------------------------------------------------------- + +shiftAdd :: Bits a => (b -> a) -> [b] -> a +shiftAdd conv xs = + foldl' (.|.) zeroBits $ + fmap (\(j, x) -> shiftL x (j * 8)) $ zip [0 ..] $ map conv xs + +-- Note: This only works in little endian machines +-- TODO: +-- Instead of generating this via TH can't we write it directly in Haskell and +-- use that? Creating one comparison function for each deserialization may be +-- too much code and may not be necessary. +-- Benchmark both the implementations and check. +xorCmp :: [Word8] -> Name -> Name -> Q Exp +xorCmp tag off arr = + case tagLen of + x | x < 2 -> [|$(go8 0) == zeroBits|] + x | x < 4 -> [|$(go16 0) == zeroBits|] + x | x < 8 -> [|$(go32 0) == zeroBits|] + _ -> [|$(go64 0) == zeroBits|] + where + tagLen = length tag + go8 i | i >= tagLen = [|zeroBits|] + go8 i = do + let wIntegral = litIntegral i + [|xor (unsafeInlineIO + (Unbox.peekAt + ($(varE off) + $(litIntegral i)) + $(varE arr))) + ($(wIntegral) :: Word8) .|. + $(go8 (i + 1))|] + go16 i + | i >= tagLen = [|zeroBits|] + go16 i + | tagLen - i < 2 = go16 (tagLen - 2) + go16 i = do + let wIntegral = + litIntegral + (shiftAdd w8_w16 [tag !! i, tag !! (i + 1)] :: Word16) + [|xor (unsafeInlineIO + (Unbox.peekAt + ($(varE off) + $(litIntegral i)) + $(varE arr))) + ($(wIntegral) :: Word16) .|. + $(go16 (i + 2))|] + go32 i + | i >= tagLen = [|zeroBits|] + go32 i + | tagLen - i < 4 = go32 (tagLen - 4) + go32 i = do + let wIntegral = + litIntegral + (shiftAdd + w8_w32 + [ tag !! i + , tag !! (i + 1) + , tag !! (i + 2) + , tag !! (i + 3) + ] :: Word32) + [|xor (unsafeInlineIO + (Unbox.peekAt + ($(varE off) + $(litIntegral i)) + $(varE arr))) + ($(wIntegral) :: Word32) .|. + $(go32 (i + 4))|] + go64 i + | i >= tagLen = [|zeroBits|] + go64 i + | tagLen - i < 8 = go64 (tagLen - 8) + go64 i = do + let wIntegral = + litIntegral + (shiftAdd + w8_w64 + [ tag !! i + , tag !! (i + 1) + , tag !! (i + 2) + , tag !! (i + 3) + , tag !! (i + 4) + , tag !! (i + 5) + , tag !! (i + 6) + , tag !! (i + 7) + ]) + [|xor (unsafeInlineIO + (Unbox.peekAt + ($(varE off) + $(litIntegral i)) + $(varE arr))) + ($(wIntegral) :: Word64) .|. + $(go64 (i + 8))|] + +-------------------------------------------------------------------------------- +-- Primitive serialization +-------------------------------------------------------------------------------- + +-- TODO: +-- Will this be too much of a code bloat? +-- Loop with the loop body unrolled? +-- Serialize this in batches similar to batch comparision in xorCmp? +serializeW8List :: Name -> Name -> [Word8] -> Q Exp +serializeW8List off arr w8List = do + [|let $(varP (makeN 0)) = $(varE off) + in $(doE (fmap makeBind [0 .. (lenW8List - 1)] ++ + [noBindS [|pure $(varE (makeN lenW8List))|]]))|] + + where + + lenW8List = length w8List + makeBind i = + bindS + (varP (makeN (i + 1))) + [|$(varE 'serializeAt) + $(varE (makeN i)) + $(varE arr) + ($(litIntegral (w8List !! i)) :: Word8)|] + +-------------------------------------------------------------------------------- +-- TH Helpers +-------------------------------------------------------------------------------- + +litIntegral :: Integral a => a -> Q Exp +litIntegral = litE . IntegerL . fromIntegral + +litProxy :: Unbox a => Proxy a -> Q Exp +litProxy = litE . IntegerL . fromIntegral . Unbox.sizeOf + +-------------------------------------------------------------------------------- +-- Error codes +-------------------------------------------------------------------------------- + +errorUnsupported :: String -> a +errorUnsupported err = + error + $ unlines + [ "Unsupported" + , "===========" + , "This is improper use of the library." + , "This case is unsupported." + , "Please contact the developer if this case is of interest." + , "" + , "Message" + , "-------" + , err + ] + +errorUnimplemented :: a +errorUnimplemented = + error + $ unlines + [ "Unimplemented" + , "=============" + , "Please contact the developer if this case is of interest." + ] diff --git a/src/Streamly/Internal/Data/Serialize/TH/Common.hs b/src/Streamly/Internal/Data/Serialize/TH/Common.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Serialize/TH/Common.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Streamly.Internal.Data.Serialize.TH.Common +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Serialize.TH.Common + ( mkDeserializeExprOne + , mkSerializeExprFields + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Language.Haskell.TH +import Streamly.Internal.Data.Serialize.TH.Bottom + +-------------------------------------------------------------------------------- +-- Code +-------------------------------------------------------------------------------- + +mkDeserializeExprOne :: Name -> SimpleDataCon -> Q Exp +mkDeserializeExprOne peeker (SimpleDataCon cname fields) = + case fields of + -- Only tag is serialized for unit fields, no actual value + [] -> [|pure ($(varE (mkName "i0")), $(conE cname))|] + _ -> + doE + (concat + [ fmap makeBind [0 .. (numFields - 1)] + , [ noBindS + (appE + (varE 'pure) + (tupE + [ varE (makeI numFields) + , appsE + (conE cname : + map (varE . makeA) + [0 .. (numFields - 1)]) + ])) + ] + ]) + where + numFields = length fields + makeBind i = + bindS + (tupP [varP (makeI (i + 1)), varP (makeA i)]) + [|$(varE peeker) $(varE (makeI i)) $(varE _arr) $(varE _endOffset)|] + +mkSerializeExprFields :: Name -> [Field] -> Q Exp +mkSerializeExprFields poker fields = + case fields of + -- Unit constructor, do nothing just tag is enough + [] -> [|pure ($(varE (mkName "i0")))|] + _ -> + doE + (fmap makeBind [0 .. (numFields - 1)] ++ + [noBindS [|pure $(varE (makeI numFields))|]]) + where + numFields = length fields + makeBind i = + bindS + (varP (makeI (i + 1))) + [|$(varE poker) + $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|] diff --git a/src/Streamly/Internal/Data/Serialize/TH/RecHeader.hs b/src/Streamly/Internal/Data/Serialize/TH/RecHeader.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Serialize/TH/RecHeader.hs @@ -0,0 +1,413 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Streamly.Internal.Data.Serialize.TH.RecHeader +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Serialize.TH.RecHeader + ( mkRecSerializeExpr + , mkRecDeserializeExpr + , mkRecSizeOfExpr + , conUpdateFuncDec + , mkDeserializeKeysDec + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Control.Monad (void) +import Data.Foldable (length, sum) +import Data.List (foldl') +import Data.Word (Word32, Word8) +import Data.Maybe (fromJust) +import Language.Haskell.TH +import Streamly.Internal.Data.Serialize.Type (Serialize(..)) +import Data.Foldable (foldlM) +import Streamly.Internal.Data.MutByteArray.Type (MutByteArray) +import Data.Proxy (Proxy(..)) + +import qualified Streamly.Internal.Data.Unbox as Unbox + +import Streamly.Internal.Data.Serialize.TH.Bottom +import Streamly.Internal.Data.Serialize.TH.Common +import Prelude hiding (Foldable(..)) + +-------------------------------------------------------------------------------- +-- Notes +-------------------------------------------------------------------------------- + +-- Compatibility Algorithm +-- ======================= +-- +-- The algorithm is written without any low level implementation details. See +-- the code for any low level implementation details. +-- +-- Serialization: +-- -------------- +-- +-- To serialize the data, +-- +-- * Get the list of keys for the record as @keyList@. +-- * Serialize the @keyList@. +-- * Serialize the @fields@ one-by-one after serializing the @keyList@. +-- +-- Deserialization: +-- ---------------- +-- +-- To deserialize the data to type @T@, +-- +-- __Checking for type match__: +-- +-- * Get the list of keys for type @T@ as @targetKeyList@. +-- * Get the list of keys encoded as @encodedKeyList@. +-- * If @targetKeyList == encodedKeyList@ see the __Type Match__ section else +-- see the __No Type Match__ section. +-- +-- __Type Match__: +-- +-- * Decode the fields one-by-one and construct the type @T@ in the end. +-- +-- __No Type Match__: +-- +-- * Decode the list of keys encoded into @encodedKeyList@. +-- * Get the list of keys for type @T@ as @targetKeyList@. +-- * Loop through @encodedKeyList@ and start deserializing the encoded data. +-- * If the key is present in @encodedKeyList@ and not in @targetKeyList@ +-- then skip parsing the corresponding value. +-- * If the key is present in @targetKeyList@ and not in @encodedKeyList@ +-- then set the value for that key as @Nothing@. +-- * If the key is present in both @encodedKeyList@ and in @targetKeyList@ +-- parse the value. +-- * Construct @T@ after parsing all the data. + +-- Developer Notes +-- =============== +-- +-- * Record update syntax is not robust across language extensions and common +-- record plugins (like record-dot-processor, large-records, etc.). + +-------------------------------------------------------------------------------- +-- Compact lists +-------------------------------------------------------------------------------- + +-- Like haskell list but the maximum length of the list is 255 +newtype CompactList a = + CompactList + { unCompactList :: [a] + } + +-- We use 'Word8' to encode the length, hence the maximim number of elements in +-- the list is 255. +instance forall a. Serialize a => Serialize (CompactList a) where + + -- {-# INLINE addSizeTo #-} + addSizeTo acc (CompactList xs) = + foldl' addSizeTo (acc + Unbox.sizeOf (Proxy :: Proxy Word8)) xs + + -- Inlining this causes large compilation times for tests + {-# INLINABLE deserializeAt #-} + deserializeAt off arr sz = do + (off1, len8) <- deserializeAt off arr sz :: IO (Int, Word8) + let len = w8_int len8 + peekList f o i | i >= 3 = do + -- Unfold the loop three times + (o1, x1) <- deserializeAt o arr sz + (o2, x2) <- deserializeAt o1 arr sz + (o3, x3) <- deserializeAt o2 arr sz + peekList (f . (\xs -> x1:x2:x3:xs)) o3 (i - 3) + peekList f o 0 = pure (o, f []) + peekList f o i = do + (o1, x) <- deserializeAt o arr sz + peekList (f . (x:)) o1 (i - 1) + (nextOff, lst) <- peekList id off1 len + pure (nextOff, CompactList lst) + + -- Inlining this causes large compilation times for tests + {-# INLINABLE serializeAt #-} + serializeAt off arr (CompactList val) = do + void $ serializeAt off arr (int_w8 (length val) :: Word8) + let off1 = off + Unbox.sizeOf (Proxy :: Proxy Word8) + let pokeList o [] = pure o + pokeList o (x:xs) = do + o1 <- serializeAt o arr x + pokeList o1 xs + pokeList off1 val + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +fieldToNameBase :: Field -> String +fieldToNameBase = nameBase . fromJust . fst + +isMaybeType :: Type -> Bool +isMaybeType (AppT (ConT m) _) = m == ''Maybe +isMaybeType _ = False + +-------------------------------------------------------------------------------- +-- Size +-------------------------------------------------------------------------------- + +-- We add 4 here because we use 'serializeWithSize' for serializing. +exprGetSize :: Q Exp -> (Int, Type) -> Q Exp +exprGetSize acc (i, _) = + [|addSizeTo $(acc) $(varE (mkFieldName i)) + 4|] + +sizeOfHeader :: SimpleDataCon -> Int +sizeOfHeader (SimpleDataCon _ fields) = + sizeForFinalOff + sizeForHeaderLength + sizeForNumFields + + sum (map ((+ sizeForFieldLen) . length . fieldToNameBase) fields) + + where + + sizeForFinalOff = 4 + sizeForHeaderLength = 4 -- Max header length is (255 * (255 + 1) + 1) and + -- hence 2 bytes is enough to store it. But we still + -- use 4 bytes as using 2 bytes introduces + -- regression. + sizeForNumFields = 1 -- At max 255 fields in the record constructor + sizeForFieldLen = 1 -- At max 255 letters in the key + +mkRecSizeOfExpr :: SimpleDataCon -> Q Exp +mkRecSizeOfExpr con = do + n_acc <- newName "acc" + n_x <- newName "x" + lamE + [varP n_acc, varP n_x] + [|$(litIntegral hlen) + + $(caseE (varE n_x) [matchCons (varE n_acc) con])|] + + where + + hlen = sizeOfHeader con + sizeOfFields acc fields = foldl' exprGetSize acc $ zip [0 ..] fields + matchCons acc (SimpleDataCon cname fields) = + let expr = sizeOfFields acc (map snd fields) + in matchConstructor cname (length fields) expr + +-------------------------------------------------------------------------------- +-- Header +-------------------------------------------------------------------------------- + +headerValue :: SimpleDataCon -> [Word8] +headerValue (SimpleDataCon _ fields) = + int_w8 numFields : concatMap lengthPrependedFieldEncoding fields + + where + + -- Error out if the number of fields or the length of key is >= 256. We use + -- Word8 for encoding the info and hence the max value is 255. + numFields = + let lenFields = length fields + in if lenFields <= 255 + then lenFields + else errorUnsupported + "Number of fields in the record should be <= 255." + lengthPrependedFieldEncoding field = + let fEnc = + let fEnc_ = map c2w (fieldToNameBase field) + lenFEnc = length fEnc_ + in if lenFEnc <= 255 + then fEnc_ + else + errorUnsupported + "Length of any key should be <= 255." + in int_w8 (length fEnc) : fEnc + +-------------------------------------------------------------------------------- +-- Peek +-------------------------------------------------------------------------------- + +-- Encoding the size is required if we want to skip the field without knowing +-- its type. We encode the size as 'Word32' hence there is a 4 bytes increase +-- in size. +{-# INLINE serializeWithSize #-} +serializeWithSize :: Serialize a => Int -> MutByteArray -> a -> IO Int +serializeWithSize off arr val = do + off1 <- serializeAt (off + 4) arr val + Unbox.pokeAt off arr (int_w32 (off1 - off - 4) :: Word32) + pure off1 + +mkRecSerializeExpr :: Name -> SimpleDataCon -> Q Exp +mkRecSerializeExpr initialOffset con@(SimpleDataCon cname fields) = do + afterHLen <- newName "afterHLen" + -- Encoding the header length is required. + -- We first compare the header length encoded and the current header + -- length. Only if the header lengths match, we compare the headers. + [|do $(varP afterHLen) <- + serializeAt + ($(varE initialOffset) + 4) + $(varE _arr) + ($(litIntegral hlen) :: Word32) + $(varP (makeI 0)) <- $(serializeW8List afterHLen _arr hval) + let $(openConstructor cname (length fields)) = $(varE _val) + finalOff <- $(mkSerializeExprFields 'serializeWithSize fields) + Unbox.pokeAt + $(varE initialOffset) + $(varE _arr) + ((fromIntegral :: Int -> Word32) + (finalOff - $(varE initialOffset))) + pure finalOff|] + + where + + hval = headerValue con + hlen = length hval + +-------------------------------------------------------------------------------- +-- Poke +-------------------------------------------------------------------------------- + +{-# INLINE deserializeWithSize #-} +deserializeWithSize :: + Serialize a => Int -> MutByteArray -> Int -> IO (Int, a) +deserializeWithSize off = deserializeAt (off + 4) + +conUpdateFuncDec :: Name -> [Field] -> Q [Dec] +conUpdateFuncDec funcName fields = do + prevAcc <- newName "prevAcc" + curOff <- newName "curOff" + endOff <- newName "endOff" + arr <- newName "arr" + key <- newName "key" + method <- + caseE + (varE key) + (concat + [ map (matchField arr endOff (prevAcc, curOff)) fnames + , [ match + wildP + (normalB + [|do (valOff, valLen :: Word32) <- + deserializeAt + $(varE curOff) + $(varE arr) + $(varE endOff) + pure + ( $(varE prevAcc) + , valOff + w32_int valLen)|]) + [] + ] + ]) + pure + [ PragmaD (InlineP funcName NoInline FunLike AllPhases) + , FunD + funcName + [ Clause + [ VarP arr + , VarP endOff + , TupP [VarP prevAcc, VarP curOff] + , VarP key + ] + (NormalB method) + [] + ] + ] + + where + + fnames = fmap (fromJust . fst) fields + matchField :: Name -> Name -> (Name, Name) -> Name -> Q Match + matchField arr endOff (acc, currOff) fname = do + let fnameLit = StringL (nameBase fname) + match + (litP fnameLit) + (normalB + [|do (valOff, valLen :: Word32) <- + deserializeAt + $(varE currOff) + $(varE arr) + $(varE endOff) + pure + ( ($(litE fnameLit), $(varE currOff)) : $(varE acc) + , valOff + w32_int valLen)|]) + [] + +mkDeserializeKeysDec :: Name -> Name -> SimpleDataCon -> Q [Dec] +mkDeserializeKeysDec funcName updateFunc (SimpleDataCon cname fields) = do + hOff <- newName "hOff" + finalOff <- newName "finalOff" + arr <- newName "arr" + endOff <- newName "endOff" + kvEncoded <- newName "kvEncoded" + finalRec <- newName "finalRec" + let deserializeFieldExpr (Just name, ty) = do + let nameLit = litE (StringL (nameBase name)) + [|case lookup $(nameLit) $(varE kvEncoded) of + Nothing -> $(emptyTy name ty) + Just off -> do + val <- deserializeWithSize off $(varE arr) $(varE endOff) + pure $ snd val|] + deserializeFieldExpr _ = + errorUnsupported "The datatype should use record syntax." + method <- + [|do (dataOff, hlist :: CompactList (CompactList Word8)) <- + deserializeAt $(varE hOff) $(varE arr) $(varE endOff) + let keys = wListToString . unCompactList <$> unCompactList hlist + ($(varP kvEncoded), _) <- + foldlM + ($(varE updateFunc) $(varE arr) $(varE endOff)) + ([], dataOff) + keys + $(varP finalRec) <- + $(foldl' + (\acc i -> + [|$(acc) <*> + $(deserializeFieldExpr i)|]) + [|pure $(conE cname)|] + fields) + pure ($(varE finalOff), $(varE finalRec))|] + pure + [ PragmaD (InlineP funcName NoInline FunLike AllPhases) + , FunD + funcName + [ Clause + [ VarP hOff + , VarP finalOff + , VarP arr + , VarP endOff + ] + (NormalB method) + [] + ] + ] + + where + + emptyTy k ty = + if isMaybeType ty + then [|pure Nothing|] + else [|error $(litE (StringL (nameBase k ++ " is not found.")))|] + + +mkRecDeserializeExpr :: Name -> Name -> Name -> SimpleDataCon -> Q Exp +mkRecDeserializeExpr initialOff endOff deserializeWithKeys con = do + hOff <- newName "hOff" + let sizeForFinalOff = 4 -- Word32 + sizeForHeaderLength = 4 -- Word32 + sizePreData = sizeForFinalOff + sizeForHeaderLength + hlen + [|do (hlenOff, encLen :: Word32) <- + deserializeAt $(varE initialOff) $(varE _arr) $(varE endOff) + ($(varP hOff), hlen1 :: Word32) <- + deserializeAt hlenOff $(varE _arr) $(varE endOff) + if (hlen1 == $(litIntegral hlen)) && $(xorCmp hval hOff _arr) + then do + let $(varP (makeI 0)) = + $(varE initialOff) + + $(litIntegral sizePreData) + $(mkDeserializeExprOne 'deserializeWithSize con) + else $(varE deserializeWithKeys) + $(varE hOff) + ($(varE initialOff) + w32_int encLen) + $(varE _arr) + $(varE endOff)|] + + where + + hval = headerValue con + hlen = length hval diff --git a/src/Streamly/Internal/Data/Serialize/Type.hs b/src/Streamly/Internal/Data/Serialize/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Serialize/Type.hs @@ -0,0 +1,321 @@ +{- HLINT ignore -} +-- | +-- Module : Streamly.Internal.Data.Serialize.Type +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- + +module Streamly.Internal.Data.Serialize.Type + ( + Serialize(..) + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Control.Monad (when) +import Data.List (foldl') +import Data.Proxy (Proxy (..)) +import Streamly.Internal.Data.Unbox (Unbox) +import Streamly.Internal.Data.MutByteArray.Type (MutByteArray(..)) +import Streamly.Internal.Data.Array.Type (Array(..)) +import GHC.Int (Int16(..), Int32(..), Int64(..), Int8(..)) +import GHC.Word (Word16(..), Word32(..), Word64(..), Word8(..)) +import GHC.Stable (StablePtr(..)) +import GHC.Fingerprint.Type (Fingerprint) + +import qualified Streamly.Internal.Data.Array.Type as Array +import qualified Streamly.Internal.Data.MutArray.Type as MutArray +import qualified Streamly.Internal.Data.MutByteArray.Type as MBA +import qualified Streamly.Internal.Data.Unbox as Unbox + +import GHC.Exts +import Prelude hiding (Foldable(..)) + +-------------------------------------------------------------------------------- +-- Developer Note +-------------------------------------------------------------------------------- + +-- IMPORTANT +-- ========= +-- +-- Don't ever serialize the absolute offsets in the encoding. Serialize length +-- instead. Absolute offsets are NOT stable. +-- +-- They will only work if the start offset of the Array when encoding and +-- decoding is the same. This is almost never the case. + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +-- | The 'Serialize' type class provides operations for serialization and +-- deserialization of general Haskell data types to and from their byte stream +-- representation. +-- +-- Unlike 'Unbox', 'Serialize' uses variable length encoding, therefore, it can +-- serialize recursive and variable length data types like lists, or variable +-- length sum types where the length of the value may vary depending on a +-- particular constructor. For variable length data types the length is encoded +-- along with the data. +-- +-- The 'deserializeAt' operation reads bytes from the mutable byte array and +-- builds a Haskell data type from these bytes, the number of bytes it reads +-- depends on the type and the encoded value it is reading. 'serializeAt' +-- operation converts a Haskell data type to its binary representation which +-- must consist of as many bytes as added by the @addSizeTo@ operation for that +-- value and then stores these bytes into the mutable byte array. The +-- programmer is expected to use the @addSizeTo@ operation and allocate an +-- array of sufficient length before calling 'serializeAt'. +-- +-- IMPORTANT: The serialized data's byte ordering remains the same as the host +-- machine's byte order. Therefore, it can not be deserialized from host +-- machines with a different byte ordering. +-- +-- Instances can be derived via Template Haskell, or written manually. +-- +-- Here is an example, for deriving an instance of this type class using +-- template Haskell: +-- +-- >>> :{ +-- data Object = Object +-- { _obj1 :: [Int] +-- , _obj2 :: Int +-- } +-- :} +-- +-- @ +-- import Streamly.Data.MutByteArray (deriveSerialize) +-- \$(deriveSerialize [d|instance Serialize Object|]) +-- @ +-- +-- See 'Streamly.Data.MutByteArray.deriveSerialize' and +-- 'Streamly.Data.MutByteArray.deriveSerializeWith' for more information on +-- deriving using Template Haskell. +-- +-- Here is an example of a manual instance. +-- +-- >>> import Streamly.Data.MutByteArray (Serialize(..)) +-- +-- >>> :{ +-- instance Serialize Object where +-- addSizeTo acc obj = addSizeTo (addSizeTo acc (_obj1 obj)) (_obj2 obj) +-- deserializeAt i arr len = do +-- -- Check the array bounds before reading +-- (i1, x0) <- deserializeAt i arr len +-- (i2, x1) <- deserializeAt i1 arr len +-- pure (i2, Object x0 x1) +-- serializeAt i arr (Object x0 x1) = do +-- i1 <- serializeAt i arr x0 +-- i2 <- serializeAt i1 arr x1 +-- pure i2 +-- :} +-- +class Serialize a where + -- XXX Use (a -> Sum Int) instead, remove the Size type + + -- A left fold step to fold a generic structure to its serializable size. + -- It is of the form @Int -> a -> Int@ because you can have tail-recursive + -- traversal of the structures. + + -- | @addSizeTo accum value@ returns @accum@ incremented by the size of the + -- serialized representation of @value@ in bytes. Size cannot be zero. It + -- should be at least 1 byte. + addSizeTo :: Int -> a -> Int + + -- We can implement the following functions without returning the `Int` + -- offset but that may require traversing the Haskell structure again to get + -- the size. Therefore, this is a performance optimization. + + -- | @deserializeAt byte-offset array arrayLen@ deserializes a value from + -- the given byte-offset in the array. Returns a tuple consisting of the + -- next byte-offset and the deserialized value. + -- + -- The arrayLen passed is the entire length of the input buffer. It is to + -- be used to check if we would overflow the input buffer when + -- deserializing. + -- + -- Throws an exception if the operation would exceed the supplied arrayLen. + deserializeAt :: Int -> MutByteArray -> Int -> IO (Int, a) + + -- | @serializeAt byte-offset array value@ writes the serialized + -- representation of the @value@ in the array at the given byte-offset. + -- Returns the next byte-offset. + -- + -- This is an unsafe operation, the programmer must ensure that the array + -- has enough space available to serialize the value as determined by the + -- @addSizeTo@ operation. + serializeAt :: Int -> MutByteArray -> a -> IO Int + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +-- _size is the length from array start to the last accessed byte. +#ifdef DEBUG +{-# INLINE checkBounds #-} +checkBounds :: String -> Int -> MutByteArray -> IO () +checkBounds _label _size _arr = do + sz <- MBA.length _arr + if (_size > sz) + then error + $ _label + ++ ": accessing array at offset = " + ++ show (_size - 1) + ++ " max valid offset = " ++ show (sz - 1) + else return () +#endif + +-- Note: Instead of passing around the size parameter, we can use +-- (MBA.length arr) for checking the array bound, but that turns +-- out to be more expensive. +-- +-- Another way to optimize this is to avoid the check for fixed size +-- structures. For fixed size structures we can do a check at the top level and +-- then use checkless deserialization using the Unbox type class. That will +-- require ConstSize and VarSize constructors in size. The programmer can +-- bundle all const size fields in a newtype to make serialization faster. This +-- can speed up the computation of size when serializing and checking size when +-- deserialing. +-- +-- For variable size non-recursive structures a separate size validation method +-- could be used to validate the size before deserializing. "validate" can also +-- be used to collpase multiple chunks of arrays coming from network into a +-- single array for deserializing. But that can also be done by framing the +-- serialized value with a size header. +-- +{-# INLINE deserializeChecked #-} +deserializeChecked :: forall a. Unbox a => Int -> MutByteArray -> Int -> IO (Int, a) +deserializeChecked off arr sz = + let next = off + Unbox.sizeOf (Proxy :: Proxy a) + in do + -- Keep likely path in the straight branch. + if next <= sz + then Unbox.peekAt off arr >>= \val -> pure (next, val) + else error + $ "deserializeAt: accessing array at offset = " + ++ show (next - 1) + ++ " max valid offset = " ++ show (sz - 1) + +{-# INLINE serializeUnsafe #-} +serializeUnsafe :: forall a. Unbox a => Int -> MutByteArray -> a -> IO Int +serializeUnsafe off arr val = + let next = off + Unbox.sizeOf (Proxy :: Proxy a) + in do +#ifdef DEBUG + checkBounds "serializeAt" next arr +#endif + Unbox.pokeAt off arr val + pure next + +#define DERIVE_SERIALIZE_FROM_UNBOX(_type) \ +instance Serialize _type where \ +; {-# INLINE addSizeTo #-} \ +; addSizeTo acc _ = acc + Unbox.sizeOf (Proxy :: Proxy _type) \ +; {-# INLINE deserializeAt #-} \ +; deserializeAt off arr end = deserializeChecked off arr end :: IO (Int, _type) \ +; {-# INLINE serializeAt #-} \ +; serializeAt = \ + serializeUnsafe :: Int -> MutByteArray -> _type -> IO Int + +DERIVE_SERIALIZE_FROM_UNBOX(()) +DERIVE_SERIALIZE_FROM_UNBOX(Bool) +DERIVE_SERIALIZE_FROM_UNBOX(Char) +DERIVE_SERIALIZE_FROM_UNBOX(Int8) +DERIVE_SERIALIZE_FROM_UNBOX(Int16) +DERIVE_SERIALIZE_FROM_UNBOX(Int32) +DERIVE_SERIALIZE_FROM_UNBOX(Int) +DERIVE_SERIALIZE_FROM_UNBOX(Int64) +DERIVE_SERIALIZE_FROM_UNBOX(Word) +DERIVE_SERIALIZE_FROM_UNBOX(Word8) +DERIVE_SERIALIZE_FROM_UNBOX(Word16) +DERIVE_SERIALIZE_FROM_UNBOX(Word32) +DERIVE_SERIALIZE_FROM_UNBOX(Word64) +DERIVE_SERIALIZE_FROM_UNBOX(Double) +DERIVE_SERIALIZE_FROM_UNBOX(Float) +DERIVE_SERIALIZE_FROM_UNBOX((StablePtr a)) +DERIVE_SERIALIZE_FROM_UNBOX((Ptr a)) +DERIVE_SERIALIZE_FROM_UNBOX((FunPtr a)) +DERIVE_SERIALIZE_FROM_UNBOX(Fingerprint) + +instance forall a. Serialize a => Serialize [a] where + + -- {-# INLINE addSizeTo #-} + addSizeTo acc xs = + foldl' addSizeTo (acc + Unbox.sizeOf (Proxy :: Proxy Int)) xs + + -- Inlining this causes large compilation times for tests + {-# INLINABLE deserializeAt #-} + deserializeAt off arr sz = do + (off1, len64) <- deserializeAt off arr sz :: IO (Int, Int64) + let len = (fromIntegral :: Int64 -> Int) len64 + peekList f o i | i >= 3 = do + -- Unfold the loop three times + (o1, x1) <- deserializeAt o arr sz + (o2, x2) <- deserializeAt o1 arr sz + (o3, x3) <- deserializeAt o2 arr sz + peekList (f . (\xs -> x1:x2:x3:xs)) o3 (i - 3) + peekList f o 0 = pure (o, f []) + peekList f o i = do + (o1, x) <- deserializeAt o arr sz + peekList (f . (x:)) o1 (i - 1) + peekList id off1 len + + -- Inlining this causes large compilation times for tests + {-# INLINABLE serializeAt #-} + serializeAt off arr val = do + let off1 = off + Unbox.sizeOf (Proxy :: Proxy Int64) + let pokeList acc o [] = + Unbox.pokeAt off arr (acc :: Int64) >> pure o + pokeList acc o (x:xs) = do + o1 <- serializeAt o arr x + pokeList (acc + 1) o1 xs + pokeList 0 off1 val + +instance +#ifdef DEVBUILD + Unbox a => +#endif + Serialize (Array a) where + {-# INLINE addSizeTo #-} + addSizeTo i (Array {..}) = i + (arrEnd - arrStart) + 8 + + {-# INLINE deserializeAt #-} + deserializeAt off arr len = do + (off1, byteLen) <- deserializeAt off arr len :: IO (Int, Int) + let off2 = off1 + byteLen + when (off2 > len) $ + error + $ "deserializeAt: accessing array at offset = " + ++ show (off2 - 1) + ++ " max valid offset = " ++ show (len - 1) + -- XXX Use MutByteArray.cloneSliceUnsafe + let slice = MutArray.MutArray arr off1 off2 off2 + newArr <- MutArray.clone slice + pure (off2, Array.unsafeFreeze newArr) + + {-# INLINE serializeAt #-} + serializeAt off arr (Array {..}) = do + let arrLen = arrEnd - arrStart + off1 <- serializeAt off arr arrLen + MBA.unsafePutSlice arrContents arrStart arr off1 arrLen + pure (off1 + arrLen) + +instance (Serialize a, Serialize b) => Serialize (a, b) where + + {-# INLINE addSizeTo #-} + addSizeTo acc (a, b) = addSizeTo (addSizeTo acc a) b + + {-# INLINE serializeAt #-} + serializeAt off arr (a, b) = do + off1 <- serializeAt off arr a + serializeAt off1 arr b + + {-# INLINE deserializeAt #-} + deserializeAt off arr end = do + (off1, a) <- deserializeAt off arr end + (off2, b) <- deserializeAt off1 arr end + pure (off2, (a, b)) diff --git a/src/Streamly/Internal/Data/Stream.hs b/src/Streamly/Internal/Data/Stream.hs --- a/src/Streamly/Internal/Data/Stream.hs +++ b/src/Streamly/Internal/Data/Stream.hs @@ -1,14 +1,41 @@ -- | -- Module : Streamly.Internal.Data.Stream --- Copyright : (c) 2019 Composewell Technologies +-- Copyright : (c) 2018 Composewell Technologies -- License : BSD-3-Clause -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC -- +-- Direct style re-implementation of CPS stream in +-- "Streamly.Internal.Data.StreamK". GHC is able to INLINE and fuse direct +-- style better, providing better performance than CPS implementation. +-- +-- @ +-- import qualified Streamly.Internal.Data.Stream as Stream +-- @ + module Streamly.Internal.Data.Stream - ( module Streamly.Internal.Data.Stream.StreamD + ( + module Streamly.Internal.Data.Stream.Type + , module Streamly.Internal.Data.Stream.Generate + , module Streamly.Internal.Data.Stream.Eliminate + , module Streamly.Internal.Data.Stream.Exception + , module Streamly.Internal.Data.Stream.Lift + , module Streamly.Internal.Data.Stream.Transformer + , module Streamly.Internal.Data.Stream.Nesting + , module Streamly.Internal.Data.Stream.Transform + , module Streamly.Internal.Data.Stream.Top + , module Streamly.Internal.Data.Stream.Container ) where -import Streamly.Internal.Data.Stream.StreamD +import Streamly.Internal.Data.Stream.Type +import Streamly.Internal.Data.Stream.Generate +import Streamly.Internal.Data.Stream.Eliminate +import Streamly.Internal.Data.Stream.Exception +import Streamly.Internal.Data.Stream.Lift +import Streamly.Internal.Data.Stream.Transformer +import Streamly.Internal.Data.Stream.Nesting +import Streamly.Internal.Data.Stream.Transform +import Streamly.Internal.Data.Stream.Top +import Streamly.Internal.Data.Stream.Container diff --git a/src/Streamly/Internal/Data/Stream/Bottom.hs b/src/Streamly/Internal/Data/Stream/Bottom.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Bottom.hs +++ /dev/null @@ -1,670 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Bottom --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Bottom level Stream module that can be used by all other upper level --- Stream modules. - -module Streamly.Internal.Data.Stream.Bottom - ( - -- * Generation - fromPure - , fromEffect - , fromList - , timesWith - , absTimesWith - , relTimesWith - - -- * Folds - , fold - , foldBreak - , foldBreak2 - , foldEither - , foldEither2 - , foldConcat - - -- * Builders - , foldAdd - , foldAddLazy - - -- * Scans - , smapM - -- $smapM_Notes - , postscan - , catMaybes - , scanMaybe - - , take - , takeWhile - , takeEndBy - , drop - , findIndices - - -- * Merge - , intersperseM - - -- * Fold and Unfold - , reverse - , reverse' - - -- * Expand - , concatEffect - , concatEffect2 - , concatMapM - , concatMap - - -- * Reduce - , foldManyPost - - -- * Zipping - , zipWithM - , zipWith - ) -where - -#include "inline.hs" - -import Control.Monad.IO.Class (MonadIO(..)) -import GHC.Types (SPEC(..)) -import Streamly.Internal.Data.Fold.Type (Fold (..)) -import Streamly.Internal.Data.Time.Units (AbsTime, RelTime64, addToAbsTime64) -import Streamly.Internal.Data.Unboxed (Unbox) -import Streamly.Internal.Data.Producer.Type (Producer(..)) -import Streamly.Internal.System.IO (defaultChunkSize) -import Streamly.Internal.Data.SVar.Type (defState) - -import qualified Streamly.Internal.Data.Array.Type as A -import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Stream.StreamK as K -import qualified Streamly.Internal.Data.Stream.StreamD as D - -import Prelude hiding (take, takeWhile, drop, reverse, concatMap, map, zipWith) - -import Streamly.Internal.Data.Stream.Type - --- --- $setup --- >>> :m --- >>> import Control.Monad (join, (>=>), (<=<)) --- >>> import Data.Function (fix, (&)) --- >>> import Data.Functor.Identity (Identity) --- >>> import Data.Maybe (fromJust, isJust) --- >>> import Prelude hiding (take, takeWhile, drop, reverse) --- >>> import Streamly.Data.Array (Array) --- >>> import Streamly.Data.Fold (Fold) --- >>> import Streamly.Data.Stream (Stream) --- >>> import System.IO.Unsafe (unsafePerformIO) --- >>> import qualified Streamly.Data.Array as Array --- >>> import qualified Streamly.Data.MutArray as MArray --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Parser as Parser --- >>> import qualified Streamly.Data.Unfold as Unfold --- >>> import qualified Streamly.Internal.Data.Fold as Fold (toStream) --- >>> import Streamly.Internal.Data.Stream as Stream - ------------------------------------------------------------------------------- --- Generation - Time related ------------------------------------------------------------------------------- - --- | @timesWith g@ returns a stream of time value tuples. The first component --- of the tuple is an absolute time reference (epoch) denoting the start of the --- stream and the second component is a time relative to the reference. --- --- The argument @g@ specifies the granularity of the relative time in seconds. --- A lower granularity clock gives higher precision but is more expensive in --- terms of CPU usage. Any granularity lower than 1 ms is treated as 1 ms. --- --- >>> import Control.Concurrent (threadDelay) --- >>> f = Fold.drainMapM (\x -> print x >> threadDelay 1000000) --- >>> Stream.fold f $ Stream.take 3 $ Stream.timesWith 0.01 --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE timesWith #-} -timesWith :: MonadIO m => Double -> Stream m (AbsTime, RelTime64) -timesWith g = fromStreamD $ D.timesWith g - --- | @absTimesWith g@ returns a stream of absolute timestamps using a clock of --- granularity @g@ specified in seconds. A low granularity clock is more --- expensive in terms of CPU usage. Any granularity lower than 1 ms is treated --- as 1 ms. --- --- >>> f = Fold.drainMapM print --- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.absTimesWith 0.01 --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE absTimesWith #-} -absTimesWith :: MonadIO m => Double -> Stream m AbsTime -absTimesWith = fmap (uncurry addToAbsTime64) . timesWith - --- | @relTimesWith g@ returns a stream of relative time values starting from 0, --- using a clock of granularity @g@ specified in seconds. A low granularity --- clock is more expensive in terms of CPU usage. Any granularity lower than 1 --- ms is treated as 1 ms. --- --- >>> f = Fold.drainMapM print --- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.relTimesWith 0.01 --- RelTime64 (NanoSecond64 ...) --- RelTime64 (NanoSecond64 ...) --- RelTime64 (NanoSecond64 ...) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE relTimesWith #-} -relTimesWith :: MonadIO m => Double -> Stream m RelTime64 -relTimesWith = fmap snd . timesWith - ------------------------------------------------------------------------------- --- Elimination - Running a Fold ------------------------------------------------------------------------------- - --- | Append a stream to a fold lazily to build an accumulator incrementally. --- --- Example, to continue folding a list of streams on the same sum fold: --- --- >>> streams = [Stream.fromList [1..5], Stream.fromList [6..10]] --- >>> f = Prelude.foldl Stream.foldAddLazy Fold.sum streams --- >>> Stream.fold f Stream.nil --- 55 --- -{-# INLINE foldAddLazy #-} -foldAddLazy :: Monad m => Fold m a b -> Stream m a -> Fold m a b -foldAddLazy f s = D.foldAddLazy f $ toStreamD s - --- >>> foldAdd f = Stream.foldAddLazy f >=> Fold.reduce - --- | --- >>> foldAdd = flip Fold.addStream --- -foldAdd :: Monad m => Fold m a b -> Stream m a -> m (Fold m a b) -foldAdd f = fold (Fold.duplicate f) - --- >>> fold f = Fold.extractM . Stream.foldAddLazy f --- >>> fold f = Stream.fold Fold.one . Stream.foldManyPost f --- >>> fold f = Fold.extractM <=< Stream.foldAdd f - --- | Fold a stream using the supplied left 'Fold' and reducing the resulting --- expression strictly at each step. The behavior is similar to 'foldl''. A --- 'Fold' can terminate early without consuming the full stream. See the --- documentation of individual 'Fold's for termination behavior. --- --- Definitions: --- --- >>> fold f = fmap fst . Stream.foldBreak f --- >>> fold f = Stream.parse (Parser.fromFold f) --- --- Example: --- --- >>> Stream.fold Fold.sum (Stream.enumerateFromTo 1 100) --- 5050 --- -{-# INLINE fold #-} -fold :: Monad m => Fold m a b -> Stream m a -> m b -fold fl strm = D.fold fl $ D.fromStreamK $ toStreamK strm - --- Alternative name foldSome, but may be confused vs foldMany. - --- | Like 'fold' but also returns the remaining stream. The resulting stream --- would be 'Stream.nil' if the stream finished before the fold. --- --- /CPS/ --- -{-# INLINE foldBreak #-} -foldBreak :: Monad m => Fold m a b -> Stream m a -> m (b, Stream m a) -foldBreak fl strm = fmap f $ K.foldBreak fl (toStreamK strm) - - where - - f (b, str) = (b, fromStreamK str) - --- XXX The quadratic slowdown in recursive use is because recursive function --- cannot be inlined and StreamD/StreamK conversions pile up and cannot be --- eliminated by rewrite rules. - --- | Like 'foldBreak' but fuses. --- --- /Note:/ Unlike 'foldBreak', recursive application on the resulting stream --- would lead to quadratic slowdown. If you need recursion with fusion (within --- one iteration of recursion) use StreamD.foldBreak directly. --- --- /Internal/ -{-# INLINE foldBreak2 #-} -foldBreak2 :: Monad m => Fold m a b -> Stream m a -> m (b, Stream m a) -foldBreak2 fl strm = fmap f $ D.foldBreak fl $ toStreamD strm - - where - - f (b, str) = (b, fromStreamD str) - --- | Fold resulting in either breaking the stream or continuation of the fold. --- Instead of supplying the input stream in one go we can run the fold multiple --- times, each time supplying the next segment of the input stream. If the fold --- has not yet finished it returns a fold that can be run again otherwise it --- returns the fold result and the residual stream. --- --- /Internal/ -{-# INLINE foldEither #-} -foldEither :: Monad m => - Fold m a b -> Stream m a -> m (Either (Fold m a b) (b, Stream m a)) -foldEither fl strm = fmap (fmap f) $ K.foldEither fl $ toStreamK strm - - where - - f (b, str) = (b, fromStreamK str) - --- | Like 'foldEither' but fuses. However, recursive application on resulting --- stream would lead to quadratic slowdown. --- --- /Internal/ -{-# INLINE foldEither2 #-} -foldEither2 :: Monad m => - Fold m a b -> Stream m a -> m (Either (Fold m a b) (b, Stream m a)) -foldEither2 fl strm = fmap (fmap f) $ D.foldEither fl $ toStreamD strm - - where - - f (b, str) = (b, fromStreamD str) - --- XXX Array folds can be implemented using this. --- foldContainers? Specialized to foldArrays. - --- | Generate streams from individual elements of a stream and fold the --- concatenation of those streams using the supplied fold. Return the result of --- the fold and residual stream. --- --- For example, this can be used to efficiently fold an Array Word8 stream --- using Word8 folds. --- --- The outer stream forces CPS to allow scalable appends and the inner stream --- forces direct style for stream fusion. --- --- /Internal/ -{-# INLINE foldConcat #-} -foldConcat :: Monad m => - Producer m a b -> Fold m b c -> Stream m a -> m (c, Stream m a) -foldConcat - (Producer pstep pinject pextract) - (Fold fstep begin done) - stream = do - - res <- begin - case res of - Fold.Partial fs -> go fs streamK - Fold.Done fb -> return (fb, fromStreamK streamK) - - where - - streamK = toStreamK stream - - go !acc m1 = do - let stop = do - r <- done acc - return (r, fromStreamK K.nil) - single a = do - st <- pinject a - res <- go1 SPEC acc st - case res of - Left fs -> do - r <- done fs - return (r, fromStreamK K.nil) - Right (b, s) -> do - x <- pextract s - return (b, fromStreamK (K.fromPure x)) - yieldk a r = do - st <- pinject a - res <- go1 SPEC acc st - case res of - Left fs -> go fs r - Right (b, s) -> do - x <- pextract s - return (b, fromStreamK (x `K.cons` r)) - in K.foldStream defState yieldk single stop m1 - - {-# INLINE go1 #-} - go1 !_ !fs st = do - r <- pstep st - case r of - D.Yield x s -> do - res <- fstep fs x - case res of - Fold.Done b -> return $ Right (b, s) - Fold.Partial fs1 -> go1 SPEC fs1 s - D.Skip s -> go1 SPEC fs s - D.Stop -> return $ Left fs - ------------------------------------------------------------------------------- --- Transformation ------------------------------------------------------------------------------- - -{- --- | --- >>> map = fmap --- --- Same as 'fmap'. --- --- >>> Stream.fold Fold.toList $ fmap (+1) $ Stream.fromList [1,2,3] --- [2,3,4] --- -{-# INLINE map #-} -map :: Monad m => (a -> b) -> Stream m a -> Stream m b -map f = fromStreamD . D.map f . toStreamD --} - --- | Postscan a stream using the given monadic fold. --- --- The following example extracts the input stream up to a point where the --- running average of elements is no more than 10: --- --- >>> import Data.Maybe (fromJust) --- >>> let avg = Fold.teeWith (/) Fold.sum (fmap fromIntegral Fold.length) --- >>> s = Stream.enumerateFromTo 1.0 100.0 --- >>> :{ --- Stream.fold Fold.toList --- $ fmap (fromJust . fst) --- $ Stream.takeWhile (\(_,x) -> x <= 10) --- $ Stream.postscan (Fold.tee Fold.latest avg) s --- :} --- [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0] --- -{-# INLINE postscan #-} -postscan :: Monad m => Fold m a b -> Stream m a -> Stream m b -postscan fld = fromStreamD . D.postscan fld . toStreamD - --- $smapM_Notes --- --- The stateful step function can be simplified to @(s -> a -> m b)@ to provide --- a read-only environment. However, that would just be 'mapM'. --- --- The initial action could be @m (s, Maybe b)@, and we can also add a final --- action @s -> m (Maybe b)@. This can be used to get pre/post scan like --- functionality and also to flush the state in the end like scanlMAfter'. --- We can also use it along with a fusible version of bracket to get --- scanlMAfter' like functionality. See issue #677. --- --- This can be further generalized to a type similar to Fold/Parser, giving it --- filtering and parsing capability as well (this is in fact equivalent to --- parseMany): --- --- smapM :: (s -> a -> m (Step s b)) -> m s -> Stream m a -> Stream m b --- - --- | A stateful 'mapM', equivalent to a left scan, more like mapAccumL. --- Hopefully, this is a better alternative to @scan@. Separation of state from --- the output makes it easier to think in terms of a shared state, and also --- makes it easier to keep the state fully strict and the output lazy. --- --- See also: 'postscan' --- --- /Pre-release/ --- -{-# INLINE smapM #-} -smapM :: Monad m => - (s -> a -> m (s, b)) - -> m s - -> Stream m a - -> Stream m b -smapM step initial stream = - -- XXX implement this directly instead of using postscan - let f = Fold.foldlM' - (\(s, _) a -> step s a) - (fmap (,undefined) initial) - in fmap snd $ postscan f stream - --- | In a stream of 'Maybe's, discard 'Nothing's and unwrap 'Just's. --- --- >>> catMaybes = Stream.mapMaybe id --- >>> catMaybes = fmap fromJust . Stream.filter isJust --- --- /Pre-release/ --- -{-# INLINE catMaybes #-} -catMaybes :: Monad m => Stream m (Maybe a) -> Stream m a --- catMaybes = fmap fromJust . filter isJust -catMaybes = fromStreamD . D.catMaybes . toStreamD - --- | Use a filtering fold on a stream. --- --- >>> scanMaybe f = Stream.catMaybes . Stream.postscan f --- -{-# INLINE scanMaybe #-} -scanMaybe :: Monad m => Fold m a (Maybe b) -> Stream m a -> Stream m b -scanMaybe p = catMaybes . postscan p - ------------------------------------------------------------------------------- --- Transformation - Trimming ------------------------------------------------------------------------------- - --- | Take first 'n' elements from the stream and discard the rest. --- -{-# INLINE take #-} -take :: Monad m => Int -> Stream m a -> Stream m a --- take n = scanMaybe (Fold.taking n) -take n m = fromStreamD $ D.take n $ toStreamD m - --- | End the stream as soon as the predicate fails on an element. --- -{-# INLINE takeWhile #-} -takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a --- takeWhile p = scanMaybe (Fold.takingEndBy_ (not . p)) -takeWhile p m = fromStreamD $ D.takeWhile p $ toStreamD m - -{-# INLINE takeEndBy #-} -takeEndBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m a --- takeEndBy p = scanMaybe (Fold.takingEndBy p) -takeEndBy p m = fromStreamD $ D.takeEndBy p $ toStreamD m - --- | Discard first 'n' elements from the stream and take the rest. --- -{-# INLINE drop #-} -drop :: Monad m => Int -> Stream m a -> Stream m a --- drop n = scanMaybe (Fold.dropping n) -drop n m = fromStreamD $ D.drop n $ toStreamD m - ------------------------------------------------------------------------------- --- Searching ------------------------------------------------------------------------------- - --- | Find all the indices where the element in the stream satisfies the given --- predicate. --- --- >>> findIndices p = Stream.scanMaybe (Fold.findIndices p) --- -{-# INLINE findIndices #-} -findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int --- findIndices p = scanMaybe (Fold.findIndices p) -findIndices p m = fromStreamD $ D.findIndices p (toStreamD m) - ------------------------------------------------------------------------------- --- Transformation by Inserting ------------------------------------------------------------------------------- - --- intersperseM = intersperseMWith 1 - --- | Insert an effect and its output before consuming an element of a stream --- except the first one. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.trace putChar $ Stream.intersperseM (putChar '.' >> return ',') input --- h.,e.,l.,l.,o"h,e,l,l,o" --- --- Be careful about the order of effects. In the above example we used trace --- after the intersperse, if we use it before the intersperse the output would --- be he.l.l.o."h,e,l,l,o". --- --- >>> Stream.fold Fold.toList $ Stream.intersperseM (putChar '.' >> return ',') $ Stream.trace putChar input --- he.l.l.o."h,e,l,l,o" --- -{-# INLINE intersperseM #-} -intersperseM :: Monad m => m a -> Stream m a -> Stream m a -intersperseM m = fromStreamD . D.intersperseM m . toStreamD - ------------------------------------------------------------------------------- --- Transformation by Reordering ------------------------------------------------------------------------------- - --- XXX Use a compact region list to temporarily store the list, in both reverse --- as well as in reverse'. --- --- /Note:/ 'reverse'' is much faster than this, use that when performance --- matters. --- --- | Returns the elements of the stream in reverse order. The stream must be --- finite. Note that this necessarily buffers the entire stream in memory. --- --- >>> reverse = Stream.foldlT (flip Stream.cons) Stream.nil --- -{-# INLINE reverse #-} -reverse :: Stream m a -> Stream m a -reverse s = fromStreamK $ K.reverse $ toStreamK s - --- | Like 'reverse' but several times faster, requires a 'Storable' instance. --- --- /O(n) space/ --- --- /Pre-release/ -{-# INLINE reverse' #-} -reverse' :: (MonadIO m, Unbox a) => Stream m a -> Stream m a --- reverse' s = fromStreamD $ D.reverse' $ toStreamD s -reverse' = - fromStreamD - . A.flattenArraysRev -- unfoldMany A.readRev - . D.fromStreamK - . K.reverse - . D.toStreamK - . A.chunksOf defaultChunkSize - . toStreamD - ------------------------------------------------------------------------------- --- Combine streams and flatten ------------------------------------------------------------------------------- - --- | Map a stream producing monadic function on each element of the stream --- and then flatten the results into a single stream. Since the stream --- generation function is monadic, unlike 'concatMap', it can produce an --- effect at the beginning of each iteration of the inner loop. --- --- See 'unfoldMany' for a fusible alternative. --- -{-# INLINE concatMapM #-} -concatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b -concatMapM f m = fromStreamD $ D.concatMapM (fmap toStreamD . f) (toStreamD m) - --- | Map a stream producing function on each element of the stream and then --- flatten the results into a single stream. --- --- >>> concatMap f = Stream.concatMapM (return . f) --- >>> concatMap f = Stream.concatMapWith Stream.append f --- >>> concatMap f = Stream.concat . fmap f --- >>> concatMap f = Stream.unfoldMany (Unfold.lmap f Unfold.fromStream) --- --- See 'unfoldMany' for a fusible alternative. --- -{-# INLINE concatMap #-} -concatMap ::Monad m => (a -> Stream m b) -> Stream m a -> Stream m b -concatMap f m = fromStreamD $ D.concatMap (toStreamD . f) (toStreamD m) - --- >>> concatEffect = Stream.concat . lift -- requires (MonadTrans t) --- >>> concatEffect = join . lift -- requires (MonadTrans t, Monad (Stream m)) - --- | Given a stream value in the underlying monad, lift and join the underlying --- monad with the stream monad. --- --- >>> concatEffect = Stream.concat . Stream.fromEffect --- --- See also: 'concat', 'sequence' --- --- See 'concatEffect2' for a fusible alternative. --- --- /CPS/ --- -{-# INLINE concatEffect #-} -concatEffect :: Monad m => m (Stream m a) -> Stream m a -concatEffect generator = - fromStreamK $ K.concatEffect $ fmap toStreamK generator - -{-# INLINE concatEffect2 #-} -concatEffect2 :: Monad m => m (Stream m a) -> Stream m a --- concatEffect generator = concatMapM (\() -> generator) (fromPure ()) -concatEffect2 generator = - fromStreamD $ D.concatEffect $ fmap toStreamD generator - --- XXX Need a more intuitive name, and need to reconcile the names --- foldMany/fold/parse/parseMany/parseManyPost etc. - --- | Like 'foldMany' but evaluates the fold before the stream, and yields its --- output even if the stream is empty, therefore, always results in a non-empty --- output even on an empty stream (default result of the fold). --- --- Example, empty stream: --- --- >>> f = Fold.take 2 Fold.sum --- >>> fmany = Stream.fold Fold.toList . Stream.foldManyPost f --- >>> fmany $ Stream.fromList [] --- [0] --- --- Example, last fold empty: --- --- >>> fmany $ Stream.fromList [1..4] --- [3,7,0] --- --- Example, last fold non-empty: --- --- >>> fmany $ Stream.fromList [1..5] --- [3,7,5] --- --- Note that using a closed fold e.g. @Fold.take 0@, would result in an --- infinite stream without consuming the input. --- --- /Pre-release/ --- -{-# INLINE foldManyPost #-} -foldManyPost - :: Monad m - => Fold m a b - -> Stream m a - -> Stream m b -foldManyPost f m = fromStreamD $ D.foldManyPost f (toStreamD m) - ------------------------------------------------------------------------------- --- Zipping ------------------------------------------------------------------------------- - --- | Like 'zipWith' but using a monadic zipping function. --- -{-# INLINE zipWithM #-} -zipWithM :: Monad m => - (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c -zipWithM f m1 m2 = fromStreamK $ K.zipWithM f (toStreamK m1) (toStreamK m2) - --- | Stream @a@ is evaluated first, followed by stream @b@, the resulting --- elements @a@ and @b@ are then zipped using the supplied zip function and the --- result @c@ is yielded to the consumer. --- --- If stream @a@ or stream @b@ ends, the zipped stream ends. If stream @b@ ends --- first, the element @a@ from previous evaluation of stream @a@ is discarded. --- --- >>> s1 = Stream.fromList [1,2,3] --- >>> s2 = Stream.fromList [4,5,6] --- >>> Stream.fold Fold.toList $ Stream.zipWith (+) s1 s2 --- [5,7,9] --- -{-# INLINE zipWith #-} -zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c -zipWith f m1 m2 = fromStreamK $ K.zipWith f (toStreamK m1) (toStreamK m2) diff --git a/src/Streamly/Internal/Data/Stream/Chunked.hs b/src/Streamly/Internal/Data/Stream/Chunked.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Chunked.hs +++ /dev/null @@ -1,1215 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Chunked --- Copyright : (c) 2019 Composewell Technologies --- License : BSD3-3-Clause --- Maintainer : streamly@composewell.com --- Stability : pre-release --- Portability : GHC --- --- Combinators to efficiently manipulate streams of immutable arrays. --- -module Streamly.Internal.Data.Stream.Chunked - ( - -- * Creation - chunksOf - - -- * Flattening to elements - , concat - , concatRev - , interpose - , interposeSuffix - , intercalateSuffix - , unlines - - -- * Elimination - -- ** Element Folds - -- The byte level foldBreak can work as efficiently as the chunk level. We - -- can flatten the stream to byte stream and use that. But if we want the - -- remaining stream to be a chunk stream then this could be handy. But it - -- could also be implemented using parseBreak. - , foldBreak -- StreamK.foldBreakChunks - , foldBreakD - -- The byte level parseBreak cannot work efficiently. Because the stream - -- will have to be a StreamK for backtracking, StreamK at byte level would - -- not be efficient. - , parseBreak -- StreamK.parseBreakChunks - -- , parseBreakD - -- , foldManyChunks - -- , parseManyChunks - - -- ** Array Folds - -- XXX Use Parser.Chunked instead, need only chunkedParseBreak, - -- foldBreak can be implemented using parseBreak. Use StreamK. - , runArrayFold - , runArrayFoldBreak - -- , parseArr - , runArrayParserDBreak -- StreamK.chunkedParseBreak - , runArrayFoldMany -- StreamK.chunkedParseMany - - , toArray - - -- * Compaction - -- We can use something like foldManyChunks, parseManyChunks with a take - -- fold. - , lpackArraysChunksOf -- Fold.compactChunks - , compact -- rechunk, compactChunks - - -- * Splitting - -- We can use something like foldManyChunks, parseManyChunks with an - -- appropriate splitting fold. - , splitOn -- Stream.rechunkOn - , splitOnSuffix -- Stream.rechunkOnSuffix - ) -where - -#include "ArrayMacros.h" -#include "inline.hs" - -import Data.Bifunctor (second) -import Control.Exception (assert) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Proxy (Proxy(..)) -import Data.Word (Word8) -import Streamly.Internal.Data.Unboxed (Unbox, peekWith, sizeOf) -import Fusion.Plugin.Types (Fuse(..)) -import GHC.Exts (SpecConstrAnnotation(..)) -import GHC.Types (SPEC(..)) -import Prelude hiding (null, last, (!!), read, concat, unlines) - -import Streamly.Data.Fold (Fold) -import Streamly.Internal.Data.Array.Type (Array(..)) -import Streamly.Internal.Data.Array.Mut.Type (MutArray) -import Streamly.Internal.Data.Fold.Chunked (ChunkFold(..)) -import Streamly.Internal.Data.Parser (ParseError(..)) -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Stream.StreamK (StreamK, fromStream, toStream) -import Streamly.Internal.Data.SVar.Type (adaptState, defState) -import Streamly.Internal.Data.Array.Mut.Type - (allocBytesToElemCount) -import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) - -import qualified Streamly.Data.Fold as FL -import qualified Streamly.Internal.Data.Array as A -import qualified Streamly.Internal.Data.Array as Array -import qualified Streamly.Internal.Data.Array.Type as A -import qualified Streamly.Internal.Data.Array.Mut.Type as MA -import qualified Streamly.Internal.Data.Array.Mut.Stream as AS -import qualified Streamly.Internal.Data.Fold.Type as FL (Fold(..), Step(..)) -import qualified Streamly.Internal.Data.Parser as PR -import qualified Streamly.Internal.Data.Parser.ParserD as PRD - (Parser(..), Initial(..)) -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Stream.StreamK as K - --- XXX Since these are immutable arrays MonadIO constraint can be removed from --- most places. - -------------------------------------------------------------------------------- --- Generation -------------------------------------------------------------------------------- - --- | @chunksOf n stream@ groups the elements in the input stream into arrays of --- @n@ elements each. --- --- > chunksOf n = Stream.groupsOf n (Array.writeN n) --- --- /Pre-release/ -{-# INLINE chunksOf #-} -chunksOf :: (MonadIO m, Unbox a) - => Int -> Stream m a -> Stream m (Array a) -chunksOf = A.chunksOf - -------------------------------------------------------------------------------- --- Append -------------------------------------------------------------------------------- - --- XXX efficiently compare two streams of arrays. Two streams can have chunks --- of different sizes, we can handle that in the stream comparison abstraction. --- This could be useful e.g. to fast compare whether two files differ. - --- | Convert a stream of arrays into a stream of their elements. --- --- Same as the following: --- --- > concat = Stream.unfoldMany Array.read --- --- @since 0.7.0 -{-# INLINE concat #-} -concat :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a --- concat m = fromStreamD $ A.flattenArrays (toStreamD m) --- concat m = fromStreamD $ D.concatMap A.toStreamD (toStreamD m) -concat = D.unfoldMany A.reader - --- | Convert a stream of arrays into a stream of their elements reversing the --- contents of each array before flattening. --- --- > concatRev = Stream.unfoldMany Array.readerRev --- --- @since 0.7.0 -{-# INLINE concatRev #-} -concatRev :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a --- concatRev m = fromStreamD $ A.flattenArraysRev (toStreamD m) -concatRev = D.unfoldMany A.readerRev - -------------------------------------------------------------------------------- --- Intersperse and append -------------------------------------------------------------------------------- - --- | Flatten a stream of arrays after inserting the given element between --- arrays. --- --- /Pre-release/ -{-# INLINE interpose #-} -interpose :: (Monad m, Unbox a) => a -> Stream m (Array a) -> Stream m a -interpose x = D.interpose x A.reader - -{-# INLINE intercalateSuffix #-} -intercalateSuffix :: (Monad m, Unbox a) - => Array a -> Stream m (Array a) -> Stream m a -intercalateSuffix = D.intercalateSuffix A.reader - --- | Flatten a stream of arrays appending the given element after each --- array. --- --- @since 0.7.0 -{-# INLINE interposeSuffix #-} -interposeSuffix :: (Monad m, Unbox a) - => a -> Stream m (Array a) -> Stream m a --- interposeSuffix x = fromStreamD . A.unlines x . toStreamD -interposeSuffix x = D.interposeSuffix x A.reader - -data FlattenState s = - OuterLoop s - | InnerLoop s !MA.MutableByteArray !Int !Int - --- XXX This is a special case of interposeSuffix, can be removed. --- XXX Remove monadIO constraint -{-# INLINE_NORMAL unlines #-} -unlines :: forall m a. (MonadIO m, Unbox a) - => a -> D.Stream m (Array a) -> D.Stream m a -unlines sep (D.Stream step state) = D.Stream step' (OuterLoop state) - where - {-# INLINE_LATE step' #-} - step' gst (OuterLoop st) = do - r <- step (adaptState gst) st - return $ case r of - D.Yield Array{..} s -> - D.Skip (InnerLoop s arrContents arrStart arrEnd) - D.Skip s -> D.Skip (OuterLoop s) - D.Stop -> D.Stop - - step' _ (InnerLoop st _ p end) | p == end = - return $ D.Yield sep $ OuterLoop st - - step' _ (InnerLoop st contents p end) = do - x <- liftIO $ peekWith contents p - return $ D.Yield x (InnerLoop st contents (INDEX_NEXT(p,a)) end) - -------------------------------------------------------------------------------- --- Compact -------------------------------------------------------------------------------- - --- XXX These would not be needed once we implement compactLEFold, see --- module Streamly.Internal.Data.Array.Mut.Stream --- --- XXX Note that this thaws immutable arrays for appending, that may be --- problematic if multiple users do the same thing, however, immutable arrays --- would usually have no capacity to append, therefore, a copy will be forced --- anyway. Confirm this. We can forcefully trim the array capacity before thaw --- to ensure this. -{-# INLINE_NORMAL packArraysChunksOf #-} -packArraysChunksOf :: (MonadIO m, Unbox a) - => Int -> D.Stream m (Array a) -> D.Stream m (Array a) -packArraysChunksOf n str = - D.map A.unsafeFreeze $ AS.packArraysChunksOf n $ D.map A.unsafeThaw str - --- XXX instead of writing two different versions of this operation, we should --- write it as a pipe. --- --- XXX Confirm that immutable arrays won't be modified. -{-# INLINE_NORMAL lpackArraysChunksOf #-} -lpackArraysChunksOf :: (MonadIO m, Unbox a) - => Int -> Fold m (Array a) () -> Fold m (Array a) () -lpackArraysChunksOf n fld = - FL.lmap A.unsafeThaw $ AS.lpackArraysChunksOf n (FL.lmap A.unsafeFreeze fld) - --- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a --- maximum specified size in bytes. --- --- @since 0.7.0 -{-# INLINE compact #-} -compact :: (MonadIO m, Unbox a) - => Int -> Stream m (Array a) -> Stream m (Array a) -compact = packArraysChunksOf - -------------------------------------------------------------------------------- --- Split -------------------------------------------------------------------------------- - -data SplitState s arr - = Initial s - | Buffering s arr - | Splitting s arr - | Yielding arr (SplitState s arr) - | Finishing - --- | Split a stream of arrays on a given separator byte, dropping the separator --- and coalescing all the arrays between two separators into a single array. --- --- @since 0.7.0 -{-# INLINE_NORMAL _splitOn #-} -_splitOn - :: MonadIO m - => Word8 - -> D.Stream m (Array Word8) - -> D.Stream m (Array Word8) -_splitOn byte (D.Stream step state) = D.Stream step' (Initial state) - - where - - {-# INLINE_LATE step' #-} - step' gst (Initial st) = do - r <- step gst st - case r of - D.Yield arr s -> do - (arr1, marr2) <- A.breakOn byte arr - return $ case marr2 of - Nothing -> D.Skip (Buffering s arr1) - Just arr2 -> D.Skip (Yielding arr1 (Splitting s arr2)) - D.Skip s -> return $ D.Skip (Initial s) - D.Stop -> return D.Stop - - step' gst (Buffering st buf) = do - r <- step gst st - case r of - D.Yield arr s -> do - (arr1, marr2) <- A.breakOn byte arr - buf' <- A.splice buf arr1 - return $ case marr2 of - Nothing -> D.Skip (Buffering s buf') - Just x -> D.Skip (Yielding buf' (Splitting s x)) - D.Skip s -> return $ D.Skip (Buffering s buf) - D.Stop -> return $ - if A.byteLength buf == 0 - then D.Stop - else D.Skip (Yielding buf Finishing) - - step' _ (Splitting st buf) = do - (arr1, marr2) <- A.breakOn byte buf - return $ case marr2 of - Nothing -> D.Skip $ Buffering st arr1 - Just arr2 -> D.Skip $ Yielding arr1 (Splitting st arr2) - - step' _ (Yielding arr next) = return $ D.Yield arr next - step' _ Finishing = return D.Stop - --- XXX Remove MonadIO constraint. --- | Split a stream of arrays on a given separator byte, dropping the separator --- and coalescing all the arrays between two separators into a single array. --- --- @since 0.7.0 -{-# INLINE splitOn #-} -splitOn - :: (MonadIO m) - => Word8 - -> Stream m (Array Word8) - -> Stream m (Array Word8) -splitOn byte = D.splitInnerBy (A.breakOn byte) A.splice - -{-# INLINE splitOnSuffix #-} -splitOnSuffix - :: (MonadIO m) - => Word8 - -> Stream m (Array Word8) - -> Stream m (Array Word8) --- splitOn byte s = fromStreamD $ A.splitOn byte $ toStreamD s -splitOnSuffix byte = D.splitInnerBySuffix (A.breakOn byte) A.splice - -------------------------------------------------------------------------------- --- Elimination - Running folds -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL foldBreakD #-} -foldBreakD :: forall m a b. (MonadIO m, Unbox a) => - Fold m a b -> D.Stream m (Array a) -> m (b, D.Stream m (Array a)) -foldBreakD (FL.Fold fstep initial extract) stream@(D.Stream step state) = do - res <- initial - case res of - FL.Partial fs -> go SPEC state fs - FL.Done fb -> return $! (fb, stream) - - where - - {-# INLINE go #-} - go !_ st !fs = do - r <- step defState st - case r of - D.Yield (Array contents start end) s -> - let fp = Tuple' end contents - in goArray SPEC s fp start fs - D.Skip s -> go SPEC s fs - D.Stop -> do - b <- extract fs - return (b, D.nil) - - goArray !_ s (Tuple' end _) !cur !fs - | cur == end = do - go SPEC s fs - goArray !_ st fp@(Tuple' end contents) !cur !fs = do - x <- liftIO $ peekWith contents cur - res <- fstep fs x - let next = INDEX_NEXT(cur,a) - case res of - FL.Done b -> do - let arr = Array contents next end - return $! (b, D.cons arr (D.Stream step st)) - FL.Partial fs1 -> goArray SPEC st fp next fs1 - -{-# INLINE_NORMAL foldBreakK #-} -foldBreakK :: forall m a b. (MonadIO m, Unbox a) => - Fold m a b -> K.StreamK m (Array a) -> m (b, K.StreamK m (Array a)) -foldBreakK (FL.Fold fstep initial extract) stream = do - res <- initial - case res of - FL.Partial fs -> go fs stream - FL.Done fb -> return (fb, stream) - - where - - {-# INLINE go #-} - go !fs st = do - let stop = (, K.nil) <$> extract fs - single a = yieldk a K.nil - yieldk (Array contents start end) r = - let fp = Tuple' end contents - in goArray fs r fp start - in K.foldStream defState yieldk single stop st - - goArray !fs st (Tuple' end _) !cur - | cur == end = do - go fs st - goArray !fs st fp@(Tuple' end contents) !cur = do - x <- liftIO $ peekWith contents cur - res <- fstep fs x - let next = INDEX_NEXT(cur,a) - case res of - FL.Done b -> do - let arr = Array contents next end - return $! (b, K.cons arr st) - FL.Partial fs1 -> goArray fs1 st fp next - --- | Fold an array stream using the supplied 'Fold'. Returns the fold result --- and the unconsumed stream. --- --- > foldBreak f = runArrayFoldBreak (ChunkFold.fromFold f) --- --- /Internal/ --- -{-# INLINE_NORMAL foldBreak #-} -foldBreak :: - (MonadIO m, Unbox a) - => Fold m a b - -> StreamK m (A.Array a) - -> m (b, StreamK m (A.Array a)) --- foldBreak f s = fmap fromStreamD <$> foldBreakD f (toStreamD s) -foldBreak = foldBreakK --- If foldBreak performs better than runArrayFoldBreak we can use a rewrite --- rule to rewrite runArrayFoldBreak to fold. --- foldBreak f = runArrayFoldBreak (ChunkFold.fromFold f) - -------------------------------------------------------------------------------- --- Fold to a single Array -------------------------------------------------------------------------------- - --- When we have to take an array partially, take the last part of the array. -{-# INLINE takeArrayListRev #-} -takeArrayListRev :: forall a. Unbox a => Int -> [Array a] -> [Array a] -takeArrayListRev = go - - where - - go _ [] = [] - go n _ | n <= 0 = [] - go n (x:xs) = - let len = Array.length x - in if n > len - then x : go (n - len) xs - else if n == len - then [x] - else let !(Array contents _ end) = x - !start = end - (n * SIZE_OF(a)) - in [Array contents start end] - --- When we have to take an array partially, take the last part of the array in --- the first split. -{-# INLINE splitAtArrayListRev #-} -splitAtArrayListRev :: - forall a. Unbox a => Int -> [Array a] -> ([Array a],[Array a]) -splitAtArrayListRev n ls - | n <= 0 = ([], ls) - | otherwise = go n ls - where - go :: Int -> [Array a] -> ([Array a], [Array a]) - go _ [] = ([], []) - go m (x:xs) = - let len = Array.length x - (xs', xs'') = go (m - len) xs - in if m > len - then (x:xs', xs'') - else if m == len - then ([x],xs) - else let !(Array contents start end) = x - end1 = end - (m * SIZE_OF(a)) - arr2 = Array contents start end1 - arr1 = Array contents end1 end - in ([arr1], arr2:xs) - -------------------------------------------------------------------------------- --- Fold to a single Array -------------------------------------------------------------------------------- - --- XXX Both of these implementations of splicing seem to perform equally well. --- We need to perform benchmarks over a range of sizes though. - --- CAUTION! length must more than equal to lengths of all the arrays in the --- stream. -{-# INLINE spliceArraysLenUnsafe #-} -spliceArraysLenUnsafe :: (MonadIO m, Unbox a) - => Int -> Stream m (MutArray a) -> m (MutArray a) -spliceArraysLenUnsafe len buffered = do - arr <- liftIO $ MA.newPinned len - D.foldlM' MA.spliceUnsafe (return arr) buffered - -{-# INLINE _spliceArrays #-} -_spliceArrays :: (MonadIO m, Unbox a) - => Stream m (Array a) -> m (Array a) -_spliceArrays s = do - buffered <- D.foldr K.cons K.nil s - len <- K.fold FL.sum (fmap Array.length buffered) - arr <- liftIO $ MA.newPinned len - final <- D.foldlM' writeArr (return arr) (toStream buffered) - return $ A.unsafeFreeze final - - where - - writeArr dst arr = MA.spliceUnsafe dst (A.unsafeThaw arr) - -{-# INLINE _spliceArraysBuffered #-} -_spliceArraysBuffered :: (MonadIO m, Unbox a) - => Stream m (Array a) -> m (Array a) -_spliceArraysBuffered s = do - buffered <- D.foldr K.cons K.nil s - len <- K.fold FL.sum (fmap Array.length buffered) - A.unsafeFreeze <$> - spliceArraysLenUnsafe len (fmap A.unsafeThaw (toStream buffered)) - -{-# INLINE spliceArraysRealloced #-} -spliceArraysRealloced :: forall m a. (MonadIO m, Unbox a) - => Stream m (Array a) -> m (Array a) -spliceArraysRealloced s = do - let n = allocBytesToElemCount (undefined :: a) (4 * 1024) - idst = liftIO $ MA.newPinned n - - arr <- D.foldlM' MA.spliceExp idst (fmap A.unsafeThaw s) - liftIO $ A.unsafeFreeze <$> MA.rightSize arr - --- XXX This should just be "fold A.write" --- --- | Given a stream of arrays, splice them all together to generate a single --- array. The stream must be /finite/. --- --- @since 0.7.0 -{-# INLINE toArray #-} -toArray :: (MonadIO m, Unbox a) => Stream m (Array a) -> m (Array a) -toArray = spliceArraysRealloced --- spliceArrays = _spliceArraysBuffered - --- exponentially increasing sizes of the chunks upto the max limit. --- XXX this will be easier to implement with parsers/terminating folds --- With this we should be able to reduce the number of chunks/allocations. --- The reallocation/copy based toArray can also be implemented using this. --- -{- -{-# INLINE toArraysInRange #-} -toArraysInRange :: (MonadIO m, Unbox a) - => Int -> Int -> Fold m (Array a) b -> Fold m a b -toArraysInRange low high (Fold step initial extract) = --} - -{- --- | Fold the input to a pure buffered stream (List) of arrays. -{-# INLINE _toArraysOf #-} -_toArraysOf :: (MonadIO m, Unbox a) - => Int -> Fold m a (Stream Identity (Array a)) -_toArraysOf n = FL.groupsOf n (A.writeNF n) FL.toStream --} - -------------------------------------------------------------------------------- --- Elimination - running element parsers -------------------------------------------------------------------------------- - --- GHC parser does not accept {-# ANN type [] NoSpecConstr #-}, so we need --- to make a newtype. -{-# ANN type List NoSpecConstr #-} -newtype List a = List {getList :: [a]} - -{- --- This can be generalized to any type provided it can be unfolded to a stream --- and it can be combined using a semigroup operation. --- --- XXX This should be written using CPS (as parseK) if we want it to scale wrt --- to the number of times it can be called on the same stream. -{-# INLINE_NORMAL parseBreakD #-} -parseBreakD :: - forall m a b. (MonadIO m, MonadThrow m, Unbox a) - => PRD.Parser a m b - -> D.Stream m (Array.Array a) - -> m (b, D.Stream m (Array.Array a)) -parseBreakD - (PRD.Parser pstep initial extract) stream@(D.Stream step state) = do - - res <- initial - case res of - PRD.IPartial s -> go SPEC state (List []) s - PRD.IDone b -> return (b, stream) - PRD.IError err -> throwM $ ParseError err - - where - - -- "backBuf" contains last few items in the stream that we may have to - -- backtrack to. - -- - -- XXX currently we are using a dumb list based approach for backtracking - -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. - -- That will allow us more efficient random back and forth movement. - go !_ st backBuf !pst = do - r <- step defState st - case r of - D.Yield (Array contents start end) s -> - gobuf SPEC s backBuf - (Tuple' end contents) start pst - D.Skip s -> go SPEC s backBuf pst - D.Stop -> do - b <- extract pst - return (b, D.nil) - - -- Use strictness on "cur" to keep it unboxed - gobuf !_ s backBuf (Tuple' end _) !cur !pst - | cur == end = do - go SPEC s backBuf pst - gobuf !_ s backBuf fp@(Tuple' end contents) !cur !pst = do - x <- liftIO $ peekWith contents cur - pRes <- pstep pst x - let next = INDEX_NEXT(cur,a) - case pRes of - PR.Partial 0 pst1 -> - gobuf SPEC s (List []) fp next pst1 - PR.Partial n pst1 -> do - assert (n <= Prelude.length (x:getList backBuf)) (return ()) - let src0 = Prelude.take n (x:getList backBuf) - arr0 = A.fromListN n (Prelude.reverse src0) - arr1 = Array contents next end - src = arr0 <> arr1 - let !(Array cont1 start end1) = src - fp1 = Tuple' end1 cont1 - gobuf SPEC s (List []) fp1 start pst1 - PR.Continue 0 pst1 -> - gobuf SPEC s (List (x:getList backBuf)) fp next pst1 - PR.Continue n pst1 -> do - assert (n <= Prelude.length (x:getList backBuf)) (return ()) - let (src0, buf1) = splitAt n (x:getList backBuf) - arr0 = A.fromListN n (Prelude.reverse src0) - arr1 = Array contents next end - src = arr0 <> arr1 - let !(Array cont1 start end1) = src - fp1 = Tuple' end1 cont1 - gobuf SPEC s (List buf1) fp1 start pst1 - PR.Done 0 b -> do - let arr = Array contents next end - return (b, D.cons arr (D.Stream step s)) - PR.Done n b -> do - assert (n <= Prelude.length (x:getList backBuf)) (return ()) - let src0 = Prelude.take n (x:getList backBuf) - -- XXX create the array in reverse instead - arr0 = A.fromListN n (Prelude.reverse src0) - arr1 = Array contents next end - -- XXX Use StreamK to avoid adding arbitrary layers of - -- constructors every time. - str = D.cons arr0 (D.cons arr1 (D.Stream step s)) - return (b, str) - PR.Error err -> throwM $ ParseError err --} - -{-# INLINE_NORMAL parseBreakK #-} -parseBreakK :: - forall m a b. (MonadIO m, Unbox a) - => PRD.Parser a m b - -> K.StreamK m (Array.Array a) - -> m (Either ParseError b, K.StreamK m (Array.Array a)) -parseBreakK (PRD.Parser pstep initial extract) stream = do - res <- initial - case res of - PRD.IPartial s -> go s stream [] - PRD.IDone b -> return (Right b, stream) - PRD.IError err -> return (Left (ParseError err), stream) - - where - - -- "backBuf" contains last few items in the stream that we may have to - -- backtrack to. - -- - -- XXX currently we are using a dumb list based approach for backtracking - -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. - -- That will allow us more efficient random back and forth movement. - go !pst st backBuf = do - let stop = goStop pst backBuf -- (, K.nil) <$> extract pst - single a = yieldk a K.nil - yieldk arr r = goArray pst backBuf r arr - in K.foldStream defState yieldk single stop st - - -- Use strictness on "cur" to keep it unboxed - goArray !pst backBuf st (Array _ cur end) | cur == end = go pst st backBuf - goArray !pst backBuf st (Array contents cur end) = do - x <- liftIO $ peekWith contents cur - pRes <- pstep pst x - let next = INDEX_NEXT(cur,a) - case pRes of - PR.Partial 0 s -> - goArray s [] st (Array contents next end) - PR.Partial n s -> do - assert (n <= Prelude.length (x:backBuf)) (return ()) - let src0 = Prelude.take n (x:backBuf) - arr0 = A.fromListN n (Prelude.reverse src0) - arr1 = Array contents next end - src = arr0 <> arr1 - goArray s [] st src - PR.Continue 0 s -> - goArray s (x:backBuf) st (Array contents next end) - PR.Continue n s -> do - assert (n <= Prelude.length (x:backBuf)) (return ()) - let (src0, buf1) = splitAt n (x:backBuf) - arr0 = A.fromListN n (Prelude.reverse src0) - arr1 = Array contents next end - src = arr0 <> arr1 - goArray s buf1 st src - PR.Done 0 b -> do - let arr = Array contents next end - return (Right b, K.cons arr st) - PR.Done n b -> do - assert (n <= Prelude.length (x:backBuf)) (return ()) - let src0 = Prelude.take n (x:backBuf) - -- XXX Use fromListRevN once implemented - -- arr0 = A.fromListRevN n src0 - arr0 = A.fromListN n (Prelude.reverse src0) - arr1 = Array contents next end - str = K.cons arr0 (K.cons arr1 st) - return (Right b, str) - PR.Error err -> do - let str = K.cons (Array contents cur end) stream - return (Left (ParseError err), str) - - -- This is a simplified goArray - goExtract !pst backBuf (Array _ cur end) - | cur == end = goStop pst backBuf - goExtract !pst backBuf (Array contents cur end) = do - x <- liftIO $ peekWith contents cur - pRes <- pstep pst x - let next = INDEX_NEXT(cur,a) - case pRes of - PR.Partial 0 s -> - goExtract s [] (Array contents next end) - PR.Partial n s -> do - assert (n <= Prelude.length (x:backBuf)) (return ()) - let src0 = Prelude.take n (x:backBuf) - arr0 = A.fromListN n (Prelude.reverse src0) - arr1 = Array contents next end - src = arr0 <> arr1 - goExtract s [] src - PR.Continue 0 s -> - goExtract s backBuf (Array contents next end) - PR.Continue n s -> do - assert (n <= Prelude.length (x:backBuf)) (return ()) - let (src0, buf1) = splitAt n (x:backBuf) - arr0 = A.fromListN n (Prelude.reverse src0) - arr1 = Array contents next end - src = arr0 <> arr1 - goExtract s buf1 src - PR.Done 0 b -> do - let arr = Array contents next end - return (Right b, K.fromPure arr) - PR.Done n b -> do - assert (n <= Prelude.length backBuf) (return ()) - let src0 = Prelude.take n backBuf - -- XXX Use fromListRevN once implemented - -- arr0 = A.fromListRevN n src0 - arr0 = A.fromListN n (Prelude.reverse src0) - arr1 = Array contents next end - str = K.cons arr0 (K.fromPure arr1) - return (Right b, str) - PR.Error err -> do - let str = K.fromPure (Array contents cur end) - return (Left (ParseError err), str) - - -- This is a simplified goExtract - {-# INLINE goStop #-} - goStop !pst backBuf = do - pRes <- extract pst - case pRes of - PR.Partial _ _ -> error "Bug: parseBreak: Partial in extract" - PR.Continue 0 s -> - goStop s backBuf - PR.Continue n s -> do - assert (n <= Prelude.length backBuf) (return ()) - let (src0, buf1) = splitAt n backBuf - arr = A.fromListN n (Prelude.reverse src0) - goExtract s buf1 arr - PR.Done 0 b -> - return (Right b, K.nil) - PR.Done n b -> do - assert (n <= Prelude.length backBuf) (return ()) - let src0 = Prelude.take n backBuf - -- XXX Use fromListRevN once implemented - -- arr0 = A.fromListRevN n src0 - arr0 = A.fromListN n (Prelude.reverse src0) - return (Right b, K.fromPure arr0) - PR.Error err -> - return (Left (ParseError err), K.nil) - --- | Parse an array stream using the supplied 'Parser'. Returns the parse --- result and the unconsumed stream. Throws 'ParseError' if the parse fails. --- --- /Internal/ --- -{-# INLINE_NORMAL parseBreak #-} -parseBreak :: - (MonadIO m, Unbox a) - => PR.Parser a m b - -> StreamK m (A.Array a) - -> m (Either ParseError b, StreamK m (A.Array a)) -{- -parseBreak p s = - fmap fromStreamD <$> parseBreakD (PRD.fromParserK p) (toStreamD s) --} -parseBreak = parseBreakK - -------------------------------------------------------------------------------- --- Elimination - Running Array Folds and parsers -------------------------------------------------------------------------------- - --- | Note that this is not the same as using a @Parser (Array a) m b@ with the --- regular "Streamly.Internal.Data.IsStream.parse" function. The regular parse --- would consume the input arrays as single unit. This parser parses in the way --- as described in the ChunkFold module. The input arrays are treated as @n@ --- element units and can be consumed partially. The remaining elements are --- inserted in the source stream as an array. --- -{-# INLINE_NORMAL runArrayParserDBreak #-} -runArrayParserDBreak :: - forall m a b. (MonadIO m, Unbox a) - => PRD.Parser (Array a) m b - -> D.Stream m (Array.Array a) - -> m (Either ParseError b, D.Stream m (Array.Array a)) -runArrayParserDBreak - (PRD.Parser pstep initial extract) - stream@(D.Stream step state) = do - - res <- initial - case res of - PRD.IPartial s -> go SPEC state (List []) s - PRD.IDone b -> return (Right b, stream) - PRD.IError err -> return (Left (ParseError err), stream) - - where - - -- "backBuf" contains last few items in the stream that we may have to - -- backtrack to. - -- - -- XXX currently we are using a dumb list based approach for backtracking - -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. - -- That will allow us more efficient random back and forth movement. - go _ st backBuf !pst = do - r <- step defState st - case r of - D.Yield x s -> gobuf SPEC [x] s backBuf pst - D.Skip s -> go SPEC s backBuf pst - D.Stop -> goStop backBuf pst - - gobuf !_ [] s backBuf !pst = go SPEC s backBuf pst - gobuf !_ (x:xs) s backBuf !pst = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - gobuf SPEC xs s (List []) pst1 - PR.Partial n pst1 -> do - assert - (n <= sum (map Array.length (x:getList backBuf))) - (return ()) - let src0 = takeArrayListRev n (x:getList backBuf) - src = Prelude.reverse src0 ++ xs - gobuf SPEC src s (List []) pst1 - PR.Continue 0 pst1 -> - gobuf SPEC xs s (List (x:getList backBuf)) pst1 - PR.Continue n pst1 -> do - assert - (n <= sum (map Array.length (x:getList backBuf))) - (return ()) - let (src0, buf1) = splitAtArrayListRev n (x:getList backBuf) - src = Prelude.reverse src0 ++ xs - gobuf SPEC src s (List buf1) pst1 - PR.Done 0 b -> do - let str = D.append (D.fromList xs) (D.Stream step s) - return (Right b, str) - PR.Done n b -> do - assert - (n <= sum (map Array.length (x:getList backBuf))) - (return ()) - let src0 = takeArrayListRev n (x:getList backBuf) - src = Prelude.reverse src0 ++ xs - return (Right b, D.append (D.fromList src) (D.Stream step s)) - PR.Error err -> do - let strm = D.append (D.fromList (x:xs)) (D.Stream step s) - return (Left (ParseError err), strm) - - -- This is a simplified gobuf - goExtract _ [] backBuf !pst = goStop backBuf pst - goExtract _ (x:xs) backBuf !pst = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - goExtract SPEC xs (List []) pst1 - PR.Partial n pst1 -> do - assert - (n <= sum (map Array.length (x:getList backBuf))) - (return ()) - let src0 = takeArrayListRev n (x:getList backBuf) - src = Prelude.reverse src0 ++ xs - goExtract SPEC src (List []) pst1 - PR.Continue 0 pst1 -> - goExtract SPEC xs (List (x:getList backBuf)) pst1 - PR.Continue n pst1 -> do - assert - (n <= sum (map Array.length (x:getList backBuf))) - (return ()) - let (src0, buf1) = splitAtArrayListRev n (x:getList backBuf) - src = Prelude.reverse src0 ++ xs - goExtract SPEC src (List buf1) pst1 - PR.Done 0 b -> - return (Right b, D.fromList xs) - PR.Done n b -> do - assert - (n <= sum (map Array.length (x:getList backBuf))) - (return ()) - let src0 = takeArrayListRev n (x:getList backBuf) - src = Prelude.reverse src0 ++ xs - return (Right b, D.fromList src) - PR.Error err -> - return (Left (ParseError err), D.fromList (x:xs)) - - -- This is a simplified goExtract - {-# INLINE goStop #-} - goStop backBuf pst = do - pRes <- extract pst - case pRes of - PR.Partial _ _ -> error "Bug: runArrayParserDBreak: Partial in extract" - PR.Continue 0 pst1 -> - goStop backBuf pst1 - PR.Continue n pst1 -> do - assert - (n <= sum (map Array.length (getList backBuf))) - (return ()) - let (src0, buf1) = splitAtArrayListRev n (getList backBuf) - src = Prelude.reverse src0 - goExtract SPEC src (List buf1) pst1 - PR.Done 0 b -> return (Right b, D.nil) - PR.Done n b -> do - assert - (n <= sum (map Array.length (getList backBuf))) - (return ()) - let src0 = takeArrayListRev n (getList backBuf) - src = Prelude.reverse src0 - return (Right b, D.fromList src) - PR.Error err -> - return (Left (ParseError err), D.nil) - -{- --- | Parse an array stream using the supplied 'Parser'. Returns the parse --- result and the unconsumed stream. Throws 'ParseError' if the parse fails. --- --- /Internal/ --- -{-# INLINE parseArr #-} -parseArr :: - (MonadIO m, MonadThrow m, Unbox a) - => ASF.Parser a m b - -> Stream m (A.Array a) - -> m (b, Stream m (A.Array a)) -parseArr p s = fmap fromStreamD <$> parseBreakD p (toStreamD s) --} - --- | Fold an array stream using the supplied array stream 'Fold'. --- --- /Pre-release/ --- -{-# INLINE runArrayFold #-} -runArrayFold :: (MonadIO m, Unbox a) => - ChunkFold m a b -> StreamK m (A.Array a) -> m (Either ParseError b) -runArrayFold (ChunkFold p) s = fst <$> runArrayParserDBreak p (toStream s) - --- | Like 'fold' but also returns the remaining stream. --- --- /Pre-release/ --- -{-# INLINE runArrayFoldBreak #-} -runArrayFoldBreak :: (MonadIO m, Unbox a) => - ChunkFold m a b -> StreamK m (A.Array a) -> m (Either ParseError b, StreamK m (A.Array a)) -runArrayFoldBreak (ChunkFold p) s = - second fromStream <$> runArrayParserDBreak p (toStream s) - -{-# ANN type ParseChunksState Fuse #-} -data ParseChunksState x inpBuf st pst = - ParseChunksInit inpBuf st - | ParseChunksInitBuf inpBuf - | ParseChunksInitLeftOver inpBuf - | ParseChunksStream st inpBuf !pst - | ParseChunksStop inpBuf !pst - | ParseChunksBuf inpBuf st inpBuf !pst - | ParseChunksExtract inpBuf inpBuf !pst - | ParseChunksYield x (ParseChunksState x inpBuf st pst) - -{-# INLINE_NORMAL runArrayFoldManyD #-} -runArrayFoldManyD - :: (Monad m, Unbox a) - => ChunkFold m a b - -> D.Stream m (Array a) - -> D.Stream m (Either ParseError b) -runArrayFoldManyD - (ChunkFold (PRD.Parser pstep initial extract)) (D.Stream step state) = - - D.Stream stepOuter (ParseChunksInit [] state) - - where - - {-# INLINE_LATE stepOuter #-} - -- Buffer is empty, get the first element from the stream, initialize the - -- fold and then go to stream processing loop. - stepOuter gst (ParseChunksInit [] st) = do - r <- step (adaptState gst) st - case r of - D.Yield x s -> do - res <- initial - case res of - PRD.IPartial ps -> - return $ D.Skip $ ParseChunksBuf [x] s [] ps - PRD.IDone pb -> do - let next = ParseChunksInit [x] s - return $ D.Skip $ ParseChunksYield (Right pb) next - PRD.IError err -> do - let next = ParseChunksInitLeftOver [] - return - $ D.Skip - $ ParseChunksYield (Left (ParseError err)) next - D.Skip s -> return $ D.Skip $ ParseChunksInit [] s - D.Stop -> return D.Stop - - -- Buffer is not empty, go to buffered processing loop - stepOuter _ (ParseChunksInit src st) = do - res <- initial - case res of - PRD.IPartial ps -> - return $ D.Skip $ ParseChunksBuf src st [] ps - PRD.IDone pb -> - let next = ParseChunksInit src st - in return $ D.Skip $ ParseChunksYield (Right pb) next - PRD.IError err -> do - let next = ParseChunksInitLeftOver [] - return - $ D.Skip - $ ParseChunksYield (Left (ParseError err)) next - - -- This is a simplified ParseChunksInit - stepOuter _ (ParseChunksInitBuf src) = do - res <- initial - case res of - PRD.IPartial ps -> - return $ D.Skip $ ParseChunksExtract src [] ps - PRD.IDone pb -> - let next = ParseChunksInitBuf src - in return $ D.Skip $ ParseChunksYield (Right pb) next - PRD.IError err -> do - let next = ParseChunksInitLeftOver [] - return - $ D.Skip - $ ParseChunksYield (Left (ParseError err)) next - - -- XXX we just discard any leftover input at the end - stepOuter _ (ParseChunksInitLeftOver _) = return D.Stop - - -- Buffer is empty, process elements from the stream - stepOuter gst (ParseChunksStream st backBuf pst) = do - r <- step (adaptState gst) st - case r of - D.Yield x s -> do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - return $ D.Skip $ ParseChunksStream s [] pst1 - PR.Partial n pst1 -> do - assert - (n <= sum (map Array.length (x:backBuf))) - (return ()) - let src0 = takeArrayListRev n (x:backBuf) - src = Prelude.reverse src0 - return $ D.Skip $ ParseChunksBuf src s [] pst1 - PR.Continue 0 pst1 -> - return $ D.Skip $ ParseChunksStream s (x:backBuf) pst1 - PR.Continue n pst1 -> do - assert - (n <= sum (map Array.length (x:backBuf))) - (return ()) - let (src0, buf1) = splitAtArrayListRev n (x:backBuf) - src = Prelude.reverse src0 - return $ D.Skip $ ParseChunksBuf src s buf1 pst1 - PR.Done 0 b -> do - return $ D.Skip $ - ParseChunksYield (Right b) (ParseChunksInit [] s) - PR.Done n b -> do - assert - (n <= sum (map Array.length (x:backBuf))) - (return ()) - let src0 = takeArrayListRev n (x:backBuf) - src = Prelude.reverse src0 - next = ParseChunksInit src s - return - $ D.Skip - $ ParseChunksYield (Right b) next - PR.Error err -> do - let next = ParseChunksInitLeftOver [] - return - $ D.Skip - $ ParseChunksYield (Left (ParseError err)) next - - D.Skip s -> return $ D.Skip $ ParseChunksStream s backBuf pst - D.Stop -> return $ D.Skip $ ParseChunksStop backBuf pst - - -- go back to stream processing mode - stepOuter _ (ParseChunksBuf [] s buf pst) = - return $ D.Skip $ ParseChunksStream s buf pst - - -- buffered processing loop - stepOuter _ (ParseChunksBuf (x:xs) s backBuf pst) = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - return $ D.Skip $ ParseChunksBuf xs s [] pst1 - PR.Partial n pst1 -> do - assert (n <= sum (map Array.length (x:backBuf))) (return ()) - let src0 = takeArrayListRev n (x:backBuf) - src = Prelude.reverse src0 ++ xs - return $ D.Skip $ ParseChunksBuf src s [] pst1 - PR.Continue 0 pst1 -> - return $ D.Skip $ ParseChunksBuf xs s (x:backBuf) pst1 - PR.Continue n pst1 -> do - assert (n <= sum (map Array.length (x:backBuf))) (return ()) - let (src0, buf1) = splitAtArrayListRev n (x:backBuf) - src = Prelude.reverse src0 ++ xs - return $ D.Skip $ ParseChunksBuf src s buf1 pst1 - PR.Done 0 b -> - return - $ D.Skip - $ ParseChunksYield (Right b) (ParseChunksInit xs s) - PR.Done n b -> do - assert (n <= sum (map Array.length (x:backBuf))) (return ()) - let src0 = takeArrayListRev n (x:backBuf) - src = Prelude.reverse src0 ++ xs - return - $ D.Skip - $ ParseChunksYield (Right b) (ParseChunksInit src s) - PR.Error err -> do - let next = ParseChunksInitLeftOver [] - return - $ D.Skip - $ ParseChunksYield (Left (ParseError err)) next - - -- This is a simplified ParseChunksBuf - stepOuter _ (ParseChunksExtract [] buf pst) = - return $ D.Skip $ ParseChunksStop buf pst - - stepOuter _ (ParseChunksExtract (x:xs) backBuf pst) = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - return $ D.Skip $ ParseChunksExtract xs [] pst1 - PR.Partial n pst1 -> do - assert (n <= sum (map Array.length (x:backBuf))) (return ()) - let src0 = takeArrayListRev n (x:backBuf) - src = Prelude.reverse src0 ++ xs - return $ D.Skip $ ParseChunksExtract src [] pst1 - PR.Continue 0 pst1 -> - return $ D.Skip $ ParseChunksExtract xs (x:backBuf) pst1 - PR.Continue n pst1 -> do - assert (n <= sum (map Array.length (x:backBuf))) (return ()) - let (src0, buf1) = splitAtArrayListRev n (x:backBuf) - src = Prelude.reverse src0 ++ xs - return $ D.Skip $ ParseChunksExtract src buf1 pst1 - PR.Done 0 b -> - return - $ D.Skip - $ ParseChunksYield (Right b) (ParseChunksInitBuf xs) - PR.Done n b -> do - assert (n <= sum (map Array.length (x:backBuf))) (return ()) - let src0 = takeArrayListRev n (x:backBuf) - src = Prelude.reverse src0 ++ xs - return - $ D.Skip - $ ParseChunksYield (Right b) (ParseChunksInitBuf src) - PR.Error err -> do - let next = ParseChunksInitLeftOver [] - return - $ D.Skip - $ ParseChunksYield (Left (ParseError err)) next - - - -- This is a simplified ParseChunksExtract - stepOuter _ (ParseChunksStop backBuf pst) = do - pRes <- extract pst - case pRes of - PR.Partial _ _ -> error "runArrayFoldManyD: Partial in extract" - PR.Continue 0 pst1 -> - return $ D.Skip $ ParseChunksStop backBuf pst1 - PR.Continue n pst1 -> do - assert (n <= sum (map Array.length backBuf)) (return ()) - let (src0, buf1) = splitAtArrayListRev n backBuf - src = Prelude.reverse src0 - return $ D.Skip $ ParseChunksExtract src buf1 pst1 - PR.Done 0 b -> - return - $ D.Skip - $ ParseChunksYield (Right b) (ParseChunksInitLeftOver []) - PR.Done n b -> do - assert (n <= sum (map Array.length backBuf)) (return ()) - let src0 = takeArrayListRev n backBuf - src = Prelude.reverse src0 - return - $ D.Skip - $ ParseChunksYield (Right b) (ParseChunksInitBuf src) - PR.Error err -> do - let next = ParseChunksInitLeftOver [] - return - $ D.Skip - $ ParseChunksYield (Left (ParseError err)) next - - stepOuter _ (ParseChunksYield a next) = return $ D.Yield a next - --- | Apply an 'ChunkFold' repeatedly on an array stream and emit the --- fold outputs in the output stream. --- --- See "Streamly.Data.Stream.foldMany" for more details. --- --- /Pre-release/ -{-# INLINE runArrayFoldMany #-} -runArrayFoldMany - :: (Monad m, Unbox a) - => ChunkFold m a b - -> StreamK m (Array a) - -> StreamK m (Either ParseError b) -runArrayFoldMany p m = fromStream $ runArrayFoldManyD p (toStream m) diff --git a/src/Streamly/Internal/Data/Stream/Common.hs b/src/Streamly/Internal/Data/Stream/Common.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Common.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- Module : Streamly.Internal.Data.Stream.Common --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Low level functions using StreamK as the intermediate stream type. These --- functions are used in other stream modules to implement their instances. --- -module Streamly.Internal.Data.Stream.Common - ( - -- * Conversion operations - fromList - , toList - - -- * Fold operations - , foldr - , foldl' - , fold - - -- * Zip style operations - , eqBy - , cmpBy - ) -where - -#include "inline.hs" - -import Streamly.Internal.Data.Fold.Type (Fold (..)) - -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D - -import Prelude hiding (foldr, repeat) - ------------------------------------------------------------------------------- --- Conversions ------------------------------------------------------------------------------- - --- | --- @ --- fromList = 'Prelude.foldr' 'K.cons' 'K.nil' --- @ --- --- Construct a stream from a list of pure values. This is more efficient than --- 'K.fromFoldable' for serial streams. --- -{-# INLINE_EARLY fromList #-} -fromList :: Monad m => [a] -> K.StreamK m a -fromList = D.toStreamK . D.fromList -{-# RULES "fromList fallback to StreamK" [1] - forall a. D.toStreamK (D.fromList a) = K.fromFoldable a #-} - --- | Convert a stream into a list in the underlying monad. --- -{-# INLINE toList #-} -toList :: Monad m => K.StreamK m a -> m [a] -toList m = D.toList $ D.fromStreamK m - ------------------------------------------------------------------------------- --- Folds ------------------------------------------------------------------------------- - -{-# INLINE foldrM #-} -foldrM :: Monad m => (a -> m b -> m b) -> m b -> K.StreamK m a -> m b -foldrM step acc m = D.foldrM step acc $ D.fromStreamK m - -{-# INLINE foldr #-} -foldr :: Monad m => (a -> b -> b) -> b -> K.StreamK m a -> m b -foldr f z = foldrM (\a b -> f a <$> b) (return z) - --- | Strict left associative fold. --- -{-# INLINE foldl' #-} -foldl' :: - Monad m => (b -> a -> b) -> b -> K.StreamK m a -> m b -foldl' step begin m = D.foldl' step begin $ D.fromStreamK m - - -{-# INLINE fold #-} -fold :: Monad m => Fold m a b -> K.StreamK m a -> m b -fold fld m = D.fold fld $ D.fromStreamK m - ------------------------------------------------------------------------------- --- Comparison ------------------------------------------------------------------------------- - --- | Compare two streams for equality --- -{-# INLINE eqBy #-} -eqBy :: Monad m => - (a -> b -> Bool) -> K.StreamK m a -> K.StreamK m b -> m Bool -eqBy f m1 m2 = D.eqBy f (D.fromStreamK m1) (D.fromStreamK m2) - --- | Compare two streams --- -{-# INLINE cmpBy #-} -cmpBy - :: Monad m - => (a -> b -> Ordering) -> K.StreamK m a -> K.StreamK m b -> m Ordering -cmpBy f m1 m2 = D.cmpBy f (D.fromStreamK m1) (D.fromStreamK m2) diff --git a/src/Streamly/Internal/Data/Stream/Container.hs b/src/Streamly/Internal/Data/Stream/Container.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Container.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Stream.Container +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Stream operations that require transformers or containers like Set or Map. + +module Streamly.Internal.Data.Stream.Container + ( + -- * Deduplication + ordNub + + -- * Joins + , leftJoin + , outerJoin + + -- * Ord Joins + , innerOrdJoin + , leftOrdJoin + , outerOrdJoin + ) +where + +#include "inline.hs" + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.State.Strict (get, put) +import Data.Function ((&)) +import Data.Maybe (isJust) +import Streamly.Internal.Data.Stream.Step (Step(..)) +import Streamly.Internal.Data.Stream.Type (Stream(..), Nested(..)) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Internal.Data.Array.Generic as Array +import qualified Streamly.Internal.Data.MutArray.Type as MA +import qualified Streamly.Internal.Data.Stream.Type as Stream +import qualified Streamly.Internal.Data.Stream.Generate as Stream +import qualified Streamly.Internal.Data.Stream.Transform as Stream +import qualified Streamly.Internal.Data.Stream.Transformer as Stream + +#include "DocTestDataStream.hs" + +-- | @nub@ specialized to 'Ord' types for better performance. Returns a +-- subsequence of the stream removing any duplicate elements. +-- +-- The memory used is proportional to the number of unique elements in the +-- stream. One way to limit the memory is to use @take@ on the resulting +-- stream to limit the unique elements in the stream. +{-# INLINE_NORMAL ordNub #-} +ordNub :: (Monad m, Ord a) => Stream m a -> Stream m a +ordNub (Stream step1 state1) = Stream step (Set.empty, state1) + + where + + step gst (set, st) = do + r <- step1 gst st + return + $ case r of + Yield x s -> + if Set.member x set + then Skip (set, s) + else Yield x (Set.insert x set, s) + Skip s -> Skip (set, s) + Stop -> Stop + +-- XXX Generate error if a duplicate insertion is attempted? +toMap :: (Monad m, Ord k) => Stream m (k, v) -> m (Map.Map k v) +toMap = + let f = Fold.foldl' (\kv (k, b) -> Map.insert k b kv) Map.empty + in Stream.fold f + +-- If the second stream is too big it can be partitioned based on hashes and +-- then we can process one parition at a time. +-- +-- XXX An IntMap may be faster when the keys are Int. +-- XXX Use hashmap instead of map? + +-- | 'innerJoin' specialized to 'Ord' types for better performance. +-- +-- If the input streams have duplicate keys, the behavior is undefined. +-- +-- For space efficiency use the smaller stream as the second stream. +-- +-- Space: O(n) +-- +-- Time: O(m + n) +-- +-- /Pre-release/ +{-# INLINE innerOrdJoin #-} +innerOrdJoin :: (Monad m, Ord k) => + Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, b) +innerOrdJoin s1 s2 = + Stream.concatEffect $ do + km <- toMap s2 + pure $ Stream.mapMaybe (joinAB km) s1 + + where + + joinAB kvm (k, a) = + case k `Map.lookup` kvm of + Just b -> Just (k, a, b) + Nothing -> Nothing + +-- XXX We can do this concurrently. +-- XXX Check performance of StreamD vs StreamK +-- XXX If the second stream is sorted and passed as an Array or a seek capable +-- stream then we could use binary search if we have an Ord instance or +-- Ordering returning function. The time complexity would then become (m x log +-- n). + +-- | Like 'innerJoin' but emits @(a, Just b)@ whenever a and b are equal, for +-- those @a@'s that are not equal to any @b@ emits @(a, Nothing)@. +-- +-- This is a generalization of 'innerJoin' to include all elements from the +-- left stream and not just those which have an equal in the right stream. This +-- is not a commutative operation, the order of the stream arguments matters. +-- +-- All the caveats mentioned in 'innerJoin' apply here as well. Right join is +-- not provided because it is just a flipped left join: +-- +-- >>> rightJoin eq = flip (Stream.leftJoin eq) +-- +-- Space: O(n) assuming the second stream is cached in memory. +-- +-- Time: O(m x n) +-- +-- /Unimplemented/ +{-# INLINE leftJoin #-} +leftJoin :: Monad m => + (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) +leftJoin eq s1 s2 = Stream.evalStateT (return False) $ unNested $ do + a <- Nested (Stream.liftInner s1) + -- XXX should we use StreamD monad here? + -- XXX Is there a better way to perform some action at the end of a loop + -- iteration? + Nested (Stream.fromEffect $ put False) + let final = Stream.concatEffect $ do + r <- get + if r + then pure Stream.nil + else pure (Stream.fromPure Nothing) + b <- Nested (fmap Just (Stream.liftInner s2) `Stream.append` final) + case b of + Just b1 -> + if a `eq` b1 + then do + Nested (Stream.fromEffect $ put True) + return (a, Just b1) + else Nested Stream.nil + Nothing -> return (a, Nothing) + +-- | 'leftJoin' specialized to 'Ord' types for better performance. +-- +-- Space: O(n) +-- +-- Time: O(m + n) +-- +-- /Pre-release/ +{-# INLINE leftOrdJoin #-} +leftOrdJoin :: (Ord k, Monad m) => + Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, Maybe b) +leftOrdJoin s1 s2 = + Stream.concatEffect $ do + km <- toMap s2 + return $ fmap (joinAB km) s1 + + where + + joinAB km (k, a) = + case k `Map.lookup` km of + Just b -> (k, a, Just b) + Nothing -> (k, a, Nothing) + +-- XXX We can do this concurrently. +-- XXX Check performance of StreamD vs StreamK cross operation. + +-- | Like 'leftJoin' but emits a @(Just a, Just b)@. Like 'leftJoin', for those +-- @a@'s that are not equal to any @b@ emit @(Just a, Nothing)@, but +-- additionally, for those @b@'s that are not equal to any @a@ emit @(Nothing, +-- Just b)@. +-- +-- This is a generalization of left join to include all the elements from the +-- right stream as well, in other words it is a combination of left and right +-- joins. This is a commutative operation. The order of stream arguments can be +-- changed without affecting results, except for the ordering of elements in +-- the resulting tuple. +-- +-- For space efficiency use the smaller stream as the second stream. +-- +-- Space: O(n) +-- +-- Time: O(m x n) +-- +-- /Pre-release/ +{-# INLINE outerJoin #-} +outerJoin :: MonadIO m => + (a -> b -> Bool) + -> Stream m a + -> Stream m b + -> Stream m (Maybe a, Maybe b) +outerJoin eq s1 s2 = + Stream.concatEffect $ do + inputArr <- Array.fromStream s2 + let len = Array.length inputArr + foundArr <- + Stream.fold + (MA.createOf len) + (Stream.fromList (Prelude.replicate len False)) + return $ go inputArr foundArr `Stream.append` leftOver inputArr foundArr + + where + + leftOver inputArr foundArr = + let stream1 = Array.read inputArr + stream2 = Stream.unfold MA.reader foundArr + in Stream.filter + isJust + ( Stream.zipWith (\x y -> + if y + then Nothing + else Just (Nothing, Just x) + ) stream1 stream2 + ) & Stream.catMaybes + + evalState = Stream.evalStateT (return False) . unNested + + go inputArr foundArr = evalState $ do + a <- Nested (Stream.liftInner s1) + -- XXX should we use StreamD monad here? + -- XXX Is there a better way to perform some action at the end of a loop + -- iteration? + Nested (Stream.fromEffect $ put False) + let final = Stream.concatEffect $ do + r <- get + if r + then pure Stream.nil + else pure (Stream.fromPure Nothing) + (i, b) <- + let stream = Array.read inputArr + in Nested + (Stream.indexed $ fmap Just (Stream.liftInner stream) `Stream.append` final) + + case b of + Just b1 -> + if a `eq` b1 + then do + Nested (Stream.fromEffect $ put True) + MA.putIndex i foundArr True + return (Just a, Just b1) + else Nested Stream.nil + Nothing -> return (Just a, Nothing) + +-- Put the b's that have been paired, in another hash or mutate the hash to set +-- a flag. At the end go through @Stream m b@ and find those that are not in that +-- hash to return (Nothing, b). + +-- | 'outerJoin' specialized to 'Ord' types for better performance. +-- +-- Space: O(m + n) +-- +-- Time: O(m + n) +-- +-- /Pre-release/ +{-# INLINE outerOrdJoin #-} +outerOrdJoin :: + (Ord k, MonadIO m) => + Stream m (k, a) -> Stream m (k, b) -> Stream m (k, Maybe a, Maybe b) +outerOrdJoin s1 s2 = + Stream.concatEffect $ do + km1 <- kvFold s1 + km2 <- kvFold s2 + + -- XXX Not sure if toList/fromList would fuse optimally. We may have to + -- create a fused Map.toStream function. + let res1 = fmap (joinAB km2) + $ Stream.fromList $ Map.toList km1 + where + joinAB km (k, a) = + case k `Map.lookup` km of + Just b -> (k, Just a, Just b) + Nothing -> (k, Just a, Nothing) + + -- XXX We can take advantage of the lookups in the first pass above to + -- reduce the number of lookups in this pass. If we keep mutable cells + -- in the second Map, we can flag it in the first pass and not do any + -- lookup in the second pass if it is flagged. + let res2 = Stream.mapMaybe (joinAB km1) + $ Stream.fromList $ Map.toList km2 + where + joinAB km (k, b) = + case k `Map.lookup` km of + Just _ -> Nothing + Nothing -> Just (k, Nothing, Just b) + + return $ Stream.append res1 res2 + + where + + -- XXX Generate error if a duplicate insertion is attempted? + kvFold = + let f = Fold.foldl' (\kv (k, b) -> Map.insert k b kv) Map.empty + in Stream.fold f diff --git a/src/Streamly/Internal/Data/Stream/Cross.hs b/src/Streamly/Internal/Data/Stream/Cross.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Cross.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Streamly.Internal.Data.Stream.Cross --- Copyright : (c) 2017 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Stream.Cross - ( - CrossStream (..) - ) -where - -import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Applicative (liftA2) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Functor.Identity (Identity(..)) -import GHC.Exts (IsList(..), IsString(..)) -import Streamly.Internal.Data.Stream.Type (Stream) - -import qualified Streamly.Internal.Data.Stream.Type as Stream -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - --- $setup --- >>> import Streamly.Internal.Data.Stream.Cross (CrossStream(..)) --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Stream as Stream - ------------------------------------------------------------------------------- --- Stream with a cross product style monad instance ------------------------------------------------------------------------------- - --- | A newtype wrapper for the 'Stream' type with a cross product style monad --- instance. --- --- Semigroup instance appends two streams. --- --- A 'Monad' bind behaves like a @for@ loop: --- --- >>> :{ --- Stream.fold Fold.toList $ unCrossStream $ do --- x <- CrossStream (Stream.fromList [1,2]) -- foreach x in stream --- return x --- :} --- [1,2] --- --- Nested monad binds behave like nested @for@ loops: --- --- >>> :{ --- Stream.fold Fold.toList $ unCrossStream $ do --- x <- CrossStream (Stream.fromList [1,2]) -- foreach x in stream --- y <- CrossStream (Stream.fromList [3,4]) -- foreach y in stream --- return (x, y) --- :} --- [(1,3),(1,4),(2,3),(2,4)] --- -newtype CrossStream m a = CrossStream {unCrossStream :: Stream m a} - deriving (Functor, Semigroup, Monoid, Foldable) - --- Pure (Identity monad) stream instances -deriving instance Traversable (CrossStream Identity) -deriving instance IsList (CrossStream Identity a) -deriving instance (a ~ Char) => IsString (CrossStream Identity a) -deriving instance Eq a => Eq (CrossStream Identity a) -deriving instance Ord a => Ord (CrossStream Identity a) -deriving instance Show a => Show (CrossStream Identity a) -deriving instance Read a => Read (CrossStream Identity a) - ------------------------------------------------------------------------------- --- Applicative ------------------------------------------------------------------------------- - --- Note: we need to define all the typeclass operations because we want to --- INLINE them. -instance Monad m => Applicative (CrossStream m) where - {-# INLINE pure #-} - pure x = CrossStream (Stream.fromPure x) - - {-# INLINE (<*>) #-} - (CrossStream s1) <*> (CrossStream s2) = - CrossStream (Stream.crossApply s1 s2) - -- (<*>) = K.crossApply - - {-# INLINE liftA2 #-} - liftA2 f x = (<*>) (fmap f x) - - {-# INLINE (*>) #-} - (CrossStream s1) *> (CrossStream s2) = - CrossStream (Stream.crossApplySnd s1 s2) - -- (*>) = K.crossApplySnd - - {-# INLINE (<*) #-} - (CrossStream s1) <* (CrossStream s2) = - CrossStream (Stream.crossApplyFst s1 s2) - -- (<*) = K.crossApplyFst - ------------------------------------------------------------------------------- --- Monad ------------------------------------------------------------------------------- - -instance Monad m => Monad (CrossStream m) where - return = pure - - -- Benchmarks better with StreamD bind and pure: - -- toList, filterAllout, *>, *<, >> (~2x) - -- - -- pure = Stream . D.fromStreamD . D.fromPure - -- m >>= f = D.fromStreamD $ D.concatMap (D.toStreamD . f) (D.toStreamD m) - - -- Benchmarks better with CPS bind and pure: - -- Prime sieve (25x) - -- n binds, breakAfterSome, filterAllIn, state transformer (~2x) - -- - {-# INLINE (>>=) #-} - (>>=) (CrossStream m) f = - CrossStream - (Stream.fromStreamK - $ K.bindWith - K.append - (Stream.toStreamK m) - (Stream.toStreamK . unCrossStream . f)) - - {-# INLINE (>>) #-} - (>>) = (*>) - ------------------------------------------------------------------------------- --- Transformers ------------------------------------------------------------------------------- - -instance (MonadIO m) => MonadIO (CrossStream m) where - liftIO x = CrossStream (Stream.fromEffect $ liftIO x) - -instance MonadTrans CrossStream where - {-# INLINE lift #-} - lift x = CrossStream (Stream.fromEffect x) - -instance (MonadThrow m) => MonadThrow (CrossStream m) where - throwM = lift . throwM diff --git a/src/Streamly/Internal/Data/Stream/Eliminate.hs b/src/Streamly/Internal/Data/Stream/Eliminate.hs --- a/src/Streamly/Internal/Data/Stream/Eliminate.hs +++ b/src/Streamly/Internal/Data/Stream/Eliminate.hs @@ -1,233 +1,138 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Internal.Data.Stream.Eliminate --- Copyright : (c) 2017 Composewell Technologies +-- Copyright : (c) 2018 Composewell Technologies +-- (c) Roman Leshchinskiy 2008-2010 -- License : BSD-3-Clause -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC --- --- This module contains functions ending in the shape: --- --- @ --- Stream m a -> m b --- @ --- --- We call them stream folding functions, they reduce a stream @Stream m a@ to --- a monadic value @m b@. +-- A few functions in this module have been adapted from the vector package +-- (c) Roman Leshchinskiy. +-- module Streamly.Internal.Data.Stream.Eliminate ( - -- * Running Examples - -- $setup - - -- * Running a 'Fold' - -- See "Streamly.Internal.Data.Fold". - fold - , foldBreak - , foldBreak2 - , foldEither - , foldEither2 - , foldConcat - - -- * Builders - , foldAdd - , foldAddLazy - - -- * Running a 'Parser' - -- "Streamly.Internal.Data.Parser". - , parse - --, parseK - , parseD - --, parseBreak - , parseBreakD + -- * Running a Parser + parse + , parsePos + , parseBreak + , parseBreakPos - -- * Stream Deconstruction - -- | foldr and foldl do not provide the remaining stream. 'uncons' is more - -- general, as it can be used to implement those as well. It allows to use - -- the stream one element at a time, and we have the remaining stream all - -- the time. + -- * Deconstruction , uncons - , init -- * Right Folds - , foldrM - , foldr + , foldr1 - -- * Left Folds - -- Lazy left folds are useful only for reversing the stream - , foldlS + -- * Specific Fold Functions + , mapM_ -- Map and Fold + , null + , init + , tail + , last + , elem + , notElem + , all + , any + , maximum + , maximumBy + , minimum + , minimumBy + , lookup + , findM + , find + , (!!) + , the - -- * Multi-Stream folds - -- Full equivalence - , eqBy - , cmpBy + -- * To containers + , toListRev - -- finding subsequences + -- * Multi-Stream Folds + -- | These should probably be expressed using parsers. , isPrefixOf , isInfixOf , isSuffixOf + , isSuffixOfUnbox , isSubsequenceOf - - -- trimming sequences , stripPrefix - -- , stripInfix , stripSuffix + , stripSuffixUnbox + + -- * Deprecated + , parseD + , parseBreakD ) where #include "inline.hs" +#include "deprecation.h" import Control.Monad.IO.Class (MonadIO(..)) -import Foreign.Storable (Storable) -import Streamly.Internal.Data.Parser (Parser (..), ParseError (..)) -import Streamly.Internal.Data.Unboxed (Unbox) -import Streamly.Internal.Data.Stream.Type (Stream) +import GHC.Types (SPEC(..)) +import Streamly.Internal.Data.Parser (ParseError(..), ParseErrorPos(..)) +import Streamly.Internal.Data.SVar.Type (adaptState, defState) +import Streamly.Internal.Data.Unbox (Unbox) +import Streamly.Internal.Data.Maybe.Strict (Maybe'(..)) + import qualified Streamly.Internal.Data.Array.Type as Array import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Parser.ParserD as PRD -import qualified Streamly.Internal.Data.Parser.ParserK.Type as PRK -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -import qualified Streamly.Internal.Data.Stream.StreamK as K - -import Streamly.Internal.Data.Stream.Bottom -import Streamly.Internal.Data.Stream.Type hiding (Stream) +import qualified Streamly.Internal.Data.Parser as PR +import qualified Streamly.Internal.Data.ParserDrivers as Drivers +import qualified Streamly.Internal.Data.Stream.Nesting as Nesting +import qualified Streamly.Internal.Data.Stream.Transform as StreamD -import Prelude hiding (foldr, init, reverse) +import Prelude hiding + ( Foldable(..), all, any, head, last, lookup, mapM, mapM_ + , notElem, splitAt, init, tail, (!!)) +import Streamly.Internal.Data.Stream.Type hiding (splitAt) --- $setup --- >>> :m --- >>> import Streamly.Internal.Data.Stream (Stream) --- >>> import qualified Streamly.Internal.Data.Stream as Stream --- >>> import qualified Streamly.Internal.Data.Parser as Parser --- >>> import qualified Streamly.Internal.Data.Fold as Fold --- >>> import qualified Streamly.Internal.Data.Unfold as Unfold +#include "DocTestDataStream.hs" ------------------------------------------------------------------------------ --- Deconstruction +-- Elimination by Folds ------------------------------------------------------------------------------ --- | Decompose a stream into its head and tail. If the stream is empty, returns --- 'Nothing'. If the stream is non-empty, returns @Just (a, ma)@, where @a@ is --- the head of the stream and @ma@ its tail. --- --- Properties: --- --- >>> Nothing <- Stream.uncons Stream.nil --- >>> Just ("a", t) <- Stream.uncons (Stream.cons "a" Stream.nil) --- --- This can be used to consume the stream in an imperative manner one element --- at a time, as it just breaks down the stream into individual elements and we --- can loop over them as we deem fit. For example, this can be used to convert --- a streamly stream into other stream types. --- --- All the folds in this module can be expressed in terms of 'uncons', however, --- this is generally less efficient than specific folds because it takes apart --- the stream one element at a time, therefore, does not take adavantage of --- stream fusion. --- --- 'foldBreak' is a more general way of consuming a stream piecemeal. --- --- >>> :{ --- uncons xs = do --- r <- Stream.foldBreak Fold.one xs --- return $ case r of --- (Nothing, _) -> Nothing --- (Just h, t) -> Just (h, t) --- :} --- --- /CPS/ --- -{-# INLINE uncons #-} -uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a)) -uncons m = fmap (fmap (fmap fromStreamK)) $ K.uncons (toStreamK m) - --- | Extract all but the last element of the stream, if any. --- --- Note: This will end up buffering the entire stream. --- --- /Pre-release/ -{-# INLINE init #-} -init :: Monad m => Stream m a -> m (Maybe (Stream m a)) -init m = fmap (fmap fromStreamK) $ K.init $ toStreamK m - ------------------------------------------------------------------------------ -- Right Folds ------------------------------------------------------------------------------ --- | Right associative/lazy pull fold. @foldrM build final stream@ constructs --- an output structure using the step function @build@. @build@ is invoked with --- the next input element and the remaining (lazy) tail of the output --- structure. It builds a lazy output expression using the two. When the "tail --- structure" in the output expression is evaluated it calls @build@ again thus --- lazily consuming the input @stream@ until either the output expression built --- by @build@ is free of the "tail" or the input is exhausted in which case --- @final@ is used as the terminating case for the output structure. For more --- details see the description in the previous section. --- --- Example, determine if any element is 'odd' in a stream: --- --- >>> s = Stream.fromList (2:4:5:undefined) --- >>> step x xs = if odd x then return True else xs --- >>> Stream.foldrM step (return False) s --- True --- -{-# INLINE foldrM #-} -foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b -foldrM step acc m = D.foldrM step acc $ toStreamD m - --- | Right fold, lazy for lazy monads and pure streams, and strict for strict --- monads. --- --- Please avoid using this routine in strict monads like IO unless you need a --- strict right fold. This is provided only for use in lazy monads (e.g. --- Identity) or pure streams. Note that with this signature it is not possible --- to implement a lazy foldr when the monad @m@ is strict. In that case it --- would be strict in its accumulator and therefore would necessarily consume --- all its input. --- --- >>> foldr f z = Stream.foldrM (\a b -> f a <$> b) (return z) --- -{-# INLINE foldr #-} -foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b -foldr f z = foldrM (\a b -> f a <$> b) (return z) +{-# INLINE_NORMAL foldr1 #-} +foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a) +foldr1 f m = do + r <- uncons m + case r of + Nothing -> return Nothing + Just (h, t) -> fmap Just (foldr f h t) ------------------------------------------------------------------------------ --- Left Folds +-- Parsers ------------------------------------------------------------------------------ --- | Lazy left fold to a stream. -{-# INLINE foldlS #-} -foldlS :: - (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b -foldlS f z = - fromStreamK - . K.foldlS - (\xs x -> toStreamK $ f (fromStreamK xs) x) - (toStreamK z) - . toStreamK - ------------------------------------------------------------------------------- --- Running a Parser ------------------------------------------------------------------------------- +-- XXX It may be a good idea to use constant sized chunks for backtracking. We +-- can take a byte stream but when we have to backtrack we create constant +-- sized chunks. We maintain one forward list and one backward list of constant +-- sized chunks, and a last backtracking offset. That way we just need lists of +-- contents and no need to maintain start/end pointers for individual arrays, +-- reducing bookkeeping work. --- | Parse a stream using the supplied ParserD 'PRD.Parser'. --- --- /Internal/ +-- | Parse a stream using the supplied 'Parser'. -- -{-# INLINE_NORMAL parseD #-} -parseD :: Monad m => PRD.Parser a m b -> Stream m a -> m (Either ParseError b) -parseD p = D.parseD p . toStreamD +{-# INLINE parseBreak #-} +parseBreak, parseBreakD :: Monad m => + PR.Parser a m b -> Stream m a -> m (Either ParseError b, Stream m a) +parseBreak = Drivers.parseBreak --- XXX Drive directly as parserK rather than converting to parserD first. +RENAME(parseBreakD,parseBreak) --- | Parse a stream using the supplied ParserK 'PRK.Parser'. +-- | Like 'parseBreak' but includes stream position information in the error +-- messages. -- --- /Internal/ ---{-# INLINE parseK #-} ---parseK :: Monad m => PRK.Parser a m b -> Stream m a -> m (Either ParseError b) ---parseK = parse +{-# INLINE parseBreakPos #-} +parseBreakPos :: Monad m => + PR.Parser a m b -> Stream m a -> m (Either ParseErrorPos b, Stream m a) +parseBreakPos = Drivers.parseBreakPos -- | Parse a stream using the supplied 'Parser'. -- @@ -242,25 +147,330 @@ -- Note: @parse p@ is not the same as @head . parseMany p@ on an empty stream. -- {-# INLINE [3] parse #-} -parse :: Monad m => Parser a m b -> Stream m a -> m (Either ParseError b) -parse = parseD +parse, parseD :: Monad m => PR.Parser a m b -> Stream m a -> m (Either ParseError b) +parse parser strm = do + (b, _) <- parseBreak parser strm + return b -{-# INLINE_NORMAL parseBreakD #-} -parseBreakD :: Monad m => - PRD.Parser a m b -> Stream m a -> m (Either ParseError b, Stream m a) -parseBreakD parser strm = do - (b, strmD) <- D.parseBreakD parser (toStreamD strm) - return $! (b, fromStreamD strmD) +RENAME(parseD,parse) --- | Parse a stream using the supplied 'Parser'. +-- | Like 'parse' but includes stream position information in the error +-- messages. -- --- /CPS/ +-- >>> Stream.parsePos (Parser.takeEQ 2 Fold.drain) (Stream.fromList [1]) +-- Left (ParseErrorPos 1 "takeEQ: Expecting exactly 2 elements, input terminated on 1") -- ---{-# INLINE parseBreak #-} ---parseBreak :: Monad m => Parser a m b -> Stream m a -> m (Either ParseError b, Stream m a) ---parseBreak p strm = D.parseBreak p strm +{-# INLINE [3] parsePos #-} +parsePos :: Monad m => PR.Parser a m b -> Stream m a -> m (Either ParseErrorPos b) +parsePos parser strm = do + (b, _) <- parseBreakPos parser strm + return b ------------------------------------------------------------------------------ +-- Specialized Folds +------------------------------------------------------------------------------ + +-- benchmark after dropping 1 item from stream or using unfolds +{-# INLINE_NORMAL null #-} +null :: Monad m => Stream m a -> m Bool +#ifdef USE_FOLDS_EVERYWHERE +null = fold Fold.null +#else +null = foldrM (\_ _ -> return False) (return True) +#endif + +{-# INLINE_NORMAL init #-} +init :: Monad m => Stream m a -> m (Maybe (Stream m a)) +init stream = do + r <- uncons stream + case r of + Nothing -> return Nothing + Just (h, Stream step1 state1) -> + return $ Just $ Stream step (h, state1) + + where + + step gst (a, s1) = do + res <- step1 (adaptState gst) s1 + return $ + case res of + Yield x s -> Yield a (x, s) + Skip s -> Skip (a, s) + Stop -> Stop + +-- | Same as: +-- +-- >>> tail = fmap (fmap snd) . Stream.uncons +-- +-- Does not fuse, has the same performance as the StreamK version. +-- +{-# INLINE_NORMAL tail #-} +tail :: Monad m => Stream m a -> m (Maybe (Stream m a)) +tail = fmap (fmap snd) . uncons +{- +tail (UnStream step state) = go SPEC state + where + go !_ st = do + r <- step defState st + case r of + Yield _ s -> return (Just $ Stream step s) + Skip s -> go SPEC s + Stop -> return Nothing +-} + +-- XXX will it fuse? need custom impl? +{-# INLINE_NORMAL last #-} +last :: Monad m => Stream m a -> m (Maybe a) +#ifdef USE_FOLDS_EVERYWHERE +last = fold Fold.last +#else +last = foldl' (\_ y -> Just y) Nothing +#endif + +-- XXX Use the foldrM based impl instead +{-# INLINE_NORMAL elem #-} +elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool +#ifdef USE_FOLDS_EVERYWHERE +elem e = fold (Fold.elem e) +#else +-- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m +elem e (Stream step state) = go SPEC state + where + go !_ st = do + r <- step defState st + case r of + Yield x s + | x == e -> return True + | otherwise -> go SPEC s + Skip s -> go SPEC s + Stop -> return False +#endif + +{-# INLINE_NORMAL notElem #-} +notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool +notElem e s = fmap not (e `elem` s) + +{-# INLINE_NORMAL all #-} +all :: Monad m => (a -> Bool) -> Stream m a -> m Bool +#ifdef USE_FOLDS_EVERYWHERE +all p = fold (Fold.all p) +#else +-- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m +all p (Stream step state) = go SPEC state + where + go !_ st = do + r <- step defState st + case r of + Yield x s + | p x -> go SPEC s + | otherwise -> return False + Skip s -> go SPEC s + Stop -> return True +#endif + +{-# INLINE_NORMAL any #-} +any :: Monad m => (a -> Bool) -> Stream m a -> m Bool +#ifdef USE_FOLDS_EVERYWHERE +any p = fold (Fold.any p) +#else +-- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m +any p (Stream step state) = go SPEC state + where + go !_ st = do + r <- step defState st + case r of + Yield x s + | p x -> return True + | otherwise -> go SPEC s + Skip s -> go SPEC s + Stop -> return False +#endif + +{-# INLINE_NORMAL maximum #-} +maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a) +#ifdef USE_FOLDS_EVERYWHERE +maximum = fold Fold.maximum +#else +maximum (Stream step state) = go SPEC Nothing' state + where + go !_ Nothing' st = do + r <- step defState st + case r of + Yield x s -> go SPEC (Just' x) s + Skip s -> go SPEC Nothing' s + Stop -> return Nothing + go !_ (Just' acc) st = do + r <- step defState st + case r of + Yield x s + | acc <= x -> go SPEC (Just' x) s + | otherwise -> go SPEC (Just' acc) s + Skip s -> go SPEC (Just' acc) s + Stop -> return (Just acc) +#endif + +{-# INLINE_NORMAL maximumBy #-} +maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a) +#ifdef USE_FOLDS_EVERYWHERE +maximumBy cmp = fold (Fold.maximumBy cmp) +#else +maximumBy cmp (Stream step state) = go SPEC Nothing' state + where + go !_ Nothing' st = do + r <- step defState st + case r of + Yield x s -> go SPEC (Just' x) s + Skip s -> go SPEC Nothing' s + Stop -> return Nothing + go !_ (Just' acc) st = do + r <- step defState st + case r of + Yield x s -> case cmp acc x of + GT -> go SPEC (Just' acc) s + _ -> go SPEC (Just' x) s + Skip s -> go SPEC (Just' acc) s + Stop -> return (Just acc) +#endif + +{-# INLINE_NORMAL minimum #-} +minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a) +#ifdef USE_FOLDS_EVERYWHERE +minimum = fold Fold.minimum +#else +minimum (Stream step state) = go SPEC Nothing' state + + where + + go !_ Nothing' st = do + r <- step defState st + case r of + Yield x s -> go SPEC (Just' x) s + Skip s -> go SPEC Nothing' s + Stop -> return Nothing + go !_ (Just' acc) st = do + r <- step defState st + case r of + Yield x s + | acc <= x -> go SPEC (Just' acc) s + | otherwise -> go SPEC (Just' x) s + Skip s -> go SPEC (Just' acc) s + Stop -> return (Just acc) +#endif + +{-# INLINE_NORMAL minimumBy #-} +minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a) +#ifdef USE_FOLDS_EVERYWHERE +minimumBy cmp = fold (Fold.minimumBy cmp) +#else +minimumBy cmp (Stream step state) = go SPEC Nothing' state + + where + + go !_ Nothing' st = do + r <- step defState st + case r of + Yield x s -> go SPEC (Just' x) s + Skip s -> go SPEC Nothing' s + Stop -> return Nothing + go !_ (Just' acc) st = do + r <- step defState st + case r of + Yield x s -> case cmp acc x of + GT -> go SPEC (Just' x) s + _ -> go SPEC (Just' acc) s + Skip s -> go SPEC (Just' acc) s + Stop -> return (Just acc) +#endif + +{-# INLINE_NORMAL (!!) #-} +(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a) +#ifdef USE_FOLDS_EVERYWHERE +stream !! i = fold (Fold.index i) stream +#else +(Stream step state) !! i = go SPEC i state + + where + + go !_ !n st = do + r <- step defState st + case r of + Yield x s | n < 0 -> return Nothing + | n == 0 -> return $ Just x + | otherwise -> go SPEC (n - 1) s + Skip s -> go SPEC n s + Stop -> return Nothing +#endif + +{-# INLINE_NORMAL lookup #-} +lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b) +#ifdef USE_FOLDS_EVERYWHERE +lookup e = fold (Fold.lookup e) +#else +lookup e = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs) + (return Nothing) +#endif + +{-# INLINE_NORMAL findM #-} +findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a) +#ifdef USE_FOLDS_EVERYWHERE +findM p = fold (Fold.findM p) +#else +findM p = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs) + (return Nothing) +#endif + +{-# INLINE find #-} +find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a) +find p = findM (return . p) + +{-# INLINE toListRev #-} +toListRev :: Monad m => Stream m a -> m [a] +#ifdef USE_FOLDS_EVERYWHERE +toListRev = fold Fold.toListRev +#else +toListRev = foldl' (flip (:)) [] +#endif + +------------------------------------------------------------------------------ +-- Transformation comprehensions +------------------------------------------------------------------------------ + +{-# INLINE_NORMAL the #-} +the :: (Eq a, Monad m) => Stream m a -> m (Maybe a) +#ifdef USE_FOLDS_EVERYWHERE +the = fold Fold.the +#else +the (Stream step state) = go SPEC state + where + go !_ st = do + r <- step defState st + case r of + Yield x s -> go' SPEC x s + Skip s -> go SPEC s + Stop -> return Nothing + go' !_ n st = do + r <- step defState st + case r of + Yield x s | x == n -> go' SPEC n s + | otherwise -> return Nothing + Skip s -> go' SPEC n s + Stop -> return (Just n) +#endif + +------------------------------------------------------------------------------ +-- Map and Fold +------------------------------------------------------------------------------ + +-- | Execute a monadic action for each element of the 'Stream' +{-# INLINE_NORMAL mapM_ #-} +mapM_ :: Monad m => (a -> m b) -> Stream m a -> m () +#ifdef USE_FOLDS_EVERYWHERE +mapM_ f = fold (Fold.drainBy f) +#else +mapM_ m = drain . mapM m +#endif + +------------------------------------------------------------------------------ -- Multi-stream folds ------------------------------------------------------------------------------ @@ -270,10 +480,91 @@ -- >>> Stream.isPrefixOf (Stream.fromList "hello") (Stream.fromList "hello" :: Stream IO Char) -- True -- -{-# INLINE isPrefixOf #-} +{-# INLINE_NORMAL isPrefixOf #-} isPrefixOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool -isPrefixOf m1 m2 = D.isPrefixOf (toStreamD m1) (toStreamD m2) +isPrefixOf (Stream stepa ta) (Stream stepb tb) = go SPEC Nothing' ta tb + where + + go !_ Nothing' sa sb = do + r <- stepa defState sa + case r of + Yield x sa' -> go SPEC (Just' x) sa' sb + Skip sa' -> go SPEC Nothing' sa' sb + Stop -> return True + + go !_ (Just' x) sa sb = do + r <- stepb defState sb + case r of + Yield y sb' -> + if x == y + then go SPEC Nothing' sa sb' + else return False + Skip sb' -> go SPEC (Just' x) sa sb' + Stop -> return False + +-- | Returns 'True' if all the elements of the first stream occur, in order, in +-- the second stream. The elements do not have to occur consecutively. A stream +-- is a subsequence of itself. +-- +-- >>> Stream.isSubsequenceOf (Stream.fromList "hlo") (Stream.fromList "hello" :: Stream IO Char) +-- True +-- +{-# INLINE_NORMAL isSubsequenceOf #-} +isSubsequenceOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool +isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go SPEC Nothing' ta tb + + where + + go !_ Nothing' sa sb = do + r <- stepa defState sa + case r of + Yield x sa' -> go SPEC (Just' x) sa' sb + Skip sa' -> go SPEC Nothing' sa' sb + Stop -> return True + + go !_ (Just' x) sa sb = do + r <- stepb defState sb + case r of + Yield y sb' -> + if x == y + then go SPEC Nothing' sa sb' + else go SPEC (Just' x) sa sb' + Skip sb' -> go SPEC (Just' x) sa sb' + Stop -> return False + +-- | @stripPrefix prefix input@ strips the @prefix@ stream from the @input@ +-- stream if it is a prefix of input. Returns 'Nothing' if the input does not +-- start with the given prefix, stripped input otherwise. Returns @Just nil@ +-- when the prefix is the same as the input stream. +-- +-- Space: @O(1)@ +-- +{-# INLINE_NORMAL stripPrefix #-} +stripPrefix + :: (Monad m, Eq a) + => Stream m a -> Stream m a -> m (Maybe (Stream m a)) +stripPrefix (Stream stepa ta) (Stream stepb tb) = go SPEC Nothing' ta tb + + where + + go !_ Nothing' sa sb = do + r <- stepa defState sa + case r of + Yield x sa' -> go SPEC (Just' x) sa' sb + Skip sa' -> go SPEC Nothing' sa' sb + Stop -> return $ Just (Stream stepb sb) + + go !_ (Just' x) sa sb = do + r <- stepb defState sb + case r of + Yield y sb' -> + if x == y + then go SPEC Nothing' sa sb' + else return Nothing + Skip sb' -> go SPEC (Just' x) sa sb' + Stop -> return Nothing + -- | Returns 'True' if the first stream is an infix of the second. A stream is -- considered an infix of itself. -- @@ -288,12 +579,12 @@ -- /Requires 'Storable' constraint/ -- {-# INLINE isInfixOf #-} -isInfixOf :: (MonadIO m, Eq a, Enum a, Storable a, Unbox a) +isInfixOf :: (MonadIO m, Eq a, Enum a, Unbox a) => Stream m a -> Stream m a -> m Bool isInfixOf infx stream = do - arr <- fold Array.write infx + arr <- fold Array.create infx -- XXX can use breakOnSeq instead (when available) - r <- D.null $ D.drop 1 $ D.splitOnSeq arr Fold.drain $ toStreamD stream + r <- null $ StreamD.drop 1 $ Nesting.splitSepBySeq_ arr Fold.drain stream return (not r) -- Note: isPrefixOf uses the prefix stream only once. In contrast, isSuffixOf @@ -326,36 +617,15 @@ -- {-# INLINE isSuffixOf #-} isSuffixOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool -isSuffixOf suffix stream = reverse suffix `isPrefixOf` reverse stream - --- | Returns 'True' if all the elements of the first stream occur, in order, in --- the second stream. The elements do not have to occur consecutively. A stream --- is a subsequence of itself. --- --- >>> Stream.isSubsequenceOf (Stream.fromList "hlo") (Stream.fromList "hello" :: Stream IO Char) --- True --- -{-# INLINE isSubsequenceOf #-} -isSubsequenceOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool -isSubsequenceOf m1 m2 = D.isSubsequenceOf (toStreamD m1) (toStreamD m2) - --- Note: If we want to return a Maybe value to know whether the --- suffix/infix was present or not along with the stripped stream then --- we need to buffer the whole input stream. +isSuffixOf suffix stream = + StreamD.reverse suffix `isPrefixOf` StreamD.reverse stream --- | @stripPrefix prefix input@ strips the @prefix@ stream from the @input@ --- stream if it is a prefix of input. Returns 'Nothing' if the input does not --- start with the given prefix, stripped input otherwise. Returns @Just nil@ --- when the prefix is the same as the input stream. --- --- Space: @O(1)@ --- -{-# INLINE stripPrefix #-} -stripPrefix - :: (Monad m, Eq a) - => Stream m a -> Stream m a -> m (Maybe (Stream m a)) -stripPrefix m1 m2 = fmap fromStreamD <$> - D.stripPrefix (toStreamD m1) (toStreamD m2) +-- | Much faster than 'isSuffixOf'. +{-# INLINE isSuffixOfUnbox #-} +isSuffixOfUnbox :: (MonadIO m, Eq a, Unbox a) => + Stream m a -> Stream m a -> m Bool +isSuffixOfUnbox suffix stream = + StreamD.reverseUnbox suffix `isPrefixOf` StreamD.reverseUnbox stream -- | Drops the given suffix from a stream. Returns 'Nothing' if the stream does -- not end with the given suffix. Returns @Just nil@ when the suffix is the @@ -365,8 +635,6 @@ -- stripSuffix on that especially if the elements have a Storable or Prim -- instance. -- --- See also "Streamly.Internal.Data.Stream.Reduce.dropSuffix". --- -- Space: @O(n)@, buffers the entire input stream as well as the suffix -- -- /Pre-release/ @@ -374,4 +642,15 @@ stripSuffix :: (Monad m, Eq a) => Stream m a -> Stream m a -> m (Maybe (Stream m a)) -stripSuffix m1 m2 = fmap reverse <$> stripPrefix (reverse m1) (reverse m2) +stripSuffix m1 m2 = + fmap StreamD.reverse + <$> stripPrefix (StreamD.reverse m1) (StreamD.reverse m2) + +-- | Much faster than 'stripSuffix'. +{-# INLINE stripSuffixUnbox #-} +stripSuffixUnbox + :: (MonadIO m, Eq a, Unbox a) + => Stream m a -> Stream m a -> m (Maybe (Stream m a)) +stripSuffixUnbox m1 m2 = + fmap StreamD.reverseUnbox + <$> stripPrefix (StreamD.reverseUnbox m1) (StreamD.reverseUnbox m2) diff --git a/src/Streamly/Internal/Data/Stream/Enumerate.hs b/src/Streamly/Internal/Data/Stream/Enumerate.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Enumerate.hs +++ /dev/null @@ -1,560 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Enumerate --- Copyright : (c) 2018 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- The functions defined in this module should be rarely needed for direct use, --- try to use the operations from the 'Enumerable' type class --- instances instead. --- --- This module provides an 'Enumerable' type class to enumerate 'Enum' types --- into a stream. The operations in this type class correspond to similar --- perations in the 'Enum' type class, the only difference is that they produce --- a stream instead of a list. These operations cannot be defined generically --- based on the 'Enum' type class. We provide instances for commonly used --- types. If instances for other types are needed convenience functions defined --- in this module can be used to define them. Alternatively, these functions --- can be used directly. - --- XXX The Unfold.Enumeration module is more modular, check the differences and --- reconcile the two. - -module Streamly.Internal.Data.Stream.Enumerate - ( - Enumerable (..) - - -- ** Enumerating 'Bounded' 'Enum' Types - , enumerate - , enumerateTo - , enumerateFromBounded - - -- ** Enumerating 'Enum' Types not larger than 'Int' - , enumerateFromToSmall - , enumerateFromThenToSmall - , enumerateFromThenSmallBounded - - -- ** Enumerating 'Bounded' 'Integral' Types - , enumerateFromIntegral - , enumerateFromThenIntegral - - -- ** Enumerating 'Integral' Types - , enumerateFromToIntegral - , enumerateFromThenToIntegral - - -- ** Enumerating unbounded 'Integral' Types - , enumerateFromStepIntegral - - -- ** Enumerating 'Fractional' Types - , enumerateFromFractional - , enumerateFromToFractional - , enumerateFromThenFractional - , enumerateFromThenToFractional - ) -where - -import Data.Fixed -import Data.Int -import Data.Ratio -import Data.Word -import Numeric.Natural -import Data.Functor.Identity (Identity(..)) - -import Streamly.Internal.Data.Stream.Type (Stream, fromStreamD) - -import qualified Streamly.Internal.Data.Stream.StreamD.Generate as D - --- $setup --- >>> import Streamly.Data.Fold as Fold --- >>> import Streamly.Internal.Data.Stream as Stream --- >>> import Streamly.Internal.Data.Stream.Enumerate as Stream - -------------------------------------------------------------------------------- --- Enumeration of Integral types -------------------------------------------------------------------------------- --- --- | @enumerateFromStepIntegral from step@ generates an infinite stream whose --- first element is @from@ and the successive elements are in increments of --- @step@. --- --- CAUTION: This function is not safe for finite integral types. It does not --- check for overflow, underflow or bounds. --- --- @ --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromStepIntegral 0 2 --- [0,2,4,6] --- --- >>> Stream.fold Fold.toList $ Stream.take 3 $ Stream.enumerateFromStepIntegral 0 (-2) --- [0,-2,-4] --- --- @ --- -{-# INLINE enumerateFromStepIntegral #-} -enumerateFromStepIntegral - :: (Monad m, Integral a) - => a -> a -> Stream m a -enumerateFromStepIntegral from stride = - fromStreamD $ D.enumerateFromStepIntegral from stride - --- | Enumerate an 'Integral' type. @enumerateFromIntegral from@ generates a --- stream whose first element is @from@ and the successive elements are in --- increments of @1@. The stream is bounded by the size of the 'Integral' type. --- --- @ --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromIntegral (0 :: Int) --- [0,1,2,3] --- --- @ --- -{-# INLINE enumerateFromIntegral #-} -enumerateFromIntegral - :: (Monad m, Integral a, Bounded a) - => a -> Stream m a -enumerateFromIntegral from = fromStreamD $ D.enumerateFromIntegral from - --- | Enumerate an 'Integral' type in steps. @enumerateFromThenIntegral from --- then@ generates a stream whose first element is @from@, the second element --- is @then@ and the successive elements are in increments of @then - from@. --- The stream is bounded by the size of the 'Integral' type. --- --- @ --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThenIntegral (0 :: Int) 2 --- [0,2,4,6] --- --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThenIntegral (0 :: Int) (-2) --- [0,-2,-4,-6] --- --- @ --- -{-# INLINE enumerateFromThenIntegral #-} -enumerateFromThenIntegral - :: (Monad m, Integral a, Bounded a) - => a -> a -> Stream m a -enumerateFromThenIntegral from next = - fromStreamD $ D.enumerateFromThenIntegral from next - --- | Enumerate an 'Integral' type up to a given limit. --- @enumerateFromToIntegral from to@ generates a finite stream whose first --- element is @from@ and successive elements are in increments of @1@ up to --- @to@. --- --- @ --- >>> Stream.fold Fold.toList $ Stream.enumerateFromToIntegral 0 4 --- [0,1,2,3,4] --- --- @ --- -{-# INLINE enumerateFromToIntegral #-} -enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a -enumerateFromToIntegral from to = - fromStreamD $ D.enumerateFromToIntegral from to - --- | Enumerate an 'Integral' type in steps up to a given limit. --- @enumerateFromThenToIntegral from then to@ generates a finite stream whose --- first element is @from@, the second element is @then@ and the successive --- elements are in increments of @then - from@ up to @to@. --- --- @ --- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenToIntegral 0 2 6 --- [0,2,4,6] --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenToIntegral 0 (-2) (-6) --- [0,-2,-4,-6] --- --- @ --- -{-# INLINE enumerateFromThenToIntegral #-} -enumerateFromThenToIntegral - :: (Monad m, Integral a) - => a -> a -> a -> Stream m a -enumerateFromThenToIntegral from next to = - fromStreamD $ D.enumerateFromThenToIntegral from next to - -------------------------------------------------------------------------------- --- Enumeration of Fractional types -------------------------------------------------------------------------------- --- --- Even though the underlying implementation of enumerateFromFractional and --- enumerateFromThenFractional works for any 'Num' we have restricted these to --- 'Fractional' because these do not perform any bounds check, in contrast to --- integral versions and are therefore not equivalent substitutes for those. --- --- | Numerically stable enumeration from a 'Fractional' number in steps of size --- @1@. @enumerateFromFractional from@ generates a stream whose first element --- is @from@ and the successive elements are in increments of @1@. No overflow --- or underflow checks are performed. --- --- This is the equivalent to 'enumFrom' for 'Fractional' types. For example: --- --- @ --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromFractional 1.1 --- [1.1,2.1,3.1,4.1] --- --- @ --- --- -{-# INLINE enumerateFromFractional #-} -enumerateFromFractional :: (Monad m, Fractional a) => a -> Stream m a -enumerateFromFractional from = fromStreamD $ D.enumerateFromNum from - --- | Numerically stable enumeration from a 'Fractional' number in steps. --- @enumerateFromThenFractional from then@ generates a stream whose first --- element is @from@, the second element is @then@ and the successive elements --- are in increments of @then - from@. No overflow or underflow checks are --- performed. --- --- This is the equivalent of 'enumFromThen' for 'Fractional' types. For --- example: --- --- @ --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThenFractional 1.1 2.1 --- [1.1,2.1,3.1,4.1] --- --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThenFractional 1.1 (-2.1) --- [1.1,-2.1,-5.300000000000001,-8.500000000000002] --- --- @ --- -{-# INLINE enumerateFromThenFractional #-} -enumerateFromThenFractional - :: (Monad m, Fractional a) - => a -> a -> Stream m a -enumerateFromThenFractional from next = fromStreamD $ D.enumerateFromThenNum from next - --- | Numerically stable enumeration from a 'Fractional' number to a given --- limit. @enumerateFromToFractional from to@ generates a finite stream whose --- first element is @from@ and successive elements are in increments of @1@ up --- to @to@. --- --- This is the equivalent of 'enumFromTo' for 'Fractional' types. For --- example: --- --- @ --- >>> Stream.fold Fold.toList $ Stream.enumerateFromToFractional 1.1 4 --- [1.1,2.1,3.1,4.1] --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromToFractional 1.1 4.6 --- [1.1,2.1,3.1,4.1,5.1] --- --- @ --- --- Notice that the last element is equal to the specified @to@ value after --- rounding to the nearest integer. --- -{-# INLINE enumerateFromToFractional #-} -enumerateFromToFractional - :: (Monad m, Fractional a, Ord a) - => a -> a -> Stream m a -enumerateFromToFractional from to = - fromStreamD $ D.enumerateFromToFractional from to - --- | Numerically stable enumeration from a 'Fractional' number in steps up to a --- given limit. @enumerateFromThenToFractional from then to@ generates a --- finite stream whose first element is @from@, the second element is @then@ --- and the successive elements are in increments of @then - from@ up to @to@. --- --- This is the equivalent of 'enumFromThenTo' for 'Fractional' types. For --- example: --- --- @ --- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenToFractional 0.1 2 6 --- [0.1,2.0,3.9,5.799999999999999] --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenToFractional 0.1 (-2) (-6) --- [0.1,-2.0,-4.1000000000000005,-6.200000000000001] --- --- @ --- --- -{-# INLINE enumerateFromThenToFractional #-} -enumerateFromThenToFractional - :: (Monad m, Fractional a, Ord a) - => a -> a -> a -> Stream m a -enumerateFromThenToFractional from next to = - fromStreamD $ D.enumerateFromThenToFractional from next to - -------------------------------------------------------------------------------- --- Enumeration of Enum types not larger than Int -------------------------------------------------------------------------------- --- --- | 'enumerateFromTo' for 'Enum' types not larger than 'Int'. --- -{-# INLINE enumerateFromToSmall #-} -enumerateFromToSmall :: (Monad m, Enum a) => a -> a -> Stream m a -enumerateFromToSmall from to = - fmap toEnum - $ enumerateFromToIntegral (fromEnum from) (fromEnum to) - --- | 'enumerateFromThenTo' for 'Enum' types not larger than 'Int'. --- -{-# INLINE enumerateFromThenToSmall #-} -enumerateFromThenToSmall :: (Monad m, Enum a) - => a -> a -> a -> Stream m a -enumerateFromThenToSmall from next to = - fmap toEnum - $ enumerateFromThenToIntegral - (fromEnum from) (fromEnum next) (fromEnum to) - --- | 'enumerateFromThen' for 'Enum' types not larger than 'Int'. --- --- Note: We convert the 'Enum' to 'Int' and enumerate the 'Int'. If a --- type is bounded but does not have a 'Bounded' instance then we can go on --- enumerating it beyond the legal values of the type, resulting in the failure --- of 'toEnum' when converting back to 'Enum'. Therefore we require a 'Bounded' --- instance for this function to be safely used. --- -{-# INLINE enumerateFromThenSmallBounded #-} -enumerateFromThenSmallBounded :: (Monad m, Enumerable a, Bounded a) - => a -> a -> Stream m a -enumerateFromThenSmallBounded from next = - if fromEnum next >= fromEnum from - then enumerateFromThenTo from next maxBound - else enumerateFromThenTo from next minBound - -------------------------------------------------------------------------------- --- Enumerable type class -------------------------------------------------------------------------------- --- --- NOTE: We would like to rewrite calls to fromList [1..] etc. to stream --- enumerations like this: --- --- {-# RULES "fromList enumFrom" [1] --- forall (a :: Int). D.fromList (enumFrom a) = D.enumerateFromIntegral a #-} --- --- But this does not work because enumFrom is a class method and GHC rewrites --- it quickly, so we do not get a chance to have our rule fired. - --- | Types that can be enumerated as a stream. The operations in this type --- class are equivalent to those in the 'Enum' type class, except that these --- generate a stream instead of a list. Use the functions in --- "Streamly.Internal.Data.Stream.Enumeration" module to define new instances. --- -class Enum a => Enumerable a where - -- | @enumerateFrom from@ generates a stream starting with the element - -- @from@, enumerating up to 'maxBound' when the type is 'Bounded' or - -- generating an infinite stream when the type is not 'Bounded'. - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFrom (0 :: Int) - -- [0,1,2,3] - -- - -- @ - -- - -- For 'Fractional' types, enumeration is numerically stable. However, no - -- overflow or underflow checks are performed. - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFrom 1.1 - -- [1.1,2.1,3.1,4.1] - -- - -- @ - -- - enumerateFrom :: (Monad m) => a -> Stream m a - - -- | Generate a finite stream starting with the element @from@, enumerating - -- the type up to the value @to@. If @to@ is smaller than @from@ then an - -- empty stream is returned. - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromTo 0 4 - -- [0,1,2,3,4] - -- - -- @ - -- - -- For 'Fractional' types, the last element is equal to the specified @to@ - -- value after rounding to the nearest integral value. - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromTo 1.1 4 - -- [1.1,2.1,3.1,4.1] - -- - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromTo 1.1 4.6 - -- [1.1,2.1,3.1,4.1,5.1] - -- - -- @ - -- - enumerateFromTo :: (Monad m) => a -> a -> Stream m a - - -- | @enumerateFromThen from then@ generates a stream whose first element - -- is @from@, the second element is @then@ and the successive elements are - -- in increments of @then - from@. Enumeration can occur downwards or - -- upwards depending on whether @then@ comes before or after @from@. For - -- 'Bounded' types the stream ends when 'maxBound' is reached, for - -- unbounded types it keeps enumerating infinitely. - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThen 0 2 - -- [0,2,4,6] - -- - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThen 0 (-2) - -- [0,-2,-4,-6] - -- - -- @ - -- - enumerateFromThen :: (Monad m) => a -> a -> Stream m a - - -- | @enumerateFromThenTo from then to@ generates a finite stream whose - -- first element is @from@, the second element is @then@ and the successive - -- elements are in increments of @then - from@ up to @to@. Enumeration can - -- occur downwards or upwards depending on whether @then@ comes before or - -- after @from@. - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenTo 0 2 6 - -- [0,2,4,6] - -- - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenTo 0 (-2) (-6) - -- [0,-2,-4,-6] - -- - -- @ - -- - enumerateFromThenTo :: (Monad m) => a -> a -> a -> Stream m a - --- MAYBE: Sometimes it is more convenient to know the count rather then the --- ending or starting element. For those cases we can define the folllowing --- APIs. All of these will work only for bounded types if we represent the --- count by Int. --- --- enumerateN --- enumerateFromN --- enumerateToN --- enumerateFromStep --- enumerateFromStepN - -------------------------------------------------------------------------------- --- Convenient functions for bounded types -------------------------------------------------------------------------------- --- --- | --- > enumerate = enumerateFrom minBound --- --- Enumerate a 'Bounded' type from its 'minBound' to 'maxBound' --- -{-# INLINE enumerate #-} -enumerate :: (Monad m, Bounded a, Enumerable a) => Stream m a -enumerate = enumerateFrom minBound - --- | --- > enumerateTo = enumerateFromTo minBound --- --- Enumerate a 'Bounded' type from its 'minBound' to specified value. --- -{-# INLINE enumerateTo #-} -enumerateTo :: (Monad m, Bounded a, Enumerable a) => a -> Stream m a -enumerateTo = enumerateFromTo minBound - --- | --- > enumerateFromBounded = enumerateFromTo from maxBound --- --- 'enumerateFrom' for 'Bounded' 'Enum' types. --- -{-# INLINE enumerateFromBounded #-} -enumerateFromBounded :: (Monad m, Enumerable a, Bounded a) - => a -> Stream m a -enumerateFromBounded from = enumerateFromTo from maxBound - -------------------------------------------------------------------------------- --- Enumerable Instances -------------------------------------------------------------------------------- --- --- For Enum types smaller than or equal to Int size. -#define ENUMERABLE_BOUNDED_SMALL(SMALL_TYPE) \ -instance Enumerable SMALL_TYPE where { \ - {-# INLINE enumerateFrom #-}; \ - enumerateFrom = enumerateFromBounded; \ - {-# INLINE enumerateFromThen #-}; \ - enumerateFromThen = enumerateFromThenSmallBounded; \ - {-# INLINE enumerateFromTo #-}; \ - enumerateFromTo = enumerateFromToSmall; \ - {-# INLINE enumerateFromThenTo #-}; \ - enumerateFromThenTo = enumerateFromThenToSmall } - - -ENUMERABLE_BOUNDED_SMALL(()) -ENUMERABLE_BOUNDED_SMALL(Bool) -ENUMERABLE_BOUNDED_SMALL(Ordering) -ENUMERABLE_BOUNDED_SMALL(Char) - --- For bounded Integral Enum types, may be larger than Int. -#define ENUMERABLE_BOUNDED_INTEGRAL(INTEGRAL_TYPE) \ -instance Enumerable INTEGRAL_TYPE where { \ - {-# INLINE enumerateFrom #-}; \ - enumerateFrom = enumerateFromIntegral; \ - {-# INLINE enumerateFromThen #-}; \ - enumerateFromThen = enumerateFromThenIntegral; \ - {-# INLINE enumerateFromTo #-}; \ - enumerateFromTo = enumerateFromToIntegral; \ - {-# INLINE enumerateFromThenTo #-}; \ - enumerateFromThenTo = enumerateFromThenToIntegral } - -ENUMERABLE_BOUNDED_INTEGRAL(Int) -ENUMERABLE_BOUNDED_INTEGRAL(Int8) -ENUMERABLE_BOUNDED_INTEGRAL(Int16) -ENUMERABLE_BOUNDED_INTEGRAL(Int32) -ENUMERABLE_BOUNDED_INTEGRAL(Int64) -ENUMERABLE_BOUNDED_INTEGRAL(Word) -ENUMERABLE_BOUNDED_INTEGRAL(Word8) -ENUMERABLE_BOUNDED_INTEGRAL(Word16) -ENUMERABLE_BOUNDED_INTEGRAL(Word32) -ENUMERABLE_BOUNDED_INTEGRAL(Word64) - --- For unbounded Integral Enum types. -#define ENUMERABLE_UNBOUNDED_INTEGRAL(INTEGRAL_TYPE) \ -instance Enumerable INTEGRAL_TYPE where { \ - {-# INLINE enumerateFrom #-}; \ - enumerateFrom from = enumerateFromStepIntegral from 1; \ - {-# INLINE enumerateFromThen #-}; \ - enumerateFromThen from next = \ - enumerateFromStepIntegral from (next - from); \ - {-# INLINE enumerateFromTo #-}; \ - enumerateFromTo = enumerateFromToIntegral; \ - {-# INLINE enumerateFromThenTo #-}; \ - enumerateFromThenTo = enumerateFromThenToIntegral } - -ENUMERABLE_UNBOUNDED_INTEGRAL(Integer) -ENUMERABLE_UNBOUNDED_INTEGRAL(Natural) - -#define ENUMERABLE_FRACTIONAL(FRACTIONAL_TYPE,CONSTRAINT) \ -instance (CONSTRAINT) => Enumerable FRACTIONAL_TYPE where { \ - {-# INLINE enumerateFrom #-}; \ - enumerateFrom = enumerateFromFractional; \ - {-# INLINE enumerateFromThen #-}; \ - enumerateFromThen = enumerateFromThenFractional; \ - {-# INLINE enumerateFromTo #-}; \ - enumerateFromTo = enumerateFromToFractional; \ - {-# INLINE enumerateFromThenTo #-}; \ - enumerateFromThenTo = enumerateFromThenToFractional } - -ENUMERABLE_FRACTIONAL(Float,) -ENUMERABLE_FRACTIONAL(Double,) -ENUMERABLE_FRACTIONAL((Fixed a),HasResolution a) -ENUMERABLE_FRACTIONAL((Ratio a),Integral a) - -instance Enumerable a => Enumerable (Identity a) where - {-# INLINE enumerateFrom #-} - enumerateFrom (Identity from) = - fmap Identity $ enumerateFrom from - {-# INLINE enumerateFromThen #-} - enumerateFromThen (Identity from) (Identity next) = - fmap Identity $ enumerateFromThen from next - {-# INLINE enumerateFromTo #-} - enumerateFromTo (Identity from) (Identity to) = - fmap Identity $ enumerateFromTo from to - {-# INLINE enumerateFromThenTo #-} - enumerateFromThenTo (Identity from) (Identity next) (Identity to) = - fmap Identity - $ enumerateFromThenTo from next to - --- TODO -{- -instance Enumerable a => Enumerable (Last a) -instance Enumerable a => Enumerable (First a) -instance Enumerable a => Enumerable (Max a) -instance Enumerable a => Enumerable (Min a) -instance Enumerable a => Enumerable (Const a b) -instance Enumerable (f a) => Enumerable (Alt f a) -instance Enumerable (f a) => Enumerable (Ap f a) --} diff --git a/src/Streamly/Internal/Data/Stream/Exception.hs b/src/Streamly/Internal/Data/Stream/Exception.hs --- a/src/Streamly/Internal/Data/Stream/Exception.hs +++ b/src/Streamly/Internal/Data/Stream/Exception.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Internal.Data.Stream.Exception --- Copyright : (c) 2019 Composewell Technologies +-- Copyright : (c) 2020 Composewell Technologies and Contributors -- License : BSD-3-Clause -- Maintainer : streamly@composewell.com -- Stability : experimental @@ -8,46 +9,209 @@ module Streamly.Internal.Data.Stream.Exception ( + -- * Resources before - , afterUnsafe , afterIO + , afterUnsafe + , finallyIO + , finallyIO' + , finallyIO'' + , finallyUnsafe + , gbracket_ + , gbracket , bracketUnsafe - , bracketIO , bracketIO3 + , bracketIO + , bracketIO' + , bracketIO'' + + , withAcquireIO + , withAcquireIO' + + -- * Exceptions , onException - , finallyUnsafe - , finallyIO , ghandle , handle ) where -import Control.Exception (Exception) +#include "inline.hs" + +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Exception (Exception, SomeException, mask_) import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO) -import Streamly.Internal.Data.Stream.Type (Stream, fromStreamD, toStreamD) +import Data.IORef (newIORef) +import GHC.Exts (inline) +import Streamly.Internal.Control.Exception + (AcquireIO(..), acquire, allocator, releaser) +import Streamly.Internal.Data.IOFinalizer + (newIOFinalizer, runIOFinalizer, clearingIOFinalizer) -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Control.Monad.Catch as MC +import qualified Data.IntMap.Strict as Map --- $setup --- >>> :m --- >>> import qualified Streamly.Internal.Data.Stream as Stream +import Streamly.Internal.Data.Stream.Type ------------------------------------------------------------------------------- --- Exceptions ------------------------------------------------------------------------------- +#include "DocTestDataStream.hs" +data GbracketState s1 s2 v + = GBracketInit + | GBracketNormal s1 v + | GBracketException s2 + +-- | Like 'gbracket' but with following differences: +-- +-- * alloc action @m c@ runs with async exceptions enabled +-- * cleanup action @c -> m d@ won't run if the stream is garbage collected +-- after partial evaluation. +-- +-- /Inhibits stream fusion/ +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL gbracket_ #-} +gbracket_ + :: Monad m + => m c -- ^ before + -> (c -> m d) -- ^ after, on normal stop + -> (c -> e -> Stream m b -> m (Stream m b)) -- ^ on exception + -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) + -> (c -> Stream m b) -- ^ stream generator + -> Stream m b +gbracket_ bef aft onExc ftry action = + Stream step GBracketInit + + where + + {-# INLINE_LATE step #-} + step _ GBracketInit = do + r <- bef + return $ Skip $ GBracketNormal (action r) r + + step gst (GBracketNormal (UnStream step1 st) v) = do + res <- ftry $ step1 gst st + case res of + Right r -> case r of + Yield x s -> + return $ Yield x (GBracketNormal (Stream step1 s) v) + Skip s -> return $ Skip (GBracketNormal (Stream step1 s) v) + Stop -> aft v >> return Stop + -- XXX Do not handle async exceptions, just rethrow them. + Left e -> do + strm <- onExc v e (UnStream step1 st) + return $ Skip (GBracketException strm) + step gst (GBracketException (UnStream step1 st)) = do + res <- step1 gst st + case res of + Yield x s -> return $ Yield x (GBracketException (Stream step1 s)) + Skip s -> return $ Skip (GBracketException (Stream step1 s)) + Stop -> return Stop + +data GbracketIOState s1 s2 v wref + = GBracketIOInit + | GBracketIONormal s1 v wref + | GBracketIOException s2 + +-- | Run the alloc action @m c@ with async exceptions disabled but keeping +-- blocking operations interruptible (see 'Control.Exception.mask'). Use the +-- output @c@ as input to @c -> Stream m b@ to generate an output stream. When +-- generating the stream use the supplied @try@ operation @forall s. m s -> m +-- (Either e s)@ to catch synchronous exceptions. If an exception occurs run +-- the exception handler @c -> e -> Stream m b -> m (Stream m b)@. Note that +-- 'gbracket' does not rethrow the exception, it has to be done by the +-- exception handler if desired. +-- +-- The cleanup action @c -> m d@, runs whenever the stream ends normally, due +-- to a sync or async exception or if it gets garbage collected after a partial +-- lazy evaluation. See 'bracket' for the semantics of the cleanup action. +-- +-- 'gbracket' can express all other exception handling combinators. +-- +-- /Inhibits stream fusion/ +-- +-- /Pre-release/ +{-# INLINE_NORMAL gbracket #-} +gbracket + :: MonadIO m + => IO c -- ^ before + -> (c -> IO d1) -- ^ on normal stop + -> (c -> e -> Stream m b -> IO (Stream m b)) -- ^ on exception + -> (c -> IO d2) -- ^ on GC without normal stop or exception + -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) + -> (c -> Stream m b) -- ^ stream generator + -> Stream m b +gbracket bef aft onExc onGC ftry action = + Stream step GBracketIOInit + + where + + -- If the stream is never evaluated the "aft" action will never be + -- called. For that to occur we will need the user of this API to pass a + -- weak pointer to us. + {-# INLINE_LATE step #-} + step _ GBracketIOInit = do + -- allocation of resource and installation of finalizer must be atomic + -- with respect to async exception, otherwise we may leave a window + -- where the resource may not be freed. + (r, ref) <- liftIO $ mask_ $ do + r <- bef + ref <- newIOFinalizer (onGC r) + return (r, ref) + return $ Skip $ GBracketIONormal (action r) r ref + + step gst (GBracketIONormal (UnStream step1 st) v ref) = do + -- IMPORTANT: Note that if an async exception occurs before try or + -- after try, in those cases the exception will not be intercepted and + -- the cleanup handler won't run. In those cases the cleanup handler + -- will run via GC. + res <- ftry $ step1 gst st + case res of + Right r -> case r of + Yield x s -> + return $ Yield x (GBracketIONormal (Stream step1 s) v ref) + Skip s -> + return $ Skip (GBracketIONormal (Stream step1 s) v ref) + Stop -> + liftIO (clearingIOFinalizer ref (aft v)) >> return Stop + -- XXX Do not handle async exceptions, just rethrow them. + Left e -> do + -- Clearing of finalizer and running of exception handler must + -- be atomic wrt async exceptions. Otherwise if we have cleared + -- the finalizer and have not run the exception handler then we + -- may leak the resource. + stream <- + liftIO (clearingIOFinalizer ref (onExc v e (UnStream step1 st))) + return $ Skip (GBracketIOException stream) + step gst (GBracketIOException (UnStream step1 st)) = do + res <- step1 gst st + case res of + Yield x s -> + return $ Yield x (GBracketIOException (Stream step1 s)) + Skip s -> return $ Skip (GBracketIOException (Stream step1 s)) + Stop -> return Stop + -- | Run the action @m b@ before the stream yields its first element. -- -- Same as the following but more efficient due to fusion: -- --- >>> before action xs = Stream.nilM action <> xs -- >>> before action xs = Stream.concatMap (const xs) (Stream.fromEffect action) -- -{-# INLINE before #-} +{-# INLINE_NORMAL before #-} before :: Monad m => m b -> Stream m a -> Stream m a -before action xs = fromStreamD $ D.before action $ toStreamD xs +before action (Stream step state) = Stream step' Nothing + where + + {-# INLINE_LATE step' #-} + step' _ Nothing = action >> return (Skip (Just state)) + + step' gst (Just st) = do + res <- step gst st + case res of + Yield x s -> return $ Yield x (Just s) + Skip s -> return $ Skip (Just s) + Stop -> return Stop + -- | Like 'after', with following differences: -- -- * action @m b@ won't run if the stream is garbage collected @@ -61,10 +225,20 @@ -- -- /Pre-release/ -- -{-# INLINE afterUnsafe #-} +{-# INLINE_NORMAL afterUnsafe #-} afterUnsafe :: Monad m => m b -> Stream m a -> Stream m a -afterUnsafe action xs = fromStreamD $ D.afterUnsafe action $ toStreamD xs +afterUnsafe action (Stream step state) = Stream step' state + where + + {-# INLINE_LATE step' #-} + step' gst st = do + res <- step gst st + case res of + Yield x s -> return $ Yield x s + Skip s -> return $ Skip s + Stop -> action >> return Stop + -- | Run the action @IO b@ whenever the stream is evaluated to completion, or -- if it is garbage collected after a partial lazy evaluation. -- @@ -73,51 +247,61 @@ -- -- /See also 'afterUnsafe'/ -- -{-# INLINE afterIO #-} -afterIO :: MonadIO m => IO b -> Stream m a -> Stream m a -afterIO action xs = fromStreamD $ D.afterIO action $ toStreamD xs +{-# INLINE_NORMAL afterIO #-} +afterIO :: MonadIO m + => IO b -> Stream m a -> Stream m a +afterIO action (Stream step state) = Stream step' Nothing + where + + {-# INLINE_LATE step' #-} + step' _ Nothing = do + ref <- liftIO $ newIOFinalizer action + return $ Skip $ Just (state, ref) + step' gst (Just (st, ref)) = do + res <- step gst st + case res of + Yield x s -> return $ Yield x (Just (s, ref)) + Skip s -> return $ Skip (Just (s, ref)) + Stop -> do + runIOFinalizer ref + return Stop + +-- XXX For high performance error checks in busy streams we may need another +-- Error constructor in step. + -- | Run the action @m b@ if the stream evaluation is aborted due to an -- exception. The exception is not caught, simply rethrown. -- +-- Observes exceptions only in the stream generation, and not in stream +-- consumers. +-- -- /Inhibits stream fusion/ -- -{-# INLINE onException #-} +{-# INLINE_NORMAL onException #-} onException :: MonadCatch m => m b -> Stream m a -> Stream m a -onException action xs = fromStreamD $ D.onException action $ toStreamD xs +onException action stream = + gbracket_ + (return ()) -- before + return -- after + (\_ (e :: MC.SomeException) _ -> action >> MC.throwM e) + (inline MC.try) + (const stream) --- | Like 'finally' with following differences: --- --- * action @m b@ won't run if the stream is garbage collected --- after partial evaluation. --- * has slightly better performance than 'finallyIO'. --- --- /Inhibits stream fusion/ --- --- /Pre-release/ --- -{-# INLINE finallyUnsafe #-} -finallyUnsafe :: MonadCatch m => m b -> Stream m a -> Stream m a -finallyUnsafe action xs = fromStreamD $ D.finallyUnsafe action $ toStreamD xs +{-# INLINE_NORMAL _onException #-} +_onException :: MonadCatch m => m b -> Stream m a -> Stream m a +_onException action (Stream step state) = Stream step' state --- | Run the action @IO b@ whenever the stream stream stops normally, aborts --- due to an exception or if it is garbage collected after a partial lazy --- evaluation. --- --- The semantics of running the action @IO b@ are similar to the cleanup action --- semantics described in 'bracketIO'. --- --- >>> finallyIO release = Stream.bracketIO (return ()) (const release) --- --- /See also 'finallyUnsafe'/ --- --- /Inhibits stream fusion/ --- -{-# INLINE finallyIO #-} -finallyIO :: (MonadIO m, MonadCatch m) => - IO b -> Stream m a -> Stream m a -finallyIO action xs = fromStreamD $ D.finallyIO action $ toStreamD xs + where + {-# INLINE_LATE step' #-} + step' gst st = do + res <- step gst st `MC.onException` action + case res of + Yield x s -> return $ Yield x s + Skip s -> return $ Skip s + Stop -> return Stop + -- | Like 'bracket' but with following differences: -- -- * alloc action @m b@ runs with async exceptions enabled @@ -129,41 +313,22 @@ -- -- /Pre-release/ -- -{-# INLINE bracketUnsafe #-} +{-# INLINE_NORMAL bracketUnsafe #-} bracketUnsafe :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a -bracketUnsafe bef aft bet = fromStreamD $ D.bracketUnsafe bef aft (toStreamD . bet) - --- | Run the alloc action @IO b@ with async exceptions disabled but keeping --- blocking operations interruptible (see 'Control.Exception.mask'). Use the --- output @b@ as input to @b -> Stream m a@ to generate an output stream. --- --- @b@ is usually a resource under the IO monad, e.g. a file handle, that --- requires a cleanup after use. The cleanup action @b -> IO c@, runs whenever --- the stream ends normally, due to a sync or async exception or if it gets --- garbage collected after a partial lazy evaluation. --- --- 'bracketIO' only guarantees that the cleanup action runs, and it runs with --- async exceptions enabled. The action must ensure that it can successfully --- cleanup the resource in the face of sync or async exceptions. --- --- When the stream ends normally or on a sync exception, cleanup action runs --- immediately in the current thread context, whereas in other cases it runs in --- the GC context, therefore, cleanup may be delayed until the GC gets to run. --- --- /See also: 'bracketUnsafe'/ --- --- /Inhibits stream fusion/ --- -{-# INLINE bracketIO #-} -bracketIO :: (MonadIO m, MonadCatch m) - => IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a -bracketIO bef aft = bracketIO3 bef aft aft aft +bracketUnsafe bef aft = + gbracket_ + bef + aft + (\a (e :: SomeException) _ -> aft a >> MC.throwM e) + (inline MC.try) -- For a use case of this see the "streamly-process" package. It needs to kill -- the process in case of exception or garbage collection, but waits for the -- process to terminate in normal cases. +-- XXX Just use bracketIO2 instead - stop and exception. + -- | Like 'bracketIO' but can use 3 separate cleanup actions depending on the -- mode of termination: -- @@ -176,20 +341,393 @@ -- stream is abandoned @onGC@ is executed, if the stream encounters an -- exception @onException@ is executed. -- +-- The exception is not caught, it is rethrown. +-- -- /Inhibits stream fusion/ -- -- /Pre-release/ -{-# INLINE bracketIO3 #-} -bracketIO3 :: (MonadIO m, MonadCatch m) - => IO b +{-# INLINE_NORMAL bracketIO3 #-} +bracketIO3 :: (MonadIO m, MonadCatch m) => + IO b -> (b -> IO c) -> (b -> IO d) -> (b -> IO e) -> (b -> Stream m a) -> Stream m a -bracketIO3 bef aft gc exc bet = fromStreamD $ - D.bracketIO3 bef aft exc gc (toStreamD . bet) +bracketIO3 bef aft onExc onGC = + gbracket + bef + aft + (\a (e :: SomeException) _ -> onExc a >> MC.throwM e) + onGC + (inline MC.try) +-- XXX Fix the early termination case not being prompt. Will require a "final" +-- function in the stream constructor. + +-- Examples of cases where the stream is not fully consumed: +-- +-- * a bracketed stream is folded but before the stream ends, the fold +-- terminates or encounters an exception abandoning the original stream. +-- * 'take' on a bracketed stream terminates without draining the stream +-- completely. To avoid this, bracket should be outermost combinator on a +-- stream. +-- * A synchronous exception is handled using 'handle', in that case the +-- original stream is abandoned and collected by GC. +-- +-- In case of async exceptions, if the async exception occurs when we are +-- executing the stream code then it will be intercepted. After the stream +-- element is generated, control is handed over to the consumer (fold), async +-- exceptions occurring in this period are not intercepted by bracketIO, they +-- are intercepted by the fold's bracket instead. If an async exceptions occurs +-- in this part and the stream is abandoned, the cleanup handler runs on GC. + +-- | The alloc action @IO b@ is executed with async exceptions disabled but keeping +-- blocking operations interruptible (see 'Control.Exception.mask'). Uses the +-- output @b@ of the IO action as input to the function @b -> Stream m a@ to +-- generate an output stream. +-- +-- @b@ is usually a resource allocated under the IO monad, e.g. a file handle, that +-- requires a cleanup after use. The cleanup is done using the @b -> IO c@ +-- action. bracketIO guarantees that the allocated resource is eventually (see +-- details below) cleaned up even in the face of sync or async exceptions. If +-- an exception occurs it is not caught, simply rethrown. +-- +-- 'bracketIO' only guarantees that the cleanup action runs, and it runs with +-- __async exceptions enabled__. The action must ensure that it can successfully +-- cleanup the resource in the face of sync or async exceptions. +-- +-- /Best case/: Cleanup happens immediately in the following cases: +-- +-- * the stream is consumed completely +-- * an exception occurs in the bracketed part of the pipeline +-- +-- /Worst case/: In the following cases cleanup is deferred to GC. +-- +-- * the bracketed stream is partially consumed and abandoned +-- * pipeline is aborted due to an exception outside the bracket +-- +-- Use Streamly.Control.Exception.'Streamly.Control.Exception.withAcquireIO' +-- for covering the entire pipeline with guaranteed cleanup at the end of +-- bracket. +-- +-- Observes exceptions only in the stream generation, and not in stream +-- consumers. +-- +-- /See also: 'bracketUnsafe'/ +-- +-- /Inhibits stream fusion/ +-- +{-# INLINE bracketIO #-} +bracketIO :: (MonadIO m, MonadCatch m) + => IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a +bracketIO bef aft = bracketIO3 bef aft aft aft + +-- If you are recovering from exceptions using 'handle' then you should use +-- bracketIO'' which releases the resource promptly on exception before the +-- exception handler generates another stream. But for better performance +-- bracketIO' may be better and leave the resource to be freed by GC. +-- +-- XXX If we want to recover from exceptions then we should probably have an +-- integrated combinator combining handling with bracketIO'' otherwise we will +-- have multiple layers of "try" which will not be good for perf. + +data GbracketIO'State s ref release + = GBracketIO'Init + | GBracketIO'Normal s ref release + +-- | Like 'bracketIO' but requires an 'Streamly.Control.Exception.AcquireIO' reference in the underlying monad +-- of the stream, and guarantees that all resources are freed before the +-- scope of the monad level resource manager +-- (Streamly.Control.Exception.'Streamly.Control.Exception.withAcquireIO') +-- ends. Where fusion matters, this combinator can be much faster than 'bracketIO' as it +-- allows stream fusion. +-- +-- /Best case/: Cleanup happens immediately if the stream is consumed +-- completely. +-- +-- /Worst case/: In the following cases cleanup is guaranteed to occur at the +-- end of the monad level bracket. However, if a GC occurs then cleanup will +-- occur even earlier than that. +-- +-- * the bracketed stream is partially consumed and abandoned +-- * pipeline is aborted due to an exception +-- +-- __This is the recommended default bracket operation.__ +-- +-- Note: You can use 'Streamly.Control.Exception.acquire' directly, instead of using this combinator, if +-- you don’t need to release the resource when the stream ends. However, if +-- you're using the stream inside another stream (like with concatMap), you +-- usually do want to release it at the end of the stream. +-- +-- /Allows stream fusion/ +-- +{-# INLINE bracketIO' #-} +bracketIO' :: MonadIO m + => AcquireIO -> IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a +bracketIO' bracket alloc free action = + Stream step GBracketIO'Init + + where + + -- In nested stream cases, where the inner stream is abandoned due to early + -- termination or due to exception handling, we use GC based cleanup as + -- fallback because the monad level cleanup may not occur in deterministic + -- amount of time, but GC may. Users can also implement backpressure + -- themselves e.g. if the number of open fds is greater than n then perform + -- GC until it comes down. + {-# INLINE_LATE step #-} + step _ GBracketIO'Init = do + (r, ref, release) <- liftIO $ mask_ $ do + (r, release) <- liftIO $ acquire bracket alloc free + ref <- newIOFinalizer release + return (r, ref, release) + return $ Skip $ GBracketIO'Normal (action r) ref release + + step gst (GBracketIO'Normal (UnStream step1 st) ref release) = do + res <- step1 gst st + case res of + Yield x s -> + return $ Yield x (GBracketIO'Normal (Stream step1 s) ref release) + Skip s -> + return $ Skip (GBracketIO'Normal (Stream step1 s) ref release) + Stop -> + liftIO (clearingIOFinalizer ref release) >> return Stop + +-- | Like bracketIO, the only difference is that there is a guarantee that the +-- resources will be freed at the end of the monad level bracket +-- ('Streamly.Control.Exception.AcquireIO'). +-- +-- /Best case/: Cleanup happens immediately in the following cases: +-- +-- * the stream is consumed completely +-- * an exception occurs in the bracketed part of the pipeline +-- +-- /Worst case/: In the following cases cleanup is guaranteed to occur at the +-- end of the monad level bracket. However, if a GC occurs before that then +-- cleanup will occur early. +-- +-- * the bracketed stream is partially consumed and abandoned +-- * pipeline is aborted due to an exception outside the bracket +-- +-- Note: Instead of using this combinator you can directly use +-- 'Streamly.Control.Exception.acquire' +-- if you do not care about releasing the resource at the end of the stream +-- and if you are not recovering from an exception using 'handle'. You may want +-- to care about releasing the resource at the end of a stream if you are using +-- it in a nested manner (e.g. in concatMap). +-- +-- /Inhibits stream fusion/ +-- +{-# INLINE bracketIO'' #-} +bracketIO'' :: (MonadIO m, MonadCatch m) + => AcquireIO -> IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a +bracketIO'' bracket alloc free action = + Stream step GBracketIO'Init + + where + + {-# INLINE_LATE step #-} + step _ GBracketIO'Init = do + (r, ref, release) <- liftIO $ mask_ $ do + (r, release) <- liftIO $ acquire bracket alloc free + ref <- newIOFinalizer release + return (r, ref, release) + return $ Skip $ GBracketIO'Normal (action r) ref release + + step gst (GBracketIO'Normal (UnStream step1 st) ref release) = do + -- If an async exception occurs before try or after try, in those cases + -- the exception will not be intercepted here. In those cases the + -- release action will run via AcquireIO release hook. + res <- MC.try $ step1 gst st + case res of + Right r -> + case r of + Yield x s -> + return + $ Yield x (GBracketIO'Normal (Stream step1 s) ref release) + Skip s -> + return + $ Skip (GBracketIO'Normal (Stream step1 s) ref release) + Stop -> + liftIO (clearingIOFinalizer ref release) >> return Stop + Left (e :: SomeException) -> + liftIO (clearingIOFinalizer ref release) >> MC.throwM e + +-- | Like finallyIO, based on bracketIO' semantics. +{-# INLINE finallyIO' #-} +finallyIO' :: MonadIO m => AcquireIO -> IO b -> Stream m a -> Stream m a +finallyIO' bracket free stream = + bracketIO' bracket (return ()) (const free) (const stream) + +-- | Like finallyIO, based on bracketIO'' semantics. +{-# INLINE finallyIO'' #-} +finallyIO'' :: (MonadIO m, MonadCatch m) => + AcquireIO -> IO b -> Stream m a -> Stream m a +finallyIO'' bracket free stream = + bracketIO'' bracket (return ()) (const free) (const stream) + +-- | Like 'bracketIO' but with on-demand allocations and manual release +-- facility. +-- +-- Here is an example: +-- +-- >>> :{ +-- close x h = do +-- putStrLn $ "closing: " ++ x +-- hClose h +-- :} +-- +-- >>> :{ +-- generate ref = +-- Stream.fromList ["file1", "file2"] +-- & Stream.mapM +-- (\x -> do +-- (h, release) <- Exception.acquire ref (openFile x ReadMode) (close x) +-- -- use h here +-- threadDelay 1000000 +-- when (x == "file1") $ do +-- putStrLn $ "Manually releasing: " ++ x +-- release +-- return x +-- ) +-- & Stream.trace print +-- :} +-- +-- >>> :{ +-- run = +-- Stream.withAcquireIO generate +-- & Stream.fold Fold.drain +-- :} +-- +-- In the above code, you should see the \"closing:\" message for both the +-- files, and only once for each file. Make sure you create "file1" and "file2" +-- before running it. +-- +-- Here is an example for just registering hooks to be called eventually: +-- +-- >>> :{ +-- generate ref = +-- Stream.fromList ["file1", "file2"] +-- & Stream.mapM +-- (\x -> do +-- Exception.register ref $ putStrLn $ "saw: " ++ x +-- threadDelay 1000000 +-- return x +-- ) +-- & Stream.trace print +-- :} +-- +-- >>> :{ +-- run = +-- Stream.withAcquireIO generate +-- & Stream.fold Fold.drain +-- :} +-- +-- In the above code, even if you interrupt the program with CTRL-C you should +-- still see the "saw:" message for the elements seen before the interrupt. +-- +-- See 'bracketIO' documentation for the caveats related to partially consumed +-- streams and async exceptions. +-- +-- Use monad level bracket Streamly.Control.Exception.'Streamly..Control.Exception.withAcquireIO' +-- for guaranteed cleanup in the entire pipeline, however, monad level bracket does not provide +-- an automatic cleanup at the end of the stream; you can only release +-- resources manually or via automatic cleanup at the end of the monad bracket. +-- The end of stream cleanup is useful especially in nested streams where we +-- want to cleanup at the end of every inner stream instead of waiting for the +-- outer stream to end for cleaning up to happen. +-- +{-# INLINE withAcquireIO #-} +withAcquireIO :: (MonadIO m, MonadCatch m) => + (AcquireIO -> Stream m a) -> Stream m a +withAcquireIO action = do + bracketIO bef (releaser . fst) (\(_, alloc) -> action alloc) + + where + + bef = do + -- Assuming 64-bit int counter will never overflow + ref <- liftIO $ newIORef (0 :: Int, Map.empty, Map.empty) + return (ref, AcquireIO (allocator ref)) + +-- | We can also combine the stream local 'withAcquireIO' with the global monad +-- level bracket +-- Streamly.Internal.Control.Exception.'Streamly.Internal.Control.Exception.withAcquireIO'. +-- The release actions returned by the local allocator can be registered to be +-- called by the monad level bracket. This way we can guarantee that in the +-- worst case release actions happen at the end of bracket and do not depend on +-- GC. This is the most powerful way of allocating resources on-demand with +-- manual release inside a stream. If required a custom combinator can be +-- written to register the local allocator's release in the global allocator +-- automatically. +-- +-- /Unimplemented/ +{-# INLINE withAcquireIO' #-} +withAcquireIO' :: -- (MonadIO m, MonadCatch m) => + AcquireIO -> (AcquireIO -> Stream m a) -> Stream m a +withAcquireIO' _globalAlloc _action = undefined + +data BracketState s v = BracketInit | BracketRun s v + +-- | Alternate (custom) implementation of 'bracket'. +-- +{-# INLINE_NORMAL _bracket #-} +_bracket :: MonadCatch m + => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a +_bracket bef aft bet = Stream step' BracketInit + + where + + {-# INLINE_LATE step' #-} + step' _ BracketInit = bef >>= \x -> return (Skip (BracketRun (bet x) x)) + + -- NOTE: It is important to use UnStream instead of the Stream pattern + -- here, otherwise we get huge perf degradation, see note in concatMap. + step' gst (BracketRun (UnStream step state) v) = do + -- res <- step gst state `MC.onException` aft v + res <- inline MC.try $ step gst state + case res of + Left (e :: SomeException) -> aft v >> MC.throwM e >> return Stop + Right r -> case r of + Yield x s -> return $ Yield x (BracketRun (Stream step s) v) + Skip s -> return $ Skip (BracketRun (Stream step s) v) + Stop -> aft v >> return Stop + +-- | Like 'finally' with following differences: +-- +-- * action @m b@ won't run if the stream is garbage collected +-- after partial evaluation. +-- * has slightly better performance than 'finallyIO'. +-- +-- /Inhibits stream fusion/ +-- +-- /Pre-release/ +-- +{-# INLINE finallyUnsafe #-} +finallyUnsafe :: MonadCatch m => m b -> Stream m a -> Stream m a +finallyUnsafe action xs = bracketUnsafe (return ()) (const action) (const xs) + +-- | Run the action @IO b@ whenever the stream stream stops normally, aborts +-- due to an exception or if it is garbage collected after a partial lazy +-- evaluation. +-- +-- The semantics of running the action @IO b@ are similar to the cleanup action +-- semantics described in 'bracketIO'. +-- +-- >>> finallyIO release stream = Stream.bracketIO (return ()) (const release) (const stream) +-- +-- See also finallyIO' for stricter resource release guarantees. +-- +-- /See also 'finallyUnsafe'/ +-- +-- /Inhibits stream fusion/ +-- +{-# INLINE finallyIO #-} +finallyIO :: (MonadIO m, MonadCatch m) => IO b -> Stream m a -> Stream m a +finallyIO action xs = bracketIO3 (return ()) act act act (const xs) + where act _ = action + -- | Like 'handle' but the exception handler is also provided with the stream -- that generated the exception as input. The exception handler can thus -- re-evaluate the stream to retry the action that failed. The exception @@ -202,21 +740,51 @@ -- -- /Pre-release/ -- -{-# INLINE ghandle #-} +{-# INLINE_NORMAL ghandle #-} ghandle :: (MonadCatch m, Exception e) - => (e -> Stream m a -> Stream m a) -> Stream m a -> Stream m a -ghandle handler = - fromStreamD - . D.ghandle (\e xs -> toStreamD $ handler e (fromStreamD xs)) - . toStreamD + => (e -> Stream m a -> m (Stream m a)) -> Stream m a -> Stream m a +ghandle f stream = + gbracket_ (return ()) return (const f) (inline MC.try) (const stream) -- | When evaluating a stream if an exception occurs, stream evaluation aborts -- and the specified exception handler is run with the exception as argument. +-- The exception is caught and handled unless the handler decides to rethrow +-- it. Note that exception handling is not applied to the stream returned by +-- the exception handler. -- +-- Observes exceptions only in the stream generation, and not in stream +-- consumers. +-- -- /Inhibits stream fusion/ -- -{-# INLINE handle #-} +{-# INLINE_NORMAL handle #-} handle :: (MonadCatch m, Exception e) + => (e -> m (Stream m a)) -> Stream m a -> Stream m a +handle f stream = + gbracket_ (return ()) return (\_ e _ -> f e) (inline MC.try) (const stream) + +-- | Alternate (custom) implementation of 'handle'. +-- +{-# INLINE_NORMAL _handle #-} +_handle :: (MonadCatch m, Exception e) => (e -> Stream m a) -> Stream m a -> Stream m a -handle handler xs = - fromStreamD $ D.handle (toStreamD . handler) $ toStreamD xs +_handle f (Stream step state) = Stream step' (Left state) + + where + + {-# INLINE_LATE step' #-} + step' gst (Left st) = do + res <- inline MC.try $ step gst st + case res of + Left e -> return $ Skip $ Right (f e) + Right r -> case r of + Yield x s -> return $ Yield x (Left s) + Skip s -> return $ Skip (Left s) + Stop -> return Stop + + step' gst (Right (UnStream step1 st)) = do + res <- step1 gst st + case res of + Yield x s -> return $ Yield x (Right (Stream step1 s)) + Skip s -> return $ Skip (Right (Stream step1 s)) + Stop -> return Stop diff --git a/src/Streamly/Internal/Data/Stream/Expand.hs b/src/Streamly/Internal/Data/Stream/Expand.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Expand.hs +++ /dev/null @@ -1,893 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Expand --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Expand a stream by combining two or more streams or by combining streams --- with unfolds. - -module Streamly.Internal.Data.Stream.Expand - ( - -- * Binary Combinators (Linear) - -- | Functions ending in the shape: - -- - -- @Stream m a -> Stream m a -> Stream m a@. - -- - -- The functions in this section have a linear or flat n-ary combining - -- characterstics. It means that when combined @n@ times (e.g. @a `serial` - -- b `serial` c ...@) the resulting expression will have an @O(n)@ - -- complexity (instead O(n^2) for pair wise combinators described in the - -- next section. These functions can be used efficiently with - -- 'concatMapWith' et. al. combinators that combine streams in a linear - -- fashion (contrast with 'mergeMapWith' which combines streams as a - -- binary tree). - - append - -- * Binary Combinators (Pair Wise) - -- | Like the functions in the section above these functions also combine - -- two streams into a single stream but when used @n@ times linearly they - -- exhibit O(n^2) complexity. They are best combined in a binary tree - -- fashion using 'mergeMapWith' giving a @n * log n@ complexity. Avoid - -- using these with 'concatMapWith' when combining a large or infinite - -- number of streams. - - -- ** Append - , append2 - - -- ** Interleave - , interleave - , interleave2 - , interleaveFst - , interleaveFst2 - , interleaveFstSuffix2 - , interleaveMin - , interleaveMin2 - - -- ** Round Robin - , roundrobin - - -- ** Merge - , mergeBy - , mergeByM - , mergeByM2 - , mergeMinBy - , mergeFstBy - - -- ** Zip - , zipWith - , zipWithM - - -- * Combine Streams and Unfolds - -- | - -- Expand a stream by repeatedly using an unfold and merging the resulting - -- streams. Functions generally ending in the shape: - -- - -- @Unfold m a b -> Stream m a -> Stream m b@ - - -- ** Unfold and combine streams - -- | Unfold and flatten streams. - , unfoldMany -- XXX Rename to unfoldAppend - , unfoldInterleave - , unfoldRoundRobin - - -- ** Interpose - -- | Insert effects between streams. Like unfoldMany but intersperses an - -- effect between the streams. A special case of gintercalate. - , interpose - , interposeSuffix - -- , interposeBy - - -- ** Intercalate - -- | Insert Streams between Streams. - -- Like unfoldMany but intersperses streams from another source between - -- the streams from the first source. - , intercalate - , intercalateSuffix - , gintercalate - , gintercalateSuffix - - -- * Combine Streams of Streams - -- | Map and serially append streams. 'concatMapM' is a generalization of - -- the binary append operation to append many streams. - , concatMapM - , concatMap - , concatEffect - , concat - - -- * ConcatMapWith - -- | Map and flatten a stream like 'concatMap' but using a custom binary - -- stream merging combinator instead of just appending the streams. The - -- merging occurs sequentially, it works efficiently for 'serial', 'async', - -- 'ahead' like merge operations where we consume one stream before the - -- next or in case of 'wAsync' or 'parallel' where we consume all streams - -- simultaneously anyway. - -- - -- However, in cases where the merging consumes streams in a round robin - -- fashion, a pair wise merging using 'mergeMapWith' would be more - -- efficient. These cases include operations like 'mergeBy' or 'zipWith'. - - , concatMapWith - , bindWith - , concatSmapMWith - - -- * MergeMapWith - -- | See the notes about suitable merge functions in the 'concatMapWith' - -- section. - , mergeMapWith - - -- * Iterate - -- | Map and flatten Trees of Streams - , unfoldIterateDfs - , unfoldIterateBfs - , unfoldIterateBfsRev - - , concatIterateWith - , mergeIterateWith - - , concatIterateDfs - , concatIterateBfs - - -- More experimental ops - , concatIterateBfsRev - , concatIterateLeftsWith - , concatIterateScanWith - , concatIterateScan - ) -where - -#include "inline.hs" - -import Streamly.Internal.Data.Stream.Bottom - ( concatEffect, concatMapM, concatMap, smapM, zipWith, zipWithM) -import Streamly.Internal.Data.Stream.Type - ( Stream, fromStreamD, fromStreamK, toStreamD, toStreamK - , bindWith, concatMapWith, cons, nil) -import Streamly.Internal.Data.Unfold.Type (Unfold) - -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Stream.StreamK as K (mergeBy, mergeByM) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - -import Prelude hiding (concat, concatMap, zipWith) - --- $setup --- >>> :m --- >>> import Data.Either (either) --- >>> import Data.IORef --- >>> import Streamly.Internal.Data.Stream (Stream) --- >>> import Prelude hiding (zipWith, concatMap, concat) --- >>> import qualified Streamly.Data.Array as Array --- >>> import qualified Streamly.Internal.Data.Fold as Fold --- >>> import qualified Streamly.Internal.Data.Stream as Stream --- >>> import qualified Streamly.Internal.Data.Unfold as Unfold --- >>> import qualified Streamly.Internal.Data.Parser as Parser --- >>> import qualified Streamly.Internal.FileSystem.Dir as Dir --- - ------------------------------------------------------------------------------- --- Appending ------------------------------------------------------------------------------- - -infixr 6 `append2` - --- | This is fused version of 'append'. It could be up to 100x faster than --- 'append' when combining two fusible streams. However, it slows down --- quadratically with the number of streams being appended. Therefore, it is --- suitable for ad-hoc append of a few streams, and should not be used with --- 'concatMapWith' or 'mergeMapWith'. --- --- /Fused/ --- -{-# INLINE append2 #-} -append2 ::Monad m => Stream m b -> Stream m b -> Stream m b -append2 m1 m2 = fromStreamD $ D.append (toStreamD m1) (toStreamD m2) - -infixr 6 `append` - --- | Appends two streams sequentially, yielding all elements from the first --- stream, and then all elements from the second stream. --- --- >>> s1 = Stream.fromList [1,2] --- >>> s2 = Stream.fromList [3,4] --- >>> Stream.fold Fold.toList $ s1 `Stream.append` s2 --- [1,2,3,4] --- --- This has O(n) append performance where @n@ is the number of streams. It can --- be used to efficiently fold an infinite lazy container of streams --- 'concatMapWith' et. al. --- --- See 'append2' for a fusible alternative. --- --- /CPS/ -{-# INLINE append #-} -append :: Stream m a -> Stream m a -> Stream m a -append = (<>) - ------------------------------------------------------------------------------- --- Interleaving ------------------------------------------------------------------------------- - -infixr 6 `interleave` - --- | Interleaves two streams, yielding one element from each stream --- alternately. When one stream stops the rest of the other stream is used in --- the output stream. --- --- When joining many streams in a left associative manner earlier streams will --- get exponential priority than the ones joining later. Because of exponential --- weighting it can be used with 'concatMapWith' even on a large number of --- streams. --- --- See 'interleave2' for a fusible alternative. --- --- /CPS/ -{-# INLINE interleave #-} -interleave :: Stream m a -> Stream m a -> Stream m a -interleave s1 s2 = fromStreamK $ K.interleave (toStreamK s1) (toStreamK s2) - -{-# INLINE interleave2 #-} -interleave2 :: Monad m => Stream m a -> Stream m a -> Stream m a -interleave2 s1 s2 = fromStreamD $ D.interleave (toStreamD s1) (toStreamD s2) - --- | Like `interleave` but stops interleaving as soon as the first stream --- stops. --- --- See 'interleaveFst2' for a fusible alternative. --- --- /CPS/ -{-# INLINE interleaveFst #-} -interleaveFst :: Stream m a -> Stream m a -> Stream m a -interleaveFst s1 s2 = - fromStreamK $ K.interleaveFst (toStreamK s1) (toStreamK s2) - --- | Like `interleave` but stops interleaving as soon as any of the two streams --- stops. --- --- See 'interleaveMin2' for a fusible alternative. --- --- /CPS/ -{-# INLINE interleaveMin #-} -interleaveMin :: Stream m a -> Stream m a -> Stream m a -interleaveMin s1 s2 = - fromStreamK $ K.interleaveMin (toStreamK s1) (toStreamK s2) - -{-# INLINE interleaveMin2 #-} -interleaveMin2 :: Monad m => Stream m a -> Stream m a -> Stream m a -interleaveMin2 s1 s2 = - fromStreamD $ D.interleaveMin (toStreamD s1) (toStreamD s2) - --- | Interleaves the outputs of two streams, yielding elements from each stream --- alternately, starting from the first stream. As soon as the first stream --- finishes, the output stops, discarding the remaining part of the second --- stream. In this case, the last element in the resulting stream would be from --- the second stream. If the second stream finishes early then the first stream --- still continues to yield elements until it finishes. --- --- >>> :set -XOverloadedStrings --- >>> import Data.Functor.Identity (Identity) --- >>> Stream.interleaveFstSuffix2 "abc" ",,,," :: Stream Identity Char --- fromList "a,b,c," --- >>> Stream.interleaveFstSuffix2 "abc" "," :: Stream Identity Char --- fromList "a,bc" --- --- 'interleaveFstSuffix2' is a dual of 'interleaveFst2'. --- --- Do not use at scale in concatMapWith. --- --- /Pre-release/ -{-# INLINE interleaveFstSuffix2 #-} -interleaveFstSuffix2 :: Monad m => Stream m b -> Stream m b -> Stream m b -interleaveFstSuffix2 m1 m2 = - fromStreamD $ D.interleaveFstSuffix (toStreamD m1) (toStreamD m2) - --- | Interleaves the outputs of two streams, yielding elements from each stream --- alternately, starting from the first stream and ending at the first stream. --- If the second stream is longer than the first, elements from the second --- stream are infixed with elements from the first stream. If the first stream --- is longer then it continues yielding elements even after the second stream --- has finished. --- --- >>> :set -XOverloadedStrings --- >>> import Data.Functor.Identity (Identity) --- >>> Stream.interleaveFst2 "abc" ",,,," :: Stream Identity Char --- fromList "a,b,c" --- >>> Stream.interleaveFst2 "abc" "," :: Stream Identity Char --- fromList "a,bc" --- --- 'interleaveFst2' is a dual of 'interleaveFstSuffix2'. --- --- Do not use at scale in concatMapWith. --- --- /Pre-release/ -{-# INLINE interleaveFst2 #-} -interleaveFst2 :: Monad m => Stream m b -> Stream m b -> Stream m b -interleaveFst2 m1 m2 = - fromStreamD $ D.interleaveFst (toStreamD m1) (toStreamD m2) - ------------------------------------------------------------------------------- --- Scheduling ------------------------------------------------------------------------------- - --- | Schedule the execution of two streams in a fair round-robin manner, --- executing each stream once, alternately. Execution of a stream may not --- necessarily result in an output, a stream may chose to @Skip@ producing an --- element until later giving the other stream a chance to run. Therefore, this --- combinator fairly interleaves the execution of two streams rather than --- fairly interleaving the output of the two streams. This can be useful in --- co-operative multitasking without using explicit threads. This can be used --- as an alternative to `async`. --- --- Do not use at scale in concatMapWith. --- --- /Pre-release/ -{-# INLINE roundrobin #-} -roundrobin :: Monad m => Stream m b -> Stream m b -> Stream m b -roundrobin m1 m2 = fromStreamD $ D.roundRobin (toStreamD m1) (toStreamD m2) - ------------------------------------------------------------------------------- --- Merging (sorted streams) ------------------------------------------------------------------------------- - --- | Merge two streams using a comparison function. The head elements of both --- the streams are compared and the smaller of the two elements is emitted, if --- both elements are equal then the element from the first stream is used --- first. --- --- If the streams are sorted in ascending order, the resulting stream would --- also remain sorted in ascending order. --- --- >>> s1 = Stream.fromList [1,3,5] --- >>> s2 = Stream.fromList [2,4,6,8] --- >>> Stream.fold Fold.toList $ Stream.mergeBy compare s1 s2 --- [1,2,3,4,5,6,8] --- --- See 'mergeByM2' for a fusible alternative. --- --- /CPS/ -{-# INLINE mergeBy #-} -mergeBy :: (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a -mergeBy f m1 m2 = fromStreamK $ K.mergeBy f (toStreamK m1) (toStreamK m2) - --- | Like 'mergeBy' but with a monadic comparison function. --- --- Merge two streams randomly: --- --- @ --- > randomly _ _ = randomIO >>= \x -> return $ if x then LT else GT --- > Stream.toList $ Stream.mergeByM randomly (Stream.fromList [1,1,1,1]) (Stream.fromList [2,2,2,2]) --- [2,1,2,2,2,1,1,1] --- @ --- --- Merge two streams in a proportion of 2:1: --- --- >>> :{ --- do --- let s1 = Stream.fromList [1,1,1,1,1,1] --- s2 = Stream.fromList [2,2,2] --- let proportionately m n = do --- ref <- newIORef $ cycle $ Prelude.concat [Prelude.replicate m LT, Prelude.replicate n GT] --- return $ \_ _ -> do --- r <- readIORef ref --- writeIORef ref $ Prelude.tail r --- return $ Prelude.head r --- f <- proportionately 2 1 --- xs <- Stream.fold Fold.toList $ Stream.mergeByM f s1 s2 --- print xs --- :} --- [1,1,2,1,1,2,1,1,2] --- --- See 'mergeByM2' for a fusible alternative. --- --- /CPS/ -{-# INLINE mergeByM #-} -mergeByM - :: Monad m - => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a -mergeByM f m1 m2 = fromStreamK $ K.mergeByM f (toStreamK m1) (toStreamK m2) - --- | Like 'mergeByM' but much faster, works best when merging statically known --- number of streams. When merging more than two streams try to merge pairs and --- pair of pairs in a tree like structure.'mergeByM' works better with variable --- number of streams being merged using 'mergeMapWith'. --- --- /Internal/ -{-# INLINE mergeByM2 #-} -mergeByM2 - :: Monad m - => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a -mergeByM2 f m1 m2 = - fromStreamD $ D.mergeByM f (toStreamD m1) (toStreamD m2) - --- | Like 'mergeByM' but stops merging as soon as any of the two streams stops. --- --- /Unimplemented/ -{-# INLINABLE mergeMinBy #-} -mergeMinBy :: -- Monad m => - (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a -mergeMinBy _f _m1 _m2 = undefined - -- fromStreamD $ D.mergeMinBy f (toStreamD m1) (toStreamD m2) - --- | Like 'mergeByM' but stops merging as soon as the first stream stops. --- --- /Unimplemented/ -{-# INLINABLE mergeFstBy #-} -mergeFstBy :: -- Monad m => - (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a -mergeFstBy _f _m1 _m2 = undefined - -- fromStreamK $ D.mergeFstBy f (toStreamD m1) (toStreamD m2) - ------------------------------------------------------------------------------- --- Combine N Streams - unfoldMany ------------------------------------------------------------------------------- - --- | Like 'concatMap' but uses an 'Unfold' for stream generation. Unlike --- 'concatMap' this can fuse the 'Unfold' code with the inner loop and --- therefore provide many times better performance. --- -{-# INLINE unfoldMany #-} -unfoldMany ::Monad m => Unfold m a b -> Stream m a -> Stream m b -unfoldMany u m = fromStreamD $ D.unfoldMany u (toStreamD m) - --- | This does not pair streams like mergeMapWith, instead, it goes through --- each stream one by one and yields one element from each stream. After it --- goes to the last stream it reverses the traversal to come back to the first --- stream yielding elements from each stream on its way back to the first --- stream and so on. --- --- >>> lists = Stream.fromList [[1,1],[2,2],[3,3],[4,4],[5,5]] --- >>> interleaved = Stream.unfoldInterleave Unfold.fromList lists --- >>> Stream.fold Fold.toList interleaved --- [1,2,3,4,5,5,4,3,2,1] --- --- Note that this is order of magnitude more efficient than "mergeMapWith --- wSerial" because of fusion. --- --- /Fused/ -{-# INLINE unfoldInterleave #-} -unfoldInterleave ::Monad m => Unfold m a b -> Stream m a -> Stream m b -unfoldInterleave u m = - fromStreamD $ D.unfoldInterleave u (toStreamD m) - --- | 'unfoldInterleave' switches to the next stream whenever a value from a --- stream is yielded, it does not switch on a 'Skip'. So if a stream keeps --- skipping for long time other streams won't get a chance to run. --- 'unfoldRoundRobin' switches on Skip as well. So it basically schedules each --- stream fairly irrespective of whether it produces a value or not. --- -{-# INLINE unfoldRoundRobin #-} -unfoldRoundRobin ::Monad m => Unfold m a b -> Stream m a -> Stream m b -unfoldRoundRobin u m = - fromStreamD $ D.unfoldRoundRobin u (toStreamD m) - ------------------------------------------------------------------------------- --- Combine N Streams - interpose ------------------------------------------------------------------------------- - --- > interpose x unf str = gintercalate unf str UF.identity (repeat x) - --- | Unfold the elements of a stream, intersperse the given element between the --- unfolded streams and then concat them into a single stream. --- --- >>> unwords = Stream.interpose ' ' --- --- /Pre-release/ -{-# INLINE interpose #-} -interpose :: Monad m - => c -> Unfold m b c -> Stream m b -> Stream m c -interpose x unf str = - fromStreamD $ D.interpose x unf (toStreamD str) - --- interposeSuffix x unf str = gintercalateSuffix unf str UF.identity (repeat x) - --- | Unfold the elements of a stream, append the given element after each --- unfolded stream and then concat them into a single stream. --- --- >>> unlines = Stream.interposeSuffix '\n' --- --- /Pre-release/ -{-# INLINE interposeSuffix #-} -interposeSuffix :: Monad m - => c -> Unfold m b c -> Stream m b -> Stream m c -interposeSuffix x unf str = - fromStreamD $ D.interposeSuffix x unf (toStreamD str) - ------------------------------------------------------------------------------- --- Combine N Streams - intercalate ------------------------------------------------------------------------------- - --- XXX we can swap the order of arguments to gintercalate so that the --- definition of unfoldMany becomes simpler? The first stream should be --- infixed inside the second one. However, if we change the order in --- "interleave" as well similarly, then that will make it a bit unintuitive. --- --- > unfoldMany unf str = --- > gintercalate unf str (UF.nilM (\_ -> return ())) (repeat ()) - --- | 'interleaveFst' followed by unfold and concat. --- --- /Pre-release/ -{-# INLINE gintercalate #-} -gintercalate - :: Monad m - => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c -gintercalate unf1 str1 unf2 str2 = - fromStreamD $ D.gintercalate - unf1 (toStreamD str1) - unf2 (toStreamD str2) - --- > intercalate unf seed str = gintercalate unf str unf (repeatM seed) - --- | 'intersperse' followed by unfold and concat. --- --- >>> intercalate u a = Stream.unfoldMany u . Stream.intersperse a --- >>> intersperse = Stream.intercalate Unfold.identity --- >>> unwords = Stream.intercalate Unfold.fromList " " --- --- >>> input = Stream.fromList ["abc", "def", "ghi"] --- >>> Stream.fold Fold.toList $ Stream.intercalate Unfold.fromList " " input --- "abc def ghi" --- -{-# INLINE intercalate #-} -intercalate :: Monad m - => Unfold m b c -> b -> Stream m b -> Stream m c -intercalate unf seed str = fromStreamD $ - D.unfoldMany unf $ D.intersperse seed (toStreamD str) - --- | 'interleaveFstSuffix2' followed by unfold and concat. --- --- /Pre-release/ -{-# INLINE gintercalateSuffix #-} -gintercalateSuffix - :: Monad m - => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c -gintercalateSuffix unf1 str1 unf2 str2 = - fromStreamD $ D.gintercalateSuffix - unf1 (toStreamD str1) - unf2 (toStreamD str2) - --- > intercalateSuffix unf seed str = gintercalateSuffix unf str unf (repeatM seed) - --- | 'intersperseMSuffix' followed by unfold and concat. --- --- >>> intercalateSuffix u a = Stream.unfoldMany u . Stream.intersperseMSuffix a --- >>> intersperseMSuffix = Stream.intercalateSuffix Unfold.identity --- >>> unlines = Stream.intercalateSuffix Unfold.fromList "\n" --- --- >>> input = Stream.fromList ["abc", "def", "ghi"] --- >>> Stream.fold Fold.toList $ Stream.intercalateSuffix Unfold.fromList "\n" input --- "abc\ndef\nghi\n" --- -{-# INLINE intercalateSuffix #-} -intercalateSuffix :: Monad m - => Unfold m b c -> b -> Stream m b -> Stream m c -intercalateSuffix unf seed = - fromStreamD . D.intercalateSuffix unf seed . toStreamD - ------------------------------------------------------------------------------- --- Combine N Streams - concatMap ------------------------------------------------------------------------------- - --- | Flatten a stream of streams to a single stream. --- --- >>> concat = Stream.concatMap id --- --- /Pre-release/ -{-# INLINE concat #-} -concat :: Monad m => Stream m (Stream m a) -> Stream m a -concat = concatMap id - ------------------------------------------------------------------------------- --- Combine N Streams - concatMap ------------------------------------------------------------------------------- - --- | Like 'concatMapWith' but carries a state which can be used to share --- information across multiple steps of concat. --- --- >>> concatSmapMWith combine f initial = Stream.concatMapWith combine id . Stream.smapM f initial --- --- /Pre-release/ --- -{-# INLINE concatSmapMWith #-} -concatSmapMWith - :: Monad m - => (Stream m b -> Stream m b -> Stream m b) - -> (s -> a -> m (s, Stream m b)) - -> m s - -> Stream m a - -> Stream m b -concatSmapMWith combine f initial = - concatMapWith combine id . smapM f initial - --- XXX Implement a StreamD version for fusion. - --- | Combine streams in pairs using a binary combinator, the resulting streams --- are then combined again in pairs recursively until we get to a single --- combined stream. The composition would thus form a binary tree. --- --- For example, you can sort a stream using merge sort like this: --- --- >>> s = Stream.fromList [5,1,7,9,2] --- >>> generate = Stream.fromPure --- >>> combine = Stream.mergeBy compare --- >>> Stream.fold Fold.toList $ Stream.mergeMapWith combine generate s --- [1,2,5,7,9] --- --- Note that if the stream length is not a power of 2, the binary tree composed --- by mergeMapWith would not be balanced, which may or may not be important --- depending on what you are trying to achieve. --- --- /Caution: the stream of streams must be finite/ --- --- /CPS/ --- --- /Pre-release/ --- -{-# INLINE mergeMapWith #-} -mergeMapWith :: - (Stream m b -> Stream m b -> Stream m b) - -> (a -> Stream m b) - -> Stream m a - -> Stream m b -mergeMapWith par f m = - fromStreamK - $ K.mergeMapWith - (\s1 s2 -> toStreamK $ fromStreamK s1 `par` fromStreamK s2) - (toStreamK . f) - (toStreamK m) - ------------------------------------------------------------------------------- --- concatIterate - Map and flatten Trees of Streams ------------------------------------------------------------------------------- - --- | Yield an input element in the output stream, map a stream generator on it --- and repeat the process on the resulting stream. Resulting streams are --- flattened using the 'concatMapWith' combinator. This can be used for a depth --- first style (DFS) traversal of a tree like structure. --- --- Example, list a directory tree using DFS: --- --- >>> f = either Dir.readEitherPaths (const Stream.nil) --- >>> input = Stream.fromPure (Left ".") --- >>> ls = Stream.concatIterateWith Stream.append f input --- --- Note that 'iterateM' is a special case of 'concatIterateWith': --- --- >>> iterateM f = Stream.concatIterateWith Stream.append (Stream.fromEffect . f) . Stream.fromEffect --- --- /CPS/ --- --- /Pre-release/ --- -{-# INLINE concatIterateWith #-} -concatIterateWith :: - (Stream m a -> Stream m a -> Stream m a) - -> (a -> Stream m a) - -> Stream m a - -> Stream m a -concatIterateWith combine f = iterateStream - - where - - iterateStream = concatMapWith combine generate - - generate x = x `cons` iterateStream (f x) - --- | Traverse the stream in depth first style (DFS). Map each element in the --- input stream to a stream and flatten, recursively map the resulting elements --- as well to a stream and flatten until no more streams are generated. --- --- Example, list a directory tree using DFS: --- --- >>> f = either (Just . Dir.readEitherPaths) (const Nothing) --- >>> input = Stream.fromPure (Left ".") --- >>> ls = Stream.concatIterateDfs f input --- --- This is equivalent to using @concatIterateWith Stream.append@. --- --- /Pre-release/ -{-# INLINE concatIterateDfs #-} -concatIterateDfs :: Monad m => - (a -> Maybe (Stream m a)) - -> Stream m a - -> Stream m a -concatIterateDfs f stream = - fromStreamD - $ D.concatIterateDfs (fmap toStreamD . f ) (toStreamD stream) - --- | Similar to 'concatIterateDfs' except that it traverses the stream in --- breadth first style (BFS). First, all the elements in the input stream are --- emitted, and then their traversals are emitted. --- --- Example, list a directory tree using BFS: --- --- >>> f = either (Just . Dir.readEitherPaths) (const Nothing) --- >>> input = Stream.fromPure (Left ".") --- >>> ls = Stream.concatIterateBfs f input --- --- /Pre-release/ -{-# INLINE concatIterateBfs #-} -concatIterateBfs :: Monad m => - (a -> Maybe (Stream m a)) - -> Stream m a - -> Stream m a -concatIterateBfs f stream = - fromStreamD - $ D.concatIterateBfs (fmap toStreamD . f ) (toStreamD stream) - --- | Same as 'concatIterateBfs' except that the traversal of the last --- element on a level is emitted first and then going backwards up to the first --- element (reversed ordering). This may be slightly faster than --- 'concatIterateBfs'. --- -{-# INLINE concatIterateBfsRev #-} -concatIterateBfsRev :: Monad m => - (a -> Maybe (Stream m a)) - -> Stream m a - -> Stream m a -concatIterateBfsRev f stream = - fromStreamD - $ D.concatIterateBfsRev (fmap toStreamD . f ) (toStreamD stream) - --- | Like 'concatIterateWith' but uses the pairwise flattening combinator --- 'mergeMapWith' for flattening the resulting streams. This can be used for a --- balanced traversal of a tree like structure. --- --- Example, list a directory tree using balanced traversal: --- --- >>> f = either Dir.readEitherPaths (const Stream.nil) --- >>> input = Stream.fromPure (Left ".") --- >>> ls = Stream.mergeIterateWith Stream.interleave f input --- --- /CPS/ --- --- /Pre-release/ --- -{-# INLINE mergeIterateWith #-} -mergeIterateWith :: - (Stream m a -> Stream m a -> Stream m a) - -> (a -> Stream m a) - -> Stream m a - -> Stream m a -mergeIterateWith combine f = iterateStream - - where - - iterateStream = mergeMapWith combine generate - - generate x = x `cons` iterateStream (f x) - --- | Same as @concatIterateDfs@ but more efficient due to stream fusion. --- --- Example, list a directory tree using DFS: --- --- >>> f = Unfold.either Dir.eitherReaderPaths Unfold.nil --- >>> input = Stream.fromPure (Left ".") --- >>> ls = Stream.unfoldIterateDfs f input --- --- /Pre-release/ -{-# INLINE unfoldIterateDfs #-} -unfoldIterateDfs :: Monad m => Unfold m a a -> Stream m a -> Stream m a -unfoldIterateDfs u = fromStreamD . D.unfoldIterateDfs u . toStreamD - --- | Like 'unfoldIterateDfs' but uses breadth first style traversal. --- --- /Pre-release/ -{-# INLINE unfoldIterateBfs #-} -unfoldIterateBfs :: Monad m => Unfold m a a -> Stream m a -> Stream m a -unfoldIterateBfs u = fromStreamD . D.unfoldIterateBfs u . toStreamD - --- | Like 'unfoldIterateBfs' but processes the children in reverse order, --- therefore, may be slightly faster. --- --- /Pre-release/ -{-# INLINE unfoldIterateBfsRev #-} -unfoldIterateBfsRev :: Monad m => Unfold m a a -> Stream m a -> Stream m a -unfoldIterateBfsRev u = - fromStreamD . D.unfoldIterateBfsRev u . toStreamD - ------------------------------------------------------------------------------- --- Flattening Graphs ------------------------------------------------------------------------------- - --- To traverse graphs we need a state to be carried around in the traversal. --- For example, we can use a hashmap to store the visited status of nodes. - --- | Like 'iterateMap' but carries a state in the stream generation function. --- This can be used to traverse graph like structures, we can remember the --- visited nodes in the state to avoid cycles. --- --- Note that a combination of 'iterateMap' and 'usingState' can also be used to --- traverse graphs. However, this function provides a more localized state --- instead of using a global state. --- --- See also: 'mfix' --- --- /Pre-release/ --- -{-# INLINE concatIterateScanWith #-} -concatIterateScanWith - :: Monad m - => (Stream m a -> Stream m a -> Stream m a) - -> (b -> a -> m (b, Stream m a)) - -> m b - -> Stream m a - -> Stream m a -concatIterateScanWith combine f initial stream = - concatEffect $ do - b <- initial - iterateStream (b, stream) - - where - - iterateStream (b, s) = pure $ concatMapWith combine (generate b) s - - generate b a = a `cons` feedback b a - - feedback b a = concatEffect $ f b a >>= iterateStream - --- Next stream is to be generated by the return value of the previous stream. A --- general intuitive way of doing that could be to use an appending monad --- instance for streams where the result of the previous stream is used to --- generate the next one. In the first pass we can just emit the values in the --- stream and keep building a buffered list/stream, once done we can then --- process the buffered stream. - -{-# INLINE concatIterateScan #-} -concatIterateScan - :: Monad m - => (b -> a -> m b) - -> (b -> m (Maybe (b, Stream m a))) - -> b - -> Stream m a -concatIterateScan scanner generate initial = - fromStreamD - $ D.concatIterateScan - scanner (fmap (fmap (fmap toStreamD)) . generate) initial - ------------------------------------------------------------------------------- --- Either streams ------------------------------------------------------------------------------- - --- Keep concating either streams as long as rights are generated, stop as soon --- as a left is generated and concat the left stream. --- --- See also: 'handle' --- --- /Unimplemented/ --- -{- -concatMapEitherWith - :: (forall x. t m x -> t m x -> t m x) - -> (a -> t m (Either (Stream m b) b)) - -> Stream m a - -> Stream m b -concatMapEitherWith = undefined --} - --- XXX We should prefer using the Maybe stream returning signatures over this. --- This API should perhaps be removed in favor of those. - --- | In an 'Either' stream iterate on 'Left's. This is a special case of --- 'concatIterateWith': --- --- >>> concatIterateLeftsWith combine f = Stream.concatIterateWith combine (either f (const Stream.nil)) --- --- To traverse a directory tree: --- --- >>> input = Stream.fromPure (Left ".") --- >>> ls = Stream.concatIterateLeftsWith Stream.append Dir.readEither input --- --- /Pre-release/ --- -{-# INLINE concatIterateLeftsWith #-} -concatIterateLeftsWith - :: (b ~ Either a c) - => (Stream m b -> Stream m b -> Stream m b) - -> (a -> Stream m b) - -> Stream m b - -> Stream m b -concatIterateLeftsWith combine f = - concatIterateWith combine (either f (const nil)) diff --git a/src/Streamly/Internal/Data/Stream/Generate.hs b/src/Streamly/Internal/Data/Stream/Generate.hs --- a/src/Streamly/Internal/Data/Stream/Generate.hs +++ b/src/Streamly/Internal/Data/Stream/Generate.hs @@ -1,460 +1,1214 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- Module : Streamly.Internal.Data.Stream.Generate --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Stream.Generate - ( - -- * Primitives - Stream.nil - , Stream.nilM - , Stream.cons - , Stream.consM - - -- * From 'Unfold' - , unfold - - -- * Unfolding - , unfoldr - , unfoldrM - - -- * From Values - , Stream.fromPure - , Stream.fromEffect - , repeat - , repeatM - , replicate - , replicateM - - -- * Enumeration - , Enumerable (..) - , enumerate - , enumerateTo - - -- * Time Enumeration - , times - , timesWith - , absTimes - , absTimesWith - , relTimes - , relTimesWith - , durations - , timeout - - -- * Iteration - , iterate - , iterateM - - -- * Cyclic Elements - , mfix - - -- * From Containers - , Bottom.fromList - , fromFoldable - - -- * From memory - , fromPtr - , fromPtrN - , fromByteStr# - -- , fromByteArray# - , fromUnboxedIORef - ) -where - -#include "inline.hs" - -import Control.Monad.IO.Class (MonadIO) -import Data.Word (Word8) -import Foreign.Storable (Storable) -import GHC.Exts (Addr#, Ptr (Ptr)) -import Streamly.Internal.Data.Stream.Bottom - (absTimesWith, relTimesWith, timesWith) -import Streamly.Internal.Data.Stream.Enumerate - (Enumerable(..), enumerate, enumerateTo) -import Streamly.Internal.Data.Stream.Type - (Stream, fromStreamD, fromStreamK, toStreamK) -import Streamly.Internal.Data.Time.Units (AbsTime, RelTime64, addToAbsTime64) -import Streamly.Internal.Data.Unboxed (Unbox) -import Streamly.Internal.Data.Unfold.Type (Unfold) - -import qualified Streamly.Internal.Data.IORef.Unboxed as Unboxed -import qualified Streamly.Internal.Data.Stream.Bottom as Bottom -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -import qualified Streamly.Internal.Data.Stream.Type as Stream -import qualified Streamly.Internal.Data.Stream.Transform as Stream (sequence) - -import Prelude hiding (iterate, replicate, repeat, take) - --- $setup --- >>> :m --- >>> import Control.Concurrent (threadDelay) --- >>> import Data.Function (fix, (&)) --- >>> import Data.Semigroup (cycle1) --- >>> import Streamly.Internal.Data.Stream.Cross (CrossStream(..)) --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Unfold as Unfold --- >>> import qualified Streamly.Internal.Data.Stream as Stream --- >>> import GHC.Exts (Ptr (Ptr)) - ------------------------------------------------------------------------------- --- From Unfold ------------------------------------------------------------------------------- - --- | Convert an 'Unfold' into a stream by supplying it an input seed. --- --- >>> s = Stream.unfold Unfold.replicateM (3, putStrLn "hello") --- >>> Stream.fold Fold.drain s --- hello --- hello --- hello --- -{-# INLINE unfold #-} -unfold :: Monad m => Unfold m a b -> a -> Stream m b -unfold unf = Stream.fromStreamD . D.unfold unf - ------------------------------------------------------------------------------- --- Generation by Unfolding ------------------------------------------------------------------------------- - --- | --- >>> :{ --- unfoldr step s = --- case step s of --- Nothing -> Stream.nil --- Just (a, b) -> a `Stream.cons` unfoldr step b --- :} --- --- Build a stream by unfolding a /pure/ step function @step@ starting from a --- seed @s@. The step function returns the next element in the stream and the --- next seed value. When it is done it returns 'Nothing' and the stream ends. --- For example, --- --- >>> :{ --- let f b = --- if b > 2 --- then Nothing --- else Just (b, b + 1) --- in Stream.fold Fold.toList $ Stream.unfoldr f 0 --- :} --- [0,1,2] --- -{-# INLINE_EARLY unfoldr #-} -unfoldr :: Monad m => (b -> Maybe (a, b)) -> b -> Stream m a -unfoldr step seed = fromStreamD (D.unfoldr step seed) -{-# RULES "unfoldr fallback to StreamK" [1] - forall a b. D.toStreamK (D.unfoldr a b) = K.unfoldr a b #-} - --- | Build a stream by unfolding a /monadic/ step function starting from a --- seed. The step function returns the next element in the stream and the next --- seed value. When it is done it returns 'Nothing' and the stream ends. For --- example, --- --- >>> :{ --- let f b = --- if b > 2 --- then return Nothing --- else return (Just (b, b + 1)) --- in Stream.fold Fold.toList $ Stream.unfoldrM f 0 --- :} --- [0,1,2] --- -{-# INLINE unfoldrM #-} -unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> Stream m a -unfoldrM step = fromStreamD . D.unfoldrM step - ------------------------------------------------------------------------------- --- From Values ------------------------------------------------------------------------------- - --- | --- Generate an infinite stream by repeating a pure value. --- -{-# INLINE_NORMAL repeat #-} -repeat :: Monad m => a -> Stream m a -repeat = fromStreamD . D.repeat - --- | --- >>> repeatM = Stream.sequence . Stream.repeat --- >>> repeatM = fix . Stream.consM --- >>> repeatM = cycle1 . Stream.fromEffect --- --- Generate a stream by repeatedly executing a monadic action forever. --- --- >>> :{ --- repeatAction = --- Stream.repeatM (threadDelay 1000000 >> print 1) --- & Stream.take 10 --- & Stream.fold Fold.drain --- :} --- -{-# INLINE_NORMAL repeatM #-} -repeatM :: Monad m => m a -> Stream m a -repeatM = Stream.sequence . repeat - --- | --- >>> replicate n = Stream.take n . Stream.repeat --- --- Generate a stream of length @n@ by repeating a value @n@ times. --- -{-# INLINE_NORMAL replicate #-} -replicate :: Monad m => Int -> a -> Stream m a -replicate n = fromStreamD . D.replicate n - --- | --- >>> replicateM n = Stream.sequence . Stream.replicate n --- --- Generate a stream by performing a monadic action @n@ times. -{-# INLINE_NORMAL replicateM #-} -replicateM :: Monad m => Int -> m a -> Stream m a -replicateM n = Stream.sequence . replicate n - ------------------------------------------------------------------------------- --- Time Enumeration ------------------------------------------------------------------------------- - --- | @times@ returns a stream of time value tuples with clock of 10 ms --- granularity. The first component of the tuple is an absolute time reference --- (epoch) denoting the start of the stream and the second component is a time --- relative to the reference. --- --- >>> f = Fold.drainMapM (\x -> print x >> threadDelay 1000000) --- >>> Stream.fold f $ Stream.take 3 $ Stream.times --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE times #-} -times :: MonadIO m => Stream m (AbsTime, RelTime64) -times = timesWith 0.01 - --- | @absTimes@ returns a stream of absolute timestamps using a clock of 10 ms --- granularity. --- --- >>> f = Fold.drainMapM print --- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.absTimes --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE absTimes #-} -absTimes :: MonadIO m => Stream m AbsTime -absTimes = fmap (uncurry addToAbsTime64) times - --- | @relTimes@ returns a stream of relative time values starting from 0, --- using a clock of granularity 10 ms. --- --- >>> f = Fold.drainMapM print --- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.relTimes --- RelTime64 (NanoSecond64 ...) --- RelTime64 (NanoSecond64 ...) --- RelTime64 (NanoSecond64 ...) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE relTimes #-} -relTimes :: MonadIO m => Stream m RelTime64 -relTimes = fmap snd times - --- | @durations g@ returns a stream of relative time values measuring the time --- elapsed since the immediate predecessor element of the stream was generated. --- The first element of the stream is always 0. @durations@ uses a clock of --- granularity @g@ specified in seconds. A low granularity clock is more --- expensive in terms of CPU usage. The minimum granularity is 1 millisecond. --- Durations lower than 1 ms will be 0. --- --- Note: This API is not safe on 32-bit machines. --- --- /Unimplemented/ --- -{-# INLINE durations #-} -durations :: -- Monad m => - Double -> t m RelTime64 -durations = undefined - --- | Generate a singleton event at or after the specified absolute time. Note --- that this is different from a threadDelay, a threadDelay starts from the --- time when the action is evaluated, whereas if we use AbsTime based timeout --- it will immediately expire if the action is evaluated too late. --- --- /Unimplemented/ --- -{-# INLINE timeout #-} -timeout :: -- Monad m => - AbsTime -> t m () -timeout = undefined - ------------------------------------------------------------------------------- --- Iterating functions ------------------------------------------------------------------------------- - --- | --- >>> iterate f x = x `Stream.cons` iterate f x --- --- Generate an infinite stream with @x@ as the first element and each --- successive element derived by applying the function @f@ on the previous --- element. --- --- >>> Stream.fold Fold.toList $ Stream.take 5 $ Stream.iterate (+1) 1 --- [1,2,3,4,5] --- -{-# INLINE_NORMAL iterate #-} -iterate :: Monad m => (a -> a) -> a -> Stream m a -iterate step = fromStreamD . D.iterate step - --- | --- >>> iterateM f m = m >>= \a -> return a `Stream.consM` iterateM f (f a) --- --- Generate an infinite stream with the first element generated by the action --- @m@ and each successive element derived by applying the monadic function --- @f@ on the previous element. --- --- >>> :{ --- Stream.iterateM (\x -> print x >> return (x + 1)) (return 0) --- & Stream.take 3 --- & Stream.fold Fold.toList --- :} --- 0 --- 1 --- [0,1,2] --- -{-# INLINE iterateM #-} -iterateM :: Monad m => (a -> m a) -> m a -> Stream m a -iterateM step = fromStreamD . D.iterateM step - --- | We can define cyclic structures using @let@: --- --- >>> let (a, b) = ([1, b], head a) in (a, b) --- ([1,1],1) --- --- The function @fix@ defined as: --- --- >>> fix f = let x = f x in x --- --- ensures that the argument of a function and its output refer to the same --- lazy value @x@ i.e. the same location in memory. Thus @x@ can be defined --- in terms of itself, creating structures with cyclic references. --- --- >>> f ~(a, b) = ([1, b], head a) --- >>> fix f --- ([1,1],1) --- --- 'Control.Monad.mfix' is essentially the same as @fix@ but for monadic --- values. --- --- Using 'mfix' for streams we can construct a stream in which each element of --- the stream is defined in a cyclic fashion. The argument of the function --- being fixed represents the current element of the stream which is being --- returned by the stream monad. Thus, we can use the argument to construct --- itself. --- --- In the following example, the argument @action@ of the function @f@ --- represents the tuple @(x,y)@ returned by it in a given iteration. We define --- the first element of the tuple in terms of the second. --- --- >>> import Streamly.Internal.Data.Stream as Stream --- >>> import System.IO.Unsafe (unsafeInterleaveIO) --- --- >>> :{ --- main = Stream.fold (Fold.drainMapM print) $ Stream.mfix f --- where --- f action = unCrossStream $ do --- let incr n act = fmap ((+n) . snd) $ unsafeInterleaveIO act --- x <- CrossStream (Stream.sequence $ Stream.fromList [incr 1 action, incr 2 action]) --- y <- CrossStream (Stream.fromList [4,5]) --- return (x, y) --- :} --- --- Note: you cannot achieve this by just changing the order of the monad --- statements because that would change the order in which the stream elements --- are generated. --- --- Note that the function @f@ must be lazy in its argument, that's why we use --- 'unsafeInterleaveIO' on @action@ because IO monad is strict. --- --- /CPS/ --- --- /Pre-release/ -{-# INLINE mfix #-} -mfix :: Monad m => (m a -> Stream m a) -> Stream m a -mfix f = fromStreamK $ K.mfix (toStreamK . f) - ------------------------------------------------------------------------------- --- Conversions ------------------------------------------------------------------------------- - --- | --- >>> fromFoldable = Prelude.foldr Stream.cons Stream.nil --- --- Construct a stream from a 'Foldable' containing pure values: --- --- /CPS/ --- -{-# INLINE fromFoldable #-} -fromFoldable :: Foldable f => f a -> Stream m a -fromFoldable = fromStreamK . K.fromFoldable - ------------------------------------------------------------------------------- --- From pointers ------------------------------------------------------------------------------- - --- | Keep reading 'Storable' elements from 'Ptr' onwards. --- --- /Unsafe:/ The caller is responsible for safe addressing. --- --- /Pre-release/ -{-# INLINE fromPtr #-} -fromPtr :: (MonadIO m, Storable a) => Ptr a -> Stream m a -fromPtr = Stream.fromStreamD . D.fromPtr - --- | Take @n@ 'Storable' elements starting from 'Ptr' onwards. --- --- >>> fromPtrN n = Stream.take n . Stream.fromPtr --- --- /Unsafe:/ The caller is responsible for safe addressing. --- --- /Pre-release/ -{-# INLINE fromPtrN #-} -fromPtrN :: (MonadIO m, Storable a) => Int -> Ptr a -> Stream m a -fromPtrN n = Stream.fromStreamD . D.take n . D.fromPtr - --- | Read bytes from an 'Addr#' until a 0 byte is encountered, the 0 byte is --- not included in the stream. --- --- >>> fromByteStr# addr = Stream.takeWhile (/= 0) $ Stream.fromPtr $ Ptr addr --- --- /Unsafe:/ The caller is responsible for safe addressing. --- --- Note that this is completely safe when reading from Haskell string --- literals because they are guaranteed to be NULL terminated: --- --- >>> Stream.fold Fold.toList $ Stream.fromByteStr# "\1\2\3\0"# --- [1,2,3] --- -{-# INLINE fromByteStr# #-} -fromByteStr# :: MonadIO m => Addr# -> Stream m Word8 -fromByteStr# addr = - Stream.fromStreamD $ D.takeWhile (/= 0) $ D.fromPtr $ Ptr addr - --- | Construct a stream by reading an 'Unboxed' 'IORef' repeatedly. --- --- /Pre-release/ --- -{-# INLINE fromUnboxedIORef #-} -fromUnboxedIORef :: (MonadIO m, Unbox a) => Unboxed.IORef a -> Stream m a -fromUnboxedIORef = fromStreamD . Unboxed.toStreamD +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Stream.Generate +-- Copyright : (c) 2020 Composewell Technologies and Contributors +-- (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +-- A few combinators in this module have been adapted from the vector package +-- (c) Roman Leshchinskiy. See the notes in specific combinators. +-- +module Streamly.Internal.Data.Stream.Generate + ( + -- * Primitives + nil + , cons + + -- * Unfolding + , unfoldr + , unfoldrM + + -- * From Values + , repeat + , repeatM + , replicate + , replicateM + + -- * Enumeration + -- ** Enumerating 'Num' Types + , enumerateFromStepNum + , enumerateFromNum + , enumerateFromThenNum + + -- ** Enumerating 'Bounded' 'Enum' Types + , enumerate + , enumerateTo + , enumerateFromBounded + + -- ** Enumerating 'Enum' Types not larger than 'Int' + , enumerateFromToSmall + , enumerateFromThenToSmall + , enumerateFromThenSmallBounded + + -- ** Enumerating 'Bounded' 'Integral' Types + , enumerateFromIntegral + , enumerateFromThenIntegral + + -- ** Enumerating 'Integral' Types + , enumerateFromToIntegral + , enumerateFromThenToIntegral + + -- ** Enumerating unbounded 'Integral' Types + , enumerateFromStepIntegral + + -- ** Enumerating 'Fractional' Types + , enumerateFromFractional + , enumerateFromToFractional + , enumerateFromThenFractional + , enumerateFromThenToFractional + + -- ** Enumerable Type Class + , Enumerable(..) + + -- * Time Enumeration + , times + , timesWith + , absTimes + , absTimesWith + , relTimes + , relTimesWith + , durations + , timeout + + -- * From Generators + -- | Generate a monadic stream from a seed. + , fromIndices + , fromIndicesM + , generate + , generateM + + -- * Iteration + , iterate + , iterateM + + -- * From Containers + -- | Transform an input structure into a stream. + + , fromListM + , fromFoldable + , fromFoldableM + + -- * From Pointers + , fromPtr + , fromPtrN + , fromCString# + , fromW16CString# + + -- * Deprecated + , fromByteStr# + ) +where + +#include "inline.hs" +#include "ArrayMacros.h" + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Functor.Identity (Identity(..)) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (Storable (peek), sizeOf) +import GHC.Exts (Addr#, Ptr (Ptr)) +import Streamly.Internal.Data.Time.Clock + (Clock(Monotonic), asyncClock, readClock) +import Streamly.Internal.Data.Time.Units + (toAbsTime, AbsTime, toRelTime64, RelTime64, addToAbsTime64) +import Streamly.Internal.System.IO (unsafeInlineIO) + +#ifdef USE_UNFOLDS_EVERYWHERE +import qualified Streamly.Internal.Data.Unfold as Unfold +#endif + +import Data.Fixed +import Data.Int +import Data.Ratio +import Data.Word +import Numeric.Natural +import Prelude hiding (iterate, repeat, replicate, take, takeWhile) +import Streamly.Internal.Data.Stream.Type + +#include "DocTestDataStream.hs" + +------------------------------------------------------------------------------ +-- Primitives +------------------------------------------------------------------------------ + +-- XXX implement in terms of nilM? + +-- | A stream that terminates without producing any output or side effect. +-- +-- >>> Stream.toList Stream.nil +-- [] +-- +{-# INLINE_NORMAL nil #-} +nil :: Applicative m => Stream m a +nil = Stream (\_ _ -> pure Stop) () + +infixr 5 `cons` + +-- XXX implement in terms of consM? +-- cons x = consM (return x) +-- From an implementation perspective, StreamK.cons translates into a +-- functional call whereas fused cons translates into a conditional branch +-- (jump). However, the overhead of the function call in StreamK.cons only +-- occurs once, while the overhead of the conditional branch in fused cons is +-- incurred for each subsequent element in the stream. As a result, +-- StreamK.cons has a time complexity of O(n), while fused cons has a time +-- complexity of O(n^2), where @n@ represents the number of 'cons' used. + +-- When composing a few elements together statically, a balanced tree composed +-- using 'cons' and 'append' is more efficient than a right associated one +-- composed using 'cons': +-- +-- >>> s1 = 1 `Stream.cons` 2 `Stream.cons` Stream.nil +-- >>> s2 = 2 `Stream.cons` 3 `Stream.cons` Stream.nil +-- >>> s = s1 `Stream.append` s2 +-- +-- However, generating a stream using a case statement or indexing into a +-- static literal array would be the best. Check if the case statement +-- translates to a look up table or a binary search. + +-- | WARNING! O(n^2) time complexity wrt number of elements. Use the O(n) +-- complexity StreamK.'Streamly.Data.StreamK.cons' unless you want to +-- statically fuse just a few elements. +-- +-- Fuse a pure value at the head of an existing stream:: +-- +-- >>> s = 1 `Stream.cons` Stream.fromList [2,3] +-- >>> Stream.toList s +-- [1,2,3] +-- +-- Definition: +-- +-- >>> cons x xs = return x `Stream.consM` xs +-- +{-# INLINE_NORMAL cons #-} +cons :: Applicative m => a -> Stream m a -> Stream m a +cons x (Stream step state) = Stream step1 Nothing + where + {-# INLINE_LATE step1 #-} + step1 _ Nothing = pure $ Yield x (Just state) + step1 gst (Just st) = do + (\case + Yield a s -> Yield a (Just s) + Skip s -> Skip (Just s) + Stop -> Stop) <$> step gst st + +------------------------------------------------------------------------------ +-- Unfolding +------------------------------------------------------------------------------ + +-- Adapted from vector package + +-- | Build a stream by unfolding a /monadic/ step function starting from a +-- seed. The step function returns the next element in the stream and the next +-- seed value. When it is done it returns 'Nothing' and the stream ends. For +-- example, +-- +-- >>> :{ +-- let f b = +-- if b > 2 +-- then return Nothing +-- else return (Just (b, b + 1)) +-- in Stream.toList $ Stream.unfoldrM f 0 +-- :} +-- [0,1,2] +-- +{-# INLINE_NORMAL unfoldrM #-} +unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +unfoldrM next = unfold (Unfold.unfoldrM next) +#else +unfoldrM next = Stream step + where + {-# INLINE_LATE step #-} + step _ st = do + r <- next st + return $ case r of + Just (x, s) -> Yield x s + Nothing -> Stop +#endif + +-- | Build a stream by unfolding a /pure/ step function @step@ starting from a +-- seed @s@. The step function returns the next element in the stream and the +-- next seed value. When it is done it returns 'Nothing' and the stream ends. +-- For example, +-- +-- >>> :{ +-- let f b = +-- if b > 2 +-- then Nothing +-- else Just (b, b + 1) +-- in Stream.toList $ Stream.unfoldr f 0 +-- :} +-- [0,1,2] +-- +{-# INLINE_LATE unfoldr #-} +unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a +unfoldr f = unfoldrM (return . f) + +------------------------------------------------------------------------------ +-- From values +------------------------------------------------------------------------------ + +-- | +-- >>> repeatM act = Stream.iterateM (const act) act +-- >>> repeatM = Stream.sequence . Stream.repeat +-- +-- Generate a stream by repeatedly executing a monadic action forever. +-- +-- >>> :{ +-- repeatAction = +-- Stream.repeatM (threadDelay 1000000 >> print 1) +-- & Stream.take 10 +-- & Stream.fold Fold.drain +-- :} +-- +{-# INLINE_NORMAL repeatM #-} +repeatM :: Monad m => m a -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +repeatM = unfold Unfold.repeatM +#else +repeatM x = Stream (\_ _ -> x >>= \r -> return $ Yield r ()) () +#endif + +-- | +-- Generate an infinite stream by repeating a pure value. +-- +-- >>> repeat = Stream.iterate id +-- >>> repeat x = Stream.repeatM (pure x) +-- +{-# INLINE_NORMAL repeat #-} +repeat :: Monad m => a -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +repeat x = repeatM (pure x) +#else +repeat x = Stream (\_ _ -> return $ Yield x ()) () +#endif + +-- Adapted from the vector package + +-- | +-- >>> replicateM n = Stream.sequence . Stream.replicate n +-- +-- Generate a stream by performing a monadic action @n@ times. +{-# INLINE_NORMAL replicateM #-} +replicateM :: Monad m => Int -> m a -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +replicateM n p = unfold Unfold.replicateM (n, p) +#else +replicateM n p = Stream step n + where + {-# INLINE_LATE step #-} + step _ (i :: Int) + | i <= 0 = return Stop + | otherwise = do + x <- p + return $ Yield x (i - 1) +#endif + +-- | +-- >>> replicate n = Stream.take n . Stream.repeat +-- >>> replicate n x = Stream.replicateM n (pure x) +-- +-- Generate a stream of length @n@ by repeating a value @n@ times. +-- +{-# INLINE_NORMAL replicate #-} +replicate :: Monad m => Int -> a -> Stream m a +replicate n x = replicateM n (return x) + +------------------------------------------------------------------------------ +-- Enumeration of Num +------------------------------------------------------------------------------ + +-- | For floating point numbers if the increment is less than the precision then +-- it just gets lost. Therefore we cannot always increment it correctly by just +-- repeated addition. +-- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15 +-- 9007199254740992 + 2 :: Double => 9.007199254740994e15 +-- +-- Instead we accumulate the increment counter and compute the increment +-- every time before adding it to the starting number. +-- +-- This works for Integrals as well as floating point numbers, but +-- enumerateFromStepIntegral is faster for integrals. +{-# INLINE_NORMAL enumerateFromStepNum #-} +enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +enumerateFromStepNum from stride = + unfold Unfold.enumerateFromStepNum (from, stride) +#else +enumerateFromStepNum from stride = Stream step 0 + where + {-# INLINE_LATE step #-} + step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1) +#endif + +{-# INLINE_NORMAL enumerateFromNum #-} +enumerateFromNum :: (Monad m, Num a) => a -> Stream m a +enumerateFromNum from = enumerateFromStepNum from 1 + +{-# INLINE_NORMAL enumerateFromThenNum #-} +enumerateFromThenNum :: (Monad m, Num a) => a -> a -> Stream m a +enumerateFromThenNum from next = enumerateFromStepNum from (next - from) + +------------------------------------------------------------------------------ +-- Enumeration of Integrals +------------------------------------------------------------------------------ + +#ifndef USE_UNFOLDS_EVERYWHERE +data EnumState a = EnumInit | EnumYield a a a | EnumStop + +{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-} +enumerateFromThenToIntegralUp + :: (Monad m, Integral a) + => a -> a -> a -> Stream m a +enumerateFromThenToIntegralUp from next to = Stream step EnumInit + where + {-# INLINE_LATE step #-} + step _ EnumInit = + return $ + if to < next + then if to < from + then Stop + else Yield from EnumStop + else -- from <= next <= to + let stride = next - from + in Skip $ EnumYield from stride (to - stride) + + step _ (EnumYield x stride toMinus) = + return $ + if x > toMinus + then Yield x EnumStop + else Yield x $ EnumYield (x + stride) stride toMinus + + step _ EnumStop = return Stop + +{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-} +enumerateFromThenToIntegralDn + :: (Monad m, Integral a) + => a -> a -> a -> Stream m a +enumerateFromThenToIntegralDn from next to = Stream step EnumInit + where + {-# INLINE_LATE step #-} + step _ EnumInit = + return $ if to > next + then if to > from + then Stop + else Yield from EnumStop + else -- from >= next >= to + let stride = next - from + in Skip $ EnumYield from stride (to - stride) + + step _ (EnumYield x stride toMinus) = + return $ + if x < toMinus + then Yield x EnumStop + else Yield x $ EnumYield (x + stride) stride toMinus + + step _ EnumStop = return Stop +#endif + +-- XXX This can perhaps be simplified and written in terms of +-- enumeratFromStepIntegral as we have done in unfolds. + +-- | Enumerate an 'Integral' type in steps up to a given limit. +-- @enumerateFromThenToIntegral from then to@ generates a finite stream whose +-- first element is @from@, the second element is @then@ and the successive +-- elements are in increments of @then - from@ up to @to@. +-- +-- >>> Stream.toList $ Stream.enumerateFromThenToIntegral 0 2 6 +-- [0,2,4,6] +-- +-- >>> Stream.toList $ Stream.enumerateFromThenToIntegral 0 (-2) (-6) +-- [0,-2,-4,-6] +-- +{-# INLINE_NORMAL enumerateFromThenToIntegral #-} +enumerateFromThenToIntegral + :: (Monad m, Integral a) + => a -> a -> a -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +enumerateFromThenToIntegral from next to = + unfold Unfold.enumerateFromThenToIntegral (from, next, to) +#else +enumerateFromThenToIntegral from next to + | next >= from = enumerateFromThenToIntegralUp from next to + | otherwise = enumerateFromThenToIntegralDn from next to +#endif + +-- | Enumerate an 'Integral' type in steps. @enumerateFromThenIntegral from +-- then@ generates a stream whose first element is @from@, the second element +-- is @then@ and the successive elements are in increments of @then - from@. +-- The stream is bounded by the size of the 'Integral' type. +-- +-- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThenIntegral (0 :: Int) 2 +-- [0,2,4,6] +-- +-- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThenIntegral (0 :: Int) (-2) +-- [0,-2,-4,-6] +-- +{-# INLINE_NORMAL enumerateFromThenIntegral #-} +enumerateFromThenIntegral + :: (Monad m, Integral a, Bounded a) + => a -> a -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +enumerateFromThenIntegral from next = + unfold Unfold.enumerateFromThenIntegralBounded (from, next) +#else +enumerateFromThenIntegral from next = + if next > from + then enumerateFromThenToIntegralUp from next maxBound + else enumerateFromThenToIntegralDn from next minBound +#endif + +-- | @enumerateFromStepIntegral from step@ generates an infinite stream whose +-- first element is @from@ and the successive elements are in increments of +-- @step@. +-- +-- CAUTION: This function is not safe for finite integral types. It does not +-- check for overflow, underflow or bounds. +-- +-- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromStepIntegral 0 2 +-- [0,2,4,6] +-- +-- >>> Stream.toList $ Stream.take 3 $ Stream.enumerateFromStepIntegral 0 (-2) +-- [0,-2,-4] +-- +{-# INLINE_NORMAL enumerateFromStepIntegral #-} +enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +enumerateFromStepIntegral from stride = + unfold Unfold.enumerateFromStepIntegral (from, stride) +#else +enumerateFromStepIntegral from stride = + from `seq` stride `seq` Stream step from + where + {-# INLINE_LATE step #-} + step _ !x = return $ Yield x $! (x + stride) +#endif + +-- | Enumerate an 'Integral' type up to a given limit. +-- @enumerateFromToIntegral from to@ generates a finite stream whose first +-- element is @from@ and successive elements are in increments of @1@ up to +-- @to@. +-- +-- >>> Stream.toList $ Stream.enumerateFromToIntegral 0 4 +-- [0,1,2,3,4] +-- +{-# INLINE enumerateFromToIntegral #-} +enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a +enumerateFromToIntegral from to = + takeWhile (<= to) $ enumerateFromStepIntegral from 1 + +-- | Enumerate an 'Integral' type. @enumerateFromIntegral from@ generates a +-- stream whose first element is @from@ and the successive elements are in +-- increments of @1@. The stream is bounded by the size of the 'Integral' type. +-- +-- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromIntegral (0 :: Int) +-- [0,1,2,3] +-- +{-# INLINE enumerateFromIntegral #-} +enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a +enumerateFromIntegral from = enumerateFromToIntegral from maxBound + +------------------------------------------------------------------------------ +-- Enumeration of Fractionals +------------------------------------------------------------------------------ + +-- We cannot write a general function for Num. The only way to write code +-- portable between the two is to use a 'Real' constraint and convert between +-- Fractional and Integral using fromRational which is horribly slow. + +-- Even though the underlying implementation of enumerateFromFractional and +-- enumerateFromThenFractional works for any 'Num' we have restricted these to +-- 'Fractional' because these do not perform any bounds check, in contrast to +-- integral versions and are therefore not equivalent substitutes for those. + +-- | Numerically stable enumeration from a 'Fractional' number in steps of size +-- @1@. @enumerateFromFractional from@ generates a stream whose first element +-- is @from@ and the successive elements are in increments of @1@. No overflow +-- or underflow checks are performed. +-- +-- This is the equivalent to 'enumFrom' for 'Fractional' types. For example: +-- +-- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromFractional 1.1 +-- [1.1,2.1,3.1,4.1] +-- +{-# INLINE enumerateFromFractional #-} +enumerateFromFractional :: (Monad m, Fractional a) => a -> Stream m a +enumerateFromFractional = enumerateFromNum + +-- | Numerically stable enumeration from a 'Fractional' number in steps. +-- @enumerateFromThenFractional from then@ generates a stream whose first +-- element is @from@, the second element is @then@ and the successive elements +-- are in increments of @then - from@. No overflow or underflow checks are +-- performed. +-- +-- This is the equivalent of 'enumFromThen' for 'Fractional' types. For +-- example: +-- +-- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThenFractional 1.1 2.1 +-- [1.1,2.1,3.1,4.1] +-- +-- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThenFractional 1.1 (-2.1) +-- [1.1,-2.1,-5.300000000000001,-8.500000000000002] +-- +{-# INLINE enumerateFromThenFractional #-} +enumerateFromThenFractional + :: (Monad m, Fractional a) + => a -> a -> Stream m a +enumerateFromThenFractional = enumerateFromThenNum + +-- | Numerically stable enumeration from a 'Fractional' number to a given +-- limit. @enumerateFromToFractional from to@ generates a finite stream whose +-- first element is @from@ and successive elements are in increments of @1@ up +-- to @to@. +-- +-- This is the equivalent of 'enumFromTo' for 'Fractional' types. For +-- example: +-- +-- >>> Stream.toList $ Stream.enumerateFromToFractional 1.1 4 +-- [1.1,2.1,3.1,4.1] +-- +-- >>> Stream.toList $ Stream.enumerateFromToFractional 1.1 4.6 +-- [1.1,2.1,3.1,4.1,5.1] +-- +-- Notice that the last element is equal to the specified @to@ value after +-- rounding to the nearest integer. +-- +{-# INLINE_NORMAL enumerateFromToFractional #-} +enumerateFromToFractional + :: (Monad m, Fractional a, Ord a) + => a -> a -> Stream m a +enumerateFromToFractional from to = + takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1 + +-- | Numerically stable enumeration from a 'Fractional' number in steps up to a +-- given limit. @enumerateFromThenToFractional from then to@ generates a +-- finite stream whose first element is @from@, the second element is @then@ +-- and the successive elements are in increments of @then - from@ up to @to@. +-- +-- This is the equivalent of 'enumFromThenTo' for 'Fractional' types. For +-- example: +-- +-- >>> Stream.toList $ Stream.enumerateFromThenToFractional 0.1 2 6 +-- [0.1,2.0,3.9,5.799999999999999] +-- +-- >>> Stream.toList $ Stream.enumerateFromThenToFractional 0.1 (-2) (-6) +-- [0.1,-2.0,-4.1000000000000005,-6.200000000000001] +-- +{-# INLINE_NORMAL enumerateFromThenToFractional #-} +enumerateFromThenToFractional + :: (Monad m, Fractional a, Ord a) + => a -> a -> a -> Stream m a +enumerateFromThenToFractional from next to = + takeWhile predicate $ enumerateFromThenFractional from next + where + mid = (next - from) / 2 + predicate | next >= from = (<= to + mid) + | otherwise = (>= to + mid) + +------------------------------------------------------------------------------- +-- Enumeration of Enum types not larger than Int +------------------------------------------------------------------------------- +-- +-- | 'enumerateFromTo' for 'Enum' types not larger than 'Int'. +-- +{-# INLINE enumerateFromToSmall #-} +enumerateFromToSmall :: (Monad m, Enum a) => a -> a -> Stream m a +enumerateFromToSmall from to = + fmap toEnum + $ enumerateFromToIntegral (fromEnum from) (fromEnum to) + +-- | 'enumerateFromThenTo' for 'Enum' types not larger than 'Int'. +-- +{-# INLINE enumerateFromThenToSmall #-} +enumerateFromThenToSmall :: (Monad m, Enum a) + => a -> a -> a -> Stream m a +enumerateFromThenToSmall from next to = + fmap toEnum + $ enumerateFromThenToIntegral + (fromEnum from) (fromEnum next) (fromEnum to) + +-- | 'enumerateFromThen' for 'Enum' types not larger than 'Int'. +-- +-- Note: We convert the 'Enum' to 'Int' and enumerate the 'Int'. If a +-- type is bounded but does not have a 'Bounded' instance then we can go on +-- enumerating it beyond the legal values of the type, resulting in the failure +-- of 'toEnum' when converting back to 'Enum'. Therefore we require a 'Bounded' +-- instance for this function to be safely used. +-- +{-# INLINE enumerateFromThenSmallBounded #-} +enumerateFromThenSmallBounded :: (Monad m, Enumerable a, Bounded a) + => a -> a -> Stream m a +enumerateFromThenSmallBounded from next = + if fromEnum next >= fromEnum from + then enumerateFromThenTo from next maxBound + else enumerateFromThenTo from next minBound + +------------------------------------------------------------------------------- +-- Enumerable type class +------------------------------------------------------------------------------- +-- +-- NOTE: We would like to rewrite calls to fromList [1..] etc. to stream +-- enumerations like this: +-- +-- {-# RULES "fromList enumFrom" [1] +-- forall (a :: Int). D.fromList (enumFrom a) = D.enumerateFromIntegral a #-} +-- +-- But this does not work because enumFrom is a class method and GHC rewrites +-- it quickly, so we do not get a chance to have our rule fired. + +-- | Types that can be enumerated as a stream. The operations in this type +-- class are equivalent to those in the 'Enum' type class, except that these +-- generate a stream instead of a list. Use the functions in +-- "Streamly.Internal.Data.Stream.Enumeration" module to define new instances. +-- +class Enum a => Enumerable a where + -- | @enumerateFrom from@ generates a stream starting with the element + -- @from@, enumerating up to 'maxBound' when the type is 'Bounded' or + -- generating an infinite stream when the type is not 'Bounded'. + -- + -- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFrom (0 :: Int) + -- [0,1,2,3] + -- + -- For 'Fractional' types, enumeration is numerically stable. However, no + -- overflow or underflow checks are performed. + -- + -- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFrom 1.1 + -- [1.1,2.1,3.1,4.1] + -- + enumerateFrom :: (Monad m) => a -> Stream m a + + -- | Generate a finite stream starting with the element @from@, enumerating + -- the type up to the value @to@. If @to@ is smaller than @from@ then an + -- empty stream is returned. + -- + -- >>> Stream.toList $ Stream.enumerateFromTo 0 4 + -- [0,1,2,3,4] + -- + -- For 'Fractional' types, the last element is equal to the specified @to@ + -- value after rounding to the nearest integral value. + -- + -- >>> Stream.toList $ Stream.enumerateFromTo 1.1 4 + -- [1.1,2.1,3.1,4.1] + -- + -- >>> Stream.toList $ Stream.enumerateFromTo 1.1 4.6 + -- [1.1,2.1,3.1,4.1,5.1] + -- + enumerateFromTo :: (Monad m) => a -> a -> Stream m a + + -- | @enumerateFromThen from then@ generates a stream whose first element + -- is @from@, the second element is @then@ and the successive elements are + -- in increments of @then - from@. Enumeration can occur downwards or + -- upwards depending on whether @then@ comes before or after @from@. For + -- 'Bounded' types the stream ends when 'maxBound' is reached, for + -- unbounded types it keeps enumerating infinitely. + -- + -- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThen 0 2 + -- [0,2,4,6] + -- + -- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThen 0 (-2) + -- [0,-2,-4,-6] + -- + enumerateFromThen :: (Monad m) => a -> a -> Stream m a + + -- | @enumerateFromThenTo from then to@ generates a finite stream whose + -- first element is @from@, the second element is @then@ and the successive + -- elements are in increments of @then - from@ up to @to@. Enumeration can + -- occur downwards or upwards depending on whether @then@ comes before or + -- after @from@. + -- + -- >>> Stream.toList $ Stream.enumerateFromThenTo 0 2 6 + -- [0,2,4,6] + -- + -- >>> Stream.toList $ Stream.enumerateFromThenTo 0 (-2) (-6) + -- [0,-2,-4,-6] + -- + enumerateFromThenTo :: (Monad m) => a -> a -> a -> Stream m a + +-- MAYBE: Sometimes it is more convenient to know the count rather then the +-- ending or starting element. For those cases we can define the folllowing +-- APIs. All of these will work only for bounded types if we represent the +-- count by Int. +-- +-- enumerateN +-- enumerateFromN +-- enumerateToN +-- enumerateFromStep +-- enumerateFromStepN + +------------------------------------------------------------------------------- +-- Convenient functions for bounded types +------------------------------------------------------------------------------- +-- +-- | +-- > enumerate = enumerateFrom minBound +-- +-- Enumerate a 'Bounded' type from its 'minBound' to 'maxBound' +-- +{-# INLINE enumerate #-} +enumerate :: (Monad m, Bounded a, Enumerable a) => Stream m a +enumerate = enumerateFrom minBound + +-- | +-- >>> enumerateTo = Stream.enumerateFromTo minBound +-- +-- Enumerate a 'Bounded' type from its 'minBound' to specified value. +-- +{-# INLINE enumerateTo #-} +enumerateTo :: (Monad m, Bounded a, Enumerable a) => a -> Stream m a +enumerateTo = enumerateFromTo minBound + +-- | +-- >>> enumerateFromBounded from = Stream.enumerateFromTo from maxBound +-- +-- 'enumerateFrom' for 'Bounded' 'Enum' types. +-- +{-# INLINE enumerateFromBounded #-} +enumerateFromBounded :: (Monad m, Enumerable a, Bounded a) + => a -> Stream m a +enumerateFromBounded from = enumerateFromTo from maxBound + +------------------------------------------------------------------------------- +-- Enumerable Instances +------------------------------------------------------------------------------- +-- +-- For Enum types smaller than or equal to Int size. +#define ENUMERABLE_BOUNDED_SMALL(SMALL_TYPE) \ +instance Enumerable SMALL_TYPE where { \ + {-# INLINE enumerateFrom #-}; \ + enumerateFrom = enumerateFromBounded; \ + {-# INLINE enumerateFromThen #-}; \ + enumerateFromThen = enumerateFromThenSmallBounded; \ + {-# INLINE enumerateFromTo #-}; \ + enumerateFromTo = enumerateFromToSmall; \ + {-# INLINE enumerateFromThenTo #-}; \ + enumerateFromThenTo = enumerateFromThenToSmall } + +ENUMERABLE_BOUNDED_SMALL(()) +ENUMERABLE_BOUNDED_SMALL(Bool) +ENUMERABLE_BOUNDED_SMALL(Ordering) +ENUMERABLE_BOUNDED_SMALL(Char) + +-- For bounded Integral Enum types, may be larger than Int. +#define ENUMERABLE_BOUNDED_INTEGRAL(INTEGRAL_TYPE) \ +instance Enumerable INTEGRAL_TYPE where { \ + {-# INLINE enumerateFrom #-}; \ + enumerateFrom = enumerateFromIntegral; \ + {-# INLINE enumerateFromThen #-}; \ + enumerateFromThen = enumerateFromThenIntegral; \ + {-# INLINE enumerateFromTo #-}; \ + enumerateFromTo = enumerateFromToIntegral; \ + {-# INLINE enumerateFromThenTo #-}; \ + enumerateFromThenTo = enumerateFromThenToIntegral } + +ENUMERABLE_BOUNDED_INTEGRAL(Int) +ENUMERABLE_BOUNDED_INTEGRAL(Int8) +ENUMERABLE_BOUNDED_INTEGRAL(Int16) +ENUMERABLE_BOUNDED_INTEGRAL(Int32) +ENUMERABLE_BOUNDED_INTEGRAL(Int64) +ENUMERABLE_BOUNDED_INTEGRAL(Word) +ENUMERABLE_BOUNDED_INTEGRAL(Word8) +ENUMERABLE_BOUNDED_INTEGRAL(Word16) +ENUMERABLE_BOUNDED_INTEGRAL(Word32) +ENUMERABLE_BOUNDED_INTEGRAL(Word64) + +-- For unbounded Integral Enum types. +#define ENUMERABLE_UNBOUNDED_INTEGRAL(INTEGRAL_TYPE) \ +instance Enumerable INTEGRAL_TYPE where { \ + {-# INLINE enumerateFrom #-}; \ + enumerateFrom from = enumerateFromStepIntegral from 1; \ + {-# INLINE enumerateFromThen #-}; \ + enumerateFromThen from next = \ + enumerateFromStepIntegral from (next - from); \ + {-# INLINE enumerateFromTo #-}; \ + enumerateFromTo = enumerateFromToIntegral; \ + {-# INLINE enumerateFromThenTo #-}; \ + enumerateFromThenTo = enumerateFromThenToIntegral } + +ENUMERABLE_UNBOUNDED_INTEGRAL(Integer) +ENUMERABLE_UNBOUNDED_INTEGRAL(Natural) + +#define ENUMERABLE_FRACTIONAL(FRACTIONAL_TYPE,CONSTRAINT) \ +instance (CONSTRAINT) => Enumerable FRACTIONAL_TYPE where { \ + {-# INLINE enumerateFrom #-}; \ + enumerateFrom = enumerateFromFractional; \ + {-# INLINE enumerateFromThen #-}; \ + enumerateFromThen = enumerateFromThenFractional; \ + {-# INLINE enumerateFromTo #-}; \ + enumerateFromTo = enumerateFromToFractional; \ + {-# INLINE enumerateFromThenTo #-}; \ + enumerateFromThenTo = enumerateFromThenToFractional } + +ENUMERABLE_FRACTIONAL(Float,) +ENUMERABLE_FRACTIONAL(Double,) +ENUMERABLE_FRACTIONAL((Fixed a),HasResolution a) +ENUMERABLE_FRACTIONAL((Ratio a),Integral a) + +instance Enumerable a => Enumerable (Identity a) where + {-# INLINE enumerateFrom #-} + enumerateFrom (Identity from) = + fmap Identity $ enumerateFrom from + {-# INLINE enumerateFromThen #-} + enumerateFromThen (Identity from) (Identity next) = + fmap Identity $ enumerateFromThen from next + {-# INLINE enumerateFromTo #-} + enumerateFromTo (Identity from) (Identity to) = + fmap Identity $ enumerateFromTo from to + {-# INLINE enumerateFromThenTo #-} + enumerateFromThenTo (Identity from) (Identity next) (Identity to) = + fmap Identity + $ enumerateFromThenTo from next to + +-- TODO +{- +instance Enumerable a => Enumerable (Last a) +instance Enumerable a => Enumerable (First a) +instance Enumerable a => Enumerable (Max a) +instance Enumerable a => Enumerable (Min a) +instance Enumerable a => Enumerable (Const a b) +instance Enumerable (f a) => Enumerable (Alt f a) +instance Enumerable (f a) => Enumerable (Ap f a) +-} +------------------------------------------------------------------------------ +-- Time Enumeration +------------------------------------------------------------------------------ + +-- | @timesWith g@ returns a stream of time value tuples. The first component +-- of the tuple is an absolute time reference (epoch) denoting the start of the +-- stream and the second component is a time relative to the reference. +-- +-- The argument @g@ specifies the granularity of the relative time in seconds. +-- A lower granularity clock gives higher precision but is more expensive in +-- terms of CPU usage. Any granularity lower than 1 ms is treated as 1 ms. +-- +-- >>> import Control.Concurrent (threadDelay) +-- >>> f = Fold.drainMapM (\x -> print x >> threadDelay 1000000) +-- >>> Stream.fold f $ Stream.take 3 $ Stream.timesWith 0.01 +-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) +-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) +-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) +-- +-- Note: This API is not safe on 32-bit machines. +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL timesWith #-} +timesWith :: MonadIO m => Double -> Stream m (AbsTime, RelTime64) +timesWith g = Stream step Nothing + + where + + {-# INLINE_LATE step #-} + step _ Nothing = do + clock <- liftIO $ asyncClock Monotonic g + a <- liftIO $ readClock clock + return $ Skip $ Just (clock, a) + + step _ s@(Just (clock, t0)) = do + a <- liftIO $ readClock clock + -- XXX we can perhaps use an AbsTime64 using a 64 bit Int for + -- efficiency. or maybe we can use a representation using Double for + -- floating precision time + return $ Yield (toAbsTime t0, toRelTime64 (a - t0)) s + +-- | @absTimesWith g@ returns a stream of absolute timestamps using a clock of +-- granularity @g@ specified in seconds. A low granularity clock is more +-- expensive in terms of CPU usage. Any granularity lower than 1 ms is treated +-- as 1 ms. +-- +-- >>> f = Fold.drainMapM print +-- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.absTimesWith 0.01 +-- AbsTime (TimeSpec {sec = ..., nsec = ...}) +-- AbsTime (TimeSpec {sec = ..., nsec = ...}) +-- AbsTime (TimeSpec {sec = ..., nsec = ...}) +-- +-- Note: This API is not safe on 32-bit machines. +-- +-- /Pre-release/ +-- +{-# INLINE absTimesWith #-} +absTimesWith :: MonadIO m => Double -> Stream m AbsTime +absTimesWith = fmap (uncurry addToAbsTime64) . timesWith + +-- | @relTimesWith g@ returns a stream of relative time values starting from 0, +-- using a clock of granularity @g@ specified in seconds. A low granularity +-- clock is more expensive in terms of CPU usage. Any granularity lower than 1 +-- ms is treated as 1 ms. +-- +-- >>> f = Fold.drainMapM print +-- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.relTimesWith 0.01 +-- RelTime64 (NanoSecond64 ...) +-- RelTime64 (NanoSecond64 ...) +-- RelTime64 (NanoSecond64 ...) +-- +-- Note: This API is not safe on 32-bit machines. +-- +-- /Pre-release/ +-- +{-# INLINE relTimesWith #-} +relTimesWith :: MonadIO m => Double -> Stream m RelTime64 +relTimesWith = fmap snd . timesWith + +-- | @times@ returns a stream of time value tuples with clock of 10 ms +-- granularity. The first component of the tuple is an absolute time reference +-- (epoch) denoting the start of the stream and the second component is a time +-- relative to the reference. +-- +-- >>> f = Fold.drainMapM (\x -> print x >> threadDelay 1000000) +-- >>> Stream.fold f $ Stream.take 3 $ Stream.times +-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) +-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) +-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) +-- +-- Note: This API is not safe on 32-bit machines. +-- +-- /Pre-release/ +-- +{-# INLINE times #-} +times :: MonadIO m => Stream m (AbsTime, RelTime64) +times = timesWith 0.01 + +-- | @absTimes@ returns a stream of absolute timestamps using a clock of 10 ms +-- granularity. +-- +-- >>> f = Fold.drainMapM print +-- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.absTimes +-- AbsTime (TimeSpec {sec = ..., nsec = ...}) +-- AbsTime (TimeSpec {sec = ..., nsec = ...}) +-- AbsTime (TimeSpec {sec = ..., nsec = ...}) +-- +-- Note: This API is not safe on 32-bit machines. +-- +-- /Pre-release/ +-- +{-# INLINE absTimes #-} +absTimes :: MonadIO m => Stream m AbsTime +absTimes = fmap (uncurry addToAbsTime64) times + +-- | @relTimes@ returns a stream of relative time values starting from 0, +-- using a clock of granularity 10 ms. +-- +-- >>> f = Fold.drainMapM print +-- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.relTimes +-- RelTime64 (NanoSecond64 ...) +-- RelTime64 (NanoSecond64 ...) +-- RelTime64 (NanoSecond64 ...) +-- +-- Note: This API is not safe on 32-bit machines. +-- +-- /Pre-release/ +-- +{-# INLINE relTimes #-} +relTimes :: MonadIO m => Stream m RelTime64 +relTimes = fmap snd times + +-- | @durations g@ returns a stream of relative time values measuring the time +-- elapsed since the immediate predecessor element of the stream was generated. +-- The first element of the stream is always 0. @durations@ uses a clock of +-- granularity @g@ specified in seconds. A low granularity clock is more +-- expensive in terms of CPU usage. The minimum granularity is 1 millisecond. +-- Durations lower than 1 ms will be 0. +-- +-- Note: This API is not safe on 32-bit machines. +-- +-- /Unimplemented/ +-- +{-# INLINE durations #-} +durations :: -- Monad m => + Double -> t m RelTime64 +durations = undefined + +-- | Generate a singleton event at or after the specified absolute time. Note +-- that this is different from a threadDelay, a threadDelay starts from the +-- time when the action is evaluated, whereas if we use AbsTime based timeout +-- it will immediately expire if the action is evaluated too late. +-- +-- /Unimplemented/ +-- +{-# INLINE timeout #-} +timeout :: -- Monad m => + AbsTime -> t m () +timeout = undefined + +------------------------------------------------------------------------------- +-- From Generators +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL fromIndicesM #-} +fromIndicesM :: Monad m => (Int -> m a) -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +fromIndicesM gen = unfold (Unfold.fromIndicesM gen) 0 +#else +fromIndicesM gen = Stream step 0 + where + {-# INLINE_LATE step #-} + step _ i = do + x <- gen i + return $ Yield x (i + 1) +#endif + +{-# INLINE fromIndices #-} +fromIndices :: Monad m => (Int -> a) -> Stream m a +fromIndices gen = fromIndicesM (return . gen) + +-- Adapted from the vector package +{-# INLINE_NORMAL generateM #-} +generateM :: Monad m => Int -> (Int -> m a) -> Stream m a +generateM n gen = n `seq` Stream step 0 + where + {-# INLINE_LATE step #-} + step _ i | i < n = do + x <- gen i + return $ Yield x (i + 1) + | otherwise = return Stop + +{-# INLINE generate #-} +generate :: Monad m => Int -> (Int -> a) -> Stream m a +generate n gen = generateM n (return . gen) + +------------------------------------------------------------------------------- +-- Iteration +------------------------------------------------------------------------------- + +-- | Generate an infinite stream with the first element generated by the action +-- @m@ and each successive element derived by applying the monadic function @f@ +-- on the previous element. +-- +-- >>> :{ +-- Stream.iterateM (\x -> print x >> return (x + 1)) (return 0) +-- & Stream.take 3 +-- & Stream.toList +-- :} +-- 0 +-- 1 +-- [0,1,2] +-- +{-# INLINE_NORMAL iterateM #-} +iterateM :: Monad m => (a -> m a) -> m a -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +iterateM step = unfold (Unfold.iterateM step) +#else +iterateM step = Stream (\_ st -> st >>= \(!x) -> return $ Yield x (step x)) +#endif + +-- | Generate an infinite stream with @x@ as the first element and each +-- successive element derived by applying the function @f@ on the previous +-- element. +-- +-- >>> Stream.toList $ Stream.take 5 $ Stream.iterate (+1) 1 +-- [1,2,3,4,5] +-- +{-# INLINE_NORMAL iterate #-} +iterate :: Monad m => (a -> a) -> a -> Stream m a +iterate step st = iterateM (return . step) (return st) + +------------------------------------------------------------------------------- +-- From containers +------------------------------------------------------------------------------- + +-- | Convert a list of monadic actions to a 'Stream' +{-# INLINE_LATE fromListM #-} +fromListM :: Monad m => [m a] -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +fromListM = unfold Unfold.fromListM +#else +fromListM = Stream step + where + {-# INLINE_LATE step #-} + step _ (m:ms) = m >>= \x -> return $ Yield x ms + step _ [] = return Stop +#endif + +-- | +-- >>> fromFoldable = Prelude.foldr Stream.cons Stream.nil +-- +-- Construct a stream from a 'Foldable' containing pure values: +-- +-- /WARNING: O(n^2), suitable only for a small number of +-- elements in the stream/ +-- +{-# INLINE fromFoldable #-} +fromFoldable :: (Monad m, Foldable f) => f a -> Stream m a +fromFoldable = Prelude.foldr cons nil + +-- | +-- >>> fromFoldableM = Prelude.foldr Stream.consM Stream.nil +-- +-- Construct a stream from a 'Foldable' containing pure values: +-- +-- /WARNING: O(n^2), suitable only for a small number of +-- elements in the stream/ +-- +{-# INLINE fromFoldableM #-} +fromFoldableM :: (Monad m, Foldable f) => f (m a) -> Stream m a +fromFoldableM = Prelude.foldr consM nil + +------------------------------------------------------------------------------- +-- From pointers +------------------------------------------------------------------------------- + +-- | Keep reading 'Storable' elements from an immutable 'Ptr' onwards. +-- +-- /Unsafe:/ The caller is responsible for safe addressing. +-- +-- /Pre-release/ +{-# INLINE fromPtr #-} +fromPtr :: forall m a. (Monad m, Storable a) => Ptr a -> Stream m a +fromPtr = Stream step + + where + + {-# INLINE_LATE step #-} + step _ p = do + let !x = unsafeInlineIO $ peek p + return $ Yield x (PTR_NEXT(p, a)) + +-- | Take @n@ 'Storable' elements starting from an immutable 'Ptr' onwards. +-- +-- >>> fromPtrN n = Stream.take n . Stream.fromPtr +-- +-- /Unsafe:/ The caller is responsible for safe addressing. +-- +-- /Pre-release/ +{-# INLINE fromPtrN #-} +fromPtrN :: (Monad m, Storable a) => Int -> Ptr a -> Stream m a +fromPtrN n = take n . fromPtr + +-- | Read bytes from an immutable 'Addr#' until a 0 byte is encountered, the 0 +-- byte is not included in the stream. +-- +-- >>> :set -XMagicHash +-- >>> fromCString# addr = Stream.takeWhile (/= 0) $ Stream.fromPtr $ (Ptr addr :: Ptr Word8) +-- +-- /Unsafe:/ The caller is responsible for safe addressing. +-- +-- Note that this is completely safe when reading from Haskell string +-- literals because they are guaranteed to be NULL terminated: +-- +-- >>> Stream.toList $ Stream.fromCString# "\1\2\3\0"# +-- [1,2,3] +-- +{-# INLINE fromCString# #-} +fromCString# :: Monad m => Addr# -> Stream m Word8 +fromCString# addr = takeWhile (/= 0) $ fromPtr $ Ptr addr + +{-# DEPRECATED fromByteStr# "Please use fromCString# instead" #-} +{-# INLINE fromByteStr# #-} +fromByteStr# :: Monad m => Addr# -> Stream m Word8 +fromByteStr# = fromCString# + +-- | Read Word16 from an immutable 'Addr#' until a 0 Word16 is encountered, the +-- 0 Word16 is not included in the stream. +-- +-- >>> :set -XMagicHash +-- >>> fromW16CString# addr = Stream.takeWhile (/= 0) $ Stream.fromPtr $ (Ptr addr :: Ptr Word16) +-- +-- /Unsafe:/ The caller is responsible for safe addressing. +-- +{-# INLINE fromW16CString# #-} +fromW16CString# :: Monad m => Addr# -> Stream m Word16 +fromW16CString# addr = takeWhile (/= 0) $ fromPtr $ Ptr addr diff --git a/src/Streamly/Internal/Data/Stream/Lift.hs b/src/Streamly/Internal/Data/Stream/Lift.hs --- a/src/Streamly/Internal/Data/Stream/Lift.hs +++ b/src/Streamly/Internal/Data/Stream/Lift.hs @@ -1,16 +1,19 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Internal.Data.Stream.Lift --- Copyright : (c) 2019 Composewell Technologies +-- Copyright : (c) 2018 Composewell Technologies -- License : BSD-3-Clause -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC +-- +-- Transform the underlying monad of a stream. module Streamly.Internal.Data.Stream.Lift ( -- * Generalize Inner Monad morphInner - , generalizeInner + , generalizeInner -- XXX rename to morphPure -- * Transform Inner Monad , liftInnerWith @@ -19,22 +22,19 @@ ) where -import Data.Functor.Identity (Identity (..)) -import Streamly.Internal.Data.Stream.Type - (Stream, fromStreamD, toStreamD, fromStreamK, toStreamK) +#include "inline.hs" -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Stream.StreamK as K +import Data.Functor.Identity (Identity(..)) +import Streamly.Internal.Data.SVar.Type (adaptState) --- $setup --- >>> :m --- >>> import Data.Functor.Identity (runIdentity) --- >>> import Streamly.Internal.Data.Stream as Stream +import Streamly.Internal.Data.Stream.Type ------------------------------------------------------------------------------- --- Generalize the underlying monad ------------------------------------------------------------------------------- +#include "DocTestDataStream.hs" +------------------------------------------------------------------------------- +-- Generalize Inner Monad +------------------------------------------------------------------------------- + -- | Transform the inner monad of a stream using a natural transformation. -- -- Example, generalize the inner monad from Identity to any other: @@ -43,11 +43,17 @@ -- -- Also known as hoist. -- --- /CPS/ -{-# INLINE morphInner #-} -morphInner :: (Monad m, Monad n) - => (forall x. m x -> n x) -> Stream m a -> Stream n a -morphInner f xs = fromStreamK $ K.hoist f (toStreamK xs) +{-# INLINE_NORMAL morphInner #-} +morphInner :: Monad n => (forall x. m x -> n x) -> Stream m a -> Stream n a +morphInner f (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- f $ step (adaptState gst) st + return $ case r of + Yield x s -> Yield x s + Skip s -> Skip s + Stop -> Stop -- | Generalize the inner monad of the stream from 'Identity' to any monad. -- @@ -55,41 +61,69 @@ -- -- >>> generalizeInner = Stream.morphInner (return . runIdentity) -- --- /CPS/ --- {-# INLINE generalizeInner #-} generalizeInner :: Monad m => Stream Identity a -> Stream m a generalizeInner = morphInner (return . runIdentity) - -- fromStreamK $ K.hoist (return . runIdentity) (toStreamK xs) ------------------------------------------------------------------------------- --- Add and remove a monad transformer ------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +-- Transform Inner Monad +------------------------------------------------------------------------------- -- | Lift the inner monad @m@ of a stream @Stream m a@ to @t m@ using the -- supplied lift function. -- -{-# INLINE liftInnerWith #-} -liftInnerWith :: (Monad m, Monad (t m)) - => (forall b. m b -> t m b) -> Stream m a -> Stream (t m) a -liftInnerWith lift xs = fromStreamD $ D.liftInnerWith lift (toStreamD xs) +{-# INLINE_NORMAL liftInnerWith #-} +liftInnerWith :: (Monad (t m)) => + (forall b. m b -> t m b) -> Stream m a -> Stream (t m) a +liftInnerWith lift (Stream step state) = Stream step1 state + where + + {-# INLINE_LATE step1 #-} + step1 gst st = do + r <- lift $ step (adaptState gst) st + return $ case r of + Yield x s -> Yield x s + Skip s -> Skip s + Stop -> Stop + -- | Evaluate the inner monad of a stream using the supplied runner function. -- -{-# INLINE runInnerWith #-} -runInnerWith :: (Monad m, Applicative (t m)) => +{-# INLINE_NORMAL runInnerWith #-} +runInnerWith :: Monad m => (forall b. t m b -> m b) -> Stream (t m) a -> Stream m a -runInnerWith run xs = fromStreamD $ D.runInnerWith run (toStreamD xs) +runInnerWith run (Stream step state) = Stream step1 state + where + + {-# INLINE_LATE step1 #-} + step1 gst st = do + r <- run $ step (adaptState gst) st + return $ case r of + Yield x s -> Yield x s + Skip s -> Skip s + Stop -> Stop + -- | Evaluate the inner monad of a stream using the supplied stateful runner -- function and the initial state. The state returned by an invocation of the -- runner is supplied as input state to the next invocation. -- -{-# INLINE runInnerWithState #-} -runInnerWithState :: (Monad m, Applicative (t m)) => - (forall b. s -> t m b -> m (b, s)) +{-# INLINE_NORMAL runInnerWithState #-} +runInnerWithState :: Monad m => + (forall b. s -> t m b -> m (b, s)) -> m s -> Stream (t m) a -> Stream m (s, a) -runInnerWithState run initial xs = - fromStreamD $ D.runInnerWithState run initial (toStreamD xs) +runInnerWithState run initial (Stream step state) = + Stream step1 (state, initial) + + where + + {-# INLINE_LATE step1 #-} + step1 gst (st, action) = do + sv <- action + (r, !sv1) <- run sv (step (adaptState gst) st) + return $ case r of + Yield x s -> Yield (sv1, x) (s, return sv1) + Skip s -> Skip (s, return sv1) + Stop -> Stop diff --git a/src/Streamly/Internal/Data/Stream/Nesting.hs b/src/Streamly/Internal/Data/Stream/Nesting.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Nesting.hs @@ -0,0 +1,3981 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Stream.Nesting +-- Copyright : (c) 2018 Composewell Technologies +-- (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- This module contains transformations involving multiple streams, unfolds or +-- folds. There are two types of transformations generational or eliminational. +-- Generational transformations are like the "Generate" module but they +-- generate a stream by combining streams instead of elements. Eliminational +-- transformations are like the "Eliminate" module but they transform a stream +-- by eliminating parts of the stream instead of eliminating the whole stream. +-- +-- These combinators involve transformation, generation, elimination so can be +-- classified under any of those. + +-- The zipWithM combinator in this module has been adapted from the vector +-- package (c) Roman Leshchinskiy. +-- +-- Flipped versions can be named as: +-- mapFor/forEach, concatFor, unfoldStepFor (only step function) +-- foreach would be better for streams than mapFor as map could be used for any +-- type not just containers with multiple elements. +-- +-- Flipped versions for folding streams: +-- groupsFor :: stream -> fold -> stream (flipped groupsWhile) +-- +-- Flipped versions for folds: +-- foldMany :: outer fold -> inner fold -> fold (original version) +-- groupFoldFor :: inner fold -> outer fold -> fold (flipped version) +-- groupStepFor :: inner fold -> outer fold step -> fold (flipped version) +-- This can be convenient for defining the outer fold step using a lambda. +-- +module Streamly.Internal.Data.Stream.Nesting + ( + -- * Generate + -- | Combining streams to generate streams. + + -- ** Combine Two Streams + -- | Functions ending in the shape: + -- + -- @Stream m a -> Stream m a -> Stream m a@. + + -- *** Interleaving + -- | Interleave elements from two streams alternately. A special case of + -- unfoldEachInterleave. Interleave is equivalent to mergeBy with a round + -- robin merge function. + InterleaveState(..) + , interleave + , interleaveEndBy' + , interleaveSepBy' + , interleaveBeginBy + , interleaveEndBy + , interleaveSepBy + + -- *** Co-operative Scheduling + -- | Execute streams alternately irrespective of whether they generate + -- elements or not. Note that scheduling is affected by the Skip + -- constructor; implementations with more skips receive proportionally less + -- scheduling time. A more programmer controlled approach would be to emit + -- a Maybe in a stream and use the output driven scheduling combinators + -- instead of Skip driven, even if a stream emits Nothing, the output will + -- force scheduling of another stream. + -- + , roundRobin -- interleaveFair?/ParallelFair + + -- *** Merging + -- | Interleave elements from two streams based on a condition. + , mergeBy + , mergeByM + , mergeMinBy + , mergeFstBy + + -- ** Combine N Streams + -- | Functions generally ending in these shapes: + -- + -- @ + -- concat: f (Stream m a) -> Stream m a + -- concatMap: (a -> Stream m b) -> Stream m a -> Stream m b + -- unfoldEach: Unfold m a b -> Stream m a -> Stream m b + -- @ + + -- *** unfoldEach + -- | Generate streams by using an unfold on each element of an input + -- stream, append the resulting streams and flatten. A special case of + -- intercalate. + , unfoldEachFoldBy + , ConcatUnfoldInterleaveState (..) + , bfsUnfoldEach + , altBfsUnfoldEach + , fairUnfoldEach + + -- *** unfoldEach joined by elements + -- | Like unfoldEach but intersperses an element between the streams after + -- unfolding. A special case of intercalate. + , unfoldEachSepBy + , unfoldEachSepByM + , unfoldEachEndBy + , unfoldEachEndByM + + -- *** unfoldEach joined by sequences + -- | Like unfoldEach but intersperses a sequence between the unfolded + -- streams before unfolding. A special case of intercalate. + , unfoldEachSepBySeq + , unfoldEachEndBySeq + + -- *** unfoldEach joined by streams + -- | Like unfoldEach but intersperses streams between the unfolded streams. + , intercalateSepBy + , intercalateEndBy + + -- *** concatMap + , fairConcatMapM + , fairConcatMap + , fairConcatForM + , fairConcatFor + + -- *** unfoldSched + -- Note appending does not make sense for sched, only bfs or diagonal. + + -- | Like unfoldEach but schedules the generated streams based on time + -- slice instead of based on the outputs. + , unfoldSched + -- , altUnfoldSched -- alternating directions + , fairUnfoldSched + + -- *** schedMap + , schedMapM + , schedMap + , fairSchedMapM + , fairSchedMap + + -- *** schedFor + , schedForM + , schedFor + , fairSchedForM + , fairSchedFor + + -- * Eliminate + -- | Folding and Parsing chunks of streams to eliminate nested streams. + -- Functions generally ending in these shapes: + -- + -- @ + -- f (Fold m a b) -> t m a -> t m b + -- f (Parser a m b) -> t m a -> t m b + -- @ + + -- ** Folding + -- | Apply folds on a stream. + , foldSequence + , foldIterateM + + -- ** Parsing + -- | Parsing is opposite to flattening. 'parseMany' is dual to concatMap or + -- unfoldEach concatMap generates a stream from single values in a + -- stream and flattens, parseMany does the opposite of flattening by + -- splitting the stream and then folds each such split to single value in + -- the output stream. + , parseMany + , parseManyPos + , parseSequence + , parseManyTill + , parseIterate + , parseIteratePos + + -- ** Grouping + -- | Group segments of a stream and fold. Special case of parsing. + , groupsWhile + , groupsRollingBy + + -- ** Splitting + -- | A special case of parsing. + , takeEndBySeq + , takeEndBySeq_ + , wordsBy + , splitSepBySeq_ + , splitEndBySeq + , splitEndBySeq_ + , splitOnSuffixSeq -- internal + + , splitBeginBy_ + , splitEndBySeqOneOf + , splitSepBySeqOneOf + + -- * Transform (Nested Containers) + -- | Opposite to compact in ArrayStream + , splitInnerBy -- XXX innerSplitOn + , splitInnerBySuffix -- XXX innerSplitOnSuffix + + -- * Reduce By Streams + , dropPrefix + , dropInfix + , dropSuffix + + -- * Deprecated + , interpose + , interposeM + , interposeSuffix + , interposeSuffixM + , gintercalate + , gintercalateSuffix + , intercalate + , intercalateSuffix + , unfoldInterleave + , unfoldRoundRobin + , interleaveMin + , interleaveFst + , interleaveFstSuffix + , parseManyD + , parseIterateD + , groupsBy + , splitOnSeq + ) +where + +#include "deprecation.h" +#include "inline.hs" +#include "ArrayMacros.h" + +import Control.Exception (assert) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Bits (shiftR, shiftL, (.|.), (.&.)) +import Data.Proxy (Proxy(..)) +import Data.Word (Word32) +import Fusion.Plugin.Types (Fuse(..)) +import GHC.Types (SPEC(..)) + +import Streamly.Internal.Data.Array.Type (Array(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.MutArray.Type (MutArray(..)) +import Streamly.Internal.Data.Parser (ParseError(..), ParseErrorPos) +import Streamly.Internal.Data.RingArray (RingArray(..)) +import Streamly.Internal.Data.SVar.Type (adaptState) +import Streamly.Internal.Data.Unbox (Unbox(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) + +import qualified Streamly.Internal.Data.Array.Type as A +import qualified Streamly.Internal.Data.MutArray.Type as MutArray +import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Internal.Data.Parser as PR +import qualified Streamly.Internal.Data.Parser as PRD +import qualified Streamly.Internal.Data.ParserDrivers as Drivers +import qualified Streamly.Internal.Data.RingArray as RB +import qualified Streamly.Internal.Data.Stream.Generate as Stream +import qualified Streamly.Internal.Data.Unfold.Type as Unfold + +import Streamly.Internal.Data.Stream.Transform + (intersperse, intersperseEndByM) +import Streamly.Internal.Data.Stream.Type hiding (splitAt) + +import Prelude hiding (concatMap, mapM, zipWith, splitAt) + +#include "DocTestDataStream.hs" + +------------------------------------------------------------------------------ +-- Interleaving +------------------------------------------------------------------------------ + +data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2 + | InterleaveSecondOnly s2 | InterleaveFirstOnly s1 + +-- XXX Ideally we should change the order of the arguments but we have the same +-- convention in append as well, we will have to change that too. Also, the +-- argument order of append makes sense for infix use. + +-- | WARNING! O(n^2) time complexity wrt number of streams. Suitable for +-- statically fusing a small number of streams. Use the O(n) complexity +-- StreamK.'Streamly.Data.StreamK.interleave' otherwise. +-- +-- Interleaves two streams, yielding one element from each stream alternately, +-- starting from the first stream. When one stream is exhausted, all the +-- remaining elements of the other stream are emitted in the output stream. +-- +-- Both the streams are completely exhausted. +-- +-- @ +-- (a b c) (. . .) => a . b . c . +-- (a b c) (. . ) => a . b . c +-- (a b ) (. . .) => a . b . . +-- @ +-- +-- Examples: +-- +-- >>> f x y = Stream.toList $ Stream.interleave (Stream.fromList x) (Stream.fromList y) +-- >>> f "abc" "..." +-- "a.b.c." +-- >>> f "abc" ".." +-- "a.b.c" +-- >>> f "ab" "..." +-- "a.b.." +-- +{-# INLINE_NORMAL interleave #-} +interleave :: Monad m => Stream m a -> Stream m a -> Stream m a +interleave (Stream step1 state1) (Stream step2 state2) = + Stream step (InterleaveFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveSecond s st2) + Skip s -> Skip (InterleaveFirst s st2) + Stop -> Skip (InterleaveSecondOnly st2) + + step gst (InterleaveSecond st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveFirst st1 s) + Skip s -> Skip (InterleaveSecond st1 s) + Stop -> Skip (InterleaveFirstOnly st1) + + step gst (InterleaveFirstOnly st1) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveFirstOnly s) + Skip s -> Skip (InterleaveFirstOnly s) + Stop -> Stop + + step gst (InterleaveSecondOnly st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveSecondOnly s) + Skip s -> Skip (InterleaveSecondOnly s) + Stop -> Stop + +-- XXX Check the performance of the implementation, we can write a custom one. + +{-# ANN module "HLint: ignore Use zip" #-} + +-- | Interleave the two streams such that the elements of the second stream are +-- ended by the elements of the first stream. If one of the streams is +-- exhausted then interleaving stops. +-- +-- @ +-- (. . .) (a b c) => a . b . c . +-- (. . ) (a b c) => a . b . -- c is discarded +-- (. . .) (a b ) => a . b . -- . is discarded +-- @ +-- +-- Examples: +-- +-- >>> f x y = Stream.toList $ Stream.interleaveEndBy' (Stream.fromList x) (Stream.fromList y) +-- >>> f "..." "abc" +-- "a.b.c." +-- >>> f ".." "abc" +-- "a.b." +-- >>> f "..." "ab" +-- "a.b." +-- +-- Definition: +-- +-- >>> interleaveEndBy' s1 s2 = Stream.unfoldEach Unfold.fromTuple $ Stream.zipWith (,) s2 s1 +-- +-- Similarly, we can defined interleaveBeginBy' as: +-- +-- >>> interleaveBeginBy' = flip interleaveEndBy' +-- +{-# INLINE_NORMAL interleaveEndBy' #-} +interleaveEndBy' :: Monad m => Stream m a -> Stream m a -> Stream m a +interleaveEndBy' s1 s2 = unfoldEach Unfold.fromTuple $ zipWith (,) s2 s1 + +-- | Like `interleave` but stops interleaving as soon as any of the two streams +-- stops. The suffix 'Min' in the name determines the stop behavior. +-- +-- This is the same as interleaveEndBy' but it might emit an additional element +-- at the end. +-- +{-# DEPRECATED interleaveMin "Please use flip interleaveEndBy' instead." #-} +{-# INLINE_NORMAL interleaveMin #-} +interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a +interleaveMin (Stream step1 state1) (Stream step2 state2) = + Stream step (InterleaveFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveSecond s st2) + Skip s -> Skip (InterleaveFirst s st2) + Stop -> Stop + + step gst (InterleaveSecond st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveFirst st1 s) + Skip s -> Skip (InterleaveSecond st1 s) + Stop -> Stop + + step _ (InterleaveFirstOnly _) = undefined + step _ (InterleaveSecondOnly _) = undefined + +-- | Interleave the two streams such that the elements of the first stream are +-- infixed between the elements of the second stream. If one of the streams is +-- exhausted then interleaving stops. +-- +-- @ +-- (. . .) (a b c) => a . b . c -- additional . is discarded +-- (. . ) (a b c) => a . b . c +-- (. ) (a b c) => a . b -- c is discarded +-- @ +-- +-- >>> f x y = Stream.toList $ Stream.interleaveSepBy' (Stream.fromList x) (Stream.fromList y) +-- >>> f "..." "abc" +-- "a.b.c" +-- >>> f ".." "abc" +-- "a.b.c" +-- >>> f "." "abc" +-- "a.b" +-- +{-# INLINE_NORMAL interleaveSepBy' #-} +interleaveSepBy' :: Monad m => Stream m a -> Stream m a -> Stream m a +-- XXX Not an efficient implementation, need to write a fused one. +interleaveSepBy' s1 s2 = concatEffect $ do + r <- uncons s2 + case r of + Nothing -> return Stream.nil + Just (h, t) -> + return $ h `Stream.cons` + unfoldEach Unfold.fromTuple (zipWith (,) s1 t) + +-- | Interleave the two streams such that the elements of the second stream are +-- prefixed by the elements of the first stream. Interleaving stops when and +-- only when the second stream is exhausted. Shortfall of the prefix stream is +-- ignored and excess is discarded. +-- +-- @ +-- (. . .) (a b c) => . a . b . c +-- (. . .) (a b ) => . a . b -- additional . is discarded +-- (. . ) (a b c) => . a . b c -- missing . is ignored +-- @ +-- +-- /Unimplemented/ +-- +{-# INLINE_NORMAL interleaveBeginBy #-} +interleaveBeginBy :: -- Monad m => + Stream m a -> Stream m a -> Stream m a +interleaveBeginBy = undefined + +-- | Like 'interleaveEndBy'' but interleaving stops when and only when the +-- second stream is exhausted. Shortfall of the suffix stream is ignored and +-- excess is discarded. +-- +-- @ +-- (. . .) (a b c) => a . b . c . +-- (. . ) (a b c) => a . b . c -- missing . is ignored +-- (. . .) (a b ) => a . b . -- additional . is discarded +-- @ +-- +-- >>> f x y = Stream.toList $ Stream.interleaveEndBy (Stream.fromList x) (Stream.fromList y) +-- >>> f "..." "abc" +-- "a.b.c." +-- >>> f ".." "abc" +-- "a.b.c" +-- >>> f "..." "ab" +-- "a.b." +-- +{-# INLINE_NORMAL interleaveEndBy #-} +interleaveEndBy :: Monad m => Stream m a -> Stream m a -> Stream m a +interleaveEndBy (Stream step2 state2) (Stream step1 state1) = + Stream step (InterleaveFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveSecond s st2) + Skip s -> Skip (InterleaveFirst s st2) + Stop -> Stop + + step gst (InterleaveSecond st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveFirst st1 s) + Skip s -> Skip (InterleaveSecond st1 s) + Stop -> Skip (InterleaveFirstOnly st1) + + step gst (InterleaveFirstOnly st1) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveFirstOnly s) + Skip s -> Skip (InterleaveFirstOnly s) + Stop -> Stop + + step _ (InterleaveSecondOnly _) = undefined + +{-# INLINE interleaveFstSuffix #-} +{-# DEPRECATED interleaveFstSuffix "Please use flip interleaveEndBy instead." #-} +interleaveFstSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a +interleaveFstSuffix = flip interleaveEndBy + +data InterleaveInfixState s1 s2 a + = InterleaveInfixFirst s1 s2 + | InterleaveInfixSecondBuf s1 s2 + | InterleaveInfixSecondYield s1 s2 a + | InterleaveInfixFirstYield s1 s2 a + | InterleaveInfixFirstOnly s1 + +-- | Like 'interleaveSepBy'' but interleaving stops when and only when the +-- second stream is exhausted. Shortfall of the infix stream is ignored and +-- excess is discarded. +-- +-- @ +-- (. . .) (a b c) => a . b . c -- additional . is discarded +-- (. . ) (a b c) => a . b . c +-- (. ) (a b c) => a . b c -- missing . is ignored +-- @ +-- +-- Examples: +-- +-- >>> f x y = Stream.toList $ Stream.interleaveSepBy (Stream.fromList x) (Stream.fromList y) +-- >>> f "..." "abc" +-- "a.b.c" +-- >>> f ".." "abc" +-- "a.b.c" +-- >>> f "." "abc" +-- "a.bc" +-- +{-# INLINE_NORMAL interleaveSepBy #-} +interleaveSepBy :: Monad m => Stream m a -> Stream m a -> Stream m a +interleaveSepBy (Stream step2 state2) (Stream step1 state1) = + Stream step (InterleaveInfixFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveInfixFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveInfixSecondBuf s st2) + Skip s -> Skip (InterleaveInfixFirst s st2) + Stop -> Stop + + step gst (InterleaveInfixSecondBuf st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Skip (InterleaveInfixSecondYield st1 s a) + Skip s -> Skip (InterleaveInfixSecondBuf st1 s) + Stop -> Skip (InterleaveInfixFirstOnly st1) + + step gst (InterleaveInfixSecondYield st1 st2 x) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield x (InterleaveInfixFirstYield s st2 a) + Skip s -> Skip (InterleaveInfixSecondYield s st2 x) + Stop -> Stop + + step _ (InterleaveInfixFirstYield st1 st2 x) = do + return $ Yield x (InterleaveInfixSecondBuf st1 st2) + + step gst (InterleaveInfixFirstOnly st1) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveInfixFirstOnly s) + Skip s -> Skip (InterleaveInfixFirstOnly s) + Stop -> Stop + +{-# DEPRECATED interleaveFst "Please use flip interleaveSepBy instead." #-} +{-# INLINE_NORMAL interleaveFst #-} +interleaveFst :: Monad m => Stream m a -> Stream m a -> Stream m a +interleaveFst = flip interleaveSepBy + +------------------------------------------------------------------------------ +-- Scheduling +------------------------------------------------------------------------------ + +-- | Schedule the execution of two streams in a fair round-robin manner, +-- executing each stream once, alternately. Execution of a stream may not +-- necessarily result in an output, a stream may choose to @Skip@ producing an +-- element until later giving the other stream a chance to run. Therefore, this +-- combinator fairly interleaves the execution of two streams rather than +-- fairly interleaving the output of the two streams. This can be useful in +-- co-operative multitasking without using explicit threads. This can be used +-- as an alternative to `async`. +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +-- /Pre-release/ +{-# INLINE_NORMAL roundRobin #-} +roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a +roundRobin (Stream step1 state1) (Stream step2 state2) = + Stream step (InterleaveFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveSecond s st2) + Skip s -> Skip (InterleaveSecond s st2) + Stop -> Skip (InterleaveSecondOnly st2) + + step gst (InterleaveSecond st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveFirst st1 s) + Skip s -> Skip (InterleaveFirst st1 s) + Stop -> Skip (InterleaveFirstOnly st1) + + step gst (InterleaveSecondOnly st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveSecondOnly s) + Skip s -> Skip (InterleaveSecondOnly s) + Stop -> Stop + + step gst (InterleaveFirstOnly st1) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveFirstOnly s) + Skip s -> Skip (InterleaveFirstOnly s) + Stop -> Stop + +------------------------------------------------------------------------------ +-- Merging +------------------------------------------------------------------------------ + +-- | Like 'mergeBy' but with a monadic comparison function. +-- +-- Example, to merge two streams randomly: +-- +-- @ +-- > randomly _ _ = randomIO >>= \x -> return $ if x then LT else GT +-- > Stream.toList $ Stream.mergeByM randomly (Stream.fromList [1,1,1,1]) (Stream.fromList [2,2,2,2]) +-- [2,1,2,2,2,1,1,1] +-- @ +-- +-- Example, merge two streams in a proportion of 2:1: +-- +-- >>> :set -fno-warn-unrecognised-warning-flags +-- >>> :set -fno-warn-x-partial +-- >>> :{ +-- do +-- let s1 = Stream.fromList [1,1,1,1,1,1] +-- s2 = Stream.fromList [2,2,2] +-- let proportionately m n = do +-- ref <- newIORef $ cycle $ Prelude.concat [Prelude.replicate m LT, Prelude.replicate n GT] +-- return $ \_ _ -> do +-- r <- readIORef ref +-- writeIORef ref $ Prelude.tail r +-- return $ Prelude.head r +-- f <- proportionately 2 1 +-- xs <- Stream.fold Fold.toList $ Stream.mergeByM f s1 s2 +-- print xs +-- :} +-- [1,1,2,1,1,2,1,1,2] +-- +{-# INLINE_NORMAL mergeByM #-} +mergeByM + :: (Monad m) + => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a +mergeByM cmp (Stream stepa ta) (Stream stepb tb) = + Stream step (Just ta, Just tb, Nothing, Nothing) + where + {-# INLINE_LATE step #-} + + -- one of the values is missing, and the corresponding stream is running + step gst (Just sa, sb, Nothing, b) = do + r <- stepa gst sa + return $ case r of + Yield a sa' -> Skip (Just sa', sb, Just a, b) + Skip sa' -> Skip (Just sa', sb, Nothing, b) + Stop -> Skip (Nothing, sb, Nothing, b) + + step gst (sa, Just sb, a, Nothing) = do + r <- stepb gst sb + return $ case r of + Yield b sb' -> Skip (sa, Just sb', a, Just b) + Skip sb' -> Skip (sa, Just sb', a, Nothing) + Stop -> Skip (sa, Nothing, a, Nothing) + + -- both the values are available + step _ (sa, sb, Just a, Just b) = do + res <- cmp a b + return $ case res of + GT -> Yield b (sa, sb, Just a, Nothing) + _ -> Yield a (sa, sb, Nothing, Just b) + + -- one of the values is missing, corresponding stream is done + step _ (Nothing, sb, Nothing, Just b) = + return $ Yield b (Nothing, sb, Nothing, Nothing) + + step _ (sa, Nothing, Just a, Nothing) = + return $ Yield a (sa, Nothing, Nothing, Nothing) + + step _ (Nothing, Nothing, Nothing, Nothing) = return Stop + +-- | WARNING! O(n^2) time complexity wrt number of streams. Suitable for +-- statically fusing a small number of streams. Use the O(n) complexity +-- StreamK.'Streamly.Data.StreamK.mergeBy' otherwise. +-- +-- Merge two streams using a comparison function. The head elements of both +-- the streams are compared and the smaller of the two elements is emitted, if +-- both elements are equal then the element from the first stream is used +-- first. +-- +-- If the streams are sorted in ascending order, the resulting stream would +-- also remain sorted in ascending order. +-- +-- >>> s1 = Stream.fromList [1,3,5] +-- >>> s2 = Stream.fromList [2,4,6,8] +-- >>> Stream.fold Fold.toList $ Stream.mergeBy compare s1 s2 +-- [1,2,3,4,5,6,8] +-- +{-# INLINE mergeBy #-} +mergeBy + :: (Monad m) + => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a +mergeBy cmp = mergeByM (\a b -> return $ cmp a b) + +-- | Like 'mergeByM' but stops merging as soon as any of the two streams stops. +-- +-- /Unimplemented/ +{-# INLINABLE mergeMinBy #-} +mergeMinBy :: -- Monad m => + (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a +mergeMinBy _f _m1 _m2 = undefined + -- fromStreamD $ D.mergeMinBy f (toStreamD m1) (toStreamD m2) + +-- | Like 'mergeByM' but stops merging as soon as the first stream stops. +-- +-- /Unimplemented/ +{-# INLINABLE mergeFstBy #-} +mergeFstBy :: -- Monad m => + (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a +mergeFstBy _f _m1 _m2 = undefined + -- fromStreamK $ D.mergeFstBy f (toStreamD m1) (toStreamD m2) + +------------------------------------------------------------------------------ +-- Combine N Streams - unfoldEach +------------------------------------------------------------------------------ + +-- XXX If we want to have strictly N elements in each batch then we can supply a +-- Maybe input to the fold. That could be another variant of this combinator. + +-- | Stream must be finite. Unfolds each element of the input stream to +-- generate streams. After generating one element from each stream fold those +-- using the supplied fold and emit the result in the output stream. Continue +-- doing this until the streams are exhausted. +-- +-- /Unimplemented/ +{-# INLINE_NORMAL unfoldEachFoldBy #-} +unfoldEachFoldBy :: -- Monad m => + Fold m b c -> Unfold m a b -> Stream m a -> Stream m c +unfoldEachFoldBy = undefined + +data BfsUnfoldEachState o i = + BfsUnfoldEachOuter o ([i] -> [i]) + | BfsUnfoldEachInner [i] ([i] -> [i]) + +-- XXX use arrays to store state instead of lists? +-- +-- XXX In general we can use different scheduling strategies e.g. how to +-- schedule the outer vs inner loop or assigning weights to different streams +-- or outer and inner loops. + +-- After a yield, switch to the next stream. Do not switch streams on Skip. +-- Yield from outer stream switches to the inner stream. +-- +-- There are two choices here, (1) exhaust the outer stream first and then +-- start yielding from the inner streams, this is much simpler to implement, +-- (2) yield at least one element from an inner stream before going back to +-- outer stream and opening the next stream from it. +-- +-- Ideally, we need some scheduling bias to inner streams vs outer stream. +-- Maybe we can configure the behavior. + +-- | Like 'unfoldEach' but interleaves the resulting streams in a breadth first +-- manner instead of appending them. Unfolds each element in the input stream +-- to a stream and then interleave the resulting streams. +-- +-- >>> lists = Stream.fromList [[1,4,7],[2,5,8],[3,6,9]] +-- >>> Stream.toList $ Stream.bfsUnfoldEach Unfold.fromList lists +-- [1,2,3,4,5,6,7,8,9] +-- +-- CAUTION! Do not use on infinite streams. +-- +{-# INLINE_NORMAL bfsUnfoldEach #-} +bfsUnfoldEach :: Monad m => + Unfold m a b -> Stream m a -> Stream m b +bfsUnfoldEach (Unfold istep inject) (Stream ostep ost) = + Stream step (BfsUnfoldEachOuter ost id) + + where + + {-# INLINE_LATE step #-} + step gst (BfsUnfoldEachOuter o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- inject a + i `seq` return (Skip (BfsUnfoldEachOuter o' (ls . (i :)))) + Skip o' -> return $ Skip (BfsUnfoldEachOuter o' ls) + Stop -> return $ Skip (BfsUnfoldEachInner (ls []) id) + + step _ (BfsUnfoldEachInner [] rs) = + case rs [] of + [] -> return Stop + ls -> return $ Skip (BfsUnfoldEachInner ls id) + + step _ (BfsUnfoldEachInner (st:ls) rs) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (BfsUnfoldEachInner ls (rs . (s :))) + Skip s -> Skip (BfsUnfoldEachInner (s:ls) rs) + Stop -> Skip (BfsUnfoldEachInner ls rs) + +data ConcatUnfoldInterleaveState o i = + ConcatUnfoldInterleaveOuter o [i] + | ConcatUnfoldInterleaveInner o [i] + | ConcatUnfoldInterleaveInnerL [i] [i] + | ConcatUnfoldInterleaveInnerR [i] [i] + +-- | Like 'bfsUnfoldEach' but reverses the traversal direction after reaching +-- the last stream and then after reaching the first stream, thus alternating +-- the directions. This could be a little bit more efficient if the order of +-- traversal is not important. +-- +-- >>> lists = Stream.fromList [[1,4,7],[2,5,8],[3,6,9]] +-- >>> Stream.toList $ Stream.altBfsUnfoldEach Unfold.fromList lists +-- [1,2,3,6,5,4,7,8,9] +-- +-- CAUTION! Do not use on infinite streams. +-- +{-# INLINE_NORMAL altBfsUnfoldEach #-} +altBfsUnfoldEach, unfoldInterleave :: Monad m => + Unfold m a b -> Stream m a -> Stream m b +altBfsUnfoldEach (Unfold istep inject) (Stream ostep ost) = + Stream step (ConcatUnfoldInterleaveOuter ost []) + + where + + {-# INLINE_LATE step #-} + step gst (ConcatUnfoldInterleaveOuter o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- inject a + i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls))) + Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls) + Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls []) + + step _ (ConcatUnfoldInterleaveInner _ []) = undefined + step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls)) + Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls)) + Stop -> Skip (ConcatUnfoldInterleaveOuter o ls) + + step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop + step _ (ConcatUnfoldInterleaveInnerL [] rs) = + return $ Skip (ConcatUnfoldInterleaveInnerR [] rs) + + step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs)) + Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs) + Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs) + + step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop + step _ (ConcatUnfoldInterleaveInnerR ls []) = + return $ Skip (ConcatUnfoldInterleaveInnerL ls []) + + step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs) + Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs)) + Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs) + +RENAME(unfoldInterleave,altBfsUnfoldEach) + +-- XXX In general we can use different scheduling strategies e.g. how to +-- schedule the outer vs inner loop or assigning weights to different streams +-- or outer and inner loops. +-- +-- This could be inefficient if the tasks are too small. +-- +-- Compared to unfoldEachInterleave this one switches streams on Skips. + +-- | Similar to 'bfsUnfoldEach' but scheduling is independent of output. +-- +-- This is an N-ary version of 'roundRobin'. +-- +-- >>> lists = Stream.fromList [[1,4,7],[2,5,8],[3,6,9]] +-- >>> Stream.toList $ Stream.unfoldSched Unfold.fromList lists +-- [1,2,3,4,5,6,7,8,9] +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +-- CAUTION! Do not use on infinite streams. +-- +{-# INLINE_NORMAL unfoldSched #-} +unfoldSched, unfoldRoundRobin :: Monad m => + Unfold m a b -> Stream m a -> Stream m b +unfoldSched (Unfold istep inject) (Stream ostep ost) = + Stream step (BfsUnfoldEachOuter ost id) + + where + + {-# INLINE_LATE step #-} + step gst (BfsUnfoldEachOuter o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- inject a + i `seq` return (Skip (BfsUnfoldEachOuter o' (ls . (i :)))) + Skip o' -> return $ Skip (BfsUnfoldEachOuter o' ls) + Stop -> return $ Skip (BfsUnfoldEachInner (ls []) id) + + step _ (BfsUnfoldEachInner [] rs) = + case rs [] of + [] -> return Stop + ls -> return $ Skip (BfsUnfoldEachInner ls id) + + step _ (BfsUnfoldEachInner (st:ls) rs) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (BfsUnfoldEachInner ls (rs . (s :))) + Skip s -> Skip (BfsUnfoldEachInner ls (rs . (s :))) + Stop -> Skip (BfsUnfoldEachInner ls rs) + +RENAME(unfoldRoundRobin,unfoldSched) + +-- | Round robin co-operative scheduling of multiple streams. +-- +-- Like concatMap but schedules the generated streams in a round robin +-- fashion. Note that it does not strive to interleave the outputs of the +-- streams, just gives the streams a chance to run whether it produces an +-- output or not. Therefore, the outputs may not seem to be fairly interleaved +-- if a stream decides to skip the output. +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +-- CAUTION! Do not use on infinite streams. +-- +{-# INLINE_NORMAL schedMapM #-} +schedMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b +schedMapM f (Stream ostep ost) = + Stream step (BfsUnfoldEachOuter ost id) + + where + + {-# INLINE_LATE step #-} + step gst (BfsUnfoldEachOuter o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- f a + return (Skip (BfsUnfoldEachOuter o' (ls . (i :)))) + Skip o' -> return $ Skip (BfsUnfoldEachOuter o' ls) + Stop -> return $ Skip (BfsUnfoldEachInner (ls []) id) + + step _ (BfsUnfoldEachInner [] rs) = + case rs [] of + [] -> return Stop + ls -> return $ Skip (BfsUnfoldEachInner ls id) + + step gst (BfsUnfoldEachInner (UnStream istep st:ls) rs) = do + r <- istep gst st + return $ case r of + Yield x s -> Yield x (BfsUnfoldEachInner ls (rs . (Stream istep s :))) + Skip s -> Skip (BfsUnfoldEachInner ls (rs . (Stream istep s :))) + Stop -> Skip (BfsUnfoldEachInner ls rs) + +-- | See 'SchedFor' for documentation. +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +-- CAUTION! Do not use on infinite streams. +-- +{-# INLINE schedMap #-} +schedMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b +schedMap f = schedMapM (return . f) + +-- | See 'SchedFor' for documentation. +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +-- CAUTION! Do not use on infinite streams. +-- +{-# INLINE schedForM #-} +schedForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b +schedForM = flip schedMapM + +-- | Similar to 'bfsConcatFor' but scheduling is independent of output. +-- +-- >>> lists = Stream.fromList [[1,4,7],[2,5,8],[3,6,9]] +-- >>> Stream.toList $ Stream.schedFor lists $ \xs -> Stream.fromList xs +-- [1,2,3,4,5,6,7,8,9] +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +-- CAUTION! Do not use on infinite streams. +-- +{-# INLINE schedFor #-} +schedFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b +schedFor = flip schedMap + +-- | Similar to 'fairUnfoldEach' but scheduling is independent of the output. +-- +-- >>> :{ +-- outerLoop = Stream.fromList [1,2,3] +-- innerLoop = Unfold.carry $ Unfold.lmap (const [4,5,6]) Unfold.fromList +-- :} +-- +-- >>> Stream.toList $ Stream.fairUnfoldSched innerLoop outerLoop +-- [(1,4),(1,5),(2,4),(1,6),(2,5),(3,4),(2,6),(3,5),(3,6)] +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +{-# INLINE_NORMAL fairUnfoldSched #-} +fairUnfoldSched :: Monad m => + Unfold m a b -> Stream m a -> Stream m b +fairUnfoldSched (Unfold istep inject) (Stream ostep ost) = + Stream step (FairUnfoldInit ost id) + + where + + {-# INLINE_LATE step #-} + step gst (FairUnfoldInit o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- inject a + i `seq` return (Skip (FairUnfoldNext o' id (ls [i]))) + Skip o' -> return $ Skip (FairUnfoldNext o' id (ls [])) + Stop -> return $ Skip (FairUnfoldDrain id (ls [])) + + step _ (FairUnfoldNext o ys []) = + return $ Skip (FairUnfoldInit o ys) + + step _ (FairUnfoldNext o ys (st:ls)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (FairUnfoldNext o (ys . (s :)) ls) + Skip s -> Skip (FairUnfoldNext o (ys . (s :)) ls) + Stop -> Skip (FairUnfoldNext o ys ls) + + step _ (FairUnfoldDrain ys []) = + case ys [] of + [] -> return Stop + xs -> return $ Skip (FairUnfoldDrain id xs) + + step _ (FairUnfoldDrain ys (st:ls)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (FairUnfoldDrain (ys . (s :)) ls) + Skip s -> Skip (FairUnfoldDrain (ys . (s :)) ls) + Stop -> Skip (FairUnfoldDrain ys ls) + +-- | See 'fairConcatFor' for more details. This is similar except that this +-- uses unfolds, therefore, it is much faster due to fusion. +-- +-- >>> :{ +-- outerLoop = Stream.fromList [1,2,3] +-- innerLoop = Unfold.carry $ Unfold.lmap (const [4,5,6]) Unfold.fromList +-- :} +-- +-- >>> Stream.toList $ Stream.fairUnfoldEach innerLoop outerLoop +-- [(1,4),(1,5),(2,4),(1,6),(2,5),(3,4),(2,6),(3,5),(3,6)] +-- +{-# INLINE_NORMAL fairUnfoldEach #-} +fairUnfoldEach :: Monad m => + Unfold m a b -> Stream m a -> Stream m b +fairUnfoldEach (Unfold istep inject) (Stream ostep ost) = + Stream step (FairUnfoldInit ost id) + + where + + {-# INLINE_LATE step #-} + step gst (FairUnfoldInit o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- inject a + i `seq` return (Skip (FairUnfoldNext o' id (ls [i]))) + Skip o' -> return $ Skip (FairUnfoldInit o' ls) + Stop -> return $ Skip (FairUnfoldDrain id (ls [])) + + step _ (FairUnfoldNext o ys []) = + return $ Skip (FairUnfoldInit o ys) + + step _ (FairUnfoldNext o ys (st:ls)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (FairUnfoldNext o (ys . (s :)) ls) + Skip s -> Skip (FairUnfoldNext o ys (s : ls)) + Stop -> Skip (FairUnfoldNext o ys ls) + + step _ (FairUnfoldDrain ys []) = + case ys [] of + [] -> return Stop + xs -> return $ Skip (FairUnfoldDrain id xs) + + step _ (FairUnfoldDrain ys (st:ls)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (FairUnfoldDrain (ys . (s :)) ls) + Skip s -> Skip (FairUnfoldDrain ys (s : ls)) + Stop -> Skip (FairUnfoldDrain ys ls) + +-- | See 'fairSchedFor' for documentation. +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +{-# INLINE_NORMAL fairSchedMapM #-} +fairSchedMapM :: Monad m => + (a -> m (Stream m b)) -> Stream m a -> Stream m b +fairSchedMapM f (Stream ostep ost) = + Stream step (FairUnfoldInit ost id) + + where + + {-# INLINE_LATE step #-} + step gst (FairUnfoldInit o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- f a + i `seq` return (Skip (FairUnfoldNext o' id (ls [i]))) + Skip o' -> return $ Skip (FairUnfoldNext o' id (ls [])) + Stop -> return $ Skip (FairUnfoldDrain id (ls [])) + + step _ (FairUnfoldNext o ys []) = + return $ Skip (FairUnfoldInit o ys) + + step gst (FairUnfoldNext o ys (UnStream istep st:ls)) = do + r <- istep gst st + return $ case r of + Yield x s -> Yield x (FairUnfoldNext o (ys . (Stream istep s :)) ls) + Skip s -> Skip (FairUnfoldNext o (ys . (Stream istep s :)) ls) + Stop -> Skip (FairUnfoldNext o ys ls) + + step _ (FairUnfoldDrain ys []) = + case ys [] of + [] -> return Stop + xs -> return $ Skip (FairUnfoldDrain id xs) + + step gst (FairUnfoldDrain ys (UnStream istep st:ls)) = do + r <- istep gst st + return $ case r of + Yield x s -> Yield x (FairUnfoldDrain (ys . (Stream istep s :)) ls) + Skip s -> Skip (FairUnfoldDrain (ys . (Stream istep s :)) ls) + Stop -> Skip (FairUnfoldDrain ys ls) + +-- | See 'fairSchedFor' for documentation. +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +{-# INLINE fairSchedMap #-} +fairSchedMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b +fairSchedMap f = fairSchedMapM (return . f) + +-- | See 'fairSchedFor' for documentation. +-- +-- Scheduling is affected by the Skip constructor; implementations with more +-- skips receive proportionally less scheduling time. +-- +{-# INLINE fairSchedForM #-} +fairSchedForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b +fairSchedForM = flip fairSchedMapM + +-- | 'fairSchedFor' is just like 'fairConcatFor', it traverses the depth and +-- breadth of nesting equally. It maintains fairness among different levels of +-- loop iterations. Therefore, the outer and the inner loops in a nested loop +-- get equal priority. It can be used to nest infinite streams without starving +-- outer streams due to inner ones. +-- +-- There is one crucial difference, while 'fairConcatFor' necessarily produces +-- an output from one stream before it schedules the next, 'fairSchedFor' +-- schedules the next stream even if a stream did not produce an output. Thus +-- it interleaves the CPU rather than the outputs of the streams. Thus even if +-- an infinite stream does not produce an output it can not block all other +-- streams. +-- +-- Note that the order of emitting the output from different streams may not be +-- predictable, it depends on the skip points inside the stream. Scheduling is +-- affected by the Skip constructor; implementations with more skips receive +-- proportionally less scheduling time. +-- +-- == Non-Productive Streams +-- +-- Unlike in 'fairConcatFor', if one of the two interleaved streams does not +-- produce an output at all and continues forever then the other stream will +-- still get scheduled. The following program will hang forever for +-- 'fairConcatFor' but will work fine with 'fairSchedFor'. +-- +-- >>> :{ +-- oddsIf x = Stream.fromList (if x then [1,3..] else [2,4..]) +-- filterEven x = if even x then Stream.fromPure x else Stream.nil +-- :} +-- +-- >>> :{ +-- evens = +-- Stream.fairSchedFor (Stream.fromList [True,False]) $ \r -> +-- Stream.fairSchedFor (oddsIf r) filterEven +-- :} +-- +-- >>> Stream.toList $ Stream.take 3 $ evens +-- [2,4,6] +-- +-- When @r@ is True, the nested 'fairSchedFor' is a non-productive infinite +-- loop, but still the outer loop gets a chance to generate the @False@ value, +-- and the @evens@ function can produce output. The same code won't terminate +-- if we use 'fairConcatFor' instead of 'fairSchedFor'. Thus even without +-- explicit concurrency we can schedule multiple streams on the same CPU. +-- +-- == Logic Programming +-- +-- When exploring large streams in logic programming, 'fairSchedFor' can be +-- used as a safe alternative to 'fairConcatFor' as it cannot block due to +-- non-productive infinite streams. +-- +{-# INLINE fairSchedFor #-} +fairSchedFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b +fairSchedFor = flip fairSchedMap + +-- | See 'fairConcatFor' for documentation. +{-# INLINE_NORMAL fairConcatMapM #-} +fairConcatMapM :: Monad m => + (a -> m (Stream m b)) -> Stream m a -> Stream m b +fairConcatMapM f (Stream ostep ost) = + Stream step (FairUnfoldInit ost id) + + where + + {-# INLINE_LATE step #-} + step gst (FairUnfoldInit o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- f a + i `seq` return (Skip (FairUnfoldNext o' id (ls [i]))) + Skip o' -> return $ Skip (FairUnfoldInit o' ls) + Stop -> return $ Skip (FairUnfoldDrain id (ls [])) + + step _ (FairUnfoldNext o ys []) = + return $ Skip (FairUnfoldInit o ys) + + step gst (FairUnfoldNext o ys (UnStream istep st:ls)) = do + r <- istep gst st + return $ case r of + Yield x s -> Yield x (FairUnfoldNext o (ys . (Stream istep s :)) ls) + Skip s -> Skip (FairUnfoldNext o ys (UnStream istep s:ls)) + Stop -> Skip (FairUnfoldNext o ys ls) + + step _ (FairUnfoldDrain ys []) = + case ys [] of + [] -> return Stop + xs -> return $ Skip (FairUnfoldDrain id xs) + + step gst (FairUnfoldDrain ys (UnStream istep st:ls)) = do + r <- istep gst st + return $ case r of + Yield x s -> Yield x (FairUnfoldDrain (ys . (Stream istep s :)) ls) + Skip s -> Skip (FairUnfoldDrain ys (Stream istep s : ls)) + Stop -> Skip (FairUnfoldDrain ys ls) + +-- | See 'fairConcatFor' for documentation. +{-# INLINE fairConcatMap #-} +fairConcatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b +fairConcatMap f = fairConcatMapM (return . f) + +-- | See 'fairConcatFor' for documentation. +{-# INLINE fairConcatForM #-} +fairConcatForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b +fairConcatForM = flip fairConcatMapM + +-- | 'fairConcatFor' is like 'concatFor' but traverses the depth and breadth of +-- nesting equally. Therefore, the outer and the inner loops in a nested loop +-- get equal priority. It can be used to nest infinite streams without starving +-- outer streams due to inner ones. +-- +-- Given a stream of three streams: +-- +-- @ +-- 1. [1,2,3] +-- 2. [4,5,6] +-- 3. [7,8,9] +-- @ +-- +-- Here, outer loop is the stream of streams and the inner loops are the +-- individual streams. The traversal sweeps the diagonals in the above grid to +-- give equal chance to outer and inner loops. The resulting stream is +-- @(1),(2,4),(3,5,7),(6,8),(9)@, diagonals are parenthesized for emphasis. +-- +-- == Looping +-- +-- A single stream case is equivalent to 'concatFor': +-- +-- >>> Stream.toList $ Stream.fairConcatFor (Stream.fromList [1,2]) $ \x -> Stream.fromPure x +-- [1,2] +-- +-- == Fair Nested Looping +-- +-- Multiple streams nest like @for@ loops. The result is a cross product of the +-- streams. However, the ordering of the results of the cross product is such +-- that each stream gets consumed equally. In other words, inner iterations of +-- a nested loop get the same priority as the outer iterations. Inner +-- iterations do not finish completely before the outer iterations start. +-- +-- >>> :{ +-- Stream.toList $ do +-- Stream.fairConcatFor (Stream.fromList [1,2,3]) $ \x -> +-- Stream.fairConcatFor (Stream.fromList [4,5,6]) $ \y -> +-- Stream.fromPure (x, y) +-- :} +-- [(1,4),(1,5),(2,4),(1,6),(2,5),(3,4),(2,6),(3,5),(3,6)] +-- +-- == Nesting Infinite Streams +-- +-- Example with infinite streams. Print all pairs in the cross product with sum +-- less than a specified number. +-- +-- >>> :{ +-- Stream.toList +-- $ Stream.takeWhile (\(x,y) -> x + y < 6) +-- $ Stream.fairConcatFor (Stream.fromList [1..]) $ \x -> +-- Stream.fairConcatFor (Stream.fromList [1..]) $ \y -> +-- Stream.fromPure (x, y) +-- :} +-- [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(1,4),(2,3),(3,2),(4,1)] +-- +-- == How the nesting works? +-- +-- If we look at the cross product of [1,2,3], [4,5,6], the streams being +-- combined using 'fairConcatFor' are the following sequential loop iterations: +-- +-- @ +-- (1,4) (1,5) (1,6) -- first iteration of the outer loop +-- (2,4) (2,5) (2,6) -- second iteration of the outer loop +-- (3,4) (3,5) (3,6) -- third iteration of the outer loop +-- @ +-- +-- The result is a triangular or diagonal traversal of these iterations: +-- +-- @ +-- [(1,4),(1,5),(2,4),(1,6),(2,5),(3,4),(2,6),(3,5),(3,6)] +-- @ +-- +-- == Non-Termination Cases +-- +-- If one of the two interleaved streams does not produce an output at all and +-- continues forever then the other stream will never get scheduled. This is +-- because a stream is unscheduled only after it produces an output. This can +-- lead to non-terminating programs, an example is provided below. +-- +-- >>> :{ +-- oddsIf x = Stream.fromList (if x then [1,3..] else [2,4..]) +-- filterEven x = if even x then Stream.fromPure x else Stream.nil +-- :} +-- +-- >>> :{ +-- evens = +-- Stream.fairConcatFor (Stream.fromList [True,False]) $ \r -> +-- Stream.concatFor (oddsIf r) filterEven +-- :} +-- +-- The @evens@ function does not terminate because, when r is True, the nested +-- 'concatFor' is a non-productive infinite loop, therefore, the outer loop +-- never gets a chance to generate the @False@ value. +-- +-- But the following refactoring of the above code works as expected: +-- +-- >>> :{ +-- mixed = +-- Stream.fairConcatFor (Stream.fromList [True,False]) $ \r -> +-- Stream.concatFor (oddsIf r) Stream.fromPure +-- :} +-- +-- >>> evens = Stream.fairConcatFor mixed filterEven +-- >>> Stream.toList $ Stream.take 3 $ evens +-- [2,4,6] +-- +-- This works because in @mixed@ both the streams being interleaved are +-- productive. +-- +-- Care should be taken how you write your program, keep in mind the scheduling +-- implications. To avoid such scheduling problems in serial interleaving, you +-- can use 'fairSchedFor' or concurrent scheduling i.e. parFairConcatFor. Due +-- to concurrent scheduling the other branch will make progress even if one is +-- an infinite loop producing nothing. +-- +-- == Logic Programming +-- +-- Streamly provides all operations for logic programming. It provides +-- functionality equivalent to 'LogicT' type from the 'logict' package. +-- The @MonadLogic@ operations can be implemented using the available stream +-- operations. For example, 'uncons' is @msplit@, 'interleave' corresponds to +-- the @interleave@ operation of MonadLogic, 'fairConcatFor' is the +-- fair bind (@>>-@) operation. 'fairSchedFor' is an even better alternative +-- for fair bind, it guarantees that non-productive infinite streams cannot +-- block progress. +-- +-- == Related Operations +-- +-- See also "Streamly.Internal.Data.StreamK.fairConcatFor". +-- +{-# INLINE fairConcatFor #-} +fairConcatFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b +fairConcatFor = flip fairConcatMap + +------------------------------------------------------------------------------ +-- Combine N Streams - interpose +------------------------------------------------------------------------------ + +{-# ANN type InterposeSuffixState Fuse #-} +data InterposeSuffixState s1 i1 = + InterposeSuffixFirst s1 + -- | InterposeSuffixFirstYield s1 i1 + | InterposeSuffixFirstInner s1 i1 + | InterposeSuffixSecond s1 + +-- XXX Note that if an unfolded layer turns out to be nil we still emit the +-- separator effect. An alternate behavior could be to emit the separator +-- effect only if at least one element has been yielded by the unfolding. +-- However, that becomes a bit complicated, so we have chosen the former +-- behavior for now. + +-- | Monadic variant of 'unfoldEachEndBy'. +-- +-- Definition: +-- +-- >>> unfoldEachEndByM x = Stream.intercalateEndBy Unfold.identity (Stream.repeatM x) +-- +{-# INLINE_NORMAL unfoldEachEndByM #-} +unfoldEachEndByM, interposeSuffixM :: Monad m => + m c -> Unfold m b c -> Stream m b -> Stream m c +unfoldEachEndByM + action + (Unfold istep1 inject1) (Stream step1 state1) = + Stream step (InterposeSuffixFirst state1) + + where + + {-# INLINE_LATE step #-} + step gst (InterposeSuffixFirst s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (InterposeSuffixFirstInner s i)) + -- i `seq` return (Skip (InterposeSuffixFirstYield s i)) + Skip s -> return $ Skip (InterposeSuffixFirst s) + Stop -> return Stop + + {- + step _ (InterposeSuffixFirstYield s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i') + Skip i' -> Skip (InterposeSuffixFirstYield s1 i') + Stop -> Skip (InterposeSuffixFirst s1) + -} + + step _ (InterposeSuffixFirstInner s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i') + Skip i' -> Skip (InterposeSuffixFirstInner s1 i') + Stop -> Skip (InterposeSuffixSecond s1) + + step _ (InterposeSuffixSecond s1) = do + r <- action + return $ Yield r (InterposeSuffixFirst s1) + +-- | Unfold the elements of a stream, append the given element after each +-- unfolded stream and then concat them into a single stream. +-- +-- Definition: +-- +-- >>> unfoldEachEndBy x = Stream.intercalateEndBy Unfold.identity (Stream.repeat x) +-- +-- Usage: +-- +-- >>> unlines = Stream.unfoldEachEndBy '\n' +-- +-- /Pre-release/ +{-# INLINE unfoldEachEndBy #-} +unfoldEachEndBy, interposeSuffix :: Monad m + => c -> Unfold m b c -> Stream m b -> Stream m c +unfoldEachEndBy x = unfoldEachEndByM (return x) + +RENAME(interposeSuffix,unfoldEachEndBy) +RENAME(interposeSuffixM,unfoldEachEndByM) + +{-# ANN type InterposeState Fuse #-} +data InterposeState s1 i1 a = + InterposeFirst s1 + -- | InterposeFirstYield s1 i1 + | InterposeFirstInner s1 i1 + | InterposeFirstInject s1 + -- | InterposeFirstBuf s1 i1 + | InterposeSecondYield s1 i1 + -- -- | InterposeSecondYield s1 i1 a + -- -- | InterposeFirstResume s1 i1 a + +-- Note that this only interposes the pure values, we may run many effects to +-- generate those values as some effects may not generate anything (Skip). + +-- | Monadic variant of 'unfoldEachSepBy'. +-- +-- Definition: +-- +-- >>> unfoldEachSepByM x = Stream.intercalateSepBy Unfold.identity (Stream.repeatM x) +-- +{-# INLINE_NORMAL unfoldEachSepByM #-} +unfoldEachSepByM, interposeM :: Monad m => + m c -> Unfold m b c -> Stream m b -> Stream m c +unfoldEachSepByM + action + (Unfold istep1 inject1) (Stream step1 state1) = + Stream step (InterposeFirst state1) + + where + + {-# INLINE_LATE step #-} + step gst (InterposeFirst s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (InterposeFirstInner s i)) + -- i `seq` return (Skip (InterposeFirstYield s i)) + Skip s -> return $ Skip (InterposeFirst s) + Stop -> return Stop + + {- + step _ (InterposeFirstYield s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (InterposeFirstInner s1 i') + Skip i' -> Skip (InterposeFirstYield s1 i') + Stop -> Skip (InterposeFirst s1) + -} + + step _ (InterposeFirstInner s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (InterposeFirstInner s1 i') + Skip i' -> Skip (InterposeFirstInner s1 i') + Stop -> Skip (InterposeFirstInject s1) + + step gst (InterposeFirstInject s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + -- i `seq` return (Skip (InterposeFirstBuf s i)) + i `seq` return (Skip (InterposeSecondYield s i)) + Skip s -> return $ Skip (InterposeFirstInject s) + Stop -> return Stop + + {- + step _ (InterposeFirstBuf s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Skip (InterposeSecondYield s1 i' x) + Skip i' -> Skip (InterposeFirstBuf s1 i') + Stop -> Stop + -} + + {- + step _ (InterposeSecondYield s1 i1 v) = do + r <- action + return $ Yield r (InterposeFirstResume s1 i1 v) + -} + step _ (InterposeSecondYield s1 i1) = do + r <- action + return $ Yield r (InterposeFirstInner s1 i1) + + {- + step _ (InterposeFirstResume s1 i1 v) = do + return $ Yield v (InterposeFirstInner s1 i1) + -} + +-- | Unfold the elements of a stream, intersperse the given element between the +-- unfolded streams and then concat them into a single stream. +-- +-- Definition: +-- +-- >>> unfoldEachSepBy x = Stream.unfoldEachSepByM (return x) +-- >>> unfoldEachSepBy x = Stream.intercalateSepBy Unfold.identity (Stream.repeat x) +-- +-- Usage: +-- +-- >>> unwords = Stream.unfoldEachSepBy ' ' +-- +-- /Pre-release/ +{-# INLINE unfoldEachSepBy #-} +unfoldEachSepBy, interpose :: Monad m + => c -> Unfold m b c -> Stream m b -> Stream m c +unfoldEachSepBy x = unfoldEachSepByM (return x) + +RENAME(interposeM,unfoldEachSepByM) +RENAME(interpose,unfoldEachSepBy) + +------------------------------------------------------------------------------ +-- Combine N Streams - intercalate +------------------------------------------------------------------------------ + +data ICUState s1 s2 i1 i2 = + ICUFirst s1 s2 + | ICUSecond s1 s2 + | ICUSecondOnly s2 + | ICUFirstOnly s1 + | ICUFirstInner s1 s2 i1 + | ICUSecondInner s1 s2 i2 + | ICUFirstOnlyInner s1 i1 + | ICUSecondOnlyInner s2 i2 + +-- | See 'intercalateSepBy' for detailed documentation. +-- +-- You can think of this as 'interleaveEndBy' on the stream of streams followed +-- by concat. Same as the following but more efficient: +-- +-- >>> intercalateEndBy u1 s1 u2 s2 = Stream.concat $ Stream.interleaveEndBy (fmap (Stream.unfold u1) s1) (fmap (Stream.unfold u2) s2) +-- +-- /Pre-release/ +{-# INLINE_NORMAL intercalateEndBy #-} +intercalateEndBy :: Monad m => + Unfold m a c -> Stream m a + -> Unfold m b c -> Stream m b + -> Stream m c +intercalateEndBy + (Unfold istep2 inject2) (Stream step2 state2) + (Unfold istep1 inject1) (Stream step1 state1) = + Stream step (ICUFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (ICUFirst s1 s2) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICUFirstInner s s2 i)) + Skip s -> return $ Skip (ICUFirst s s2) + Stop -> return Stop + + step gst (ICUFirstOnly s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICUFirstOnlyInner s i)) + Skip s -> return $ Skip (ICUFirstOnly s) + Stop -> return Stop + + step _ (ICUFirstInner s1 s2 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICUFirstInner s1 s2 i') + Skip i' -> Skip (ICUFirstInner s1 s2 i') + Stop -> Skip (ICUSecond s1 s2) + + step _ (ICUFirstOnlyInner s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICUFirstOnlyInner s1 i') + Skip i' -> Skip (ICUFirstOnlyInner s1 i') + Stop -> Skip (ICUFirstOnly s1) + + step gst (ICUSecond s1 s2) = do + r <- step2 (adaptState gst) s2 + case r of + Yield a s -> do + i <- inject2 a + i `seq` return (Skip (ICUSecondInner s1 s i)) + Skip s -> return $ Skip (ICUSecond s1 s) + Stop -> return $ Skip (ICUFirstOnly s1) + + step _ (ICUSecondInner s1 s2 i2) = do + r <- istep2 i2 + return $ case r of + Yield x i' -> Yield x (ICUSecondInner s1 s2 i') + Skip i' -> Skip (ICUSecondInner s1 s2 i') + Stop -> Skip (ICUFirst s1 s2) + + step _ (ICUSecondOnly _s2) = undefined + step _ (ICUSecondOnlyInner _s2 _i2) = undefined + +-- | +-- +-- >>> gintercalateSuffix u1 s1 u2 s2 = Stream.intercalateEndBy u2 s2 u1 s1 +-- +{-# DEPRECATED gintercalateSuffix "Please use intercalateEndBy instead. Note the change in argument order." #-} +{-# INLINE gintercalateSuffix #-} +gintercalateSuffix + :: Monad m + => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c +gintercalateSuffix u1 s1 u2 s2 = intercalateEndBy u2 s2 u1 s1 + +data ICALState s1 s2 i1 i2 a = + ICALFirst s1 s2 + -- | ICALFirstYield s1 s2 i1 + | ICALFirstInner s1 s2 i1 + | ICALFirstOnly s1 + | ICALFirstOnlyInner s1 i1 + | ICALSecondInject s1 s2 + | ICALFirstInject s1 s2 i2 + -- | ICALFirstBuf s1 s2 i1 i2 + | ICALSecondInner s1 s2 i1 i2 + -- -- | ICALSecondInner s1 s2 i1 i2 a + -- -- | ICALFirstResume s1 s2 i1 i2 a + +-- | The first stream @Stream m b@ is turned into a stream of streams by +-- unfolding each element using the first unfold, similarly @Stream m a@ is +-- also turned into a stream of streams. The second stream of streams is +-- interspersed with the streams from the first stream in an infix manner and +-- then the resulting stream is flattened. +-- +-- You can think of this as 'interleaveSepBy' on the stream of streams followed +-- by concat. Same as the following but more efficient: +-- +-- >>> intercalateSepBy u1 s1 u2 s2 = Stream.concat $ Stream.interleaveSepBy (fmap (Stream.unfold u1) s1) (fmap (Stream.unfold u2) s2) +-- +-- If the separator stream consists of nil streams then it becomes equivalent +-- to 'unfoldEach': +-- +-- >>> unfoldEach = Stream.intercalateSepBy (Unfold.nilM (const (return ()))) (Stream.repeat ()) +-- +-- /Pre-release/ +{-# INLINE_NORMAL intercalateSepBy #-} +intercalateSepBy + :: Monad m + => Unfold m b c -> Stream m b + -> Unfold m a c -> Stream m a + -> Stream m c +{- +intercalateSepBy u1 s1 u2 s2 = + Stream.concat $ interleaveSepBy (fmap (unfold u1) s1) (fmap (unfold u2) s2) +-} +intercalateSepBy + (Unfold istep2 inject2) (Stream step2 state2) + (Unfold istep1 inject1) (Stream step1 state1) = + Stream step (ICALFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (ICALFirst s1 s2) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICALFirstInner s s2 i)) + -- i `seq` return (Skip (ICALFirstYield s s2 i)) + Skip s -> return $ Skip (ICALFirst s s2) + Stop -> return Stop + + {- + step _ (ICALFirstYield s1 s2 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICALFirstInner s1 s2 i') + Skip i' -> Skip (ICALFirstYield s1 s2 i') + Stop -> Skip (ICALFirst s1 s2) + -} + + step _ (ICALFirstInner s1 s2 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICALFirstInner s1 s2 i') + Skip i' -> Skip (ICALFirstInner s1 s2 i') + Stop -> Skip (ICALSecondInject s1 s2) + + step gst (ICALFirstOnly s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICALFirstOnlyInner s i)) + Skip s -> return $ Skip (ICALFirstOnly s) + Stop -> return Stop + + step _ (ICALFirstOnlyInner s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICALFirstOnlyInner s1 i') + Skip i' -> Skip (ICALFirstOnlyInner s1 i') + Stop -> Skip (ICALFirstOnly s1) + + -- We inject the second stream even before checking if the first stream + -- would yield any more elements. There is no clear choice whether we + -- should do this before or after that. Doing it after may make the state + -- machine a bit simpler though. + step gst (ICALSecondInject s1 s2) = do + r <- step2 (adaptState gst) s2 + case r of + Yield a s -> do + i <- inject2 a + i `seq` return (Skip (ICALFirstInject s1 s i)) + Skip s -> return $ Skip (ICALSecondInject s1 s) + Stop -> return $ Skip (ICALFirstOnly s1) + + step gst (ICALFirstInject s1 s2 i2) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICALSecondInner s s2 i i2)) + -- i `seq` return (Skip (ICALFirstBuf s s2 i i2)) + Skip s -> return $ Skip (ICALFirstInject s s2 i2) + Stop -> return Stop + + {- + step _ (ICALFirstBuf s1 s2 i1 i2) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Skip (ICALSecondInner s1 s2 i' i2 x) + Skip i' -> Skip (ICALFirstBuf s1 s2 i' i2) + Stop -> Stop + + step _ (ICALSecondInner s1 s2 i1 i2 v) = do + r <- istep2 i2 + return $ case r of + Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i' v) + Skip i' -> Skip (ICALSecondInner s1 s2 i1 i' v) + Stop -> Skip (ICALFirstResume s1 s2 i1 i2 v) + -} + + step _ (ICALSecondInner s1 s2 i1 i2) = do + r <- istep2 i2 + return $ case r of + Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i') + Skip i' -> Skip (ICALSecondInner s1 s2 i1 i') + Stop -> Skip (ICALFirstInner s1 s2 i1) + -- Stop -> Skip (ICALFirstResume s1 s2 i1 i2) + + {- + step _ (ICALFirstResume s1 s2 i1 i2 x) = do + return $ Yield x (ICALFirstInner s1 s2 i1 i2) + -} + +-- | +-- +-- >>> gintercalate u1 s1 u2 s2 = Stream.intercalateSepBy u2 s2 u1 s1 +-- +{-# DEPRECATED gintercalate "Please use intercalateSepBy instead." #-} +{-# INLINE gintercalate #-} +gintercalate :: Monad m => + Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c +gintercalate u1 s1 u2 s2 = intercalateSepBy u2 s2 u1 s1 + +-- | Unfold each element of the stream, end each unfold by a sequence generated +-- by unfolding the supplied value. +-- +-- Definition: +-- +-- >>> unfoldEachEndBySeq a u = Stream.unfoldEach u . Stream.intersperseEndByM a +-- >>> unfoldEachEndBySeq a u = Stream.intercalateEndBy u (Stream.repeat a) u +-- +-- Idioms: +-- +-- >>> intersperseEndByM x = Stream.unfoldEachEndBySeq x Unfold.identity +-- >>> unlines = Stream.unfoldEachEndBySeq "\n" Unfold.fromList +-- +-- Usage: +-- +-- >>> input = Stream.fromList ["abc", "def", "ghi"] +-- >>> Stream.toList $ Stream.unfoldEachEndBySeq "\n" Unfold.fromList input +-- "abc\ndef\nghi\n" +-- +{-# INLINE unfoldEachEndBySeq #-} +unfoldEachEndBySeq :: Monad m + => b -> Unfold m b c -> Stream m b -> Stream m c +unfoldEachEndBySeq seed unf = unfoldEach unf . intersperseEndByM (return seed) + +{-# DEPRECATED intercalateSuffix "Please use unfoldEachEndBySeq instead." #-} +{-# INLINE intercalateSuffix #-} +intercalateSuffix :: Monad m + => Unfold m b c -> b -> Stream m b -> Stream m c +intercalateSuffix u x = unfoldEachEndBySeq x u + +-- | Unfold each element of the stream, separate the successive unfolds by a +-- sequence generated by unfolding the supplied value. +-- +-- Definition: +-- +-- >>> unfoldEachSepBySeq a u = Stream.unfoldEach u . Stream.intersperse a +-- >>> unfoldEachSepBySeq a u = Stream.intercalateSepBy u (Stream.repeat a) u +-- +-- Idioms: +-- +-- >>> intersperse x = Stream.unfoldEachSepBySeq x Unfold.identity +-- >>> unwords = Stream.unfoldEachSepBySeq " " Unfold.fromList +-- +-- Usage: +-- +-- >>> input = Stream.fromList ["abc", "def", "ghi"] +-- >>> Stream.toList $ Stream.unfoldEachSepBySeq " " Unfold.fromList input +-- "abc def ghi" +-- +{-# INLINE unfoldEachSepBySeq #-} +unfoldEachSepBySeq :: Monad m + => b -> Unfold m b c -> Stream m b -> Stream m c +unfoldEachSepBySeq seed unf str = unfoldEach unf $ intersperse seed str + +{-# DEPRECATED intercalate "Please use unfoldEachSepBySeq instead." #-} +{-# INLINE intercalate #-} +intercalate :: Monad m + => Unfold m b c -> b -> Stream m b -> Stream m c +intercalate u x = unfoldEachSepBySeq x u + +------------------------------------------------------------------------------ +-- Folding +------------------------------------------------------------------------------ + +-- | Apply a stream of folds to an input stream and emit the results in the +-- output stream. +-- +-- /Unimplemented/ +-- +{-# INLINE foldSequence #-} +foldSequence + :: -- Monad m => + Stream m (Fold m a b) + -> Stream m a + -> Stream m b +foldSequence _f _m = undefined + +{-# ANN type FIterState Fuse #-} +data FIterState s f m a b + = FIterInit s f + | forall fs. FIterStream s (fs -> a -> m (FL.Step fs b)) fs (fs -> m b) + (fs -> m b) + | FIterYield b (FIterState s f m a b) + | FIterStop + +-- | Iterate a fold generator on a stream. The initial value @b@ is used to +-- generate the first fold, the fold is applied on the stream and the result of +-- the fold is used to generate the next fold and so on. +-- +-- Usage: +-- +-- >>> import Data.Monoid (Sum(..)) +-- >>> f x = return (Fold.take 2 (Fold.sconcat x)) +-- >>> s = fmap Sum $ Stream.fromList [1..10] +-- >>> Stream.fold Fold.toList $ fmap getSum $ Stream.foldIterateM f (pure 0) s +-- [3,10,21,36,55,55] +-- +-- This is the streaming equivalent of monad like sequenced application of +-- folds where next fold is dependent on the previous fold. +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL foldIterateM #-} +foldIterateM :: + Monad m => (b -> m (FL.Fold m a b)) -> m b -> Stream m a -> Stream m b +foldIterateM func seed0 (Stream step state) = + Stream stepOuter (FIterInit state seed0) + + where + + {-# INLINE iterStep #-} + iterStep from st fstep extract final = do + res <- from + return + $ Skip + $ case res of + FL.Partial fs -> FIterStream st fstep fs extract final + FL.Done fb -> FIterYield fb $ FIterInit st (return fb) + + {-# INLINE_LATE stepOuter #-} + stepOuter _ (FIterInit st seed) = do + (FL.Fold fstep initial extract final) <- seed >>= func + iterStep initial st fstep extract final + stepOuter gst (FIterStream st fstep fs extract final) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + iterStep (fstep fs x) s fstep extract final + Skip s -> return $ Skip $ FIterStream s fstep fs extract final + Stop -> do + b <- final fs + return $ Skip $ FIterYield b FIterStop + stepOuter _ (FIterYield a next) = return $ Yield a next + stepOuter _ FIterStop = return Stop + +------------------------------------------------------------------------------ +-- Parsing +------------------------------------------------------------------------------ + +-- | Apply a 'Parser' repeatedly on a stream and emit the parsed values in the +-- output stream. +-- +-- Usage: +-- +-- >>> s = Stream.fromList [1..10] +-- >>> parser = Parser.takeBetween 0 2 Fold.sum +-- >>> Stream.toList $ Stream.parseMany parser s +-- [Right 3,Right 7,Right 11,Right 15,Right 19] +-- +-- This is the streaming equivalent of the 'Streamly.Data.Parser.many' parse +-- combinator. +-- +-- Known Issues: When the parser fails there is no way to get the remaining +-- stream. +-- +{-# INLINE parseMany #-} +parseMany + :: Monad m + => PRD.Parser a m b + -> Stream m a + -> Stream m (Either ParseError b) +parseMany = Drivers.parseMany + +-- | Like 'parseMany' but includes stream position information in the error +-- messages. +-- +{-# INLINE parseManyPos #-} +parseManyPos + :: Monad m + => PRD.Parser a m b + -> Stream m a + -> Stream m (Either ParseErrorPos b) +parseManyPos = Drivers.parseManyPos + +{-# DEPRECATED parseManyD "Please use parseMany instead." #-} +{-# INLINE parseManyD #-} +parseManyD + :: Monad m + => PR.Parser a m b + -> Stream m a + -> Stream m (Either ParseError b) +parseManyD = parseMany + +-- | Apply a stream of parsers to an input stream and emit the results in the +-- output stream. +-- +-- /Unimplemented/ +-- +{-# INLINE parseSequence #-} +parseSequence + :: -- Monad m => + Stream m (PR.Parser a m b) + -> Stream m a + -> Stream m b +parseSequence _f _m = undefined + +-- XXX Change the parser arguments' order + +-- | @parseManyTill collect test stream@ tries the parser @test@ on the input, +-- if @test@ fails it backtracks and tries @collect@, after @collect@ succeeds +-- @test@ is tried again and so on. The parser stops when @test@ succeeds. The +-- output of @test@ is discarded and the output of @collect@ is emitted in the +-- output stream. The parser fails if @collect@ fails. +-- +-- /Unimplemented/ +-- +{-# INLINE parseManyTill #-} +parseManyTill :: + -- MonadThrow m => + PR.Parser a m b + -> PR.Parser a m x + -> Stream m a + -> Stream m b +parseManyTill = undefined + +-- | Iterate a parser generating function on a stream. The initial value @b@ is +-- used to generate the first parser, the parser is applied on the stream and +-- the result is used to generate the next parser and so on. +-- +-- Example: +-- +-- >>> import Data.Monoid (Sum(..)) +-- >>> s = Stream.fromList [1..10] +-- >>> Stream.toList $ fmap getSum $ Stream.catRights $ Stream.parseIterate (\b -> Parser.takeBetween 0 2 (Fold.sconcat b)) (Sum 0) $ fmap Sum s +-- [3,10,21,36,55,55] +-- +-- This is the streaming equivalent of monad like sequenced application of +-- parsers where next parser is dependent on the previous parser. +-- +-- /Pre-release/ +-- +{-# INLINE parseIterate #-} +parseIterate + :: Monad m + => (b -> PRD.Parser a m b) + -> b + -> Stream m a + -> Stream m (Either ParseError b) +parseIterate = Drivers.parseIterate + +-- | Like 'parseIterate' but includes stream position information in the error +-- messages. +-- +{-# INLINE parseIteratePos #-} +parseIteratePos + :: Monad m + => (b -> PRD.Parser a m b) + -> b + -> Stream m a + -> Stream m (Either ParseErrorPos b) +parseIteratePos = Drivers.parseIteratePos + +{-# DEPRECATED parseIterateD "Please use parseIterate instead." #-} +{-# INLINE parseIterateD #-} +parseIterateD + :: Monad m + => (b -> PR.Parser a m b) + -> b + -> Stream m a + -> Stream m (Either ParseError b) +parseIterateD = parseIterate + +------------------------------------------------------------------------------ +-- Grouping +------------------------------------------------------------------------------ + +data GroupByState st fs a b + = GroupingInit st + | GroupingDo st !fs + | GroupingInitWith st !a + | GroupingDoWith st !fs !a + | GroupingYield !b (GroupByState st fs a b) + | GroupingDone + +-- | Keep collecting items in a group as long as the comparison function +-- returns true. The comparison function is @cmp old new@ where @old@ is the +-- first item in the group and @new@ is the incoming item being tested for +-- membership of the group. The collected items are folded by the supplied +-- fold. +-- +-- Definition: +-- +-- >>> groupsWhile cmp f = Stream.parseMany (Parser.groupBy cmp f) +{-# INLINE_NORMAL groupsWhile #-} +groupsWhile :: Monad m + => (a -> a -> Bool) + -> Fold m a b + -> Stream m a + -> Stream m b +{- +groupsWhile eq fld = parseMany (PRD.groupBy eq fld) +-} +groupsWhile cmp (Fold fstep initial _ final) (Stream step state) = + Stream stepOuter (GroupingInit state) + + where + + {-# INLINE_LATE stepOuter #-} + stepOuter _ (GroupingInit st) = do + -- XXX Note that if the stream stops without yielding a single element + -- in the group we discard the "initial" effect. + res <- initial + return + $ case res of + FL.Partial s -> Skip $ GroupingDo st s + FL.Done b -> Yield b $ GroupingInit st + stepOuter gst (GroupingDo st fs) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + r <- fstep fs x + case r of + FL.Partial fs1 -> go SPEC x s fs1 + FL.Done b -> return $ Yield b (GroupingInit s) + Skip s -> return $ Skip $ GroupingDo s fs + Stop -> final fs >> return Stop + + where + + go !_ prev stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if cmp prev x + then do + r <- fstep acc x + case r of + FL.Partial fs1 -> go SPEC prev s fs1 + FL.Done b -> return $ Yield b (GroupingInit s) + else do + r <- final acc + return $ Yield r (GroupingInitWith s x) + Skip s -> go SPEC prev s acc + Stop -> do + r <- final acc + return $ Yield r GroupingDone + stepOuter _ (GroupingInitWith st x) = do + res <- initial + return + $ case res of + FL.Partial s -> Skip $ GroupingDoWith st s x + FL.Done b -> Yield b $ GroupingInitWith st x + stepOuter gst (GroupingDoWith st fs prev) = do + res <- fstep fs prev + case res of + FL.Partial fs1 -> go SPEC st fs1 + FL.Done b -> return $ Yield b (GroupingInit st) + + where + + -- XXX code duplicated from the previous equation + go !_ stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if cmp prev x + then do + r <- fstep acc x + case r of + FL.Partial fs1 -> go SPEC s fs1 + FL.Done b -> return $ Yield b (GroupingInit s) + else do + r <- final acc + return $ Yield r (GroupingInitWith s x) + Skip s -> go SPEC s acc + Stop -> do + r <- final acc + return $ Yield r GroupingDone + stepOuter _ (GroupingYield _ _) = error "groupsWhile: Unreachable" + stepOuter _ GroupingDone = return Stop + +-- | The argument order of the comparison function in `groupsWhile` is +-- different than that of `groupsBy`. +-- +-- In `groupsBy` the comparison function takes the next element as the first +-- argument and the previous element as the second argument. In `groupsWhile` +-- the first argument is the previous element and second argument is the next +-- element. +{-# DEPRECATED groupsBy "Please use groupsWhile instead. Please note the change in the argument order of the comparison function." #-} +{-# INLINE_NORMAL groupsBy #-} +groupsBy :: Monad m + => (a -> a -> Bool) + -> Fold m a b + -> Stream m a + -> Stream m b +groupsBy cmp = groupsWhile (flip cmp) + +-- | +-- +-- Definition: +-- +-- >>> groupsRollingBy cmp f = Stream.parseMany (Parser.groupByRolling cmp f) +-- +{-# INLINE_NORMAL groupsRollingBy #-} +groupsRollingBy :: Monad m + => (a -> a -> Bool) + -> Fold m a b + -> Stream m a + -> Stream m b +{- +groupsRollingBy eq fld = parseMany (PRD.groupByRolling eq fld) +-} +groupsRollingBy cmp (Fold fstep initial _ final) (Stream step state) = + Stream stepOuter (GroupingInit state) + + where + + {-# INLINE_LATE stepOuter #-} + stepOuter _ (GroupingInit st) = do + -- XXX Note that if the stream stops without yielding a single element + -- in the group we discard the "initial" effect. + res <- initial + return + $ case res of + FL.Partial fs -> Skip $ GroupingDo st fs + FL.Done fb -> Yield fb $ GroupingInit st + stepOuter gst (GroupingDo st fs) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + r <- fstep fs x + case r of + FL.Partial fs1 -> go SPEC x s fs1 + FL.Done fb -> return $ Yield fb (GroupingInit s) + Skip s -> return $ Skip $ GroupingDo s fs + Stop -> final fs >> return Stop + + where + + go !_ prev stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if cmp prev x + then do + r <- fstep acc x + case r of + FL.Partial fs1 -> go SPEC x s fs1 + FL.Done b -> return $ Yield b (GroupingInit s) + else do + r <- final acc + return $ Yield r (GroupingInitWith s x) + Skip s -> go SPEC prev s acc + Stop -> do + r <- final acc + return $ Yield r GroupingDone + stepOuter _ (GroupingInitWith st x) = do + res <- initial + return + $ case res of + FL.Partial s -> Skip $ GroupingDoWith st s x + FL.Done b -> Yield b $ GroupingInitWith st x + stepOuter gst (GroupingDoWith st fs previous) = do + res <- fstep fs previous + case res of + FL.Partial s -> go SPEC previous st s + FL.Done b -> return $ Yield b (GroupingInit st) + + where + + -- XXX GHC: groupsWhile has one less parameter in this go loop and it + -- fuses. However, groupsRollingBy does not fuse, removing the prev + -- parameter makes it fuse. Something needs to be fixed in GHC. The + -- workaround for this is noted in the comments below. + go !_ prev !stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if cmp prev x + then do + r <- fstep acc x + case r of + FL.Partial fs1 -> go SPEC x s fs1 + FL.Done b -> return $ Yield b (GroupingInit st) + else do + {- + r <- final acc + return $ Yield r (GroupingInitWith s x) + -} + -- The code above does not let groupBy fuse. We use the + -- alternative code below instead. Instead of jumping + -- to GroupingInitWith state, we unroll the code of + -- GroupingInitWith state here to help GHC with stream + -- fusion. + result <- initial + r <- final acc + return + $ Yield r + $ case result of + FL.Partial fsi -> GroupingDoWith s fsi x + FL.Done b -> GroupingYield b (GroupingInit s) + Skip s -> go SPEC prev s acc + Stop -> do + r <- final acc + return $ Yield r GroupingDone + stepOuter _ (GroupingYield r next) = return $ Yield r next + stepOuter _ GroupingDone = return Stop + +------------------------------------------------------------------------------ +-- Splitting - by a predicate +------------------------------------------------------------------------------ + +data WordsByState st fs b + = WordsByInit st + | WordsByDo st !fs + | WordsByDone + | WordsByYield !b (WordsByState st fs b) + +-- | Split the stream after stripping leading, trailing, and repeated +-- separators determined by the predicate supplied. The tokens after splitting +-- are collected by the supplied fold. In other words, the tokens are parsed in +-- the same way as words are parsed from whitespace separated text. +-- +-- >>> f x = Stream.toList $ Stream.wordsBy (== '.') Fold.toList $ Stream.fromList x +-- >>> f "a.b" +-- ["a","b"] +-- >>> f "a..b" +-- ["a","b"] +-- >>> f ".a..b." +-- ["a","b"] +-- +{-# INLINE_NORMAL wordsBy #-} +wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +wordsBy predicate (Fold fstep initial _ final) (Stream step state) = + Stream stepOuter (WordsByInit state) + + where + + {-# INLINE_LATE stepOuter #-} + stepOuter _ (WordsByInit st) = do + res <- initial + return + $ case res of + FL.Partial s -> Skip $ WordsByDo st s + FL.Done b -> Yield b (WordsByInit st) + + stepOuter gst (WordsByDo st fs) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + if predicate x + then do + resi <- initial + return + $ case resi of + FL.Partial fs1 -> Skip $ WordsByDo s fs1 + FL.Done b -> Yield b (WordsByInit s) + else do + r <- fstep fs x + case r of + FL.Partial fs1 -> go SPEC s fs1 + FL.Done b -> return $ Yield b (WordsByInit s) + Skip s -> return $ Skip $ WordsByDo s fs + Stop -> final fs >> return Stop + + where + + go !_ stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if predicate x + then do + {- + r <- final acc + return $ Yield r (WordsByInit s) + -} + -- The above code does not fuse well. Need to check why + -- GHC is not able to simplify it well. Using the code + -- below, instead of jumping through the WordsByInit + -- state always, we directly go to WordsByDo state in + -- the common case of Partial. + resi <- initial + r <- final acc + return + $ Yield r + $ case resi of + FL.Partial fs1 -> WordsByDo s fs1 + FL.Done b -> WordsByYield b (WordsByInit s) + else do + r <- fstep acc x + case r of + FL.Partial fs1 -> go SPEC s fs1 + FL.Done b -> return $ Yield b (WordsByInit s) + Skip s -> go SPEC s acc + Stop -> do + r <- final acc + return $ Yield r WordsByDone + + stepOuter _ WordsByDone = return Stop + + stepOuter _ (WordsByYield b next) = return $ Yield b next + +------------------------------------------------------------------------------ +-- Splitting on a sequence +------------------------------------------------------------------------------ + +-- String search algorithms: +-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html + +-- XXX Can GHC find a way to modularise this? Can we write different cases +-- i.e.g single element, word hash, karp-rabin as different functions and then +-- be able to combine them into a single state machine? + +{-# ANN type TakeEndBySeqState Fuse #-} +data TakeEndBySeqState mba rb rh ck w s b x = + TakeEndBySeqInit + | TakeEndBySeqYield !b (TakeEndBySeqState mba rb rh ck w s b x) + | TakeEndBySeqDone + + | TakeEndBySeqSingle s x + + | TakeEndBySeqWordInit !Int !w s + | TakeEndBySeqWordLoop !w s + | TakeEndBySeqWordDone !Int !w + + | TakeEndBySeqKRInit s mba + | TakeEndBySeqKRInit1 s mba !Int + | TakeEndBySeqKRLoop s mba !rh !ck + | TakeEndBySeqKRCheck s mba !rh + | TakeEndBySeqKRDone !Int rb + +-- | If the pattern is empty the output stream is empty. +{-# INLINE_NORMAL takeEndBySeqWith #-} +takeEndBySeqWith + :: forall m a. (MonadIO m, Unbox a, Enum a, Eq a) + => Bool + -> Array a + -> Stream m a + -> Stream m a +takeEndBySeqWith withSep patArr (Stream step state) = + Stream stepOuter TakeEndBySeqInit + + where + + patLen = A.length patArr + patBytes = A.byteLength patArr + maxIndex = patLen - 1 + maxOffset = patBytes - SIZE_OF(a) + elemBits = SIZE_OF(a) * 8 + + -- For word pattern case + wordMask :: Word + wordMask = (1 `shiftL` (elemBits * patLen)) - 1 + + elemMask :: Word + elemMask = (1 `shiftL` elemBits) - 1 + + wordPat :: Word + wordPat = wordMask .&. A.foldl' addToWord 0 patArr + + addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) + + -- For Rabin-Karp search + k = 2891336453 :: Word32 + coeff = k ^ patLen + + addCksum cksum a = cksum * k + fromIntegral (fromEnum a) + + deltaCksum cksum old new = + addCksum cksum new - coeff * fromIntegral (fromEnum old) + + -- XXX shall we use a random starting hash or 1 instead of 0? + patHash = A.foldl' addCksum 0 patArr + + skip = return . Skip + + {-# INLINE yield #-} + yield x !s = skip $ TakeEndBySeqYield x s + + {-# INLINE_LATE stepOuter #-} + stepOuter _ TakeEndBySeqInit = do + -- XXX When we statically specify the method compiler is able to + -- simplify the code better and removes the handling of other states. + -- When it is determined dynamically, the code is less efficient. For + -- example, the single element search degrades by 80% if the handling + -- of other cases is present. We need to investigate this further but + -- until then we can guide the compiler statically where we can. If we + -- want to use single element search statically then we can use + -- takeEndBy instead. + -- + -- XXX Is there a way for GHC to statically determine patLen when we + -- use an array created from a static string as pattern e.g. "\n". + case () of + _ | patLen == 0 -> return Stop + | patLen == 1 -> do + pat <- liftIO $ A.unsafeGetIndexIO 0 patArr + return $ Skip $ TakeEndBySeqSingle state pat + | SIZE_OF(a) * patLen <= sizeOf (Proxy :: Proxy Word) -> + return $ Skip $ TakeEndBySeqWordInit 0 0 state + | otherwise -> do + (MutArray mba _ _ _) :: MutArray a <- + liftIO $ MutArray.emptyOf patLen + skip $ TakeEndBySeqKRInit state mba + + --------------------- + -- Single yield point + --------------------- + + stepOuter _ (TakeEndBySeqYield x next) = return $ Yield x next + + ----------------- + -- Done + ----------------- + + stepOuter _ TakeEndBySeqDone = return Stop + + ----------------- + -- Single Pattern + ----------------- + + stepOuter gst (TakeEndBySeqSingle st pat) = do + res <- step (adaptState gst) st + case res of + Yield x s -> + if pat /= x + then yield x (TakeEndBySeqSingle s pat) + else do + if withSep + then yield x TakeEndBySeqDone + else return Stop + Skip s -> skip $ TakeEndBySeqSingle s pat + Stop -> return Stop + + --------------------------- + -- Short Pattern - Shift Or + --------------------------- + + -- Note: Karp-Rabin is roughly 15% slower than word hash for a 2 element + -- pattern. This may be useful for common cases like splitting lines using + -- "\r\n". + stepOuter _ (TakeEndBySeqWordDone 0 _) = do + return Stop + stepOuter _ (TakeEndBySeqWordDone n wrd) = do + let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1))) + in yield + (toEnum $ fromIntegral old) + (TakeEndBySeqWordDone (n - 1) wrd) + + -- XXX If we remove this init state for perf experiment the time taken + -- reduces to half, there may be some optimization opportunity here. + stepOuter gst (TakeEndBySeqWordInit idx wrd st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let wrd1 = addToWord wrd x + next + | idx /= maxIndex = + TakeEndBySeqWordInit (idx + 1) wrd1 s + | wrd1 .&. wordMask /= wordPat = + TakeEndBySeqWordLoop wrd1 s + | otherwise = TakeEndBySeqDone + if withSep + then yield x next + else skip next + Skip s -> skip $ TakeEndBySeqWordInit idx wrd s + Stop -> + if withSep + then return Stop + else skip $ TakeEndBySeqWordDone idx wrd + + stepOuter gst (TakeEndBySeqWordLoop wrd st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + -- XXX Never use a lazy expression as state, that causes issues + -- in simplification because the state argument of Yield is + -- lazy, maybe we can make that strict. + let wrd1 = addToWord wrd x + old = (wordMask .&. wrd) + `shiftR` (elemBits * (patLen - 1)) + !y = + if withSep + then x + else toEnum $ fromIntegral old + -- Note: changing the nesting order of if and yield makes a + -- difference in performance. + if wrd1 .&. wordMask /= wordPat + then yield y (TakeEndBySeqWordLoop wrd1 s) + else yield y TakeEndBySeqDone + Skip s -> skip $ TakeEndBySeqWordLoop wrd s + Stop -> + if withSep + then return Stop + else skip $ TakeEndBySeqWordDone patLen wrd + + ------------------------------- + -- General Pattern - Karp Rabin + ------------------------------- + + stepOuter gst (TakeEndBySeqKRInit st0 mba) = do + res <- step (adaptState gst) st0 + case res of + Yield x s -> do + liftIO $ pokeAt 0 mba x + if withSep + then yield x (TakeEndBySeqKRInit1 s mba (SIZE_OF(a))) + else skip $ TakeEndBySeqKRInit1 s mba (SIZE_OF(a)) + Skip s -> skip $ TakeEndBySeqKRInit s mba + Stop -> return Stop + + stepOuter gst (TakeEndBySeqKRInit1 st mba offset) = do + res <- step (adaptState gst) st + let arr :: Array a = Array + { arrContents = mba + , arrStart = 0 + , arrEnd = patBytes + } + case res of + Yield x s -> do + liftIO $ pokeAt offset mba x + let next = + if offset /= maxOffset + then TakeEndBySeqKRInit1 s mba (offset + SIZE_OF(a)) + else + let ringHash = A.foldl' addCksum 0 arr + in if ringHash == patHash + then TakeEndBySeqKRCheck s mba 0 + else TakeEndBySeqKRLoop s mba 0 ringHash + if withSep + then yield x next + else skip next + Skip s -> skip $ TakeEndBySeqKRInit1 s mba offset + Stop -> do + if withSep + then return Stop + else do + let rb = RingArray + { ringContents = mba + , ringSize = offset + , ringHead = 0 + } + in skip $ TakeEndBySeqKRDone offset rb + + stepOuter gst (TakeEndBySeqKRLoop st mba rh cksum) = do + res <- step (adaptState gst) st + let rb = RingArray + { ringContents = mba + , ringSize = patBytes + , ringHead = rh + } + case res of + Yield x s -> do + (rb1, old) <- liftIO (RB.replace rb x) + let cksum1 = deltaCksum cksum old x + let rh1 = ringHead rb1 + next = + if cksum1 /= patHash + then TakeEndBySeqKRLoop s mba rh1 cksum1 + else TakeEndBySeqKRCheck s mba rh1 + if withSep + then yield x next + else yield old next + Skip s -> skip $ TakeEndBySeqKRLoop s mba rh cksum + Stop -> do + if withSep + then return Stop + else skip $ TakeEndBySeqKRDone patBytes rb + + stepOuter _ (TakeEndBySeqKRCheck st mba rh) = do + let rb = RingArray + { ringContents = mba + , ringSize = patBytes + , ringHead = rh + } + matches <- liftIO $ RB.eqArray rb patArr + if matches + then return Stop + else skip $ TakeEndBySeqKRLoop st mba rh patHash + + stepOuter _ (TakeEndBySeqKRDone 0 _) = return Stop + stepOuter _ (TakeEndBySeqKRDone len rb) = do + assert (len >= 0) (return ()) + old <- RB.unsafeGetHead rb + let rb1 = RB.moveForward rb + yield old $ TakeEndBySeqKRDone (len - SIZE_OF(a)) rb1 + +-- | Take the stream until the supplied sequence is encountered. Take the +-- sequence as well and stop. +-- +-- Usage: +-- +-- >>> f pat xs = Stream.toList $ Stream.takeEndBySeq (Array.fromList pat) $ Stream.fromList xs +-- >>> f "fgh" "abcdefghijk" +-- "abcdefgh" +-- >>> f "lmn" "abcdefghijk" +-- "abcdefghijk" +-- >>> f "" "abcdefghijk" +-- "" +-- +{-# INLINE takeEndBySeq #-} +takeEndBySeq + :: forall m a. (MonadIO m, Unbox a, Enum a, Eq a) + => Array a + -> Stream m a + -> Stream m a +takeEndBySeq = takeEndBySeqWith True + +-- | Take the stream until the supplied sequence is encountered. Do not take +-- the sequence. +-- +-- Usage: +-- +-- >>> f pat xs = Stream.toList $ Stream.takeEndBySeq_ (Array.fromList pat) $ Stream.fromList xs +-- >>> f "fgh" "abcdefghijk" +-- "abcde" +-- >>> f "lmn" "abcdefghijk" +-- "abcdefghijk" +-- >>> f "" "abcdefghijk" +-- "" +-- +{-# INLINE takeEndBySeq_ #-} +takeEndBySeq_ + :: forall m a. (MonadIO m, Unbox a, Enum a, Eq a) + => Array a + -> Stream m a + -> Stream m a +takeEndBySeq_ = takeEndBySeqWith False + +{- +-- TODO can we unify the splitting operations using a splitting configuration +-- like in the split package. +-- +data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show) +data SplitOptions = SplitOptions + { style :: SplitStyle + , withSep :: Bool -- ^ keep the separators in output + -- , compact :: Bool -- ^ treat multiple consecutive separators as one + -- , trimHead :: Bool -- ^ drop blank at head + -- , trimTail :: Bool -- ^ drop blank at tail + } +-} + +-- XXX using "fs" as the last arg in Constructors may simplify the code a bit, +-- because we can use the constructor directly without having to create "jump" +-- functions. +{-# ANN type SplitOnSeqState Fuse #-} +data SplitOnSeqState mba rb rh ck w fs s b x = + SplitOnSeqInit + | SplitOnSeqYield b (SplitOnSeqState mba rb rh ck w fs s b x) + | SplitOnSeqDone + + | SplitOnSeqEmpty !fs s + + | SplitOnSeqSingle0 !fs s x + | SplitOnSeqSingle !fs s x + + | SplitOnSeqWordInit0 !fs s + | SplitOnSeqWordInit Int Word !fs s + | SplitOnSeqWordLoop !w s !fs + | SplitOnSeqWordDone Int !fs !w + + | SplitOnSeqKRInit0 Int !fs s mba + | SplitOnSeqKRInit Int !fs s mba + | SplitOnSeqKRLoop fs s mba !rh !ck + | SplitOnSeqKRCheck fs s mba !rh + | SplitOnSeqKRDone Int !fs rb + + | SplitOnSeqReinit (fs -> SplitOnSeqState mba rb rh ck w fs s b x) + +-- XXX Need to fix empty stream split behavior + +-- | Like 'splitSepBy_' but splits the stream on a sequence of elements rather than +-- a single element. Parses a sequence of tokens separated by an infixed +-- separator e.g. @a;b;c@ is parsed as @a@, @b@, @c@. If the pattern is empty +-- then each element is a match, thus the fold is finalized on each element. +-- +-- >>> splitSepBy p xs = Stream.fold Fold.toList $ Stream.splitSepBySeq_ (Array.fromList p) Fold.toList (Stream.fromList xs) +-- +-- >>> splitSepBy "" "" +-- [] +-- +-- >>> splitSepBy "" "a...b" +-- ["a",".",".",".","b"] +-- +-- >>> splitSepBy ".." "" +-- [] +-- +-- >>> splitSepBy ".." "a...b" +-- ["a",".b"] +-- +-- >>> splitSepBy ".." "abc" +-- ["abc"] +-- +-- >>> splitSepBy ".." ".." +-- ["",""] +-- +-- >>> splitSepBy "." ".a" +-- ["","a"] +-- +-- >>> splitSepBy "." "a." +-- ["a",""] +-- +-- Uses Rabin-Karp algorithm for substring search. +-- +{-# INLINE_NORMAL splitSepBySeq_ #-} +splitSepBySeq_, splitOnSeq + :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) + => Array a + -> Fold m a b + -> Stream m a + -> Stream m b +splitSepBySeq_ patArr (Fold fstep initial _ final) (Stream step state) = + Stream stepOuter SplitOnSeqInit + + where + + patLen = A.length patArr + patBytes = A.byteLength patArr + maxIndex = patLen - 1 + maxOffset = patBytes - SIZE_OF(a) + elemBits = SIZE_OF(a) * 8 + + -- For word pattern case + wordMask :: Word + wordMask = (1 `shiftL` (elemBits * patLen)) - 1 + + elemMask :: Word + elemMask = (1 `shiftL` elemBits) - 1 + + wordPat :: Word + wordPat = wordMask .&. A.foldl' addToWord 0 patArr + + addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) + + -- For Rabin-Karp search + k = 2891336453 :: Word32 + coeff = k ^ patLen + + addCksum cksum a = cksum * k + fromIntegral (fromEnum a) + + deltaCksum cksum old new = + addCksum cksum new - coeff * fromIntegral (fromEnum old) + + -- XXX shall we use a random starting hash or 1 instead of 0? + patHash = A.foldl' addCksum 0 patArr + + skip = return . Skip + + nextAfterInit nextGen stepRes = + case stepRes of + FL.Partial s -> nextGen s + FL.Done b -> SplitOnSeqYield b (SplitOnSeqReinit nextGen) + + {-# INLINE yieldReinit #-} + yieldReinit nextGen fs = + initial >>= skip . SplitOnSeqYield fs . nextAfterInit nextGen + + {-# INLINE_LATE stepOuter #-} + stepOuter _ SplitOnSeqInit = do + res <- initial + case res of + FL.Partial acc + | patLen == 0 -> + return $ Skip $ SplitOnSeqEmpty acc state + | patLen == 1 -> do + pat <- liftIO $ A.unsafeGetIndexIO 0 patArr + return $ Skip $ SplitOnSeqSingle0 acc state pat + | SIZE_OF(a) * patLen <= sizeOf (Proxy :: Proxy Word) -> + return $ Skip $ SplitOnSeqWordInit0 acc state + | otherwise -> do + (MutArray mba _ _ _) :: MutArray a <- + liftIO $ MutArray.emptyOf patLen + skip $ SplitOnSeqKRInit0 0 acc state mba + FL.Done b -> skip $ SplitOnSeqYield b SplitOnSeqInit + + stepOuter _ (SplitOnSeqYield x next) = return $ Yield x next + + --------------------------- + -- Checkpoint + --------------------------- + + stepOuter _ (SplitOnSeqReinit nextGen) = + initial >>= skip . nextAfterInit nextGen + + --------------------------- + -- Empty pattern + --------------------------- + + stepOuter gst (SplitOnSeqEmpty acc st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + r <- fstep acc x + b1 <- + case r of + FL.Partial acc1 -> final acc1 + FL.Done b -> return b + let jump c = SplitOnSeqEmpty c s + in yieldReinit jump b1 + Skip s -> skip (SplitOnSeqEmpty acc s) + Stop -> final acc >> return Stop + + ----------------- + -- Done + ----------------- + + stepOuter _ SplitOnSeqDone = return Stop + + ----------------- + -- Single Pattern + ----------------- + + stepOuter gst (SplitOnSeqSingle0 fs st pat) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + -- XXX This code block is duplicated in SplitOnSeqSingle state + let jump c = SplitOnSeqSingle c s pat + if pat == x + then final fs >>= yieldReinit jump + else do + r <- fstep fs x + case r of + FL.Partial fs1 -> + pure $ Skip $ SplitOnSeqSingle fs1 s pat + FL.Done b -> yieldReinit jump b + Skip s -> pure $ Skip $ SplitOnSeqSingle0 fs s pat + Stop -> final fs >> pure Stop + + stepOuter gst (SplitOnSeqSingle fs0 st0 pat) = do + go SPEC fs0 st0 + + where + + -- The local loop increases allocations by 6% but improves CPU + -- performance by 14%. + go !_ !fs !st = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let jump c = SplitOnSeqSingle c s pat + if pat == x + then final fs >>= yieldReinit jump + else do + r <- fstep fs x + case r of + FL.Partial fs1 -> go SPEC fs1 s + FL.Done b -> yieldReinit jump b + Skip s -> go SPEC fs s + Stop -> do + r <- final fs + return $ Skip $ SplitOnSeqYield r SplitOnSeqDone + + --------------------------- + -- Short Pattern - Shift Or + --------------------------- + + -- Note: We fill the matching buffer before we emit anything, in case it + -- matches and we have to drop it. Though we could be more eager in + -- emitting as soon as we know that the pattern cannot match. But still the + -- worst case will remain the same, in case a match is going to happen we + -- will have to delay until the very end. + + stepOuter _ (SplitOnSeqWordDone 0 fs _) = do + r <- final fs + skip $ SplitOnSeqYield r SplitOnSeqDone + stepOuter _ (SplitOnSeqWordDone n fs wrd) = do + let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1))) + r <- fstep fs (toEnum $ fromIntegral old) + case r of + FL.Partial fs1 -> skip $ SplitOnSeqWordDone (n - 1) fs1 wrd + FL.Done b -> do + let jump c = SplitOnSeqWordDone (n - 1) c wrd + yieldReinit jump b + + stepOuter gst (SplitOnSeqWordInit0 fs st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> + let wrd1 = addToWord 0 x + in pure $ Skip $ SplitOnSeqWordInit 1 wrd1 fs s + Skip s -> pure $ Skip $ SplitOnSeqWordInit0 fs s + Stop -> final fs >> pure Stop + + stepOuter gst (SplitOnSeqWordInit idx0 wrd0 fs st0) = + go SPEC idx0 wrd0 st0 + + where + + {-# INLINE go #-} + go !_ !idx !wrd !st = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let wrd1 = addToWord wrd x + if idx == maxIndex + then do + if wrd1 .&. wordMask == wordPat + then do + let jump c = SplitOnSeqWordInit 0 0 c s + final fs >>= yieldReinit jump + else skip $ SplitOnSeqWordLoop wrd1 s fs + else go SPEC (idx + 1) wrd1 s + Skip s -> go SPEC idx wrd s + Stop -> do + if idx /= 0 + then skip $ SplitOnSeqWordDone idx fs wrd + else do + r <- final fs + skip $ SplitOnSeqYield r SplitOnSeqDone + + stepOuter gst (SplitOnSeqWordLoop wrd0 st0 fs0) = + go SPEC wrd0 st0 fs0 + + where + + -- This loop does not affect allocations but it improves the CPU + -- performance signifcantly compared to looping using state. + {-# INLINE go #-} + go !_ !wrd !st !fs = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let jump c = SplitOnSeqWordInit 0 0 c s + wrd1 = addToWord wrd x + old = (wordMask .&. wrd) + `shiftR` (elemBits * (patLen - 1)) + r <- fstep fs (toEnum $ fromIntegral old) + case r of + FL.Partial fs1 -> do + if wrd1 .&. wordMask == wordPat + then final fs1 >>= yieldReinit jump + else go SPEC wrd1 s fs1 + FL.Done b -> yieldReinit jump b + Skip s -> go SPEC wrd s fs + Stop -> skip $ SplitOnSeqWordDone patLen fs wrd + + ------------------------------- + -- General Pattern - Karp Rabin + ------------------------------- + + -- XXX Document this pattern for writing efficient code. Loop around only + -- required elements in the recursive loop, build the structures being + -- manipulated locally e.g. we are passing only mba, here and build an + -- array using patLen and arrStart from the surrounding context. + + stepOuter gst (SplitOnSeqKRInit0 offset fs st mba) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + liftIO $ pokeAt offset mba x + skip $ SplitOnSeqKRInit (offset + SIZE_OF(a)) fs s mba + Skip s -> skip $ SplitOnSeqKRInit0 offset fs s mba + Stop -> final fs >> pure Stop + + stepOuter gst (SplitOnSeqKRInit offset fs st mba) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + liftIO $ pokeAt offset mba x + if offset == maxOffset + then do + let arr :: Array a = Array + { arrContents = mba + , arrStart = 0 + , arrEnd = patBytes + } + let ringHash = A.foldl' addCksum 0 arr + if ringHash == patHash && A.byteEq arr patArr + then skip $ SplitOnSeqKRCheck fs s mba 0 + else skip $ SplitOnSeqKRLoop fs s mba 0 ringHash + else skip $ SplitOnSeqKRInit (offset + SIZE_OF(a)) fs s mba + Skip s -> skip $ SplitOnSeqKRInit offset fs s mba + Stop -> do + let rb = RingArray + { ringContents = mba + , ringSize = offset + , ringHead = 0 + } + skip $ SplitOnSeqKRDone offset fs rb + + -- XXX The recursive "go" is more efficient than the state based recursion + -- code commented out below. Perhaps its more efficient because of + -- factoring out "mba" outside the loop. + -- + stepOuter gst (SplitOnSeqKRLoop fs0 st0 mba rh0 cksum0) = + go SPEC fs0 st0 rh0 cksum0 + + where + + go !_ !fs !st !rh !cksum = do + res <- step (adaptState gst) st + let rb = RingArray + { ringContents = mba + , ringSize = patBytes + , ringHead = rh + } + case res of + Yield x s -> do + (rb1, old) <- liftIO (RB.replace rb x) + r <- fstep fs old + case r of + FL.Partial fs1 -> do + let cksum1 = deltaCksum cksum old x + let rh1 = ringHead rb1 + if cksum1 == patHash + then skip $ SplitOnSeqKRCheck fs1 s mba rh1 + else go SPEC fs1 s rh1 cksum1 + FL.Done b -> do + -- XXX the old code looks wrong as we are resetting + -- the ring head but the ring still has old + -- elements as we are not resetting the size. + let jump c = SplitOnSeqKRInit 0 c s mba + yieldReinit jump b + Skip s -> go SPEC fs s rh cksum + Stop -> skip $ SplitOnSeqKRDone patBytes fs rb + + -- XXX The following code is 5 times slower compared to the recursive loop + -- based code above. Need to investigate why. One possibility is that the + -- go loop above does not thread around the ring buffer (rb). This code may + -- be causing the state to bloat and getting allocated on each iteration. + -- We can check the cmm/asm code to confirm. If so a good GHC solution to + -- such problem is needed. One way to avoid this could be to use unboxed + -- mutable state? + {- + stepOuter gst (SplitOnSeqKRLoop fs st rb rh cksum) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + old <- liftIO $ peek rh + let cksum1 = deltaCksum cksum old x + fs1 <- fstep fs old + if (cksum1 == patHash) + then do + r <- done fs1 + skip $ SplitOnSeqYield r $ SplitOnSeqKRInit 0 s rb rh + else do + rh1 <- liftIO (RB.unsafeInsert rb rh x) + skip $ SplitOnSeqKRLoop fs1 s rb rh1 cksum1 + Skip s -> skip $ SplitOnSeqKRLoop fs s rb rh cksum + Stop -> skip $ SplitOnSeqKRDone patLen fs rb rh + -} + + stepOuter _ (SplitOnSeqKRCheck fs st mba rh) = do + let rb = RingArray + { ringContents = mba + , ringSize = patBytes + , ringHead = rh + } + res <- liftIO $ RB.eqArray rb patArr + if res + then do + r <- final fs + let jump c = SplitOnSeqKRInit 0 c st mba + yieldReinit jump r + else skip $ SplitOnSeqKRLoop fs st mba rh patHash + + stepOuter _ (SplitOnSeqKRDone 0 fs _) = do + r <- final fs + skip $ SplitOnSeqYield r SplitOnSeqDone + stepOuter _ (SplitOnSeqKRDone len fs rb) = do + assert (len >= 0) (return ()) + old <- RB.unsafeGetHead rb + let rb1 = RB.moveForward rb + r <- fstep fs old + case r of + FL.Partial fs1 -> skip $ SplitOnSeqKRDone (len - SIZE_OF(a)) fs1 rb1 + FL.Done b -> do + let jump c = SplitOnSeqKRDone (len - SIZE_OF(a)) c rb1 + yieldReinit jump b + +RENAME(splitOnSeq,splitSepBySeq_) + +{-# ANN type SplitOnSuffixSeqState Fuse #-} +data SplitOnSuffixSeqState mba rb rh ck w fs s b x = + SplitOnSuffixSeqInit + | SplitOnSuffixSeqYield b (SplitOnSuffixSeqState mba rb rh ck w fs s b x) + | SplitOnSuffixSeqDone + + | SplitOnSuffixSeqEmpty !fs s + + | SplitOnSuffixSeqSingleInit !fs s x + | SplitOnSuffixSeqSingle !fs s x + + | SplitOnSuffixSeqWordInit !fs s + | SplitOnSuffixSeqWordLoop !w s !fs + | SplitOnSuffixSeqWordDone Int !fs !w + + | SplitOnSuffixSeqKRInit !fs s mba + | SplitOnSuffixSeqKRInit1 !fs s mba + | SplitOnSuffixSeqKRLoop fs s mba !rh !ck + | SplitOnSuffixSeqKRCheck fs s mba !rh + | SplitOnSuffixSeqKRDone Int !fs rb + + | SplitOnSuffixSeqReinit + (fs -> SplitOnSuffixSeqState mba rb rh ck w fs s b x) + +-- | @splitOnSuffixSeq withSep pat fld input@ splits the input using @pat@ as a +-- suffixed separator, the resulting split segments are fed to the fold @fld@. +-- If @withSep@ is True then the separator sequence is also suffixed with the +-- split segments. +-- +-- /Internal/ +{-# INLINE_NORMAL splitOnSuffixSeq #-} +splitOnSuffixSeq + :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) + => Bool + -> Array a + -> Fold m a b + -> Stream m a + -> Stream m b +splitOnSuffixSeq withSep patArr (Fold fstep initial _ final) (Stream step state) = + Stream stepOuter SplitOnSuffixSeqInit + + where + + patLen = A.length patArr + patBytes = A.byteLength patArr + maxIndex = patLen - 1 + maxOffset = patBytes - SIZE_OF(a) + elemBits = SIZE_OF(a) * 8 + + -- For word pattern case + wordMask :: Word + wordMask = (1 `shiftL` (elemBits * patLen)) - 1 + + elemMask :: Word + elemMask = (1 `shiftL` elemBits) - 1 + + wordPat :: Word + wordPat = wordMask .&. A.foldl' addToWord 0 patArr + + addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) + + nextAfterInit nextGen stepRes = + case stepRes of + FL.Partial s -> nextGen s + FL.Done b -> + SplitOnSuffixSeqYield b (SplitOnSuffixSeqReinit nextGen) + + {-# INLINE yieldReinit #-} + yieldReinit nextGen fs = + initial >>= skip . SplitOnSuffixSeqYield fs . nextAfterInit nextGen + + -- For single element pattern case + {-# INLINE processYieldSingle #-} + processYieldSingle pat x s fs = do + let jump c = SplitOnSuffixSeqSingleInit c s pat + if pat == x + then do + r <- if withSep then fstep fs x else return $ FL.Partial fs + b1 <- + case r of + FL.Partial fs1 -> final fs1 + FL.Done b -> return b + yieldReinit jump b1 + else do + r <- fstep fs x + case r of + FL.Partial fs1 -> skip $ SplitOnSuffixSeqSingle fs1 s pat + FL.Done b -> yieldReinit jump b + + -- For Rabin-Karp search + k = 2891336453 :: Word32 + coeff = k ^ patLen + + addCksum cksum a = cksum * k + fromIntegral (fromEnum a) + + deltaCksum cksum old new = + addCksum cksum new - coeff * fromIntegral (fromEnum old) + + -- XXX shall we use a random starting hash or 1 instead of 0? + patHash = A.foldl' addCksum 0 patArr + + skip = return . Skip + + {-# INLINE_LATE stepOuter #-} + stepOuter _ SplitOnSuffixSeqInit = do + res <- initial + case res of + FL.Partial fs + | patLen == 0 -> + skip $ SplitOnSuffixSeqEmpty fs state + | patLen == 1 -> do + pat <- liftIO $ A.unsafeGetIndexIO 0 patArr + skip $ SplitOnSuffixSeqSingleInit fs state pat + | SIZE_OF(a) * patLen <= sizeOf (Proxy :: Proxy Word) -> + skip $ SplitOnSuffixSeqWordInit fs state + | otherwise -> do + (MutArray mba _ _ _) :: MutArray a <- + liftIO $ MutArray.emptyOf patLen + skip $ SplitOnSuffixSeqKRInit fs state mba + FL.Done fb -> skip $ SplitOnSuffixSeqYield fb SplitOnSuffixSeqInit + + stepOuter _ (SplitOnSuffixSeqYield x next) = return $ Yield x next + + --------------------------- + -- Reinit + --------------------------- + + stepOuter _ (SplitOnSuffixSeqReinit nextGen) = + initial >>= skip . nextAfterInit nextGen + + --------------------------- + -- Empty pattern + --------------------------- + + stepOuter gst (SplitOnSuffixSeqEmpty acc st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let jump c = SplitOnSuffixSeqEmpty c s + r <- fstep acc x + b1 <- + case r of + FL.Partial fs -> final fs + FL.Done b -> return b + yieldReinit jump b1 + Skip s -> skip (SplitOnSuffixSeqEmpty acc s) + Stop -> final acc >> return Stop + + ----------------- + -- Done + ----------------- + + stepOuter _ SplitOnSuffixSeqDone = return Stop + + ----------------- + -- Single Pattern + ----------------- + + stepOuter gst (SplitOnSuffixSeqSingleInit fs st pat) = do + res <- step (adaptState gst) st + case res of + Yield x s -> processYieldSingle pat x s fs + Skip s -> skip $ SplitOnSuffixSeqSingleInit fs s pat + Stop -> final fs >> return Stop + + stepOuter gst (SplitOnSuffixSeqSingle fs st pat) = do + res <- step (adaptState gst) st + case res of + Yield x s -> processYieldSingle pat x s fs + Skip s -> skip $ SplitOnSuffixSeqSingle fs s pat + Stop -> do + r <- final fs + skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone + + --------------------------- + -- Short Pattern - Shift Or + --------------------------- + + stepOuter _ (SplitOnSuffixSeqWordDone 0 fs _) = do + r <- final fs + skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone + stepOuter _ (SplitOnSuffixSeqWordDone n fs wrd) = do + let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1))) + r <- fstep fs (toEnum $ fromIntegral old) + case r of + FL.Partial fs1 -> skip $ SplitOnSuffixSeqWordDone (n - 1) fs1 wrd + FL.Done b -> do + let jump c = SplitOnSuffixSeqWordDone (n - 1) c wrd + yieldReinit jump b + + stepOuter gst (SplitOnSuffixSeqWordInit fs0 st0) = do + res <- step (adaptState gst) st0 + case res of + Yield x s -> do + let wrd = addToWord 0 x + r <- if withSep then fstep fs0 x else return $ FL.Partial fs0 + case r of + FL.Partial fs1 -> go SPEC 1 wrd s fs1 + FL.Done b -> do + let jump c = SplitOnSuffixSeqWordInit c s + yieldReinit jump b + Skip s -> skip (SplitOnSuffixSeqWordInit fs0 s) + Stop -> final fs0 >> return Stop + + where + + {-# INLINE go #-} + go !_ !idx !wrd !st !fs = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let jump c = SplitOnSuffixSeqWordInit c s + let wrd1 = addToWord wrd x + r <- if withSep then fstep fs x else return $ FL.Partial fs + case r of + FL.Partial fs1 + | idx /= maxIndex -> + go SPEC (idx + 1) wrd1 s fs1 + | wrd1 .&. wordMask /= wordPat -> + skip $ SplitOnSuffixSeqWordLoop wrd1 s fs1 + | otherwise -> + final fs1 >>= yieldReinit jump + FL.Done b -> yieldReinit jump b + Skip s -> go SPEC idx wrd s fs + Stop -> + if withSep + then do + r <- final fs + skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone + else skip $ SplitOnSuffixSeqWordDone idx fs wrd + + stepOuter gst (SplitOnSuffixSeqWordLoop wrd0 st0 fs0) = + go SPEC wrd0 st0 fs0 + + where + + {-# INLINE go #-} + go !_ !wrd !st !fs = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let jump c = SplitOnSuffixSeqWordInit c s + wrd1 = addToWord wrd x + old = (wordMask .&. wrd) + `shiftR` (elemBits * (patLen - 1)) + r <- + if withSep + then fstep fs x + else fstep fs (toEnum $ fromIntegral old) + case r of + FL.Partial fs1 -> + if wrd1 .&. wordMask == wordPat + then final fs1 >>= yieldReinit jump + else go SPEC wrd1 s fs1 + FL.Done b -> yieldReinit jump b + Skip s -> go SPEC wrd s fs + Stop -> + if withSep + then do + r <- final fs + skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone + else skip $ SplitOnSuffixSeqWordDone patLen fs wrd + + ------------------------------- + -- General Pattern - Karp Rabin + ------------------------------- + + stepOuter gst (SplitOnSuffixSeqKRInit fs st0 mba) = do + res <- step (adaptState gst) st0 + case res of + Yield x s -> do + liftIO $ pokeAt 0 mba x + r <- if withSep then fstep fs x else return $ FL.Partial fs + case r of + FL.Partial fs1 -> + skip $ SplitOnSuffixSeqKRInit1 fs1 s mba + FL.Done b -> do + let jump c = SplitOnSuffixSeqKRInit c s mba + yieldReinit jump b + Skip s -> skip $ SplitOnSuffixSeqKRInit fs s mba + Stop -> final fs >> return Stop + + stepOuter gst (SplitOnSuffixSeqKRInit1 fs0 st0 mba) = do + go SPEC (SIZE_OF(a)) st0 fs0 + + where + + go !_ !offset st !fs = do + res <- step (adaptState gst) st + let arr :: Array a = Array + { arrContents = mba + , arrStart = 0 + , arrEnd = patBytes + } + case res of + Yield x s -> do + liftIO $ pokeAt offset mba x + r <- if withSep then fstep fs x else return $ FL.Partial fs + let ringHash = A.foldl' addCksum 0 arr + case r of + FL.Partial fs1 + | offset /= maxOffset -> + go SPEC (offset + SIZE_OF(a)) s fs1 + | ringHash == patHash -> + skip $ SplitOnSuffixSeqKRCheck fs1 s mba 0 + | otherwise -> + skip $ SplitOnSuffixSeqKRLoop + fs1 s mba 0 ringHash + FL.Done b -> do + let jump c = SplitOnSuffixSeqKRInit c s mba + yieldReinit jump b + Skip s -> go SPEC offset s fs + Stop -> do + -- do not issue a blank segment when we end at pattern + if offset == maxOffset && A.byteEq arr patArr + then final fs >> return Stop + else if withSep + then do + r <- final fs + skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone + else do + let rb = RingArray + { ringContents = mba + , ringSize = offset + , ringHead = 0 + } + in skip $ SplitOnSuffixSeqKRDone offset fs rb + + stepOuter gst (SplitOnSuffixSeqKRLoop fs0 st0 mba rh0 cksum0) = + go SPEC fs0 st0 rh0 cksum0 + + where + + go !_ !fs !st !rh !cksum = do + res <- step (adaptState gst) st + let rb = RingArray + { ringContents = mba + , ringSize = patBytes + , ringHead = rh + } + case res of + Yield x s -> do + (rb1, old) <- liftIO (RB.replace rb x) + let cksum1 = deltaCksum cksum old x + let rh1 = ringHead rb1 + r <- if withSep then fstep fs x else fstep fs old + case r of + FL.Partial fs1 -> + if cksum1 /= patHash + then go SPEC fs1 s rh1 cksum1 + else skip $ SplitOnSuffixSeqKRCheck fs1 s mba rh1 + FL.Done b -> do + let jump c = SplitOnSuffixSeqKRInit c s mba + yieldReinit jump b + Skip s -> go SPEC fs s rh cksum + Stop -> do + if withSep + then do + r <- final fs + skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone + else skip $ SplitOnSuffixSeqKRDone patBytes fs rb + + stepOuter _ (SplitOnSuffixSeqKRCheck fs st mba rh) = do + let rb = RingArray + { ringContents = mba + , ringSize = patBytes + , ringHead = rh + } + matches <- liftIO $ RB.eqArray rb patArr + if matches + then do + r <- final fs + let jump c = SplitOnSuffixSeqKRInit c st mba + yieldReinit jump r + else skip $ SplitOnSuffixSeqKRLoop fs st mba rh patHash + + stepOuter _ (SplitOnSuffixSeqKRDone 0 fs _) = do + r <- final fs + skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone + stepOuter _ (SplitOnSuffixSeqKRDone len fs rb) = do + assert (len >= 0) (return ()) + old <- RB.unsafeGetHead rb + let rb1 = RB.moveForward rb + r <- fstep fs old + case r of + FL.Partial fs1 -> + skip $ SplitOnSuffixSeqKRDone (len - SIZE_OF(a)) fs1 rb1 + FL.Done b -> do + let jump c = SplitOnSuffixSeqKRDone (len - SIZE_OF(a)) c rb1 + yieldReinit jump b + +-- | Parses a sequence of tokens suffixed by a separator e.g. @a;b;c;@ is +-- parsed as @a;@, @b;@, @c;@. If the pattern is empty the input stream is +-- returned as it is. +-- +-- Equivalent to the following: +-- +-- >>> splitEndBySeq pat f = Stream.foldMany (Fold.takeEndBySeq pat f) +-- +-- Usage: +-- +-- >>> f p = Stream.splitEndBySeq (Array.fromList p) Fold.toList +-- >>> splitEndBy p xs = Stream.fold Fold.toList $ f p (Stream.fromList xs) +-- +-- >>> splitEndBy "" "" +-- [] +-- +-- >>> splitEndBy "" "a...b" +-- ["a",".",".",".","b"] +-- +-- >>> splitEndBy ".." "" +-- [] +-- +-- +-- >>> splitEndBy ".." "a...b" +-- ["a..",".b"] +-- +-- +-- >>> splitEndBy ".." "abc" +-- ["abc"] +-- +-- >>> splitEndBy ".." ".." +-- [".."] +-- +-- >>> splitEndBy "." ".a" +-- [".","a"] +-- +-- >>> splitEndBy "." "a." +-- ["a."] +-- +-- Uses Rabin-Karp algorithm for substring search. +-- +{-# INLINE_NORMAL splitEndBySeq #-} +splitEndBySeq + :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) + => Array a + -> Fold m a b + -> Stream m a + -> Stream m b +splitEndBySeq = splitOnSuffixSeq True + +-- | Like 'splitEndBySeq' but drops the separators and returns only the tokens. +-- +-- Equivalent to the following: +-- +-- >>> splitEndBySeq_ pat f = Stream.foldMany (Fold.takeEndBySeq_ pat f) +-- +-- Usage: +-- +-- >>> f p = Stream.splitEndBySeq_ (Array.fromList p) Fold.toList +-- >>> splitEndBy_ p xs = Stream.fold Fold.toList $ f p (Stream.fromList xs) +-- +-- >>> splitEndBy_ "" "" +-- [] +-- +-- >>> splitEndBy_ "" "a...b" +-- ["a",".",".",".","b"] +-- +-- >>> splitEndBy_ ".." "" +-- [] +-- +-- >>> splitEndBy_ ".." "a...b" +-- ["a",".b"] +-- +-- >>> splitEndBy_ ".." "abc" +-- ["abc"] +-- +-- >>> splitEndBy_ ".." ".." +-- [""] +-- +-- >>> splitEndBy_ "." ".a" +-- ["","a"] +-- +-- >>> splitEndBy_ "." "a." +-- ["a"] +-- +-- Uses Rabin-Karp algorithm for substring search. +-- +{-# INLINE_NORMAL splitEndBySeq_ #-} +splitEndBySeq_ + :: forall m a b. (MonadIO m, Unbox a, Enum a, Eq a) + => Array a + -> Fold m a b + -> Stream m a + -> Stream m b +splitEndBySeq_ = splitOnSuffixSeq False + +-- Implement this as a fold or a parser instead. +-- This can be implemented easily using Rabin Karp + +-- | Split post any one of the given patterns. +-- +-- /Unimplemented/ +{-# INLINE splitEndBySeqOneOf #-} +splitEndBySeqOneOf :: -- (Monad m, Unboxed a, Integral a) => + [Array a] -> Fold m a b -> Stream m a -> Stream m b +splitEndBySeqOneOf _subseq _f _m = undefined + +-- | Split on a prefixed separator element, dropping the separator. The +-- supplied 'Fold' is applied on the split segments. +-- +-- @ +-- > splitOnPrefix' p xs = Stream.toList $ Stream.splitOnPrefix p (Fold.toList) (Stream.fromList xs) +-- > splitOnPrefix' (== '.') ".a.b" +-- ["a","b"] +-- @ +-- +-- An empty stream results in an empty output stream: +-- @ +-- > splitOnPrefix' (== '.') "" +-- [] +-- @ +-- +-- An empty segment consisting of only a prefix is folded to the default output +-- of the fold: +-- +-- @ +-- > splitOnPrefix' (== '.') "." +-- [""] +-- +-- > splitOnPrefix' (== '.') ".a.b." +-- ["a","b",""] +-- +-- > splitOnPrefix' (== '.') ".a..b" +-- ["a","","b"] +-- +-- @ +-- +-- A prefix is optional at the beginning of the stream: +-- +-- @ +-- > splitOnPrefix' (== '.') "a" +-- ["a"] +-- +-- > splitOnPrefix' (== '.') "a.b" +-- ["a","b"] +-- @ +-- +-- 'splitOnPrefix' is an inverse of 'intercalatePrefix' with a single element: +-- +-- > Stream.intercalatePrefix (Stream.fromPure '.') Unfold.fromList . Stream.splitOnPrefix (== '.') Fold.toList === id +-- +-- Assuming the input stream does not contain the separator: +-- +-- > Stream.splitOnPrefix (== '.') Fold.toList . Stream.intercalatePrefix (Stream.fromPure '.') Unfold.fromList === id +-- +-- /Unimplemented/ +{-# INLINE splitBeginBy_ #-} +splitBeginBy_ :: -- (MonadCatch m) => + (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +splitBeginBy_ _predicate _f = undefined + -- parseMany (Parser.sliceBeginBy predicate f) + +-- Int list examples for splitOn: +-- +-- >>> splitList [] [1,2,3,3,4] +-- > [[1],[2],[3],[3],[4]] +-- +-- >>> splitList [5] [1,2,3,3,4] +-- > [[1,2,3,3,4]] +-- +-- >>> splitList [1] [1,2,3,3,4] +-- > [[],[2,3,3,4]] +-- +-- >>> splitList [4] [1,2,3,3,4] +-- > [[1,2,3,3],[]] +-- +-- >>> splitList [2] [1,2,3,3,4] +-- > [[1],[3,3,4]] +-- +-- >>> splitList [3] [1,2,3,3,4] +-- > [[1,2],[],[4]] +-- +-- >>> splitList [3,3] [1,2,3,3,4] +-- > [[1,2],[4]] +-- +-- >>> splitList [1,2,3,3,4] [1,2,3,3,4] +-- > [[],[]] + +-- This can be implemented easily using Rabin Karp +-- | Split on any one of the given patterns. +-- +-- /Unimplemented/ +-- +{-# INLINE splitSepBySeqOneOf #-} +splitSepBySeqOneOf :: -- (Monad m, Unboxed a, Integral a) => + [Array a] -> Fold m a b -> Stream m a -> Stream m b +splitSepBySeqOneOf _subseq _f _m = + undefined -- D.fromStreamD $ D.splitOnAny f subseq (D.toStreamD m) + +------------------------------------------------------------------------------ +-- Nested Container Transformation +------------------------------------------------------------------------------ + +{-# ANN type SplitState Fuse #-} +data SplitState s arr + = SplitInitial s + | SplitBuffering s arr + | SplitSplitting s arr + | SplitYielding arr (SplitState s arr) + | SplitFinishing + +-- XXX An alternative approach would be to use a partial fold (Fold m a b) to +-- split using a splitBy like combinator. The Fold would consume upto the +-- separator and return any leftover which can then be fed to the next fold. +-- +-- We can revisit this once we have partial folds/parsers. +-- +-- | Performs infix separator style splitting. +{-# INLINE_NORMAL splitInnerBy #-} +splitInnerBy + :: Monad m + => (f a -> m (f a, Maybe (f a))) -- splitter + -> (f a -> f a -> m (f a)) -- joiner + -> Stream m (f a) + -> Stream m (f a) +splitInnerBy splitter joiner (Stream step1 state1) = + Stream step (SplitInitial state1) + + where + + {-# INLINE_LATE step #-} + step gst (SplitInitial st) = do + r <- step1 gst st + case r of + Yield x s -> do + (x1, mx2) <- splitter x + return $ case mx2 of + Nothing -> Skip (SplitBuffering s x1) + Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2)) + Skip s -> return $ Skip (SplitInitial s) + Stop -> return Stop + + step gst (SplitBuffering st buf) = do + r <- step1 gst st + case r of + Yield x s -> do + (x1, mx2) <- splitter x + buf' <- joiner buf x1 + return $ case mx2 of + Nothing -> Skip (SplitBuffering s buf') + Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2)) + Skip s -> return $ Skip (SplitBuffering s buf) + Stop -> return $ Skip (SplitYielding buf SplitFinishing) + + step _ (SplitSplitting st buf) = do + (x1, mx2) <- splitter buf + return $ case mx2 of + Nothing -> Skip $ SplitBuffering st x1 + Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2) + + step _ (SplitYielding x next) = return $ Yield x next + step _ SplitFinishing = return Stop + +-- | Performs infix separator style splitting. +{-# INLINE_NORMAL splitInnerBySuffix #-} +splitInnerBySuffix + :: Monad m + => (f a -> Bool) -- isEmpty? + -> (f a -> m (f a, Maybe (f a))) -- splitter + -> (f a -> f a -> m (f a)) -- joiner + -> Stream m (f a) + -> Stream m (f a) +splitInnerBySuffix isEmpty splitter joiner (Stream step1 state1) = + Stream step (SplitInitial state1) + + where + + {-# INLINE_LATE step #-} + step gst (SplitInitial st) = do + r <- step1 gst st + case r of + Yield x s -> do + (x1, mx2) <- splitter x + return $ case mx2 of + Nothing -> Skip (SplitBuffering s x1) + Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2)) + Skip s -> return $ Skip (SplitInitial s) + Stop -> return Stop + + step gst (SplitBuffering st buf) = do + r <- step1 gst st + case r of + Yield x s -> do + (x1, mx2) <- splitter x + buf' <- joiner buf x1 + return $ case mx2 of + Nothing -> Skip (SplitBuffering s buf') + Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2)) + Skip s -> return $ Skip (SplitBuffering s buf) + Stop -> + return $ + if isEmpty buf + then Stop + else Skip (SplitYielding buf SplitFinishing) + + step _ (SplitSplitting st buf) = do + (x1, mx2) <- splitter buf + return $ case mx2 of + Nothing -> Skip $ SplitBuffering st x1 + Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2) + + step _ (SplitYielding x next) = return $ Yield x next + step _ SplitFinishing = return Stop + +------------------------------------------------------------------------------ +-- Trimming +------------------------------------------------------------------------------ + +-- | Drop prefix from the input stream if present. +-- +-- Space: @O(1)@ +-- +-- See also stripPrefix. +-- +-- /Unimplemented/ +{-# INLINE dropPrefix #-} +dropPrefix :: + -- (Monad m, Eq a) => + Stream m a -> Stream m a -> Stream m a +dropPrefix = error "Not implemented yet!" + +-- | Drop all matching infix from the input stream if present. Infix stream +-- may be consumed multiple times. +-- +-- Space: @O(n)@ where n is the length of the infix. +-- +-- See also stripInfix. +-- +-- /Unimplemented/ +{-# INLINE dropInfix #-} +dropInfix :: + -- (Monad m, Eq a) => + Stream m a -> Stream m a -> Stream m a +dropInfix = error "Not implemented yet!" + +-- | Drop suffix from the input stream if present. Suffix stream may be +-- consumed multiple times. +-- +-- Space: @O(n)@ where n is the length of the suffix. +-- +-- See also stripSuffix. +-- +-- /Unimplemented/ +{-# INLINE dropSuffix #-} +dropSuffix :: + -- (Monad m, Eq a) => + Stream m a -> Stream m a -> Stream m a +dropSuffix = error "Not implemented yet!" diff --git a/src/Streamly/Internal/Data/Stream/Reduce.hs b/src/Streamly/Internal/Data/Stream/Reduce.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Reduce.hs +++ /dev/null @@ -1,444 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Reduce --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Reduce streams by streams, folds or parsers. - -module Streamly.Internal.Data.Stream.Reduce - ( - -- * Reduce By Streams - dropPrefix - , dropInfix - , dropSuffix - - -- * Reduce By Folds - -- | - -- Reduce a stream by folding or parsing chunks of the stream. Functions - -- generally ending in these shapes: - -- - -- @ - -- f (Fold m a b) -> Stream m a -> Stream m b - -- f (Parser a m b) -> Stream m a -> Stream m b - -- @ - - -- ** Generic Folding - -- | Apply folds on a stream. - , foldMany - , foldManyPost - , refoldMany - , foldSequence - , foldIterateM - , refoldIterateM - , reduceIterateBfs - - -- ** Chunking - -- | Element unaware grouping. - , chunksOf - - -- ** Splitting - -- XXX Implement these as folds or parsers instead. - , splitOnSuffixSeqAny - , splitOnPrefix - , splitOnAny - - -- * Reduce By Parsers - -- ** Generic Parsing - -- | Apply parsers on a stream. - , parseMany - , parseManyD - , parseManyTill - , parseSequence - , parseIterate - - ) -where - -import Control.Monad.IO.Class (MonadIO(..)) -import Streamly.Internal.Data.Array.Type (Array) -import Streamly.Internal.Data.Fold.Type (Fold (..)) -import Streamly.Internal.Data.Parser (Parser (..)) -import Streamly.Internal.Data.Parser.ParserD (ParseError) -import Streamly.Internal.Data.Refold.Type (Refold (..)) -import Streamly.Internal.Data.Stream.Bottom (foldManyPost) -import Streamly.Internal.Data.Stream.Type (Stream, fromStreamD, toStreamD) -import Streamly.Internal.Data.Unboxed (Unbox) - -import qualified Streamly.Internal.Data.Array.Type as Array -import qualified Streamly.Internal.Data.Parser.ParserD as ParserD -import qualified Streamly.Internal.Data.Stream.StreamD as D - -import Prelude hiding (concatMap, map) - --- $setup --- >>> :m --- >>> import Prelude hiding (zipWith, concatMap, concat) --- >>> import Streamly.Internal.Data.Stream as Stream --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Internal.Data.Fold as Fold --- >>> import qualified Streamly.Internal.Data.Unfold as Unfold --- >>> import qualified Streamly.Internal.Data.Parser as Parser --- >>> import qualified Streamly.Data.Array as Array - ------------------------------------------------------------------------------- --- Trimming ------------------------------------------------------------------------------- - --- | Drop prefix from the input stream if present. --- --- Space: @O(1)@ --- --- /Unimplemented/ -{-# INLINE dropPrefix #-} -dropPrefix :: - -- (Monad m, Eq a) => - Stream m a -> Stream m a -> Stream m a -dropPrefix = error "Not implemented yet!" - --- | Drop all matching infix from the input stream if present. Infix stream --- may be consumed multiple times. --- --- Space: @O(n)@ where n is the length of the infix. --- --- /Unimplemented/ -{-# INLINE dropInfix #-} -dropInfix :: - -- (Monad m, Eq a) => - Stream m a -> Stream m a -> Stream m a -dropInfix = error "Not implemented yet!" - --- | Drop suffix from the input stream if present. Suffix stream may be --- consumed multiple times. --- --- Space: @O(n)@ where n is the length of the suffix. --- --- /Unimplemented/ -{-# INLINE dropSuffix #-} -dropSuffix :: - -- (Monad m, Eq a) => - Stream m a -> Stream m a -> Stream m a -dropSuffix = error "Not implemented yet!" - ------------------------------------------------------------------------------- --- Folding ------------------------------------------------------------------------------- - --- | Apply a 'Fold' repeatedly on a stream and emit the results in the --- output stream. Unlike 'foldManyPost' it evaluates the fold after the stream, --- therefore, an empty input stream results in an empty output stream. --- --- Definition: --- --- >>> foldMany f = Stream.parseMany (Parser.fromFold f) --- --- Example, empty stream: --- --- >>> f = Fold.take 2 Fold.sum --- >>> fmany = Stream.fold Fold.toList . Stream.foldMany f --- >>> fmany $ Stream.fromList [] --- [] --- --- Example, last fold empty: --- --- >>> fmany $ Stream.fromList [1..4] --- [3,7] --- --- Example, last fold non-empty: --- --- >>> fmany $ Stream.fromList [1..5] --- [3,7,5] --- --- Note that using a closed fold e.g. @Fold.take 0@, would result in an --- infinite stream on a non-empty input stream. --- -{-# INLINE foldMany #-} -foldMany - :: Monad m - => Fold m a b - -> Stream m a - -> Stream m b -foldMany f m = fromStreamD $ D.foldMany f (toStreamD m) - --- | Like 'foldMany' but using the 'Refold' type instead of 'Fold'. --- --- /Pre-release/ -{-# INLINE refoldMany #-} -refoldMany :: Monad m => - Refold m c a b -> m c -> Stream m a -> Stream m b -refoldMany f action = fromStreamD . D.refoldMany f action . toStreamD - --- | Apply a stream of folds to an input stream and emit the results in the --- output stream. --- --- /Unimplemented/ --- -{-# INLINE foldSequence #-} -foldSequence - :: -- Monad m => - Stream m (Fold m a b) - -> Stream m a - -> Stream m b -foldSequence _f _m = undefined - --- | Iterate a fold generator on a stream. The initial value @b@ is used to --- generate the first fold, the fold is applied on the stream and the result of --- the fold is used to generate the next fold and so on. --- --- >>> import Data.Monoid (Sum(..)) --- >>> f x = return (Fold.take 2 (Fold.sconcat x)) --- >>> s = fmap Sum $ Stream.fromList [1..10] --- >>> Stream.fold Fold.toList $ fmap getSum $ Stream.foldIterateM f (pure 0) s --- [3,10,21,36,55,55] --- --- This is the streaming equivalent of monad like sequenced application of --- folds where next fold is dependent on the previous fold. --- --- /Pre-release/ --- -{-# INLINE foldIterateM #-} -foldIterateM :: - Monad m => (b -> m (Fold m a b)) -> m b -> Stream m a -> Stream m b -foldIterateM f i m = fromStreamD $ D.foldIterateM f i (toStreamD m) - --- | Like 'foldIterateM' but using the 'Refold' type instead. This could be --- much more efficient due to stream fusion. --- --- /Internal/ -{-# INLINE refoldIterateM #-} -refoldIterateM :: Monad m => - Refold m b a b -> m b -> Stream m a -> Stream m b -refoldIterateM c i m = fromStreamD $ D.refoldIterateM c i (toStreamD m) - --- | Binary BFS style reduce, folds a level entirely using the supplied fold --- function, collecting the outputs as next level of the tree, then repeats the --- same process on the next level. The last elements of a previously folded --- level are folded first. -{-# INLINE reduceIterateBfs #-} -reduceIterateBfs :: Monad m => - (a -> a -> m a) -> Stream m a -> m (Maybe a) -reduceIterateBfs f stream = D.reduceIterateBfs f (toStreamD stream) - ------------------------------------------------------------------------------- --- Splitting ------------------------------------------------------------------------------- - --- Implement this as a fold or a parser instead. --- This can be implemented easily using Rabin Karp --- | Split post any one of the given patterns. --- --- /Unimplemented/ -{-# INLINE splitOnSuffixSeqAny #-} -splitOnSuffixSeqAny :: -- (Monad m, Unboxed a, Integral a) => - [Array a] -> Fold m a b -> Stream m a -> Stream m b -splitOnSuffixSeqAny _subseq _f _m = undefined - -- D.fromStreamD $ D.splitPostAny f subseq (D.toStreamD m) - --- | Split on a prefixed separator element, dropping the separator. The --- supplied 'Fold' is applied on the split segments. --- --- @ --- > splitOnPrefix' p xs = Stream.toList $ Stream.splitOnPrefix p (Fold.toList) (Stream.fromList xs) --- > splitOnPrefix' (== '.') ".a.b" --- ["a","b"] --- @ --- --- An empty stream results in an empty output stream: --- @ --- > splitOnPrefix' (== '.') "" --- [] --- @ --- --- An empty segment consisting of only a prefix is folded to the default output --- of the fold: --- --- @ --- > splitOnPrefix' (== '.') "." --- [""] --- --- > splitOnPrefix' (== '.') ".a.b." --- ["a","b",""] --- --- > splitOnPrefix' (== '.') ".a..b" --- ["a","","b"] --- --- @ --- --- A prefix is optional at the beginning of the stream: --- --- @ --- > splitOnPrefix' (== '.') "a" --- ["a"] --- --- > splitOnPrefix' (== '.') "a.b" --- ["a","b"] --- @ --- --- 'splitOnPrefix' is an inverse of 'intercalatePrefix' with a single element: --- --- > Stream.intercalatePrefix (Stream.fromPure '.') Unfold.fromList . Stream.splitOnPrefix (== '.') Fold.toList === id --- --- Assuming the input stream does not contain the separator: --- --- > Stream.splitOnPrefix (== '.') Fold.toList . Stream.intercalatePrefix (Stream.fromPure '.') Unfold.fromList === id --- --- /Unimplemented/ -{-# INLINE splitOnPrefix #-} -splitOnPrefix :: -- (IsStream t, MonadCatch m) => - (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b -splitOnPrefix _predicate _f = undefined - -- parseMany (Parser.sliceBeginBy predicate f) - --- Int list examples for splitOn: --- --- >>> splitList [] [1,2,3,3,4] --- > [[1],[2],[3],[3],[4]] --- --- >>> splitList [5] [1,2,3,3,4] --- > [[1,2,3,3,4]] --- --- >>> splitList [1] [1,2,3,3,4] --- > [[],[2,3,3,4]] --- --- >>> splitList [4] [1,2,3,3,4] --- > [[1,2,3,3],[]] --- --- >>> splitList [2] [1,2,3,3,4] --- > [[1],[3,3,4]] --- --- >>> splitList [3] [1,2,3,3,4] --- > [[1,2],[],[4]] --- --- >>> splitList [3,3] [1,2,3,3,4] --- > [[1,2],[4]] --- --- >>> splitList [1,2,3,3,4] [1,2,3,3,4] --- > [[],[]] - --- This can be implemented easily using Rabin Karp --- | Split on any one of the given patterns. --- --- /Unimplemented/ --- -{-# INLINE splitOnAny #-} -splitOnAny :: -- (Monad m, Unboxed a, Integral a) => - [Array a] -> Fold m a b -> Stream m a -> Stream m b -splitOnAny _subseq _f _m = - undefined -- D.fromStreamD $ D.splitOnAny f subseq (D.toStreamD m) - ------------------------------------------------------------------------------- --- Parsing ------------------------------------------------------------------------------- - --- | Apply a 'Parser' repeatedly on a stream and emit the parsed values in the --- output stream. --- --- Example: --- --- >>> s = Stream.fromList [1..10] --- >>> parser = Parser.takeBetween 0 2 Fold.sum --- >>> Stream.fold Fold.toList $ Stream.parseMany parser s --- [Right 3,Right 7,Right 11,Right 15,Right 19] --- --- This is the streaming equivalent of the 'Streamly.Data.Parser.many' parse --- combinator. --- --- Known Issues: When the parser fails there is no way to get the remaining --- stream. --- -{-# INLINE parseMany #-} -parseMany - :: Monad m - => Parser a m b - -> Stream m a - -> Stream m (Either ParseError b) -parseMany p m = - fromStreamD $ D.parseManyD p (toStreamD m) - --- | Same as parseMany but for StreamD streams. --- --- /Internal/ --- -{-# INLINE parseManyD #-} -parseManyD - :: Monad m - => ParserD.Parser a m b - -> Stream m a - -> Stream m (Either ParseError b) -parseManyD p m = - fromStreamD $ D.parseManyD p (toStreamD m) - --- | Apply a stream of parsers to an input stream and emit the results in the --- output stream. --- --- /Unimplemented/ --- -{-# INLINE parseSequence #-} -parseSequence - :: -- Monad m => - Stream m (Parser a m b) - -> Stream m a - -> Stream m b -parseSequence _f _m = undefined - --- XXX Change the parser arguments' order - --- | @parseManyTill collect test stream@ tries the parser @test@ on the input, --- if @test@ fails it backtracks and tries @collect@, after @collect@ succeeds --- @test@ is tried again and so on. The parser stops when @test@ succeeds. The --- output of @test@ is discarded and the output of @collect@ is emitted in the --- output stream. The parser fails if @collect@ fails. --- --- /Unimplemented/ --- -{-# INLINE parseManyTill #-} -parseManyTill :: - -- MonadThrow m => - Parser a m b - -> Parser a m x - -> t m a - -> t m b -parseManyTill = undefined - --- | Iterate a parser generating function on a stream. The initial value @b@ is --- used to generate the first parser, the parser is applied on the stream and --- the result is used to generate the next parser and so on. --- --- >>> import Data.Monoid (Sum(..)) --- >>> s = Stream.fromList [1..10] --- >>> Stream.fold Fold.toList $ fmap getSum $ Stream.catRights $ Stream.parseIterate (\b -> Parser.takeBetween 0 2 (Fold.sconcat b)) (Sum 0) $ fmap Sum s --- [3,10,21,36,55,55] --- --- This is the streaming equivalent of monad like sequenced application of --- parsers where next parser is dependent on the previous parser. --- --- /Pre-release/ --- -{-# INLINE parseIterate #-} -parseIterate - :: Monad m - => (b -> Parser a m b) - -> b - -> Stream m a - -> Stream m (Either ParseError b) -parseIterate f i m = fromStreamD $ - D.parseIterateD f i (toStreamD m) - ------------------------------------------------------------------------------- --- Chunking ------------------------------------------------------------------------------- - --- | @chunksOf n stream@ groups the elements in the input stream into arrays of --- @n@ elements each. --- --- Same as the following but may be more efficient: --- --- >>> chunksOf n = Stream.foldMany (Array.writeN n) --- --- /Pre-release/ -{-# INLINE chunksOf #-} -chunksOf :: (MonadIO m, Unbox a) - => Int -> Stream m a -> Stream m (Array a) -chunksOf n = fromStreamD . Array.chunksOf n . toStreamD diff --git a/src/Streamly/Internal/Data/Stream/Step.hs b/src/Streamly/Internal/Data/Stream/Step.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Step.hs @@ -0,0 +1,39 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Step +-- Copyright : (c) 2018 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Stream.Step + ( + -- * The stream type + Step (..) + ) +where + +import Fusion.Plugin.Types (Fuse(..)) + +-- | A stream is a succession of 'Step's. A 'Yield' produces a single value and +-- the next state of the stream. 'Stop' indicates there are no more values in +-- the stream. +{-# ANN type Step Fuse #-} +data Step s a = Yield a s | Skip s | Stop + +instance Functor (Step s) where + {-# INLINE fmap #-} + fmap f (Yield x s) = Yield (f x) s + fmap _ (Skip s) = Skip s + fmap _ Stop = Stop + +{- +fromPure :: Monad m => a -> s -> m (Step s a) +fromPure a = return . Yield a + +skip :: Monad m => s -> m (Step s a) +skip = return . Skip + +stop :: Monad m => m (Step s a) +stop = return Stop +-} diff --git a/src/Streamly/Internal/Data/Stream/StreamD.hs b/src/Streamly/Internal/Data/Stream/StreamD.hs --- a/src/Streamly/Internal/Data/Stream/StreamD.hs +++ b/src/Streamly/Internal/Data/Stream/StreamD.hs @@ -5,38 +5,12 @@ -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC --- --- Direct style re-implementation of CPS stream in --- "Streamly.Internal.Data.Stream.StreamK". The symbol or suffix 'D' in this --- module denotes the "Direct" style. GHC is able to INLINE and fuse direct --- style better, providing better performance than CPS implementation. --- --- @ --- import qualified Streamly.Internal.Data.Stream.StreamD as D --- @ module Streamly.Internal.Data.Stream.StreamD +{-# DEPRECATED "Please use \"Streamly.Internal.Data.Stream\" instead." #-} ( - module Streamly.Internal.Data.Stream.StreamD.Type - , module Streamly.Internal.Data.Stream.StreamD.Generate - , module Streamly.Internal.Data.Stream.StreamD.Eliminate - , module Streamly.Internal.Data.Stream.StreamD.Exception - , module Streamly.Internal.Data.Stream.StreamD.Lift - , module Streamly.Internal.Data.Stream.StreamD.Transformer - , module Streamly.Internal.Data.Stream.StreamD.Nesting - , module Streamly.Internal.Data.Stream.StreamD.Transform - , module Streamly.Internal.Data.Stream.StreamD.Top - , module Streamly.Internal.Data.Stream.StreamD.Container + module Streamly.Internal.Data.Stream ) where -import Streamly.Internal.Data.Stream.StreamD.Type -import Streamly.Internal.Data.Stream.StreamD.Generate -import Streamly.Internal.Data.Stream.StreamD.Eliminate -import Streamly.Internal.Data.Stream.StreamD.Exception -import Streamly.Internal.Data.Stream.StreamD.Lift -import Streamly.Internal.Data.Stream.StreamD.Transformer -import Streamly.Internal.Data.Stream.StreamD.Nesting -import Streamly.Internal.Data.Stream.StreamD.Transform -import Streamly.Internal.Data.Stream.StreamD.Top -import Streamly.Internal.Data.Stream.StreamD.Container +import Streamly.Internal.Data.Stream diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Container.hs b/src/Streamly/Internal/Data/Stream/StreamD/Container.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Container.hs +++ /dev/null @@ -1,302 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Container --- Copyright : (c) 2019 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Stream operations that require transformers or containers like Set or Map. - -module Streamly.Internal.Data.Stream.StreamD.Container - ( - nub - - -- * Joins for unconstrained types - , joinLeftGeneric - , joinOuterGeneric - - -- * Joins with Ord constraint - , joinInner - , joinLeft - , joinOuter - ) -where - -#include "inline.hs" - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.State.Strict (get, put) -import Data.Function ((&)) -import Data.Maybe (isJust) -import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) -import Streamly.Internal.Data.Stream.StreamD.Type - (Stream(..), mkCross, unCross) - -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Streamly.Data.Fold as Fold -import qualified Streamly.Internal.Data.Array.Generic as Array -import qualified Streamly.Internal.Data.Array.Mut.Type as MA -import qualified Streamly.Internal.Data.Stream.StreamD.Type as Stream -import qualified Streamly.Internal.Data.Stream.StreamD.Nesting as Stream -import qualified Streamly.Internal.Data.Stream.StreamD.Generate as Stream -import qualified Streamly.Internal.Data.Stream.StreamD.Transform as Stream -import qualified Streamly.Internal.Data.Stream.StreamD.Transformer as Stream - -#include "DocTestDataStream.hs" - --- | The memory used is proportional to the number of unique elements in the --- stream. If we want to limit the memory we can just use "take" to limit the --- uniq elements in the stream. -{-# INLINE_NORMAL nub #-} -nub :: (Monad m, Ord a) => Stream m a -> Stream m a -nub (Stream step1 state1) = Stream step (Set.empty, state1) - - where - - step gst (set, st) = do - r <- step1 gst st - return - $ case r of - Yield x s -> - if Set.member x set - then Skip (set, s) - else Yield x (Set.insert x set, s) - Skip s -> Skip (set, s) - Stop -> Stop - --- XXX Generate error if a duplicate insertion is attempted? -toMap :: (Monad m, Ord k) => Stream m (k, v) -> m (Map.Map k v) -toMap = - let f = Fold.foldl' (\kv (k, b) -> Map.insert k b kv) Map.empty - in Stream.fold f - --- If the second stream is too big it can be partitioned based on hashes and --- then we can process one parition at a time. --- --- XXX An IntMap may be faster when the keys are Int. --- XXX Use hashmap instead of map? --- --- | Like 'joinInner' but uses a 'Map' for efficiency. --- --- If the input streams have duplicate keys, the behavior is undefined. --- --- For space efficiency use the smaller stream as the second stream. --- --- Space: O(n) --- --- Time: O(m + n) --- --- /Pre-release/ -{-# INLINE joinInner #-} -joinInner :: (Monad m, Ord k) => - Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, b) -joinInner s1 s2 = - Stream.concatEffect $ do - km <- toMap s2 - pure $ Stream.mapMaybe (joinAB km) s1 - - where - - joinAB kvm (k, a) = - case k `Map.lookup` kvm of - Just b -> Just (k, a, b) - Nothing -> Nothing - --- XXX We can do this concurrently. --- XXX If the second stream is sorted and passed as an Array or a seek capable --- stream then we could use binary search if we have an Ord instance or --- Ordering returning function. The time complexity would then become (m x log --- n). - --- XXX Check performance of StreamD vs StreamK - --- | Like 'joinInner' but emit @(a, Just b)@, and additionally, for those @a@'s --- that are not equal to any @b@ emit @(a, Nothing)@. --- --- The second stream is evaluated multiple times. If the stream is a --- consume-once stream then the caller should cache it in an 'Data.Array.Array' --- before calling this function. Caching may also improve performance if the --- stream is expensive to evaluate. --- --- >>> joinRightGeneric eq = flip (Stream.joinLeftGeneric eq) --- --- Space: O(n) assuming the second stream is cached in memory. --- --- Time: O(m x n) --- --- /Unimplemented/ -{-# INLINE joinLeftGeneric #-} -joinLeftGeneric :: Monad m => - (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) -joinLeftGeneric eq s1 s2 = Stream.evalStateT (return False) $ unCross $ do - a <- mkCross (Stream.liftInner s1) - -- XXX should we use StreamD monad here? - -- XXX Is there a better way to perform some action at the end of a loop - -- iteration? - mkCross (Stream.fromEffect $ put False) - let final = Stream.concatEffect $ do - r <- get - if r - then pure Stream.nil - else pure (Stream.fromPure Nothing) - b <- mkCross (fmap Just (Stream.liftInner s2) `Stream.append` final) - case b of - Just b1 -> - if a `eq` b1 - then do - mkCross (Stream.fromEffect $ put True) - return (a, Just b1) - else mkCross Stream.nil - Nothing -> return (a, Nothing) - --- XXX rename to joinLeftOrd? - --- | A more efficient 'joinLeft' using a hashmap for efficiency. --- --- Space: O(n) --- --- Time: O(m + n) --- --- /Pre-release/ -{-# INLINE joinLeft #-} -joinLeft :: (Ord k, Monad m) => - Stream m (k, a) -> Stream m (k, b) -> Stream m (k, a, Maybe b) -joinLeft s1 s2 = - Stream.concatEffect $ do - km <- toMap s2 - return $ fmap (joinAB km) s1 - - where - - joinAB km (k, a) = - case k `Map.lookup` km of - Just b -> (k, a, Just b) - Nothing -> (k, a, Nothing) - --- XXX We can do this concurrently. - --- XXX Check performance of StreamD vs StreamK - --- | Like 'joinLeft' but emits a @(Just a, Just b)@. Like 'joinLeft', for those --- @a@'s that are not equal to any @b@ emit @(Just a, Nothing)@, but --- additionally, for those @b@'s that are not equal to any @a@ emit @(Nothing, --- Just b)@. --- --- For space efficiency use the smaller stream as the second stream. --- --- Space: O(n) --- --- Time: O(m x n) --- --- /Pre-release/ -{-# INLINE joinOuterGeneric #-} -joinOuterGeneric :: MonadIO m => - (a -> b -> Bool) - -> Stream m a - -> Stream m b - -> Stream m (Maybe a, Maybe b) -joinOuterGeneric eq s1 s = - Stream.concatEffect $ do - inputArr <- Array.fromStream s - let len = Array.length inputArr - foundArr <- - Stream.fold - (MA.writeN len) - (Stream.fromList (Prelude.replicate len False)) - return $ go inputArr foundArr `Stream.append` leftOver inputArr foundArr - - where - - leftOver inputArr foundArr = - let stream1 = Array.read inputArr - stream2 = Stream.unfold MA.reader foundArr - in Stream.filter - isJust - ( Stream.zipWith (\x y -> - if y - then Nothing - else Just (Nothing, Just x) - ) stream1 stream2 - ) & Stream.catMaybes - - evalState = Stream.evalStateT (return False) . unCross - - go inputArr foundArr = evalState $ do - a <- mkCross (Stream.liftInner s1) - -- XXX should we use StreamD monad here? - -- XXX Is there a better way to perform some action at the end of a loop - -- iteration? - mkCross (Stream.fromEffect $ put False) - let final = Stream.concatEffect $ do - r <- get - if r - then pure Stream.nil - else pure (Stream.fromPure Nothing) - (i, b) <- - let stream = Array.read inputArr - in mkCross - (Stream.indexed $ fmap Just (Stream.liftInner stream) `Stream.append` final) - - case b of - Just b1 -> - if a `eq` b1 - then do - mkCross (Stream.fromEffect $ put True) - MA.putIndex i foundArr True - return (Just a, Just b1) - else mkCross Stream.nil - Nothing -> return (Just a, Nothing) - --- Put the b's that have been paired, in another hash or mutate the hash to set --- a flag. At the end go through @Stream m b@ and find those that are not in that --- hash to return (Nothing, b). - --- | Like 'joinOuter' but uses a 'Map' for efficiency. --- --- Space: O(m + n) --- --- Time: O(m + n) --- --- /Pre-release/ -{-# INLINE joinOuter #-} -joinOuter :: - (Ord k, MonadIO m) => - Stream m (k, a) -> Stream m (k, b) -> Stream m (k, Maybe a, Maybe b) -joinOuter s1 s2 = - Stream.concatEffect $ do - km1 <- kvFold s1 - km2 <- kvFold s2 - - -- XXX Not sure if toList/fromList would fuse optimally. We may have to - -- create a fused Map.toStream function. - let res1 = fmap (joinAB km2) - $ Stream.fromList $ Map.toList km1 - where - joinAB km (k, a) = - case k `Map.lookup` km of - Just b -> (k, Just a, Just b) - Nothing -> (k, Just a, Nothing) - - -- XXX We can take advantage of the lookups in the first pass above to - -- reduce the number of lookups in this pass. If we keep mutable cells - -- in the second Map, we can flag it in the first pass and not do any - -- lookup in the second pass if it is flagged. - let res2 = Stream.mapMaybe (joinAB km1) - $ Stream.fromList $ Map.toList km2 - where - joinAB km (k, b) = - case k `Map.lookup` km of - Just _ -> Nothing - Nothing -> Just (k, Nothing, Just b) - - return $ Stream.append res1 res2 - - where - - -- XXX Generate error if a duplicate insertion is attempted? - kvFold = - let f = Fold.foldl' (\kv (k, b) -> Map.insert k b kv) Map.empty - in Stream.fold f diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs b/src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs +++ /dev/null @@ -1,833 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Eliminate --- Copyright : (c) 2018 Composewell Technologies --- (c) Roman Leshchinskiy 2008-2010 --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - --- A few functions in this module have been adapted from the vector package --- (c) Roman Leshchinskiy. --- -module Streamly.Internal.Data.Stream.StreamD.Eliminate - ( - -- * Running a 'Fold' - fold - - -- -- * Running a 'Parser' - , parse - , parseD - , parseBreak - , parseBreakD - - -- * Stream Deconstruction - , uncons - - -- * Right Folds - , foldrM - , foldr - , foldrMx - , foldr1 - - -- * Left Folds - , foldlM' - , foldl' - , foldlMx' - , foldlx' - - -- * Specific Fold Functions - , drain - , mapM_ -- Map and Fold - , null - , head - , headElse - , tail - , last - , elem - , notElem - , all - , any - , maximum - , maximumBy - , minimum - , minimumBy - , lookup - , findM - , find - , (!!) - , the - - -- * To containers - , toList - , toListRev - - -- * Multi-Stream Folds - -- ** Comparisons - -- | These should probably be expressed using zipping operations. - , eqBy - , cmpBy - - -- ** Substreams - -- | These should probably be expressed using parsers. - , isPrefixOf - , isInfixOf - , isSuffixOf - , isSuffixOfUnbox - , isSubsequenceOf - , stripPrefix - , stripSuffix - , stripSuffixUnbox - ) -where - -#include "inline.hs" - -import Control.Exception (assert) -import Control.Monad.IO.Class (MonadIO(..)) -import Foreign.Storable (Storable) -import GHC.Exts (SpecConstrAnnotation(..)) -import GHC.Types (SPEC(..)) -import Streamly.Internal.Data.Parser (ParseError(..)) -import Streamly.Internal.Data.SVar.Type (defState) -import Streamly.Internal.Data.Unboxed (Unbox) - -import Streamly.Internal.Data.Maybe.Strict (Maybe'(..)) - -import qualified Streamly.Internal.Data.Array.Type as Array -import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Parser as PR -import qualified Streamly.Internal.Data.Parser.ParserD as PRD -import qualified Streamly.Internal.Data.Stream.StreamD.Generate as StreamD -import qualified Streamly.Internal.Data.Stream.StreamD.Nesting as Nesting -import qualified Streamly.Internal.Data.Stream.StreamD.Transform as StreamD - -import Prelude hiding - ( all, any, elem, foldr, foldr1, head, last, lookup, mapM, mapM_ - , maximum, minimum, notElem, null, splitAt, tail, (!!)) -import Streamly.Internal.Data.Stream.StreamD.Type - -#include "DocTestDataStream.hs" - ------------------------------------------------------------------------------- --- Elimination by Folds ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Right Folds ------------------------------------------------------------------------------- - -{-# INLINE_NORMAL foldr1 #-} -foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a) -foldr1 f m = do - r <- uncons m - case r of - Nothing -> return Nothing - Just (h, t) -> fmap Just (foldr f h t) - ------------------------------------------------------------------------------- --- Parsers ------------------------------------------------------------------------------- - --- Inlined definition. Without the inline "serially/parser/take" benchmark --- degrades and parseMany does not fuse. Even using "inline" at the callsite --- does not help. -{-# INLINE splitAt #-} -splitAt :: Int -> [a] -> ([a],[a]) -splitAt n ls - | n <= 0 = ([], ls) - | otherwise = splitAt' n ls - where - splitAt' :: Int -> [a] -> ([a], [a]) - splitAt' _ [] = ([], []) - splitAt' 1 (x:xs) = ([x], xs) - splitAt' m (x:xs) = (x:xs', xs'') - where - (xs', xs'') = splitAt' (m - 1) xs - --- GHC parser does not accept {-# ANN type [] NoSpecConstr #-}, so we need --- to make a newtype. -{-# ANN type List NoSpecConstr #-} -newtype List a = List {getList :: [a]} - --- | Run a 'Parse' over a stream. -{-# INLINE_NORMAL parseD #-} -parseD - :: Monad m - => PRD.Parser a m b - -> Stream m a - -> m (Either ParseError b) -parseD parser strm = do - (b, _) <- parseBreakD parser strm - return b - --- | Parse a stream using the supplied 'Parser'. --- --- Parsers (See "Streamly.Internal.Data.Parser") are more powerful folds that --- add backtracking and error functionality to terminating folds. Unlike folds, --- parsers may not always result in a valid output, they may result in an --- error. For example: --- --- >>> Stream.parse (Parser.takeEQ 1 Fold.drain) Stream.nil --- Left (ParseError "takeEQ: Expecting exactly 1 elements, input terminated on 0") --- --- Note: @parse p@ is not the same as @head . parseMany p@ on an empty stream. --- -{-# INLINE [3] parse #-} -parse :: Monad m => PR.Parser a m b -> Stream m a -> m (Either ParseError b) -parse = parseD - --- XXX It may be a good idea to use constant sized chunks for backtracking. We --- can take a byte stream but when we have to backtrack we create constant --- sized chunks. We maintain one forward list and one backward list of constant --- sized chunks, and a last backtracking offset. That way we just need lists of --- contents and no need to maintain start/end pointers for individual arrays, --- reducing bookkeeping work. - --- | Run a 'Parse' over a stream and return rest of the Stream. -{-# INLINE_NORMAL parseBreakD #-} -parseBreakD - :: Monad m - => PRD.Parser a m b - -> Stream m a - -> m (Either ParseError b, Stream m a) -parseBreakD (PRD.Parser pstep initial extract) stream@(Stream step state) = do - res <- initial - case res of - PRD.IPartial s -> go SPEC state (List []) s - PRD.IDone b -> return (Right b, stream) - PRD.IError err -> return (Left (ParseError err), stream) - - where - - -- "buf" contains last few items in the stream that we may have to - -- backtrack to. - -- - -- XXX currently we are using a dumb list based approach for backtracking - -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. - -- That will allow us more efficient random back and forth movement. - go !_ st buf !pst = do - r <- step defState st - case r of - Yield x s -> do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> go SPEC s (List []) pst1 - PR.Partial 1 pst1 -> go1 SPEC s x pst1 - PR.Partial n pst1 -> do - assert (n <= length (x:getList buf)) (return ()) - let src0 = Prelude.take n (x:getList buf) - src = Prelude.reverse src0 - gobuf SPEC s (List []) (List src) pst1 - PR.Continue 0 pst1 -> go SPEC s (List (x:getList buf)) pst1 - PR.Continue 1 pst1 -> gobuf SPEC s buf (List [x]) pst1 - PR.Continue n pst1 -> do - assert (n <= length (x:getList buf)) (return ()) - let (src0, buf1) = splitAt n (x:getList buf) - src = Prelude.reverse src0 - gobuf SPEC s (List buf1) (List src) pst1 - PR.Done 0 b -> return (Right b, Stream step s) - PR.Done n b -> do - assert (n <= length (x:getList buf)) (return ()) - let src0 = Prelude.take n (x:getList buf) - src = Prelude.reverse src0 - -- XXX This would make it quadratic. We should probably - -- use StreamK if we have to append many times. - return - ( Right b, - Nesting.append (fromList src) (Stream step s)) - PR.Error err -> - return (Left (ParseError err), Stream step s) - Skip s -> go SPEC s buf pst - Stop -> goStop SPEC buf pst - - go1 _ s x !pst = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - go SPEC s (List []) pst1 - PR.Partial 1 pst1 -> do - go1 SPEC s x pst1 - PR.Partial n _ -> - error $ "parseBreak: parser bug, go1: Partial n = " ++ show n - PR.Continue 0 pst1 -> - go SPEC s (List [x]) pst1 - PR.Continue 1 pst1 -> - go1 SPEC s x pst1 - PR.Continue n _ -> do - error $ "parseBreak: parser bug, go1: Continue n = " ++ show n - PR.Done 0 b -> do - return (Right b, Stream step s) - PR.Done 1 b -> do - return (Right b, StreamD.cons x (Stream step s)) - PR.Done n _ -> do - error $ "parseBreak: parser bug, go1: Done n = " ++ show n - PR.Error err -> - return - ( Left (ParseError err) - , Nesting.append (fromPure x) (Stream step s) - ) - - gobuf !_ s buf (List []) !pst = go SPEC s buf pst - gobuf !_ s buf (List (x:xs)) !pst = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - gobuf SPEC s (List []) (List xs) pst1 - PR.Partial n pst1 -> do - assert (n <= length (x:getList buf)) (return ()) - let src0 = Prelude.take n (x:getList buf) - src = Prelude.reverse src0 ++ xs - gobuf SPEC s (List []) (List src) pst1 - PR.Continue 0 pst1 -> - gobuf SPEC s (List (x:getList buf)) (List xs) pst1 - PR.Continue 1 pst1 -> - gobuf SPEC s buf (List (x:xs)) pst1 - PR.Continue n pst1 -> do - assert (n <= length (x:getList buf)) (return ()) - let (src0, buf1) = splitAt n (x:getList buf) - src = Prelude.reverse src0 ++ xs - gobuf SPEC s (List buf1) (List src) pst1 - PR.Done n b -> do - assert (n <= length (x:getList buf)) (return ()) - let src0 = Prelude.take n (x:getList buf) - src = Prelude.reverse src0 - return (Right b, Nesting.append (fromList src) (Stream step s)) - PR.Error err -> - return - ( Left (ParseError err) - , Nesting.append (fromList (x:xs)) (Stream step s) - ) - - -- This is simplified gobuf - goExtract !_ buf (List []) !pst = goStop SPEC buf pst - goExtract !_ buf (List (x:xs)) !pst = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - goExtract SPEC (List []) (List xs) pst1 - PR.Partial n pst1 -> do - assert (n <= length (x:getList buf)) (return ()) - let src0 = Prelude.take n (x:getList buf) - src = Prelude.reverse src0 ++ xs - goExtract SPEC (List []) (List src) pst1 - PR.Continue 0 pst1 -> - goExtract SPEC (List (x:getList buf)) (List xs) pst1 - PR.Continue 1 pst1 -> - goExtract SPEC buf (List (x:xs)) pst1 - PR.Continue n pst1 -> do - assert (n <= length (x:getList buf)) (return ()) - let (src0, buf1) = splitAt n (x:getList buf) - src = Prelude.reverse src0 ++ xs - goExtract SPEC (List buf1) (List src) pst1 - PR.Done n b -> do - assert (n <= length (x:getList buf)) (return ()) - let src0 = Prelude.take n (x:getList buf) - src = Prelude.reverse src0 - return (Right b, fromList src) - PR.Error err -> return (Left (ParseError err), fromList (x:xs)) - - -- This is simplified goExtract - -- XXX Use SPEC? - {-# INLINE goStop #-} - goStop _ buf pst = do - pRes <- extract pst - case pRes of - PR.Partial _ _ -> error "Bug: parseBreak: Partial in extract" - PR.Continue 0 pst1 -> goStop SPEC buf pst1 - PR.Continue n pst1 -> do - assert (n <= length (getList buf)) (return ()) - let (src0, buf1) = splitAt n (getList buf) - src = Prelude.reverse src0 - goExtract SPEC (List buf1) (List src) pst1 - PR.Done 0 b -> return (Right b, StreamD.nil) - PR.Done n b -> do - assert (n <= length (getList buf)) (return ()) - let src0 = Prelude.take n (getList buf) - src = Prelude.reverse src0 - return (Right b, fromList src) - PR.Error err -> - return (Left (ParseError err), StreamD.nil) - --- | Parse a stream using the supplied 'Parser'. --- -{-# INLINE parseBreak #-} -parseBreak :: Monad m => PR.Parser a m b -> Stream m a -> m (Either ParseError b, Stream m a) -parseBreak = parseBreakD - ------------------------------------------------------------------------------- --- Specialized Folds ------------------------------------------------------------------------------- - --- benchmark after dropping 1 item from stream or using unfolds -{-# INLINE_NORMAL null #-} -null :: Monad m => Stream m a -> m Bool -#ifdef USE_FOLDS_EVERYWHERE -null = fold Fold.null -#else -null = foldrM (\_ _ -> return False) (return True) -#endif - -{-# INLINE_NORMAL head #-} -head :: Monad m => Stream m a -> m (Maybe a) -#ifdef USE_FOLDS_EVERYWHERE -head = fold Fold.one -#else -head = foldrM (\x _ -> return (Just x)) (return Nothing) -#endif - -{-# INLINE_NORMAL headElse #-} -headElse :: Monad m => a -> Stream m a -> m a -headElse a = foldrM (\x _ -> return x) (return a) - --- Does not fuse, has the same performance as the StreamK version. -{-# INLINE_NORMAL tail #-} -tail :: Monad m => Stream m a -> m (Maybe (Stream m a)) -tail (UnStream step state) = go SPEC state - where - go !_ st = do - r <- step defState st - case r of - Yield _ s -> return (Just $ Stream step s) - Skip s -> go SPEC s - Stop -> return Nothing - --- XXX will it fuse? need custom impl? -{-# INLINE_NORMAL last #-} -last :: Monad m => Stream m a -> m (Maybe a) -#ifdef USE_FOLDS_EVERYWHERE -last = fold Fold.last -#else -last = foldl' (\_ y -> Just y) Nothing -#endif - --- XXX Use the foldrM based impl instead -{-# INLINE_NORMAL elem #-} -elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool -#ifdef USE_FOLDS_EVERYWHERE -elem e = fold (Fold.elem e) -#else --- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m -elem e (Stream step state) = go SPEC state - where - go !_ st = do - r <- step defState st - case r of - Yield x s - | x == e -> return True - | otherwise -> go SPEC s - Skip s -> go SPEC s - Stop -> return False -#endif - -{-# INLINE_NORMAL notElem #-} -notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool -notElem e s = fmap not (elem e s) - -{-# INLINE_NORMAL all #-} -all :: Monad m => (a -> Bool) -> Stream m a -> m Bool -#ifdef USE_FOLDS_EVERYWHERE -all p = fold (Fold.all p) -#else --- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m -all p (Stream step state) = go SPEC state - where - go !_ st = do - r <- step defState st - case r of - Yield x s - | p x -> go SPEC s - | otherwise -> return False - Skip s -> go SPEC s - Stop -> return True -#endif - -{-# INLINE_NORMAL any #-} -any :: Monad m => (a -> Bool) -> Stream m a -> m Bool -#ifdef USE_FOLDS_EVERYWHERE -any p = fold (Fold.any p) -#else --- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m -any p (Stream step state) = go SPEC state - where - go !_ st = do - r <- step defState st - case r of - Yield x s - | p x -> return True - | otherwise -> go SPEC s - Skip s -> go SPEC s - Stop -> return False -#endif - -{-# INLINE_NORMAL maximum #-} -maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a) -#ifdef USE_FOLDS_EVERYWHERE -maximum = fold Fold.maximum -#else -maximum (Stream step state) = go SPEC Nothing' state - where - go !_ Nothing' st = do - r <- step defState st - case r of - Yield x s -> go SPEC (Just' x) s - Skip s -> go SPEC Nothing' s - Stop -> return Nothing - go !_ (Just' acc) st = do - r <- step defState st - case r of - Yield x s - | acc <= x -> go SPEC (Just' x) s - | otherwise -> go SPEC (Just' acc) s - Skip s -> go SPEC (Just' acc) s - Stop -> return (Just acc) -#endif - -{-# INLINE_NORMAL maximumBy #-} -maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a) -#ifdef USE_FOLDS_EVERYWHERE -maximumBy cmp = fold (Fold.maximumBy cmp) -#else -maximumBy cmp (Stream step state) = go SPEC Nothing' state - where - go !_ Nothing' st = do - r <- step defState st - case r of - Yield x s -> go SPEC (Just' x) s - Skip s -> go SPEC Nothing' s - Stop -> return Nothing - go !_ (Just' acc) st = do - r <- step defState st - case r of - Yield x s -> case cmp acc x of - GT -> go SPEC (Just' acc) s - _ -> go SPEC (Just' x) s - Skip s -> go SPEC (Just' acc) s - Stop -> return (Just acc) -#endif - -{-# INLINE_NORMAL minimum #-} -minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a) -#ifdef USE_FOLDS_EVERYWHERE -minimum = fold Fold.minimum -#else -minimum (Stream step state) = go SPEC Nothing' state - - where - - go !_ Nothing' st = do - r <- step defState st - case r of - Yield x s -> go SPEC (Just' x) s - Skip s -> go SPEC Nothing' s - Stop -> return Nothing - go !_ (Just' acc) st = do - r <- step defState st - case r of - Yield x s - | acc <= x -> go SPEC (Just' acc) s - | otherwise -> go SPEC (Just' x) s - Skip s -> go SPEC (Just' acc) s - Stop -> return (Just acc) -#endif - -{-# INLINE_NORMAL minimumBy #-} -minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a) -#ifdef USE_FOLDS_EVERYWHERE -minimumBy cmp = fold (Fold.minimumBy cmp) -#else -minimumBy cmp (Stream step state) = go SPEC Nothing' state - - where - - go !_ Nothing' st = do - r <- step defState st - case r of - Yield x s -> go SPEC (Just' x) s - Skip s -> go SPEC Nothing' s - Stop -> return Nothing - go !_ (Just' acc) st = do - r <- step defState st - case r of - Yield x s -> case cmp acc x of - GT -> go SPEC (Just' x) s - _ -> go SPEC (Just' acc) s - Skip s -> go SPEC (Just' acc) s - Stop -> return (Just acc) -#endif - -{-# INLINE_NORMAL (!!) #-} -(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a) -#ifdef USE_FOLDS_EVERYWHERE -stream !! i = fold (Fold.index i) stream -#else -(Stream step state) !! i = go SPEC i state - - where - - go !_ !n st = do - r <- step defState st - case r of - Yield x s | n < 0 -> return Nothing - | n == 0 -> return $ Just x - | otherwise -> go SPEC (n - 1) s - Skip s -> go SPEC n s - Stop -> return Nothing -#endif - -{-# INLINE_NORMAL lookup #-} -lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b) -#ifdef USE_FOLDS_EVERYWHERE -lookup e = fold (Fold.lookup e) -#else -lookup e = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs) - (return Nothing) -#endif - -{-# INLINE_NORMAL findM #-} -findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a) -#ifdef USE_FOLDS_EVERYWHERE -findM p = fold (Fold.findM p) -#else -findM p = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs) - (return Nothing) -#endif - -{-# INLINE find #-} -find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a) -find p = findM (return . p) - -{-# INLINE toListRev #-} -toListRev :: Monad m => Stream m a -> m [a] -#ifdef USE_FOLDS_EVERYWHERE -toListRev = fold Fold.toListRev -#else -toListRev = foldl' (flip (:)) [] -#endif - ------------------------------------------------------------------------------- --- Transformation comprehensions ------------------------------------------------------------------------------- - -{-# INLINE_NORMAL the #-} -the :: (Eq a, Monad m) => Stream m a -> m (Maybe a) -#ifdef USE_FOLDS_EVERYWHERE -the = fold Fold.the -#else -the (Stream step state) = go SPEC state - where - go !_ st = do - r <- step defState st - case r of - Yield x s -> go' SPEC x s - Skip s -> go SPEC s - Stop -> return Nothing - go' !_ n st = do - r <- step defState st - case r of - Yield x s | x == n -> go' SPEC n s - | otherwise -> return Nothing - Skip s -> go' SPEC n s - Stop -> return (Just n) -#endif - ------------------------------------------------------------------------------- --- Map and Fold ------------------------------------------------------------------------------- - --- | Execute a monadic action for each element of the 'Stream' -{-# INLINE_NORMAL mapM_ #-} -mapM_ :: Monad m => (a -> m b) -> Stream m a -> m () -#ifdef USE_FOLDS_EVERYWHERE -mapM_ f = fold (Fold.drainBy f) -#else -mapM_ m = drain . mapM m -#endif - ------------------------------------------------------------------------------- --- Multi-stream folds ------------------------------------------------------------------------------- - --- | Returns 'True' if the first stream is the same as or a prefix of the --- second. A stream is a prefix of itself. --- --- >>> Stream.isPrefixOf (Stream.fromList "hello") (Stream.fromList "hello" :: Stream IO Char) --- True --- -{-# INLINE_NORMAL isPrefixOf #-} -isPrefixOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool -isPrefixOf (Stream stepa ta) (Stream stepb tb) = go SPEC Nothing' ta tb - - where - - go !_ Nothing' sa sb = do - r <- stepa defState sa - case r of - Yield x sa' -> go SPEC (Just' x) sa' sb - Skip sa' -> go SPEC Nothing' sa' sb - Stop -> return True - - go !_ (Just' x) sa sb = do - r <- stepb defState sb - case r of - Yield y sb' -> - if x == y - then go SPEC Nothing' sa sb' - else return False - Skip sb' -> go SPEC (Just' x) sa sb' - Stop -> return False - --- | Returns 'True' if all the elements of the first stream occur, in order, in --- the second stream. The elements do not have to occur consecutively. A stream --- is a subsequence of itself. --- --- >>> Stream.isSubsequenceOf (Stream.fromList "hlo") (Stream.fromList "hello" :: Stream IO Char) --- True --- -{-# INLINE_NORMAL isSubsequenceOf #-} -isSubsequenceOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool -isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go SPEC Nothing' ta tb - - where - - go !_ Nothing' sa sb = do - r <- stepa defState sa - case r of - Yield x sa' -> go SPEC (Just' x) sa' sb - Skip sa' -> go SPEC Nothing' sa' sb - Stop -> return True - - go !_ (Just' x) sa sb = do - r <- stepb defState sb - case r of - Yield y sb' -> - if x == y - then go SPEC Nothing' sa sb' - else go SPEC (Just' x) sa sb' - Skip sb' -> go SPEC (Just' x) sa sb' - Stop -> return False - --- | @stripPrefix prefix input@ strips the @prefix@ stream from the @input@ --- stream if it is a prefix of input. Returns 'Nothing' if the input does not --- start with the given prefix, stripped input otherwise. Returns @Just nil@ --- when the prefix is the same as the input stream. --- --- Space: @O(1)@ --- -{-# INLINE_NORMAL stripPrefix #-} -stripPrefix - :: (Monad m, Eq a) - => Stream m a -> Stream m a -> m (Maybe (Stream m a)) -stripPrefix (Stream stepa ta) (Stream stepb tb) = go SPEC Nothing' ta tb - - where - - go !_ Nothing' sa sb = do - r <- stepa defState sa - case r of - Yield x sa' -> go SPEC (Just' x) sa' sb - Skip sa' -> go SPEC Nothing' sa' sb - Stop -> return $ Just (Stream stepb sb) - - go !_ (Just' x) sa sb = do - r <- stepb defState sb - case r of - Yield y sb' -> - if x == y - then go SPEC Nothing' sa sb' - else return Nothing - Skip sb' -> go SPEC (Just' x) sa sb' - Stop -> return Nothing - --- | Returns 'True' if the first stream is an infix of the second. A stream is --- considered an infix of itself. --- --- >>> s = Stream.fromList "hello" :: Stream IO Char --- >>> Stream.isInfixOf s s --- True --- --- Space: @O(n)@ worst case where @n@ is the length of the infix. --- --- /Pre-release/ --- --- /Requires 'Storable' constraint/ --- -{-# INLINE isInfixOf #-} -isInfixOf :: (MonadIO m, Eq a, Enum a, Storable a, Unbox a) - => Stream m a -> Stream m a -> m Bool -isInfixOf infx stream = do - arr <- fold Array.write infx - -- XXX can use breakOnSeq instead (when available) - r <- null $ StreamD.drop 1 $ Nesting.splitOnSeq arr Fold.drain stream - return (not r) - --- Note: isPrefixOf uses the prefix stream only once. In contrast, isSuffixOf --- may use the suffix stream many times. To run in optimal memory we do not --- want to buffer the suffix stream in memory therefore we need an ability to --- clone (or consume it multiple times) the suffix stream without any side --- effects so that multiple potential suffix matches can proceed in parallel --- without buffering the suffix stream. For example, we may create the suffix --- stream from a file handle, however, if we evaluate the stream multiple --- times, once for each match, we will need a different file handle each time --- which may exhaust the file descriptors. Instead, we want to share the same --- underlying file descriptor, use pread on it to generate the stream and clone --- the stream for each match. Therefore the suffix stream should be built in --- such a way that it can be consumed multiple times without any problems. - --- XXX Can be implemented with better space/time complexity. --- Space: @O(n)@ worst case where @n@ is the length of the suffix. - --- | Returns 'True' if the first stream is a suffix of the second. A stream is --- considered a suffix of itself. --- --- >>> Stream.isSuffixOf (Stream.fromList "hello") (Stream.fromList "hello" :: Stream IO Char) --- True --- --- Space: @O(n)@, buffers entire input stream and the suffix. --- --- /Pre-release/ --- --- /Suboptimal/ - Help wanted. --- -{-# INLINE isSuffixOf #-} -isSuffixOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool -isSuffixOf suffix stream = - StreamD.reverse suffix `isPrefixOf` StreamD.reverse stream - --- | Much faster than 'isSuffixOf'. -{-# INLINE isSuffixOfUnbox #-} -isSuffixOfUnbox :: (MonadIO m, Eq a, Unbox a) => - Stream m a -> Stream m a -> m Bool -isSuffixOfUnbox suffix stream = - StreamD.reverseUnbox suffix `isPrefixOf` StreamD.reverseUnbox stream - --- | Drops the given suffix from a stream. Returns 'Nothing' if the stream does --- not end with the given suffix. Returns @Just nil@ when the suffix is the --- same as the stream. --- --- It may be more efficient to convert the stream to an Array and use --- stripSuffix on that especially if the elements have a Storable or Prim --- instance. --- --- See also "Streamly.Internal.Data.Stream.Reduce.dropSuffix". --- --- Space: @O(n)@, buffers the entire input stream as well as the suffix --- --- /Pre-release/ -{-# INLINE stripSuffix #-} -stripSuffix - :: (Monad m, Eq a) - => Stream m a -> Stream m a -> m (Maybe (Stream m a)) -stripSuffix m1 m2 = - fmap StreamD.reverse - <$> stripPrefix (StreamD.reverse m1) (StreamD.reverse m2) - --- | Much faster than 'stripSuffix'. -{-# INLINE stripSuffixUnbox #-} -stripSuffixUnbox - :: (MonadIO m, Eq a, Unbox a) - => Stream m a -> Stream m a -> m (Maybe (Stream m a)) -stripSuffixUnbox m1 m2 = - fmap StreamD.reverseUnbox - <$> stripPrefix (StreamD.reverseUnbox m1) (StreamD.reverseUnbox m2) diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Exception.hs b/src/Streamly/Internal/Data/Stream/StreamD/Exception.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Exception.hs +++ /dev/null @@ -1,479 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Exception --- Copyright : (c) 2020 Composewell Technologies and Contributors --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Stream.StreamD.Exception - ( - gbracket_ - , gbracket - , before - , afterUnsafe - , afterIO - , bracketUnsafe - , bracketIO3 - , bracketIO - , onException - , finallyUnsafe - , finallyIO - , ghandle - , handle - ) -where - -#include "inline.hs" - -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Exception (Exception, SomeException, mask_) -import Control.Monad.Catch (MonadCatch) -import GHC.Exts (inline) -import Streamly.Internal.Data.IOFinalizer - (newIOFinalizer, runIOFinalizer, clearingIOFinalizer) - -import qualified Control.Monad.Catch as MC - -import Streamly.Internal.Data.Stream.StreamD.Type - -#include "DocTestDataStream.hs" - -data GbracketState s1 s2 v - = GBracketInit - | GBracketNormal s1 v - | GBracketException s2 - --- | Like 'gbracket' but with following differences: --- --- * alloc action @m c@ runs with async exceptions enabled --- * cleanup action @c -> m d@ won't run if the stream is garbage collected --- after partial evaluation. --- --- /Inhibits stream fusion/ --- --- /Pre-release/ --- -{-# INLINE_NORMAL gbracket_ #-} -gbracket_ - :: Monad m - => m c -- ^ before - -> (c -> m d) -- ^ after, on normal stop - -> (c -> e -> Stream m b -> Stream m b) -- ^ on exception - -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) - -> (c -> Stream m b) -- ^ stream generator - -> Stream m b -gbracket_ bef aft onExc ftry action = - Stream step GBracketInit - - where - - {-# INLINE_LATE step #-} - step _ GBracketInit = do - r <- bef - return $ Skip $ GBracketNormal (action r) r - - step gst (GBracketNormal (UnStream step1 st) v) = do - res <- ftry $ step1 gst st - case res of - Right r -> case r of - Yield x s -> - return $ Yield x (GBracketNormal (Stream step1 s) v) - Skip s -> return $ Skip (GBracketNormal (Stream step1 s) v) - Stop -> aft v >> return Stop - -- XXX Do not handle async exceptions, just rethrow them. - Left e -> - return - $ Skip (GBracketException (onExc v e (UnStream step1 st))) - step gst (GBracketException (UnStream step1 st)) = do - res <- step1 gst st - case res of - Yield x s -> return $ Yield x (GBracketException (Stream step1 s)) - Skip s -> return $ Skip (GBracketException (Stream step1 s)) - Stop -> return Stop - -data GbracketIOState s1 s2 v wref - = GBracketIOInit - | GBracketIONormal s1 v wref - | GBracketIOException s2 - --- | Run the alloc action @m c@ with async exceptions disabled but keeping --- blocking operations interruptible (see 'Control.Exception.mask'). Use the --- output @c@ as input to @c -> Stream m b@ to generate an output stream. When --- generating the stream use the supplied @try@ operation @forall s. m s -> m --- (Either e s)@ to catch synchronous exceptions. If an exception occurs run --- the exception handler @c -> e -> Stream m b -> m (Stream m b)@. Note that --- 'gbracket' does not rethrow the exception, it has to be done by the --- exception handler if desired. --- --- The cleanup action @c -> m d@, runs whenever the stream ends normally, due --- to a sync or async exception or if it gets garbage collected after a partial --- lazy evaluation. See 'bracket' for the semantics of the cleanup action. --- --- 'gbracket' can express all other exception handling combinators. --- --- /Inhibits stream fusion/ --- --- /Pre-release/ -{-# INLINE_NORMAL gbracket #-} -gbracket - :: MonadIO m - => IO c -- ^ before - -> (c -> IO d1) -- ^ on normal stop - -> (c -> e -> Stream m b -> IO (Stream m b)) -- ^ on exception - -> (c -> IO d2) -- ^ on GC without normal stop or exception - -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) - -> (c -> Stream m b) -- ^ stream generator - -> Stream m b -gbracket bef aft onExc onGC ftry action = - Stream step GBracketIOInit - - where - - -- If the stream is never evaluated the "aft" action will never be - -- called. For that to occur we will need the user of this API to pass a - -- weak pointer to us. - {-# INLINE_LATE step #-} - step _ GBracketIOInit = do - -- We mask asynchronous exceptions to make the execution - -- of 'bef' and the registration of 'aft' atomic. - -- A similar thing is done in the resourcet package: https://git.io/JvKV3 - -- Tutorial: https://markkarpov.com/tutorial/exceptions.html - (r, ref) <- liftIO $ mask_ $ do - r <- bef - ref <- newIOFinalizer (onGC r) - return (r, ref) - return $ Skip $ GBracketIONormal (action r) r ref - - step gst (GBracketIONormal (UnStream step1 st) v ref) = do - res <- ftry $ step1 gst st - case res of - Right r -> case r of - Yield x s -> - return $ Yield x (GBracketIONormal (Stream step1 s) v ref) - Skip s -> - return $ Skip (GBracketIONormal (Stream step1 s) v ref) - Stop -> - liftIO (clearingIOFinalizer ref (aft v)) >> return Stop - -- XXX Do not handle async exceptions, just rethrow them. - Left e -> do - -- Clearing of finalizer and running of exception handler must - -- be atomic wrt async exceptions. Otherwise if we have cleared - -- the finalizer and have not run the exception handler then we - -- may leak the resource. - stream <- - liftIO (clearingIOFinalizer ref (onExc v e (UnStream step1 st))) - return $ Skip (GBracketIOException stream) - step gst (GBracketIOException (UnStream step1 st)) = do - res <- step1 gst st - case res of - Yield x s -> - return $ Yield x (GBracketIOException (Stream step1 s)) - Skip s -> return $ Skip (GBracketIOException (Stream step1 s)) - Stop -> return Stop - --- | Run the action @m b@ before the stream yields its first element. --- --- Same as the following but more efficient due to fusion: --- --- >>> before action xs = Stream.nilM action <> xs --- >>> before action xs = Stream.concatMap (const xs) (Stream.fromEffect action) --- -{-# INLINE_NORMAL before #-} -before :: Monad m => m b -> Stream m a -> Stream m a -before action (Stream step state) = Stream step' Nothing - - where - - {-# INLINE_LATE step' #-} - step' _ Nothing = action >> return (Skip (Just state)) - - step' gst (Just st) = do - res <- step gst st - case res of - Yield x s -> return $ Yield x (Just s) - Skip s -> return $ Skip (Just s) - Stop -> return Stop - --- | Like 'after', with following differences: --- --- * action @m b@ won't run if the stream is garbage collected --- after partial evaluation. --- * Monad @m@ does not require any other constraints. --- * has slightly better performance than 'after'. --- --- Same as the following, but with stream fusion: --- --- >>> afterUnsafe action xs = xs <> Stream.nilM action --- --- /Pre-release/ --- -{-# INLINE_NORMAL afterUnsafe #-} -afterUnsafe :: Monad m => m b -> Stream m a -> Stream m a -afterUnsafe action (Stream step state) = Stream step' state - - where - - {-# INLINE_LATE step' #-} - step' gst st = do - res <- step gst st - case res of - Yield x s -> return $ Yield x s - Skip s -> return $ Skip s - Stop -> action >> return Stop - --- | Run the action @IO b@ whenever the stream is evaluated to completion, or --- if it is garbage collected after a partial lazy evaluation. --- --- The semantics of the action @IO b@ are similar to the semantics of cleanup --- action in 'bracketIO'. --- --- /See also 'afterUnsafe'/ --- -{-# INLINE_NORMAL afterIO #-} -afterIO :: MonadIO m - => IO b -> Stream m a -> Stream m a -afterIO action (Stream step state) = Stream step' Nothing - - where - - {-# INLINE_LATE step' #-} - step' _ Nothing = do - ref <- liftIO $ newIOFinalizer action - return $ Skip $ Just (state, ref) - step' gst (Just (st, ref)) = do - res <- step gst st - case res of - Yield x s -> return $ Yield x (Just (s, ref)) - Skip s -> return $ Skip (Just (s, ref)) - Stop -> do - runIOFinalizer ref - return Stop - --- XXX For high performance error checks in busy streams we may need another --- Error constructor in step. - --- | Run the action @m b@ if the stream evaluation is aborted due to an --- exception. The exception is not caught, simply rethrown. --- --- /Inhibits stream fusion/ --- -{-# INLINE_NORMAL onException #-} -onException :: MonadCatch m => m b -> Stream m a -> Stream m a -onException action stream = - gbracket_ - (return ()) -- before - return -- after - (\_ (e :: MC.SomeException) _ -> nilM (action >> MC.throwM e)) - (inline MC.try) - (const stream) - -{-# INLINE_NORMAL _onException #-} -_onException :: MonadCatch m => m b -> Stream m a -> Stream m a -_onException action (Stream step state) = Stream step' state - - where - - {-# INLINE_LATE step' #-} - step' gst st = do - res <- step gst st `MC.onException` action - case res of - Yield x s -> return $ Yield x s - Skip s -> return $ Skip s - Stop -> return Stop - --- | Like 'bracket' but with following differences: --- --- * alloc action @m b@ runs with async exceptions enabled --- * cleanup action @b -> m c@ won't run if the stream is garbage collected --- after partial evaluation. --- * has slightly better performance than 'bracketIO'. --- --- /Inhibits stream fusion/ --- --- /Pre-release/ --- -{-# INLINE_NORMAL bracketUnsafe #-} -bracketUnsafe :: MonadCatch m - => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a -bracketUnsafe bef aft = - gbracket_ - bef - aft - (\a (e :: SomeException) _ -> nilM (aft a >> MC.throwM e)) - (inline MC.try) - --- For a use case of this see the "streamly-process" package. It needs to kill --- the process in case of exception or garbage collection, but waits for the --- process to terminate in normal cases. - --- | Like 'bracketIO' but can use 3 separate cleanup actions depending on the --- mode of termination: --- --- 1. When the stream stops normally --- 2. When the stream is garbage collected --- 3. When the stream encounters an exception --- --- @bracketIO3 before onStop onGC onException action@ runs @action@ using the --- result of @before@. If the stream stops, @onStop@ action is executed, if the --- stream is abandoned @onGC@ is executed, if the stream encounters an --- exception @onException@ is executed. --- --- /Inhibits stream fusion/ --- --- /Pre-release/ -{-# INLINE_NORMAL bracketIO3 #-} -bracketIO3 :: (MonadIO m, MonadCatch m) => - IO b - -> (b -> IO c) - -> (b -> IO d) - -> (b -> IO e) - -> (b -> Stream m a) - -> Stream m a -bracketIO3 bef aft onExc onGC = - gbracket - bef - aft - (\a (e :: SomeException) _ -> onExc a >> return (nilM (MC.throwM e))) - onGC - (inline MC.try) - --- | Run the alloc action @IO b@ with async exceptions disabled but keeping --- blocking operations interruptible (see 'Control.Exception.mask'). Use the --- output @b@ as input to @b -> Stream m a@ to generate an output stream. --- --- @b@ is usually a resource under the IO monad, e.g. a file handle, that --- requires a cleanup after use. The cleanup action @b -> IO c@, runs whenever --- the stream ends normally, due to a sync or async exception or if it gets --- garbage collected after a partial lazy evaluation. --- --- 'bracketIO' only guarantees that the cleanup action runs, and it runs with --- async exceptions enabled. The action must ensure that it can successfully --- cleanup the resource in the face of sync or async exceptions. --- --- When the stream ends normally or on a sync exception, cleanup action runs --- immediately in the current thread context, whereas in other cases it runs in --- the GC context, therefore, cleanup may be delayed until the GC gets to run. --- --- /See also: 'bracketUnsafe'/ --- --- /Inhibits stream fusion/ --- -{-# INLINE bracketIO #-} -bracketIO :: (MonadIO m, MonadCatch m) - => IO b -> (b -> IO c) -> (b -> Stream m a) -> Stream m a -bracketIO bef aft = bracketIO3 bef aft aft aft - -data BracketState s v = BracketInit | BracketRun s v - --- | Alternate (custom) implementation of 'bracket'. --- -{-# INLINE_NORMAL _bracket #-} -_bracket :: MonadCatch m - => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a -_bracket bef aft bet = Stream step' BracketInit - - where - - {-# INLINE_LATE step' #-} - step' _ BracketInit = bef >>= \x -> return (Skip (BracketRun (bet x) x)) - - -- NOTE: It is important to use UnStream instead of the Stream pattern - -- here, otherwise we get huge perf degradation, see note in concatMap. - step' gst (BracketRun (UnStream step state) v) = do - -- res <- step gst state `MC.onException` aft v - res <- inline MC.try $ step gst state - case res of - Left (e :: SomeException) -> aft v >> MC.throwM e >> return Stop - Right r -> case r of - Yield x s -> return $ Yield x (BracketRun (Stream step s) v) - Skip s -> return $ Skip (BracketRun (Stream step s) v) - Stop -> aft v >> return Stop - --- | Like 'finally' with following differences: --- --- * action @m b@ won't run if the stream is garbage collected --- after partial evaluation. --- * has slightly better performance than 'finallyIO'. --- --- /Inhibits stream fusion/ --- --- /Pre-release/ --- -{-# INLINE finallyUnsafe #-} -finallyUnsafe :: MonadCatch m => m b -> Stream m a -> Stream m a -finallyUnsafe action xs = bracketUnsafe (return ()) (const action) (const xs) - --- | Run the action @IO b@ whenever the stream stream stops normally, aborts --- due to an exception or if it is garbage collected after a partial lazy --- evaluation. --- --- The semantics of running the action @IO b@ are similar to the cleanup action --- semantics described in 'bracketIO'. --- --- >>> finallyIO release = Stream.bracketIO (return ()) (const release) --- --- /See also 'finallyUnsafe'/ --- --- /Inhibits stream fusion/ --- -{-# INLINE finallyIO #-} -finallyIO :: (MonadIO m, MonadCatch m) => IO b -> Stream m a -> Stream m a -finallyIO action xs = bracketIO3 (return ()) act act act (const xs) - where act _ = action - --- | Like 'handle' but the exception handler is also provided with the stream --- that generated the exception as input. The exception handler can thus --- re-evaluate the stream to retry the action that failed. The exception --- handler can again call 'ghandle' on it to retry the action multiple times. --- --- This is highly experimental. In a stream of actions we can map the stream --- with a retry combinator to retry each action on failure. --- --- /Inhibits stream fusion/ --- --- /Pre-release/ --- -{-# INLINE_NORMAL ghandle #-} -ghandle :: (MonadCatch m, Exception e) - => (e -> Stream m a -> Stream m a) -> Stream m a -> Stream m a -ghandle f stream = - gbracket_ (return ()) return (const f) (inline MC.try) (const stream) - --- | When evaluating a stream if an exception occurs, stream evaluation aborts --- and the specified exception handler is run with the exception as argument. --- --- /Inhibits stream fusion/ --- -{-# INLINE_NORMAL handle #-} -handle :: (MonadCatch m, Exception e) - => (e -> Stream m a) -> Stream m a -> Stream m a -handle f stream = - gbracket_ (return ()) return (\_ e _ -> f e) (inline MC.try) (const stream) - --- | Alternate (custom) implementation of 'handle'. --- -{-# INLINE_NORMAL _handle #-} -_handle :: (MonadCatch m, Exception e) - => (e -> Stream m a) -> Stream m a -> Stream m a -_handle f (Stream step state) = Stream step' (Left state) - - where - - {-# INLINE_LATE step' #-} - step' gst (Left st) = do - res <- inline MC.try $ step gst st - case res of - Left e -> return $ Skip $ Right (f e) - Right r -> case r of - Yield x s -> return $ Yield x (Left s) - Skip s -> return $ Skip (Left s) - Stop -> return Stop - - step' gst (Right (UnStream step1 st)) = do - res <- step1 gst st - case res of - Yield x s -> return $ Yield x (Right (Stream step1 s)) - Skip s -> return $ Skip (Right (Stream step1 s)) - Stop -> return Stop diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Generate.hs b/src/Streamly/Internal/Data/Stream/StreamD/Generate.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Generate.hs +++ /dev/null @@ -1,1205 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Generate --- Copyright : (c) 2020 Composewell Technologies and Contributors --- (c) Roman Leshchinskiy 2008-2010 --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- - --- A few combinators in this module have been adapted from the vector package --- (c) Roman Leshchinskiy. See the notes in specific combinators. --- -module Streamly.Internal.Data.Stream.StreamD.Generate - ( - -- * Primitives - nil - , nilM - , cons - , consM - - -- * From 'Unfold' - , unfold - - -- * Unfolding - , unfoldr - , unfoldrM - - -- * From Values - , fromPure - , fromEffect - , repeat - , repeatM - , replicate - , replicateM - - -- * Enumeration - -- ** Enumerating 'Num' Types - , enumerateFromStepNum - , enumerateFromNum - , enumerateFromThenNum - - -- ** Enumerating 'Bounded' 'Enum' Types - , enumerate - , enumerateTo - , enumerateFromBounded - - -- ** Enumerating 'Enum' Types not larger than 'Int' - , enumerateFromToSmall - , enumerateFromThenToSmall - , enumerateFromThenSmallBounded - - -- ** Enumerating 'Bounded' 'Integral' Types - , enumerateFromIntegral - , enumerateFromThenIntegral - - -- ** Enumerating 'Integral' Types - , enumerateFromToIntegral - , enumerateFromThenToIntegral - - -- ** Enumerating unbounded 'Integral' Types - , enumerateFromStepIntegral - - -- ** Enumerating 'Fractional' Types - , enumerateFromFractional - , enumerateFromToFractional - , enumerateFromThenFractional - , enumerateFromThenToFractional - - -- ** Enumerable Type Class - , Enumerable(..) - - -- * Time Enumeration - , times - , timesWith - , absTimes - , absTimesWith - , relTimes - , relTimesWith - , durations - , timeout - - -- * From Generators - -- | Generate a monadic stream from a seed. - , fromIndices - , fromIndicesM - , generate - , generateM - - -- * Iteration - , iterate - , iterateM - - -- * From Containers - -- | Transform an input structure into a stream. - - , fromList - , fromListM - , fromFoldable - , fromFoldableM - - -- * From Pointers - , fromPtr - , fromPtrN - , fromByteStr# - - -- * Conversions - , fromStreamK - , toStreamK - ) -where - -#include "inline.hs" -#include "ArrayMacros.h" - -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Functor.Identity (Identity(..)) -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (Storable (peek), sizeOf) -import GHC.Exts (Addr#, Ptr (Ptr)) -import Streamly.Internal.Data.Time.Clock - (Clock(Monotonic), asyncClock, readClock) -import Streamly.Internal.Data.Time.Units - (toAbsTime, AbsTime, toRelTime64, RelTime64, addToAbsTime64) - -#ifdef USE_UNFOLDS_EVERYWHERE -import qualified Streamly.Internal.Data.Unfold as Unfold -import qualified Streamly.Internal.Data.Unfold.Enumeration as Unfold -#endif - -import Data.Fixed -import Data.Int -import Data.Ratio -import Data.Word -import Numeric.Natural -import Prelude hiding (iterate, repeat, replicate, take, takeWhile) -import Streamly.Internal.Data.Stream.StreamD.Type - -#include "DocTestDataStream.hs" - ------------------------------------------------------------------------------- --- Primitives ------------------------------------------------------------------------------- - --- XXX implement in terms of nilM? - --- | A stream that terminates without producing any output or side effect. --- --- >>> Stream.fold Fold.toList Stream.nil --- [] --- -{-# INLINE_NORMAL nil #-} -nil :: Applicative m => Stream m a -nil = Stream (\_ _ -> pure Stop) () - --- XXX implement in terms of consM? --- cons x = consM (return x) - --- | Fuse a pure value at the head of an existing stream:: --- --- >>> s = 1 `Stream.cons` Stream.fromList [2,3] --- >>> Stream.fold Fold.toList s --- [1,2,3] --- --- This function should not be used to dynamically construct a stream. If a --- stream is constructed by successive use of this function it would take --- O(n^2) time to consume the stream. --- --- This function should only be used to statically fuse an element with a --- stream. Do not use this recursively or where it cannot be inlined. --- --- See "Streamly.Data.StreamK" for a 'cons' that can be used to --- construct a stream recursively. --- --- Definition: --- --- >>> cons x xs = return x `Stream.consM` xs --- -{-# INLINE_NORMAL cons #-} -cons :: Applicative m => a -> Stream m a -> Stream m a -cons x (Stream step state) = Stream step1 Nothing - where - {-# INLINE_LATE step1 #-} - step1 _ Nothing = pure $ Yield x (Just state) - step1 gst (Just st) = do - (\case - Yield a s -> Yield a (Just s) - Skip s -> Skip (Just s) - Stop -> Stop) <$> step gst st - ------------------------------------------------------------------------------- --- Unfolding ------------------------------------------------------------------------------- - --- Adapted from vector package - --- | Build a stream by unfolding a /monadic/ step function starting from a --- seed. The step function returns the next element in the stream and the next --- seed value. When it is done it returns 'Nothing' and the stream ends. For --- example, --- --- >>> :{ --- let f b = --- if b > 2 --- then return Nothing --- else return (Just (b, b + 1)) --- in Stream.fold Fold.toList $ Stream.unfoldrM f 0 --- :} --- [0,1,2] --- -{-# INLINE_NORMAL unfoldrM #-} -unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -unfoldrM next = unfold (Unfold.unfoldrM next) -#else -unfoldrM next = Stream step - where - {-# INLINE_LATE step #-} - step _ st = do - r <- next st - return $ case r of - Just (x, s) -> Yield x s - Nothing -> Stop -#endif - --- | --- >>> :{ --- unfoldr step s = --- case step s of --- Nothing -> Stream.nil --- Just (a, b) -> a `Stream.cons` unfoldr step b --- :} --- --- Build a stream by unfolding a /pure/ step function @step@ starting from a --- seed @s@. The step function returns the next element in the stream and the --- next seed value. When it is done it returns 'Nothing' and the stream ends. --- For example, --- --- >>> :{ --- let f b = --- if b > 2 --- then Nothing --- else Just (b, b + 1) --- in Stream.fold Fold.toList $ Stream.unfoldr f 0 --- :} --- [0,1,2] --- -{-# INLINE_LATE unfoldr #-} -unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a -unfoldr f = unfoldrM (return . f) - ------------------------------------------------------------------------------- --- From values ------------------------------------------------------------------------------- - --- | --- >>> repeatM = Stream.sequence . Stream.repeat --- >>> repeatM = fix . Stream.consM --- >>> repeatM = cycle1 . Stream.fromEffect --- --- Generate a stream by repeatedly executing a monadic action forever. --- --- >>> :{ --- repeatAction = --- Stream.repeatM (threadDelay 1000000 >> print 1) --- & Stream.take 10 --- & Stream.fold Fold.drain --- :} --- -{-# INLINE_NORMAL repeatM #-} -repeatM :: Monad m => m a -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -repeatM = unfold Unfold.repeatM -#else -repeatM x = Stream (\_ _ -> x >>= \r -> return $ Yield r ()) () -#endif - --- | --- Generate an infinite stream by repeating a pure value. --- --- >>> repeat x = Stream.repeatM (pure x) --- -{-# INLINE_NORMAL repeat #-} -repeat :: Monad m => a -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -repeat x = repeatM (pure x) -#else -repeat x = Stream (\_ _ -> return $ Yield x ()) () -#endif - --- Adapted from the vector package - --- | --- >>> replicateM n = Stream.sequence . Stream.replicate n --- --- Generate a stream by performing a monadic action @n@ times. -{-# INLINE_NORMAL replicateM #-} -replicateM :: Monad m => Int -> m a -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -replicateM n p = unfold Unfold.replicateM (n, p) -#else -replicateM n p = Stream step n - where - {-# INLINE_LATE step #-} - step _ (i :: Int) - | i <= 0 = return Stop - | otherwise = do - x <- p - return $ Yield x (i - 1) -#endif - --- | --- >>> replicate n = Stream.take n . Stream.repeat --- >>> replicate n x = Stream.replicateM n (pure x) --- --- Generate a stream of length @n@ by repeating a value @n@ times. --- -{-# INLINE_NORMAL replicate #-} -replicate :: Monad m => Int -> a -> Stream m a -replicate n x = replicateM n (return x) - ------------------------------------------------------------------------------- --- Enumeration of Num ------------------------------------------------------------------------------- - --- | For floating point numbers if the increment is less than the precision then --- it just gets lost. Therefore we cannot always increment it correctly by just --- repeated addition. --- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15 --- 9007199254740992 + 2 :: Double => 9.007199254740994e15 --- --- Instead we accumulate the increment counter and compute the increment --- every time before adding it to the starting number. --- --- This works for Integrals as well as floating point numbers, but --- enumerateFromStepIntegral is faster for integrals. -{-# INLINE_NORMAL enumerateFromStepNum #-} -enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -enumerateFromStepNum from stride = - unfold Unfold.enumerateFromStepNum (from, stride) -#else -enumerateFromStepNum from stride = Stream step 0 - where - {-# INLINE_LATE step #-} - step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1) -#endif - -{-# INLINE_NORMAL enumerateFromNum #-} -enumerateFromNum :: (Monad m, Num a) => a -> Stream m a -enumerateFromNum from = enumerateFromStepNum from 1 - -{-# INLINE_NORMAL enumerateFromThenNum #-} -enumerateFromThenNum :: (Monad m, Num a) => a -> a -> Stream m a -enumerateFromThenNum from next = enumerateFromStepNum from (next - from) - ------------------------------------------------------------------------------- --- Enumeration of Integrals ------------------------------------------------------------------------------- - -#ifndef USE_UNFOLDS_EVERYWHERE -data EnumState a = EnumInit | EnumYield a a a | EnumStop - -{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-} -enumerateFromThenToIntegralUp - :: (Monad m, Integral a) - => a -> a -> a -> Stream m a -enumerateFromThenToIntegralUp from next to = Stream step EnumInit - where - {-# INLINE_LATE step #-} - step _ EnumInit = - return $ - if to < next - then if to < from - then Stop - else Yield from EnumStop - else -- from <= next <= to - let stride = next - from - in Skip $ EnumYield from stride (to - stride) - - step _ (EnumYield x stride toMinus) = - return $ - if x > toMinus - then Yield x EnumStop - else Yield x $ EnumYield (x + stride) stride toMinus - - step _ EnumStop = return Stop - -{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-} -enumerateFromThenToIntegralDn - :: (Monad m, Integral a) - => a -> a -> a -> Stream m a -enumerateFromThenToIntegralDn from next to = Stream step EnumInit - where - {-# INLINE_LATE step #-} - step _ EnumInit = - return $ if to > next - then if to > from - then Stop - else Yield from EnumStop - else -- from >= next >= to - let stride = next - from - in Skip $ EnumYield from stride (to - stride) - - step _ (EnumYield x stride toMinus) = - return $ - if x < toMinus - then Yield x EnumStop - else Yield x $ EnumYield (x + stride) stride toMinus - - step _ EnumStop = return Stop -#endif - --- XXX This can perhaps be simplified and written in terms of --- enumeratFromStepIntegral as we have done in unfolds. - --- | Enumerate an 'Integral' type in steps up to a given limit. --- @enumerateFromThenToIntegral from then to@ generates a finite stream whose --- first element is @from@, the second element is @then@ and the successive --- elements are in increments of @then - from@ up to @to@. --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenToIntegral 0 2 6 --- [0,2,4,6] --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenToIntegral 0 (-2) (-6) --- [0,-2,-4,-6] --- -{-# INLINE_NORMAL enumerateFromThenToIntegral #-} -enumerateFromThenToIntegral - :: (Monad m, Integral a) - => a -> a -> a -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -enumerateFromThenToIntegral from next to = - unfold Unfold.enumerateFromThenToIntegral (from, next, to) -#else -enumerateFromThenToIntegral from next to - | next >= from = enumerateFromThenToIntegralUp from next to - | otherwise = enumerateFromThenToIntegralDn from next to -#endif - --- | Enumerate an 'Integral' type in steps. @enumerateFromThenIntegral from --- then@ generates a stream whose first element is @from@, the second element --- is @then@ and the successive elements are in increments of @then - from@. --- The stream is bounded by the size of the 'Integral' type. --- --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThenIntegral (0 :: Int) 2 --- [0,2,4,6] --- --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThenIntegral (0 :: Int) (-2) --- [0,-2,-4,-6] --- -{-# INLINE_NORMAL enumerateFromThenIntegral #-} -enumerateFromThenIntegral - :: (Monad m, Integral a, Bounded a) - => a -> a -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -enumerateFromThenIntegral from next = - unfold Unfold.enumerateFromThenIntegralBounded (from, next) -#else -enumerateFromThenIntegral from next = - if next > from - then enumerateFromThenToIntegralUp from next maxBound - else enumerateFromThenToIntegralDn from next minBound -#endif - --- | @enumerateFromStepIntegral from step@ generates an infinite stream whose --- first element is @from@ and the successive elements are in increments of --- @step@. --- --- CAUTION: This function is not safe for finite integral types. It does not --- check for overflow, underflow or bounds. --- --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromStepIntegral 0 2 --- [0,2,4,6] --- --- >>> Stream.fold Fold.toList $ Stream.take 3 $ Stream.enumerateFromStepIntegral 0 (-2) --- [0,-2,-4] --- -{-# INLINE_NORMAL enumerateFromStepIntegral #-} -enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -enumerateFromStepIntegral from stride = - unfold Unfold.enumerateFromStepIntegral (from, stride) -#else -enumerateFromStepIntegral from stride = - from `seq` stride `seq` Stream step from - where - {-# INLINE_LATE step #-} - step _ !x = return $ Yield x $! (x + stride) -#endif - --- | Enumerate an 'Integral' type up to a given limit. --- @enumerateFromToIntegral from to@ generates a finite stream whose first --- element is @from@ and successive elements are in increments of @1@ up to --- @to@. --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromToIntegral 0 4 --- [0,1,2,3,4] --- -{-# INLINE enumerateFromToIntegral #-} -enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a -enumerateFromToIntegral from to = - takeWhile (<= to) $ enumerateFromStepIntegral from 1 - --- | Enumerate an 'Integral' type. @enumerateFromIntegral from@ generates a --- stream whose first element is @from@ and the successive elements are in --- increments of @1@. The stream is bounded by the size of the 'Integral' type. --- --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromIntegral (0 :: Int) --- [0,1,2,3] --- -{-# INLINE enumerateFromIntegral #-} -enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a -enumerateFromIntegral from = enumerateFromToIntegral from maxBound - ------------------------------------------------------------------------------- --- Enumeration of Fractionals ------------------------------------------------------------------------------- - --- We cannot write a general function for Num. The only way to write code --- portable between the two is to use a 'Real' constraint and convert between --- Fractional and Integral using fromRational which is horribly slow. - --- Even though the underlying implementation of enumerateFromFractional and --- enumerateFromThenFractional works for any 'Num' we have restricted these to --- 'Fractional' because these do not perform any bounds check, in contrast to --- integral versions and are therefore not equivalent substitutes for those. - --- | Numerically stable enumeration from a 'Fractional' number in steps of size --- @1@. @enumerateFromFractional from@ generates a stream whose first element --- is @from@ and the successive elements are in increments of @1@. No overflow --- or underflow checks are performed. --- --- This is the equivalent to 'enumFrom' for 'Fractional' types. For example: --- --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromFractional 1.1 --- [1.1,2.1,3.1,4.1] --- -{-# INLINE enumerateFromFractional #-} -enumerateFromFractional :: (Monad m, Fractional a) => a -> Stream m a -enumerateFromFractional = enumerateFromNum - --- | Numerically stable enumeration from a 'Fractional' number in steps. --- @enumerateFromThenFractional from then@ generates a stream whose first --- element is @from@, the second element is @then@ and the successive elements --- are in increments of @then - from@. No overflow or underflow checks are --- performed. --- --- This is the equivalent of 'enumFromThen' for 'Fractional' types. For --- example: --- --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThenFractional 1.1 2.1 --- [1.1,2.1,3.1,4.1] --- --- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThenFractional 1.1 (-2.1) --- [1.1,-2.1,-5.300000000000001,-8.500000000000002] --- -{-# INLINE enumerateFromThenFractional #-} -enumerateFromThenFractional - :: (Monad m, Fractional a) - => a -> a -> Stream m a -enumerateFromThenFractional = enumerateFromThenNum - --- | Numerically stable enumeration from a 'Fractional' number to a given --- limit. @enumerateFromToFractional from to@ generates a finite stream whose --- first element is @from@ and successive elements are in increments of @1@ up --- to @to@. --- --- This is the equivalent of 'enumFromTo' for 'Fractional' types. For --- example: --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromToFractional 1.1 4 --- [1.1,2.1,3.1,4.1] --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromToFractional 1.1 4.6 --- [1.1,2.1,3.1,4.1,5.1] --- --- Notice that the last element is equal to the specified @to@ value after --- rounding to the nearest integer. --- -{-# INLINE_NORMAL enumerateFromToFractional #-} -enumerateFromToFractional - :: (Monad m, Fractional a, Ord a) - => a -> a -> Stream m a -enumerateFromToFractional from to = - takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1 - --- | Numerically stable enumeration from a 'Fractional' number in steps up to a --- given limit. @enumerateFromThenToFractional from then to@ generates a --- finite stream whose first element is @from@, the second element is @then@ --- and the successive elements are in increments of @then - from@ up to @to@. --- --- This is the equivalent of 'enumFromThenTo' for 'Fractional' types. For --- example: --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenToFractional 0.1 2 6 --- [0.1,2.0,3.9,5.799999999999999] --- --- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenToFractional 0.1 (-2) (-6) --- [0.1,-2.0,-4.1000000000000005,-6.200000000000001] --- -{-# INLINE_NORMAL enumerateFromThenToFractional #-} -enumerateFromThenToFractional - :: (Monad m, Fractional a, Ord a) - => a -> a -> a -> Stream m a -enumerateFromThenToFractional from next to = - takeWhile predicate $ enumerateFromThenFractional from next - where - mid = (next - from) / 2 - predicate | next >= from = (<= to + mid) - | otherwise = (>= to + mid) - -------------------------------------------------------------------------------- --- Enumeration of Enum types not larger than Int -------------------------------------------------------------------------------- --- --- | 'enumerateFromTo' for 'Enum' types not larger than 'Int'. --- -{-# INLINE enumerateFromToSmall #-} -enumerateFromToSmall :: (Monad m, Enum a) => a -> a -> Stream m a -enumerateFromToSmall from to = - fmap toEnum - $ enumerateFromToIntegral (fromEnum from) (fromEnum to) - --- | 'enumerateFromThenTo' for 'Enum' types not larger than 'Int'. --- -{-# INLINE enumerateFromThenToSmall #-} -enumerateFromThenToSmall :: (Monad m, Enum a) - => a -> a -> a -> Stream m a -enumerateFromThenToSmall from next to = - fmap toEnum - $ enumerateFromThenToIntegral - (fromEnum from) (fromEnum next) (fromEnum to) - --- | 'enumerateFromThen' for 'Enum' types not larger than 'Int'. --- --- Note: We convert the 'Enum' to 'Int' and enumerate the 'Int'. If a --- type is bounded but does not have a 'Bounded' instance then we can go on --- enumerating it beyond the legal values of the type, resulting in the failure --- of 'toEnum' when converting back to 'Enum'. Therefore we require a 'Bounded' --- instance for this function to be safely used. --- -{-# INLINE enumerateFromThenSmallBounded #-} -enumerateFromThenSmallBounded :: (Monad m, Enumerable a, Bounded a) - => a -> a -> Stream m a -enumerateFromThenSmallBounded from next = - if fromEnum next >= fromEnum from - then enumerateFromThenTo from next maxBound - else enumerateFromThenTo from next minBound - -------------------------------------------------------------------------------- --- Enumerable type class -------------------------------------------------------------------------------- --- --- NOTE: We would like to rewrite calls to fromList [1..] etc. to stream --- enumerations like this: --- --- {-# RULES "fromList enumFrom" [1] --- forall (a :: Int). D.fromList (enumFrom a) = D.enumerateFromIntegral a #-} --- --- But this does not work because enumFrom is a class method and GHC rewrites --- it quickly, so we do not get a chance to have our rule fired. - --- | Types that can be enumerated as a stream. The operations in this type --- class are equivalent to those in the 'Enum' type class, except that these --- generate a stream instead of a list. Use the functions in --- "Streamly.Internal.Data.Stream.Enumeration" module to define new instances. --- -class Enum a => Enumerable a where - -- | @enumerateFrom from@ generates a stream starting with the element - -- @from@, enumerating up to 'maxBound' when the type is 'Bounded' or - -- generating an infinite stream when the type is not 'Bounded'. - -- - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFrom (0 :: Int) - -- [0,1,2,3] - -- - -- For 'Fractional' types, enumeration is numerically stable. However, no - -- overflow or underflow checks are performed. - -- - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFrom 1.1 - -- [1.1,2.1,3.1,4.1] - -- - enumerateFrom :: (Monad m) => a -> Stream m a - - -- | Generate a finite stream starting with the element @from@, enumerating - -- the type up to the value @to@. If @to@ is smaller than @from@ then an - -- empty stream is returned. - -- - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromTo 0 4 - -- [0,1,2,3,4] - -- - -- For 'Fractional' types, the last element is equal to the specified @to@ - -- value after rounding to the nearest integral value. - -- - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromTo 1.1 4 - -- [1.1,2.1,3.1,4.1] - -- - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromTo 1.1 4.6 - -- [1.1,2.1,3.1,4.1,5.1] - -- - enumerateFromTo :: (Monad m) => a -> a -> Stream m a - - -- | @enumerateFromThen from then@ generates a stream whose first element - -- is @from@, the second element is @then@ and the successive elements are - -- in increments of @then - from@. Enumeration can occur downwards or - -- upwards depending on whether @then@ comes before or after @from@. For - -- 'Bounded' types the stream ends when 'maxBound' is reached, for - -- unbounded types it keeps enumerating infinitely. - -- - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThen 0 2 - -- [0,2,4,6] - -- - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.enumerateFromThen 0 (-2) - -- [0,-2,-4,-6] - -- - enumerateFromThen :: (Monad m) => a -> a -> Stream m a - - -- | @enumerateFromThenTo from then to@ generates a finite stream whose - -- first element is @from@, the second element is @then@ and the successive - -- elements are in increments of @then - from@ up to @to@. Enumeration can - -- occur downwards or upwards depending on whether @then@ comes before or - -- after @from@. - -- - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenTo 0 2 6 - -- [0,2,4,6] - -- - -- >>> Stream.fold Fold.toList $ Stream.enumerateFromThenTo 0 (-2) (-6) - -- [0,-2,-4,-6] - -- - enumerateFromThenTo :: (Monad m) => a -> a -> a -> Stream m a - --- MAYBE: Sometimes it is more convenient to know the count rather then the --- ending or starting element. For those cases we can define the folllowing --- APIs. All of these will work only for bounded types if we represent the --- count by Int. --- --- enumerateN --- enumerateFromN --- enumerateToN --- enumerateFromStep --- enumerateFromStepN - -------------------------------------------------------------------------------- --- Convenient functions for bounded types -------------------------------------------------------------------------------- --- --- | --- > enumerate = enumerateFrom minBound --- --- Enumerate a 'Bounded' type from its 'minBound' to 'maxBound' --- -{-# INLINE enumerate #-} -enumerate :: (Monad m, Bounded a, Enumerable a) => Stream m a -enumerate = enumerateFrom minBound - --- | --- >>> enumerateTo = Stream.enumerateFromTo minBound --- --- Enumerate a 'Bounded' type from its 'minBound' to specified value. --- -{-# INLINE enumerateTo #-} -enumerateTo :: (Monad m, Bounded a, Enumerable a) => a -> Stream m a -enumerateTo = enumerateFromTo minBound - --- | --- >>> enumerateFromBounded from = Stream.enumerateFromTo from maxBound --- --- 'enumerateFrom' for 'Bounded' 'Enum' types. --- -{-# INLINE enumerateFromBounded #-} -enumerateFromBounded :: (Monad m, Enumerable a, Bounded a) - => a -> Stream m a -enumerateFromBounded from = enumerateFromTo from maxBound - -------------------------------------------------------------------------------- --- Enumerable Instances -------------------------------------------------------------------------------- --- --- For Enum types smaller than or equal to Int size. -#define ENUMERABLE_BOUNDED_SMALL(SMALL_TYPE) \ -instance Enumerable SMALL_TYPE where { \ - {-# INLINE enumerateFrom #-}; \ - enumerateFrom = enumerateFromBounded; \ - {-# INLINE enumerateFromThen #-}; \ - enumerateFromThen = enumerateFromThenSmallBounded; \ - {-# INLINE enumerateFromTo #-}; \ - enumerateFromTo = enumerateFromToSmall; \ - {-# INLINE enumerateFromThenTo #-}; \ - enumerateFromThenTo = enumerateFromThenToSmall } - -ENUMERABLE_BOUNDED_SMALL(()) -ENUMERABLE_BOUNDED_SMALL(Bool) -ENUMERABLE_BOUNDED_SMALL(Ordering) -ENUMERABLE_BOUNDED_SMALL(Char) - --- For bounded Integral Enum types, may be larger than Int. -#define ENUMERABLE_BOUNDED_INTEGRAL(INTEGRAL_TYPE) \ -instance Enumerable INTEGRAL_TYPE where { \ - {-# INLINE enumerateFrom #-}; \ - enumerateFrom = enumerateFromIntegral; \ - {-# INLINE enumerateFromThen #-}; \ - enumerateFromThen = enumerateFromThenIntegral; \ - {-# INLINE enumerateFromTo #-}; \ - enumerateFromTo = enumerateFromToIntegral; \ - {-# INLINE enumerateFromThenTo #-}; \ - enumerateFromThenTo = enumerateFromThenToIntegral } - -ENUMERABLE_BOUNDED_INTEGRAL(Int) -ENUMERABLE_BOUNDED_INTEGRAL(Int8) -ENUMERABLE_BOUNDED_INTEGRAL(Int16) -ENUMERABLE_BOUNDED_INTEGRAL(Int32) -ENUMERABLE_BOUNDED_INTEGRAL(Int64) -ENUMERABLE_BOUNDED_INTEGRAL(Word) -ENUMERABLE_BOUNDED_INTEGRAL(Word8) -ENUMERABLE_BOUNDED_INTEGRAL(Word16) -ENUMERABLE_BOUNDED_INTEGRAL(Word32) -ENUMERABLE_BOUNDED_INTEGRAL(Word64) - --- For unbounded Integral Enum types. -#define ENUMERABLE_UNBOUNDED_INTEGRAL(INTEGRAL_TYPE) \ -instance Enumerable INTEGRAL_TYPE where { \ - {-# INLINE enumerateFrom #-}; \ - enumerateFrom from = enumerateFromStepIntegral from 1; \ - {-# INLINE enumerateFromThen #-}; \ - enumerateFromThen from next = \ - enumerateFromStepIntegral from (next - from); \ - {-# INLINE enumerateFromTo #-}; \ - enumerateFromTo = enumerateFromToIntegral; \ - {-# INLINE enumerateFromThenTo #-}; \ - enumerateFromThenTo = enumerateFromThenToIntegral } - -ENUMERABLE_UNBOUNDED_INTEGRAL(Integer) -ENUMERABLE_UNBOUNDED_INTEGRAL(Natural) - -#define ENUMERABLE_FRACTIONAL(FRACTIONAL_TYPE,CONSTRAINT) \ -instance (CONSTRAINT) => Enumerable FRACTIONAL_TYPE where { \ - {-# INLINE enumerateFrom #-}; \ - enumerateFrom = enumerateFromFractional; \ - {-# INLINE enumerateFromThen #-}; \ - enumerateFromThen = enumerateFromThenFractional; \ - {-# INLINE enumerateFromTo #-}; \ - enumerateFromTo = enumerateFromToFractional; \ - {-# INLINE enumerateFromThenTo #-}; \ - enumerateFromThenTo = enumerateFromThenToFractional } - -ENUMERABLE_FRACTIONAL(Float,) -ENUMERABLE_FRACTIONAL(Double,) -ENUMERABLE_FRACTIONAL((Fixed a),HasResolution a) -ENUMERABLE_FRACTIONAL((Ratio a),Integral a) - -instance Enumerable a => Enumerable (Identity a) where - {-# INLINE enumerateFrom #-} - enumerateFrom (Identity from) = - fmap Identity $ enumerateFrom from - {-# INLINE enumerateFromThen #-} - enumerateFromThen (Identity from) (Identity next) = - fmap Identity $ enumerateFromThen from next - {-# INLINE enumerateFromTo #-} - enumerateFromTo (Identity from) (Identity to) = - fmap Identity $ enumerateFromTo from to - {-# INLINE enumerateFromThenTo #-} - enumerateFromThenTo (Identity from) (Identity next) (Identity to) = - fmap Identity - $ enumerateFromThenTo from next to - --- TODO -{- -instance Enumerable a => Enumerable (Last a) -instance Enumerable a => Enumerable (First a) -instance Enumerable a => Enumerable (Max a) -instance Enumerable a => Enumerable (Min a) -instance Enumerable a => Enumerable (Const a b) -instance Enumerable (f a) => Enumerable (Alt f a) -instance Enumerable (f a) => Enumerable (Ap f a) --} ------------------------------------------------------------------------------- --- Time Enumeration ------------------------------------------------------------------------------- - --- | @timesWith g@ returns a stream of time value tuples. The first component --- of the tuple is an absolute time reference (epoch) denoting the start of the --- stream and the second component is a time relative to the reference. --- --- The argument @g@ specifies the granularity of the relative time in seconds. --- A lower granularity clock gives higher precision but is more expensive in --- terms of CPU usage. Any granularity lower than 1 ms is treated as 1 ms. --- --- >>> import Control.Concurrent (threadDelay) --- >>> f = Fold.drainMapM (\x -> print x >> threadDelay 1000000) --- >>> Stream.fold f $ Stream.take 3 $ Stream.timesWith 0.01 --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE_NORMAL timesWith #-} -timesWith :: MonadIO m => Double -> Stream m (AbsTime, RelTime64) -timesWith g = Stream step Nothing - - where - - {-# INLINE_LATE step #-} - step _ Nothing = do - clock <- liftIO $ asyncClock Monotonic g - a <- liftIO $ readClock clock - return $ Skip $ Just (clock, a) - - step _ s@(Just (clock, t0)) = do - a <- liftIO $ readClock clock - -- XXX we can perhaps use an AbsTime64 using a 64 bit Int for - -- efficiency. or maybe we can use a representation using Double for - -- floating precision time - return $ Yield (toAbsTime t0, toRelTime64 (a - t0)) s - --- | @absTimesWith g@ returns a stream of absolute timestamps using a clock of --- granularity @g@ specified in seconds. A low granularity clock is more --- expensive in terms of CPU usage. Any granularity lower than 1 ms is treated --- as 1 ms. --- --- >>> f = Fold.drainMapM print --- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.absTimesWith 0.01 --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE absTimesWith #-} -absTimesWith :: MonadIO m => Double -> Stream m AbsTime -absTimesWith = fmap (uncurry addToAbsTime64) . timesWith - --- | @relTimesWith g@ returns a stream of relative time values starting from 0, --- using a clock of granularity @g@ specified in seconds. A low granularity --- clock is more expensive in terms of CPU usage. Any granularity lower than 1 --- ms is treated as 1 ms. --- --- >>> f = Fold.drainMapM print --- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.relTimesWith 0.01 --- RelTime64 (NanoSecond64 ...) --- RelTime64 (NanoSecond64 ...) --- RelTime64 (NanoSecond64 ...) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE relTimesWith #-} -relTimesWith :: MonadIO m => Double -> Stream m RelTime64 -relTimesWith = fmap snd . timesWith - --- | @times@ returns a stream of time value tuples with clock of 10 ms --- granularity. The first component of the tuple is an absolute time reference --- (epoch) denoting the start of the stream and the second component is a time --- relative to the reference. --- --- >>> f = Fold.drainMapM (\x -> print x >> threadDelay 1000000) --- >>> Stream.fold f $ Stream.take 3 $ Stream.times --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- (AbsTime (TimeSpec {sec = ..., nsec = ...}),RelTime64 (NanoSecond64 ...)) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE times #-} -times :: MonadIO m => Stream m (AbsTime, RelTime64) -times = timesWith 0.01 - --- | @absTimes@ returns a stream of absolute timestamps using a clock of 10 ms --- granularity. --- --- >>> f = Fold.drainMapM print --- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.absTimes --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- AbsTime (TimeSpec {sec = ..., nsec = ...}) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE absTimes #-} -absTimes :: MonadIO m => Stream m AbsTime -absTimes = fmap (uncurry addToAbsTime64) times - --- | @relTimes@ returns a stream of relative time values starting from 0, --- using a clock of granularity 10 ms. --- --- >>> f = Fold.drainMapM print --- >>> Stream.fold f $ Stream.delayPre 1 $ Stream.take 3 $ Stream.relTimes --- RelTime64 (NanoSecond64 ...) --- RelTime64 (NanoSecond64 ...) --- RelTime64 (NanoSecond64 ...) --- --- Note: This API is not safe on 32-bit machines. --- --- /Pre-release/ --- -{-# INLINE relTimes #-} -relTimes :: MonadIO m => Stream m RelTime64 -relTimes = fmap snd times - --- | @durations g@ returns a stream of relative time values measuring the time --- elapsed since the immediate predecessor element of the stream was generated. --- The first element of the stream is always 0. @durations@ uses a clock of --- granularity @g@ specified in seconds. A low granularity clock is more --- expensive in terms of CPU usage. The minimum granularity is 1 millisecond. --- Durations lower than 1 ms will be 0. --- --- Note: This API is not safe on 32-bit machines. --- --- /Unimplemented/ --- -{-# INLINE durations #-} -durations :: -- Monad m => - Double -> t m RelTime64 -durations = undefined - --- | Generate a singleton event at or after the specified absolute time. Note --- that this is different from a threadDelay, a threadDelay starts from the --- time when the action is evaluated, whereas if we use AbsTime based timeout --- it will immediately expire if the action is evaluated too late. --- --- /Unimplemented/ --- -{-# INLINE timeout #-} -timeout :: -- Monad m => - AbsTime -> t m () -timeout = undefined - -------------------------------------------------------------------------------- --- From Generators -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL fromIndicesM #-} -fromIndicesM :: Monad m => (Int -> m a) -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -fromIndicesM gen = unfold (Unfold.fromIndicesM gen) 0 -#else -fromIndicesM gen = Stream step 0 - where - {-# INLINE_LATE step #-} - step _ i = do - x <- gen i - return $ Yield x (i + 1) -#endif - -{-# INLINE fromIndices #-} -fromIndices :: Monad m => (Int -> a) -> Stream m a -fromIndices gen = fromIndicesM (return . gen) - --- Adapted from the vector package -{-# INLINE_NORMAL generateM #-} -generateM :: Monad m => Int -> (Int -> m a) -> Stream m a -generateM n gen = n `seq` Stream step 0 - where - {-# INLINE_LATE step #-} - step _ i | i < n = do - x <- gen i - return $ Yield x (i + 1) - | otherwise = return Stop - -{-# INLINE generate #-} -generate :: Monad m => Int -> (Int -> a) -> Stream m a -generate n gen = generateM n (return . gen) - -------------------------------------------------------------------------------- --- Iteration -------------------------------------------------------------------------------- - --- | --- >>> iterateM f m = m >>= \a -> return a `Stream.consM` iterateM f (f a) --- --- Generate an infinite stream with the first element generated by the action --- @m@ and each successive element derived by applying the monadic function --- @f@ on the previous element. --- --- >>> :{ --- Stream.iterateM (\x -> print x >> return (x + 1)) (return 0) --- & Stream.take 3 --- & Stream.fold Fold.toList --- :} --- 0 --- 1 --- [0,1,2] --- -{-# INLINE_NORMAL iterateM #-} -iterateM :: Monad m => (a -> m a) -> m a -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -iterateM step = unfold (Unfold.iterateM step) -#else -iterateM step = Stream (\_ st -> st >>= \(!x) -> return $ Yield x (step x)) -#endif - --- | --- >>> iterate f x = x `Stream.cons` iterate f x --- --- Generate an infinite stream with @x@ as the first element and each --- successive element derived by applying the function @f@ on the previous --- element. --- --- >>> Stream.fold Fold.toList $ Stream.take 5 $ Stream.iterate (+1) 1 --- [1,2,3,4,5] --- -{-# INLINE_NORMAL iterate #-} -iterate :: Monad m => (a -> a) -> a -> Stream m a -iterate step st = iterateM (return . step) (return st) - -------------------------------------------------------------------------------- --- From containers -------------------------------------------------------------------------------- - --- | Convert a list of monadic actions to a 'Stream' -{-# INLINE_LATE fromListM #-} -fromListM :: Monad m => [m a] -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -fromListM = unfold Unfold.fromListM -#else -fromListM = Stream step - where - {-# INLINE_LATE step #-} - step _ (m:ms) = m >>= \x -> return $ Yield x ms - step _ [] = return Stop -#endif - --- | --- >>> fromFoldable = Prelude.foldr Stream.cons Stream.nil --- --- Construct a stream from a 'Foldable' containing pure values: --- --- /WARNING: O(n^2), suitable only for a small number of --- elements in the stream/ --- -{-# INLINE fromFoldable #-} -fromFoldable :: (Monad m, Foldable f) => f a -> Stream m a -fromFoldable = Prelude.foldr cons nil - --- | --- >>> fromFoldableM = Prelude.foldr Stream.consM Stream.nil --- --- Construct a stream from a 'Foldable' containing pure values: --- --- /WARNING: O(n^2), suitable only for a small number of --- elements in the stream/ --- -{-# INLINE fromFoldableM #-} -fromFoldableM :: (Monad m, Foldable f) => f (m a) -> Stream m a -fromFoldableM = Prelude.foldr consM nil - -------------------------------------------------------------------------------- --- From pointers -------------------------------------------------------------------------------- - --- | Keep reading 'Storable' elements from 'Ptr' onwards. --- --- /Unsafe:/ The caller is responsible for safe addressing. --- --- /Pre-release/ -{-# INLINE fromPtr #-} -fromPtr :: forall m a. (MonadIO m, Storable a) => Ptr a -> Stream m a -fromPtr = Stream step - - where - - {-# INLINE_LATE step #-} - step _ p = do - x <- liftIO $ peek p - return $ Yield x (PTR_NEXT(p, a)) - --- | Take @n@ 'Storable' elements starting from 'Ptr' onwards. --- --- >>> fromPtrN n = Stream.take n . Stream.fromPtr --- --- /Unsafe:/ The caller is responsible for safe addressing. --- --- /Pre-release/ -{-# INLINE fromPtrN #-} -fromPtrN :: (MonadIO m, Storable a) => Int -> Ptr a -> Stream m a -fromPtrN n = take n . fromPtr - --- | Read bytes from an 'Addr#' until a 0 byte is encountered, the 0 byte is --- not included in the stream. --- --- >>> :set -XMagicHash --- >>> fromByteStr# addr = Stream.takeWhile (/= 0) $ Stream.fromPtr $ Ptr addr --- --- /Unsafe:/ The caller is responsible for safe addressing. --- --- Note that this is completely safe when reading from Haskell string --- literals because they are guaranteed to be NULL terminated: --- --- >>> Stream.fold Fold.toList $ Stream.fromByteStr# "\1\2\3\0"# --- [1,2,3] --- -{-# INLINE fromByteStr# #-} -fromByteStr# :: MonadIO m => Addr# -> Stream m Word8 -fromByteStr# addr = - takeWhile (/= 0) $ fromPtr $ Ptr addr diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Lift.hs b/src/Streamly/Internal/Data/Stream/StreamD/Lift.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Lift.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Lift --- Copyright : (c) 2018 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Transform the underlying monad of a stream. - -module Streamly.Internal.Data.Stream.StreamD.Lift - ( - -- * Generalize Inner Monad - morphInner - , generalizeInner - - -- * Transform Inner Monad - , liftInnerWith - , runInnerWith - , runInnerWithState - ) -where - -#include "inline.hs" - -import Data.Functor.Identity (Identity(..)) -import Streamly.Internal.Data.SVar.Type (adaptState) - -import Streamly.Internal.Data.Stream.StreamD.Type - -#include "DocTestDataStream.hs" - -------------------------------------------------------------------------------- --- Generalize Inner Monad -------------------------------------------------------------------------------- - --- | Transform the inner monad of a stream using a natural transformation. --- --- Example, generalize the inner monad from Identity to any other: --- --- >>> generalizeInner = Stream.morphInner (return . runIdentity) --- --- Also known as hoist. --- -{-# INLINE_NORMAL morphInner #-} -morphInner :: Monad n => (forall x. m x -> n x) -> Stream m a -> Stream n a -morphInner f (Stream step state) = Stream step' state - where - {-# INLINE_LATE step' #-} - step' gst st = do - r <- f $ step (adaptState gst) st - return $ case r of - Yield x s -> Yield x s - Skip s -> Skip s - Stop -> Stop - --- | Generalize the inner monad of the stream from 'Identity' to any monad. --- --- Definition: --- --- >>> generalizeInner = Stream.morphInner (return . runIdentity) --- -{-# INLINE generalizeInner #-} -generalizeInner :: Monad m => Stream Identity a -> Stream m a -generalizeInner = morphInner (return . runIdentity) - -------------------------------------------------------------------------------- --- Transform Inner Monad -------------------------------------------------------------------------------- - --- | Lift the inner monad @m@ of a stream @Stream m a@ to @t m@ using the --- supplied lift function. --- -{-# INLINE_NORMAL liftInnerWith #-} -liftInnerWith :: (Monad (t m)) => - (forall b. m b -> t m b) -> Stream m a -> Stream (t m) a -liftInnerWith lift (Stream step state) = Stream step1 state - - where - - {-# INLINE_LATE step1 #-} - step1 gst st = do - r <- lift $ step (adaptState gst) st - return $ case r of - Yield x s -> Yield x s - Skip s -> Skip s - Stop -> Stop - --- | Evaluate the inner monad of a stream using the supplied runner function. --- -{-# INLINE_NORMAL runInnerWith #-} -runInnerWith :: Monad m => - (forall b. t m b -> m b) -> Stream (t m) a -> Stream m a -runInnerWith run (Stream step state) = Stream step1 state - - where - - {-# INLINE_LATE step1 #-} - step1 gst st = do - r <- run $ step (adaptState gst) st - return $ case r of - Yield x s -> Yield x s - Skip s -> Skip s - Stop -> Stop - --- | Evaluate the inner monad of a stream using the supplied stateful runner --- function and the initial state. The state returned by an invocation of the --- runner is supplied as input state to the next invocation. --- -{-# INLINE_NORMAL runInnerWithState #-} -runInnerWithState :: Monad m => - (forall b. s -> t m b -> m (b, s)) - -> m s - -> Stream (t m) a - -> Stream m (s, a) -runInnerWithState run initial (Stream step state) = - Stream step1 (state, initial) - - where - - {-# INLINE_LATE step1 #-} - step1 gst (st, action) = do - sv <- action - (r, !sv1) <- run sv (step (adaptState gst) st) - return $ case r of - Yield x s -> Yield (sv1, x) (s, return sv1) - Skip s -> Skip (s, return sv1) - Stop -> Stop diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs b/src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs +++ /dev/null @@ -1,3111 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Nesting --- Copyright : (c) 2018 Composewell Technologies --- (c) Roman Leshchinskiy 2008-2010 --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- This module contains transformations involving multiple streams, unfolds or --- folds. There are two types of transformations generational or eliminational. --- Generational transformations are like the "Generate" module but they --- generate a stream by combining streams instead of elements. Eliminational --- transformations are like the "Eliminate" module but they transform a stream --- by eliminating parts of the stream instead of eliminating the whole stream. --- --- These combinators involve transformation, generation, elimination so can be --- classified under any of those. --- --- Ultimately these operations should be supported by Unfolds, Pipes and Folds, --- and this module may become redundant. - --- The zipWithM combinator in this module has been adapted from the vector --- package (c) Roman Leshchinskiy. --- -module Streamly.Internal.Data.Stream.StreamD.Nesting - ( - -- * Generate - -- | Combining streams to generate streams. - - -- ** Combine Two Streams - -- | Functions ending in the shape: - -- - -- @t m a -> t m a -> t m a@. - - -- *** Appending - -- | Append a stream after another. A special case of concatMap or - -- unfoldMany. - AppendState(..) - , append - - -- *** Interleaving - -- | Interleave elements from two streams alternately. A special case of - -- unfoldInterleave. - , InterleaveState(..) - , interleave - , interleaveMin - , interleaveFst - , interleaveFstSuffix - - -- *** Scheduling - -- | Execute streams alternately irrespective of whether they generate - -- elements or not. Note 'interleave' would execute a stream until it - -- yields an element. A special case of unfoldRoundRobin. - , roundRobin -- interleaveFair?/ParallelFair - - -- *** Zipping - -- | Zip corresponding elements of two streams. - , zipWith - , zipWithM - - -- *** Merging - -- | Interleave elements from two streams based on a condition. - , mergeBy - , mergeByM - , mergeMinBy - , mergeFstBy - - -- ** Combine N Streams - -- | Functions generally ending in these shapes: - -- - -- @ - -- concat: f (t m a) -> t m a - -- concatMap: (a -> t m b) -> t m a -> t m b - -- unfoldMany: Unfold m a b -> t m a -> t m b - -- @ - - -- *** ConcatMap - -- | Generate streams by mapping a stream generator on each element of an - -- input stream, append the resulting streams and flatten. - , concatMap - , concatMapM - - -- *** ConcatUnfold - -- | Generate streams by using an unfold on each element of an input - -- stream, append the resulting streams and flatten. A special case of - -- gintercalate. - , unfoldMany - , ConcatUnfoldInterleaveState (..) - , unfoldInterleave - , unfoldRoundRobin - - -- *** Interpose - -- | Like unfoldMany but intersperses an effect between the streams. A - -- special case of gintercalate. - , interpose - , interposeM - , interposeSuffix - , interposeSuffixM - - -- *** Intercalate - -- | Like unfoldMany but intersperses streams from another source between - -- the streams from the first source. - , gintercalate - , gintercalateSuffix - , intercalate - , intercalateSuffix - - -- * Eliminate - -- | Folding and Parsing chunks of streams to eliminate nested streams. - -- Functions generally ending in these shapes: - -- - -- @ - -- f (Fold m a b) -> t m a -> t m b - -- f (Parser a m b) -> t m a -> t m b - -- @ - - -- ** Folding - -- | Apply folds on a stream. - , foldMany - , refoldMany - , foldSequence - , foldIterateM - , refoldIterateM - - -- ** Parsing - -- | Parsing is opposite to flattening. 'parseMany' is dual to concatMap or - -- unfoldMany. concatMap generates a stream from single values in a - -- stream and flattens, parseMany does the opposite of flattening by - -- splitting the stream and then folds each such split to single value in - -- the output stream. - , parseMany - , parseManyD - , parseSequence - , parseManyTill - , parseIterate - , parseIterateD - - -- ** Grouping - -- | Group segments of a stream and fold. Special case of parsing. - , groupsOf - , groupsBy - , groupsRollingBy - - -- ** Splitting - -- | A special case of parsing. - , wordsBy - , splitOnSeq - , splitOnSuffixSeq - , sliceOnSuffix - - -- XXX Implement these as folds or parsers instead. - , splitOnSuffixSeqAny - , splitOnPrefix - , splitOnAny - - -- * Transform (Nested Containers) - -- | Opposite to compact in ArrayStream - , splitInnerBy - , splitInnerBySuffix - , intersectBySorted - - -- * Reduce By Streams - , dropPrefix - , dropInfix - , dropSuffix - ) -where - -#include "inline.hs" -#include "ArrayMacros.h" - -import Control.Exception (assert) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Bits (shiftR, shiftL, (.|.), (.&.)) -import Data.Proxy (Proxy(..)) -import Data.Word (Word32) -import Foreign.Storable (Storable, peek) -import Fusion.Plugin.Types (Fuse(..)) -import GHC.Types (SPEC(..)) - -import Streamly.Internal.Data.Array.Type (Array(..)) -import Streamly.Internal.Data.Fold.Step (Step(..)) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Parser (ParseError(..)) -import Streamly.Internal.Data.Refold.Type (Refold(..)) -import Streamly.Internal.Data.SVar.Type (adaptState) -import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import Streamly.Internal.Data.Unboxed (Unbox, sizeOf) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) - -import qualified Streamly.Internal.Data.Array.Type as A -import qualified Streamly.Internal.Data.Fold as FL -import qualified Streamly.Internal.Data.Parser as PR -import qualified Streamly.Internal.Data.Parser.ParserD as PRD -import qualified Streamly.Internal.Data.Ring.Unboxed as RB - -import Streamly.Internal.Data.Stream.StreamD.Transform - (intersperse, intersperseMSuffix) -import Streamly.Internal.Data.Stream.StreamD.Type - -import Prelude hiding (concatMap, mapM, zipWith) - -#include "DocTestDataStream.hs" - ------------------------------------------------------------------------------- --- Appending ------------------------------------------------------------------------------- - -data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2 - --- | Fuses two streams sequentially, yielding all elements from the first --- stream, and then all elements from the second stream. --- --- >>> s1 = Stream.fromList [1,2] --- >>> s2 = Stream.fromList [3,4] --- >>> Stream.fold Fold.toList $ s1 `Stream.append` s2 --- [1,2,3,4] --- --- This function should not be used to dynamically construct a stream. If a --- stream is constructed by successive use of this function it would take --- quadratic time complexity to consume the stream. --- --- This function should only be used to statically fuse a stream with another --- stream. Do not use this recursively or where it cannot be inlined. --- --- See "Streamly.Data.StreamK" for an 'append' that can be used to --- construct a stream recursively. --- -{-# INLINE_NORMAL append #-} -append :: Monad m => Stream m a -> Stream m a -> Stream m a -append (Stream step1 state1) (Stream step2 state2) = - Stream step (AppendFirst state1) - - where - - {-# INLINE_LATE step #-} - step gst (AppendFirst st) = do - r <- step1 gst st - return $ case r of - Yield a s -> Yield a (AppendFirst s) - Skip s -> Skip (AppendFirst s) - Stop -> Skip (AppendSecond state2) - - step gst (AppendSecond st) = do - r <- step2 gst st - return $ case r of - Yield a s -> Yield a (AppendSecond s) - Skip s -> Skip (AppendSecond s) - Stop -> Stop - ------------------------------------------------------------------------------- --- Interleaving ------------------------------------------------------------------------------- - -data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2 - | InterleaveSecondOnly s2 | InterleaveFirstOnly s1 - --- | Interleaves two streams, yielding one element from each stream --- alternately. When one stream stops the rest of the other stream is used in --- the output stream. --- --- When joining many streams in a left associative manner earlier streams will --- get exponential priority than the ones joining later. Because of exponential --- weighting it can be used with 'concatMapWith' even on a large number of --- streams. --- -{-# INLINE_NORMAL interleave #-} -interleave :: Monad m => Stream m a -> Stream m a -> Stream m a -interleave (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveSecond s st2) - Skip s -> Skip (InterleaveFirst s st2) - Stop -> Skip (InterleaveSecondOnly st2) - - step gst (InterleaveSecond st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveFirst st1 s) - Skip s -> Skip (InterleaveSecond st1 s) - Stop -> Skip (InterleaveFirstOnly st1) - - step gst (InterleaveFirstOnly st1) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveFirstOnly s) - Skip s -> Skip (InterleaveFirstOnly s) - Stop -> Stop - - step gst (InterleaveSecondOnly st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveSecondOnly s) - Skip s -> Skip (InterleaveSecondOnly s) - Stop -> Stop - --- | Like `interleave` but stops interleaving as soon as any of the two streams --- stops. --- -{-# INLINE_NORMAL interleaveMin #-} -interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a -interleaveMin (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveSecond s st2) - Skip s -> Skip (InterleaveFirst s st2) - Stop -> Stop - - step gst (InterleaveSecond st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveFirst st1 s) - Skip s -> Skip (InterleaveSecond st1 s) - Stop -> Stop - - step _ (InterleaveFirstOnly _) = undefined - step _ (InterleaveSecondOnly _) = undefined - --- | Interleaves the outputs of two streams, yielding elements from each stream --- alternately, starting from the first stream. As soon as the first stream --- finishes, the output stops, discarding the remaining part of the second --- stream. In this case, the last element in the resulting stream would be from --- the second stream. If the second stream finishes early then the first stream --- still continues to yield elements until it finishes. --- --- >>> :set -XOverloadedStrings --- >>> import Data.Functor.Identity (Identity) --- >>> Stream.interleaveFstSuffix "abc" ",,,," :: Stream Identity Char --- fromList "a,b,c," --- >>> Stream.interleaveFstSuffix "abc" "," :: Stream Identity Char --- fromList "a,bc" --- --- 'interleaveFstSuffix' is a dual of 'interleaveFst'. --- --- Do not use dynamically. --- --- /Pre-release/ -{-# INLINE_NORMAL interleaveFstSuffix #-} -interleaveFstSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a -interleaveFstSuffix (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveSecond s st2) - Skip s -> Skip (InterleaveFirst s st2) - Stop -> Stop - - step gst (InterleaveSecond st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveFirst st1 s) - Skip s -> Skip (InterleaveSecond st1 s) - Stop -> Skip (InterleaveFirstOnly st1) - - step gst (InterleaveFirstOnly st1) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveFirstOnly s) - Skip s -> Skip (InterleaveFirstOnly s) - Stop -> Stop - - step _ (InterleaveSecondOnly _) = undefined - -data InterleaveInfixState s1 s2 a - = InterleaveInfixFirst s1 s2 - | InterleaveInfixSecondBuf s1 s2 - | InterleaveInfixSecondYield s1 s2 a - | InterleaveInfixFirstYield s1 s2 a - | InterleaveInfixFirstOnly s1 - --- | Interleaves the outputs of two streams, yielding elements from each stream --- alternately, starting from the first stream and ending at the first stream. --- If the second stream is longer than the first, elements from the second --- stream are infixed with elements from the first stream. If the first stream --- is longer then it continues yielding elements even after the second stream --- has finished. --- --- >>> :set -XOverloadedStrings --- >>> import Data.Functor.Identity (Identity) --- >>> Stream.interleaveFst "abc" ",,,," :: Stream Identity Char --- fromList "a,b,c" --- >>> Stream.interleaveFst "abc" "," :: Stream Identity Char --- fromList "a,bc" --- --- 'interleaveFst' is a dual of 'interleaveFstSuffix'. --- --- Do not use dynamically. --- --- /Pre-release/ -{-# INLINE_NORMAL interleaveFst #-} -interleaveFst :: Monad m => Stream m a -> Stream m a -> Stream m a -interleaveFst (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveInfixFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveInfixFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveInfixSecondBuf s st2) - Skip s -> Skip (InterleaveInfixFirst s st2) - Stop -> Stop - - step gst (InterleaveInfixSecondBuf st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Skip (InterleaveInfixSecondYield st1 s a) - Skip s -> Skip (InterleaveInfixSecondBuf st1 s) - Stop -> Skip (InterleaveInfixFirstOnly st1) - - step gst (InterleaveInfixSecondYield st1 st2 x) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield x (InterleaveInfixFirstYield s st2 a) - Skip s -> Skip (InterleaveInfixSecondYield s st2 x) - Stop -> Stop - - step _ (InterleaveInfixFirstYield st1 st2 x) = do - return $ Yield x (InterleaveInfixSecondBuf st1 st2) - - step gst (InterleaveInfixFirstOnly st1) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveInfixFirstOnly s) - Skip s -> Skip (InterleaveInfixFirstOnly s) - Stop -> Stop - ------------------------------------------------------------------------------- --- Scheduling ------------------------------------------------------------------------------- - --- | Schedule the execution of two streams in a fair round-robin manner, --- executing each stream once, alternately. Execution of a stream may not --- necessarily result in an output, a stream may choose to @Skip@ producing an --- element until later giving the other stream a chance to run. Therefore, this --- combinator fairly interleaves the execution of two streams rather than --- fairly interleaving the output of the two streams. This can be useful in --- co-operative multitasking without using explicit threads. This can be used --- as an alternative to `async`. --- --- Do not use dynamically. --- --- /Pre-release/ -{-# INLINE_NORMAL roundRobin #-} -roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a -roundRobin (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveSecond s st2) - Skip s -> Skip (InterleaveSecond s st2) - Stop -> Skip (InterleaveSecondOnly st2) - - step gst (InterleaveSecond st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveFirst st1 s) - Skip s -> Skip (InterleaveFirst st1 s) - Stop -> Skip (InterleaveFirstOnly st1) - - step gst (InterleaveSecondOnly st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveSecondOnly s) - Skip s -> Skip (InterleaveSecondOnly s) - Stop -> Stop - - step gst (InterleaveFirstOnly st1) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveFirstOnly s) - Skip s -> Skip (InterleaveFirstOnly s) - Stop -> Stop - ------------------------------------------------------------------------------- --- Merging ------------------------------------------------------------------------------- - --- | Like 'mergeBy' but with a monadic comparison function. --- --- Merge two streams randomly: --- --- @ --- > randomly _ _ = randomIO >>= \x -> return $ if x then LT else GT --- > Stream.toList $ Stream.mergeByM randomly (Stream.fromList [1,1,1,1]) (Stream.fromList [2,2,2,2]) --- [2,1,2,2,2,1,1,1] --- @ --- --- Merge two streams in a proportion of 2:1: --- --- >>> :{ --- do --- let s1 = Stream.fromList [1,1,1,1,1,1] --- s2 = Stream.fromList [2,2,2] --- let proportionately m n = do --- ref <- newIORef $ cycle $ Prelude.concat [Prelude.replicate m LT, Prelude.replicate n GT] --- return $ \_ _ -> do --- r <- readIORef ref --- writeIORef ref $ Prelude.tail r --- return $ Prelude.head r --- f <- proportionately 2 1 --- xs <- Stream.fold Fold.toList $ Stream.mergeByM f s1 s2 --- print xs --- :} --- [1,1,2,1,1,2,1,1,2] --- -{-# INLINE_NORMAL mergeByM #-} -mergeByM - :: (Monad m) - => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a -mergeByM cmp (Stream stepa ta) (Stream stepb tb) = - Stream step (Just ta, Just tb, Nothing, Nothing) - where - {-# INLINE_LATE step #-} - - -- one of the values is missing, and the corresponding stream is running - step gst (Just sa, sb, Nothing, b) = do - r <- stepa gst sa - return $ case r of - Yield a sa' -> Skip (Just sa', sb, Just a, b) - Skip sa' -> Skip (Just sa', sb, Nothing, b) - Stop -> Skip (Nothing, sb, Nothing, b) - - step gst (sa, Just sb, a, Nothing) = do - r <- stepb gst sb - return $ case r of - Yield b sb' -> Skip (sa, Just sb', a, Just b) - Skip sb' -> Skip (sa, Just sb', a, Nothing) - Stop -> Skip (sa, Nothing, a, Nothing) - - -- both the values are available - step _ (sa, sb, Just a, Just b) = do - res <- cmp a b - return $ case res of - GT -> Yield b (sa, sb, Just a, Nothing) - _ -> Yield a (sa, sb, Nothing, Just b) - - -- one of the values is missing, corresponding stream is done - step _ (Nothing, sb, Nothing, Just b) = - return $ Yield b (Nothing, sb, Nothing, Nothing) - - step _ (sa, Nothing, Just a, Nothing) = - return $ Yield a (sa, Nothing, Nothing, Nothing) - - step _ (Nothing, Nothing, Nothing, Nothing) = return Stop - --- | Merge two streams using a comparison function. The head elements of both --- the streams are compared and the smaller of the two elements is emitted, if --- both elements are equal then the element from the first stream is used --- first. --- --- If the streams are sorted in ascending order, the resulting stream would --- also remain sorted in ascending order. --- --- >>> s1 = Stream.fromList [1,3,5] --- >>> s2 = Stream.fromList [2,4,6,8] --- >>> Stream.fold Fold.toList $ Stream.mergeBy compare s1 s2 --- [1,2,3,4,5,6,8] --- -{-# INLINE mergeBy #-} -mergeBy - :: (Monad m) - => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a -mergeBy cmp = mergeByM (\a b -> return $ cmp a b) - --- | Like 'mergeByM' but stops merging as soon as any of the two streams stops. --- --- /Unimplemented/ -{-# INLINABLE mergeMinBy #-} -mergeMinBy :: -- Monad m => - (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a -mergeMinBy _f _m1 _m2 = undefined - -- fromStreamD $ D.mergeMinBy f (toStreamD m1) (toStreamD m2) - --- | Like 'mergeByM' but stops merging as soon as the first stream stops. --- --- /Unimplemented/ -{-# INLINABLE mergeFstBy #-} -mergeFstBy :: -- Monad m => - (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a -mergeFstBy _f _m1 _m2 = undefined - -- fromStreamK $ D.mergeFstBy f (toStreamD m1) (toStreamD m2) - -------------------------------------------------------------------------------- --- Intersection of sorted streams -------------------------------------------------------------------------------- - --- Assuming the streams are sorted in ascending order -{-# INLINE_NORMAL intersectBySorted #-} -intersectBySorted :: Monad m - => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a -intersectBySorted cmp (Stream stepa ta) (Stream stepb tb) = - Stream step - ( ta -- left stream state - , tb -- right stream state - , Nothing -- left value - , Nothing -- right value - ) - - where - - {-# INLINE_LATE step #-} - -- step 1, fetch the first value - step gst (sa, sb, Nothing, b) = do - r <- stepa gst sa - return $ case r of - Yield a sa' -> Skip (sa', sb, Just a, b) -- step 2/3 - Skip sa' -> Skip (sa', sb, Nothing, b) - Stop -> Stop - - -- step 2, fetch the second value - step gst (sa, sb, a@(Just _), Nothing) = do - r <- stepb gst sb - return $ case r of - Yield b sb' -> Skip (sa, sb', a, Just b) -- step 3 - Skip sb' -> Skip (sa, sb', a, Nothing) - Stop -> Stop - - -- step 3, compare the two values - step _ (sa, sb, Just a, Just b) = do - let res = cmp a b - return $ case res of - GT -> Skip (sa, sb, Just a, Nothing) -- step 2 - LT -> Skip (sa, sb, Nothing, Just b) -- step 1 - EQ -> Yield a (sa, sb, Nothing, Just b) -- step 1 - ------------------------------------------------------------------------------- --- Combine N Streams - unfoldMany ------------------------------------------------------------------------------- - -data ConcatUnfoldInterleaveState o i = - ConcatUnfoldInterleaveOuter o [i] - | ConcatUnfoldInterleaveInner o [i] - | ConcatUnfoldInterleaveInnerL [i] [i] - | ConcatUnfoldInterleaveInnerR [i] [i] - --- XXX use arrays to store state instead of lists? --- --- XXX In general we can use different scheduling strategies e.g. how to --- schedule the outer vs inner loop or assigning weights to different streams --- or outer and inner loops. - --- After a yield, switch to the next stream. Do not switch streams on Skip. --- Yield from outer stream switches to the inner stream. --- --- There are two choices here, (1) exhaust the outer stream first and then --- start yielding from the inner streams, this is much simpler to implement, --- (2) yield at least one element from an inner stream before going back to --- outer stream and opening the next stream from it. --- --- Ideally, we need some scheduling bias to inner streams vs outer stream. --- Maybe we can configure the behavior. --- --- XXX Instead of using "concatPairsWith wSerial" we can implement an N-way --- interleaving CPS combinator which behaves like unfoldInterleave. Instead --- of pairing up the streams we just need to go yielding one element from each --- stream and storing the remaining streams and then keep doing rounds through --- those in a round robin fashion. This would be much like wAsync. - --- | This does not pair streams like mergeMapWith, instead, it goes through --- each stream one by one and yields one element from each stream. After it --- goes to the last stream it reverses the traversal to come back to the first --- stream yielding elements from each stream on its way back to the first --- stream and so on. --- --- >>> lists = Stream.fromList [[1,1],[2,2],[3,3],[4,4],[5,5]] --- >>> interleaved = Stream.unfoldInterleave Unfold.fromList lists --- >>> Stream.fold Fold.toList interleaved --- [1,2,3,4,5,5,4,3,2,1] --- --- Note that this is order of magnitude more efficient than "mergeMapWith --- interleave" because of fusion. --- -{-# INLINE_NORMAL unfoldInterleave #-} -unfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b -unfoldInterleave (Unfold istep inject) (Stream ostep ost) = - Stream step (ConcatUnfoldInterleaveOuter ost []) - - where - - {-# INLINE_LATE step #-} - step gst (ConcatUnfoldInterleaveOuter o ls) = do - r <- ostep (adaptState gst) o - case r of - Yield a o' -> do - i <- inject a - i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls))) - Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls) - Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls []) - - step _ (ConcatUnfoldInterleaveInner _ []) = undefined - step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls)) - Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls)) - Stop -> Skip (ConcatUnfoldInterleaveOuter o ls) - - step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop - step _ (ConcatUnfoldInterleaveInnerL [] rs) = - return $ Skip (ConcatUnfoldInterleaveInnerR [] rs) - - step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs)) - Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs) - Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs) - - step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop - step _ (ConcatUnfoldInterleaveInnerR ls []) = - return $ Skip (ConcatUnfoldInterleaveInnerL ls []) - - step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs) - Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs)) - Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs) - --- XXX In general we can use different scheduling strategies e.g. how to --- schedule the outer vs inner loop or assigning weights to different streams --- or outer and inner loops. --- --- This could be inefficient if the tasks are too small. --- --- Compared to unfoldInterleave this one switches streams on Skips. - --- | 'unfoldInterleave' switches to the next stream whenever a value from a --- stream is yielded, it does not switch on a 'Skip'. So if a stream keeps --- skipping for long time other streams won't get a chance to run. --- 'unfoldRoundRobin' switches on Skip as well. So it basically schedules each --- stream fairly irrespective of whether it produces a value or not. --- -{-# INLINE_NORMAL unfoldRoundRobin #-} -unfoldRoundRobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b -unfoldRoundRobin (Unfold istep inject) (Stream ostep ost) = - Stream step (ConcatUnfoldInterleaveOuter ost []) - where - {-# INLINE_LATE step #-} - step gst (ConcatUnfoldInterleaveOuter o ls) = do - r <- ostep (adaptState gst) o - case r of - Yield a o' -> do - i <- inject a - i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls))) - Skip o' -> return $ Skip (ConcatUnfoldInterleaveInner o' ls) - Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls []) - - step _ (ConcatUnfoldInterleaveInner o []) = - return $ Skip (ConcatUnfoldInterleaveOuter o []) - - step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls)) - Skip s -> Skip (ConcatUnfoldInterleaveOuter o (s:ls)) - Stop -> Skip (ConcatUnfoldInterleaveOuter o ls) - - step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop - step _ (ConcatUnfoldInterleaveInnerL [] rs) = - return $ Skip (ConcatUnfoldInterleaveInnerR [] rs) - - step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs)) - Skip s -> Skip (ConcatUnfoldInterleaveInnerL ls (s:rs)) - Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs) - - step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop - step _ (ConcatUnfoldInterleaveInnerR ls []) = - return $ Skip (ConcatUnfoldInterleaveInnerL ls []) - - step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs) - Skip s -> Skip (ConcatUnfoldInterleaveInnerR (s:ls) rs) - Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs) - ------------------------------------------------------------------------------- --- Combine N Streams - interpose ------------------------------------------------------------------------------- - -{-# ANN type InterposeSuffixState Fuse #-} -data InterposeSuffixState s1 i1 = - InterposeSuffixFirst s1 - -- | InterposeSuffixFirstYield s1 i1 - | InterposeSuffixFirstInner s1 i1 - | InterposeSuffixSecond s1 - --- Note that if an unfolded layer turns out to be nil we still emit the --- separator effect. An alternate behavior could be to emit the separator --- effect only if at least one element has been yielded by the unfolding. --- However, that becomes a bit complicated, so we have chosen the former --- behvaior for now. -{-# INLINE_NORMAL interposeSuffixM #-} -interposeSuffixM - :: Monad m - => m c -> Unfold m b c -> Stream m b -> Stream m c -interposeSuffixM - action - (Unfold istep1 inject1) (Stream step1 state1) = - Stream step (InterposeSuffixFirst state1) - - where - - {-# INLINE_LATE step #-} - step gst (InterposeSuffixFirst s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (InterposeSuffixFirstInner s i)) - -- i `seq` return (Skip (InterposeSuffixFirstYield s i)) - Skip s -> return $ Skip (InterposeSuffixFirst s) - Stop -> return Stop - - {- - step _ (InterposeSuffixFirstYield s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i') - Skip i' -> Skip (InterposeSuffixFirstYield s1 i') - Stop -> Skip (InterposeSuffixFirst s1) - -} - - step _ (InterposeSuffixFirstInner s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i') - Skip i' -> Skip (InterposeSuffixFirstInner s1 i') - Stop -> Skip (InterposeSuffixSecond s1) - - step _ (InterposeSuffixSecond s1) = do - r <- action - return $ Yield r (InterposeSuffixFirst s1) - --- interposeSuffix x unf str = gintercalateSuffix unf str UF.identity (repeat x) - --- | Unfold the elements of a stream, append the given element after each --- unfolded stream and then concat them into a single stream. --- --- >>> unlines = Stream.interposeSuffix '\n' --- --- /Pre-release/ -{-# INLINE interposeSuffix #-} -interposeSuffix :: Monad m - => c -> Unfold m b c -> Stream m b -> Stream m c -interposeSuffix x = interposeSuffixM (return x) - -{-# ANN type InterposeState Fuse #-} -data InterposeState s1 i1 a = - InterposeFirst s1 - -- | InterposeFirstYield s1 i1 - | InterposeFirstInner s1 i1 - | InterposeFirstInject s1 - -- | InterposeFirstBuf s1 i1 - | InterposeSecondYield s1 i1 - -- -- | InterposeSecondYield s1 i1 a - -- -- | InterposeFirstResume s1 i1 a - --- Note that this only interposes the pure values, we may run many effects to --- generate those values as some effects may not generate anything (Skip). -{-# INLINE_NORMAL interposeM #-} -interposeM :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c -interposeM - action - (Unfold istep1 inject1) (Stream step1 state1) = - Stream step (InterposeFirst state1) - - where - - {-# INLINE_LATE step #-} - step gst (InterposeFirst s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (InterposeFirstInner s i)) - -- i `seq` return (Skip (InterposeFirstYield s i)) - Skip s -> return $ Skip (InterposeFirst s) - Stop -> return Stop - - {- - step _ (InterposeFirstYield s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (InterposeFirstInner s1 i') - Skip i' -> Skip (InterposeFirstYield s1 i') - Stop -> Skip (InterposeFirst s1) - -} - - step _ (InterposeFirstInner s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (InterposeFirstInner s1 i') - Skip i' -> Skip (InterposeFirstInner s1 i') - Stop -> Skip (InterposeFirstInject s1) - - step gst (InterposeFirstInject s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - -- i `seq` return (Skip (InterposeFirstBuf s i)) - i `seq` return (Skip (InterposeSecondYield s i)) - Skip s -> return $ Skip (InterposeFirstInject s) - Stop -> return Stop - - {- - step _ (InterposeFirstBuf s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Skip (InterposeSecondYield s1 i' x) - Skip i' -> Skip (InterposeFirstBuf s1 i') - Stop -> Stop - -} - - {- - step _ (InterposeSecondYield s1 i1 v) = do - r <- action - return $ Yield r (InterposeFirstResume s1 i1 v) - -} - step _ (InterposeSecondYield s1 i1) = do - r <- action - return $ Yield r (InterposeFirstInner s1 i1) - - {- - step _ (InterposeFirstResume s1 i1 v) = do - return $ Yield v (InterposeFirstInner s1 i1) - -} - --- > interpose x unf str = gintercalate unf str UF.identity (repeat x) - --- | Unfold the elements of a stream, intersperse the given element between the --- unfolded streams and then concat them into a single stream. --- --- >>> unwords = Stream.interpose ' ' --- --- /Pre-release/ -{-# INLINE interpose #-} -interpose :: Monad m - => c -> Unfold m b c -> Stream m b -> Stream m c -interpose x = interposeM (return x) - ------------------------------------------------------------------------------- --- Combine N Streams - intercalate ------------------------------------------------------------------------------- - -data ICUState s1 s2 i1 i2 = - ICUFirst s1 s2 - | ICUSecond s1 s2 - | ICUSecondOnly s2 - | ICUFirstOnly s1 - | ICUFirstInner s1 s2 i1 - | ICUSecondInner s1 s2 i2 - | ICUFirstOnlyInner s1 i1 - | ICUSecondOnlyInner s2 i2 - --- | 'interleaveFstSuffix' followed by unfold and concat. --- --- /Pre-release/ -{-# INLINE_NORMAL gintercalateSuffix #-} -gintercalateSuffix - :: Monad m - => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c -gintercalateSuffix - (Unfold istep1 inject1) (Stream step1 state1) - (Unfold istep2 inject2) (Stream step2 state2) = - Stream step (ICUFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (ICUFirst s1 s2) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICUFirstInner s s2 i)) - Skip s -> return $ Skip (ICUFirst s s2) - Stop -> return Stop - - step gst (ICUFirstOnly s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICUFirstOnlyInner s i)) - Skip s -> return $ Skip (ICUFirstOnly s) - Stop -> return Stop - - step _ (ICUFirstInner s1 s2 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICUFirstInner s1 s2 i') - Skip i' -> Skip (ICUFirstInner s1 s2 i') - Stop -> Skip (ICUSecond s1 s2) - - step _ (ICUFirstOnlyInner s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICUFirstOnlyInner s1 i') - Skip i' -> Skip (ICUFirstOnlyInner s1 i') - Stop -> Skip (ICUFirstOnly s1) - - step gst (ICUSecond s1 s2) = do - r <- step2 (adaptState gst) s2 - case r of - Yield a s -> do - i <- inject2 a - i `seq` return (Skip (ICUSecondInner s1 s i)) - Skip s -> return $ Skip (ICUSecond s1 s) - Stop -> return $ Skip (ICUFirstOnly s1) - - step _ (ICUSecondInner s1 s2 i2) = do - r <- istep2 i2 - return $ case r of - Yield x i' -> Yield x (ICUSecondInner s1 s2 i') - Skip i' -> Skip (ICUSecondInner s1 s2 i') - Stop -> Skip (ICUFirst s1 s2) - - step _ (ICUSecondOnly _s2) = undefined - step _ (ICUSecondOnlyInner _s2 _i2) = undefined - -data ICALState s1 s2 i1 i2 a = - ICALFirst s1 s2 - -- | ICALFirstYield s1 s2 i1 - | ICALFirstInner s1 s2 i1 - | ICALFirstOnly s1 - | ICALFirstOnlyInner s1 i1 - | ICALSecondInject s1 s2 - | ICALFirstInject s1 s2 i2 - -- | ICALFirstBuf s1 s2 i1 i2 - | ICALSecondInner s1 s2 i1 i2 - -- -- | ICALSecondInner s1 s2 i1 i2 a - -- -- | ICALFirstResume s1 s2 i1 i2 a - --- XXX we can swap the order of arguments to gintercalate so that the --- definition of unfoldMany becomes simpler? The first stream should be --- infixed inside the second one. However, if we change the order in --- "interleave" as well similarly, then that will make it a bit unintuitive. --- --- > unfoldMany unf str = --- > gintercalate unf str (UF.nilM (\_ -> return ())) (repeat ()) - --- | 'interleaveFst' followed by unfold and concat. --- --- /Pre-release/ -{-# INLINE_NORMAL gintercalate #-} -gintercalate - :: Monad m - => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c -gintercalate - (Unfold istep1 inject1) (Stream step1 state1) - (Unfold istep2 inject2) (Stream step2 state2) = - Stream step (ICALFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (ICALFirst s1 s2) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICALFirstInner s s2 i)) - -- i `seq` return (Skip (ICALFirstYield s s2 i)) - Skip s -> return $ Skip (ICALFirst s s2) - Stop -> return Stop - - {- - step _ (ICALFirstYield s1 s2 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICALFirstInner s1 s2 i') - Skip i' -> Skip (ICALFirstYield s1 s2 i') - Stop -> Skip (ICALFirst s1 s2) - -} - - step _ (ICALFirstInner s1 s2 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICALFirstInner s1 s2 i') - Skip i' -> Skip (ICALFirstInner s1 s2 i') - Stop -> Skip (ICALSecondInject s1 s2) - - step gst (ICALFirstOnly s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICALFirstOnlyInner s i)) - Skip s -> return $ Skip (ICALFirstOnly s) - Stop -> return Stop - - step _ (ICALFirstOnlyInner s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICALFirstOnlyInner s1 i') - Skip i' -> Skip (ICALFirstOnlyInner s1 i') - Stop -> Skip (ICALFirstOnly s1) - - -- We inject the second stream even before checking if the first stream - -- would yield any more elements. There is no clear choice whether we - -- should do this before or after that. Doing it after may make the state - -- machine a bit simpler though. - step gst (ICALSecondInject s1 s2) = do - r <- step2 (adaptState gst) s2 - case r of - Yield a s -> do - i <- inject2 a - i `seq` return (Skip (ICALFirstInject s1 s i)) - Skip s -> return $ Skip (ICALSecondInject s1 s) - Stop -> return $ Skip (ICALFirstOnly s1) - - step gst (ICALFirstInject s1 s2 i2) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICALSecondInner s s2 i i2)) - -- i `seq` return (Skip (ICALFirstBuf s s2 i i2)) - Skip s -> return $ Skip (ICALFirstInject s s2 i2) - Stop -> return Stop - - {- - step _ (ICALFirstBuf s1 s2 i1 i2) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Skip (ICALSecondInner s1 s2 i' i2 x) - Skip i' -> Skip (ICALFirstBuf s1 s2 i' i2) - Stop -> Stop - - step _ (ICALSecondInner s1 s2 i1 i2 v) = do - r <- istep2 i2 - return $ case r of - Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i' v) - Skip i' -> Skip (ICALSecondInner s1 s2 i1 i' v) - Stop -> Skip (ICALFirstResume s1 s2 i1 i2 v) - -} - - step _ (ICALSecondInner s1 s2 i1 i2) = do - r <- istep2 i2 - return $ case r of - Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i') - Skip i' -> Skip (ICALSecondInner s1 s2 i1 i') - Stop -> Skip (ICALFirstInner s1 s2 i1) - -- Stop -> Skip (ICALFirstResume s1 s2 i1 i2) - - {- - step _ (ICALFirstResume s1 s2 i1 i2 x) = do - return $ Yield x (ICALFirstInner s1 s2 i1 i2) - -} - --- > intercalateSuffix unf seed str = gintercalateSuffix unf str unf (repeatM seed) - --- | 'intersperseMSuffix' followed by unfold and concat. --- --- >>> intercalateSuffix u a = Stream.unfoldMany u . Stream.intersperseMSuffix a --- >>> intersperseMSuffix = Stream.intercalateSuffix Unfold.identity --- >>> unlines = Stream.intercalateSuffix Unfold.fromList "\n" --- --- >>> input = Stream.fromList ["abc", "def", "ghi"] --- >>> Stream.fold Fold.toList $ Stream.intercalateSuffix Unfold.fromList "\n" input --- "abc\ndef\nghi\n" --- -{-# INLINE intercalateSuffix #-} -intercalateSuffix :: Monad m - => Unfold m b c -> b -> Stream m b -> Stream m c -intercalateSuffix unf seed = unfoldMany unf . intersperseMSuffix (return seed) - --- > intercalate unf seed str = gintercalate unf str unf (repeatM seed) - --- | 'intersperse' followed by unfold and concat. --- --- >>> intercalate u a = Stream.unfoldMany u . Stream.intersperse a --- >>> intersperse = Stream.intercalate Unfold.identity --- >>> unwords = Stream.intercalate Unfold.fromList " " --- --- >>> input = Stream.fromList ["abc", "def", "ghi"] --- >>> Stream.fold Fold.toList $ Stream.intercalate Unfold.fromList " " input --- "abc def ghi" --- -{-# INLINE intercalate #-} -intercalate :: Monad m - => Unfold m b c -> b -> Stream m b -> Stream m c -intercalate unf seed str = unfoldMany unf $ intersperse seed str - ------------------------------------------------------------------------------- --- Folding ------------------------------------------------------------------------------- - --- | Apply a stream of folds to an input stream and emit the results in the --- output stream. --- --- /Unimplemented/ --- -{-# INLINE foldSequence #-} -foldSequence - :: -- Monad m => - Stream m (Fold m a b) - -> Stream m a - -> Stream m b -foldSequence _f _m = undefined - -{-# ANN type FIterState Fuse #-} -data FIterState s f m a b - = FIterInit s f - | forall fs. FIterStream s (fs -> a -> m (FL.Step fs b)) fs (fs -> m b) - | FIterYield b (FIterState s f m a b) - | FIterStop - --- | Iterate a fold generator on a stream. The initial value @b@ is used to --- generate the first fold, the fold is applied on the stream and the result of --- the fold is used to generate the next fold and so on. --- --- >>> import Data.Monoid (Sum(..)) --- >>> f x = return (Fold.take 2 (Fold.sconcat x)) --- >>> s = fmap Sum $ Stream.fromList [1..10] --- >>> Stream.fold Fold.toList $ fmap getSum $ Stream.foldIterateM f (pure 0) s --- [3,10,21,36,55,55] --- --- This is the streaming equivalent of monad like sequenced application of --- folds where next fold is dependent on the previous fold. --- --- /Pre-release/ --- -{-# INLINE_NORMAL foldIterateM #-} -foldIterateM :: - Monad m => (b -> m (FL.Fold m a b)) -> m b -> Stream m a -> Stream m b -foldIterateM func seed0 (Stream step state) = - Stream stepOuter (FIterInit state seed0) - - where - - {-# INLINE iterStep #-} - iterStep from st fstep extract = do - res <- from - return - $ Skip - $ case res of - FL.Partial fs -> FIterStream st fstep fs extract - FL.Done fb -> FIterYield fb $ FIterInit st (return fb) - - {-# INLINE_LATE stepOuter #-} - stepOuter _ (FIterInit st seed) = do - (FL.Fold fstep initial extract) <- seed >>= func - iterStep initial st fstep extract - stepOuter gst (FIterStream st fstep fs extract) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - iterStep (fstep fs x) s fstep extract - Skip s -> return $ Skip $ FIterStream s fstep fs extract - Stop -> do - b <- extract fs - return $ Skip $ FIterYield b FIterStop - stepOuter _ (FIterYield a next) = return $ Yield a next - stepOuter _ FIterStop = return Stop - -{-# ANN type CIterState Fuse #-} -data CIterState s f fs b - = CIterInit s f - | CIterConsume s fs - | CIterYield b (CIterState s f fs b) - | CIterStop - --- | Like 'foldIterateM' but using the 'Refold' type instead. This could be --- much more efficient due to stream fusion. --- --- /Internal/ -{-# INLINE_NORMAL refoldIterateM #-} -refoldIterateM :: - Monad m => Refold m b a b -> m b -> Stream m a -> Stream m b -refoldIterateM (Refold fstep finject fextract) initial (Stream step state) = - Stream stepOuter (CIterInit state initial) - - where - - {-# INLINE iterStep #-} - iterStep st action = do - res <- action - return - $ Skip - $ case res of - FL.Partial fs -> CIterConsume st fs - FL.Done fb -> CIterYield fb $ CIterInit st (return fb) - - {-# INLINE_LATE stepOuter #-} - stepOuter _ (CIterInit st action) = do - iterStep st (action >>= finject) - stepOuter gst (CIterConsume st fs) = do - r <- step (adaptState gst) st - case r of - Yield x s -> iterStep s (fstep fs x) - Skip s -> return $ Skip $ CIterConsume s fs - Stop -> do - b <- fextract fs - return $ Skip $ CIterYield b CIterStop - stepOuter _ (CIterYield a next) = return $ Yield a next - stepOuter _ CIterStop = return Stop - --- "n" elements at the end are dropped by the fold. -{-# INLINE sliceBy #-} -sliceBy :: Monad m => Fold m a Int -> Int -> Refold m (Int, Int) a (Int, Int) -sliceBy (Fold step1 initial1 extract1) n = Refold step inject extract - - where - - inject (i, len) = do - r <- initial1 - return $ case r of - Partial s -> Partial $ Tuple' (i + len + n) s - Done l -> Done (i, l) - - step (Tuple' i s) x = do - r <- step1 s x - return $ case r of - Partial s1 -> Partial $ Tuple' i s1 - Done len -> Done (i, len) - - extract (Tuple' i s) = (i,) <$> extract1 s - -{-# INLINE sliceOnSuffix #-} -sliceOnSuffix :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) -sliceOnSuffix predicate = - -- Scan the stream with the given refold - refoldIterateM - (sliceBy (FL.takeEndBy_ predicate FL.length) 1) - (return (-1, 0)) - ------------------------------------------------------------------------------- --- Parsing ------------------------------------------------------------------------------- - -{-# ANN type ParseChunksState Fuse #-} -data ParseChunksState x inpBuf st pst = - ParseChunksInit inpBuf st - | ParseChunksInitBuf inpBuf - | ParseChunksInitLeftOver inpBuf - | ParseChunksStream st inpBuf !pst - | ParseChunksStop inpBuf !pst - | ParseChunksBuf inpBuf st inpBuf !pst - | ParseChunksExtract inpBuf inpBuf !pst - | ParseChunksYield x (ParseChunksState x inpBuf st pst) - --- XXX return the remaining stream as part of the error. --- XXX This is in fact parseMany1 (a la foldMany1). Do we need a parseMany as --- well? -{-# INLINE_NORMAL parseManyD #-} -parseManyD - :: Monad m - => PRD.Parser a m b - -> Stream m a - -> Stream m (Either ParseError b) -parseManyD (PRD.Parser pstep initial extract) (Stream step state) = - Stream stepOuter (ParseChunksInit [] state) - - where - - {-# INLINE_LATE stepOuter #-} - -- Buffer is empty, get the first element from the stream, initialize the - -- fold and then go to stream processing loop. - stepOuter gst (ParseChunksInit [] st) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - res <- initial - case res of - PRD.IPartial ps -> - return $ Skip $ ParseChunksBuf [x] s [] ps - PRD.IDone pb -> - let next = ParseChunksInit [x] s - in return $ Skip $ ParseChunksYield (Right pb) next - PRD.IError err -> - return - $ Skip - $ ParseChunksYield - (Left (ParseError err)) - (ParseChunksInitLeftOver []) - Skip s -> return $ Skip $ ParseChunksInit [] s - Stop -> return Stop - - -- Buffer is not empty, go to buffered processing loop - stepOuter _ (ParseChunksInit src st) = do - res <- initial - case res of - PRD.IPartial ps -> - return $ Skip $ ParseChunksBuf src st [] ps - PRD.IDone pb -> - let next = ParseChunksInit src st - in return $ Skip $ ParseChunksYield (Right pb) next - PRD.IError err -> - return - $ Skip - $ ParseChunksYield - (Left (ParseError err)) - (ParseChunksInitLeftOver []) - - -- This is simplified ParseChunksInit - stepOuter _ (ParseChunksInitBuf src) = do - res <- initial - case res of - PRD.IPartial ps -> - return $ Skip $ ParseChunksExtract src [] ps - PRD.IDone pb -> - let next = ParseChunksInitBuf src - in return $ Skip $ ParseChunksYield (Right pb) next - PRD.IError err -> - return - $ Skip - $ ParseChunksYield - (Left (ParseError err)) - (ParseChunksInitLeftOver []) - - -- XXX we just discard any leftover input at the end - stepOuter _ (ParseChunksInitLeftOver _) = return Stop - - -- Buffer is empty, process elements from the stream - stepOuter gst (ParseChunksStream st buf pst) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - return $ Skip $ ParseChunksStream s [] pst1 - PR.Partial n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 - return $ Skip $ ParseChunksBuf src s [] pst1 - PR.Continue 0 pst1 -> - return $ Skip $ ParseChunksStream s (x:buf) pst1 - PR.Continue n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let (src0, buf1) = splitAt n (x:buf) - src = Prelude.reverse src0 - return $ Skip $ ParseChunksBuf src s buf1 pst1 - PR.Done 0 b -> do - return $ Skip $ - ParseChunksYield (Right b) (ParseChunksInit [] s) - PR.Done n b -> do - assert (n <= length (x:buf)) (return ()) - let src = Prelude.reverse (Prelude.take n (x:buf)) - return $ Skip $ - ParseChunksYield (Right b) (ParseChunksInit src s) - PR.Error err -> - return - $ Skip - $ ParseChunksYield - (Left (ParseError err)) - (ParseChunksInitLeftOver []) - Skip s -> return $ Skip $ ParseChunksStream s buf pst - Stop -> return $ Skip $ ParseChunksStop buf pst - - -- go back to stream processing mode - stepOuter _ (ParseChunksBuf [] s buf pst) = - return $ Skip $ ParseChunksStream s buf pst - - -- buffered processing loop - stepOuter _ (ParseChunksBuf (x:xs) s buf pst) = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - return $ Skip $ ParseChunksBuf xs s [] pst1 - PR.Partial n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 ++ xs - return $ Skip $ ParseChunksBuf src s [] pst1 - PR.Continue 0 pst1 -> - return $ Skip $ ParseChunksBuf xs s (x:buf) pst1 - PR.Continue n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let (src0, buf1) = splitAt n (x:buf) - src = Prelude.reverse src0 ++ xs - return $ Skip $ ParseChunksBuf src s buf1 pst1 - PR.Done 0 b -> - return - $ Skip - $ ParseChunksYield (Right b) (ParseChunksInit xs s) - PR.Done n b -> do - assert (n <= length (x:buf)) (return ()) - let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs - return $ Skip - $ ParseChunksYield (Right b) (ParseChunksInit src s) - PR.Error err -> - return - $ Skip - $ ParseChunksYield - (Left (ParseError err)) - (ParseChunksInitLeftOver []) - - -- This is simplified ParseChunksBuf - stepOuter _ (ParseChunksExtract [] buf pst) = - return $ Skip $ ParseChunksStop buf pst - - stepOuter _ (ParseChunksExtract (x:xs) buf pst) = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - return $ Skip $ ParseChunksExtract xs [] pst1 - PR.Partial n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 ++ xs - return $ Skip $ ParseChunksExtract src [] pst1 - PR.Continue 0 pst1 -> - return $ Skip $ ParseChunksExtract xs (x:buf) pst1 - PR.Continue n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let (src0, buf1) = splitAt n (x:buf) - src = Prelude.reverse src0 ++ xs - return $ Skip $ ParseChunksExtract src buf1 pst1 - PR.Done 0 b -> - return - $ Skip - $ ParseChunksYield (Right b) (ParseChunksInitBuf xs) - PR.Done n b -> do - assert (n <= length (x:buf)) (return ()) - let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs - return - $ Skip - $ ParseChunksYield (Right b) (ParseChunksInitBuf src) - PR.Error err -> - return - $ Skip - $ ParseChunksYield - (Left (ParseError err)) - (ParseChunksInitLeftOver []) - - -- This is simplified ParseChunksExtract - stepOuter _ (ParseChunksStop buf pst) = do - pRes <- extract pst - case pRes of - PR.Partial _ _ -> error "Bug: parseMany: Partial in extract" - PR.Continue 0 pst1 -> - return $ Skip $ ParseChunksStop buf pst1 - PR.Continue n pst1 -> do - assert (n <= length buf) (return ()) - let (src0, buf1) = splitAt n buf - src = Prelude.reverse src0 - return $ Skip $ ParseChunksExtract src buf1 pst1 - PR.Done 0 b -> do - return $ Skip $ - ParseChunksYield (Right b) (ParseChunksInitLeftOver []) - PR.Done n b -> do - assert (n <= length buf) (return ()) - let src = Prelude.reverse (Prelude.take n buf) - return $ Skip $ - ParseChunksYield (Right b) (ParseChunksInitBuf src) - PR.Error err -> - return - $ Skip - $ ParseChunksYield - (Left (ParseError err)) - (ParseChunksInitLeftOver []) - - stepOuter _ (ParseChunksYield a next) = return $ Yield a next - --- | Apply a 'Parser' repeatedly on a stream and emit the parsed values in the --- output stream. --- --- Example: --- --- >>> s = Stream.fromList [1..10] --- >>> parser = Parser.takeBetween 0 2 Fold.sum --- >>> Stream.fold Fold.toList $ Stream.parseMany parser s --- [Right 3,Right 7,Right 11,Right 15,Right 19] --- --- This is the streaming equivalent of the 'Streamly.Data.Parser.many' parse --- combinator. --- --- Known Issues: When the parser fails there is no way to get the remaining --- stream. --- -{-# INLINE parseMany #-} -parseMany - :: Monad m - => PR.Parser a m b - -> Stream m a - -> Stream m (Either ParseError b) -parseMany = parseManyD - --- | Apply a stream of parsers to an input stream and emit the results in the --- output stream. --- --- /Unimplemented/ --- -{-# INLINE parseSequence #-} -parseSequence - :: -- Monad m => - Stream m (PR.Parser a m b) - -> Stream m a - -> Stream m b -parseSequence _f _m = undefined - --- XXX Change the parser arguments' order - --- | @parseManyTill collect test stream@ tries the parser @test@ on the input, --- if @test@ fails it backtracks and tries @collect@, after @collect@ succeeds --- @test@ is tried again and so on. The parser stops when @test@ succeeds. The --- output of @test@ is discarded and the output of @collect@ is emitted in the --- output stream. The parser fails if @collect@ fails. --- --- /Unimplemented/ --- -{-# INLINE parseManyTill #-} -parseManyTill :: - -- MonadThrow m => - PR.Parser a m b - -> PR.Parser a m x - -> Stream m a - -> Stream m b -parseManyTill = undefined - -{-# ANN type ConcatParseState Fuse #-} -data ConcatParseState c b inpBuf st p m a = - ConcatParseInit inpBuf st p - | ConcatParseInitBuf inpBuf p - | ConcatParseInitLeftOver inpBuf - | forall s. ConcatParseStop - inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m (PRD.Step s b)) - | forall s. ConcatParseStream - st inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m (PRD.Step s b)) - | forall s. ConcatParseBuf - inpBuf st inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m (PRD.Step s b)) - | forall s. ConcatParseExtract - inpBuf inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m (PRD.Step s b)) - | ConcatParseYield c (ConcatParseState c b inpBuf st p m a) - --- XXX Review the changes -{-# INLINE_NORMAL parseIterateD #-} -parseIterateD - :: Monad m - => (b -> PRD.Parser a m b) - -> b - -> Stream m a - -> Stream m (Either ParseError b) -parseIterateD func seed (Stream step state) = - Stream stepOuter (ConcatParseInit [] state (func seed)) - - where - - {-# INLINE_LATE stepOuter #-} - -- Buffer is empty, go to stream processing loop - stepOuter _ (ConcatParseInit [] st (PRD.Parser pstep initial extract)) = do - res <- initial - case res of - PRD.IPartial ps -> - return $ Skip $ ConcatParseStream st [] pstep ps extract - PRD.IDone pb -> - let next = ConcatParseInit [] st (func pb) - in return $ Skip $ ConcatParseYield (Right pb) next - PRD.IError err -> - return - $ Skip - $ ConcatParseYield - (Left (ParseError err)) - (ConcatParseInitLeftOver []) - - -- Buffer is not empty, go to buffered processing loop - stepOuter _ (ConcatParseInit src st - (PRD.Parser pstep initial extract)) = do - res <- initial - case res of - PRD.IPartial ps -> - return $ Skip $ ConcatParseBuf src st [] pstep ps extract - PRD.IDone pb -> - let next = ConcatParseInit src st (func pb) - in return $ Skip $ ConcatParseYield (Right pb) next - PRD.IError err -> - return - $ Skip - $ ConcatParseYield - (Left (ParseError err)) - (ConcatParseInitLeftOver []) - - -- This is simplified ConcatParseInit - stepOuter _ (ConcatParseInitBuf src - (PRD.Parser pstep initial extract)) = do - res <- initial - case res of - PRD.IPartial ps -> - return $ Skip $ ConcatParseExtract src [] pstep ps extract - PRD.IDone pb -> - let next = ConcatParseInitBuf src (func pb) - in return $ Skip $ ConcatParseYield (Right pb) next - PRD.IError err -> - return - $ Skip - $ ConcatParseYield - (Left (ParseError err)) - (ConcatParseInitLeftOver []) - - -- XXX we just discard any leftover input at the end - stepOuter _ (ConcatParseInitLeftOver _) = return Stop - - -- Buffer is empty process elements from the stream - stepOuter gst (ConcatParseStream st buf pstep pst extract) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - return $ Skip $ ConcatParseStream s [] pstep pst1 extract - PR.Partial n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 - return $ Skip $ ConcatParseBuf src s [] pstep pst1 extract - -- PR.Continue 0 pst1 -> - -- return $ Skip $ ConcatParseStream s (x:buf) pst1 - PR.Continue n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let (src0, buf1) = splitAt n (x:buf) - src = Prelude.reverse src0 - return $ Skip $ ConcatParseBuf src s buf1 pstep pst1 extract - -- XXX Specialize for Stop 0 common case? - PR.Done n b -> do - assert (n <= length (x:buf)) (return ()) - let src = Prelude.reverse (Prelude.take n (x:buf)) - return $ Skip $ - ConcatParseYield (Right b) (ConcatParseInit src s (func b)) - PR.Error err -> - return - $ Skip - $ ConcatParseYield - (Left (ParseError err)) - (ConcatParseInitLeftOver []) - Skip s -> return $ Skip $ ConcatParseStream s buf pstep pst extract - Stop -> return $ Skip $ ConcatParseStop buf pstep pst extract - - -- go back to stream processing mode - stepOuter _ (ConcatParseBuf [] s buf pstep ps extract) = - return $ Skip $ ConcatParseStream s buf pstep ps extract - - -- buffered processing loop - stepOuter _ (ConcatParseBuf (x:xs) s buf pstep pst extract) = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - return $ Skip $ ConcatParseBuf xs s [] pstep pst1 extract - PR.Partial n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 ++ xs - return $ Skip $ ConcatParseBuf src s [] pstep pst1 extract - -- PR.Continue 0 pst1 -> return $ Skip $ ConcatParseBuf xs s (x:buf) pst1 - PR.Continue n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let (src0, buf1) = splitAt n (x:buf) - src = Prelude.reverse src0 ++ xs - return $ Skip $ ConcatParseBuf src s buf1 pstep pst1 extract - -- XXX Specialize for Stop 0 common case? - PR.Done n b -> do - assert (n <= length (x:buf)) (return ()) - let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs - return $ Skip $ ConcatParseYield (Right b) - (ConcatParseInit src s (func b)) - PR.Error err -> - return - $ Skip - $ ConcatParseYield - (Left (ParseError err)) - (ConcatParseInitLeftOver []) - - -- This is simplified ConcatParseBuf - stepOuter _ (ConcatParseExtract [] buf pstep pst extract) = - return $ Skip $ ConcatParseStop buf pstep pst extract - - stepOuter _ (ConcatParseExtract (x:xs) buf pstep pst extract) = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 pst1 -> - return $ Skip $ ConcatParseExtract xs [] pstep pst1 extract - PR.Partial n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 ++ xs - return $ Skip $ ConcatParseExtract src [] pstep pst1 extract - PR.Continue 0 pst1 -> - return $ Skip $ ConcatParseExtract xs (x:buf) pstep pst1 extract - PR.Continue n pst1 -> do - assert (n <= length (x:buf)) (return ()) - let (src0, buf1) = splitAt n (x:buf) - src = Prelude.reverse src0 ++ xs - return $ Skip $ ConcatParseExtract src buf1 pstep pst1 extract - PR.Done 0 b -> - return $ Skip $ ConcatParseYield (Right b) (ConcatParseInitBuf xs (func b)) - PR.Done n b -> do - assert (n <= length (x:buf)) (return ()) - let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs - return $ Skip $ ConcatParseYield (Right b) (ConcatParseInitBuf src (func b)) - PR.Error err -> - return - $ Skip - $ ConcatParseYield - (Left (ParseError err)) - (ConcatParseInitLeftOver []) - - -- This is simplified ConcatParseExtract - stepOuter _ (ConcatParseStop buf pstep pst extract) = do - pRes <- extract pst - case pRes of - PR.Partial _ _ -> error "Bug: parseIterate: Partial in extract" - PR.Continue 0 pst1 -> - return $ Skip $ ConcatParseStop buf pstep pst1 extract - PR.Continue n pst1 -> do - assert (n <= length buf) (return ()) - let (src0, buf1) = splitAt n buf - src = Prelude.reverse src0 - return $ Skip $ ConcatParseExtract src buf1 pstep pst1 extract - PR.Done 0 b -> do - return $ Skip $ - ConcatParseYield (Right b) (ConcatParseInitLeftOver []) - PR.Done n b -> do - assert (n <= length buf) (return ()) - let src = Prelude.reverse (Prelude.take n buf) - return $ Skip $ - ConcatParseYield (Right b) (ConcatParseInitBuf src (func b)) - PR.Error err -> - return - $ Skip - $ ConcatParseYield - (Left (ParseError err)) - (ConcatParseInitLeftOver []) - - stepOuter _ (ConcatParseYield a next) = return $ Yield a next - --- | Iterate a parser generating function on a stream. The initial value @b@ is --- used to generate the first parser, the parser is applied on the stream and --- the result is used to generate the next parser and so on. --- --- >>> import Data.Monoid (Sum(..)) --- >>> s = Stream.fromList [1..10] --- >>> Stream.fold Fold.toList $ fmap getSum $ Stream.catRights $ Stream.parseIterate (\b -> Parser.takeBetween 0 2 (Fold.sconcat b)) (Sum 0) $ fmap Sum s --- [3,10,21,36,55,55] --- --- This is the streaming equivalent of monad like sequenced application of --- parsers where next parser is dependent on the previous parser. --- --- /Pre-release/ --- -{-# INLINE parseIterate #-} -parseIterate - :: Monad m - => (b -> PR.Parser a m b) - -> b - -> Stream m a - -> Stream m (Either ParseError b) -parseIterate = parseIterateD - ------------------------------------------------------------------------------- --- Grouping ------------------------------------------------------------------------------- - -data GroupByState st fs a b - = GroupingInit st - | GroupingDo st !fs - | GroupingInitWith st !a - | GroupingDoWith st !fs !a - | GroupingYield !b (GroupByState st fs a b) - | GroupingDone - -{-# INLINE_NORMAL groupsBy #-} -groupsBy :: Monad m - => (a -> a -> Bool) - -> Fold m a b - -> Stream m a - -> Stream m b -{- -groupsBy eq fld = parseMany (PRD.groupBy eq fld) --} -groupsBy cmp (Fold fstep initial done) (Stream step state) = - Stream stepOuter (GroupingInit state) - - where - - {-# INLINE_LATE stepOuter #-} - stepOuter _ (GroupingInit st) = do - -- XXX Note that if the stream stops without yielding a single element - -- in the group we discard the "initial" effect. - res <- initial - return - $ case res of - FL.Partial s -> Skip $ GroupingDo st s - FL.Done b -> Yield b $ GroupingInit st - stepOuter gst (GroupingDo st fs) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - r <- fstep fs x - case r of - FL.Partial fs1 -> go SPEC x s fs1 - FL.Done b -> return $ Yield b (GroupingInit s) - Skip s -> return $ Skip $ GroupingDo s fs - Stop -> return Stop - - where - - go !_ prev stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if cmp x prev - then do - r <- fstep acc x - case r of - FL.Partial fs1 -> go SPEC prev s fs1 - FL.Done b -> return $ Yield b (GroupingInit s) - else do - r <- done acc - return $ Yield r (GroupingInitWith s x) - Skip s -> go SPEC prev s acc - Stop -> done acc >>= \r -> return $ Yield r GroupingDone - stepOuter _ (GroupingInitWith st x) = do - res <- initial - return - $ case res of - FL.Partial s -> Skip $ GroupingDoWith st s x - FL.Done b -> Yield b $ GroupingInitWith st x - stepOuter gst (GroupingDoWith st fs prev) = do - res <- fstep fs prev - case res of - FL.Partial fs1 -> go SPEC st fs1 - FL.Done b -> return $ Yield b (GroupingInit st) - - where - - -- XXX code duplicated from the previous equation - go !_ stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if cmp x prev - then do - r <- fstep acc x - case r of - FL.Partial fs1 -> go SPEC s fs1 - FL.Done b -> return $ Yield b (GroupingInit s) - else do - r <- done acc - return $ Yield r (GroupingInitWith s x) - Skip s -> go SPEC s acc - Stop -> done acc >>= \r -> return $ Yield r GroupingDone - stepOuter _ (GroupingYield _ _) = error "groupsBy: Unreachable" - stepOuter _ GroupingDone = return Stop - -{-# INLINE_NORMAL groupsRollingBy #-} -groupsRollingBy :: Monad m - => (a -> a -> Bool) - -> Fold m a b - -> Stream m a - -> Stream m b -{- -groupsRollingBy eq fld = parseMany (PRD.groupByRolling eq fld) --} -groupsRollingBy cmp (Fold fstep initial done) (Stream step state) = - Stream stepOuter (GroupingInit state) - - where - - {-# INLINE_LATE stepOuter #-} - stepOuter _ (GroupingInit st) = do - -- XXX Note that if the stream stops without yielding a single element - -- in the group we discard the "initial" effect. - res <- initial - return - $ case res of - FL.Partial fs -> Skip $ GroupingDo st fs - FL.Done fb -> Yield fb $ GroupingInit st - stepOuter gst (GroupingDo st fs) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - r <- fstep fs x - case r of - FL.Partial fs1 -> go SPEC x s fs1 - FL.Done fb -> return $ Yield fb (GroupingInit s) - Skip s -> return $ Skip $ GroupingDo s fs - Stop -> return Stop - - where - - go !_ prev stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if cmp prev x - then do - r <- fstep acc x - case r of - FL.Partial fs1 -> go SPEC x s fs1 - FL.Done b -> return $ Yield b (GroupingInit s) - else do - r <- done acc - return $ Yield r (GroupingInitWith s x) - Skip s -> go SPEC prev s acc - Stop -> done acc >>= \r -> return $ Yield r GroupingDone - stepOuter _ (GroupingInitWith st x) = do - res <- initial - return - $ case res of - FL.Partial s -> Skip $ GroupingDoWith st s x - FL.Done b -> Yield b $ GroupingInitWith st x - stepOuter gst (GroupingDoWith st fs previous) = do - res <- fstep fs previous - case res of - FL.Partial s -> go SPEC previous st s - FL.Done b -> return $ Yield b (GroupingInit st) - - where - - -- XXX GHC: groupsBy has one less parameter in this go loop and it - -- fuses. However, groupsRollingBy does not fuse, removing the prev - -- parameter makes it fuse. Something needs to be fixed in GHC. The - -- workaround for this is noted in the comments below. - go !_ prev !stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if cmp prev x - then do - r <- fstep acc x - case r of - FL.Partial fs1 -> go SPEC x s fs1 - FL.Done b -> return $ Yield b (GroupingInit st) - else do - {- - r <- done acc - return $ Yield r (GroupingInitWith s x) - -} - -- The code above does not let groupBy fuse. We use the - -- alternative code below instead. Instead of jumping - -- to GroupingInitWith state, we unroll the code of - -- GroupingInitWith state here to help GHC with stream - -- fusion. - result <- initial - r <- done acc - return - $ Yield r - $ case result of - FL.Partial fsi -> GroupingDoWith s fsi x - FL.Done b -> GroupingYield b (GroupingInit s) - Skip s -> go SPEC prev s acc - Stop -> done acc >>= \r -> return $ Yield r GroupingDone - stepOuter _ (GroupingYield r next) = return $ Yield r next - stepOuter _ GroupingDone = return Stop - ------------------------------------------------------------------------------- --- Splitting - by a predicate ------------------------------------------------------------------------------- - -data WordsByState st fs b - = WordsByInit st - | WordsByDo st !fs - | WordsByDone - | WordsByYield !b (WordsByState st fs b) - -{-# INLINE_NORMAL wordsBy #-} -wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b -wordsBy predicate (Fold fstep initial done) (Stream step state) = - Stream stepOuter (WordsByInit state) - - where - - {-# INLINE_LATE stepOuter #-} - stepOuter _ (WordsByInit st) = do - res <- initial - return - $ case res of - FL.Partial s -> Skip $ WordsByDo st s - FL.Done b -> Yield b (WordsByInit st) - - stepOuter gst (WordsByDo st fs) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - if predicate x - then do - resi <- initial - return - $ case resi of - FL.Partial fs1 -> Skip $ WordsByDo s fs1 - FL.Done b -> Yield b (WordsByInit s) - else do - r <- fstep fs x - case r of - FL.Partial fs1 -> go SPEC s fs1 - FL.Done b -> return $ Yield b (WordsByInit s) - Skip s -> return $ Skip $ WordsByDo s fs - Stop -> return Stop - - where - - go !_ stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if predicate x - then do - {- - r <- done acc - return $ Yield r (WordsByInit s) - -} - -- The above code does not fuse well. Need to check why - -- GHC is not able to simplify it well. Using the code - -- below, instead of jumping through the WordsByInit - -- state always, we directly go to WordsByDo state in - -- the common case of Partial. - resi <- initial - r <- done acc - return - $ Yield r - $ case resi of - FL.Partial fs1 -> WordsByDo s fs1 - FL.Done b -> WordsByYield b (WordsByInit s) - else do - r <- fstep acc x - case r of - FL.Partial fs1 -> go SPEC s fs1 - FL.Done b -> return $ Yield b (WordsByInit s) - Skip s -> go SPEC s acc - Stop -> done acc >>= \r -> return $ Yield r WordsByDone - - stepOuter _ WordsByDone = return Stop - - stepOuter _ (WordsByYield b next) = return $ Yield b next - ------------------------------------------------------------------------------- --- Splitting on a sequence ------------------------------------------------------------------------------- - --- String search algorithms: --- http://www-igm.univ-mlv.fr/~lecroq/string/index.html - -{- --- TODO can we unify the splitting operations using a splitting configuration --- like in the split package. --- -data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show) -data SplitOptions = SplitOptions - { style :: SplitStyle - , withSep :: Bool -- ^ keep the separators in output - -- , compact :: Bool -- ^ treat multiple consecutive separators as one - -- , trimHead :: Bool -- ^ drop blank at head - -- , trimTail :: Bool -- ^ drop blank at tail - } --} - --- XXX using "fs" as the last arg in Constructors may simplify the code a bit, --- because we can use the constructor directly without having to create "jump" --- functions. -{-# ANN type SplitOnSeqState Fuse #-} -data SplitOnSeqState rb rh ck w fs s b x = - SplitOnSeqInit - | SplitOnSeqYield b (SplitOnSeqState rb rh ck w fs s b x) - | SplitOnSeqDone - - | SplitOnSeqEmpty !fs s - - | SplitOnSeqSingle !fs s x - - | SplitOnSeqWordInit !fs s - | SplitOnSeqWordLoop !w s !fs - | SplitOnSeqWordDone Int !fs !w - - | SplitOnSeqKRInit Int !fs s rb !rh - | SplitOnSeqKRLoop fs s rb !rh !ck - | SplitOnSeqKRCheck fs s rb !rh - | SplitOnSeqKRDone Int !fs rb !rh - - | SplitOnSeqReinit (fs -> SplitOnSeqState rb rh ck w fs s b x) - -{-# INLINE_NORMAL splitOnSeq #-} -splitOnSeq - :: forall m a b. (MonadIO m, Storable a, Unbox a, Enum a, Eq a) - => Array a - -> Fold m a b - -> Stream m a - -> Stream m b -splitOnSeq patArr (Fold fstep initial done) (Stream step state) = - Stream stepOuter SplitOnSeqInit - - where - - patLen = A.length patArr - maxIndex = patLen - 1 - elemBits = SIZE_OF(a) * 8 - - -- For word pattern case - wordMask :: Word - wordMask = (1 `shiftL` (elemBits * patLen)) - 1 - - elemMask :: Word - elemMask = (1 `shiftL` elemBits) - 1 - - wordPat :: Word - wordPat = wordMask .&. A.foldl' addToWord 0 patArr - - addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) - - -- For Rabin-Karp search - k = 2891336453 :: Word32 - coeff = k ^ patLen - - addCksum cksum a = cksum * k + fromIntegral (fromEnum a) - - deltaCksum cksum old new = - addCksum cksum new - coeff * fromIntegral (fromEnum old) - - -- XXX shall we use a random starting hash or 1 instead of 0? - patHash = A.foldl' addCksum 0 patArr - - skip = return . Skip - - nextAfterInit nextGen stepRes = - case stepRes of - FL.Partial s -> nextGen s - FL.Done b -> SplitOnSeqYield b (SplitOnSeqReinit nextGen) - - {-# INLINE yieldProceed #-} - yieldProceed nextGen fs = - initial >>= skip . SplitOnSeqYield fs . nextAfterInit nextGen - - {-# INLINE_LATE stepOuter #-} - stepOuter _ SplitOnSeqInit = do - res <- initial - case res of - FL.Partial acc -> - if patLen == 0 - then return $ Skip $ SplitOnSeqEmpty acc state - else if patLen == 1 - then do - pat <- liftIO $ A.unsafeIndexIO 0 patArr - return $ Skip $ SplitOnSeqSingle acc state pat - else if SIZE_OF(a) * patLen - <= sizeOf (Proxy :: Proxy Word) - then return $ Skip $ SplitOnSeqWordInit acc state - else do - (rb, rhead) <- liftIO $ RB.new patLen - skip $ SplitOnSeqKRInit 0 acc state rb rhead - FL.Done b -> skip $ SplitOnSeqYield b SplitOnSeqInit - - stepOuter _ (SplitOnSeqYield x next) = return $ Yield x next - - --------------------------- - -- Checkpoint - --------------------------- - - stepOuter _ (SplitOnSeqReinit nextGen) = - initial >>= skip . nextAfterInit nextGen - - --------------------------- - -- Empty pattern - --------------------------- - - stepOuter gst (SplitOnSeqEmpty acc st) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - r <- fstep acc x - b1 <- - case r of - FL.Partial acc1 -> done acc1 - FL.Done b -> return b - let jump c = SplitOnSeqEmpty c s - in yieldProceed jump b1 - Skip s -> skip (SplitOnSeqEmpty acc s) - Stop -> return Stop - - ----------------- - -- Done - ----------------- - - stepOuter _ SplitOnSeqDone = return Stop - - ----------------- - -- Single Pattern - ----------------- - - stepOuter gst (SplitOnSeqSingle fs st pat) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let jump c = SplitOnSeqSingle c s pat - if pat == x - then done fs >>= yieldProceed jump - else do - r <- fstep fs x - case r of - FL.Partial fs1 -> skip $ jump fs1 - FL.Done b -> yieldProceed jump b - Skip s -> return $ Skip $ SplitOnSeqSingle fs s pat - Stop -> do - r <- done fs - return $ Skip $ SplitOnSeqYield r SplitOnSeqDone - - --------------------------- - -- Short Pattern - Shift Or - --------------------------- - - stepOuter _ (SplitOnSeqWordDone 0 fs _) = do - r <- done fs - skip $ SplitOnSeqYield r SplitOnSeqDone - stepOuter _ (SplitOnSeqWordDone n fs wrd) = do - let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1))) - r <- fstep fs (toEnum $ fromIntegral old) - case r of - FL.Partial fs1 -> skip $ SplitOnSeqWordDone (n - 1) fs1 wrd - FL.Done b -> do - let jump c = SplitOnSeqWordDone (n - 1) c wrd - yieldProceed jump b - - stepOuter gst (SplitOnSeqWordInit fs st0) = - go SPEC 0 0 st0 - - where - - {-# INLINE go #-} - go !_ !idx !wrd !st = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let wrd1 = addToWord wrd x - if idx == maxIndex - then do - if wrd1 .&. wordMask == wordPat - then do - let jump c = SplitOnSeqWordInit c s - done fs >>= yieldProceed jump - else skip $ SplitOnSeqWordLoop wrd1 s fs - else go SPEC (idx + 1) wrd1 s - Skip s -> go SPEC idx wrd s - Stop -> do - if idx /= 0 - then skip $ SplitOnSeqWordDone idx fs wrd - else do - r <- done fs - skip $ SplitOnSeqYield r SplitOnSeqDone - - stepOuter gst (SplitOnSeqWordLoop wrd0 st0 fs0) = - go SPEC wrd0 st0 fs0 - - where - - {-# INLINE go #-} - go !_ !wrd !st !fs = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let jump c = SplitOnSeqWordInit c s - wrd1 = addToWord wrd x - old = (wordMask .&. wrd) - `shiftR` (elemBits * (patLen - 1)) - r <- fstep fs (toEnum $ fromIntegral old) - case r of - FL.Partial fs1 -> do - if wrd1 .&. wordMask == wordPat - then done fs1 >>= yieldProceed jump - else go SPEC wrd1 s fs1 - FL.Done b -> yieldProceed jump b - Skip s -> go SPEC wrd s fs - Stop -> skip $ SplitOnSeqWordDone patLen fs wrd - - ------------------------------- - -- General Pattern - Karp Rabin - ------------------------------- - - stepOuter gst (SplitOnSeqKRInit idx fs st rb rh) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - rh1 <- liftIO $ RB.unsafeInsert rb rh x - if idx == maxIndex - then do - let fld = RB.unsafeFoldRing (RB.ringBound rb) - let !ringHash = fld addCksum 0 rb - if ringHash == patHash - then skip $ SplitOnSeqKRCheck fs s rb rh1 - else skip $ SplitOnSeqKRLoop fs s rb rh1 ringHash - else skip $ SplitOnSeqKRInit (idx + 1) fs s rb rh1 - Skip s -> skip $ SplitOnSeqKRInit idx fs s rb rh - Stop -> do - skip $ SplitOnSeqKRDone idx fs rb (RB.startOf rb) - - -- XXX The recursive "go" is more efficient than the state based recursion - -- code commented out below. Perhaps its more efficient because of - -- factoring out "rb" outside the loop. - -- - stepOuter gst (SplitOnSeqKRLoop fs0 st0 rb rh0 cksum0) = - go SPEC fs0 st0 rh0 cksum0 - - where - - go !_ !fs !st !rh !cksum = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - old <- liftIO $ peek rh - let cksum1 = deltaCksum cksum old x - r <- fstep fs old - case r of - FL.Partial fs1 -> do - rh1 <- liftIO (RB.unsafeInsert rb rh x) - if cksum1 == patHash - then skip $ SplitOnSeqKRCheck fs1 s rb rh1 - else go SPEC fs1 s rh1 cksum1 - FL.Done b -> do - let rst = RB.startOf rb - jump c = SplitOnSeqKRInit 0 c s rb rst - yieldProceed jump b - Skip s -> go SPEC fs s rh cksum - Stop -> skip $ SplitOnSeqKRDone patLen fs rb rh - - -- XXX The following code is 5 times slower compared to the recursive loop - -- based code above. Need to investigate why. One possibility is that the - -- go loop above does not thread around the ring buffer (rb). This code may - -- be causing the state to bloat and getting allocated on each iteration. - -- We can check the cmm/asm code to confirm. If so a good GHC solution to - -- such problem is needed. One way to avoid this could be to use unboxed - -- mutable state? - {- - stepOuter gst (SplitOnSeqKRLoop fs st rb rh cksum) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - old <- liftIO $ peek rh - let cksum1 = deltaCksum cksum old x - fs1 <- fstep fs old - if (cksum1 == patHash) - then do - r <- done fs1 - skip $ SplitOnSeqYield r $ SplitOnSeqKRInit 0 s rb rh - else do - rh1 <- liftIO (RB.unsafeInsert rb rh x) - skip $ SplitOnSeqKRLoop fs1 s rb rh1 cksum1 - Skip s -> skip $ SplitOnSeqKRLoop fs s rb rh cksum - Stop -> skip $ SplitOnSeqKRDone patLen fs rb rh - -} - - stepOuter _ (SplitOnSeqKRCheck fs st rb rh) = do - if RB.unsafeEqArray rb rh patArr - then do - r <- done fs - let rst = RB.startOf rb - jump c = SplitOnSeqKRInit 0 c st rb rst - yieldProceed jump r - else skip $ SplitOnSeqKRLoop fs st rb rh patHash - - stepOuter _ (SplitOnSeqKRDone 0 fs _ _) = do - r <- done fs - skip $ SplitOnSeqYield r SplitOnSeqDone - stepOuter _ (SplitOnSeqKRDone n fs rb rh) = do - old <- liftIO $ peek rh - let rh1 = RB.advance rb rh - r <- fstep fs old - case r of - FL.Partial fs1 -> skip $ SplitOnSeqKRDone (n - 1) fs1 rb rh1 - FL.Done b -> do - let jump c = SplitOnSeqKRDone (n - 1) c rb rh1 - yieldProceed jump b - -{-# ANN type SplitOnSuffixSeqState Fuse #-} -data SplitOnSuffixSeqState rb rh ck w fs s b x = - SplitOnSuffixSeqInit - | SplitOnSuffixSeqYield b (SplitOnSuffixSeqState rb rh ck w fs s b x) - | SplitOnSuffixSeqDone - - | SplitOnSuffixSeqEmpty !fs s - - | SplitOnSuffixSeqSingleInit !fs s x - | SplitOnSuffixSeqSingle !fs s x - - | SplitOnSuffixSeqWordInit !fs s - | SplitOnSuffixSeqWordLoop !w s !fs - | SplitOnSuffixSeqWordDone Int !fs !w - - | SplitOnSuffixSeqKRInit Int !fs s rb !rh - | SplitOnSuffixSeqKRInit1 !fs s rb !rh - | SplitOnSuffixSeqKRLoop fs s rb !rh !ck - | SplitOnSuffixSeqKRCheck fs s rb !rh - | SplitOnSuffixSeqKRDone Int !fs rb !rh - - | SplitOnSuffixSeqReinit - (fs -> SplitOnSuffixSeqState rb rh ck w fs s b x) - -{-# INLINE_NORMAL splitOnSuffixSeq #-} -splitOnSuffixSeq - :: forall m a b. (MonadIO m, Storable a, Unbox a, Enum a, Eq a) - => Bool - -> Array a - -> Fold m a b - -> Stream m a - -> Stream m b -splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) = - Stream stepOuter SplitOnSuffixSeqInit - - where - - patLen = A.length patArr - maxIndex = patLen - 1 - elemBits = SIZE_OF(a) * 8 - - -- For word pattern case - wordMask :: Word - wordMask = (1 `shiftL` (elemBits * patLen)) - 1 - - elemMask :: Word - elemMask = (1 `shiftL` elemBits) - 1 - - wordPat :: Word - wordPat = wordMask .&. A.foldl' addToWord 0 patArr - - addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a) - - nextAfterInit nextGen stepRes = - case stepRes of - FL.Partial s -> nextGen s - FL.Done b -> - SplitOnSuffixSeqYield b (SplitOnSuffixSeqReinit nextGen) - - {-# INLINE yieldProceed #-} - yieldProceed nextGen fs = - initial >>= skip . SplitOnSuffixSeqYield fs . nextAfterInit nextGen - - -- For single element pattern case - {-# INLINE processYieldSingle #-} - processYieldSingle pat x s fs = do - let jump c = SplitOnSuffixSeqSingleInit c s pat - if pat == x - then do - r <- if withSep then fstep fs x else return $ FL.Partial fs - b1 <- - case r of - FL.Partial fs1 -> done fs1 - FL.Done b -> return b - yieldProceed jump b1 - else do - r <- fstep fs x - case r of - FL.Partial fs1 -> skip $ SplitOnSuffixSeqSingle fs1 s pat - FL.Done b -> yieldProceed jump b - - -- For Rabin-Karp search - k = 2891336453 :: Word32 - coeff = k ^ patLen - - addCksum cksum a = cksum * k + fromIntegral (fromEnum a) - - deltaCksum cksum old new = - addCksum cksum new - coeff * fromIntegral (fromEnum old) - - -- XXX shall we use a random starting hash or 1 instead of 0? - patHash = A.foldl' addCksum 0 patArr - - skip = return . Skip - - {-# INLINE_LATE stepOuter #-} - stepOuter _ SplitOnSuffixSeqInit = do - res <- initial - case res of - FL.Partial fs -> - if patLen == 0 - then skip $ SplitOnSuffixSeqEmpty fs state - else if patLen == 1 - then do - pat <- liftIO $ A.unsafeIndexIO 0 patArr - skip $ SplitOnSuffixSeqSingleInit fs state pat - else if SIZE_OF(a) * patLen - <= sizeOf (Proxy :: Proxy Word) - then skip $ SplitOnSuffixSeqWordInit fs state - else do - (rb, rhead) <- liftIO $ RB.new patLen - skip $ SplitOnSuffixSeqKRInit 0 fs state rb rhead - FL.Done fb -> skip $ SplitOnSuffixSeqYield fb SplitOnSuffixSeqInit - - stepOuter _ (SplitOnSuffixSeqYield x next) = return $ Yield x next - - --------------------------- - -- Reinit - --------------------------- - - stepOuter _ (SplitOnSuffixSeqReinit nextGen) = - initial >>= skip . nextAfterInit nextGen - - --------------------------- - -- Empty pattern - --------------------------- - - stepOuter gst (SplitOnSuffixSeqEmpty acc st) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let jump c = SplitOnSuffixSeqEmpty c s - r <- fstep acc x - b1 <- - case r of - FL.Partial fs -> done fs - FL.Done b -> return b - yieldProceed jump b1 - Skip s -> skip (SplitOnSuffixSeqEmpty acc s) - Stop -> return Stop - - ----------------- - -- Done - ----------------- - - stepOuter _ SplitOnSuffixSeqDone = return Stop - - ----------------- - -- Single Pattern - ----------------- - - stepOuter gst (SplitOnSuffixSeqSingleInit fs st pat) = do - res <- step (adaptState gst) st - case res of - Yield x s -> processYieldSingle pat x s fs - Skip s -> skip $ SplitOnSuffixSeqSingleInit fs s pat - Stop -> return Stop - - stepOuter gst (SplitOnSuffixSeqSingle fs st pat) = do - res <- step (adaptState gst) st - case res of - Yield x s -> processYieldSingle pat x s fs - Skip s -> skip $ SplitOnSuffixSeqSingle fs s pat - Stop -> do - r <- done fs - skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone - - --------------------------- - -- Short Pattern - Shift Or - --------------------------- - - stepOuter _ (SplitOnSuffixSeqWordDone 0 fs _) = do - r <- done fs - skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone - stepOuter _ (SplitOnSuffixSeqWordDone n fs wrd) = do - let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1))) - r <- fstep fs (toEnum $ fromIntegral old) - case r of - FL.Partial fs1 -> skip $ SplitOnSuffixSeqWordDone (n - 1) fs1 wrd - FL.Done b -> do - let jump c = SplitOnSuffixSeqWordDone (n - 1) c wrd - yieldProceed jump b - - stepOuter gst (SplitOnSuffixSeqWordInit fs0 st0) = do - res <- step (adaptState gst) st0 - case res of - Yield x s -> do - let wrd = addToWord 0 x - r <- if withSep then fstep fs0 x else return $ FL.Partial fs0 - case r of - FL.Partial fs1 -> go SPEC 1 wrd s fs1 - FL.Done b -> do - let jump c = SplitOnSuffixSeqWordInit c s - yieldProceed jump b - Skip s -> skip (SplitOnSuffixSeqWordInit fs0 s) - Stop -> return Stop - - where - - {-# INLINE go #-} - go !_ !idx !wrd !st !fs = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let jump c = SplitOnSuffixSeqWordInit c s - let wrd1 = addToWord wrd x - r <- if withSep then fstep fs x else return $ FL.Partial fs - case r of - FL.Partial fs1 -> - if idx /= maxIndex - then go SPEC (idx + 1) wrd1 s fs1 - else if wrd1 .&. wordMask /= wordPat - then skip $ SplitOnSuffixSeqWordLoop wrd1 s fs1 - else do done fs >>= yieldProceed jump - FL.Done b -> yieldProceed jump b - Skip s -> go SPEC idx wrd s fs - Stop -> skip $ SplitOnSuffixSeqWordDone idx fs wrd - - stepOuter gst (SplitOnSuffixSeqWordLoop wrd0 st0 fs0) = - go SPEC wrd0 st0 fs0 - - where - - {-# INLINE go #-} - go !_ !wrd !st !fs = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let jump c = SplitOnSuffixSeqWordInit c s - wrd1 = addToWord wrd x - old = (wordMask .&. wrd) - `shiftR` (elemBits * (patLen - 1)) - r <- - if withSep - then fstep fs x - else fstep fs (toEnum $ fromIntegral old) - case r of - FL.Partial fs1 -> - if wrd1 .&. wordMask == wordPat - then done fs1 >>= yieldProceed jump - else go SPEC wrd1 s fs1 - FL.Done b -> yieldProceed jump b - Skip s -> go SPEC wrd s fs - Stop -> - if wrd .&. wordMask == wordPat - then return Stop - else if withSep - then do - r <- done fs - skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone - else skip $ SplitOnSuffixSeqWordDone patLen fs wrd - - ------------------------------- - -- General Pattern - Karp Rabin - ------------------------------- - - stepOuter gst (SplitOnSuffixSeqKRInit idx0 fs st0 rb rh0) = do - res <- step (adaptState gst) st0 - case res of - Yield x s -> do - rh1 <- liftIO $ RB.unsafeInsert rb rh0 x - r <- if withSep then fstep fs x else return $ FL.Partial fs - case r of - FL.Partial fs1 -> - skip $ SplitOnSuffixSeqKRInit1 fs1 s rb rh1 - FL.Done b -> do - let rst = RB.startOf rb - jump c = SplitOnSuffixSeqKRInit 0 c s rb rst - yieldProceed jump b - Skip s -> skip $ SplitOnSuffixSeqKRInit idx0 fs s rb rh0 - Stop -> return Stop - - stepOuter gst (SplitOnSuffixSeqKRInit1 fs0 st0 rb rh0) = do - go SPEC 1 rh0 st0 fs0 - - where - - go !_ !idx !rh st !fs = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - rh1 <- liftIO (RB.unsafeInsert rb rh x) - r <- if withSep then fstep fs x else return $ FL.Partial fs - case r of - FL.Partial fs1 -> - if idx /= maxIndex - then go SPEC (idx + 1) rh1 s fs1 - else skip $ - let fld = RB.unsafeFoldRing (RB.ringBound rb) - !ringHash = fld addCksum 0 rb - in if ringHash == patHash - then SplitOnSuffixSeqKRCheck fs1 s rb rh1 - else SplitOnSuffixSeqKRLoop - fs1 s rb rh1 ringHash - FL.Done b -> do - let rst = RB.startOf rb - jump c = SplitOnSuffixSeqKRInit 0 c s rb rst - yieldProceed jump b - Skip s -> go SPEC idx rh s fs - Stop -> do - -- do not issue a blank segment when we end at pattern - if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr - then return Stop - else if withSep - then do - r <- done fs - skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone - else skip $ SplitOnSuffixSeqKRDone idx fs rb (RB.startOf rb) - - stepOuter gst (SplitOnSuffixSeqKRLoop fs0 st0 rb rh0 cksum0) = - go SPEC fs0 st0 rh0 cksum0 - - where - - go !_ !fs !st !rh !cksum = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - old <- liftIO $ peek rh - rh1 <- liftIO (RB.unsafeInsert rb rh x) - let cksum1 = deltaCksum cksum old x - r <- if withSep then fstep fs x else fstep fs old - case r of - FL.Partial fs1 -> - if cksum1 /= patHash - then go SPEC fs1 s rh1 cksum1 - else skip $ SplitOnSuffixSeqKRCheck fs1 s rb rh1 - FL.Done b -> do - let rst = RB.startOf rb - jump c = SplitOnSuffixSeqKRInit 0 c s rb rst - yieldProceed jump b - Skip s -> go SPEC fs s rh cksum - Stop -> - if RB.unsafeEqArray rb rh patArr - then return Stop - else if withSep - then do - r <- done fs - skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone - else skip $ SplitOnSuffixSeqKRDone patLen fs rb rh - - stepOuter _ (SplitOnSuffixSeqKRCheck fs st rb rh) = do - if RB.unsafeEqArray rb rh patArr - then do - r <- done fs - let rst = RB.startOf rb - jump c = SplitOnSuffixSeqKRInit 0 c st rb rst - yieldProceed jump r - else skip $ SplitOnSuffixSeqKRLoop fs st rb rh patHash - - stepOuter _ (SplitOnSuffixSeqKRDone 0 fs _ _) = do - r <- done fs - skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone - stepOuter _ (SplitOnSuffixSeqKRDone n fs rb rh) = do - old <- liftIO $ peek rh - let rh1 = RB.advance rb rh - r <- fstep fs old - case r of - FL.Partial fs1 -> skip $ SplitOnSuffixSeqKRDone (n - 1) fs1 rb rh1 - FL.Done b -> do - let jump c = SplitOnSuffixSeqKRDone (n - 1) c rb rh1 - yieldProceed jump b - --- Implement this as a fold or a parser instead. --- This can be implemented easily using Rabin Karp --- | Split post any one of the given patterns. --- --- /Unimplemented/ -{-# INLINE splitOnSuffixSeqAny #-} -splitOnSuffixSeqAny :: -- (Monad m, Unboxed a, Integral a) => - [Array a] -> Fold m a b -> Stream m a -> Stream m b -splitOnSuffixSeqAny _subseq _f _m = undefined - -- D.fromStreamD $ D.splitPostAny f subseq (D.toStreamD m) - --- | Split on a prefixed separator element, dropping the separator. The --- supplied 'Fold' is applied on the split segments. --- --- @ --- > splitOnPrefix' p xs = Stream.toList $ Stream.splitOnPrefix p (Fold.toList) (Stream.fromList xs) --- > splitOnPrefix' (== '.') ".a.b" --- ["a","b"] --- @ --- --- An empty stream results in an empty output stream: --- @ --- > splitOnPrefix' (== '.') "" --- [] --- @ --- --- An empty segment consisting of only a prefix is folded to the default output --- of the fold: --- --- @ --- > splitOnPrefix' (== '.') "." --- [""] --- --- > splitOnPrefix' (== '.') ".a.b." --- ["a","b",""] --- --- > splitOnPrefix' (== '.') ".a..b" --- ["a","","b"] --- --- @ --- --- A prefix is optional at the beginning of the stream: --- --- @ --- > splitOnPrefix' (== '.') "a" --- ["a"] --- --- > splitOnPrefix' (== '.') "a.b" --- ["a","b"] --- @ --- --- 'splitOnPrefix' is an inverse of 'intercalatePrefix' with a single element: --- --- > Stream.intercalatePrefix (Stream.fromPure '.') Unfold.fromList . Stream.splitOnPrefix (== '.') Fold.toList === id --- --- Assuming the input stream does not contain the separator: --- --- > Stream.splitOnPrefix (== '.') Fold.toList . Stream.intercalatePrefix (Stream.fromPure '.') Unfold.fromList === id --- --- /Unimplemented/ -{-# INLINE splitOnPrefix #-} -splitOnPrefix :: -- (IsStream t, MonadCatch m) => - (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b -splitOnPrefix _predicate _f = undefined - -- parseMany (Parser.sliceBeginBy predicate f) - --- Int list examples for splitOn: --- --- >>> splitList [] [1,2,3,3,4] --- > [[1],[2],[3],[3],[4]] --- --- >>> splitList [5] [1,2,3,3,4] --- > [[1,2,3,3,4]] --- --- >>> splitList [1] [1,2,3,3,4] --- > [[],[2,3,3,4]] --- --- >>> splitList [4] [1,2,3,3,4] --- > [[1,2,3,3],[]] --- --- >>> splitList [2] [1,2,3,3,4] --- > [[1],[3,3,4]] --- --- >>> splitList [3] [1,2,3,3,4] --- > [[1,2],[],[4]] --- --- >>> splitList [3,3] [1,2,3,3,4] --- > [[1,2],[4]] --- --- >>> splitList [1,2,3,3,4] [1,2,3,3,4] --- > [[],[]] - --- This can be implemented easily using Rabin Karp --- | Split on any one of the given patterns. --- --- /Unimplemented/ --- -{-# INLINE splitOnAny #-} -splitOnAny :: -- (Monad m, Unboxed a, Integral a) => - [Array a] -> Fold m a b -> Stream m a -> Stream m b -splitOnAny _subseq _f _m = - undefined -- D.fromStreamD $ D.splitOnAny f subseq (D.toStreamD m) - ------------------------------------------------------------------------------- --- Nested Container Transformation ------------------------------------------------------------------------------- - -{-# ANN type SplitState Fuse #-} -data SplitState s arr - = SplitInitial s - | SplitBuffering s arr - | SplitSplitting s arr - | SplitYielding arr (SplitState s arr) - | SplitFinishing - --- XXX An alternative approach would be to use a partial fold (Fold m a b) to --- split using a splitBy like combinator. The Fold would consume upto the --- separator and return any leftover which can then be fed to the next fold. --- --- We can revisit this once we have partial folds/parsers. --- --- | Performs infix separator style splitting. -{-# INLINE_NORMAL splitInnerBy #-} -splitInnerBy - :: Monad m - => (f a -> m (f a, Maybe (f a))) -- splitter - -> (f a -> f a -> m (f a)) -- joiner - -> Stream m (f a) - -> Stream m (f a) -splitInnerBy splitter joiner (Stream step1 state1) = - Stream step (SplitInitial state1) - - where - - {-# INLINE_LATE step #-} - step gst (SplitInitial st) = do - r <- step1 gst st - case r of - Yield x s -> do - (x1, mx2) <- splitter x - return $ case mx2 of - Nothing -> Skip (SplitBuffering s x1) - Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2)) - Skip s -> return $ Skip (SplitInitial s) - Stop -> return Stop - - step gst (SplitBuffering st buf) = do - r <- step1 gst st - case r of - Yield x s -> do - (x1, mx2) <- splitter x - buf' <- joiner buf x1 - return $ case mx2 of - Nothing -> Skip (SplitBuffering s buf') - Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2)) - Skip s -> return $ Skip (SplitBuffering s buf) - Stop -> return $ Skip (SplitYielding buf SplitFinishing) - - step _ (SplitSplitting st buf) = do - (x1, mx2) <- splitter buf - return $ case mx2 of - Nothing -> Skip $ SplitBuffering st x1 - Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2) - - step _ (SplitYielding x next) = return $ Yield x next - step _ SplitFinishing = return Stop - --- | Performs infix separator style splitting. -{-# INLINE_NORMAL splitInnerBySuffix #-} -splitInnerBySuffix - :: (Monad m, Eq (f a), Monoid (f a)) - => (f a -> m (f a, Maybe (f a))) -- splitter - -> (f a -> f a -> m (f a)) -- joiner - -> Stream m (f a) - -> Stream m (f a) -splitInnerBySuffix splitter joiner (Stream step1 state1) = - Stream step (SplitInitial state1) - - where - - {-# INLINE_LATE step #-} - step gst (SplitInitial st) = do - r <- step1 gst st - case r of - Yield x s -> do - (x1, mx2) <- splitter x - return $ case mx2 of - Nothing -> Skip (SplitBuffering s x1) - Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2)) - Skip s -> return $ Skip (SplitInitial s) - Stop -> return Stop - - step gst (SplitBuffering st buf) = do - r <- step1 gst st - case r of - Yield x s -> do - (x1, mx2) <- splitter x - buf' <- joiner buf x1 - return $ case mx2 of - Nothing -> Skip (SplitBuffering s buf') - Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2)) - Skip s -> return $ Skip (SplitBuffering s buf) - Stop -> return $ - if buf == mempty - then Stop - else Skip (SplitYielding buf SplitFinishing) - - step _ (SplitSplitting st buf) = do - (x1, mx2) <- splitter buf - return $ case mx2 of - Nothing -> Skip $ SplitBuffering st x1 - Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2) - - step _ (SplitYielding x next) = return $ Yield x next - step _ SplitFinishing = return Stop - ------------------------------------------------------------------------------- --- Trimming ------------------------------------------------------------------------------- - --- | Drop prefix from the input stream if present. --- --- Space: @O(1)@ --- --- /Unimplemented/ -{-# INLINE dropPrefix #-} -dropPrefix :: - -- (Monad m, Eq a) => - Stream m a -> Stream m a -> Stream m a -dropPrefix = error "Not implemented yet!" - --- | Drop all matching infix from the input stream if present. Infix stream --- may be consumed multiple times. --- --- Space: @O(n)@ where n is the length of the infix. --- --- /Unimplemented/ -{-# INLINE dropInfix #-} -dropInfix :: - -- (Monad m, Eq a) => - Stream m a -> Stream m a -> Stream m a -dropInfix = error "Not implemented yet!" - --- | Drop suffix from the input stream if present. Suffix stream may be --- consumed multiple times. --- --- Space: @O(n)@ where n is the length of the suffix. --- --- /Unimplemented/ -{-# INLINE dropSuffix #-} -dropSuffix :: - -- (Monad m, Eq a) => - Stream m a -> Stream m a -> Stream m a -dropSuffix = error "Not implemented yet!" diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Step.hs b/src/Streamly/Internal/Data/Stream/StreamD/Step.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Step.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Step --- Copyright : (c) 2018 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Stream.StreamD.Step - ( - -- * The stream type - Step (..) - ) -where - -import Fusion.Plugin.Types (Fuse(..)) - --- | A stream is a succession of 'Step's. A 'Yield' produces a single value and --- the next state of the stream. 'Stop' indicates there are no more values in --- the stream. -{-# ANN type Step Fuse #-} -data Step s a = Yield a s | Skip s | Stop - -instance Functor (Step s) where - {-# INLINE fmap #-} - fmap f (Yield x s) = Yield (f x) s - fmap _ (Skip s) = Skip s - fmap _ Stop = Stop - -{- -fromPure :: Monad m => a -> s -> m (Step s a) -fromPure a = return . Yield a - -skip :: Monad m => s -> m (Step s a) -skip = return . Skip - -stop :: Monad m => m (Step s a) -stop = return Stop --} diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Top.hs b/src/Streamly/Internal/Data/Stream/StreamD/Top.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Top.hs +++ /dev/null @@ -1,353 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Top --- Copyright : (c) 2020 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Top level module that can depend on all other lower level Stream modules. - -module Streamly.Internal.Data.Stream.StreamD.Top - ( - -- * Transformation - -- ** Sampling - -- | Value agnostic filtering. - strideFromThen - - -- * Nesting - -- ** Set like operations - -- | These are not exactly set operations because streams are not - -- necessarily sets, they may have duplicated elements. These operations - -- are generic i.e. they work on streams of unconstrained types, therefore, - -- they have quadratic performance characterstics. For better performance - -- using Set structures see the Streamly.Internal.Data.Stream.Container - -- module. - , filterInStreamGenericBy - , deleteInStreamGenericBy - , unionWithStreamGenericBy - - -- ** Set like operations on sorted streams - , filterInStreamAscBy - , deleteInStreamAscBy - , unionWithStreamAscBy - - -- ** Join operations - , joinInnerGeneric - - -- * Joins on sorted stream - , joinInnerAscBy - , joinLeftAscBy - , joinOuterAscBy - ) -where - -#include "inline.hs" - -import Control.Monad.IO.Class (MonadIO(..)) -import Data.IORef (newIORef, readIORef, modifyIORef') -import Streamly.Internal.Data.Fold.Type (Fold) -import Streamly.Internal.Data.Stream.Common () -import Streamly.Internal.Data.Stream.StreamD.Type (Stream, cross) - -import qualified Data.List as List -import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Stream.StreamD.Type as Stream -import qualified Streamly.Internal.Data.Stream.StreamD.Nesting as Stream -import qualified Streamly.Internal.Data.Stream.StreamD.Transform as Stream - -import Prelude hiding (filter, zipWith, concatMap, concat) - -#include "DocTestDataStream.hs" - ------------------------------------------------------------------------------- --- Sampling ------------------------------------------------------------------------------- - --- XXX We can implement this using addition instead of "mod" to make it more --- efficient. - --- | @strideFromthen offset stride@ takes the element at @offset@ index and --- then every element at strides of @stride@. --- --- >>> Stream.fold Fold.toList $ Stream.strideFromThen 2 3 $ Stream.enumerateFromTo 0 10 --- [2,5,8] --- -{-# INLINE strideFromThen #-} -strideFromThen :: Monad m => Int -> Int -> Stream m a -> Stream m a -strideFromThen offset stride = - Stream.with Stream.indexed Stream.filter - (\(i, _) -> i >= offset && (i - offset) `mod` stride == 0) - ------------------------------------------------------------------------------- --- SQL Joins ------------------------------------------------------------------------------- --- --- Some references: --- * https://en.wikipedia.org/wiki/Relational_algebra --- * https://en.wikipedia.org/wiki/Join_(SQL) - --- TODO: OrdSet/IntSet/hashmap based versions of these. With Eq only --- constraint, the best would be to use an Array with linear search. If the --- second stream is sorted we can also use a binary search, using Ord --- constraint or an ordering function. --- --- For Storables we can cache the second stream into an unboxed array for --- possibly faster access/compact representation? --- --- If we do not want to keep the stream in memory but always read it from the --- source (disk/network) every time we iterate through it then we can do that --- too by reading the stream every time, the stream must have immutable state --- in that case and the user is responsible for the behavior if the stream --- source changes during iterations. We can also use an Unfold instead of --- stream. We probably need a way to distinguish streams that can be read --- mutliple times without any interference (e.g. unfolding a stream using an --- immutable handle would work i.e. using pread/pwrite instead of maintaining --- an offset in the handle). - --- XXX We can do this concurrently. --- XXX If the second stream is sorted and passed as an Array we could use --- binary search if we have an Ord instance or Ordering returning function. The --- time complexity would then become (m x log n). - --- | Like 'cross' but emits only those tuples where @a == b@ using the --- supplied equality predicate. --- --- Definition: --- --- >>> joinInnerGeneric eq s1 s2 = Stream.filter (\(a, b) -> a `eq` b) $ Stream.cross s1 s2 --- --- You should almost always prefer @joinInnerOrd@ over 'joinInnerGeneric' if --- possible. @joinInnerOrd@ is an order of magnitude faster but may take more --- space for caching the second stream. --- --- See 'Streamly.Internal.Data.Unfold.joinInnerGeneric' for a much faster fused --- alternative. --- --- Time: O(m x n) --- --- /Pre-release/ -{-# INLINE joinInnerGeneric #-} -joinInnerGeneric :: Monad m => - (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, b) -joinInnerGeneric eq s1 s2 = Stream.filter (\(a, b) -> a `eq` b) $ cross s1 s2 -{- -joinInnerGeneric eq s1 s2 = do - -- ConcatMap works faster than bind - Stream.concatMap (\a -> - Stream.concatMap (\b -> - if a `eq` b - then Stream.fromPure (a, b) - else Stream.nil - ) s2 - ) s1 --} - --- | A more efficient 'joinInner' for sorted streams. --- --- Space: O(1) --- --- Time: O(m + n) --- --- /Unimplemented/ -{-# INLINE joinInnerAscBy #-} -joinInnerAscBy :: - (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, b) -joinInnerAscBy = undefined - --- | A more efficient 'joinLeft' for sorted streams. --- --- Space: O(1) --- --- Time: O(m + n) --- --- /Unimplemented/ -{-# INLINE joinLeftAscBy #-} -joinLeftAscBy :: -- Monad m => - (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) -joinLeftAscBy _eq _s1 _s2 = undefined - --- | A more efficient 'joinOuter' for sorted streams. --- --- Space: O(1) --- --- Time: O(m + n) --- --- /Unimplemented/ -{-# INLINE joinOuterAscBy #-} -joinOuterAscBy :: -- Monad m => - (a -> b -> Ordering) - -> Stream m a - -> Stream m b - -> Stream m (Maybe a, Maybe b) -joinOuterAscBy _eq _s1 _s2 = undefined - ------------------------------------------------------------------------------- --- Set operations (special joins) ------------------------------------------------------------------------------- --- --- TODO: OrdSet/IntSet/hashmap based versions of these. With Eq only constraint --- the best would be to use an Array with linear search. If the second stream --- is sorted we can also use a binary search, using Ord constraint. - --- | Keep only those elements in the second stream that are present in the --- first stream too. The first stream is folded to a container using the --- supplied fold and then the elements in the container are looked up using the --- supplied lookup function. --- --- The first stream must be finite and must not block. -{-# INLINE filterStreamWith #-} -filterStreamWith :: Monad m => - Fold m a (f a) - -> (a -> f a -> Bool) - -> Stream m a - -> Stream m a - -> Stream m a -filterStreamWith fld member s1 s2 = - Stream.concatEffect - $ do - xs <- Stream.fold fld s1 - return $ Stream.filter (`member` xs) s2 - --- | 'filterInStreamGenericBy' retains only those elements in the second stream that --- are present in the first stream. --- --- >>> Stream.fold Fold.toList $ Stream.filterInStreamGenericBy (==) (Stream.fromList [1,2,2,4]) (Stream.fromList [2,1,1,3]) --- [2,1,1] --- --- >>> Stream.fold Fold.toList $ Stream.filterInStreamGenericBy (==) (Stream.fromList [2,1,1,3]) (Stream.fromList [1,2,2,4]) --- [1,2,2] --- --- Similar to the list intersectBy operation but with the stream argument order --- flipped. --- --- The first stream must be finite and must not block. Second stream is --- processed only after the first stream is fully realized. --- --- Space: O(n) where @n@ is the number of elements in the second stream. --- --- Time: O(m x n) where @m@ is the number of elements in the first stream and --- @n@ is the number of elements in the second stream. --- --- /Pre-release/ -{-# INLINE filterInStreamGenericBy #-} -filterInStreamGenericBy :: Monad m => - (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a -filterInStreamGenericBy eq = - -- XXX Use an (unboxed) array instead. - filterStreamWith - (Fold.scanMaybe (Fold.uniqBy eq) Fold.toListRev) - (List.any . eq) - --- | Like 'filterInStreamGenericBy' but assumes that the input streams are sorted in --- ascending order. To use it on streams sorted in descending order pass an --- inverted comparison function returning GT for less than and LT for greater --- than. --- --- Space: O(1) --- --- Time: O(m+n) --- --- /Pre-release/ -{-# INLINE filterInStreamAscBy #-} -filterInStreamAscBy :: Monad m => - (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a -filterInStreamAscBy eq s1 s2 = Stream.intersectBySorted eq s2 s1 - --- | Delete all elements of the first stream from the seconds stream. If an --- element occurs multiple times in the first stream as many occurrences of it --- are deleted from the second stream. --- --- >>> Stream.fold Fold.toList $ Stream.deleteInStreamGenericBy (==) (Stream.fromList [1,2,3]) (Stream.fromList [1,2,2]) --- [2] --- --- The following laws hold: --- --- > deleteInStreamGenericBy (==) s1 (s1 `append` s2) === s2 --- > deleteInStreamGenericBy (==) s1 (s1 `interleave` s2) === s2 --- --- Same as the list 'Data.List.//' operation but with argument order flipped. --- --- The first stream must be finite and must not block. Second stream is --- processed only after the first stream is fully realized. --- --- Space: O(m) where @m@ is the number of elements in the first stream. --- --- Time: O(m x n) where @m@ is the number of elements in the first stream and --- @n@ is the number of elements in the second stream. --- --- /Pre-release/ -{-# INLINE deleteInStreamGenericBy #-} -deleteInStreamGenericBy :: Monad m => - (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a -deleteInStreamGenericBy eq s1 s2 = - Stream.concatEffect - $ do - -- This may work well if s1 is small - -- If s1 is big we can go through s1, deleting elements from s2 and - -- not emitting an element if it was successfully deleted from s2. - -- we will need a deleteBy that can return whether the element was - -- deleted or not. - xs <- Stream.fold Fold.toList s2 - let f = Fold.foldl' (flip (List.deleteBy eq)) xs - fmap Stream.fromList $ Stream.fold f s1 - --- | A more efficient 'deleteInStreamGenericBy' for streams sorted in ascending order. --- --- Space: O(1) --- --- /Unimplemented/ -{-# INLINE deleteInStreamAscBy #-} -deleteInStreamAscBy :: -- (Monad m) => - (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a -deleteInStreamAscBy _eq _s1 _s2 = undefined - --- XXX Remove the MonadIO constraint. We can just cache one stream and then --- implement using differenceEqBy. - --- | This essentially appends to the second stream all the occurrences of --- elements in the first stream that are not already present in the second --- stream. --- --- Equivalent to the following except that @s2@ is evaluated only once: --- --- >>> unionWithStreamGenericBy eq s1 s2 = s2 `Stream.append` (Stream.deleteInStreamGenericBy eq s2 s1) --- --- Example: --- --- >>> Stream.fold Fold.toList $ Stream.unionWithStreamGenericBy (==) (Stream.fromList [1,1,2,3]) (Stream.fromList [1,2,2,4]) --- [1,2,2,4,3] --- --- Space: O(n) --- --- Time: O(m x n) --- --- /Pre-release/ -{-# INLINE unionWithStreamGenericBy #-} -unionWithStreamGenericBy :: MonadIO m => - (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a -unionWithStreamGenericBy eq s1 s2 = - Stream.concatEffect - $ do - xs <- Stream.fold Fold.toList s1 - -- XXX we can use postscanlMAfter' instead of IORef - ref <- liftIO $ newIORef $! List.nubBy eq xs - let f x = do - liftIO $ modifyIORef' ref (List.deleteBy eq x) - return x - s3 = Stream.concatEffect - $ do - xs1 <- liftIO $ readIORef ref - return $ Stream.fromList xs1 - return $ Stream.mapM f s2 `Stream.append` s3 - --- | A more efficient 'unionWithStreamGenericBy' for sorted streams. --- --- Space: O(1) --- --- /Unimplemented/ -{-# INLINE unionWithStreamAscBy #-} -unionWithStreamAscBy :: -- (Monad m) => - (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a -unionWithStreamAscBy _eq _s1 _s2 = undefined diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Transform.hs b/src/Streamly/Internal/Data/Stream/StreamD/Transform.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Transform.hs +++ /dev/null @@ -1,1945 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Transform --- Copyright : (c) 2018 Composewell Technologies --- (c) Roman Leshchinskiy 2008-2010 --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- "Streamly.Internal.Data.Pipe" might ultimately replace this module. - --- A few functions in this module have been adapted from the vector package --- (c) Roman Leshchinskiy. See the notes in specific combinators. - -module Streamly.Internal.Data.Stream.StreamD.Transform - ( - -- * Piping - -- | Pass through a 'Pipe'. - transform - - -- * Mapping - -- | Stateless one-to-one maps. - , map - , mapM - , sequence - - -- * Mapping Effects - , tap - , tapOffsetEvery - , trace - , trace_ - - -- * Folding - , foldrS - , foldlS - - -- * Scanning By 'Fold' - , postscan - , scan - , scanMany - - -- * Splitting - , splitOn - - -- * Scanning - -- | Left scans. Stateful, mostly one-to-one maps. - , scanlM' - , scanlMAfter' - , scanl' - , scanlM - , scanl - , scanl1M' - , scanl1' - , scanl1M - , scanl1 - - , prescanl' - , prescanlM' - - , postscanl - , postscanlM - , postscanl' - , postscanlM' - , postscanlMAfter' - - , postscanlx' - , postscanlMx' - , scanlMx' - , scanlx' - - -- * Filtering - -- | Produce a subset of the stream. - , with - , scanMaybe - , filter - , filterM - , deleteBy - , uniqBy - , uniq - , prune - , repeated - - -- * Trimming - -- | Produce a subset of the stream trimmed at ends. - , take - , takeWhile - , takeWhileM - , takeWhileLast - , takeWhileAround - , drop - , dropWhile - , dropWhileM - , dropLast - , dropWhileLast - , dropWhileAround - - -- * Inserting Elements - -- | Produce a superset of the stream. - , insertBy - , intersperse - , intersperseM - , intersperseMWith - , intersperseMSuffix - , intersperseMSuffixWith - - -- * Inserting Side Effects - , intersperseM_ - , intersperseMSuffix_ - , intersperseMPrefix_ - - , delay - , delayPre - , delayPost - - -- * Reordering - -- | Produce strictly the same set but reordered. - , reverse - , reverseUnbox - , reassembleBy - - -- * Position Indexing - , indexed - , indexedR - - -- * Time Indexing - , timestampWith - , timestamped - , timeIndexWith - , timeIndexed - - -- * Searching - , findIndices - , elemIndices - , slicesBy - - -- * Rolling map - -- | Map using the previous element. - , rollingMap - , rollingMapM - , rollingMap2 - - -- * Maybe Streams - , mapMaybe - , mapMaybeM - , catMaybes - - -- * Either Streams - , catLefts - , catRights - , catEithers - ) -where - -#include "inline.hs" - -import Control.Concurrent (threadDelay) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Either (fromLeft, isLeft, isRight, fromRight) -import Data.Functor ((<&>)) -import Data.Maybe (fromJust, isJust) -import Fusion.Plugin.Types (Fuse(..)) - -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Pipe.Type (Pipe(..), PipeState(..)) -import Streamly.Internal.Data.SVar.Type (adaptState) -import Streamly.Internal.Data.Time.Units (AbsTime, RelTime64) -import Streamly.Internal.Data.Unboxed (Unbox) -import Streamly.Internal.System.IO (defaultChunkSize) - --- import qualified Data.List as List -import qualified Streamly.Internal.Data.Array.Type as A -import qualified Streamly.Internal.Data.Fold as FL -import qualified Streamly.Internal.Data.Pipe.Type as Pipe -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - -import Prelude hiding - ( drop, dropWhile, filter, map, mapM, reverse - , scanl, scanl1, sequence, take, takeWhile, zipWith) - -import Streamly.Internal.Data.Stream.StreamD.Generate - (absTimesWith, relTimesWith) -import Streamly.Internal.Data.Stream.StreamD.Type - -#include "DocTestDataStream.hs" - ------------------------------------------------------------------------------- --- Piping ------------------------------------------------------------------------------- - --- | Use a 'Pipe' to transform a stream. --- --- /Pre-release/ --- -{-# INLINE_NORMAL transform #-} -transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b -transform (Pipe pstep1 pstep2 pstate) (Stream step state) = - Stream step' (Consume pstate, state) - - where - - {-# INLINE_LATE step' #-} - - step' gst (Consume pst, st) = pst `seq` do - r <- step (adaptState gst) st - case r of - Yield x s -> do - res <- pstep1 pst x - case res of - Pipe.Yield b pst' -> return $ Yield b (pst', s) - Pipe.Continue pst' -> return $ Skip (pst', s) - Skip s -> return $ Skip (Consume pst, s) - Stop -> return Stop - - step' _ (Produce pst, st) = pst `seq` do - res <- pstep2 pst - case res of - Pipe.Yield b pst' -> return $ Yield b (pst', st) - Pipe.Continue pst' -> return $ Skip (pst', st) - ------------------------------------------------------------------------------- --- Transformation Folds ------------------------------------------------------------------------------- - --- Note, this is going to have horrible performance, because of the nature of --- the stream type (i.e. direct stream vs CPS). Its only for reference, it is --- likely be practically unusable. -{-# INLINE_NORMAL foldlS #-} -foldlS :: Monad m - => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b -foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin)) - where - step' gst (Left (st, acc)) = do - r <- step (adaptState gst) st - return $ case r of - Yield x s -> Skip (Left (s, fstep acc x)) - Skip s -> Skip (Left (s, acc)) - Stop -> Skip (Right acc) - - step' gst (Right (Stream stp stt)) = do - r <- stp (adaptState gst) stt - return $ case r of - Yield x s -> Yield x (Right (Stream stp s)) - Skip s -> Skip (Right (Stream stp s)) - Stop -> Stop - ------------------------------------------------------------------------------- --- Transformation by Mapping ------------------------------------------------------------------------------- - --- | --- >>> sequence = Stream.mapM id --- --- Replace the elements of a stream of monadic actions with the outputs of --- those actions. --- --- >>> s = Stream.fromList [putStr "a", putStr "b", putStrLn "c"] --- >>> Stream.fold Fold.drain $ Stream.sequence s --- abc --- -{-# INLINE_NORMAL sequence #-} -sequence :: Monad m => Stream m (m a) -> Stream m a -sequence (Stream step state) = Stream step' state - where - {-# INLINE_LATE step' #-} - step' gst st = do - r <- step (adaptState gst) st - case r of - Yield x s -> x >>= \a -> return (Yield a s) - Skip s -> return $ Skip s - Stop -> return Stop - ------------------------------------------------------------------------------- --- Mapping side effects ------------------------------------------------------------------------------- - -data TapState fs st a - = TapInit | Tapping !fs st | TapDone st - --- XXX Multiple yield points - --- | Tap the data flowing through a stream into a 'Fold'. For example, you may --- add a tap to log the contents flowing through the stream. The fold is used --- only for effects, its result is discarded. --- --- @ --- Fold m a b --- | --- -----stream m a ---------------stream m a----- --- --- @ --- --- >>> s = Stream.enumerateFromTo 1 2 --- >>> Stream.fold Fold.drain $ Stream.tap (Fold.drainMapM print) s --- 1 --- 2 --- --- Compare with 'trace'. --- -{-# INLINE tap #-} -tap :: Monad m => Fold m a b -> Stream m a -> Stream m a -tap (Fold fstep initial extract) (Stream step state) = Stream step' TapInit - - where - - step' _ TapInit = do - res <- initial - return - $ Skip - $ case res of - FL.Partial s -> Tapping s state - FL.Done _ -> TapDone state - step' gst (Tapping acc st) = do - r <- step gst st - case r of - Yield x s -> do - res <- fstep acc x - return - $ Yield x - $ case res of - FL.Partial fs -> Tapping fs s - FL.Done _ -> TapDone s - Skip s -> return $ Skip (Tapping acc s) - Stop -> do - void $ extract acc - return Stop - step' gst (TapDone st) = do - r <- step gst st - return - $ case r of - Yield x s -> Yield x (TapDone s) - Skip s -> Skip (TapDone s) - Stop -> Stop - -data TapOffState fs s a - = TapOffInit - | TapOffTapping !fs s Int - | TapOffDone s - --- XXX Multiple yield points -{-# INLINE_NORMAL tapOffsetEvery #-} -tapOffsetEvery :: Monad m - => Int -> Int -> Fold m a b -> Stream m a -> Stream m a -tapOffsetEvery offset n (Fold fstep initial extract) (Stream step state) = - Stream step' TapOffInit - - where - - {-# INLINE_LATE step' #-} - step' _ TapOffInit = do - res <- initial - return - $ Skip - $ case res of - FL.Partial s -> TapOffTapping s state (offset `mod` n) - FL.Done _ -> TapOffDone state - step' gst (TapOffTapping acc st count) = do - r <- step gst st - case r of - Yield x s -> do - next <- - if count <= 0 - then do - res <- fstep acc x - return - $ case res of - FL.Partial sres -> - TapOffTapping sres s (n - 1) - FL.Done _ -> TapOffDone s - else return $ TapOffTapping acc s (count - 1) - return $ Yield x next - Skip s -> return $ Skip (TapOffTapping acc s count) - Stop -> do - void $ extract acc - return Stop - step' gst (TapOffDone st) = do - r <- step gst st - return - $ case r of - Yield x s -> Yield x (TapOffDone s) - Skip s -> Skip (TapOffDone s) - Stop -> Stop - --- | Apply a monadic function to each element flowing through the stream and --- discard the results. --- --- >>> s = Stream.enumerateFromTo 1 2 --- >>> Stream.fold Fold.drain $ Stream.trace print s --- 1 --- 2 --- --- Compare with 'tap'. --- -{-# INLINE trace #-} -trace :: Monad m => (a -> m b) -> Stream m a -> Stream m a -trace f = mapM (\x -> void (f x) >> return x) - --- | Perform a side effect before yielding each element of the stream and --- discard the results. --- --- >>> s = Stream.enumerateFromTo 1 2 --- >>> Stream.fold Fold.drain $ Stream.trace_ (print "got here") s --- "got here" --- "got here" --- --- Same as 'intersperseMPrefix_' but always serial. --- --- See also: 'trace' --- --- /Pre-release/ -{-# INLINE trace_ #-} -trace_ :: Monad m => m b -> Stream m a -> Stream m a -trace_ eff = mapM (\x -> eff >> return x) - ------------------------------------------------------------------------------- --- Scanning with a Fold ------------------------------------------------------------------------------- - -data ScanState s f = ScanInit s | ScanDo s !f | ScanDone - --- | Postscan a stream using the given monadic fold. --- --- The following example extracts the input stream up to a point where the --- running average of elements is no more than 10: --- --- >>> import Data.Maybe (fromJust) --- >>> let avg = Fold.teeWith (/) Fold.sum (fmap fromIntegral Fold.length) --- >>> s = Stream.enumerateFromTo 1.0 100.0 --- >>> :{ --- Stream.fold Fold.toList --- $ fmap (fromJust . fst) --- $ Stream.takeWhile (\(_,x) -> x <= 10) --- $ Stream.postscan (Fold.tee Fold.latest avg) s --- :} --- [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0] --- -{-# INLINE_NORMAL postscan #-} -postscan :: Monad m => FL.Fold m a b -> Stream m a -> Stream m b -postscan (FL.Fold fstep initial extract) (Stream sstep state) = - Stream step (ScanInit state) - - where - - {-# INLINE_LATE step #-} - step _ (ScanInit st) = do - res <- initial - return - $ case res of - FL.Partial fs -> Skip $ ScanDo st fs - FL.Done b -> Yield b ScanDone - step gst (ScanDo st fs) = do - res <- sstep (adaptState gst) st - case res of - Yield x s -> do - r <- fstep fs x - case r of - FL.Partial fs1 -> do - !b <- extract fs1 - return $ Yield b $ ScanDo s fs1 - FL.Done b -> return $ Yield b ScanDone - Skip s -> return $ Skip $ ScanDo s fs - Stop -> return Stop - step _ ScanDone = return Stop - -{-# INLINE scanWith #-} -scanWith :: Monad m - => Bool -> Fold m a b -> Stream m a -> Stream m b -scanWith restart (Fold fstep initial extract) (Stream sstep state) = - Stream step (ScanInit state) - - where - - {-# INLINE runStep #-} - runStep st action = do - res <- action - case res of - FL.Partial fs -> do - !b <- extract fs - return $ Yield b $ ScanDo st fs - FL.Done b -> - let next = if restart then ScanInit st else ScanDone - in return $ Yield b next - - {-# INLINE_LATE step #-} - step _ (ScanInit st) = runStep st initial - step gst (ScanDo st fs) = do - res <- sstep (adaptState gst) st - case res of - Yield x s -> runStep s (fstep fs x) - Skip s -> return $ Skip $ ScanDo s fs - Stop -> return Stop - step _ ScanDone = return Stop - --- XXX It may be useful to have a version of scan where we can keep the --- accumulator independent of the value emitted. So that we do not necessarily --- have to keep a value in the accumulator which we are not using. We can pass --- an extraction function that will take the accumulator and the current value --- of the element and emit the next value in the stream. That will also make it --- possible to modify the accumulator after using it. In fact, the step function --- can return new accumulator and the value to be emitted. The signature would --- be more like mapAccumL. - --- | Strict left scan. Scan a stream using the given monadic fold. --- --- >>> s = Stream.fromList [1..10] --- >>> Stream.fold Fold.toList $ Stream.takeWhile (< 10) $ Stream.scan Fold.sum s --- [0,1,3,6] --- --- See also: 'usingStateT' --- - --- EXPLANATION: --- >>> scanl' step z = Stream.scan (Fold.foldl' step z) --- --- Like 'map', 'scanl'' too is a one to one transformation, --- however it adds an extra element. --- --- >>> s = Stream.fromList [1,2,3,4] --- >>> Stream.fold Fold.toList $ scanl' (+) 0 s --- [0,1,3,6,10] --- --- >>> Stream.fold Fold.toList $ scanl' (flip (:)) [] s --- [[],[1],[2,1],[3,2,1],[4,3,2,1]] --- --- The output of 'scanl'' is the initial value of the accumulator followed by --- all the intermediate steps and the final result of 'foldl''. --- --- By streaming the accumulated state after each fold step, we can share the --- state across multiple stages of stream composition. Each stage can modify or --- extend the state, do some processing with it and emit it for the next stage, --- thus modularizing the stream processing. This can be useful in --- stateful or event-driven programming. --- --- Consider the following monolithic example, computing the sum and the product --- of the elements in a stream in one go using a @foldl'@: --- --- >>> foldl' step z = Stream.fold (Fold.foldl' step z) --- >>> foldl' (\(s, p) x -> (s + x, p * x)) (0,1) s --- (10,24) --- --- Using @scanl'@ we can make it modular by computing the sum in the first --- stage and passing it down to the next stage for computing the product: --- --- >>> :{ --- foldl' (\(_, p) (s, x) -> (s, p * x)) (0,1) --- $ scanl' (\(s, _) x -> (s + x, x)) (0,1) --- $ Stream.fromList [1,2,3,4] --- :} --- (10,24) --- --- IMPORTANT: 'scanl'' evaluates the accumulator to WHNF. To avoid building --- lazy expressions inside the accumulator, it is recommended that a strict --- data structure is used for accumulator. --- -{-# INLINE_NORMAL scan #-} -scan :: Monad m - => FL.Fold m a b -> Stream m a -> Stream m b -scan = scanWith False - --- | Like 'scan' but restarts scanning afresh when the scanning fold --- terminates. --- -{-# INLINE_NORMAL scanMany #-} -scanMany :: Monad m - => FL.Fold m a b -> Stream m a -> Stream m b -scanMany = scanWith True - ------------------------------------------------------------------------------- --- Scanning - Prescans ------------------------------------------------------------------------------- - --- Adapted from the vector package. --- --- XXX Is a prescan useful, discarding the last step does not sound useful? I --- am not sure about the utility of this function, so this is implemented but --- not exposed. We can expose it if someone provides good reasons why this is --- useful. --- --- XXX We have to execute the stream one step ahead to know that we are at the --- last step. The vector implementation of prescan executes the last fold step --- but does not yield the result. This means we have executed the effect but --- discarded value. This does not sound right. In this implementation we are --- not executing the last fold step. -{-# INLINE_NORMAL prescanlM' #-} -prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b -prescanlM' f mz (Stream step state) = Stream step' (state, mz) - where - {-# INLINE_LATE step' #-} - step' gst (st, prev) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - acc <- prev - return $ Yield acc (s, f acc x) - Skip s -> return $ Skip (s, prev) - Stop -> return Stop - -{-# INLINE prescanl' #-} -prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b -prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z) - ------------------------------------------------------------------------------- --- Monolithic postscans (postscan followed by a map) ------------------------------------------------------------------------------- - --- The performance of a modular postscan followed by a map seems to be --- equivalent to this monolithic scan followed by map therefore we may not need --- this implementation. We just have it for performance comparison and in case --- modular version does not perform well in some situation. --- -{-# INLINE_NORMAL postscanlMx' #-} -postscanlMx' :: Monad m - => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b -postscanlMx' fstep begin done (Stream step state) = do - Stream step' (state, begin) - where - {-# INLINE_LATE step' #-} - step' gst (st, acc) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - old <- acc - y <- fstep old x - v <- done y - v `seq` y `seq` return (Yield v (s, return y)) - Skip s -> return $ Skip (s, acc) - Stop -> return Stop - -{-# INLINE_NORMAL postscanlx' #-} -postscanlx' :: Monad m - => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b -postscanlx' fstep begin done = - postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) - --- XXX do we need consM strict to evaluate the begin value? -{-# INLINE scanlMx' #-} -scanlMx' :: Monad m - => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b -scanlMx' fstep begin done s = - (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s - -{-# INLINE scanlx' #-} -scanlx' :: Monad m - => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b -scanlx' fstep begin done = - scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) - ------------------------------------------------------------------------------- --- postscans ------------------------------------------------------------------------------- - --- Adapted from the vector package. -{-# INLINE_NORMAL postscanlM' #-} -postscanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b -postscanlM' fstep begin (Stream step state) = - Stream step' Nothing - where - {-# INLINE_LATE step' #-} - step' _ Nothing = do - !x <- begin - return $ Skip (Just (state, x)) - - step' gst (Just (st, acc)) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - !y <- fstep acc x - return $ Yield y (Just (s, y)) - Skip s -> return $ Skip (Just (s, acc)) - Stop -> return Stop - -{-# INLINE_NORMAL postscanl' #-} -postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a -postscanl' f seed = postscanlM' (\a b -> return (f a b)) (return seed) - -{-# ANN type PScanAfterState Fuse #-} -data PScanAfterState m st acc = - PScanAfterStep st (m acc) - | PScanAfterYield acc (PScanAfterState m st acc) - | PScanAfterStop - --- We can possibly have the "done" function as a Maybe to provide an option to --- emit or not emit the accumulator when the stream stops. --- --- TBD: use a single Yield point --- -{-# INLINE_NORMAL postscanlMAfter' #-} -postscanlMAfter' :: Monad m - => (b -> a -> m b) -> m b -> (b -> m b) -> Stream m a -> Stream m b -postscanlMAfter' fstep initial done (Stream step1 state1) = do - Stream step (PScanAfterStep state1 initial) - - where - - {-# INLINE_LATE step #-} - step gst (PScanAfterStep st acc) = do - r <- step1 (adaptState gst) st - case r of - Yield x s -> do - !old <- acc - !y <- fstep old x - return (Skip $ PScanAfterYield y (PScanAfterStep s (return y))) - Skip s -> return $ Skip $ PScanAfterStep s acc - -- Strictness is important for fusion - Stop -> do - !v <- acc - !res <- done v - return (Skip $ PScanAfterYield res PScanAfterStop) - step _ (PScanAfterYield acc next) = return $ Yield acc next - step _ PScanAfterStop = return Stop - -{-# INLINE_NORMAL postscanlM #-} -postscanlM :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b -postscanlM fstep begin (Stream step state) = Stream step' Nothing - where - {-# INLINE_LATE step' #-} - step' _ Nothing = do - r <- begin - return $ Skip (Just (state, r)) - - step' gst (Just (st, acc)) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - y <- fstep acc x - return (Yield y (Just (s, y))) - Skip s -> return $ Skip (Just (s, acc)) - Stop -> return Stop - -{-# INLINE_NORMAL postscanl #-} -postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a -postscanl f seed = postscanlM (\a b -> return (f a b)) (return seed) - --- | Like 'scanl'' but with a monadic step function and a monadic seed. --- -{-# INLINE_NORMAL scanlM' #-} -scanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b -scanlM' fstep begin (Stream step state) = Stream step' Nothing - where - {-# INLINE_LATE step' #-} - step' _ Nothing = do - !x <- begin - return $ Yield x (Just (state, x)) - step' gst (Just (st, acc)) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - !y <- fstep acc x - return $ Yield y (Just (s, y)) - Skip s -> return $ Skip (Just (s, acc)) - Stop -> return Stop - --- | @scanlMAfter' accumulate initial done stream@ is like 'scanlM'' except --- that it provides an additional @done@ function to be applied on the --- accumulator when the stream stops. The result of @done@ is also emitted in --- the stream. --- --- This function can be used to allocate a resource in the beginning of the --- scan and release it when the stream ends or to flush the internal state of --- the scan at the end. --- --- /Pre-release/ --- -{-# INLINE scanlMAfter' #-} -scanlMAfter' :: Monad m - => (b -> a -> m b) -> m b -> (b -> m b) -> Stream m a -> Stream m b -scanlMAfter' fstep initial done s = - initial `consM` postscanlMAfter' fstep initial done s - --- >>> scanl' f z xs = z `Stream.cons` postscanl' f z xs - --- | Strict left scan. Like 'map', 'scanl'' too is a one to one transformation, --- however it adds an extra element. --- --- >>> Stream.toList $ Stream.scanl' (+) 0 $ Stream.fromList [1,2,3,4] --- [0,1,3,6,10] --- --- >>> Stream.toList $ Stream.scanl' (flip (:)) [] $ Stream.fromList [1,2,3,4] --- [[],[1],[2,1],[3,2,1],[4,3,2,1]] --- --- The output of 'scanl'' is the initial value of the accumulator followed by --- all the intermediate steps and the final result of 'foldl''. --- --- By streaming the accumulated state after each fold step, we can share the --- state across multiple stages of stream composition. Each stage can modify or --- extend the state, do some processing with it and emit it for the next stage, --- thus modularizing the stream processing. This can be useful in --- stateful or event-driven programming. --- --- Consider the following monolithic example, computing the sum and the product --- of the elements in a stream in one go using a @foldl'@: --- --- >>> Stream.fold (Fold.foldl' (\(s, p) x -> (s + x, p * x)) (0,1)) $ Stream.fromList [1,2,3,4] --- (10,24) --- --- Using @scanl'@ we can make it modular by computing the sum in the first --- stage and passing it down to the next stage for computing the product: --- --- >>> :{ --- Stream.fold (Fold.foldl' (\(_, p) (s, x) -> (s, p * x)) (0,1)) --- $ Stream.scanl' (\(s, _) x -> (s + x, x)) (0,1) --- $ Stream.fromList [1,2,3,4] --- :} --- (10,24) --- --- IMPORTANT: 'scanl'' evaluates the accumulator to WHNF. To avoid building --- lazy expressions inside the accumulator, it is recommended that a strict --- data structure is used for accumulator. --- --- >>> scanl' step z = Stream.scan (Fold.foldl' step z) --- >>> scanl' f z xs = Stream.scanlM' (\a b -> return (f a b)) (return z) xs --- --- See also: 'usingStateT' --- -{-# INLINE scanl' #-} -scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b -scanl' f seed = scanlM' (\a b -> return (f a b)) (return seed) - -{-# INLINE_NORMAL scanlM #-} -scanlM :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b -scanlM fstep begin (Stream step state) = Stream step' Nothing - where - {-# INLINE_LATE step' #-} - step' _ Nothing = do - x <- begin - return $ Yield x (Just (state, x)) - step' gst (Just (st, acc)) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - y <- fstep acc x - return $ Yield y (Just (s, y)) - Skip s -> return $ Skip (Just (s, acc)) - Stop -> return Stop - -{-# INLINE scanl #-} -scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b -scanl f seed = scanlM (\a b -> return (f a b)) (return seed) - --- Adapted from the vector package -{-# INLINE_NORMAL scanl1M #-} -scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a -scanl1M fstep (Stream step state) = Stream step' (state, Nothing) - where - {-# INLINE_LATE step' #-} - step' gst (st, Nothing) = do - r <- step gst st - case r of - Yield x s -> return $ Yield x (s, Just x) - Skip s -> return $ Skip (s, Nothing) - Stop -> return Stop - - step' gst (st, Just acc) = do - r <- step gst st - case r of - Yield y s -> do - z <- fstep acc y - return $ Yield z (s, Just z) - Skip s -> return $ Skip (s, Just acc) - Stop -> return Stop - -{-# INLINE scanl1 #-} -scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a -scanl1 f = scanl1M (\x y -> return (f x y)) - --- Adapted from the vector package - --- | Like 'scanl1'' but with a monadic step function. --- -{-# INLINE_NORMAL scanl1M' #-} -scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a -scanl1M' fstep (Stream step state) = Stream step' (state, Nothing) - where - {-# INLINE_LATE step' #-} - step' gst (st, Nothing) = do - r <- step gst st - case r of - Yield x s -> x `seq` return $ Yield x (s, Just x) - Skip s -> return $ Skip (s, Nothing) - Stop -> return Stop - - step' gst (st, Just acc) = acc `seq` do - r <- step gst st - case r of - Yield y s -> do - z <- fstep acc y - z `seq` return $ Yield z (s, Just z) - Skip s -> return $ Skip (s, Just acc) - Stop -> return Stop - --- | Like 'scanl'' but for a non-empty stream. The first element of the stream --- is used as the initial value of the accumulator. Does nothing if the stream --- is empty. --- --- >>> Stream.toList $ Stream.scanl1' (+) $ Stream.fromList [1,2,3,4] --- [1,3,6,10] --- -{-# INLINE scanl1' #-} -scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a -scanl1' f = scanl1M' (\x y -> return (f x y)) - -------------------------------------------------------------------------------- --- Filtering -------------------------------------------------------------------------------- - --- | Modify a @Stream m a -> Stream m a@ stream transformation that accepts a --- predicate @(a -> b)@ to accept @((s, a) -> b)@ instead, provided a --- transformation @Stream m a -> Stream m (s, a)@. Convenient to filter with --- index or time. --- --- >>> filterWithIndex = Stream.with Stream.indexed Stream.filter --- --- /Pre-release/ -{-# INLINE with #-} -with :: Monad m => - (Stream m a -> Stream m (s, a)) - -> (((s, a) -> b) -> Stream m (s, a) -> Stream m (s, a)) - -> (((s, a) -> b) -> Stream m a -> Stream m a) -with f comb g = fmap snd . comb g . f - --- Adapted from the vector package - --- | Same as 'filter' but with a monadic predicate. --- --- >>> f p x = p x >>= \r -> return $ if r then Just x else Nothing --- >>> filterM p = Stream.mapMaybeM (f p) --- -{-# INLINE_NORMAL filterM #-} -filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a -filterM f (Stream step state) = Stream step' state - where - {-# INLINE_LATE step' #-} - step' gst st = do - r <- step gst st - case r of - Yield x s -> do - b <- f x - return $ if b - then Yield x s - else Skip s - Skip s -> return $ Skip s - Stop -> return Stop - --- | Include only those elements that pass a predicate. --- --- >>> filter p = Stream.filterM (return . p) --- >>> filter p = Stream.mapMaybe (\x -> if p x then Just x else Nothing) --- >>> filter p = Stream.scanMaybe (Fold.filtering p) --- -{-# INLINE filter #-} -filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a -filter f = filterM (return . f) --- filter p = scanMaybe (FL.filtering p) - --- | Drop repeated elements that are adjacent to each other using the supplied --- comparison function. --- --- >>> uniq = Stream.uniqBy (==) --- --- To strip duplicate path separators: --- --- >>> input = Stream.fromList "//a//b" --- >>> f x y = x == '/' && y == '/' --- >>> Stream.fold Fold.toList $ Stream.uniqBy f input --- "/a/b" --- --- Space: @O(1)@ --- --- /Pre-release/ --- -{-# INLINE uniqBy #-} -uniqBy :: Monad m => - (a -> a -> Bool) -> Stream m a -> Stream m a --- uniqBy eq = scanMaybe (FL.uniqBy eq) -uniqBy eq = catMaybes . rollingMap f - - where - - f pre curr = - case pre of - Nothing -> Just curr - Just x -> if x `eq` curr then Nothing else Just curr - --- Adapted from the vector package - --- | Drop repeated elements that are adjacent to each other. --- --- >>> uniq = Stream.uniqBy (==) --- -{-# INLINE_NORMAL uniq #-} -uniq :: (Eq a, Monad m) => Stream m a -> Stream m a --- uniq = scanMaybe FL.uniq -uniq (Stream step state) = Stream step' (Nothing, state) - where - {-# INLINE_LATE step' #-} - step' gst (Nothing, st) = do - r <- step gst st - case r of - Yield x s -> return $ Yield x (Just x, s) - Skip s -> return $ Skip (Nothing, s) - Stop -> return Stop - step' gst (Just x, st) = do - r <- step gst st - case r of - Yield y s | x == y -> return $ Skip (Just x, s) - | otherwise -> return $ Yield y (Just y, s) - Skip s -> return $ Skip (Just x, s) - Stop -> return Stop - --- | Deletes the first occurrence of the element in the stream that satisfies --- the given equality predicate. --- --- >>> input = Stream.fromList [1,3,3,5] --- >>> Stream.fold Fold.toList $ Stream.deleteBy (==) 3 input --- [1,3,5] --- -{-# INLINE_NORMAL deleteBy #-} -deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a --- deleteBy cmp x = scanMaybe (FL.deleteBy cmp x) -deleteBy eq x (Stream step state) = Stream step' (state, False) - where - {-# INLINE_LATE step' #-} - step' gst (st, False) = do - r <- step gst st - case r of - Yield y s -> return $ - if eq x y then Skip (s, True) else Yield y (s, False) - Skip s -> return $ Skip (s, False) - Stop -> return Stop - - step' gst (st, True) = do - r <- step gst st - case r of - Yield y s -> return $ Yield y (s, True) - Skip s -> return $ Skip (s, True) - Stop -> return Stop - --- | Strip all leading and trailing occurrences of an element passing a --- predicate and make all other consecutive occurrences uniq. --- --- >> prune p = Stream.dropWhileAround p $ Stream.uniqBy (x y -> p x && p y) --- --- @ --- > Stream.prune isSpace (Stream.fromList " hello world! ") --- "hello world!" --- --- @ --- --- Space: @O(1)@ --- --- /Unimplemented/ -{-# INLINE prune #-} -prune :: - -- (Monad m, Eq a) => - (a -> Bool) -> Stream m a -> Stream m a -prune = error "Not implemented yet!" - --- Possible implementation: --- @repeated = --- Stream.catMaybes . Stream.parseMany (Parser.groupBy (==) Fold.repeated)@ --- --- 'Fold.repeated' should return 'Just' when repeated, and 'Nothing' for a --- single element. - --- | Emit only repeated elements, once. --- --- /Unimplemented/ -repeated :: -- (Monad m, Eq a) => - Stream m a -> Stream m a -repeated = undefined - ------------------------------------------------------------------------------- --- Trimming ------------------------------------------------------------------------------- - --- | Take all consecutive elements at the end of the stream for which the --- predicate is true. --- --- O(n) space, where n is the number elements taken. --- --- /Unimplemented/ -{-# INLINE takeWhileLast #-} -takeWhileLast :: -- Monad m => - (a -> Bool) -> Stream m a -> Stream m a -takeWhileLast = undefined -- fromStreamD $ D.takeWhileLast n $ toStreamD m - --- | Like 'takeWhile' and 'takeWhileLast' combined. --- --- O(n) space, where n is the number elements taken from the end. --- --- /Unimplemented/ -{-# INLINE takeWhileAround #-} -takeWhileAround :: -- Monad m => - (a -> Bool) -> Stream m a -> Stream m a -takeWhileAround = undefined -- fromStreamD $ D.takeWhileAround n $ toStreamD m - --- Adapted from the vector package - --- | Discard first 'n' elements from the stream and take the rest. --- -{-# INLINE_NORMAL drop #-} -drop :: Monad m => Int -> Stream m a -> Stream m a -drop n (Stream step state) = Stream step' (state, Just n) - where - {-# INLINE_LATE step' #-} - step' gst (st, Just i) - | i > 0 = do - r <- step gst st - return $ - case r of - Yield _ s -> Skip (s, Just (i - 1)) - Skip s -> Skip (s, Just i) - Stop -> Stop - | otherwise = return $ Skip (st, Nothing) - - step' gst (st, Nothing) = do - r <- step gst st - return $ - case r of - Yield x s -> Yield x (s, Nothing) - Skip s -> Skip (s, Nothing) - Stop -> Stop - --- Adapted from the vector package -data DropWhileState s a - = DropWhileDrop s - | DropWhileYield a s - | DropWhileNext s - --- | Same as 'dropWhile' but with a monadic predicate. --- -{-# INLINE_NORMAL dropWhileM #-} -dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a --- dropWhileM p = scanMaybe (FL.droppingWhileM p) -dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state) - where - {-# INLINE_LATE step' #-} - step' gst (DropWhileDrop st) = do - r <- step gst st - case r of - Yield x s -> do - b <- f x - if b - then return $ Skip (DropWhileDrop s) - else return $ Skip (DropWhileYield x s) - Skip s -> return $ Skip (DropWhileDrop s) - Stop -> return Stop - - step' gst (DropWhileNext st) = do - r <- step gst st - case r of - Yield x s -> return $ Skip (DropWhileYield x s) - Skip s -> return $ Skip (DropWhileNext s) - Stop -> return Stop - - step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st) - --- | Drop elements in the stream as long as the predicate succeeds and then --- take the rest of the stream. --- -{-# INLINE dropWhile #-} -dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a --- dropWhile p = scanMaybe (FL.droppingWhile p) -dropWhile f = dropWhileM (return . f) - --- | Drop @n@ elements at the end of the stream. --- --- O(n) space, where n is the number elements dropped. --- --- /Unimplemented/ -{-# INLINE dropLast #-} -dropLast :: -- Monad m => - Int -> Stream m a -> Stream m a -dropLast = undefined -- fromStreamD $ D.dropLast n $ toStreamD m - --- | Drop all consecutive elements at the end of the stream for which the --- predicate is true. --- --- O(n) space, where n is the number elements dropped. --- --- /Unimplemented/ -{-# INLINE dropWhileLast #-} -dropWhileLast :: -- Monad m => - (a -> Bool) -> Stream m a -> Stream m a -dropWhileLast = undefined -- fromStreamD $ D.dropWhileLast n $ toStreamD m - --- | Like 'dropWhile' and 'dropWhileLast' combined. --- --- O(n) space, where n is the number elements dropped from the end. --- --- /Unimplemented/ -{-# INLINE dropWhileAround #-} -dropWhileAround :: -- Monad m => - (a -> Bool) -> Stream m a -> Stream m a -dropWhileAround = undefined -- fromStreamD $ D.dropWhileAround n $ toStreamD m - ------------------------------------------------------------------------------- --- Inserting Elements ------------------------------------------------------------------------------- - --- | @insertBy cmp elem stream@ inserts @elem@ before the first element in --- @stream@ that is less than @elem@ when compared using @cmp@. --- --- >>> insertBy cmp x = Stream.mergeBy cmp (Stream.fromPure x) --- --- >>> input = Stream.fromList [1,3,5] --- >>> Stream.fold Fold.toList $ Stream.insertBy compare 2 input --- [1,2,3,5] --- -{-# INLINE_NORMAL insertBy #-} -insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a -insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing) - where - {-# INLINE_LATE step' #-} - step' gst (st, False, _) = do - r <- step gst st - case r of - Yield x s -> case cmp a x of - GT -> return $ Yield x (s, False, Nothing) - _ -> return $ Yield a (s, True, Just x) - Skip s -> return $ Skip (s, False, Nothing) - Stop -> return $ Yield a (st, True, Nothing) - - step' _ (_, True, Nothing) = return Stop - - step' gst (st, True, Just prev) = do - r <- step gst st - case r of - Yield x s -> return $ Yield prev (s, True, Just x) - Skip s -> return $ Skip (s, True, Just prev) - Stop -> return $ Yield prev (st, True, Nothing) - -data LoopState x s = FirstYield s - | InterspersingYield s - | YieldAndCarry x s - --- intersperseM = intersperseMWith 1 - --- | Insert an effect and its output before consuming an element of a stream --- except the first one. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.trace putChar $ Stream.intersperseM (putChar '.' >> return ',') input --- h.,e.,l.,l.,o"h,e,l,l,o" --- --- Be careful about the order of effects. In the above example we used trace --- after the intersperse, if we use it before the intersperse the output would --- be he.l.l.o."h,e,l,l,o". --- --- >>> Stream.fold Fold.toList $ Stream.intersperseM (putChar '.' >> return ',') $ Stream.trace putChar input --- he.l.l.o."h,e,l,l,o" --- -{-# INLINE_NORMAL intersperseM #-} -intersperseM :: Monad m => m a -> Stream m a -> Stream m a -intersperseM m (Stream step state) = Stream step' (FirstYield state) - where - {-# INLINE_LATE step' #-} - step' gst (FirstYield st) = do - r <- step gst st - return $ - case r of - Yield x s -> Skip (YieldAndCarry x s) - Skip s -> Skip (FirstYield s) - Stop -> Stop - - step' gst (InterspersingYield st) = do - r <- step gst st - case r of - Yield x s -> do - a <- m - return $ Yield a (YieldAndCarry x s) - Skip s -> return $ Skip $ InterspersingYield s - Stop -> return Stop - - step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st) - --- | Insert a pure value between successive elements of a stream. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.intersperse ',' input --- "h,e,l,l,o" --- -{-# INLINE intersperse #-} -intersperse :: Monad m => a -> Stream m a -> Stream m a -intersperse a = intersperseM (return a) - --- | Insert a side effect before consuming an element of a stream except the --- first one. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.drain $ Stream.trace putChar $ Stream.intersperseM_ (putChar '.') input --- h.e.l.l.o --- --- /Pre-release/ -{-# INLINE_NORMAL intersperseM_ #-} -intersperseM_ :: Monad m => m b -> Stream m a -> Stream m a -intersperseM_ m (Stream step1 state1) = Stream step (Left (pure (), state1)) - where - {-# INLINE_LATE step #-} - step gst (Left (eff, st)) = do - r <- step1 gst st - case r of - Yield x s -> eff >> return (Yield x (Right s)) - Skip s -> return $ Skip (Left (eff, s)) - Stop -> return Stop - - step _ (Right st) = return $ Skip $ Left (void m, st) - --- | Intersperse a monadic action into the input stream after every @n@ --- elements. --- --- >> input = Stream.fromList "hello" --- >> Stream.fold Fold.toList $ Stream.intersperseMWith 2 (return ',') input --- "he,ll,o" --- --- /Unimplemented/ -{-# INLINE intersperseMWith #-} -intersperseMWith :: -- Monad m => - Int -> m a -> Stream m a -> Stream m a -intersperseMWith _n _f _xs = undefined - -data SuffixState s a - = SuffixElem s - | SuffixSuffix s - | SuffixYield a (SuffixState s a) - --- | Insert an effect and its output after consuming an element of a stream. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.trace putChar $ Stream.intersperseMSuffix (putChar '.' >> return ',') input --- h.,e.,l.,l.,o.,"h,e,l,l,o," --- --- /Pre-release/ -{-# INLINE_NORMAL intersperseMSuffix #-} -intersperseMSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a -intersperseMSuffix action (Stream step state) = Stream step' (SuffixElem state) - where - {-# INLINE_LATE step' #-} - step' gst (SuffixElem st) = do - r <- step gst st - return $ case r of - Yield x s -> Skip (SuffixYield x (SuffixSuffix s)) - Skip s -> Skip (SuffixElem s) - Stop -> Stop - - step' _ (SuffixSuffix st) = do - action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st)) - - step' _ (SuffixYield x next) = return $ Yield x next - --- | Insert a side effect after consuming an element of a stream. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.intersperseMSuffix_ (threadDelay 1000000) input --- "hello" --- --- /Pre-release/ --- -{-# INLINE_NORMAL intersperseMSuffix_ #-} -intersperseMSuffix_ :: Monad m => m b -> Stream m a -> Stream m a -intersperseMSuffix_ m (Stream step1 state1) = Stream step (Left state1) - where - {-# INLINE_LATE step #-} - step gst (Left st) = do - r <- step1 gst st - case r of - Yield x s -> return $ Yield x (Right s) - Skip s -> return $ Skip $ Left s - Stop -> return Stop - - step _ (Right st) = m >> return (Skip (Left st)) - -data SuffixSpanState s a - = SuffixSpanElem s Int - | SuffixSpanSuffix s - | SuffixSpanYield a (SuffixSpanState s a) - | SuffixSpanLast - | SuffixSpanStop - --- | Like 'intersperseMSuffix' but intersperses an effectful action into the --- input stream after every @n@ elements and after the last element. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.intersperseMSuffixWith 2 (return ',') input --- "he,ll,o," --- --- /Pre-release/ --- -{-# INLINE_NORMAL intersperseMSuffixWith #-} -intersperseMSuffixWith :: forall m a. Monad m - => Int -> m a -> Stream m a -> Stream m a -intersperseMSuffixWith n action (Stream step state) = - Stream step' (SuffixSpanElem state n) - where - {-# INLINE_LATE step' #-} - step' gst (SuffixSpanElem st i) | i > 0 = do - r <- step gst st - return $ case r of - Yield x s -> Skip (SuffixSpanYield x (SuffixSpanElem s (i - 1))) - Skip s -> Skip (SuffixSpanElem s i) - Stop -> if i == n then Stop else Skip SuffixSpanLast - step' _ (SuffixSpanElem st _) = return $ Skip (SuffixSpanSuffix st) - - step' _ (SuffixSpanSuffix st) = do - action >>= \r -> return $ Skip (SuffixSpanYield r (SuffixSpanElem st n)) - - step' _ SuffixSpanLast = do - action >>= \r -> return $ Skip (SuffixSpanYield r SuffixSpanStop) - - step' _ (SuffixSpanYield x next) = return $ Yield x next - - step' _ SuffixSpanStop = return Stop - --- | Insert a side effect before consuming an element of a stream. --- --- Definition: --- --- >>> intersperseMPrefix_ m = Stream.mapM (\x -> void m >> return x) --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.trace putChar $ Stream.intersperseMPrefix_ (putChar '.' >> return ',') input --- .h.e.l.l.o"hello" --- --- Same as 'trace_'. --- --- /Pre-release/ --- -{-# INLINE intersperseMPrefix_ #-} -intersperseMPrefix_ :: Monad m => m b -> Stream m a -> Stream m a -intersperseMPrefix_ m = mapM (\x -> void m >> return x) - ------------------------------------------------------------------------------- --- Inserting Time ------------------------------------------------------------------------------- - --- XXX This should be in Prelude, should we export this as a helper function? - --- | Block the current thread for specified number of seconds. -{-# INLINE sleep #-} -sleep :: MonadIO m => Double -> m () -sleep n = liftIO $ threadDelay $ round $ n * 1000000 - --- | Introduce a delay of specified seconds between elements of the stream. --- --- Definition: --- --- >>> sleep n = liftIO $ threadDelay $ round $ n * 1000000 --- >>> delay = Stream.intersperseM_ . sleep --- --- Example: --- --- >>> input = Stream.enumerateFromTo 1 3 --- >>> Stream.fold (Fold.drainMapM print) $ Stream.delay 1 input --- 1 --- 2 --- 3 --- -{-# INLINE delay #-} -delay :: MonadIO m => Double -> Stream m a -> Stream m a -delay = intersperseM_ . sleep - --- | Introduce a delay of specified seconds after consuming an element of a --- stream. --- --- Definition: --- --- >>> sleep n = liftIO $ threadDelay $ round $ n * 1000000 --- >>> delayPost = Stream.intersperseMSuffix_ . sleep --- --- Example: --- --- >>> input = Stream.enumerateFromTo 1 3 --- >>> Stream.fold (Fold.drainMapM print) $ Stream.delayPost 1 input --- 1 --- 2 --- 3 --- --- /Pre-release/ --- -{-# INLINE delayPost #-} -delayPost :: MonadIO m => Double -> Stream m a -> Stream m a -delayPost n = intersperseMSuffix_ $ liftIO $ threadDelay $ round $ n * 1000000 - --- | Introduce a delay of specified seconds before consuming an element of a --- stream. --- --- Definition: --- --- >>> sleep n = liftIO $ threadDelay $ round $ n * 1000000 --- >>> delayPre = Stream.intersperseMPrefix_. sleep --- --- Example: --- --- >>> input = Stream.enumerateFromTo 1 3 --- >>> Stream.fold (Fold.drainMapM print) $ Stream.delayPre 1 input --- 1 --- 2 --- 3 --- --- /Pre-release/ --- -{-# INLINE delayPre #-} -delayPre :: MonadIO m => Double -> Stream m a -> Stream m a -delayPre = intersperseMPrefix_. sleep - ------------------------------------------------------------------------------- --- Reordering ------------------------------------------------------------------------------- - --- | Returns the elements of the stream in reverse order. The stream must be --- finite. Note that this necessarily buffers the entire stream in memory. --- --- Definition: --- --- >>> reverse m = Stream.concatEffect $ Stream.fold Fold.toListRev m >>= return . Stream.fromList --- -{-# INLINE_NORMAL reverse #-} -reverse :: Monad m => Stream m a -> Stream m a -reverse m = concatEffect $ fold FL.toListRev m <&> fromList -{- -reverse m = Stream step Nothing - where - {-# INLINE_LATE step #-} - step _ Nothing = do - xs <- foldl' (flip (:)) [] m - return $ Skip (Just xs) - step _ (Just (x:xs)) = return $ Yield x (Just xs) - step _ (Just []) = return Stop --} - --- | Like 'reverse' but several times faster, requires an 'Unbox' instance. --- --- /O(n) space/ --- --- /Pre-release/ -{-# INLINE reverseUnbox #-} -reverseUnbox :: (MonadIO m, Unbox a) => Stream m a -> Stream m a -reverseUnbox = - A.flattenArraysRev -- unfoldMany A.readRev - . fromStreamK - . K.reverse - . toStreamK - . A.chunksOf defaultChunkSize - --- | Buffer until the next element in sequence arrives. The function argument --- determines the difference in sequence numbers. This could be useful in --- implementing sequenced streams, for example, TCP reassembly. --- --- /Unimplemented/ --- -{-# INLINE reassembleBy #-} -reassembleBy - :: -- Monad m => - Fold m a b - -> (a -> a -> Int) - -> Stream m a - -> Stream m b -reassembleBy = undefined - ------------------------------------------------------------------------------- --- Position Indexing ------------------------------------------------------------------------------- - --- Adapted from the vector package - --- | --- >>> f = Fold.foldl' (\(i, _) x -> (i + 1, x)) (-1,undefined) --- >>> indexed = Stream.postscan f --- >>> indexed = Stream.zipWith (,) (Stream.enumerateFrom 0) --- >>> indexedR n = fmap (\(i, a) -> (n - i, a)) . indexed --- --- Pair each element in a stream with its index, starting from index 0. --- --- >>> Stream.fold Fold.toList $ Stream.indexed $ Stream.fromList "hello" --- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')] --- -{-# INLINE_NORMAL indexed #-} -indexed :: Monad m => Stream m a -> Stream m (Int, a) --- indexed = scanMaybe FL.indexing -indexed (Stream step state) = Stream step' (state, 0) - where - {-# INLINE_LATE step' #-} - step' gst (st, i) = i `seq` do - r <- step (adaptState gst) st - case r of - Yield x s -> return $ Yield (i, x) (s, i+1) - Skip s -> return $ Skip (s, i) - Stop -> return Stop - --- Adapted from the vector package - --- | --- >>> f n = Fold.foldl' (\(i, _) x -> (i - 1, x)) (n + 1,undefined) --- >>> indexedR n = Stream.postscan (f n) --- --- >>> s n = Stream.enumerateFromThen n (n - 1) --- >>> indexedR n = Stream.zipWith (,) (s n) --- --- Pair each element in a stream with its index, starting from the --- given index @n@ and counting down. --- --- >>> Stream.fold Fold.toList $ Stream.indexedR 10 $ Stream.fromList "hello" --- [(10,'h'),(9,'e'),(8,'l'),(7,'l'),(6,'o')] --- -{-# INLINE_NORMAL indexedR #-} -indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a) --- indexedR n = scanMaybe (FL.indexingRev n) -indexedR m (Stream step state) = Stream step' (state, m) - where - {-# INLINE_LATE step' #-} - step' gst (st, i) = i `seq` do - r <- step (adaptState gst) st - case r of - Yield x s -> let i' = i - 1 - in return $ Yield (i, x) (s, i') - Skip s -> return $ Skip (s, i) - Stop -> return Stop - -------------------------------------------------------------------------------- --- Time Indexing -------------------------------------------------------------------------------- - --- Note: The timestamp stream must be the second stream in the zip so that the --- timestamp is generated after generating the stream element and not before. --- If we do not do that then the following example will generate the same --- timestamp for first two elements: --- --- Stream.fold Fold.toList $ Stream.timestamped $ Stream.delay $ Stream.enumerateFromTo 1 3 - --- | Pair each element in a stream with an absolute timestamp, using a clock of --- specified granularity. The timestamp is generated just before the element --- is consumed. --- --- >>> Stream.fold Fold.toList $ Stream.timestampWith 0.01 $ Stream.delay 1 $ Stream.enumerateFromTo 1 3 --- [(AbsTime (TimeSpec {sec = ..., nsec = ...}),1),(AbsTime (TimeSpec {sec = ..., nsec = ...}),2),(AbsTime (TimeSpec {sec = ..., nsec = ...}),3)] --- --- /Pre-release/ --- -{-# INLINE timestampWith #-} -timestampWith :: (MonadIO m) - => Double -> Stream m a -> Stream m (AbsTime, a) -timestampWith g stream = zipWith (flip (,)) stream (absTimesWith g) - --- TBD: check performance vs a custom implementation without using zipWith. --- --- /Pre-release/ --- -{-# INLINE timestamped #-} -timestamped :: (MonadIO m) - => Stream m a -> Stream m (AbsTime, a) -timestamped = timestampWith 0.01 - --- | Pair each element in a stream with relative times starting from 0, using a --- clock with the specified granularity. The time is measured just before the --- element is consumed. --- --- >>> Stream.fold Fold.toList $ Stream.timeIndexWith 0.01 $ Stream.delay 1 $ Stream.enumerateFromTo 1 3 --- [(RelTime64 (NanoSecond64 ...),1),(RelTime64 (NanoSecond64 ...),2),(RelTime64 (NanoSecond64 ...),3)] --- --- /Pre-release/ --- -{-# INLINE timeIndexWith #-} -timeIndexWith :: (MonadIO m) - => Double -> Stream m a -> Stream m (RelTime64, a) -timeIndexWith g stream = zipWith (flip (,)) stream (relTimesWith g) - --- | Pair each element in a stream with relative times starting from 0, using a --- 10 ms granularity clock. The time is measured just before the element is --- consumed. --- --- >>> Stream.fold Fold.toList $ Stream.timeIndexed $ Stream.delay 1 $ Stream.enumerateFromTo 1 3 --- [(RelTime64 (NanoSecond64 ...),1),(RelTime64 (NanoSecond64 ...),2),(RelTime64 (NanoSecond64 ...),3)] --- --- /Pre-release/ --- -{-# INLINE timeIndexed #-} -timeIndexed :: (MonadIO m) - => Stream m a -> Stream m (RelTime64, a) -timeIndexed = timeIndexWith 0.01 - ------------------------------------------------------------------------------- --- Searching ------------------------------------------------------------------------------- - --- | Find all the indices where the element in the stream satisfies the given --- predicate. --- --- >>> findIndices p = Stream.scanMaybe (Fold.findIndices p) --- -{-# INLINE_NORMAL findIndices #-} -findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int -findIndices p (Stream step state) = Stream step' (state, 0) - where - {-# INLINE_LATE step' #-} - step' gst (st, i) = i `seq` do - r <- step (adaptState gst) st - return $ case r of - Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1) - Skip s -> Skip (s, i) - Stop -> Stop - --- | Find all the indices where the value of the element in the stream is equal --- to the given value. --- --- >>> elemIndices a = Stream.findIndices (== a) --- -{-# INLINE elemIndices #-} -elemIndices :: (Monad m, Eq a) => a -> Stream m a -> Stream m Int -elemIndices a = findIndices (== a) - -{-# INLINE_NORMAL slicesBy #-} -slicesBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) -slicesBy p (Stream step1 state1) = Stream step (Just (state1, 0, 0)) - - where - - {-# INLINE_LATE step #-} - step gst (Just (st, i, len)) = i `seq` len `seq` do - r <- step1 (adaptState gst) st - return - $ case r of - Yield x s -> - if p x - then Yield (i, len + 1) (Just (s, i + len + 1, 0)) - else Skip (Just (s, i, len + 1)) - Skip s -> Skip (Just (s, i, len)) - Stop -> if len == 0 then Stop else Yield (i, len) Nothing - step _ Nothing = return Stop - ------------------------------------------------------------------------------- --- Rolling map ------------------------------------------------------------------------------- - -data RollingMapState s a = RollingMapGo s a - --- | Like 'rollingMap' but with an effectful map function. --- --- /Pre-release/ --- -{-# INLINE rollingMapM #-} -rollingMapM :: Monad m => (Maybe a -> a -> m b) -> Stream m a -> Stream m b --- rollingMapM f = scanMaybe (FL.slide2 $ Window.rollingMapM f) -rollingMapM f (Stream step1 state1) = Stream step (RollingMapGo state1 Nothing) - - where - - step gst (RollingMapGo s1 curr) = do - r <- step1 (adaptState gst) s1 - case r of - Yield x s -> do - !res <- f curr x - return $ Yield res $ RollingMapGo s (Just x) - Skip s -> return $ Skip $ RollingMapGo s curr - Stop -> return Stop - --- rollingMap is a special case of an incremental sliding fold. It can be --- written as: --- --- > fld f = slidingWindow 1 (Fold.foldl' (\_ (x,y) -> f y x) --- > rollingMap f = Stream.postscan (fld f) undefined - --- | Apply a function on every two successive elements of a stream. The first --- argument of the map function is the previous element and the second argument --- is the current element. When the current element is the first element, the --- previous element is 'Nothing'. --- --- /Pre-release/ --- -{-# INLINE rollingMap #-} -rollingMap :: Monad m => (Maybe a -> a -> b) -> Stream m a -> Stream m b --- rollingMap f = scanMaybe (FL.slide2 $ Window.rollingMap f) -rollingMap f = rollingMapM (\x y -> return $ f x y) - --- | Like 'rollingMap' but requires at least two elements in the stream, --- returns an empty stream otherwise. --- --- This is the stream equivalent of the list idiom @zipWith f xs (tail xs)@. --- --- /Pre-release/ --- -{-# INLINE rollingMap2 #-} -rollingMap2 :: Monad m => (a -> a -> b) -> Stream m a -> Stream m b -rollingMap2 f = catMaybes . rollingMap g - - where - - g Nothing _ = Nothing - g (Just x) y = Just (f x y) - ------------------------------------------------------------------------------- --- Maybe Streams ------------------------------------------------------------------------------- - --- XXX Will this always fuse properly? - --- | Map a 'Maybe' returning function to a stream, filter out the 'Nothing' --- elements, and return a stream of values extracted from 'Just'. --- --- Equivalent to: --- --- >>> mapMaybe f = Stream.catMaybes . fmap f --- -{-# INLINE_NORMAL mapMaybe #-} -mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b -mapMaybe f = fmap fromJust . filter isJust . map f - --- | Like 'mapMaybe' but maps a monadic function. --- --- Equivalent to: --- --- >>> mapMaybeM f = Stream.catMaybes . Stream.mapM f --- --- >>> mapM f = Stream.mapMaybeM (\x -> Just <$> f x) --- -{-# INLINE_NORMAL mapMaybeM #-} -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b -mapMaybeM f = fmap fromJust . filter isJust . mapM f - --- | In a stream of 'Maybe's, discard 'Nothing's and unwrap 'Just's. --- --- >>> catMaybes = Stream.mapMaybe id --- >>> catMaybes = fmap fromJust . Stream.filter isJust --- --- /Pre-release/ --- -{-# INLINE catMaybes #-} -catMaybes :: Monad m => Stream m (Maybe a) -> Stream m a --- catMaybes = fmap fromJust . filter isJust -catMaybes (Stream step state) = Stream step1 state - - where - - {-# INLINE_LATE step1 #-} - step1 gst st = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - return - $ case x of - Just a -> Yield a s - Nothing -> Skip s - Skip s -> return $ Skip s - Stop -> return Stop - --- | Use a filtering fold on a stream. --- --- >>> scanMaybe f = Stream.catMaybes . Stream.postscan f --- -{-# INLINE scanMaybe #-} -scanMaybe :: Monad m => Fold m a (Maybe b) -> Stream m a -> Stream m b -scanMaybe f = catMaybes . postscan f - ------------------------------------------------------------------------------- --- Either streams ------------------------------------------------------------------------------- - --- | Discard 'Right's and unwrap 'Left's in an 'Either' stream. --- --- >>> catLefts = fmap (fromLeft undefined) . Stream.filter isLeft --- --- /Pre-release/ --- -{-# INLINE catLefts #-} -catLefts :: Monad m => Stream m (Either a b) -> Stream m a -catLefts = fmap (fromLeft undefined) . filter isLeft - --- | Discard 'Left's and unwrap 'Right's in an 'Either' stream. --- --- >>> catRights = fmap (fromRight undefined) . Stream.filter isRight --- --- /Pre-release/ --- -{-# INLINE catRights #-} -catRights :: Monad m => Stream m (Either a b) -> Stream m b -catRights = fmap (fromRight undefined) . filter isRight - --- | Remove the either wrapper and flatten both lefts and as well as rights in --- the output stream. --- --- >>> catEithers = fmap (either id id) --- --- /Pre-release/ --- -{-# INLINE catEithers #-} -catEithers :: Monad m => Stream m (Either a a) -> Stream m a -catEithers = fmap (either id id) - ------------------------------------------------------------------------------- --- Splitting ------------------------------------------------------------------------------- - --- | Split on an infixed separator element, dropping the separator. The --- supplied 'Fold' is applied on the split segments. Splits the stream on --- separator elements determined by the supplied predicate, separator is --- considered as infixed between two segments: --- --- >>> splitOn' p xs = Stream.fold Fold.toList $ Stream.splitOn p Fold.toList (Stream.fromList xs) --- >>> splitOn' (== '.') "a.b" --- ["a","b"] --- --- An empty stream is folded to the default value of the fold: --- --- >>> splitOn' (== '.') "" --- [""] --- --- If one or both sides of the separator are missing then the empty segment on --- that side is folded to the default output of the fold: --- --- >>> splitOn' (== '.') "." --- ["",""] --- --- >>> splitOn' (== '.') ".a" --- ["","a"] --- --- >>> splitOn' (== '.') "a." --- ["a",""] --- --- >>> splitOn' (== '.') "a..b" --- ["a","","b"] --- --- splitOn is an inverse of intercalating single element: --- --- > Stream.intercalate (Stream.fromPure '.') Unfold.fromList . Stream.splitOn (== '.') Fold.toList === id --- --- Assuming the input stream does not contain the separator: --- --- > Stream.splitOn (== '.') Fold.toList . Stream.intercalate (Stream.fromPure '.') Unfold.fromList === id --- -{-# INLINE splitOn #-} -splitOn :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b -splitOn predicate f = - -- We can express the infix splitting in terms of optional suffix split - -- fold. After applying a suffix split fold repeatedly if the last segment - -- ends with a suffix then we need to return the default output of the fold - -- after that to make it an infix split. - -- - -- Alternately, we can also express it using an optional prefix split fold. - -- If the first segment starts with a prefix then we need to emit the - -- default output of the fold before that to make it an infix split, and - -- then apply prefix split fold repeatedly. - -- - -- Since a suffix split fold can be easily expressed using a - -- non-backtracking fold, we use that. - foldManyPost (FL.takeEndBy_ predicate f) diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Transformer.hs b/src/Streamly/Internal/Data/Stream/StreamD/Transformer.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Transformer.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Transformer --- Copyright : (c) 2018 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Transform the underlying monad of a stream using a monad transfomer. - -module Streamly.Internal.Data.Stream.StreamD.Transformer - ( - foldlT - , foldrT - - -- * Transform Inner Monad - , liftInner - , runReaderT - , usingReaderT - , evalStateT - , runStateT - , usingStateT - ) -where - -#include "inline.hs" - -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Monad.Trans.Reader (ReaderT) -import Control.Monad.Trans.State.Strict (StateT) -import GHC.Types (SPEC(..)) -import Streamly.Internal.Data.SVar.Type (defState, adaptState) - -import qualified Control.Monad.Trans.Reader as Reader -import qualified Control.Monad.Trans.State.Strict as State - -import Streamly.Internal.Data.Stream.StreamD.Type - -#include "DocTestDataStream.hs" - --- | Lazy left fold to a transformer monad. --- -{-# INLINE_NORMAL foldlT #-} -foldlT :: (Monad m, Monad (s m), MonadTrans s) - => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b -foldlT fstep begin (Stream step state) = go SPEC begin state - where - go !_ acc st = do - r <- lift $ step defState st - case r of - Yield x s -> go SPEC (fstep acc x) s - Skip s -> go SPEC acc s - Stop -> acc - --- | Right fold to a transformer monad. This is the most general right fold --- function. 'foldrS' is a special case of 'foldrT', however 'foldrS' --- implementation can be more efficient: --- --- >>> foldrS = Stream.foldrT --- --- >>> step f x xs = lift $ f x (runIdentityT xs) --- >>> foldrM f z s = runIdentityT $ Stream.foldrT (step f) (lift z) s --- --- 'foldrT' can be used to translate streamly streams to other transformer --- monads e.g. to a different streaming type. --- --- /Pre-release/ -{-# INLINE_NORMAL foldrT #-} -foldrT :: (Monad m, Monad (t m), MonadTrans t) - => (a -> t m b -> t m b) -> t m b -> Stream m a -> t m b -foldrT f final (Stream step state) = go SPEC state - where - {-# INLINE_LATE go #-} - go !_ st = do - r <- lift $ step defState st - case r of - Yield x s -> f x (go SPEC s) - Skip s -> go SPEC s - Stop -> final - -------------------------------------------------------------------------------- --- Transform Inner Monad -------------------------------------------------------------------------------- - --- | Lift the inner monad @m@ of @Stream m a@ to @t m@ where @t@ is a monad --- transformer. --- -{-# INLINE_NORMAL liftInner #-} -liftInner :: (Monad m, MonadTrans t, Monad (t m)) - => Stream m a -> Stream (t m) a -liftInner (Stream step state) = Stream step' state - where - {-# INLINE_LATE step' #-} - step' gst st = do - r <- lift $ step (adaptState gst) st - return $ case r of - Yield x s -> Yield x s - Skip s -> Skip s - Stop -> Stop - ------------------------------------------------------------------------------- --- Sharing read only state in a stream ------------------------------------------------------------------------------- - --- | Evaluate the inner monad of a stream as 'ReaderT'. --- -{-# INLINE_NORMAL runReaderT #-} -runReaderT :: Monad m => m s -> Stream (ReaderT s m) a -> Stream m a -runReaderT env (Stream step state) = Stream step' (state, env) - where - {-# INLINE_LATE step' #-} - step' gst (st, action) = do - sv <- action - r <- Reader.runReaderT (step (adaptState gst) st) sv - return $ case r of - Yield x s -> Yield x (s, return sv) - Skip s -> Skip (s, return sv) - Stop -> Stop - --- | Run a stream transformation using a given environment. --- -{-# INLINE usingReaderT #-} -usingReaderT - :: Monad m - => m r - -> (Stream (ReaderT r m) a -> Stream (ReaderT r m) a) - -> Stream m a - -> Stream m a -usingReaderT r f xs = runReaderT r $ f $ liftInner xs - ------------------------------------------------------------------------------- --- Sharing read write state in a stream ------------------------------------------------------------------------------- - --- | Evaluate the inner monad of a stream as 'StateT'. --- --- >>> evalStateT s = fmap snd . Stream.runStateT s --- -{-# INLINE_NORMAL evalStateT #-} -evalStateT :: Monad m => m s -> Stream (StateT s m) a -> Stream m a -evalStateT initial (Stream step state) = Stream step' (state, initial) - where - {-# INLINE_LATE step' #-} - step' gst (st, action) = do - sv <- action - (r, !sv') <- State.runStateT (step (adaptState gst) st) sv - return $ case r of - Yield x s -> Yield x (s, return sv') - Skip s -> Skip (s, return sv') - Stop -> Stop - --- | Evaluate the inner monad of a stream as 'StateT' and emit the resulting --- state and value pair after each step. --- -{-# INLINE_NORMAL runStateT #-} -runStateT :: Monad m => m s -> Stream (StateT s m) a -> Stream m (s, a) -runStateT initial (Stream step state) = Stream step' (state, initial) - where - {-# INLINE_LATE step' #-} - step' gst (st, action) = do - sv <- action - (r, !sv') <- State.runStateT (step (adaptState gst) st) sv - return $ case r of - Yield x s -> Yield (sv', x) (s, return sv') - Skip s -> Skip (s, return sv') - Stop -> Stop - --- | Run a stateful (StateT) stream transformation using a given state. --- --- >>> usingStateT s f = Stream.evalStateT s . f . Stream.liftInner --- --- See also: 'scan' --- -{-# INLINE usingStateT #-} -usingStateT - :: Monad m - => m s - -> (Stream (StateT s m) a -> Stream (StateT s m) a) - -> Stream m a - -> Stream m a -usingStateT s f = evalStateT s . f . liftInner diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Type.hs b/src/Streamly/Internal/Data/Stream/StreamD/Type.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamD/Type.hs +++ /dev/null @@ -1,2074 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Streamly.Internal.Data.Stream.StreamD.Type --- Copyright : (c) 2018 Composewell Technologies --- (c) Roman Leshchinskiy 2008-2010 --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - --- The stream type is inspired by the vector package. A few functions in this --- module have been originally adapted from the vector package (c) Roman --- Leshchinskiy. See the notes in specific functions. - -module Streamly.Internal.Data.Stream.StreamD.Type - ( - -- * The stream type - Step (..) - -- XXX UnStream is exported to avoid a performance issue in some - -- combinators if we use the pattern synonym "Stream". - , Stream (Stream, UnStream) - - -- * CrossStream type wrapper - , CrossStream - , unCross - , mkCross - - -- * Conversion to StreamK - , fromStreamK - , toStreamK - - -- * From Unfold - , unfold - - -- * Construction - -- ** Primitives - , nilM - , consM - - -- ** From Values - , fromPure - , fromEffect - - -- ** From Containers - , Streamly.Internal.Data.Stream.StreamD.Type.fromList - - -- * Elimination - -- ** Primitives - , uncons - - -- ** Strict Left Folds - , Streamly.Internal.Data.Stream.StreamD.Type.fold - , foldBreak - , foldAddLazy - , foldAdd - , foldEither - - , Streamly.Internal.Data.Stream.StreamD.Type.foldl' - , foldlM' - , foldlx' - , foldlMx' - - -- ** Lazy Right Folds - , foldrM - , foldrMx - , Streamly.Internal.Data.Stream.StreamD.Type.foldr - , foldrS - - -- ** Specific Folds - , drain - , Streamly.Internal.Data.Stream.StreamD.Type.toList - - -- * Mapping - , map - , mapM - - -- * Stateful Filters - , take - , takeWhile - , takeWhileM - , takeEndBy - , takeEndByM - - -- * Combining Two Streams - -- ** Zipping - , zipWithM - , zipWith - - -- ** Cross Product - , crossApply - , crossApplyFst - , crossApplySnd - , crossWith - , cross - - -- * Unfold Many - , ConcatMapUState (..) - , unfoldMany - - -- * Concat - , concatEffect - , concatMap - , concatMapM - , concat - - -- * Unfold Iterate - , unfoldIterateDfs - , unfoldIterateBfs - , unfoldIterateBfsRev - - -- * Concat Iterate - , concatIterateScan - , concatIterateDfs - , concatIterateBfs - , concatIterateBfsRev - - -- * Fold Many - , FoldMany (..) -- for inspection testing - , FoldManyPost (..) - , foldMany - , foldManyPost - , groupsOf - , refoldMany - - -- * Fold Iterate - , reduceIterateBfs - , foldIterateBfs - - -- * Multi-stream folds - , eqBy - , cmpBy - ) -where - -#include "inline.hs" - -import Control.Applicative (liftA2) -import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Foldable (Foldable(foldl'), fold, foldr) -import Data.Functor (($>)) -import Data.Functor.Identity (Identity(..)) -import Data.Maybe (fromMaybe) -import Data.Semigroup (Endo(..)) -import Fusion.Plugin.Types (Fuse(..)) -import GHC.Base (build) -import GHC.Exts (IsList(..), IsString(..), oneShot) -import GHC.Types (SPEC(..)) -import Prelude hiding (map, mapM, take, concatMap, takeWhile, zipWith, concat) -import Text.Read - ( Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec - , readListPrecDefault) - -import Streamly.Internal.BaseCompat ((#.)) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) -import Streamly.Internal.Data.Refold.Type (Refold(..)) -import Streamly.Internal.Data.Stream.StreamD.Step (Step (..)) -import Streamly.Internal.Data.SVar.Type (State, adaptState, defState) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) - -import qualified Streamly.Internal.Data.Fold.Type as FL hiding (foldr) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -#ifdef USE_UNFOLDS_EVERYWHERE -import qualified Streamly.Internal.Data.Unfold.Type as Unfold -#endif - -#include "DocTestDataStream.hs" - ------------------------------------------------------------------------------- --- The direct style stream type ------------------------------------------------------------------------------- - --- gst = global state - --- | A stream consists of a step function that generates the next step given a --- current state, and the current state. -data Stream m a = - forall s. UnStream (State K.StreamK m a -> s -> m (Step s a)) s - --- XXX This causes perf trouble when pattern matching with "Stream" in a --- recursive way, e.g. in uncons, foldBreak, concatMap. We need to get rid of --- this. -unShare :: Stream m a -> Stream m a -unShare (UnStream step state) = UnStream step' state - where step' gst = step (adaptState gst) - -pattern Stream :: (State K.StreamK m a -> s -> m (Step s a)) -> s -> Stream m a -pattern Stream step state <- (unShare -> UnStream step state) - where Stream = UnStream - -{-# COMPLETE Stream #-} - ------------------------------------------------------------------------------- --- Primitives ------------------------------------------------------------------------------- - --- | A stream that terminates without producing any output, but produces a side --- effect. --- --- >>> Stream.fold Fold.toList (Stream.nilM (print "nil")) --- "nil" --- [] --- --- /Pre-release/ -{-# INLINE_NORMAL nilM #-} -nilM :: Applicative m => m b -> Stream m a -nilM m = Stream (\_ _ -> m $> Stop) () - --- | Like 'cons' but fuses an effect instead of a pure value. -{-# INLINE_NORMAL consM #-} -consM :: Applicative m => m a -> Stream m a -> Stream m a -consM m (Stream step state) = Stream step1 Nothing - - where - - {-# INLINE_LATE step1 #-} - step1 _ Nothing = (`Yield` Just state) <$> m - step1 gst (Just st) = do - (\case - Yield a s -> Yield a (Just s) - Skip s -> Skip (Just s) - Stop -> Stop) <$> step gst st - --- | Decompose a stream into its head and tail. If the stream is empty, returns --- 'Nothing'. If the stream is non-empty, returns @Just (a, ma)@, where @a@ is --- the head of the stream and @ma@ its tail. --- --- Properties: --- --- >>> Nothing <- Stream.uncons Stream.nil --- >>> Just ("a", t) <- Stream.uncons (Stream.cons "a" Stream.nil) --- --- This can be used to consume the stream in an imperative manner one element --- at a time, as it just breaks down the stream into individual elements and we --- can loop over them as we deem fit. For example, this can be used to convert --- a streamly stream into other stream types. --- --- All the folds in this module can be expressed in terms of 'uncons', however, --- this is generally less efficient than specific folds because it takes apart --- the stream one element at a time, therefore, does not take adavantage of --- stream fusion. --- --- 'foldBreak' is a more general way of consuming a stream piecemeal. --- --- >>> :{ --- uncons xs = do --- r <- Stream.foldBreak Fold.one xs --- return $ case r of --- (Nothing, _) -> Nothing --- (Just h, t) -> Just (h, t) --- :} --- -{-# INLINE_NORMAL uncons #-} -uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a)) -uncons (UnStream step state) = go SPEC state - where - go !_ st = do - r <- step defState st - case r of - Yield x s -> return $ Just (x, Stream step s) - Skip s -> go SPEC s - Stop -> return Nothing - ------------------------------------------------------------------------------- --- From 'Unfold' ------------------------------------------------------------------------------- - -data UnfoldState s = UnfoldNothing | UnfoldJust s - --- | Convert an 'Unfold' into a stream by supplying it an input seed. --- --- >>> s = Stream.unfold Unfold.replicateM (3, putStrLn "hello") --- >>> Stream.fold Fold.drain s --- hello --- hello --- hello --- -{-# INLINE_NORMAL unfold #-} -unfold :: Applicative m => Unfold m a b -> a -> Stream m b -unfold (Unfold ustep inject) seed = Stream step UnfoldNothing - - where - - {-# INLINE_LATE step #-} - step _ UnfoldNothing = Skip . UnfoldJust <$> inject seed - step _ (UnfoldJust st) = do - (\case - Yield x s -> Yield x (UnfoldJust s) - Skip s -> Skip (UnfoldJust s) - Stop -> Stop) <$> ustep st - ------------------------------------------------------------------------------- --- From Values ------------------------------------------------------------------------------- - --- | Create a singleton stream from a pure value. --- --- >>> fromPure a = a `Stream.cons` Stream.nil --- >>> fromPure = pure --- >>> fromPure = Stream.fromEffect . pure --- -{-# INLINE_NORMAL fromPure #-} -fromPure :: Applicative m => a -> Stream m a -fromPure x = Stream (\_ s -> pure $ step undefined s) True - where - {-# INLINE_LATE step #-} - step _ True = Yield x False - step _ False = Stop - --- | Create a singleton stream from a monadic action. --- --- >>> fromEffect m = m `Stream.consM` Stream.nil --- >>> fromEffect = Stream.sequence . Stream.fromPure --- --- >>> Stream.fold Fold.drain $ Stream.fromEffect (putStrLn "hello") --- hello --- -{-# INLINE_NORMAL fromEffect #-} -fromEffect :: Applicative m => m a -> Stream m a -fromEffect m = Stream step True - - where - - {-# INLINE_LATE step #-} - step _ True = (`Yield` False) <$> m - step _ False = pure Stop - ------------------------------------------------------------------------------- --- From Containers ------------------------------------------------------------------------------- - --- Adapted from the vector package. - --- | Construct a stream from a list of pure values. -{-# INLINE_LATE fromList #-} -fromList :: Applicative m => [a] -> Stream m a -#ifdef USE_UNFOLDS_EVERYWHERE -fromList = unfold Unfold.fromList -#else -fromList = Stream step - where - {-# INLINE_LATE step #-} - step _ (x:xs) = pure $ Yield x xs - step _ [] = pure Stop -#endif - ------------------------------------------------------------------------------- --- Conversions From/To ------------------------------------------------------------------------------- - --- | Convert a CPS encoded StreamK to direct style step encoded StreamD -{-# INLINE_LATE fromStreamK #-} -fromStreamK :: Applicative m => K.StreamK m a -> Stream m a -fromStreamK = Stream step - where - step gst m1 = - let stop = pure Stop - single a = pure $ Yield a K.nil - yieldk a r = pure $ Yield a r - in K.foldStreamShared gst yieldk single stop m1 - --- | Convert a direct style step encoded StreamD to a CPS encoded StreamK -{-# INLINE_LATE toStreamK #-} -toStreamK :: Monad m => Stream m a -> K.StreamK m a -toStreamK (Stream step state) = go state - where - go st = K.MkStream $ \gst yld _ stp -> - let go' ss = do - r <- step gst ss - case r of - Yield x s -> yld x (go s) - Skip s -> go' s - Stop -> stp - in go' st - -#ifndef DISABLE_FUSION -{-# RULES "fromStreamK/toStreamK fusion" - forall s. toStreamK (fromStreamK s) = s #-} -{-# RULES "toStreamK/fromStreamK fusion" - forall s. fromStreamK (toStreamK s) = s #-} -#endif - ------------------------------------------------------------------------------- --- Running a 'Fold' ------------------------------------------------------------------------------- - --- >>> fold f = Fold.extractM . Stream.foldAddLazy f --- >>> fold f = Stream.fold Fold.one . Stream.foldManyPost f --- >>> fold f = Fold.extractM <=< Stream.foldAdd f - --- | Fold a stream using the supplied left 'Fold' and reducing the resulting --- expression strictly at each step. The behavior is similar to 'foldl''. A --- 'Fold' can terminate early without consuming the full stream. See the --- documentation of individual 'Fold's for termination behavior. --- --- Definitions: --- --- >>> fold f = fmap fst . Stream.foldBreak f --- >>> fold f = Stream.parse (Parser.fromFold f) --- --- Example: --- --- >>> Stream.fold Fold.sum (Stream.enumerateFromTo 1 100) --- 5050 --- -{-# INLINE_NORMAL fold #-} -fold :: Monad m => Fold m a b -> Stream m a -> m b -fold fld strm = do - (b, _) <- foldBreak fld strm - return b - --- | Fold resulting in either breaking the stream or continuation of the fold. --- Instead of supplying the input stream in one go we can run the fold multiple --- times, each time supplying the next segment of the input stream. If the fold --- has not yet finished it returns a fold that can be run again otherwise it --- returns the fold result and the residual stream. --- --- /Internal/ -{-# INLINE_NORMAL foldEither #-} -foldEither :: Monad m => - Fold m a b -> Stream m a -> m (Either (Fold m a b) (b, Stream m a)) -foldEither (Fold fstep begin done) (UnStream step state) = do - res <- begin - case res of - FL.Partial fs -> go SPEC fs state - FL.Done fb -> return $! Right (fb, Stream step state) - - where - - {-# INLINE go #-} - go !_ !fs st = do - r <- step defState st - case r of - Yield x s -> do - res <- fstep fs x - case res of - FL.Done b -> return $! Right (b, Stream step s) - FL.Partial fs1 -> go SPEC fs1 s - Skip s -> go SPEC fs s - Stop -> return $! Left (Fold fstep (return $ FL.Partial fs) done) - --- | Like 'fold' but also returns the remaining stream. The resulting stream --- would be 'Stream.nil' if the stream finished before the fold. --- -{-# INLINE_NORMAL foldBreak #-} -foldBreak :: Monad m => Fold m a b -> Stream m a -> m (b, Stream m a) -foldBreak fld strm = do - r <- foldEither fld strm - case r of - Right res -> return res - Left (Fold _ initial extract) -> do - res <- initial - case res of - FL.Done _ -> error "foldBreak: unreachable state" - FL.Partial s -> do - b <- extract s - return (b, nil) - - where - - nil = Stream (\_ _ -> return Stop) () - --- | Append a stream to a fold lazily to build an accumulator incrementally. --- --- Example, to continue folding a list of streams on the same sum fold: --- --- >>> streams = [Stream.fromList [1..5], Stream.fromList [6..10]] --- >>> f = Prelude.foldl Stream.foldAddLazy Fold.sum streams --- >>> Stream.fold f Stream.nil --- 55 --- -{-# INLINE_NORMAL foldAddLazy #-} -foldAddLazy :: Monad m => Fold m a b -> Stream m a -> Fold m a b -foldAddLazy (Fold fstep finitial fextract) (Stream sstep state) = - Fold fstep initial fextract - - where - - initial = do - res <- finitial - case res of - FL.Partial fs -> go SPEC fs state - FL.Done fb -> return $ FL.Done fb - - {-# INLINE go #-} - go !_ !fs st = do - r <- sstep defState st - case r of - Yield x s -> do - res <- fstep fs x - case res of - FL.Done b -> return $ FL.Done b - FL.Partial fs1 -> go SPEC fs1 s - Skip s -> go SPEC fs s - Stop -> return $ FL.Partial fs - --- >>> foldAdd f = Stream.foldAddLazy f >=> Fold.reduce - --- | --- >>> foldAdd = flip Fold.addStream --- -foldAdd :: Monad m => Fold m a b -> Stream m a -> m (Fold m a b) -foldAdd f = - Streamly.Internal.Data.Stream.StreamD.Type.fold (FL.duplicate f) - ------------------------------------------------------------------------------- --- Right Folds ------------------------------------------------------------------------------- - --- Adapted from the vector package. --- --- XXX Use of SPEC constructor in folds causes 2x performance degradation in --- one shot operations, but helps immensely in operations composed of multiple --- combinators or the same combinator many times. There seems to be an --- opportunity to optimize here, can we get both, better perf for single ops --- as well as composed ops? Without SPEC, all single operation benchmarks --- become 2x faster. - --- The way we want a left fold to be strict, dually we want the right fold to --- be lazy. The correct signature of the fold function to keep it lazy must be --- (a -> m b -> m b) instead of (a -> b -> m b). We were using the latter --- earlier, which is incorrect. In the latter signature we have to feed the --- value to the fold function after evaluating the monadic action, depending on --- the bind behavior of the monad, the action may get evaluated immediately --- introducing unnecessary strictness to the fold. If the implementation is --- lazy the following example, must work: --- --- S.foldrM (\x t -> if x then return t else return False) (return True) --- (S.fromList [False,undefined] :: Stream IO Bool) - --- | Right associative/lazy pull fold. @foldrM build final stream@ constructs --- an output structure using the step function @build@. @build@ is invoked with --- the next input element and the remaining (lazy) tail of the output --- structure. It builds a lazy output expression using the two. When the "tail --- structure" in the output expression is evaluated it calls @build@ again thus --- lazily consuming the input @stream@ until either the output expression built --- by @build@ is free of the "tail" or the input is exhausted in which case --- @final@ is used as the terminating case for the output structure. For more --- details see the description in the previous section. --- --- Example, determine if any element is 'odd' in a stream: --- --- >>> s = Stream.fromList (2:4:5:undefined) --- >>> step x xs = if odd x then return True else xs --- >>> Stream.foldrM step (return False) s --- True --- -{-# INLINE_NORMAL foldrM #-} -foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b -foldrM f z (Stream step state) = go SPEC state - where - {-# INLINE_LATE go #-} - go !_ st = do - r <- step defState st - case r of - Yield x s -> f x (go SPEC s) - Skip s -> go SPEC s - Stop -> z - -{-# INLINE_NORMAL foldrMx #-} -foldrMx :: Monad m - => (a -> m x -> m x) -> m x -> (m x -> m b) -> Stream m a -> m b -foldrMx fstep final convert (Stream step state) = convert $ go SPEC state - where - {-# INLINE_LATE go #-} - go !_ st = do - r <- step defState st - case r of - Yield x s -> fstep x (go SPEC s) - Skip s -> go SPEC s - Stop -> final - --- XXX Should we make all argument strict wherever we use SPEC? - --- Note that foldr works on pure values, therefore it becomes necessarily --- strict when the monad m is strict. In that case it cannot terminate early, --- it would evaluate all of its input. Though, this should work fine with lazy --- monads. For example, if "any" is implemented using "foldr" instead of --- "foldrM" it performs the same with Identity monad but performs 1000x slower --- with IO monad. - --- | Right fold, lazy for lazy monads and pure streams, and strict for strict --- monads. --- --- Please avoid using this routine in strict monads like IO unless you need a --- strict right fold. This is provided only for use in lazy monads (e.g. --- Identity) or pure streams. Note that with this signature it is not possible --- to implement a lazy foldr when the monad @m@ is strict. In that case it --- would be strict in its accumulator and therefore would necessarily consume --- all its input. --- --- >>> foldr f z = Stream.foldrM (\a b -> f a <$> b) (return z) --- --- Note: This is similar to Fold.foldr' (the right fold via left fold), but --- could be more efficient. --- -{-# INLINE_NORMAL foldr #-} -foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b -foldr f z = foldrM (liftA2 f . return) (return z) - --- this performs horribly, should not be used -{-# INLINE_NORMAL foldrS #-} -foldrS - :: Monad m - => (a -> Stream m b -> Stream m b) - -> Stream m b - -> Stream m a - -> Stream m b -foldrS f final (Stream step state) = go SPEC state - where - {-# INLINE_LATE go #-} - go !_ st = concatEffect $ fmap g $ step defState st - - g r = - case r of - Yield x s -> f x (go SPEC s) - Skip s -> go SPEC s - Stop -> final - ------------------------------------------------------------------------------- --- Left Folds ------------------------------------------------------------------------------- - --- XXX run begin action only if the stream is not empty. -{-# INLINE_NORMAL foldlMx' #-} -foldlMx' :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> m b -foldlMx' fstep begin done (Stream step state) = - begin >>= \x -> go SPEC x state - where - -- XXX !acc? - {-# INLINE_LATE go #-} - go !_ acc st = acc `seq` do - r <- step defState st - case r of - Yield x s -> do - acc' <- fstep acc x - go SPEC acc' s - Skip s -> go SPEC acc s - Stop -> done acc - -{-# INLINE foldlx' #-} -foldlx' :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> m b -foldlx' fstep begin done = - foldlMx' (\b a -> return (fstep b a)) (return begin) (return . done) - --- Adapted from the vector package. --- XXX implement in terms of foldlMx'? -{-# INLINE_NORMAL foldlM' #-} -foldlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> m b -foldlM' fstep mbegin (Stream step state) = do - begin <- mbegin - go SPEC begin state - where - {-# INLINE_LATE go #-} - go !_ acc st = acc `seq` do - r <- step defState st - case r of - Yield x s -> do - acc' <- fstep acc x - go SPEC acc' s - Skip s -> go SPEC acc s - Stop -> return acc - -{-# INLINE foldl' #-} -foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b -foldl' fstep begin = foldlM' (\b a -> return (fstep b a)) (return begin) - ------------------------------------------------------------------------------- --- Special folds ------------------------------------------------------------------------------- - --- >>> drain = mapM_ (\_ -> return ()) - --- | --- Definitions: --- --- >>> drain = Stream.fold Fold.drain --- >>> drain = Stream.foldrM (\_ xs -> xs) (return ()) --- --- Run a stream, discarding the results. --- -{-# INLINE_LATE drain #-} -drain :: Monad m => Stream m a -> m () --- drain = foldrM (\_ xs -> xs) (return ()) -drain (Stream step state) = go SPEC state - where - go !_ st = do - r <- step defState st - case r of - Yield _ s -> go SPEC s - Skip s -> go SPEC s - Stop -> return () - ------------------------------------------------------------------------------- --- To Containers ------------------------------------------------------------------------------- - --- This toList impl is faster (30% on streaming-benchmarks) than the --- corresponding left fold. The left fold retains an additional argument in the --- recursive loop. --- --- Core for the right fold loop: --- --- main_$s$wgo1 --- = \ sc_s3e6 sc1_s3e5 -> --- case ># sc1_s3e5 100000# of { --- __DEFAULT -> --- case main_$s$wgo1 sc_s3e6 (+# sc1_s3e5 1#) of --- --- Core for the left fold loop: --- --- main_$s$wgo1 --- = \ sc_s3oT sc1_s3oS sc2_s3oR -> --- case sc2_s3oR of fs2_a2lw { __DEFAULT -> --- case ># sc1_s3oS 100000# of { --- __DEFAULT -> --- let { wild_a2og = I# sc1_s3oS } in --- main_$s$wgo1 --- sc_s3oT (+# sc1_s3oS 1#) (\ x_X9 -> fs2_a2lw (: wild_a2og x_X9)); - --- | --- Definitions: --- --- >>> toList = Stream.foldr (:) [] --- >>> toList = Stream.fold Fold.toList --- --- Convert a stream into a list in the underlying monad. The list can be --- consumed lazily in a lazy monad (e.g. 'Identity'). In a strict monad (e.g. --- IO) the whole list is generated and buffered before it can be consumed. --- --- /Warning!/ working on large lists accumulated as buffers in memory could be --- very inefficient, consider using "Streamly.Data.Array" instead. --- --- Note that this could a bit more efficient compared to @Stream.fold --- Fold.toList@, and it can fuse with pure list consumers. --- -{-# INLINE_NORMAL toList #-} -toList :: Monad m => Stream m a -> m [a] -toList = Streamly.Internal.Data.Stream.StreamD.Type.foldr (:) [] - --- Use foldr/build fusion to fuse with list consumers --- This can be useful when using the IsList instance -{-# INLINE_LATE toListFB #-} -toListFB :: (a -> b -> b) -> b -> Stream Identity a -> b -toListFB c n (Stream step state) = go state - where - go st = case runIdentity (step defState st) of - Yield x s -> x `c` go s - Skip s -> go s - Stop -> n - -{-# RULES "toList Identity" Streamly.Internal.Data.Stream.StreamD.Type.toList = toListId #-} -{-# INLINE_EARLY toListId #-} -toListId :: Stream Identity a -> Identity [a] -toListId s = Identity $ build (\c n -> toListFB c n s) - ------------------------------------------------------------------------------- --- Multi-stream folds ------------------------------------------------------------------------------- - --- Adapted from the vector package. - --- | Compare two streams for equality -{-# INLINE_NORMAL eqBy #-} -eqBy :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool -eqBy eq (Stream step1 t1) (Stream step2 t2) = eq_loop0 SPEC t1 t2 - where - eq_loop0 !_ s1 s2 = do - r <- step1 defState s1 - case r of - Yield x s1' -> eq_loop1 SPEC x s1' s2 - Skip s1' -> eq_loop0 SPEC s1' s2 - Stop -> eq_null s2 - - eq_loop1 !_ x s1 s2 = do - r <- step2 defState s2 - case r of - Yield y s2' - | eq x y -> eq_loop0 SPEC s1 s2' - | otherwise -> return False - Skip s2' -> eq_loop1 SPEC x s1 s2' - Stop -> return False - - eq_null s2 = do - r <- step2 defState s2 - case r of - Yield _ _ -> return False - Skip s2' -> eq_null s2' - Stop -> return True - --- Adapted from the vector package. - --- | Compare two streams lexicographically. -{-# INLINE_NORMAL cmpBy #-} -cmpBy - :: Monad m - => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering -cmpBy cmp (Stream step1 t1) (Stream step2 t2) = cmp_loop0 SPEC t1 t2 - where - cmp_loop0 !_ s1 s2 = do - r <- step1 defState s1 - case r of - Yield x s1' -> cmp_loop1 SPEC x s1' s2 - Skip s1' -> cmp_loop0 SPEC s1' s2 - Stop -> cmp_null s2 - - cmp_loop1 !_ x s1 s2 = do - r <- step2 defState s2 - case r of - Yield y s2' -> case x `cmp` y of - EQ -> cmp_loop0 SPEC s1 s2' - c -> return c - Skip s2' -> cmp_loop1 SPEC x s1 s2' - Stop -> return GT - - cmp_null s2 = do - r <- step2 defState s2 - case r of - Yield _ _ -> return LT - Skip s2' -> cmp_null s2' - Stop -> return EQ - ------------------------------------------------------------------------------- --- Transformations ------------------------------------------------------------------------------- - --- Adapted from the vector package. - --- | --- >>> mapM f = Stream.sequence . fmap f --- --- Apply a monadic function to each element of the stream and replace it with --- the output of the resulting action. --- --- >>> s = Stream.fromList ["a", "b", "c"] --- >>> Stream.fold Fold.drain $ Stream.mapM putStr s --- abc --- -{-# INLINE_NORMAL mapM #-} -mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b -mapM f (Stream step state) = Stream step' state - where - {-# INLINE_LATE step' #-} - step' gst st = do - r <- step (adaptState gst) st - case r of - Yield x s -> f x >>= \a -> return $ Yield a s - Skip s -> return $ Skip s - Stop -> return Stop - -{-# INLINE map #-} -map :: Monad m => (a -> b) -> Stream m a -> Stream m b -map f = mapM (return . f) - --- (Functor m) based implementation of fmap does not fuse well in --- streaming-benchmarks. XXX need to investigate why. -instance Monad m => Functor (Stream m) where - {-# INLINE fmap #-} - fmap = map - - {-# INLINE (<$) #-} - (<$) = fmap . const - ------------------------------------------------------------------------------- --- Lists ------------------------------------------------------------------------------- - --- XXX Show instance is 10x slower compared to read, we can do much better. --- The list show instance itself is really slow. - --- XXX The default definitions of "<" in the Ord instance etc. do not perform --- well, because they do not get inlined. Need to add INLINE in Ord class in --- base? - -instance IsList (Stream Identity a) where - type (Item (Stream Identity a)) = a - - {-# INLINE fromList #-} - fromList = Streamly.Internal.Data.Stream.StreamD.Type.fromList - - {-# INLINE toList #-} - toList = runIdentity . Streamly.Internal.Data.Stream.StreamD.Type.toList - -instance Eq a => Eq (Stream Identity a) where - {-# INLINE (==) #-} - (==) xs ys = runIdentity $ eqBy (==) xs ys - -instance Ord a => Ord (Stream Identity a) where - {-# INLINE compare #-} - compare xs ys = runIdentity $ cmpBy compare xs ys - - {-# INLINE (<) #-} - x < y = - case compare x y of - LT -> True - _ -> False - - {-# INLINE (<=) #-} - x <= y = - case compare x y of - GT -> False - _ -> True - - {-# INLINE (>) #-} - x > y = - case compare x y of - GT -> True - _ -> False - - {-# INLINE (>=) #-} - x >= y = - case compare x y of - LT -> False - _ -> True - - {-# INLINE max #-} - max x y = if x <= y then y else x - - {-# INLINE min #-} - min x y = if x <= y then x else y - -instance Show a => Show (Stream Identity a) where - showsPrec p dl = showParen (p > 10) $ - showString "fromList " . shows (GHC.Exts.toList dl) - -instance Read a => Read (Stream Identity a) where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - Streamly.Internal.Data.Stream.StreamD.Type.fromList <$> readPrec - - readListPrec = readListPrecDefault - -instance (a ~ Char) => IsString (Stream Identity a) where - {-# INLINE fromString #-} - fromString = Streamly.Internal.Data.Stream.StreamD.Type.fromList - -------------------------------------------------------------------------------- --- Foldable -------------------------------------------------------------------------------- - --- The default Foldable instance has several issues: --- 1) several definitions do not have INLINE on them, so we provide --- re-implementations with INLINE pragmas. --- 2) the definitions of sum/product/maximum/minimum are inefficient as they --- use right folds, they cannot run in constant memory. We provide --- implementations using strict left folds here. - --- There is no Traversable instance because, there is no scalable cons for --- StreamD, use toList and fromList instead. - -instance (Foldable m, Monad m) => Foldable (Stream m) where - - {-# INLINE foldMap #-} - foldMap f = - Data.Foldable.fold - . Streamly.Internal.Data.Stream.StreamD.Type.foldr (mappend . f) mempty - - {-# INLINE foldr #-} - foldr f z t = appEndo (foldMap (Endo #. f) t) z - - {-# INLINE foldl' #-} - foldl' f z0 xs = Data.Foldable.foldr f' id xs z0 - where f' x k = oneShot $ \z -> k $! f z x - - {-# INLINE length #-} - length = Data.Foldable.foldl' (\n _ -> n + 1) 0 - - {-# INLINE elem #-} - elem = any . (==) - - {-# INLINE maximum #-} - maximum = - fromMaybe (errorWithoutStackTrace "maximum: empty stream") - . toMaybe - . Data.Foldable.foldl' getMax Nothing' - - where - - getMax Nothing' x = Just' x - getMax (Just' mx) x = Just' $! max mx x - - {-# INLINE minimum #-} - minimum = - fromMaybe (errorWithoutStackTrace "minimum: empty stream") - . toMaybe - . Data.Foldable.foldl' getMin Nothing' - - where - - getMin Nothing' x = Just' x - getMin (Just' mn) x = Just' $! min mn x - - {-# INLINE sum #-} - sum = Data.Foldable.foldl' (+) 0 - - {-# INLINE product #-} - product = Data.Foldable.foldl' (*) 1 - -------------------------------------------------------------------------------- --- Filtering -------------------------------------------------------------------------------- - --- Adapted from the vector package. - --- | Take first 'n' elements from the stream and discard the rest. --- -{-# INLINE_NORMAL take #-} -take :: Applicative m => Int -> Stream m a -> Stream m a -take n (Stream step state) = n `seq` Stream step' (state, 0) - - where - - {-# INLINE_LATE step' #-} - step' gst (st, i) | i < n = do - (\case - Yield x s -> Yield x (s, i + 1) - Skip s -> Skip (s, i) - Stop -> Stop) <$> step gst st - step' _ (_, _) = pure Stop - --- Adapted from the vector package. - --- | Same as 'takeWhile' but with a monadic predicate. --- -{-# INLINE_NORMAL takeWhileM #-} -takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a --- takeWhileM p = scanMaybe (FL.takingEndByM_ (\x -> not <$> p x)) -takeWhileM f (Stream step state) = Stream step' state - where - {-# INLINE_LATE step' #-} - step' gst st = do - r <- step gst st - case r of - Yield x s -> do - b <- f x - return $ if b then Yield x s else Stop - Skip s -> return $ Skip s - Stop -> return Stop - --- | End the stream as soon as the predicate fails on an element. --- -{-# INLINE takeWhile #-} -takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a -takeWhile f = takeWhileM (return . f) - --- Like takeWhile but with an inverted condition and also taking --- the matching element. - -{-# INLINE_NORMAL takeEndByM #-} -takeEndByM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a -takeEndByM f (Stream step state) = Stream step' (Just state) - where - {-# INLINE_LATE step' #-} - step' gst (Just st) = do - r <- step gst st - case r of - Yield x s -> do - b <- f x - return $ - if not b - then Yield x (Just s) - else Yield x Nothing - Skip s -> return $ Skip (Just s) - Stop -> return Stop - - step' _ Nothing = return Stop - -{-# INLINE takeEndBy #-} -takeEndBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m a -takeEndBy f = takeEndByM (return . f) - ------------------------------------------------------------------------------- --- Zipping ------------------------------------------------------------------------------- - --- | Like 'zipWith' but using a monadic zipping function. --- -{-# INLINE_NORMAL zipWithM #-} -zipWithM :: Monad m - => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c -zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing) - where - {-# INLINE_LATE step #-} - step gst (sa, sb, Nothing) = do - r <- stepa (adaptState gst) sa - return $ - case r of - Yield x sa' -> Skip (sa', sb, Just x) - Skip sa' -> Skip (sa', sb, Nothing) - Stop -> Stop - - step gst (sa, sb, Just x) = do - r <- stepb (adaptState gst) sb - case r of - Yield y sb' -> do - z <- f x y - return $ Yield z (sa, sb', Nothing) - Skip sb' -> return $ Skip (sa, sb', Just x) - Stop -> return Stop - -{-# RULES "zipWithM xs xs" - forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-} - --- | Stream @a@ is evaluated first, followed by stream @b@, the resulting --- elements @a@ and @b@ are then zipped using the supplied zip function and the --- result @c@ is yielded to the consumer. --- --- If stream @a@ or stream @b@ ends, the zipped stream ends. If stream @b@ ends --- first, the element @a@ from previous evaluation of stream @a@ is discarded. --- --- >>> s1 = Stream.fromList [1,2,3] --- >>> s2 = Stream.fromList [4,5,6] --- >>> Stream.fold Fold.toList $ Stream.zipWith (+) s1 s2 --- [5,7,9] --- -{-# INLINE zipWith #-} -zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c -zipWith f = zipWithM (\a b -> return (f a b)) - ------------------------------------------------------------------------------- --- Combine N Streams - concatAp ------------------------------------------------------------------------------- - --- | Apply a stream of functions to a stream of values and flatten the results. --- --- Note that the second stream is evaluated multiple times. --- --- >>> crossApply = Stream.crossWith id --- -{-# INLINE_NORMAL crossApply #-} -crossApply :: Functor f => Stream f (a -> b) -> Stream f a -> Stream f b -crossApply (Stream stepa statea) (Stream stepb stateb) = - Stream step' (Left statea) - - where - - {-# INLINE_LATE step' #-} - step' gst (Left st) = fmap - (\case - Yield f s -> Skip (Right (f, s, stateb)) - Skip s -> Skip (Left s) - Stop -> Stop) - (stepa (adaptState gst) st) - step' gst (Right (f, os, st)) = fmap - (\case - Yield a s -> Yield (f a) (Right (f, os, s)) - Skip s -> Skip (Right (f,os, s)) - Stop -> Skip (Left os)) - (stepb (adaptState gst) st) - -{-# INLINE_NORMAL crossApplySnd #-} -crossApplySnd :: Functor f => Stream f a -> Stream f b -> Stream f b -crossApplySnd (Stream stepa statea) (Stream stepb stateb) = - Stream step (Left statea) - - where - - {-# INLINE_LATE step #-} - step gst (Left st) = - fmap - (\case - Yield _ s -> Skip (Right (s, stateb)) - Skip s -> Skip (Left s) - Stop -> Stop) - (stepa (adaptState gst) st) - step gst (Right (ostate, st)) = - fmap - (\case - Yield b s -> Yield b (Right (ostate, s)) - Skip s -> Skip (Right (ostate, s)) - Stop -> Skip (Left ostate)) - (stepb gst st) - -{-# INLINE_NORMAL crossApplyFst #-} -crossApplyFst :: Functor f => Stream f a -> Stream f b -> Stream f a -crossApplyFst (Stream stepa statea) (Stream stepb stateb) = - Stream step (Left statea) - - where - - {-# INLINE_LATE step #-} - step gst (Left st) = - fmap - (\case - Yield b s -> Skip (Right (s, stateb, b)) - Skip s -> Skip (Left s) - Stop -> Stop) - (stepa gst st) - step gst (Right (ostate, st, b)) = - fmap - (\case - Yield _ s -> Yield b (Right (ostate, s, b)) - Skip s -> Skip (Right (ostate, s, b)) - Stop -> Skip (Left ostate)) - (stepb (adaptState gst) st) - -{- -instance Applicative f => Applicative (Stream f) where - {-# INLINE pure #-} - pure = fromPure - - {-# INLINE (<*>) #-} - (<*>) = crossApply - - {-# INLINE liftA2 #-} - liftA2 f x = (<*>) (fmap f x) - - {-# INLINE (*>) #-} - (*>) = crossApplySnd - - {-# INLINE (<*) #-} - (<*) = crossApplyFst --} - --- | --- Definition: --- --- >>> crossWith f m1 m2 = fmap f m1 `Stream.crossApply` m2 --- --- Note that the second stream is evaluated multiple times. --- -{-# INLINE crossWith #-} -crossWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c -crossWith f m1 m2 = fmap f m1 `crossApply` m2 - --- | Given a @Stream m a@ and @Stream m b@ generate a stream with all possible --- combinations of the tuple @(a, b)@. --- --- Definition: --- --- >>> cross = Stream.crossWith (,) --- --- The second stream is evaluated multiple times. If that is not desired it can --- be cached in an 'Data.Array.Array' and then generated from the array before --- calling this function. Caching may also improve performance if the stream is --- expensive to evaluate. --- --- See 'Streamly.Internal.Data.Unfold.cross' for a much faster fused --- alternative. --- --- Time: O(m x n) --- --- /Pre-release/ -{-# INLINE cross #-} -cross :: Monad m => Stream m a -> Stream m b -> Stream m (a, b) -cross = crossWith (,) - ------------------------------------------------------------------------------- --- Combine N Streams - unfoldMany ------------------------------------------------------------------------------- - -{-# ANN type ConcatMapUState Fuse #-} -data ConcatMapUState o i = - ConcatMapUOuter o - | ConcatMapUInner o i - --- | @unfoldMany unfold stream@ uses @unfold@ to map the input stream elements --- to streams and then flattens the generated streams into a single output --- stream. - --- This is like 'concatMap' but uses an unfold with an explicit state to --- generate the stream instead of a 'Stream' type generator. This allows better --- optimization via fusion. This can be many times more efficient than --- 'concatMap'. - --- | Like 'concatMap' but uses an 'Unfold' for stream generation. Unlike --- 'concatMap' this can fuse the 'Unfold' code with the inner loop and --- therefore provide many times better performance. --- -{-# INLINE_NORMAL unfoldMany #-} -unfoldMany :: Monad m => Unfold m a b -> Stream m a -> Stream m b -unfoldMany (Unfold istep inject) (Stream ostep ost) = - Stream step (ConcatMapUOuter ost) - where - {-# INLINE_LATE step #-} - step gst (ConcatMapUOuter o) = do - r <- ostep (adaptState gst) o - case r of - Yield a o' -> do - i <- inject a - i `seq` return (Skip (ConcatMapUInner o' i)) - Skip o' -> return $ Skip (ConcatMapUOuter o') - Stop -> return Stop - - step _ (ConcatMapUInner o i) = do - r <- istep i - return $ case r of - Yield x i' -> Yield x (ConcatMapUInner o i') - Skip i' -> Skip (ConcatMapUInner o i') - Stop -> Skip (ConcatMapUOuter o) - ------------------------------------------------------------------------------- --- Combine N Streams - concatMap ------------------------------------------------------------------------------- - --- Adapted from the vector package. - --- | Map a stream producing monadic function on each element of the stream --- and then flatten the results into a single stream. Since the stream --- generation function is monadic, unlike 'concatMap', it can produce an --- effect at the beginning of each iteration of the inner loop. --- --- See 'unfoldMany' for a fusible alternative. --- -{-# INLINE_NORMAL concatMapM #-} -concatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b -concatMapM f (Stream step state) = Stream step' (Left state) - where - {-# INLINE_LATE step' #-} - step' gst (Left st) = do - r <- step (adaptState gst) st - case r of - Yield a s -> do - b_stream <- f a - return $ Skip (Right (b_stream, s)) - Skip s -> return $ Skip (Left s) - Stop -> return Stop - - -- XXX flattenArrays is 5x faster than "concatMap fromArray". if somehow we - -- can get inner_step to inline and fuse here we can perhaps get the same - -- performance using "concatMap fromArray". - -- - -- XXX using the pattern synonym "Stream" causes a major performance issue - -- here even if the synonym does not include an adaptState call. Need to - -- find out why. Is that something to be fixed in GHC? - step' gst (Right (UnStream inner_step inner_st, st)) = do - r <- inner_step (adaptState gst) inner_st - case r of - Yield b inner_s -> - return $ Yield b (Right (Stream inner_step inner_s, st)) - Skip inner_s -> - return $ Skip (Right (Stream inner_step inner_s, st)) - Stop -> return $ Skip (Left st) - --- | Map a stream producing function on each element of the stream and then --- flatten the results into a single stream. --- --- >>> concatMap f = Stream.concatMapM (return . f) --- >>> concatMap f = Stream.concat . fmap f --- >>> concatMap f = Stream.unfoldMany (Unfold.lmap f Unfold.fromStream) --- --- See 'unfoldMany' for a fusible alternative. --- -{-# INLINE concatMap #-} -concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b -concatMap f = concatMapM (return . f) - --- | Flatten a stream of streams to a single stream. --- --- >>> concat = Stream.concatMap id --- --- /Pre-release/ -{-# INLINE concat #-} -concat :: Monad m => Stream m (Stream m a) -> Stream m a -concat = concatMap id - --- XXX The idea behind this rule is to rewrite any calls to "concatMap --- fromArray" automatically to flattenArrays which is much faster. However, we --- need an INLINE_EARLY on concatMap for this rule to fire. But if we use --- INLINE_EARLY on concatMap or fromArray then direct uses of --- "concatMap fromArray" (without the RULE) become much slower, this means --- "concatMap f" in general would become slower. Need to find a solution to --- this. --- --- {-# RULES "concatMap Array.toStreamD" --- concatMap Array.toStreamD = Array.flattenArray #-} - --- >>> concatEffect = Stream.concat . lift -- requires (MonadTrans t) --- >>> concatEffect = join . lift -- requires (MonadTrans t, Monad (Stream m)) - --- | Given a stream value in the underlying monad, lift and join the underlying --- monad with the stream monad. --- --- >>> concatEffect = Stream.concat . Stream.fromEffect --- >>> concatEffect eff = Stream.concatMapM (\() -> eff) (Stream.fromPure ()) --- --- See also: 'concat', 'sequence' --- -{-# INLINE concatEffect #-} -concatEffect :: Monad m => m (Stream m a) -> Stream m a -concatEffect generator = concatMapM (\() -> generator) (fromPure ()) - -{- --- NOTE: even though concatMap for StreamD is 4x faster compared to StreamK, --- the monad instance does not seem to be significantly faster. -instance Monad m => Monad (Stream m) where - {-# INLINE return #-} - return = pure - - {-# INLINE (>>=) #-} - (>>=) = flip concatMap - - {-# INLINE (>>) #-} - (>>) = (*>) --} - ------------------------------------------------------------------------------- --- Traversing a tree top down ------------------------------------------------------------------------------- - --- Next stream is to be generated by the return value of the previous stream. A --- general intuitive way of doing that could be to use an appending monad --- instance for streams where the result of the previous stream is used to --- generate the next one. In the first pass we can just emit the values in the --- stream and keep building a buffered list/stream, once done we can then --- process the buffered stream. - --- | Generate a stream from an initial state, scan and concat the stream, --- generate a stream again from the final state of the previous scan and repeat --- the process. -{-# INLINE_NORMAL concatIterateScan #-} -concatIterateScan :: Monad m => - (b -> a -> m b) - -> (b -> m (Maybe (b, Stream m a))) - -> b - -> Stream m a -concatIterateScan scanner generate initial = Stream step (Left initial) - - where - - {-# INLINE_LATE step #-} - step _ (Left acc) = do - r <- generate acc - case r of - Nothing -> return Stop - Just v -> return $ Skip (Right v) - - step gst (Right (st, UnStream inner_step inner_st)) = do - r <- inner_step (adaptState gst) inner_st - case r of - Yield b inner_s -> do - acc <- scanner st b - return $ Yield b (Right (acc, Stream inner_step inner_s)) - Skip inner_s -> - return $ Skip (Right (st, Stream inner_step inner_s)) - Stop -> return $ Skip (Left st) - --- Note: The iterate function returns a Maybe Stream instead of returning a nil --- stream for indicating a leaf node. This is to optimize so that we do not --- have to store any state. This makes the stored state proportional to the --- number of non-leaf nodes rather than total number of nodes. - --- | Same as 'concatIterateBfs' except that the traversal of the last --- element on a level is emitted first and then going backwards up to the first --- element (reversed ordering). This may be slightly faster than --- 'concatIterateBfs'. --- -{-# INLINE_NORMAL concatIterateBfsRev #-} -concatIterateBfsRev :: Monad m => - (a -> Maybe (Stream m a)) - -> Stream m a - -> Stream m a -concatIterateBfsRev f stream = Stream step (stream, []) - - where - - {-# INLINE_LATE step #-} - step gst (UnStream step1 st, xs) = do - r <- step1 (adaptState gst) st - case r of - Yield a s -> do - let xs1 = - case f a of - Nothing -> xs - Just x -> x:xs - return $ Yield a (Stream step1 s, xs1) - Skip s -> return $ Skip (Stream step1 s, xs) - Stop -> - case xs of - (y:ys) -> return $ Skip (y, ys) - [] -> return Stop - --- | Similar to 'concatIterateDfs' except that it traverses the stream in --- breadth first style (BFS). First, all the elements in the input stream are --- emitted, and then their traversals are emitted. --- --- Example, list a directory tree using BFS: --- --- >>> f = either (Just . Dir.readEitherPaths) (const Nothing) --- >>> input = Stream.fromPure (Left ".") --- >>> ls = Stream.concatIterateBfs f input --- --- /Pre-release/ -{-# INLINE_NORMAL concatIterateBfs #-} -concatIterateBfs :: Monad m => - (a -> Maybe (Stream m a)) - -> Stream m a - -> Stream m a -concatIterateBfs f stream = Stream step (stream, [], []) - - where - - {-# INLINE_LATE step #-} - step gst (UnStream step1 st, xs, ys) = do - r <- step1 (adaptState gst) st - case r of - Yield a s -> do - let ys1 = - case f a of - Nothing -> ys - Just y -> y:ys - return $ Yield a (Stream step1 s, xs, ys1) - Skip s -> return $ Skip (Stream step1 s, xs, ys) - Stop -> - case xs of - (x:xs1) -> return $ Skip (x, xs1, ys) - [] -> - case reverse ys of - (x:xs1) -> return $ Skip (x, xs1, []) - [] -> return Stop - --- | Traverse the stream in depth first style (DFS). Map each element in the --- input stream to a stream and flatten, recursively map the resulting elements --- as well to a stream and flatten until no more streams are generated. --- --- Example, list a directory tree using DFS: --- --- >>> f = either (Just . Dir.readEitherPaths) (const Nothing) --- >>> input = Stream.fromPure (Left ".") --- >>> ls = Stream.concatIterateDfs f input --- --- This is equivalent to using @concatIterateWith StreamK.append@. --- --- /Pre-release/ -{-# INLINE_NORMAL concatIterateDfs #-} -concatIterateDfs :: Monad m => - (a -> Maybe (Stream m a)) - -> Stream m a - -> Stream m a -concatIterateDfs f stream = Stream step (stream, []) - - where - - {-# INLINE_LATE step #-} - step gst (UnStream step1 st, xs) = do - r <- step1 (adaptState gst) st - case r of - Yield a s -> do - let st1 = - case f a of - Nothing -> (Stream step1 s, xs) - Just x -> (x, Stream step1 s:xs) - return $ Yield a st1 - Skip s -> return $ Skip (Stream step1 s, xs) - Stop -> - case xs of - (y:ys) -> return $ Skip (y, ys) - [] -> return Stop - -{-# ANN type IterateUnfoldState Fuse #-} -data IterateUnfoldState o i = - IterateUnfoldOuter o - | IterateUnfoldInner o i [i] - --- | Same as @concatIterateDfs@ but more efficient due to stream fusion. --- --- Example, list a directory tree using DFS: --- --- >>> f = Unfold.either Dir.eitherReaderPaths Unfold.nil --- >>> input = Stream.fromPure (Left ".") --- >>> ls = Stream.unfoldIterateDfs f input --- --- /Pre-release/ -{-# INLINE_NORMAL unfoldIterateDfs #-} -unfoldIterateDfs :: Monad m => - Unfold m a a - -> Stream m a - -> Stream m a -unfoldIterateDfs (Unfold istep inject) (Stream ostep ost) = - Stream step (IterateUnfoldOuter ost) - - where - - {-# INLINE_LATE step #-} - step gst (IterateUnfoldOuter o) = do - r <- ostep (adaptState gst) o - case r of - Yield a s -> do - i <- inject a - i `seq` return (Yield a (IterateUnfoldInner s i [])) - Skip s -> return $ Skip (IterateUnfoldOuter s) - Stop -> return Stop - - step _ (IterateUnfoldInner o i ii) = do - r <- istep i - case r of - Yield x s -> do - i1 <- inject x - i1 `seq` return $ Yield x (IterateUnfoldInner o i1 (s:ii)) - Skip s -> return $ Skip (IterateUnfoldInner o s ii) - Stop -> - case ii of - (y:ys) -> return $ Skip (IterateUnfoldInner o y ys) - [] -> return $ Skip (IterateUnfoldOuter o) - -{-# ANN type IterateUnfoldBFSRevState Fuse #-} -data IterateUnfoldBFSRevState o i = - IterateUnfoldBFSRevOuter o [i] - | IterateUnfoldBFSRevInner i [i] - --- | Like 'unfoldIterateBfs' but processes the children in reverse order, --- therefore, may be slightly faster. --- --- /Pre-release/ -{-# INLINE_NORMAL unfoldIterateBfsRev #-} -unfoldIterateBfsRev :: Monad m => - Unfold m a a - -> Stream m a - -> Stream m a -unfoldIterateBfsRev (Unfold istep inject) (Stream ostep ost) = - Stream step (IterateUnfoldBFSRevOuter ost []) - - where - - {-# INLINE_LATE step #-} - step gst (IterateUnfoldBFSRevOuter o ii) = do - r <- ostep (adaptState gst) o - case r of - Yield a s -> do - i <- inject a - i `seq` return (Yield a (IterateUnfoldBFSRevOuter s (i:ii))) - Skip s -> return $ Skip (IterateUnfoldBFSRevOuter s ii) - Stop -> - case ii of - (y:ys) -> return $ Skip (IterateUnfoldBFSRevInner y ys) - [] -> return Stop - - step _ (IterateUnfoldBFSRevInner i ii) = do - r <- istep i - case r of - Yield x s -> do - i1 <- inject x - i1 `seq` return $ Yield x (IterateUnfoldBFSRevInner s (i1:ii)) - Skip s -> return $ Skip (IterateUnfoldBFSRevInner s ii) - Stop -> - case ii of - (y:ys) -> return $ Skip (IterateUnfoldBFSRevInner y ys) - [] -> return Stop - -{-# ANN type IterateUnfoldBFSState Fuse #-} -data IterateUnfoldBFSState o i = - IterateUnfoldBFSOuter o [i] - | IterateUnfoldBFSInner i [i] [i] - --- | Like 'unfoldIterateDfs' but uses breadth first style traversal. --- --- /Pre-release/ -{-# INLINE_NORMAL unfoldIterateBfs #-} -unfoldIterateBfs :: Monad m => - Unfold m a a - -> Stream m a - -> Stream m a -unfoldIterateBfs (Unfold istep inject) (Stream ostep ost) = - Stream step (IterateUnfoldBFSOuter ost []) - - where - - {-# INLINE_LATE step #-} - step gst (IterateUnfoldBFSOuter o rii) = do - r <- ostep (adaptState gst) o - case r of - Yield a s -> do - i <- inject a - i `seq` return (Yield a (IterateUnfoldBFSOuter s (i:rii))) - Skip s -> return $ Skip (IterateUnfoldBFSOuter s rii) - Stop -> - case reverse rii of - (y:ys) -> return $ Skip (IterateUnfoldBFSInner y ys []) - [] -> return Stop - - step _ (IterateUnfoldBFSInner i ii rii) = do - r <- istep i - case r of - Yield x s -> do - i1 <- inject x - i1 `seq` return $ Yield x (IterateUnfoldBFSInner s ii (i1:rii)) - Skip s -> return $ Skip (IterateUnfoldBFSInner s ii rii) - Stop -> - case ii of - (y:ys) -> return $ Skip (IterateUnfoldBFSInner y ys rii) - [] -> - case reverse rii of - (y:ys) -> return $ Skip (IterateUnfoldBFSInner y ys []) - [] -> return Stop - ------------------------------------------------------------------------------- --- Folding a tree bottom up ------------------------------------------------------------------------------- - --- | Binary BFS style reduce, folds a level entirely using the supplied fold --- function, collecting the outputs as next level of the tree, then repeats the --- same process on the next level. The last elements of a previously folded --- level are folded first. -{-# INLINE_NORMAL reduceIterateBfs #-} -reduceIterateBfs :: Monad m => - (a -> a -> m a) -> Stream m a -> m (Maybe a) -reduceIterateBfs f (Stream step state) = go SPEC state [] Nothing - - where - - go _ st xs Nothing = do - r <- step defState st - case r of - Yield x1 s -> go SPEC s xs (Just x1) - Skip s -> go SPEC s xs Nothing - Stop -> - case xs of - [] -> return Nothing - _ -> goBuf SPEC xs [] - go _ st xs (Just x1) = do - r2 <- step defState st - case r2 of - Yield x2 s -> do - x <- f x1 x2 - go SPEC s (x:xs) Nothing - Skip s -> go SPEC s xs (Just x1) - Stop -> - case xs of - [] -> return (Just x1) - _ -> goBuf SPEC (x1:xs) [] - - goBuf _ [] ys = goBuf SPEC ys [] - goBuf _ [x1] ys = do - case ys of - [] -> return (Just x1) - (x2:xs) -> do - y <- f x1 x2 - goBuf SPEC xs [y] - goBuf _ (x1:x2:xs) ys = do - y <- f x1 x2 - goBuf SPEC xs (y:ys) - --- | N-Ary BFS style iterative fold, if the input stream finished before the --- fold then it returns Left otherwise Right. If the fold returns Left we --- terminate. --- --- /Unimplemented/ -foldIterateBfs :: - Fold m a (Either a a) -> Stream m a -> m (Maybe a) -foldIterateBfs = undefined - ------------------------------------------------------------------------------- --- Grouping/Splitting ------------------------------------------------------------------------------- - --- s = stream state, fs = fold state -{-# ANN type FoldManyPost Fuse #-} -data FoldManyPost s fs b a - = FoldManyPostStart s - | FoldManyPostLoop s fs - | FoldManyPostYield b (FoldManyPost s fs b a) - | FoldManyPostDone - --- XXX Need a more intuitive name, and need to reconcile the names --- foldMany/fold/parse/parseMany/parseManyPost etc. - --- XXX foldManyPost keeps the last fold always partial. if the last fold is --- complete then another fold is applied on empty input. This is used for --- applying folds like takeEndBy such that the last element is not the --- separator (infix style). But that looks like a hack. We should remove this --- and use a custom combinator for infix parsing. - --- | Like 'foldMany' but evaluates the fold even if the fold did not receive --- any input, therefore, always results in a non-empty output even on an empty --- stream (default result of the fold). --- --- Example, empty stream: --- --- >>> f = Fold.take 2 Fold.sum --- >>> fmany = Stream.fold Fold.toList . Stream.foldManyPost f --- >>> fmany $ Stream.fromList [] --- [0] --- --- Example, last fold empty: --- --- >>> fmany $ Stream.fromList [1..4] --- [3,7,0] --- --- Example, last fold non-empty: --- --- >>> fmany $ Stream.fromList [1..5] --- [3,7,5] --- --- Note that using a closed fold e.g. @Fold.take 0@, would result in an --- infinite stream without consuming the input. --- --- /Pre-release/ --- -{-# INLINE_NORMAL foldManyPost #-} -foldManyPost :: Monad m => Fold m a b -> Stream m a -> Stream m b -foldManyPost (Fold fstep initial extract) (Stream step state) = - Stream step' (FoldManyPostStart state) - - where - - {-# INLINE consume #-} - consume x s fs = do - res <- fstep fs x - return - $ Skip - $ case res of - FL.Done b -> FoldManyPostYield b (FoldManyPostStart s) - FL.Partial ps -> FoldManyPostLoop s ps - - {-# INLINE_LATE step' #-} - step' _ (FoldManyPostStart st) = do - r <- initial - return - $ Skip - $ case r of - FL.Done b -> FoldManyPostYield b (FoldManyPostStart st) - FL.Partial fs -> FoldManyPostLoop st fs - step' gst (FoldManyPostLoop st fs) = do - r <- step (adaptState gst) st - case r of - Yield x s -> consume x s fs - Skip s -> return $ Skip (FoldManyPostLoop s fs) - Stop -> do - b <- extract fs - return $ Skip (FoldManyPostYield b FoldManyPostDone) - step' _ (FoldManyPostYield b next) = return $ Yield b next - step' _ FoldManyPostDone = return Stop - -{-# ANN type FoldMany Fuse #-} -data FoldMany s fs b a - = FoldManyStart s - | FoldManyFirst fs s - | FoldManyLoop s fs - | FoldManyYield b (FoldMany s fs b a) - | FoldManyDone - --- XXX Nested foldMany does not fuse. - --- | Apply a 'Fold' repeatedly on a stream and emit the results in the output --- stream. --- --- Definition: --- --- >>> foldMany f = Stream.parseMany (Parser.fromFold f) --- --- Example, empty stream: --- --- >>> f = Fold.take 2 Fold.sum --- >>> fmany = Stream.fold Fold.toList . Stream.foldMany f --- >>> fmany $ Stream.fromList [] --- [] --- --- Example, last fold empty: --- --- >>> fmany $ Stream.fromList [1..4] --- [3,7] --- --- Example, last fold non-empty: --- --- >>> fmany $ Stream.fromList [1..5] --- [3,7,5] --- --- Note that using a closed fold e.g. @Fold.take 0@, would result in an --- infinite stream on a non-empty input stream. --- -{-# INLINE_NORMAL foldMany #-} -foldMany :: Monad m => Fold m a b -> Stream m a -> Stream m b -foldMany (Fold fstep initial extract) (Stream step state) = - Stream step' (FoldManyStart state) - - where - - {-# INLINE consume #-} - consume x s fs = do - res <- fstep fs x - return - $ Skip - $ case res of - FL.Done b -> FoldManyYield b (FoldManyStart s) - FL.Partial ps -> FoldManyLoop s ps - - {-# INLINE_LATE step' #-} - step' _ (FoldManyStart st) = do - r <- initial - return - $ Skip - $ case r of - FL.Done b -> FoldManyYield b (FoldManyStart st) - FL.Partial fs -> FoldManyFirst fs st - step' gst (FoldManyFirst fs st) = do - r <- step (adaptState gst) st - case r of - Yield x s -> consume x s fs - Skip s -> return $ Skip (FoldManyFirst fs s) - Stop -> return Stop - step' gst (FoldManyLoop st fs) = do - r <- step (adaptState gst) st - case r of - Yield x s -> consume x s fs - Skip s -> return $ Skip (FoldManyLoop s fs) - Stop -> do - b <- extract fs - return $ Skip (FoldManyYield b FoldManyDone) - step' _ (FoldManyYield b next) = return $ Yield b next - step' _ FoldManyDone = return Stop - -{-# INLINE groupsOf #-} -groupsOf :: Monad m => Int -> Fold m a b -> Stream m a -> Stream m b -groupsOf n f = foldMany (FL.take n f) - --- Keep the argument order consistent with refoldIterateM. - --- | Like 'foldMany' but for the 'Refold' type. The supplied action is used as --- the initial value for each refold. --- --- /Internal/ -{-# INLINE_NORMAL refoldMany #-} -refoldMany :: Monad m => Refold m x a b -> m x -> Stream m a -> Stream m b -refoldMany (Refold fstep inject extract) action (Stream step state) = - Stream step' (FoldManyStart state) - - where - - {-# INLINE consume #-} - consume x s fs = do - res <- fstep fs x - return - $ Skip - $ case res of - FL.Done b -> FoldManyYield b (FoldManyStart s) - FL.Partial ps -> FoldManyLoop s ps - - {-# INLINE_LATE step' #-} - step' _ (FoldManyStart st) = do - r <- action >>= inject - return - $ Skip - $ case r of - FL.Done b -> FoldManyYield b (FoldManyStart st) - FL.Partial fs -> FoldManyFirst fs st - step' gst (FoldManyFirst fs st) = do - r <- step (adaptState gst) st - case r of - Yield x s -> consume x s fs - Skip s -> return $ Skip (FoldManyFirst fs s) - Stop -> return Stop - step' gst (FoldManyLoop st fs) = do - r <- step (adaptState gst) st - case r of - Yield x s -> consume x s fs - Skip s -> return $ Skip (FoldManyLoop s fs) - Stop -> do - b <- extract fs - return $ Skip (FoldManyYield b FoldManyDone) - step' _ (FoldManyYield b next) = return $ Yield b next - step' _ FoldManyDone = return Stop - ------------------------------------------------------------------------------- --- Stream with a cross product style monad instance ------------------------------------------------------------------------------- - --- XXX CrossStream performs better than the CrossStreamK when nesting two --- loops, however, CrossStreamK seems to be better for more than two nestings, --- need to do more perf investigation. - --- | A newtype wrapper for the 'Stream' type with a cross product style monad --- instance. --- --- A 'Monad' bind behaves like a @for@ loop: --- --- >>> :{ --- Stream.fold Fold.toList $ Stream.unCross $ do --- x <- Stream.mkCross $ Stream.fromList [1,2] --- -- Perform the following actions for each x in the stream --- return x --- :} --- [1,2] --- --- Nested monad binds behave like nested @for@ loops: --- --- >>> :{ --- Stream.fold Fold.toList $ Stream.unCross $ do --- x <- Stream.mkCross $ Stream.fromList [1,2] --- y <- Stream.mkCross $ Stream.fromList [3,4] --- -- Perform the following actions for each x, for each y --- return (x, y) --- :} --- [(1,3),(1,4),(2,3),(2,4)] --- -newtype CrossStream m a = CrossStream {unCrossStream :: Stream m a} - deriving (Functor, Foldable) - -{-# INLINE mkCross #-} -mkCross :: Stream m a -> CrossStream m a -mkCross = CrossStream - -{-# INLINE unCross #-} -unCross :: CrossStream m a -> Stream m a -unCross = unCrossStream - --- Pure (Identity monad) stream instances -deriving instance IsList (CrossStream Identity a) -deriving instance (a ~ Char) => IsString (CrossStream Identity a) -deriving instance Eq a => Eq (CrossStream Identity a) -deriving instance Ord a => Ord (CrossStream Identity a) - --- Do not use automatic derivation for this to show as "fromList" rather than --- "fromList Identity". -instance Show a => Show (CrossStream Identity a) where - {-# INLINE show #-} - show (CrossStream xs) = show xs - -instance Read a => Read (CrossStream Identity a) where - {-# INLINE readPrec #-} - readPrec = fmap CrossStream readPrec - ------------------------------------------------------------------------------- --- Applicative ------------------------------------------------------------------------------- - --- Note: we need to define all the typeclass operations because we want to --- INLINE them. -instance Monad m => Applicative (CrossStream m) where - {-# INLINE pure #-} - pure x = CrossStream (fromPure x) - - {-# INLINE (<*>) #-} - (CrossStream s1) <*> (CrossStream s2) = - CrossStream (crossApply s1 s2) - - {-# INLINE liftA2 #-} - liftA2 f x = (<*>) (fmap f x) - - {-# INLINE (*>) #-} - (CrossStream s1) *> (CrossStream s2) = - CrossStream (crossApplySnd s1 s2) - - {-# INLINE (<*) #-} - (CrossStream s1) <* (CrossStream s2) = - CrossStream (crossApplyFst s1 s2) - ------------------------------------------------------------------------------- --- Monad ------------------------------------------------------------------------------- - -instance Monad m => Monad (CrossStream m) where - return = pure - - -- Benchmarks better with StreamD bind and pure: - -- toList, filterAllout, *>, *<, >> (~2x) - -- - - -- Benchmarks better with CPS bind and pure: - -- Prime sieve (25x) - -- n binds, breakAfterSome, filterAllIn, state transformer (~2x) - -- - {-# INLINE (>>=) #-} - (>>=) (CrossStream m) f = CrossStream (concatMap (unCrossStream . f) m) - - {-# INLINE (>>) #-} - (>>) = (*>) - ------------------------------------------------------------------------------- --- Transformers ------------------------------------------------------------------------------- - -instance (MonadIO m) => MonadIO (CrossStream m) where - liftIO x = CrossStream (fromEffect $ liftIO x) - -instance MonadTrans CrossStream where - {-# INLINE lift #-} - lift x = CrossStream (fromEffect x) - -instance (MonadThrow m) => MonadThrow (CrossStream m) where - throwM = lift . throwM diff --git a/src/Streamly/Internal/Data/Stream/StreamDK.hs b/src/Streamly/Internal/Data/Stream/StreamDK.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamDK.hs +++ /dev/null @@ -1,52 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.StreamDK --- Copyright : (c) 2019 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- --- This module has the following problems due to rewrite rules: --- --- * Rewrite rules lead to optimization problems, blocking fusion in some --- cases, specifically when combining multiple operations e.g. (filter . drop). --- * Rewrite rules lead to problems when calling a function recursively. For --- example, the StreamD version of foldBreak cannot be used recursively when --- wrapped in rewrite rules because each recursive call adds a roundtrip --- conversion from D to K and back to D. We can use the StreamK versions of --- these though because the rewrite rule gets eliminated in that case. --- * If we have a unified module, we need two different versions of several --- operations e.g. appendK and appendD, both are useful in different cases. --- -module Streamly.Internal.Data.Stream.StreamDK - ( module Streamly.Internal.Data.Stream.Type - , module Streamly.Internal.Data.Stream.Bottom - , module Streamly.Internal.Data.Stream.Eliminate - , module Streamly.Internal.Data.Stream.Exception - , module Streamly.Internal.Data.Stream.Expand - , module Streamly.Internal.Data.Stream.Generate - , module Streamly.Internal.Data.Stream.Lift - , module Streamly.Internal.Data.Stream.Reduce - , module Streamly.Internal.Data.Stream.Transform - , module Streamly.Internal.Data.Stream.Cross - , module Streamly.Internal.Data.Stream.Zip - - -- modules having dependencies on libraries other than base - , module Streamly.Internal.Data.Stream.Transformer - ) -where - -import Streamly.Internal.Data.Stream.Bottom -import Streamly.Internal.Data.Stream.Cross -import Streamly.Internal.Data.Stream.Eliminate -import Streamly.Internal.Data.Stream.Exception -import Streamly.Internal.Data.Stream.Expand -import Streamly.Internal.Data.Stream.Generate -import Streamly.Internal.Data.Stream.Lift -import Streamly.Internal.Data.Stream.Reduce -import Streamly.Internal.Data.Stream.Transform -import Streamly.Internal.Data.Stream.Type -import Streamly.Internal.Data.Stream.Zip - -import Streamly.Internal.Data.Stream.Transformer diff --git a/src/Streamly/Internal/Data/Stream/StreamK.hs b/src/Streamly/Internal/Data/Stream/StreamK.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamK.hs +++ /dev/null @@ -1,1372 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamK --- Copyright : (c) 2017 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Stream.StreamK - ( - -- * Setup - -- | To execute the code examples provided in this module in ghci, please - -- run the following commands first. - -- - -- $setup - - -- * The stream type - Stream - , StreamK(..) - , fromStream - , toStream - - , CrossStreamK - , unCross - , mkCross - - -- * Construction Primitives - , mkStream - , nil - , nilM - , cons - , (.:) - - -- * Elimination Primitives - , foldStream - , foldStreamShared - - -- * Transformation Primitives - , unShare - - -- * Deconstruction - , uncons - - -- * Generation - -- ** Unfolds - , unfoldr - , unfoldrM - - -- ** Specialized Generation - , repeat - , repeatM - , replicate - , replicateM - , fromIndices - , fromIndicesM - , iterate - , iterateM - - -- ** Conversions - , fromPure - , fromEffect - , fromFoldable - , fromList - - -- * foldr/build - , foldrS - , foldrSM - , buildS - , augmentS - - -- * Elimination - -- ** General Folds - , foldr - , foldr1 - , foldrM - - , foldl' - , foldlM' - , foldlS - , foldlx' - , foldlMx' - , fold - , foldBreak - , foldEither - , foldConcat - , parseDBreak - , parseD - , parseBreakChunks - , parseChunks - - -- ** Specialized Folds - , drain - , null - , head - , tail - , init - , elem - , notElem - , all - , any - , last - , minimum - , minimumBy - , maximum - , maximumBy - , findIndices - , lookup - , findM - , find - , (!!) - - -- ** Map and Fold - , mapM_ - - -- ** Conversions - , toList - , hoist - - -- * Transformation - -- ** By folding (scans) - , scanl' - , scanlx' - - -- ** Filtering - , filter - , take - , takeWhile - , drop - , dropWhile - - -- ** Mapping - , map - , mapM - , sequence - - -- ** Inserting - , intersperseM - , intersperse - , insertBy - - -- ** Deleting - , deleteBy - - -- ** Reordering - , reverse - , sortBy - - -- ** Map and Filter - , mapMaybe - - -- ** Zipping - , zipWith - , zipWithM - - -- ** Merging - , mergeBy - , mergeByM - - -- ** Nesting - , crossApplyWith - , crossApply - , crossApplySnd - , crossApplyFst - , crossWith - - , concatMapWith - , concatMap - , concatEffect - , bindWith - , concatIterateWith - , concatIterateLeftsWith - , concatIterateScanWith - - , mergeMapWith - , mergeIterateWith - - -- ** Transformation comprehensions - , the - - -- * Semigroup Style Composition - , append - , interleave - - -- * Utilities - , consM - , mfix - ) -where - -#include "ArrayMacros.h" -#include "inline.hs" -#include "assert.hs" - -import Control.Monad (void, join) -import Data.Proxy (Proxy(..)) -import GHC.Types (SPEC(..)) -import Streamly.Internal.Data.Array.Type (Array(..)) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Producer.Type (Producer(..)) -import Streamly.Internal.Data.SVar.Type (adaptState, defState) -import Streamly.Internal.Data.Unboxed (sizeOf, Unbox) -import Streamly.Internal.Data.Parser.ParserK.Type (ParserK) - -import qualified Streamly.Internal.Data.Array.Type as Array -import qualified Streamly.Internal.Data.Fold.Type as FL -import qualified Streamly.Internal.Data.Parser as Parser -import qualified Streamly.Internal.Data.Parser.ParserD.Type as PR -import qualified Streamly.Internal.Data.Parser.ParserK.Type as ParserK -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Prelude - -import Prelude - hiding (foldl, foldr, last, map, mapM, mapM_, repeat, sequence, - take, filter, all, any, takeWhile, drop, dropWhile, minimum, - maximum, elem, notElem, null, head, tail, init, zipWith, lookup, - foldr1, (!!), replicate, reverse, concatMap, iterate, splitAt) - -import Streamly.Internal.Data.Stream.StreamK.Type -import Streamly.Internal.Data.Parser.ParserD (ParseError(..)) - -#include "DocTestDataStreamK.hs" - -{-# INLINE fromStream #-} -fromStream :: Monad m => Stream.Stream m a -> StreamK m a -fromStream = Stream.toStreamK - -{-# INLINE toStream #-} -toStream :: Applicative m => StreamK m a -> Stream.Stream m a -toStream = Stream.fromStreamK - -------------------------------------------------------------------------------- --- Generation -------------------------------------------------------------------------------- - -{- --- Generalization of concurrent streams/SVar via unfoldr. --- --- Unfold a value into monadic actions and then run the resulting monadic --- actions to generate a stream. Since the step of generating the monadic --- action and running them are decoupled we can run the monadic actions --- cooncurrently. For example, the seed could be a list of monadic actions or a --- pure stream of monadic actions. --- --- We can have different flavors of this depending on the stream type t. The --- concurrent version could be async or ahead etc. Depending on how we queue --- back the feedback portion b, it could be DFS or BFS style. --- -unfoldrA :: (b -> Maybe (m a, b)) -> b -> StreamK m a -unfoldrA = undefined --} - -------------------------------------------------------------------------------- --- Special generation -------------------------------------------------------------------------------- - -repeatM :: Monad m => m a -> StreamK m a -repeatM = repeatMWith consM - -{-# INLINE replicateM #-} -replicateM :: Monad m => Int -> m a -> StreamK m a -replicateM = replicateMWith consM -{-# INLINE replicate #-} -replicate :: Int -> a -> StreamK m a -replicate n a = go n - where - go cnt = if cnt <= 0 then nil else a `cons` go (cnt - 1) - -{-# INLINE fromIndicesM #-} -fromIndicesM :: Monad m => (Int -> m a) -> StreamK m a -fromIndicesM = fromIndicesMWith consM -{-# INLINE fromIndices #-} -fromIndices :: (Int -> a) -> StreamK m a -fromIndices gen = go 0 - where - go n = gen n `cons` go (n + 1) - -{-# INLINE iterate #-} -iterate :: (a -> a) -> a -> StreamK m a -iterate step = go - where - go !s = cons s (go (step s)) - -{-# INLINE iterateM #-} -iterateM :: Monad m => (a -> m a) -> m a -> StreamK m a -iterateM = iterateMWith consM - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - -{-# INLINE fromList #-} -fromList :: [a] -> StreamK m a -fromList = fromFoldable - -------------------------------------------------------------------------------- --- Elimination by Folding -------------------------------------------------------------------------------- - -{-# INLINE foldr1 #-} -foldr1 :: Monad m => (a -> a -> a) -> StreamK m a -> m (Maybe a) -foldr1 step m = do - r <- uncons m - case r of - Nothing -> return Nothing - Just (h, t) -> fmap Just (go h t) - where - go p m1 = - let stp = return p - single a = return $ step a p - yieldk a r = fmap (step p) (go a r) - in foldStream defState yieldk single stp m1 - --- XXX replace the recursive "go" with explicit continuations. --- | Like 'foldx', but with a monadic step function. -{-# INLINABLE foldlMx' #-} -foldlMx' :: Monad m - => (x -> a -> m x) -> m x -> (x -> m b) -> StreamK m a -> m b -foldlMx' step begin done = go begin - where - go !acc m1 = - let stop = acc >>= done - single a = acc >>= \b -> step b a >>= done - yieldk a r = acc >>= \b -> step b a >>= \x -> go (return x) r - in foldStream defState yieldk single stop m1 - --- | Fold a stream using the supplied left 'Fold' and reducing the resulting --- expression strictly at each step. The behavior is similar to 'foldl''. A --- 'Fold' can terminate early without consuming the full stream. See the --- documentation of individual 'Fold's for termination behavior. --- --- Definitions: --- --- >>> fold f = fmap fst . StreamK.foldBreak f --- >>> fold f = StreamK.parseD (Parser.fromFold f) --- --- Example: --- --- >>> StreamK.fold Fold.sum $ StreamK.fromStream $ Stream.enumerateFromTo 1 100 --- 5050 --- -{-# INLINABLE fold #-} -fold :: Monad m => FL.Fold m a b -> StreamK m a -> m b -fold (FL.Fold step begin done) m = do - res <- begin - case res of - FL.Partial fs -> go fs m - FL.Done fb -> return fb - - where - go !acc m1 = - let stop = done acc - single a = step acc a - >>= \case - FL.Partial s -> done s - FL.Done b1 -> return b1 - yieldk a r = step acc a - >>= \case - FL.Partial s -> go s r - FL.Done b1 -> return b1 - in foldStream defState yieldk single stop m1 - --- | Fold resulting in either breaking the stream or continuation of the fold. --- Instead of supplying the input stream in one go we can run the fold multiple --- times, each time supplying the next segment of the input stream. If the fold --- has not yet finished it returns a fold that can be run again otherwise it --- returns the fold result and the residual stream. --- --- /Internal/ -{-# INLINE foldEither #-} -foldEither :: Monad m => - Fold m a b -> StreamK m a -> m (Either (Fold m a b) (b, StreamK m a)) -foldEither (FL.Fold step begin done) m = do - res <- begin - case res of - FL.Partial fs -> go fs m - FL.Done fb -> return $ Right (fb, m) - - where - - go !acc m1 = - let stop = return $ Left (Fold step (return $ FL.Partial acc) done) - single a = - step acc a - >>= \case - FL.Partial s -> - return $ Left (Fold step (return $ FL.Partial s) done) - FL.Done b1 -> return $ Right (b1, nil) - yieldk a r = - step acc a - >>= \case - FL.Partial s -> go s r - FL.Done b1 -> return $ Right (b1, r) - in foldStream defState yieldk single stop m1 - --- | Like 'fold' but also returns the remaining stream. The resulting stream --- would be 'StreamK.nil' if the stream finished before the fold. --- -{-# INLINE foldBreak #-} -foldBreak :: Monad m => Fold m a b -> StreamK m a -> m (b, StreamK m a) -foldBreak fld strm = do - r <- foldEither fld strm - case r of - Right res -> return res - Left (Fold _ initial extract) -> do - res <- initial - case res of - FL.Done _ -> error "foldBreak: unreachable state" - FL.Partial s -> do - b <- extract s - return (b, nil) - --- XXX Array folds can be implemented using this. --- foldContainers? Specialized to foldArrays. - --- | Generate streams from individual elements of a stream and fold the --- concatenation of those streams using the supplied fold. Return the result of --- the fold and residual stream. --- --- For example, this can be used to efficiently fold an Array Word8 stream --- using Word8 folds. --- --- /Internal/ -{-# INLINE foldConcat #-} -foldConcat :: Monad m => - Producer m a b -> Fold m b c -> StreamK m a -> m (c, StreamK m a) -foldConcat - (Producer pstep pinject pextract) - (Fold fstep begin done) - stream = do - - res <- begin - case res of - FL.Partial fs -> go fs stream - FL.Done fb -> return (fb, stream) - - where - - go !acc m1 = do - let stop = do - r <- done acc - return (r, nil) - single a = do - st <- pinject a - res <- go1 SPEC acc st - case res of - Left fs -> do - r <- done fs - return (r, nil) - Right (b, s) -> do - x <- pextract s - return (b, fromPure x) - yieldk a r = do - st <- pinject a - res <- go1 SPEC acc st - case res of - Left fs -> go fs r - Right (b, s) -> do - x <- pextract s - return (b, x `cons` r) - in foldStream defState yieldk single stop m1 - - {-# INLINE go1 #-} - go1 !_ !fs st = do - r <- pstep st - case r of - Stream.Yield x s -> do - res <- fstep fs x - case res of - FL.Done b -> return $ Right (b, s) - FL.Partial fs1 -> go1 SPEC fs1 s - Stream.Skip s -> go1 SPEC fs s - Stream.Stop -> return $ Left fs - --- | Like 'foldl'' but with a monadic step function. -{-# INLINE foldlM' #-} -foldlM' :: Monad m => (b -> a -> m b) -> m b -> StreamK m a -> m b -foldlM' step begin = foldlMx' step begin return - ------------------------------------------------------------------------------- --- Specialized folds ------------------------------------------------------------------------------- - -{-# INLINE head #-} -head :: Monad m => StreamK m a -> m (Maybe a) --- head = foldrM (\x _ -> return $ Just x) (return Nothing) -head m = - let stop = return Nothing - single a = return (Just a) - yieldk a _ = return (Just a) - in foldStream defState yieldk single stop m - -{-# INLINE elem #-} -elem :: (Monad m, Eq a) => a -> StreamK m a -> m Bool -elem e = go - where - go m1 = - let stop = return False - single a = return (a == e) - yieldk a r = if a == e then return True else go r - in foldStream defState yieldk single stop m1 - -{-# INLINE notElem #-} -notElem :: (Monad m, Eq a) => a -> StreamK m a -> m Bool -notElem e = go - where - go m1 = - let stop = return True - single a = return (a /= e) - yieldk a r = if a == e then return False else go r - in foldStream defState yieldk single stop m1 - -{-# INLINABLE all #-} -all :: Monad m => (a -> Bool) -> StreamK m a -> m Bool -all p = go - where - go m1 = - let single a | p a = return True - | otherwise = return False - yieldk a r | p a = go r - | otherwise = return False - in foldStream defState yieldk single (return True) m1 - -{-# INLINABLE any #-} -any :: Monad m => (a -> Bool) -> StreamK m a -> m Bool -any p = go - where - go m1 = - let single a | p a = return True - | otherwise = return False - yieldk a r | p a = return True - | otherwise = go r - in foldStream defState yieldk single (return False) m1 - --- | Extract the last element of the stream, if any. -{-# INLINE last #-} -last :: Monad m => StreamK m a -> m (Maybe a) -last = foldlx' (\_ y -> Just y) Nothing id - -{-# INLINE minimum #-} -minimum :: (Monad m, Ord a) => StreamK m a -> m (Maybe a) -minimum = go Nothing - where - go Nothing m1 = - let stop = return Nothing - single a = return (Just a) - yieldk a r = go (Just a) r - in foldStream defState yieldk single stop m1 - - go (Just res) m1 = - let stop = return (Just res) - single a = - if res <= a - then return (Just res) - else return (Just a) - yieldk a r = - if res <= a - then go (Just res) r - else go (Just a) r - in foldStream defState yieldk single stop m1 - -{-# INLINE minimumBy #-} -minimumBy - :: (Monad m) - => (a -> a -> Ordering) -> StreamK m a -> m (Maybe a) -minimumBy cmp = go Nothing - where - go Nothing m1 = - let stop = return Nothing - single a = return (Just a) - yieldk a r = go (Just a) r - in foldStream defState yieldk single stop m1 - - go (Just res) m1 = - let stop = return (Just res) - single a = case cmp res a of - GT -> return (Just a) - _ -> return (Just res) - yieldk a r = case cmp res a of - GT -> go (Just a) r - _ -> go (Just res) r - in foldStream defState yieldk single stop m1 - -{-# INLINE maximum #-} -maximum :: (Monad m, Ord a) => StreamK m a -> m (Maybe a) -maximum = go Nothing - where - go Nothing m1 = - let stop = return Nothing - single a = return (Just a) - yieldk a r = go (Just a) r - in foldStream defState yieldk single stop m1 - - go (Just res) m1 = - let stop = return (Just res) - single a = - if res <= a - then return (Just a) - else return (Just res) - yieldk a r = - if res <= a - then go (Just a) r - else go (Just res) r - in foldStream defState yieldk single stop m1 - -{-# INLINE maximumBy #-} -maximumBy :: Monad m => (a -> a -> Ordering) -> StreamK m a -> m (Maybe a) -maximumBy cmp = go Nothing - where - go Nothing m1 = - let stop = return Nothing - single a = return (Just a) - yieldk a r = go (Just a) r - in foldStream defState yieldk single stop m1 - - go (Just res) m1 = - let stop = return (Just res) - single a = case cmp res a of - GT -> return (Just res) - _ -> return (Just a) - yieldk a r = case cmp res a of - GT -> go (Just res) r - _ -> go (Just a) r - in foldStream defState yieldk single stop m1 - -{-# INLINE (!!) #-} -(!!) :: Monad m => StreamK m a -> Int -> m (Maybe a) -m !! i = go i m - where - go n m1 = - let single a | n == 0 = return $ Just a - | otherwise = return Nothing - yieldk a x | n < 0 = return Nothing - | n == 0 = return $ Just a - | otherwise = go (n - 1) x - in foldStream defState yieldk single (return Nothing) m1 - -{-# INLINE lookup #-} -lookup :: (Monad m, Eq a) => a -> StreamK m (a, b) -> m (Maybe b) -lookup e = go - where - go m1 = - let single (a, b) | a == e = return $ Just b - | otherwise = return Nothing - yieldk (a, b) x | a == e = return $ Just b - | otherwise = go x - in foldStream defState yieldk single (return Nothing) m1 - -{-# INLINE findM #-} -findM :: Monad m => (a -> m Bool) -> StreamK m a -> m (Maybe a) -findM p = go - where - go m1 = - let single a = do - b <- p a - if b then return $ Just a else return Nothing - yieldk a x = do - b <- p a - if b then return $ Just a else go x - in foldStream defState yieldk single (return Nothing) m1 - -{-# INLINE find #-} -find :: Monad m => (a -> Bool) -> StreamK m a -> m (Maybe a) -find p = findM (return . p) - -{-# INLINE findIndices #-} -findIndices :: (a -> Bool) -> StreamK m a -> StreamK m Int -findIndices p = go 0 - where - go offset m1 = mkStream $ \st yld sng stp -> - let single a | p a = sng offset - | otherwise = stp - yieldk a x | p a = yld offset $ go (offset + 1) x - | otherwise = foldStream (adaptState st) yld sng stp $ - go (offset + 1) x - in foldStream (adaptState st) yieldk single stp m1 - ------------------------------------------------------------------------------- --- Map and Fold ------------------------------------------------------------------------------- - --- | Apply a monadic action to each element of the stream and discard the --- output of the action. -{-# INLINE mapM_ #-} -mapM_ :: Monad m => (a -> m b) -> StreamK m a -> m () -mapM_ f = go - where - go m1 = - let stop = return () - single a = void (f a) - yieldk a r = f a >> go r - in foldStream defState yieldk single stop m1 - -{-# INLINE mapM #-} -mapM :: Monad m => (a -> m b) -> StreamK m a -> StreamK m b -mapM = mapMWith consM - ------------------------------------------------------------------------------- --- Converting folds ------------------------------------------------------------------------------- - -{-# INLINABLE toList #-} -toList :: Monad m => StreamK m a -> m [a] -toList = foldr (:) [] - --- Based on suggestions by David Feuer and Pranay Sashank -{-# INLINE hoist #-} -hoist :: (Monad m, Monad n) - => (forall x. m x -> n x) -> StreamK m a -> StreamK n a -hoist f str = - mkStream $ \st yld sng stp -> - let single = return . sng - yieldk a s = return $ yld a (hoist f s) - stop = return stp - state = adaptState st - in join . f $ foldStreamShared state yieldk single stop str - -------------------------------------------------------------------------------- --- Transformation by folding (Scans) -------------------------------------------------------------------------------- - -{-# INLINE scanlx' #-} -scanlx' :: (x -> a -> x) -> x -> (x -> b) -> StreamK m a -> StreamK m b -scanlx' step begin done m = - cons (done begin) $ go m begin - where - go m1 !acc = mkStream $ \st yld sng stp -> - let single a = sng (done $ step acc a) - yieldk a r = - let s = step acc a - in yld (done s) (go r s) - in foldStream (adaptState st) yieldk single stp m1 - -{-# INLINE scanl' #-} -scanl' :: (b -> a -> b) -> b -> StreamK m a -> StreamK m b -scanl' step begin = scanlx' step begin id - -------------------------------------------------------------------------------- --- Filtering -------------------------------------------------------------------------------- - -{-# INLINE filter #-} -filter :: (a -> Bool) -> StreamK m a -> StreamK m a -filter p = go - where - go m1 = mkStream $ \st yld sng stp -> - let single a | p a = sng a - | otherwise = stp - yieldk a r | p a = yld a (go r) - | otherwise = foldStream st yieldk single stp r - in foldStream st yieldk single stp m1 - -{-# INLINE take #-} -take :: Int -> StreamK m a -> StreamK m a -take = go - where - go n1 m1 = mkStream $ \st yld sng stp -> - let yieldk a r = yld a (go (n1 - 1) r) - in if n1 <= 0 - then stp - else foldStream st yieldk sng stp m1 - -{-# INLINE takeWhile #-} -takeWhile :: (a -> Bool) -> StreamK m a -> StreamK m a -takeWhile p = go - where - go m1 = mkStream $ \st yld sng stp -> - let single a | p a = sng a - | otherwise = stp - yieldk a r | p a = yld a (go r) - | otherwise = stp - in foldStream st yieldk single stp m1 - -{-# INLINE drop #-} -drop :: Int -> StreamK m a -> StreamK m a -drop n m = unShare (go n m) - where - go n1 m1 = mkStream $ \st yld sng stp -> - let single _ = stp - yieldk _ r = foldStreamShared st yld sng stp $ go (n1 - 1) r - -- Somehow "<=" check performs better than a ">" - in if n1 <= 0 - then foldStreamShared st yld sng stp m1 - else foldStreamShared st yieldk single stp m1 - -{-# INLINE dropWhile #-} -dropWhile :: (a -> Bool) -> StreamK m a -> StreamK m a -dropWhile p = go - where - go m1 = mkStream $ \st yld sng stp -> - let single a | p a = stp - | otherwise = sng a - yieldk a r | p a = foldStream st yieldk single stp r - | otherwise = yld a r - in foldStream st yieldk single stp m1 - -------------------------------------------------------------------------------- --- Mapping -------------------------------------------------------------------------------- - --- Be careful when modifying this, this uses a consM (|:) deliberately to allow --- other stream types to overload it. -{-# INLINE sequence #-} -sequence :: Monad m => StreamK m (m a) -> StreamK m a -sequence = go - where - go m1 = mkStream $ \st yld sng stp -> - let single ma = ma >>= sng - yieldk ma r = foldStreamShared st yld sng stp $ ma `consM` go r - in foldStream (adaptState st) yieldk single stp m1 - -------------------------------------------------------------------------------- --- Inserting -------------------------------------------------------------------------------- - -{-# INLINE intersperseM #-} -intersperseM :: Monad m => m a -> StreamK m a -> StreamK m a -intersperseM a = prependingStart - where - prependingStart m1 = mkStream $ \st yld sng stp -> - let yieldk i x = - foldStreamShared st yld sng stp $ return i `consM` go x - in foldStream st yieldk sng stp m1 - go m2 = mkStream $ \st yld sng stp -> - let single i = foldStreamShared st yld sng stp $ a `consM` fromPure i - yieldk i x = - foldStreamShared - st yld sng stp $ a `consM` return i `consM` go x - in foldStream st yieldk single stp m2 - -{-# INLINE intersperse #-} -intersperse :: Monad m => a -> StreamK m a -> StreamK m a -intersperse a = intersperseM (return a) - -{-# INLINE insertBy #-} -insertBy :: (a -> a -> Ordering) -> a -> StreamK m a -> StreamK m a -insertBy cmp x = go - where - go m1 = mkStream $ \st yld _ _ -> - let single a = case cmp x a of - GT -> yld a (fromPure x) - _ -> yld x (fromPure a) - stop = yld x nil - yieldk a r = case cmp x a of - GT -> yld a (go r) - _ -> yld x (a `cons` r) - in foldStream st yieldk single stop m1 - ------------------------------------------------------------------------------- --- Deleting ------------------------------------------------------------------------------- - -{-# INLINE deleteBy #-} -deleteBy :: (a -> a -> Bool) -> a -> StreamK m a -> StreamK m a -deleteBy eq x = go - where - go m1 = mkStream $ \st yld sng stp -> - let single a = if eq x a then stp else sng a - yieldk a r = if eq x a - then foldStream st yld sng stp r - else yld a (go r) - in foldStream st yieldk single stp m1 - -------------------------------------------------------------------------------- --- Map and Filter -------------------------------------------------------------------------------- - -{-# INLINE mapMaybe #-} -mapMaybe :: (a -> Maybe b) -> StreamK m a -> StreamK m b -mapMaybe f = go - where - go m1 = mkStream $ \st yld sng stp -> - let single a = maybe stp sng (f a) - yieldk a r = case f a of - Just b -> yld b $ go r - Nothing -> foldStream (adaptState st) yieldk single stp r - in foldStream (adaptState st) yieldk single stp m1 - ------------------------------------------------------------------------------- --- Serial Zipping ------------------------------------------------------------------------------- - --- | Zip two streams serially using a pure zipping function. --- -{-# INLINE zipWith #-} -zipWith :: Monad m => (a -> b -> c) -> StreamK m a -> StreamK m b -> StreamK m c -zipWith f = zipWithM (\a b -> return (f a b)) - --- | Zip two streams serially using a monadic zipping function. --- -{-# INLINE zipWithM #-} -zipWithM :: Monad m => - (a -> b -> m c) -> StreamK m a -> StreamK m b -> StreamK m c -zipWithM f = go - - where - - go mx my = mkStream $ \st yld sng stp -> do - let merge a ra = - let single2 b = f a b >>= sng - yield2 b rb = f a b >>= \x -> yld x (go ra rb) - in foldStream (adaptState st) yield2 single2 stp my - let single1 a = merge a nil - yield1 = merge - foldStream (adaptState st) yield1 single1 stp mx - ------------------------------------------------------------------------------- --- Merging ------------------------------------------------------------------------------- - -{-# INLINE mergeByM #-} -mergeByM :: Monad m => - (a -> a -> m Ordering) -> StreamK m a -> StreamK m a -> StreamK m a -mergeByM cmp = go - - where - - go mx my = mkStream $ \st yld sng stp -> do - let stop = foldStream st yld sng stp my - single x = foldStream st yld sng stp (goX0 x my) - yield x rx = foldStream st yld sng stp (goX x rx my) - foldStream st yield single stop mx - - goX0 x my = mkStream $ \st yld sng _ -> do - let stop = sng x - single y = do - r <- cmp x y - case r of - GT -> yld y (fromPure x) - _ -> yld x (fromPure y) - yield y ry = do - r <- cmp x y - case r of - GT -> yld y (goX0 x ry) - _ -> yld x (y `cons` ry) - in foldStream st yield single stop my - - goX x mx my = mkStream $ \st yld _ _ -> do - let stop = yld x mx - single y = do - r <- cmp x y - case r of - GT -> yld y (x `cons` mx) - _ -> yld x (goY0 mx y) - yield y ry = do - r <- cmp x y - case r of - GT -> yld y (goX x mx ry) - _ -> yld x (goY mx y ry) - in foldStream st yield single stop my - - goY0 mx y = mkStream $ \st yld sng _ -> do - let stop = sng y - single x = do - r <- cmp x y - case r of - GT -> yld y (fromPure x) - _ -> yld x (fromPure y) - yield x rx = do - r <- cmp x y - case r of - GT -> yld y (x `cons` rx) - _ -> yld x (goY0 rx y) - in foldStream st yield single stop mx - - goY mx y my = mkStream $ \st yld _ _ -> do - let stop = yld y my - single x = do - r <- cmp x y - case r of - GT -> yld y (goX0 x my) - _ -> yld x (y `cons` my) - yield x rx = do - r <- cmp x y - case r of - GT -> yld y (goX x rx my) - _ -> yld x (goY rx y my) - in foldStream st yield single stop mx - -{-# INLINE mergeBy #-} -mergeBy :: (a -> a -> Ordering) -> StreamK m a -> StreamK m a -> StreamK m a --- XXX GHC: This has slightly worse performance than replacing "r <- cmp x y" --- with "let r = cmp x y" in the monadic version. The definition below is --- exactly the same as mergeByM except this change. --- mergeBy cmp = mergeByM (\a b -> return $ cmp a b) -mergeBy cmp = go - - where - - go mx my = mkStream $ \st yld sng stp -> do - let stop = foldStream st yld sng stp my - single x = foldStream st yld sng stp (goX0 x my) - yield x rx = foldStream st yld sng stp (goX x rx my) - foldStream st yield single stop mx - - goX0 x my = mkStream $ \st yld sng _ -> do - let stop = sng x - single y = do - case cmp x y of - GT -> yld y (fromPure x) - _ -> yld x (fromPure y) - yield y ry = do - case cmp x y of - GT -> yld y (goX0 x ry) - _ -> yld x (y `cons` ry) - in foldStream st yield single stop my - - goX x mx my = mkStream $ \st yld _ _ -> do - let stop = yld x mx - single y = do - case cmp x y of - GT -> yld y (x `cons` mx) - _ -> yld x (goY0 mx y) - yield y ry = do - case cmp x y of - GT -> yld y (goX x mx ry) - _ -> yld x (goY mx y ry) - in foldStream st yield single stop my - - goY0 mx y = mkStream $ \st yld sng _ -> do - let stop = sng y - single x = do - case cmp x y of - GT -> yld y (fromPure x) - _ -> yld x (fromPure y) - yield x rx = do - case cmp x y of - GT -> yld y (x `cons` rx) - _ -> yld x (goY0 rx y) - in foldStream st yield single stop mx - - goY mx y my = mkStream $ \st yld _ _ -> do - let stop = yld y my - single x = do - case cmp x y of - GT -> yld y (goX0 x my) - _ -> yld x (y `cons` my) - yield x rx = do - case cmp x y of - GT -> yld y (goX x rx my) - _ -> yld x (goY rx y my) - in foldStream st yield single stop mx - ------------------------------------------------------------------------------- --- Transformation comprehensions ------------------------------------------------------------------------------- - -{-# INLINE the #-} -the :: (Eq a, Monad m) => StreamK m a -> m (Maybe a) -the m = do - r <- uncons m - case r of - Nothing -> return Nothing - Just (h, t) -> go h t - where - go h m1 = - let single a | h == a = return $ Just h - | otherwise = return Nothing - yieldk a r | h == a = go h r - | otherwise = return Nothing - in foldStream defState yieldk single (return $ Just h) m1 - ------------------------------------------------------------------------------- --- Alternative & MonadPlus ------------------------------------------------------------------------------- - -_alt :: StreamK m a -> StreamK m a -> StreamK m a -_alt m1 m2 = mkStream $ \st yld sng stp -> - let stop = foldStream st yld sng stp m2 - in foldStream st yld sng stop m1 - ------------------------------------------------------------------------------- --- MonadError ------------------------------------------------------------------------------- - -{- --- XXX handle and test cross thread state transfer -withCatchError - :: MonadError e m - => StreamK m a -> (e -> StreamK m a) -> StreamK m a -withCatchError m h = - mkStream $ \_ stp sng yld -> - let run x = unStream x Nothing stp sng yieldk - handle r = r `catchError` \e -> run $ h e - yieldk a r = yld a (withCatchError r h) - in handle $ run m --} - -------------------------------------------------------------------------------- --- Parsing -------------------------------------------------------------------------------- - --- Inlined definition. -{-# INLINE splitAt #-} -splitAt :: Int -> [a] -> ([a],[a]) -splitAt n ls - | n <= 0 = ([], ls) - | otherwise = splitAt' n ls - where - splitAt' :: Int -> [a] -> ([a], [a]) - splitAt' _ [] = ([], []) - splitAt' 1 (x:xs) = ([x], xs) - splitAt' m (x:xs) = (x:xs', xs'') - where - (xs', xs'') = splitAt' (m - 1) xs - --- | Run a 'Parser' over a stream and return rest of the Stream. -{-# INLINE_NORMAL parseDBreak #-} -parseDBreak - :: Monad m - => PR.Parser a m b - -> StreamK m a - -> m (Either ParseError b, StreamK m a) -parseDBreak (PR.Parser pstep initial extract) stream = do - res <- initial - case res of - PR.IPartial s -> goStream stream [] s - PR.IDone b -> return (Right b, stream) - PR.IError err -> return (Left (ParseError err), stream) - - where - - -- "buf" contains last few items in the stream that we may have to - -- backtrack to. - -- - -- XXX currently we are using a dumb list based approach for backtracking - -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. - -- That will allow us more efficient random back and forth movement. - goStream st buf !pst = - let stop = do - r <- extract pst - case r of - PR.Error err -> return (Left (ParseError err), nil) - PR.Done n b -> do - assertM(n <= length buf) - let src0 = Prelude.take n buf - src = Prelude.reverse src0 - return (Right b, fromList src) - PR.Partial _ _ -> error "Bug: parseBreak: Partial in extract" - PR.Continue 0 s -> goStream nil buf s - PR.Continue n s -> do - assertM(n <= length buf) - let (src0, buf1) = splitAt n buf - src = Prelude.reverse src0 - goBuf nil buf1 src s - single x = yieldk x nil - yieldk x r = do - res <- pstep pst x - case res of - PR.Partial 0 s -> goStream r [] s - PR.Partial n s -> do - assertM(n <= length (x:buf)) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 - goBuf r [] src s - PR.Continue 0 s -> goStream r (x:buf) s - PR.Continue n s -> do - assertM(n <= length (x:buf)) - let (src0, buf1) = splitAt n (x:buf) - src = Prelude.reverse src0 - goBuf r buf1 src s - PR.Done 0 b -> return (Right b, r) - PR.Done n b -> do - assertM(n <= length (x:buf)) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 - return (Right b, append (fromList src) r) - PR.Error err -> return (Left (ParseError err), r) - in foldStream defState yieldk single stop st - - goBuf st buf [] !pst = goStream st buf pst - goBuf st buf (x:xs) !pst = do - pRes <- pstep pst x - case pRes of - PR.Partial 0 s -> goBuf st [] xs s - PR.Partial n s -> do - assert (n <= length (x:buf)) (return ()) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 ++ xs - goBuf st [] src s - PR.Continue 0 s -> goBuf st (x:buf) xs s - PR.Continue n s -> do - assert (n <= length (x:buf)) (return ()) - let (src0, buf1) = splitAt n (x:buf) - src = Prelude.reverse src0 ++ xs - goBuf st buf1 src s - PR.Done n b -> do - assert (n <= length (x:buf)) (return ()) - let src0 = Prelude.take n (x:buf) - src = Prelude.reverse src0 - return (Right b, append (fromList src) st) - PR.Error err -> return (Left (ParseError err), nil) - --- Using ParserD or ParserK on StreamK may not make much difference. We should --- perhaps use only chunked parsing on StreamK. We can always convert a stream --- to chunks before parsing. Or just have a ParserK element parser for StreamK --- and convert ParserD to ParserK for element parsing using StreamK. -{-# INLINE parseD #-} -parseD :: Monad m => - Parser.Parser a m b -> StreamK m a -> m (Either ParseError b) -parseD f = fmap fst . parseDBreak f - -------------------------------------------------------------------------------- --- Chunked parsing using ParserK -------------------------------------------------------------------------------- - --- The backracking buffer consists of arrays in the most-recent-first order. We --- want to take a total of n array elements from this buffer. Note: when we --- have to take an array partially, we must take the last part of the array. -{-# INLINE backTrack #-} -backTrack :: forall m a. Unbox a => - Int - -> [Array a] - -> StreamK m (Array a) - -> (StreamK m (Array a), [Array a]) -backTrack = go - - where - - go _ [] stream = (stream, []) - go n xs stream | n <= 0 = (stream, xs) - go n (x:xs) stream = - let len = Array.length x - in if n > len - then go (n - len) xs (cons x stream) - else if n == len - then (cons x stream, xs) - else let !(Array contents start end) = x - !start1 = end - (n * SIZE_OF(a)) - arr1 = Array contents start1 end - arr2 = Array contents start start1 - in (cons arr1 stream, arr2:xs) - --- | A continuation to extract the result when a CPS parser is done. -{-# INLINE parserDone #-} -parserDone :: Applicative m => - ParserK.ParseResult b -> Int -> ParserK.Input a -> m (ParserK.Step a m b) -parserDone (ParserK.Success n b) _ _ = pure $ ParserK.Done n b -parserDone (ParserK.Failure n e) _ _ = pure $ ParserK.Error n e - --- XXX parseDBreakChunks may be faster than converting parserD to parserK and --- using parseBreakChunks. We can also use parseBreak as an alternative to the --- monad instance of ParserD. - --- | Run a 'ParserK' over a chunked 'StreamK' and return the rest of the Stream. -{-# INLINE_NORMAL parseBreakChunks #-} -parseBreakChunks - :: (Monad m, Unbox a) - => ParserK a m b - -> StreamK m (Array a) - -> m (Either ParseError b, StreamK m (Array a)) -parseBreakChunks parser input = do - let parserk = ParserK.runParser parser parserDone 0 0 - in go [] parserk input - - where - - {-# INLINE goStop #-} - goStop backBuf parserk = do - pRes <- parserk ParserK.None - case pRes of - -- If we stop in an alternative, it will try calling the next - -- parser, the next parser may call initial returning Partial and - -- then immediately we have to call extract on it. - ParserK.Partial 0 cont1 -> - go [] cont1 nil - ParserK.Partial n cont1 -> do - let n1 = negate n - assertM(n1 >= 0 && n1 <= sum (Prelude.map Array.length backBuf)) - let (s1, backBuf1) = backTrack n1 backBuf nil - in go backBuf1 cont1 s1 - ParserK.Continue 0 cont1 -> - go backBuf cont1 nil - ParserK.Continue n cont1 -> do - let n1 = negate n - assertM(n1 >= 0 && n1 <= sum (Prelude.map Array.length backBuf)) - let (s1, backBuf1) = backTrack n1 backBuf nil - in go backBuf1 cont1 s1 - ParserK.Done 0 b -> - return (Right b, nil) - ParserK.Done n b -> do - let n1 = negate n - assertM(n1 >= 0 && n1 <= sum (Prelude.map Array.length backBuf)) - let (s1, _) = backTrack n1 backBuf nil - in return (Right b, s1) - ParserK.Error _ err -> return (Left (ParseError err), nil) - - seekErr n len = - error $ "parseBreak: Partial: forward seek not implemented n = " - ++ show n ++ " len = " ++ show len - - yieldk backBuf parserk arr stream = do - pRes <- parserk (ParserK.Chunk arr) - let len = Array.length arr - case pRes of - ParserK.Partial n cont1 -> - case compare n len of - EQ -> go [] cont1 stream - LT -> do - if n >= 0 - then yieldk [] cont1 arr stream - else do - let n1 = negate n - bufLen = sum (Prelude.map Array.length backBuf) - s = cons arr stream - assertM(n1 >= 0 && n1 <= bufLen) - let (s1, _) = backTrack n1 backBuf s - go [] cont1 s1 - GT -> seekErr n len - ParserK.Continue n cont1 -> - case compare n len of - EQ -> go (arr:backBuf) cont1 stream - LT -> do - if n >= 0 - then yieldk backBuf cont1 arr stream - else do - let n1 = negate n - bufLen = sum (Prelude.map Array.length backBuf) - s = cons arr stream - assertM(n1 >= 0 && n1 <= bufLen) - let (s1, backBuf1) = backTrack n1 backBuf s - go backBuf1 cont1 s1 - GT -> seekErr n len - ParserK.Done n b -> do - let n1 = len - n - assertM(n1 <= sum (Prelude.map Array.length (arr:backBuf))) - let (s1, _) = backTrack n1 (arr:backBuf) stream - in return (Right b, s1) - ParserK.Error _ err -> return (Left (ParseError err), nil) - - go backBuf parserk stream = do - let stop = goStop backBuf parserk - single a = yieldk backBuf parserk a nil - in foldStream - defState (yieldk backBuf parserk) single stop stream - -{-# INLINE parseChunks #-} -parseChunks :: (Monad m, Unbox a) => - ParserK a m b -> StreamK m (Array a) -> m (Either ParseError b) -parseChunks f = fmap fst . parseBreakChunks f - -------------------------------------------------------------------------------- --- Sorting -------------------------------------------------------------------------------- - --- | Sort the input stream using a supplied comparison function. --- --- Sorting can be achieved by simply: --- --- >>> sortBy cmp = StreamK.mergeMapWith (StreamK.mergeBy cmp) StreamK.fromPure --- --- However, this combinator uses a parser to first split the input stream into --- down and up sorted segments and then merges them to optimize sorting when --- pre-sorted sequences exist in the input stream. --- --- /O(n) space/ --- -{-# INLINE sortBy #-} -sortBy :: Monad m => (a -> a -> Ordering) -> StreamK m a -> StreamK m a --- sortBy f = Stream.concatPairsWith (Stream.mergeBy f) Stream.fromPure -sortBy cmp = - let p = - Parser.groupByRollingEither - (\x -> (< GT) . cmp x) - FL.toStreamKRev - FL.toStreamK - in mergeMapWith (mergeBy cmp) id - . Stream.toStreamK - . Stream.catRights -- its a non-failing backtracking parser - . Stream.parseMany (fmap (either id id) p) - . Stream.fromStreamK diff --git a/src/Streamly/Internal/Data/Stream/StreamK/Alt.hs b/src/Streamly/Internal/Data/Stream/StreamK/Alt.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamK/Alt.hs +++ /dev/null @@ -1,244 +0,0 @@ --- | --- Module : Streamly.StreamDK.Type --- Copyright : (c) 2019 Composewell Technologies --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- A CPS style stream using a constructor based representation instead of a --- function based representation. --- --- Streamly internally uses two fundamental stream representations, (1) streams --- with an open or arbitrary control flow (we call it StreamK), (2) streams --- with a structured or closed loop control flow (we call it StreamD). The --- higher level stream types can use any of these representations under the --- hood and can interconvert between the two. --- --- StreamD: --- --- StreamD is a non-recursive data type in which the state of the stream and --- the step function are separate. When the step function is called, a stream --- element and the new stream state is yielded. The generated element and the --- state are passed to the next consumer in the loop. The state is threaded --- around in the loop until control returns back to the original step function --- to run the next step. This creates a structured closed loop representation --- (like "for" loops in C) with state of each step being hidden/abstracted or --- existential within that step. This creates a loop representation identical --- to the "for" or "while" loop constructs in imperative languages, the states --- of the steps combined together constitute the state of the loop iteration. --- --- Internally most combinators use a closed loop representation because it --- provides very high efficiency due to stream fusion. The performance of this --- representation is competitive to the C language implementations. --- --- Pros and Cons of StreamD: --- --- 1) stream-fusion: This representation can be optimized very efficiently by --- the compiler because the state is explicitly separated from step functions, --- represented using pure data constructors and visible to the compiler, the --- stream steps can be fused using case-of-case transformations and the state --- can be specialized using spec-constructor optimization, yielding a C like --- tight loop/state machine with no constructors, the state is used unboxed and --- therefore no unnecessary allocation. --- --- 2) Because of a closed representation consing too many elements in this type --- of stream does not scale, it will have quadratic performance slowdown. Each --- cons creates a layer that needs to return the control back to the caller. --- Another implementation of cons is possible but that will have to box/unbox --- the state and will not fuse. So effectively cons breaks fusion. --- --- 3) unconsing an item from the stream breaks fusion, we have to "pause" the --- loop, rebox and save the state. --- --- 3) Exception handling is easy to implement in this model because control --- flow is structured in the loop and cannot be arbitrary. Therefore, --- implementing "bracket" is natural. --- --- 4) Round-robin scheduling for co-operative multitasking is easy to implement. --- --- 5) It fuses well with the direct style Fold implementation. --- --- StreamK/StreamDK: --- --- StreamDK i.e. the stream defined in this module, like StreamK, is a --- recursive data type which has no explicit state defined using constructors, --- each step yields an element and a computation representing the rest of the --- stream. Stream state is part of the function representing the rest of the --- stream. This creates an open computation representation, or essentially a --- continuation passing style computation. After the stream step is executed, --- the caller is free to consume the produced element and then send the control --- wherever it wants, there is no restriction on the control to return back --- somewhere, the control is free to go anywhere. The caller may decide not to --- consume the rest of the stream. This representation is more like a "goto" --- based implementation in imperative languages. --- --- Pros and Cons of StreamK: --- --- 1) The way StreamD can be optimized using stream-fusion, this type can be --- optimized using foldr/build fusion. However, foldr/build has not yet been --- fully implemented for StreamK/StreamDK. --- --- 2) Using cons is natural in this representation, unlike in StreamD it does --- not have a quadratic slowdown. Currently, we in fact wrap StreamD in StreamK --- to support a better cons operation. --- --- 3) Similarly, uncons is natural in this representation. --- --- 4) Exception handling is not easy to implement because of the "goto" nature --- of CPS. --- --- 5) Composable folds are not implemented/proven, however, intuition says that --- a push style CPS representation should be able to be used along with StreamK --- to efficiently implement composable folds. - -module Streamly.Internal.Data.Stream.StreamK.Alt - ( - -- * Stream Type - - Stream - , Step (..) - - -- * Construction - , nil - , cons - , consM - , unfoldr - , unfoldrM - , replicateM - - -- * Folding - , uncons - , foldrS - - -- * Specific Folds - , drain - ) -where - -#include "inline.hs" - --- XXX Use Cons and Nil instead of Yield and Stop? -data Step m a = Yield a (Stream m a) | Stop - -newtype Stream m a = Stream (m (Step m a)) - -------------------------------------------------------------------------------- --- Construction -------------------------------------------------------------------------------- - -nil :: Monad m => Stream m a -nil = Stream $ return Stop - -{-# INLINE_NORMAL cons #-} -cons :: Monad m => a -> Stream m a -> Stream m a -cons x xs = Stream $ return $ Yield x xs - -consM :: Monad m => m a -> Stream m a -> Stream m a -consM eff xs = Stream $ eff >>= \x -> return $ Yield x xs - -unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a -unfoldrM next state = Stream (step' state) - where - step' st = do - r <- next st - return $ case r of - Just (x, s) -> Yield x (Stream (step' s)) - Nothing -> Stop -{- -unfoldrM next s0 = buildM $ \yld stp -> - let go s = do - r <- next s - case r of - Just (a, b) -> yld a (go b) - Nothing -> stp - in go s0 --} - -{-# INLINE unfoldr #-} -unfoldr :: Monad m => (b -> Maybe (a, b)) -> b -> Stream m a -unfoldr next s0 = build $ \yld stp -> - let go s = - case next s of - Just (a, b) -> yld a (go b) - Nothing -> stp - in go s0 - -replicateM :: Monad m => Int -> a -> Stream m a -replicateM n x = Stream (step n) - where - step i = return $ - if i <= 0 - then Stop - else Yield x (Stream (step (i - 1))) - -------------------------------------------------------------------------------- --- Folding -------------------------------------------------------------------------------- - -uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a)) -uncons (Stream step) = do - r <- step - return $ case r of - Yield x xs -> Just (x, xs) - Stop -> Nothing - --- | Lazy right associative fold to a stream. -{-# INLINE_NORMAL foldrS #-} -foldrS :: Monad m - => (a -> Stream m b -> Stream m b) - -> Stream m b - -> Stream m a - -> Stream m b -foldrS f streamb = go - where - go (Stream stepa) = Stream $ do - r <- stepa - case r of - Yield x xs -> let Stream step = f x (go xs) in step - Stop -> let Stream step = streamb in step - -{-# INLINE_LATE foldrM #-} -foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b -foldrM fstep acc = go - where - go (Stream step) = do - r <- step - case r of - Yield x xs -> fstep x (go xs) - Stop -> acc - -{-# INLINE_NORMAL build #-} -build :: Monad m - => forall a. (forall b. (a -> b -> b) -> b -> b) -> Stream m a -build g = g cons nil - -{-# RULES -"foldrM/build" forall k z (g :: forall b. (a -> b -> b) -> b -> b). - foldrM k z (build g) = g k z #-} - -{- --- To fuse foldrM with unfoldrM we need the type m1 to be polymorphic such that --- it is either Monad m or Stream m. So that we can use cons/nil as well as --- monadic construction function as its arguments. --- -{-# INLINE_NORMAL buildM #-} -buildM :: Monad m - => forall a. (forall b. (a -> m1 b -> m1 b) -> m1 b -> m1 b) -> Stream m a -buildM g = g cons nil --} - -------------------------------------------------------------------------------- --- Specific folds -------------------------------------------------------------------------------- - -{-# INLINE drain #-} -drain :: Monad m => Stream m a -> m () -drain = foldrM (\_ xs -> xs) (return ()) -{- -drain (Stream step) = do - r <- step - case r of - Yield _ next -> drain next - Stop -> return () - -} diff --git a/src/Streamly/Internal/Data/Stream/StreamK/Transformer.hs b/src/Streamly/Internal/Data/Stream/StreamK/Transformer.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamK/Transformer.hs +++ /dev/null @@ -1,79 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.StreamK.Transformer --- Copyright : (c) 2017 Composewell Technologies --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Stream.StreamK.Transformer - ( - foldlT - , foldrT - - , liftInner - , evalStateT - ) -where - -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Monad.Trans.State.Strict (StateT) -import Streamly.Internal.Data.Stream.StreamK - (StreamK, nil, cons, uncons, concatEffect) - -import qualified Control.Monad.Trans.State.Strict as State - --- | Lazy left fold to an arbitrary transformer monad. -{-# INLINE foldlT #-} -foldlT :: (Monad m, Monad (s m), MonadTrans s) - => (s m b -> a -> s m b) -> s m b -> StreamK m a -> s m b -foldlT step = go - where - go acc m1 = do - res <- lift $ uncons m1 - case res of - Just (h, t) -> go (step acc h) t - Nothing -> acc - --- | Right associative fold to an arbitrary transformer monad. -{-# INLINE foldrT #-} -foldrT :: (Monad m, Monad (s m), MonadTrans s) - => (a -> s m b -> s m b) -> s m b -> StreamK m a -> s m b -foldrT step final = go - where - go m1 = do - res <- lift $ uncons m1 - case res of - Just (h, t) -> step h (go t) - Nothing -> final - ------------------------------------------------------------------------------- --- Lifting inner monad ------------------------------------------------------------------------------- - -{-# INLINE evalStateT #-} -evalStateT :: Monad m => m s -> StreamK (StateT s m) a -> StreamK m a -evalStateT = go - - where - - go st m1 = concatEffect $ fmap f (st >>= State.runStateT (uncons m1)) - - f (res, s1) = - case res of - Just (h, t) -> cons h (go (return s1) t) - Nothing -> nil - -{-# INLINE liftInner #-} -liftInner :: (Monad m, MonadTrans t, Monad (t m)) => - StreamK m a -> StreamK (t m) a -liftInner = go - - where - - go m1 = concatEffect $ fmap f $ lift $ uncons m1 - - f res = - case res of - Just (h, t) -> cons h (go t) - Nothing -> nil diff --git a/src/Streamly/Internal/Data/Stream/StreamK/Type.hs b/src/Streamly/Internal/Data/Stream/StreamK/Type.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/StreamK/Type.hs +++ /dev/null @@ -1,2063 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} --- | --- Module : Streamly.Internal.Data.Stream.StreamK.Type --- Copyright : (c) 2017 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- --- Continuation passing style (CPS) stream implementation. The symbol 'K' below --- denotes a function as well as a Kontinuation. --- -module Streamly.Internal.Data.Stream.StreamK.Type - ( - -- * StreamK type - Stream - , StreamK (..) - - -- * CrossStreamK type wrapper - , CrossStreamK - , unCross - , mkCross - - -- * foldr/build Fusion - , mkStream - , foldStream - , foldStreamShared - , foldrM - , foldrS - , foldrSShared - , foldrSM - , build - , buildS - , buildM - , buildSM - , augmentS - , augmentSM - , unShare - - -- * Construction - -- ** Primitives - , fromStopK - , fromYieldK - , consK - , cons - , (.:) - , consM - , consMBy - , nil - , nilM - - -- ** Unfolding - , unfoldr - , unfoldrMWith - , unfoldrM - - -- ** From Values - , fromEffect - , fromPure - , repeat - , repeatMWith - , replicateMWith - - -- ** From Indices - , fromIndicesMWith - - -- ** Iteration - , iterateMWith - - -- ** From Containers - , fromFoldable - , fromFoldableM - - -- ** Cyclic - , mfix - - -- * Elimination - -- ** Primitives - , uncons - - -- ** Strict Left Folds - , Streamly.Internal.Data.Stream.StreamK.Type.foldl' - , foldlx' - - -- ** Lazy Right Folds - , Streamly.Internal.Data.Stream.StreamK.Type.foldr - - -- ** Specific Folds - , drain - , null - , tail - , init - - -- * Mapping - , map - , mapMWith - , mapMSerial - - -- * Combining Two Streams - -- ** Appending - , conjoin - , append - - -- ** Interleave - , interleave - , interleaveFst - , interleaveMin - - -- ** Cross Product - , crossApplyWith - , crossApply - , crossApplySnd - , crossApplyFst - , crossWith - , cross - - -- * Concat - , before - , concatEffect - , concatMapEffect - , concatMapWith - , concatMap - , bindWith - , concatIterateWith - , concatIterateLeftsWith - , concatIterateScanWith - - -- * Merge - , mergeMapWith - , mergeIterateWith - - -- * Buffered Operations - , foldlS - , reverse - ) -where - -#include "inline.hs" - --- import Control.Applicative (liftA2) -import Control.Monad ((>=>)) -import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Applicative (liftA2) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Foldable (Foldable(foldl'), fold, foldr) -import Data.Function (fix) -import Data.Functor.Identity (Identity(..)) -import Data.Maybe (fromMaybe) -import Data.Semigroup (Endo(..)) -import GHC.Exts (IsList(..), IsString(..), oneShot) -import Streamly.Internal.BaseCompat ((#.)) -import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) -import Streamly.Internal.Data.SVar.Type (State, adaptState, defState) -import Text.Read - ( Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec - , readListPrecDefault) - -import qualified Prelude - -import Prelude hiding - (map, mapM, concatMap, foldr, repeat, null, reverse, tail, init) - -#include "DocTestDataStreamK.hs" - ------------------------------------------------------------------------------- --- Basic stream type ------------------------------------------------------------------------------- - --- It uses stop, singleton and yield continuations equivalent to the following --- direct style type: --- --- @ --- data StreamK m a = Stop | Singleton a | Yield a (StreamK m a) --- @ --- --- To facilitate parallel composition we maintain a local state in an 'SVar' --- that is shared across and is used for synchronization of the streams being --- composed. --- --- The singleton case can be expressed in terms of stop and yield but we have --- it as a separate case to optimize composition operations for streams with --- single element. We build singleton streams in the implementation of 'pure' --- for Applicative and Monad, and in 'lift' for MonadTrans. - --- XXX remove the State param. - --- | Continuation Passing Style (CPS) version of "Streamly.Data.Stream.Stream". --- Unlike "Streamly.Data.Stream.Stream", 'StreamK' can be composed recursively --- without affecting performance. --- --- Semigroup instance appends two streams: --- --- >>> (<>) = Stream.append --- -{-# DEPRECATED Stream "Please use StreamK instead." #-} -type Stream = StreamK - -newtype StreamK m a = - MkStream (forall r. - State StreamK m a -- state - -> (a -> StreamK m a -> m r) -- yield - -> (a -> m r) -- singleton - -> m r -- stop - -> m r - ) - -mkStream - :: (forall r. State StreamK m a - -> (a -> StreamK m a -> m r) - -> (a -> m r) - -> m r - -> m r) - -> StreamK m a -mkStream = MkStream - --- | A terminal function that has no continuation to follow. -type StopK m = forall r. m r -> m r - --- | A monadic continuation, it is a function that yields a value of type "a" --- and calls the argument (a -> m r) as a continuation with that value. We can --- also think of it as a callback with a handler (a -> m r). Category --- theorists call it a codensity type, a special type of right kan extension. -type YieldK m a = forall r. (a -> m r) -> m r - -_wrapM :: Monad m => m a -> YieldK m a -_wrapM m = (m >>=) - --- | Make an empty stream from a stop function. -fromStopK :: StopK m -> StreamK m a -fromStopK k = mkStream $ \_ _ _ stp -> k stp - --- | Make a singleton stream from a callback function. The callback function --- calls the one-shot yield continuation to yield an element. -fromYieldK :: YieldK m a -> StreamK m a -fromYieldK k = mkStream $ \_ _ sng _ -> k sng - --- | Add a yield function at the head of the stream. -consK :: YieldK m a -> StreamK m a -> StreamK m a -consK k r = mkStream $ \_ yld _ _ -> k (`yld` r) - --- XXX Build a stream from a repeating callback function. - ------------------------------------------------------------------------------- --- Construction ------------------------------------------------------------------------------- - -infixr 5 `cons` - --- faster than consM because there is no bind. - --- | A right associative prepend operation to add a pure value at the head of --- an existing stream:: --- --- >>> s = 1 `StreamK.cons` 2 `StreamK.cons` 3 `StreamK.cons` StreamK.nil --- >>> Stream.fold Fold.toList (StreamK.toStream s) --- [1,2,3] --- --- It can be used efficiently with 'Prelude.foldr': --- --- >>> fromFoldable = Prelude.foldr StreamK.cons StreamK.nil --- --- Same as the following but more efficient: --- --- >>> cons x xs = return x `StreamK.consM` xs --- -{-# INLINE_NORMAL cons #-} -cons :: a -> StreamK m a -> StreamK m a -cons a r = mkStream $ \_ yield _ _ -> yield a r - -infixr 5 .: - --- | Operator equivalent of 'cons'. --- --- @ --- > toList $ 1 .: 2 .: 3 .: nil --- [1,2,3] --- @ --- -{-# INLINE (.:) #-} -(.:) :: a -> StreamK m a -> StreamK m a -(.:) = cons - --- | A stream that terminates without producing any output or side effect. --- --- >>> Stream.fold Fold.toList (StreamK.toStream StreamK.nil) --- [] --- -{-# INLINE_NORMAL nil #-} -nil :: StreamK m a -nil = mkStream $ \_ _ _ stp -> stp - --- | A stream that terminates without producing any output, but produces a side --- effect. --- --- >>> Stream.fold Fold.toList (StreamK.toStream (StreamK.nilM (print "nil"))) --- "nil" --- [] --- --- /Pre-release/ -{-# INLINE_NORMAL nilM #-} -nilM :: Applicative m => m b -> StreamK m a -nilM m = mkStream $ \_ _ _ stp -> m *> stp - --- | Create a singleton stream from a pure value. --- --- >>> fromPure a = a `StreamK.cons` StreamK.nil --- >>> fromPure = pure --- >>> fromPure = StreamK.fromEffect . pure --- -{-# INLINE_NORMAL fromPure #-} -fromPure :: a -> StreamK m a -fromPure a = mkStream $ \_ _ single _ -> single a - --- | Create a singleton stream from a monadic action. --- --- >>> fromEffect m = m `StreamK.consM` StreamK.nil --- --- >>> Stream.fold Fold.drain $ StreamK.toStream $ StreamK.fromEffect (putStrLn "hello") --- hello --- -{-# INLINE_NORMAL fromEffect #-} -fromEffect :: Monad m => m a -> StreamK m a -fromEffect m = mkStream $ \_ _ single _ -> m >>= single - -infixr 5 `consM` - --- NOTE: specializing the function outside the instance definition seems to --- improve performance quite a bit at times, even if we have the same --- SPECIALIZE in the instance definition. - --- | A right associative prepend operation to add an effectful value at the --- head of an existing stream:: --- --- >>> s = putStrLn "hello" `StreamK.consM` putStrLn "world" `StreamK.consM` StreamK.nil --- >>> Stream.fold Fold.drain (StreamK.toStream s) --- hello --- world --- --- It can be used efficiently with 'Prelude.foldr': --- --- >>> fromFoldableM = Prelude.foldr StreamK.consM StreamK.nil --- --- Same as the following but more efficient: --- --- >>> consM x xs = StreamK.fromEffect x `StreamK.append` xs --- -{-# INLINE consM #-} -{-# SPECIALIZE consM :: IO a -> StreamK IO a -> StreamK IO a #-} -consM :: Monad m => m a -> StreamK m a -> StreamK m a -consM m r = MkStream $ \_ yld _ _ -> m >>= (`yld` r) - --- XXX specialize to IO? -{-# INLINE consMBy #-} -consMBy :: Monad m => - (StreamK m a -> StreamK m a -> StreamK m a) -> m a -> StreamK m a -> StreamK m a -consMBy f m r = fromEffect m `f` r - ------------------------------------------------------------------------------- --- Folding a stream ------------------------------------------------------------------------------- - --- | Fold a stream by providing an SVar, a stop continuation, a singleton --- continuation and a yield continuation. The stream would share the current --- SVar passed via the State. -{-# INLINE_EARLY foldStreamShared #-} -foldStreamShared - :: State StreamK m a - -> (a -> StreamK m a -> m r) - -> (a -> m r) - -> m r - -> StreamK m a - -> m r -foldStreamShared s yield single stop (MkStream k) = k s yield single stop - --- | Fold a stream by providing a State, stop continuation, a singleton --- continuation and a yield continuation. The stream will not use the SVar --- passed via State. -{-# INLINE foldStream #-} -foldStream - :: State StreamK m a - -> (a -> StreamK m a -> m r) - -> (a -> m r) - -> m r - -> StreamK m a - -> m r -foldStream s yield single stop (MkStream k) = - k (adaptState s) yield single stop - -------------------------------------------------------------------------------- --- foldr/build fusion -------------------------------------------------------------------------------- - --- XXX perhaps we can just use foldrSM/buildM everywhere as they are more --- general and cover foldrS/buildS as well. - --- | The function 'f' decides how to reconstruct the stream. We could --- reconstruct using a shared state (SVar) or without sharing the state. --- -{-# INLINE foldrSWith #-} -foldrSWith :: - (forall r. State StreamK m b - -> (b -> StreamK m b -> m r) - -> (b -> m r) - -> m r - -> StreamK m b - -> m r) - -> (a -> StreamK m b -> StreamK m b) - -> StreamK m b - -> StreamK m a - -> StreamK m b -foldrSWith f step final m = go m - where - go m1 = mkStream $ \st yld sng stp -> - let run x = f st yld sng stp x - stop = run final - single a = run $ step a final - yieldk a r = run $ step a (go r) - -- XXX if type a and b are the same we do not need adaptState, can we - -- save some perf with that? - -- XXX since we are using adaptState anyway here we can use - -- foldStreamShared instead, will that save some perf? - in foldStream (adaptState st) yieldk single stop m1 - --- XXX we can use rewrite rules just for foldrSWith, if the function f is the --- same we can rewrite it. - --- | Fold sharing the SVar state within the reconstructed stream -{-# INLINE_NORMAL foldrSShared #-} -foldrSShared :: - (a -> StreamK m b -> StreamK m b) - -> StreamK m b - -> StreamK m a - -> StreamK m b -foldrSShared = foldrSWith foldStreamShared - --- XXX consM is a typeclass method, therefore rewritten already. Instead maybe --- we can make consM polymorphic using rewrite rules. --- {-# RULES "foldrSShared/id" foldrSShared consM nil = \x -> x #-} -{-# RULES "foldrSShared/nil" - forall k z. foldrSShared k z nil = z #-} -{-# RULES "foldrSShared/single" - forall k z x. foldrSShared k z (fromPure x) = k x z #-} --- {-# RULES "foldrSShared/app" [1] --- forall ys. foldrSShared consM ys = \xs -> xs `conjoin` ys #-} - --- | Right fold to a streaming monad. --- --- > foldrS StreamK.cons StreamK.nil === id --- --- 'foldrS' can be used to perform stateless stream to stream transformations --- like map and filter in general. It can be coupled with a scan to perform --- stateful transformations. However, note that the custom map and filter --- routines can be much more efficient than this due to better stream fusion. --- --- >>> input = StreamK.fromStream $ Stream.fromList [1..5] --- >>> Stream.fold Fold.toList $ StreamK.toStream $ StreamK.foldrS StreamK.cons StreamK.nil input --- [1,2,3,4,5] --- --- Find if any element in the stream is 'True': --- --- >>> step x xs = if odd x then StreamK.fromPure True else xs --- >>> input = StreamK.fromStream (Stream.fromList (2:4:5:undefined)) :: StreamK IO Int --- >>> Stream.fold Fold.toList $ StreamK.toStream $ StreamK.foldrS step (StreamK.fromPure False) input --- [True] --- --- Map (+2) on odd elements and filter out the even elements: --- --- >>> step x xs = if odd x then (x + 2) `StreamK.cons` xs else xs --- >>> input = StreamK.fromStream (Stream.fromList [1..5]) :: StreamK IO Int --- >>> Stream.fold Fold.toList $ StreamK.toStream $ StreamK.foldrS step StreamK.nil input --- [3,5,7] --- --- /Pre-release/ -{-# INLINE_NORMAL foldrS #-} -foldrS :: - (a -> StreamK m b -> StreamK m b) - -> StreamK m b - -> StreamK m a - -> StreamK m b -foldrS = foldrSWith foldStream - -{-# RULES "foldrS/id" foldrS cons nil = \x -> x #-} -{-# RULES "foldrS/nil" forall k z. foldrS k z nil = z #-} --- See notes in GHC.Base about this rule --- {-# RULES "foldr/cons" --- forall k z x xs. foldrS k z (x `cons` xs) = k x (foldrS k z xs) #-} -{-# RULES "foldrS/single" forall k z x. foldrS k z (fromPure x) = k x z #-} --- {-# RULES "foldrS/app" [1] --- forall ys. foldrS cons ys = \xs -> xs `conjoin` ys #-} - -------------------------------------------------------------------------------- --- foldrS with monadic cons i.e. consM -------------------------------------------------------------------------------- - -{-# INLINE foldrSMWith #-} -foldrSMWith :: Monad m - => (forall r. State StreamK m b - -> (b -> StreamK m b -> m r) - -> (b -> m r) - -> m r - -> StreamK m b - -> m r) - -> (m a -> StreamK m b -> StreamK m b) - -> StreamK m b - -> StreamK m a - -> StreamK m b -foldrSMWith f step final m = go m - where - go m1 = mkStream $ \st yld sng stp -> - let run x = f st yld sng stp x - stop = run final - single a = run $ step (return a) final - yieldk a r = run $ step (return a) (go r) - in foldStream (adaptState st) yieldk single stop m1 - -{-# INLINE_NORMAL foldrSM #-} -foldrSM :: Monad m - => (m a -> StreamK m b -> StreamK m b) - -> StreamK m b - -> StreamK m a - -> StreamK m b -foldrSM = foldrSMWith foldStream - --- {-# RULES "foldrSM/id" foldrSM consM nil = \x -> x #-} -{-# RULES "foldrSM/nil" forall k z. foldrSM k z nil = z #-} -{-# RULES "foldrSM/single" forall k z x. foldrSM k z (fromEffect x) = k x z #-} --- {-# RULES "foldrSM/app" [1] --- forall ys. foldrSM consM ys = \xs -> xs `conjoin` ys #-} - --- Like foldrSM but sharing the SVar state within the recostructed stream. -{-# INLINE_NORMAL foldrSMShared #-} -foldrSMShared :: Monad m - => (m a -> StreamK m b -> StreamK m b) - -> StreamK m b - -> StreamK m a - -> StreamK m b -foldrSMShared = foldrSMWith foldStreamShared - --- {-# RULES "foldrSM/id" foldrSM consM nil = \x -> x #-} -{-# RULES "foldrSMShared/nil" - forall k z. foldrSMShared k z nil = z #-} -{-# RULES "foldrSMShared/single" - forall k z x. foldrSMShared k z (fromEffect x) = k x z #-} --- {-# RULES "foldrSM/app" [1] --- forall ys. foldrSM consM ys = \xs -> xs `conjoin` ys #-} - -------------------------------------------------------------------------------- --- build -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL build #-} -build :: forall m a. (forall b. (a -> b -> b) -> b -> b) -> StreamK m a -build g = g cons nil - -{-# RULES "foldrM/build" - forall k z (g :: forall b. (a -> b -> b) -> b -> b). - foldrM k z (build g) = g k z #-} - -{-# RULES "foldrS/build" - forall k z (g :: forall b. (a -> b -> b) -> b -> b). - foldrS k z (build g) = g k z #-} - -{-# RULES "foldrS/cons/build" - forall k z x (g :: forall b. (a -> b -> b) -> b -> b). - foldrS k z (x `cons` build g) = k x (g k z) #-} - -{-# RULES "foldrSShared/build" - forall k z (g :: forall b. (a -> b -> b) -> b -> b). - foldrSShared k z (build g) = g k z #-} - -{-# RULES "foldrSShared/cons/build" - forall k z x (g :: forall b. (a -> b -> b) -> b -> b). - foldrSShared k z (x `cons` build g) = k x (g k z) #-} - --- build a stream by applying cons and nil to a build function -{-# INLINE_NORMAL buildS #-} -buildS :: - ((a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) - -> StreamK m a -buildS g = g cons nil - -{-# RULES "foldrS/buildS" - forall k z - (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - foldrS k z (buildS g) = g k z #-} - -{-# RULES "foldrS/cons/buildS" - forall k z x - (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - foldrS k z (x `cons` buildS g) = k x (g k z) #-} - -{-# RULES "foldrSShared/buildS" - forall k z - (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - foldrSShared k z (buildS g) = g k z #-} - -{-# RULES "foldrSShared/cons/buildS" - forall k z x - (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - foldrSShared k z (x `cons` buildS g) = k x (g k z) #-} - --- build a stream by applying consM and nil to a build function -{-# INLINE_NORMAL buildSM #-} -buildSM :: Monad m - => ((m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) - -> StreamK m a -buildSM g = g consM nil - -{-# RULES "foldrSM/buildSM" - forall k z - (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - foldrSM k z (buildSM g) = g k z #-} - -{-# RULES "foldrSMShared/buildSM" - forall k z - (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - foldrSMShared k z (buildSM g) = g k z #-} - --- Disabled because this may not fire as consM is a class Op -{- -{-# RULES "foldrS/consM/buildSM" - forall k z x (g :: (m a -> t m a -> t m a) -> t m a -> t m a) - . foldrSM k z (x `consM` buildSM g) - = k x (g k z) -#-} --} - --- Build using monadic build functions (continuations) instead of --- reconstructing a stream. -{-# INLINE_NORMAL buildM #-} -buildM :: Monad m - => (forall r. (a -> StreamK m a -> m r) - -> (a -> m r) - -> m r - -> m r - ) - -> StreamK m a -buildM g = mkStream $ \st yld sng stp -> - g (\a r -> foldStream st yld sng stp (return a `consM` r)) sng stp - --- | Like 'buildM' but shares the SVar state across computations. -{-# INLINE_NORMAL sharedMWith #-} -sharedMWith :: Monad m - => (m a -> StreamK m a -> StreamK m a) - -> (forall r. (a -> StreamK m a -> m r) - -> (a -> m r) - -> m r - -> m r - ) - -> StreamK m a -sharedMWith cns g = mkStream $ \st yld sng stp -> - g (\a r -> foldStreamShared st yld sng stp (return a `cns` r)) sng stp - -------------------------------------------------------------------------------- --- augment -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL augmentS #-} -augmentS :: - ((a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) - -> StreamK m a - -> StreamK m a -augmentS g xs = g cons xs - -{-# RULES "augmentS/nil" - forall (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - augmentS g nil = buildS g - #-} - -{-# RULES "foldrS/augmentS" - forall k z xs - (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - foldrS k z (augmentS g xs) = g k (foldrS k z xs) - #-} - -{-# RULES "augmentS/buildS" - forall (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) - (h :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - augmentS g (buildS h) = buildS (\c n -> g c (h c n)) - #-} - -{-# INLINE_NORMAL augmentSM #-} -augmentSM :: Monad m => - ((m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) - -> StreamK m a -> StreamK m a -augmentSM g xs = g consM xs - -{-# RULES "augmentSM/nil" - forall - (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - augmentSM g nil = buildSM g - #-} - -{-# RULES "foldrSM/augmentSM" - forall k z xs - (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - foldrSM k z (augmentSM g xs) = g k (foldrSM k z xs) - #-} - -{-# RULES "augmentSM/buildSM" - forall - (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) - (h :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). - augmentSM g (buildSM h) = buildSM (\c n -> g c (h c n)) - #-} - -------------------------------------------------------------------------------- --- Experimental foldrM/buildM -------------------------------------------------------------------------------- - --- | Lazy right fold with a monadic step function. -{-# INLINE_NORMAL foldrM #-} -foldrM :: (a -> m b -> m b) -> m b -> StreamK m a -> m b -foldrM step acc m = go m - where - go m1 = - let stop = acc - single a = step a acc - yieldk a r = step a (go r) - in foldStream defState yieldk single stop m1 - -{-# INLINE_NORMAL foldrMKWith #-} -foldrMKWith - :: (State StreamK m a - -> (a -> StreamK m a -> m b) - -> (a -> m b) - -> m b - -> StreamK m a - -> m b) - -> (a -> m b -> m b) - -> m b - -> ((a -> StreamK m a -> m b) -> (a -> m b) -> m b -> m b) - -> m b -foldrMKWith f step acc = go - where - go k = - let stop = acc - single a = step a acc - yieldk a r = step a (go (\yld sng stp -> f defState yld sng stp r)) - in k yieldk single stop - -{- -{-# RULES "foldrM/buildS" - forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a) - . foldrM k z (buildS g) - = g k z -#-} --} --- XXX in which case will foldrM/buildM fusion be useful? -{-# RULES "foldrM/buildM" - forall step acc (g :: (forall r. - (a -> StreamK m a -> m r) - -> (a -> m r) - -> m r - -> m r - )). - foldrM step acc (buildM g) = foldrMKWith foldStream step acc g - #-} - -{- -{-# RULES "foldrM/sharedM" - forall step acc (g :: (forall r. - (a -> StreamK m a -> m r) - -> (a -> m r) - -> m r - -> m r - )). - foldrM step acc (sharedM g) = foldrMKWith foldStreamShared step acc g - #-} --} - ------------------------------------------------------------------------------- --- Left fold ------------------------------------------------------------------------------- - --- | Strict left fold with an extraction function. Like the standard strict --- left fold, but applies a user supplied extraction function (the third --- argument) to the folded value at the end. This is designed to work with the --- @foldl@ library. The suffix @x@ is a mnemonic for extraction. --- --- Note that the accumulator is always evaluated including the initial value. -{-# INLINE foldlx' #-} -foldlx' :: forall m a b x. Monad m - => (x -> a -> x) -> x -> (x -> b) -> StreamK m a -> m b -foldlx' step begin done m = get $ go m begin - where - {-# NOINLINE get #-} - get :: StreamK m x -> m b - get m1 = - -- XXX we are not strictly evaluating the accumulator here. Is this - -- okay? - let single = return . done - -- XXX this is foldSingleton. why foldStreamShared? - in foldStreamShared undefined undefined single undefined m1 - - -- Note, this can be implemented by making a recursive call to "go", - -- however that is more expensive because of unnecessary recursion - -- that cannot be tail call optimized. Unfolding recursion explicitly via - -- continuations is much more efficient. - go :: StreamK m a -> x -> StreamK m x - go m1 !acc = mkStream $ \_ yld sng _ -> - let stop = sng acc - single a = sng $ step acc a - -- XXX this is foldNonEmptyStream - yieldk a r = foldStream defState yld sng undefined $ - go r (step acc a) - in foldStream defState yieldk single stop m1 - --- | Strict left associative fold. -{-# INLINE foldl' #-} -foldl' :: Monad m => (b -> a -> b) -> b -> StreamK m a -> m b -foldl' step begin = foldlx' step begin id - ------------------------------------------------------------------------------- --- Specialized folds ------------------------------------------------------------------------------- - --- XXX use foldrM to implement folds where possible --- XXX This (commented) definition of drain and mapM_ perform much better on --- some benchmarks but worse on others. Need to investigate why, may there is --- an optimization opportunity that we can exploit. --- drain = foldrM (\_ xs -> return () >> xs) (return ()) - --- | --- > drain = foldl' (\_ _ -> ()) () --- > drain = mapM_ (\_ -> return ()) -{-# INLINE drain #-} -drain :: Monad m => StreamK m a -> m () -drain = foldrM (\_ xs -> xs) (return ()) -{- -drain = go - where - go m1 = - let stop = return () - single _ = return () - yieldk _ r = go r - in foldStream defState yieldk single stop m1 --} - -{-# INLINE null #-} -null :: Monad m => StreamK m a -> m Bool --- null = foldrM (\_ _ -> return True) (return False) -null m = - let stop = return True - single _ = return False - yieldk _ _ = return False - in foldStream defState yieldk single stop m - ------------------------------------------------------------------------------- --- Semigroup ------------------------------------------------------------------------------- - -infixr 6 `append` - --- | Appends two streams sequentially, yielding all elements from the first --- stream, and then all elements from the second stream. --- --- >>> s1 = StreamK.fromStream $ Stream.fromList [1,2] --- >>> s2 = StreamK.fromStream $ Stream.fromList [3,4] --- >>> Stream.fold Fold.toList $ StreamK.toStream $ s1 `StreamK.append` s2 --- [1,2,3,4] --- --- This has O(n) append performance where @n@ is the number of streams. It can --- be used to efficiently fold an infinite lazy container of streams using --- 'concatMapWith' et. al. --- -{-# INLINE append #-} -append :: StreamK m a -> StreamK m a -> StreamK m a --- XXX This doubles the time of toNullAp benchmark, may not be fusing properly --- serial xs ys = augmentS (\c n -> foldrS c n xs) ys -append m1 m2 = go m1 - where - go m = mkStream $ \st yld sng stp -> - let stop = foldStream st yld sng stp m2 - single a = yld a m2 - yieldk a r = yld a (go r) - in foldStream st yieldk single stop m - --- join/merge/append streams depending on consM -{-# INLINE conjoin #-} -conjoin :: Monad m => StreamK m a -> StreamK m a -> StreamK m a -conjoin xs = augmentSM (\c n -> foldrSM c n xs) - -instance Semigroup (StreamK m a) where - (<>) = append - ------------------------------------------------------------------------------- --- Monoid ------------------------------------------------------------------------------- - -instance Monoid (StreamK m a) where - mempty = nil - mappend = (<>) - -------------------------------------------------------------------------------- --- Functor -------------------------------------------------------------------------------- - --- IMPORTANT: This is eta expanded on purpose. This should not be eta --- reduced. This will cause a lot of regressions, probably because of some --- rewrite rules. Ideally don't run hlint on this file. -{-# INLINE_LATE mapFB #-} -mapFB :: forall b m a. - (b -> StreamK m b -> StreamK m b) - -> (a -> b) - -> a - -> StreamK m b - -> StreamK m b -mapFB c f = \x ys -> c (f x) ys - -{-# RULES -"mapFB/mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f . g) -"mapFB/id" forall c. mapFB c (\x -> x) = c - #-} - -{-# INLINE map #-} -map :: (a -> b) -> StreamK m a -> StreamK m b -map f xs = buildS (\c n -> foldrS (mapFB c f) n xs) - --- XXX This definition might potentially be more efficient, but the cost in the --- benchmark is dominated by unfoldrM cost so we cannot correctly determine --- differences in the mapping cost. We should perhaps deduct the cost of --- unfoldrM from the benchmarks and then compare. -{- -map f m = go m - where - go m1 = - mkStream $ \st yld sng stp -> - let single = sng . f - yieldk a r = yld (f a) (go r) - in foldStream (adaptState st) yieldk single stp m1 --} - -{-# INLINE_LATE mapMFB #-} -mapMFB :: Monad m => (m b -> t m b -> t m b) -> (a -> m b) -> m a -> t m b -> t m b -mapMFB c f x = c (x >>= f) - -{-# RULES - "mapMFB/mapMFB" forall c f g. mapMFB (mapMFB c f) g = mapMFB c (f >=> g) - #-} --- XXX These rules may never fire because pure/return type class rules will --- fire first. -{- -"mapMFB/pure" forall c. mapMFB c (\x -> pure x) = c -"mapMFB/return" forall c. mapMFB c (\x -> return x) = c --} - --- This is experimental serial version supporting fusion. --- --- XXX what if we do not want to fuse two concurrent mapMs? --- XXX we can combine two concurrent mapM only if the SVar is of the same type --- So for now we use it only for serial streams. --- XXX fusion would be easier for monomoprhic stream types. --- {-# RULES "mapM serial" mapM = mapMSerial #-} -{-# INLINE mapMSerial #-} -mapMSerial :: Monad m => (a -> m b) -> StreamK m a -> StreamK m b -mapMSerial f xs = buildSM (\c n -> foldrSMShared (mapMFB c f) n xs) - -{-# INLINE mapMWith #-} -mapMWith :: - (m b -> StreamK m b -> StreamK m b) - -> (a -> m b) - -> StreamK m a - -> StreamK m b -mapMWith cns f = foldrSShared (\x xs -> f x `cns` xs) nil - -{- --- See note under map definition above. -mapMWith cns f = go - where - go m1 = mkStream $ \st yld sng stp -> - let single a = f a >>= sng - yieldk a r = foldStreamShared st yld sng stp $ f a `cns` go r - in foldStream (adaptState st) yieldk single stp m1 --} - --- XXX in fact use the Stream type everywhere and only use polymorphism in the --- high level modules/prelude. -instance Monad m => Functor (StreamK m) where - fmap = map - ------------------------------------------------------------------------------- --- Lists ------------------------------------------------------------------------------- - --- Serial streams can act like regular lists using the Identity monad - --- XXX Show instance is 10x slower compared to read, we can do much better. --- The list show instance itself is really slow. - --- XXX The default definitions of "<" in the Ord instance etc. do not perform --- well, because they do not get inlined. Need to add INLINE in Ord class in --- base? - -instance IsList (StreamK Identity a) where - type (Item (StreamK Identity a)) = a - - {-# INLINE fromList #-} - fromList = fromFoldable - - {-# INLINE toList #-} - toList = Data.Foldable.foldr (:) [] - --- XXX Fix these -{- -instance Eq a => Eq (StreamK Identity a) where - {-# INLINE (==) #-} - (==) xs ys = runIdentity $ eqBy (==) xs ys - -instance Ord a => Ord (StreamK Identity a) where - {-# INLINE compare #-} - compare xs ys = runIdentity $ cmpBy compare xs ys - - {-# INLINE (<) #-} - x < y = - case compare x y of - LT -> True - _ -> False - - {-# INLINE (<=) #-} - x <= y = - case compare x y of - GT -> False - _ -> True - - {-# INLINE (>) #-} - x > y = - case compare x y of - GT -> True - _ -> False - - {-# INLINE (>=) #-} - x >= y = - case compare x y of - LT -> False - _ -> True - - {-# INLINE max #-} - max x y = if x <= y then y else x - - {-# INLINE min #-} - min x y = if x <= y then x else y --} - -instance Show a => Show (StreamK Identity a) where - showsPrec p dl = showParen (p > 10) $ - showString "fromList " . shows (toList dl) - -instance Read a => Read (StreamK Identity a) where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - fromList <$> readPrec - - readListPrec = readListPrecDefault - -instance (a ~ Char) => IsString (StreamK Identity a) where - {-# INLINE fromString #-} - fromString = fromList - -------------------------------------------------------------------------------- --- Foldable -------------------------------------------------------------------------------- - --- | Lazy right associative fold. -{-# INLINE foldr #-} -foldr :: Monad m => (a -> b -> b) -> b -> StreamK m a -> m b -foldr step acc = foldrM (\x xs -> xs >>= \b -> return (step x b)) (return acc) - --- The default Foldable instance has several issues: --- 1) several definitions do not have INLINE on them, so we provide --- re-implementations with INLINE pragmas. --- 2) the definitions of sum/product/maximum/minimum are inefficient as they --- use right folds, they cannot run in constant memory. We provide --- implementations using strict left folds here. - -instance (Foldable m, Monad m) => Foldable (StreamK m) where - - {-# INLINE foldMap #-} - foldMap f = - fold - . Streamly.Internal.Data.Stream.StreamK.Type.foldr (mappend . f) mempty - - {-# INLINE foldr #-} - foldr f z t = appEndo (foldMap (Endo #. f) t) z - - {-# INLINE foldl' #-} - foldl' f z0 xs = Data.Foldable.foldr f' id xs z0 - where f' x k = oneShot $ \z -> k $! f z x - - {-# INLINE length #-} - length = Data.Foldable.foldl' (\n _ -> n + 1) 0 - - {-# INLINE elem #-} - elem = any . (==) - - {-# INLINE maximum #-} - maximum = - fromMaybe (errorWithoutStackTrace "maximum: empty stream") - . toMaybe - . Data.Foldable.foldl' getMax Nothing' - - where - - getMax Nothing' x = Just' x - getMax (Just' mx) x = Just' $! max mx x - - {-# INLINE minimum #-} - minimum = - fromMaybe (errorWithoutStackTrace "minimum: empty stream") - . toMaybe - . Data.Foldable.foldl' getMin Nothing' - - where - - getMin Nothing' x = Just' x - getMin (Just' mn) x = Just' $! min mn x - - {-# INLINE sum #-} - sum = Data.Foldable.foldl' (+) 0 - - {-# INLINE product #-} - product = Data.Foldable.foldl' (*) 1 - -------------------------------------------------------------------------------- --- Traversable -------------------------------------------------------------------------------- - -instance Traversable (StreamK Identity) where - {-# INLINE traverse #-} - traverse f xs = - runIdentity - $ Streamly.Internal.Data.Stream.StreamK.Type.foldr - consA (pure mempty) xs - - where - - consA x ys = liftA2 cons (f x) ys - -------------------------------------------------------------------------------- --- Nesting -------------------------------------------------------------------------------- - --- | Detach a stream from an SVar -{-# INLINE unShare #-} -unShare :: StreamK m a -> StreamK m a -unShare x = mkStream $ \st yld sng stp -> - foldStream st yld sng stp x - --- XXX the function stream and value stream can run in parallel -{-# INLINE crossApplyWith #-} -crossApplyWith :: - (StreamK m b -> StreamK m b -> StreamK m b) - -> StreamK m (a -> b) - -> StreamK m a - -> StreamK m b -crossApplyWith par fstream stream = go1 fstream - - where - - go1 m = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - single f = foldShared $ unShare (go2 f stream) - yieldk f r = foldShared $ unShare (go2 f stream) `par` go1 r - in foldStream (adaptState st) yieldk single stp m - - go2 f m = - mkStream $ \st yld sng stp -> - let single a = sng (f a) - yieldk a r = yld (f a) (go2 f r) - in foldStream (adaptState st) yieldk single stp m - --- | Apply a stream of functions to a stream of values and flatten the results. --- --- Note that the second stream is evaluated multiple times. --- --- Definition: --- --- >>> crossApply = StreamK.crossApplyWith StreamK.append --- >>> crossApply = Stream.crossWith id --- -{-# INLINE crossApply #-} -crossApply :: - StreamK m (a -> b) - -> StreamK m a - -> StreamK m b -crossApply fstream stream = go1 fstream - - where - - go1 m = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - single f = foldShared $ go3 f stream - yieldk f r = foldShared $ go2 f r stream - in foldStream (adaptState st) yieldk single stp m - - go2 f r1 m = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - stop = foldShared $ go1 r1 - single a = yld (f a) (go1 r1) - yieldk a r = yld (f a) (go2 f r1 r) - in foldStream (adaptState st) yieldk single stop m - - go3 f m = - mkStream $ \st yld sng stp -> - let single a = sng (f a) - yieldk a r = yld (f a) (go3 f r) - in foldStream (adaptState st) yieldk single stp m - -{-# INLINE crossApplySnd #-} -crossApplySnd :: - StreamK m a - -> StreamK m b - -> StreamK m b -crossApplySnd fstream stream = go1 fstream - - where - - go1 m = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - single _ = foldShared stream - yieldk _ r = foldShared $ go2 r stream - in foldStream (adaptState st) yieldk single stp m - - go2 r1 m = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - stop = foldShared $ go1 r1 - single a = yld a (go1 r1) - yieldk a r = yld a (go2 r1 r) - in foldStream st yieldk single stop m - -{-# INLINE crossApplyFst #-} -crossApplyFst :: - StreamK m a - -> StreamK m b - -> StreamK m a -crossApplyFst fstream stream = go1 fstream - - where - - go1 m = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - single f = foldShared $ go3 f stream - yieldk f r = foldShared $ go2 f r stream - in foldStream st yieldk single stp m - - go2 f r1 m = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - stop = foldShared $ go1 r1 - single _ = yld f (go1 r1) - yieldk _ r = yld f (go2 f r1 r) - in foldStream (adaptState st) yieldk single stop m - - go3 f m = - mkStream $ \st yld sng stp -> - let single _ = sng f - yieldk _ r = yld f (go3 f r) - in foldStream (adaptState st) yieldk single stp m - --- | --- Definition: --- --- >>> crossWith f m1 m2 = fmap f m1 `StreamK.crossApply` m2 --- --- Note that the second stream is evaluated multiple times. --- -{-# INLINE crossWith #-} -crossWith :: Monad m => (a -> b -> c) -> StreamK m a -> StreamK m b -> StreamK m c -crossWith f m1 m2 = fmap f m1 `crossApply` m2 - --- | Given a @StreamK m a@ and @StreamK m b@ generate a stream with all possible --- combinations of the tuple @(a, b)@. --- --- Definition: --- --- >>> cross = StreamK.crossWith (,) --- --- The second stream is evaluated multiple times. If that is not desired it can --- be cached in an 'Data.Array.Array' and then generated from the array before --- calling this function. Caching may also improve performance if the stream is --- expensive to evaluate. --- --- See 'Streamly.Internal.Data.Unfold.cross' for a much faster fused --- alternative. --- --- Time: O(m x n) --- --- /Pre-release/ -{-# INLINE cross #-} -cross :: Monad m => StreamK m a -> StreamK m b -> StreamK m (a, b) -cross = crossWith (,) - --- XXX This is just concatMapWith with arguments flipped. We need to keep this --- instead of using a concatMap style definition because the bind --- implementation in Async and WAsync streams show significant perf degradation --- if the argument order is changed. -{-# INLINE bindWith #-} -bindWith :: - (StreamK m b -> StreamK m b -> StreamK m b) - -> StreamK m a - -> (a -> StreamK m b) - -> StreamK m b -bindWith par m1 f = go m1 - where - go m = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - single a = foldShared $ unShare (f a) - yieldk a r = foldShared $ unShare (f a) `par` go r - in foldStream (adaptState st) yieldk single stp m - --- XXX express in terms of foldrS? --- XXX can we use a different stream type for the generated stream being --- falttened so that we can combine them differently and keep the resulting --- stream different? --- XXX do we need specialize to IO? --- XXX can we optimize when c and a are same, by removing the forall using --- rewrite rules with type applications? - --- | Perform a 'concatMap' using a specified concat strategy. The first --- argument specifies a merge or concat function that is used to merge the --- streams generated by the map function. --- -{-# INLINE concatMapWith #-} -concatMapWith - :: - (StreamK m b -> StreamK m b -> StreamK m b) - -> (a -> StreamK m b) - -> StreamK m a - -> StreamK m b -concatMapWith par f xs = bindWith par xs f - -{-# INLINE concatMap #-} -concatMap :: (a -> StreamK m b) -> StreamK m a -> StreamK m b -concatMap = concatMapWith append - -{- --- Fused version. --- XXX This fuses but when the stream is nil this performs poorly. --- The filterAllOut benchmark degrades. Need to investigate and fix that. -{-# INLINE concatMap #-} -concatMap :: IsStream t => (a -> t m b) -> t m a -> t m b -concatMap f xs = buildS - (\c n -> foldrS (\x b -> foldrS c b (f x)) n xs) - --- Stream polymorphic concatMap implementation --- XXX need to use buildSM/foldrSMShared for parallel behavior --- XXX unShare seems to degrade the fused performance -{-# INLINE_EARLY concatMap_ #-} -concatMap_ :: IsStream t => (a -> t m b) -> t m a -> t m b -concatMap_ f xs = buildS - (\c n -> foldrSShared (\x b -> foldrSShared c b (unShare $ f x)) n xs) --} - --- | Combine streams in pairs using a binary combinator, the resulting streams --- are then combined again in pairs recursively until we get to a single --- combined stream. The composition would thus form a binary tree. --- --- For example, you can sort a stream using merge sort like this: --- --- >>> s = StreamK.fromStream $ Stream.fromList [5,1,7,9,2] --- >>> generate = StreamK.fromPure --- >>> combine = StreamK.mergeBy compare --- >>> Stream.fold Fold.toList $ StreamK.toStream $ StreamK.mergeMapWith combine generate s --- [1,2,5,7,9] --- --- Note that if the stream length is not a power of 2, the binary tree composed --- by mergeMapWith would not be balanced, which may or may not be important --- depending on what you are trying to achieve. --- --- /Caution: the stream of streams must be finite/ --- --- /Pre-release/ --- -{-# INLINE mergeMapWith #-} -mergeMapWith - :: - (StreamK m b -> StreamK m b -> StreamK m b) - -> (a -> StreamK m b) - -> StreamK m a - -> StreamK m b -mergeMapWith combine f str = go (leafPairs str) - - where - - go stream = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - single a = foldShared $ unShare a - yieldk a r = foldShared $ go1 a r - in foldStream (adaptState st) yieldk single stp stream - - go1 a1 stream = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - stop = foldShared $ unShare a1 - single a = foldShared $ unShare a1 `combine` a - yieldk a r = - foldShared $ go $ combine a1 a `cons` nonLeafPairs r - in foldStream (adaptState st) yieldk single stop stream - - -- Exactly the same as "go" except that stop continuation extracts the - -- stream. - leafPairs stream = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - single a = sng (f a) - yieldk a r = foldShared $ leafPairs1 a r - in foldStream (adaptState st) yieldk single stp stream - - leafPairs1 a1 stream = - mkStream $ \st yld sng _ -> - let stop = sng (f a1) - single a = sng (f a1 `combine` f a) - yieldk a r = yld (f a1 `combine` f a) $ leafPairs r - in foldStream (adaptState st) yieldk single stop stream - - -- Exactly the same as "leafPairs" except that it does not map "f" - nonLeafPairs stream = - mkStream $ \st yld sng stp -> - let foldShared = foldStreamShared st yld sng stp - single a = sng a - yieldk a r = foldShared $ nonLeafPairs1 a r - in foldStream (adaptState st) yieldk single stp stream - - nonLeafPairs1 a1 stream = - mkStream $ \st yld sng _ -> - let stop = sng a1 - single a = sng (a1 `combine` a) - yieldk a r = yld (a1 `combine` a) $ nonLeafPairs r - in foldStream (adaptState st) yieldk single stop stream - -{- -instance Monad m => Applicative (StreamK m) where - {-# INLINE pure #-} - pure = fromPure - - {-# INLINE (<*>) #-} - (<*>) = crossApply - - {-# INLINE liftA2 #-} - liftA2 f x = (<*>) (fmap f x) - - {-# INLINE (*>) #-} - (*>) = crossApplySnd - - {-# INLINE (<*) #-} - (<*) = crossApplyFst - --- NOTE: even though concatMap for StreamD is 3x faster compared to StreamK, --- the monad instance of StreamD is slower than StreamK after foldr/build --- fusion. -instance Monad m => Monad (StreamK m) where - {-# INLINE return #-} - return = pure - - {-# INLINE (>>=) #-} - (>>=) = flip concatMap --} - -{- --- Like concatMap but generates stream using an unfold function. Similar to --- unfoldMany but for StreamK. -concatUnfoldr :: IsStream t - => (b -> t m (Maybe (a, b))) -> t m b -> t m a -concatUnfoldr = undefined --} - ------------------------------------------------------------------------------- --- concatIterate - Map and flatten Trees of Streams ------------------------------------------------------------------------------- - --- | Yield an input element in the output stream, map a stream generator on it --- and repeat the process on the resulting stream. Resulting streams are --- flattened using the 'concatMapWith' combinator. This can be used for a depth --- first style (DFS) traversal of a tree like structure. --- --- Example, list a directory tree using DFS: --- --- >>> f = StreamK.fromStream . either Dir.readEitherPaths (const Stream.nil) --- >>> input = StreamK.fromPure (Left ".") --- >>> ls = StreamK.concatIterateWith StreamK.append f input --- --- Note that 'iterateM' is a special case of 'concatIterateWith': --- --- >>> iterateM f = StreamK.concatIterateWith StreamK.append (StreamK.fromEffect . f) . StreamK.fromEffect --- --- /Pre-release/ --- -{-# INLINE concatIterateWith #-} -concatIterateWith :: - (StreamK m a -> StreamK m a -> StreamK m a) - -> (a -> StreamK m a) - -> StreamK m a - -> StreamK m a -concatIterateWith combine f = iterateStream - - where - - iterateStream = concatMapWith combine generate - - generate x = x `cons` iterateStream (f x) - --- | Like 'concatIterateWith' but uses the pairwise flattening combinator --- 'mergeMapWith' for flattening the resulting streams. This can be used for a --- balanced traversal of a tree like structure. --- --- Example, list a directory tree using balanced traversal: --- --- >>> f = StreamK.fromStream . either Dir.readEitherPaths (const Stream.nil) --- >>> input = StreamK.fromPure (Left ".") --- >>> ls = StreamK.mergeIterateWith StreamK.interleave f input --- --- /Pre-release/ --- -{-# INLINE mergeIterateWith #-} -mergeIterateWith :: - (StreamK m a -> StreamK m a -> StreamK m a) - -> (a -> StreamK m a) - -> StreamK m a - -> StreamK m a -mergeIterateWith combine f = iterateStream - - where - - iterateStream = mergeMapWith combine generate - - generate x = x `cons` iterateStream (f x) - ------------------------------------------------------------------------------- --- Flattening Graphs ------------------------------------------------------------------------------- - --- To traverse graphs we need a state to be carried around in the traversal. --- For example, we can use a hashmap to store the visited status of nodes. - --- | Like 'iterateMap' but carries a state in the stream generation function. --- This can be used to traverse graph like structures, we can remember the --- visited nodes in the state to avoid cycles. --- --- Note that a combination of 'iterateMap' and 'usingState' can also be used to --- traverse graphs. However, this function provides a more localized state --- instead of using a global state. --- --- See also: 'mfix' --- --- /Pre-release/ --- -{-# INLINE concatIterateScanWith #-} -concatIterateScanWith - :: Monad m - => (StreamK m a -> StreamK m a -> StreamK m a) - -> (b -> a -> m (b, StreamK m a)) - -> m b - -> StreamK m a - -> StreamK m a -concatIterateScanWith combine f initial stream = - concatEffect $ do - b <- initial - iterateStream (b, stream) - - where - - iterateStream (b, s) = pure $ concatMapWith combine (generate b) s - - generate b a = a `cons` feedback b a - - feedback b a = concatEffect $ f b a >>= iterateStream - ------------------------------------------------------------------------------- --- Either streams ------------------------------------------------------------------------------- - --- Keep concating either streams as long as rights are generated, stop as soon --- as a left is generated and concat the left stream. --- --- See also: 'handle' --- --- /Unimplemented/ --- -{- -concatMapEitherWith - :: (forall x. t m x -> t m x -> t m x) - -> (a -> t m (Either (StreamK m b) b)) - -> StreamK m a - -> StreamK m b -concatMapEitherWith = undefined --} - --- XXX We should prefer using the Maybe stream returning signatures over this. --- This API should perhaps be removed in favor of those. - --- | In an 'Either' stream iterate on 'Left's. This is a special case of --- 'concatIterateWith': --- --- >>> concatIterateLeftsWith combine f = StreamK.concatIterateWith combine (either f (const StreamK.nil)) --- --- To traverse a directory tree: --- --- >>> input = StreamK.fromPure (Left ".") --- >>> ls = StreamK.concatIterateLeftsWith StreamK.append (StreamK.fromStream . Dir.readEither) input --- --- /Pre-release/ --- -{-# INLINE concatIterateLeftsWith #-} -concatIterateLeftsWith - :: (b ~ Either a c) - => (StreamK m b -> StreamK m b -> StreamK m b) - -> (a -> StreamK m b) - -> StreamK m b - -> StreamK m b -concatIterateLeftsWith combine f = - concatIterateWith combine (either f (const nil)) - ------------------------------------------------------------------------------- --- Interleaving ------------------------------------------------------------------------------- - -infixr 6 `interleave` - --- Additionally we can have m elements yield from the first stream and n --- elements yielding from the second stream. We can also have time slicing --- variants of positional interleaving, e.g. run first stream for m seconds and --- run the second stream for n seconds. - --- | Interleaves two streams, yielding one element from each stream --- alternately. When one stream stops the rest of the other stream is used in --- the output stream. --- --- When joining many streams in a left associative manner earlier streams will --- get exponential priority than the ones joining later. Because of exponential --- weighting it can be used with 'concatMapWith' even on a large number of --- streams. --- -{-# INLINE interleave #-} -interleave :: StreamK m a -> StreamK m a -> StreamK m a -interleave m1 m2 = mkStream $ \st yld sng stp -> do - let stop = foldStream st yld sng stp m2 - single a = yld a m2 - yieldk a r = yld a (interleave m2 r) - foldStream st yieldk single stop m1 - -infixr 6 `interleaveFst` - --- | Like `interleave` but stops interleaving as soon as the first stream stops. --- -{-# INLINE interleaveFst #-} -interleaveFst :: StreamK m a -> StreamK m a -> StreamK m a -interleaveFst m1 m2 = mkStream $ \st yld sng stp -> do - let yieldFirst a r = yld a (yieldSecond r m2) - in foldStream st yieldFirst sng stp m1 - - where - - yieldSecond s1 s2 = mkStream $ \st yld sng stp -> do - let stop = foldStream st yld sng stp s1 - single a = yld a s1 - yieldk a r = yld a (interleave s1 r) - in foldStream st yieldk single stop s2 - -infixr 6 `interleaveMin` - --- | Like `interleave` but stops interleaving as soon as any of the two streams --- stops. --- -{-# INLINE interleaveMin #-} -interleaveMin :: StreamK m a -> StreamK m a -> StreamK m a -interleaveMin m1 m2 = mkStream $ \st yld _ stp -> do - let stop = stp - -- "single a" is defined as "yld a (interleaveMin m2 nil)" instead of - -- "sng a" to keep the behaviour consistent with the yield - -- continuation. - single a = yld a (interleaveMin m2 nil) - yieldk a r = yld a (interleaveMin m2 r) - foldStream st yieldk single stop m1 - -------------------------------------------------------------------------------- --- Generation -------------------------------------------------------------------------------- - -{-# INLINE unfoldr #-} -unfoldr :: (b -> Maybe (a, b)) -> b -> StreamK m a -unfoldr next s0 = build $ \yld stp -> - let go s = - case next s of - Just (a, b) -> yld a (go b) - Nothing -> stp - in go s0 - -{-# INLINE unfoldrMWith #-} -unfoldrMWith :: Monad m => - (m a -> StreamK m a -> StreamK m a) - -> (b -> m (Maybe (a, b))) - -> b - -> StreamK m a -unfoldrMWith cns step = go - - where - - go s = sharedMWith cns $ \yld _ stp -> do - r <- step s - case r of - Just (a, b) -> yld a (go b) - Nothing -> stp - -{-# INLINE unfoldrM #-} -unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> StreamK m a -unfoldrM = unfoldrMWith consM - --- | Generate an infinite stream by repeating a pure value. --- --- /Pre-release/ -{-# INLINE repeat #-} -repeat :: a -> StreamK m a -repeat a = let x = cons a x in x - --- | Like 'repeatM' but takes a stream 'cons' operation to combine the actions --- in a stream specific manner. A serial cons would repeat the values serially --- while an async cons would repeat concurrently. --- --- /Pre-release/ -repeatMWith :: (m a -> t m a -> t m a) -> m a -> t m a -repeatMWith cns = go - - where - - go m = m `cns` go m - -{-# INLINE replicateMWith #-} -replicateMWith :: (m a -> StreamK m a -> StreamK m a) -> Int -> m a -> StreamK m a -replicateMWith cns n m = go n - - where - - go cnt = if cnt <= 0 then nil else m `cns` go (cnt - 1) - -{-# INLINE fromIndicesMWith #-} -fromIndicesMWith :: - (m a -> StreamK m a -> StreamK m a) -> (Int -> m a) -> StreamK m a -fromIndicesMWith cns gen = go 0 - - where - - go i = mkStream $ \st stp sng yld -> do - foldStreamShared st stp sng yld (gen i `cns` go (i + 1)) - -{-# INLINE iterateMWith #-} -iterateMWith :: Monad m => - (m a -> StreamK m a -> StreamK m a) -> (a -> m a) -> m a -> StreamK m a -iterateMWith cns step = go - - where - - go s = mkStream $ \st stp sng yld -> do - !next <- s - foldStreamShared st stp sng yld (return next `cns` go (step next)) - -{-# INLINE headPartial #-} -headPartial :: Monad m => StreamK m a -> m a -headPartial = foldrM (\x _ -> return x) (error "head of nil") - -{-# INLINE tailPartial #-} -tailPartial :: StreamK m a -> StreamK m a -tailPartial m = mkStream $ \st yld sng stp -> - let stop = error "tail of nil" - single _ = stp - yieldk _ r = foldStream st yld sng stp r - in foldStream st yieldk single stop m - --- | We can define cyclic structures using @let@: --- --- >>> let (a, b) = ([1, b], head a) in (a, b) --- ([1,1],1) --- --- The function @fix@ defined as: --- --- >>> fix f = let x = f x in x --- --- ensures that the argument of a function and its output refer to the same --- lazy value @x@ i.e. the same location in memory. Thus @x@ can be defined --- in terms of itself, creating structures with cyclic references. --- --- >>> f ~(a, b) = ([1, b], head a) --- >>> fix f --- ([1,1],1) --- --- 'Control.Monad.mfix' is essentially the same as @fix@ but for monadic --- values. --- --- Using 'mfix' for streams we can construct a stream in which each element of --- the stream is defined in a cyclic fashion. The argument of the function --- being fixed represents the current element of the stream which is being --- returned by the stream monad. Thus, we can use the argument to construct --- itself. --- --- In the following example, the argument @action@ of the function @f@ --- represents the tuple @(x,y)@ returned by it in a given iteration. We define --- the first element of the tuple in terms of the second. --- --- >>> import System.IO.Unsafe (unsafeInterleaveIO) --- --- >>> :{ --- main = Stream.fold (Fold.drainMapM print) $ StreamK.toStream $ StreamK.mfix f --- where --- f action = StreamK.unCross $ do --- let incr n act = fmap ((+n) . snd) $ unsafeInterleaveIO act --- x <- StreamK.mkCross $ StreamK.fromStream $ Stream.sequence $ Stream.fromList [incr 1 action, incr 2 action] --- y <- StreamK.mkCross $ StreamK.fromStream $ Stream.fromList [4,5] --- return (x, y) --- :} --- --- Note: you cannot achieve this by just changing the order of the monad --- statements because that would change the order in which the stream elements --- are generated. --- --- Note that the function @f@ must be lazy in its argument, that's why we use --- 'unsafeInterleaveIO' on @action@ because IO monad is strict. --- --- /Pre-release/ -{-# INLINE mfix #-} -mfix :: Monad m => (m a -> StreamK m a) -> StreamK m a -mfix f = mkStream $ \st yld sng stp -> - let single a = foldStream st yld sng stp $ a `cons` ys - yieldk a _ = foldStream st yld sng stp $ a `cons` ys - in foldStream st yieldk single stp xs - - where - - -- fix the head element of the stream - xs = fix (f . headPartial) - - -- now fix the tail recursively - ys = mfix (tailPartial . f) - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - --- | --- >>> fromFoldable = Prelude.foldr StreamK.cons StreamK.nil --- --- Construct a stream from a 'Foldable' containing pure values: --- -{-# INLINE fromFoldable #-} -fromFoldable :: Foldable f => f a -> StreamK m a -fromFoldable = Prelude.foldr cons nil - -{-# INLINE fromFoldableM #-} -fromFoldableM :: (Foldable f, Monad m) => f (m a) -> StreamK m a -fromFoldableM = Prelude.foldr consM nil - -------------------------------------------------------------------------------- --- Deconstruction -------------------------------------------------------------------------------- - -{-# INLINE uncons #-} -uncons :: Applicative m => StreamK m a -> m (Maybe (a, StreamK m a)) -uncons m = - let stop = pure Nothing - single a = pure (Just (a, nil)) - yieldk a r = pure (Just (a, r)) - in foldStream defState yieldk single stop m - -{-# INLINE tail #-} -tail :: Applicative m => StreamK m a -> m (Maybe (StreamK m a)) -tail = - let stop = pure Nothing - single _ = pure $ Just nil - yieldk _ r = pure $ Just r - in foldStream defState yieldk single stop - --- | Extract all but the last element of the stream, if any. --- --- Note: This will end up buffering the entire stream. --- --- /Pre-release/ -{-# INLINE init #-} -init :: Applicative m => StreamK m a -> m (Maybe (StreamK m a)) -init = go1 - where - go1 m1 = do - (\case - Nothing -> Nothing - Just (h, t) -> Just $ go h t) <$> uncons m1 - go p m1 = mkStream $ \_ yld sng stp -> - let single _ = sng p - yieldk a x = yld p $ go a x - in foldStream defState yieldk single stp m1 - ------------------------------------------------------------------------------- --- Reordering ------------------------------------------------------------------------------- - --- | Lazy left fold to a stream. -{-# INLINE foldlS #-} -foldlS :: - (StreamK m b -> a -> StreamK m b) -> StreamK m b -> StreamK m a -> StreamK m b -foldlS step = go - where - go acc rest = mkStream $ \st yld sng stp -> - let run x = foldStream st yld sng stp x - stop = run acc - single a = run $ step acc a - yieldk a r = run $ go (step acc a) r - in foldStream (adaptState st) yieldk single stop rest - -{-# INLINE reverse #-} -reverse :: StreamK m a -> StreamK m a -reverse = foldlS (flip cons) nil - ------------------------------------------------------------------------------- --- Running effects ------------------------------------------------------------------------------- - --- | Run an action before evaluating the stream. -{-# INLINE before #-} -before :: Monad m => m b -> StreamK m a -> StreamK m a -before action stream = - mkStream $ \st yld sng stp -> - action >> foldStreamShared st yld sng stp stream - --- | concat . fromEffect -{-# INLINE concatEffect #-} -concatEffect :: Monad m => m (StreamK m a) -> StreamK m a -concatEffect action = - mkStream $ \st yld sng stp -> - action >>= foldStreamShared st yld sng stp - -{-# INLINE concatMapEffect #-} -concatMapEffect :: Monad m => (b -> StreamK m a) -> m b -> StreamK m a -concatMapEffect f action = - mkStream $ \st yld sng stp -> - action >>= foldStreamShared st yld sng stp . f - ------------------------------------------------------------------------------- --- Stream with a cross product style monad instance ------------------------------------------------------------------------------- - --- | A newtype wrapper for the 'StreamK' type adding a cross product style --- monad instance. --- --- A 'Monad' bind behaves like a @for@ loop: --- --- >>> :{ --- Stream.fold Fold.toList $ StreamK.toStream $ StreamK.unCross $ do --- x <- StreamK.mkCross $ StreamK.fromStream $ Stream.fromList [1,2] --- -- Perform the following actions for each x in the stream --- return x --- :} --- [1,2] --- --- Nested monad binds behave like nested @for@ loops: --- --- >>> :{ --- Stream.fold Fold.toList $ StreamK.toStream $ StreamK.unCross $ do --- x <- StreamK.mkCross $ StreamK.fromStream $ Stream.fromList [1,2] --- y <- StreamK.mkCross $ StreamK.fromStream $ Stream.fromList [3,4] --- -- Perform the following actions for each x, for each y --- return (x, y) --- :} --- [(1,3),(1,4),(2,3),(2,4)] --- -newtype CrossStreamK m a = CrossStreamK {unCrossStreamK :: StreamK m a} - deriving (Functor, Semigroup, Monoid, Foldable) - --- | Wrap the 'StreamK' type in a 'CrossStreamK' newtype to enable cross --- product style applicative and monad instances. --- --- This is a type level operation with no runtime overhead. -{-# INLINE mkCross #-} -mkCross :: StreamK m a -> CrossStreamK m a -mkCross = CrossStreamK - --- | Unwrap the 'StreamK' type from 'CrossStreamK' newtype. --- --- This is a type level operation with no runtime overhead. -{-# INLINE unCross #-} -unCross :: CrossStreamK m a -> StreamK m a -unCross = unCrossStreamK - --- Pure (Identity monad) stream instances -deriving instance Traversable (CrossStreamK Identity) -deriving instance IsList (CrossStreamK Identity a) -deriving instance (a ~ Char) => IsString (CrossStreamK Identity a) --- deriving instance Eq a => Eq (CrossStreamK Identity a) --- deriving instance Ord a => Ord (CrossStreamK Identity a) - --- Do not use automatic derivation for this to show as "fromList" rather than --- "fromList Identity". -instance Show a => Show (CrossStreamK Identity a) where - {-# INLINE show #-} - show (CrossStreamK xs) = show xs - -instance Read a => Read (CrossStreamK Identity a) where - {-# INLINE readPrec #-} - readPrec = fmap CrossStreamK readPrec - ------------------------------------------------------------------------------- --- Applicative ------------------------------------------------------------------------------- - --- Note: we need to define all the typeclass operations because we want to --- INLINE them. -instance Monad m => Applicative (CrossStreamK m) where - {-# INLINE pure #-} - pure x = CrossStreamK (fromPure x) - - {-# INLINE (<*>) #-} - (CrossStreamK s1) <*> (CrossStreamK s2) = - CrossStreamK (crossApply s1 s2) - - {-# INLINE liftA2 #-} - liftA2 f x = (<*>) (fmap f x) - - {-# INLINE (*>) #-} - (CrossStreamK s1) *> (CrossStreamK s2) = - CrossStreamK (crossApplySnd s1 s2) - - {-# INLINE (<*) #-} - (CrossStreamK s1) <* (CrossStreamK s2) = - CrossStreamK (crossApplyFst s1 s2) - ------------------------------------------------------------------------------- --- Monad ------------------------------------------------------------------------------- - -instance Monad m => Monad (CrossStreamK m) where - return = pure - - -- Benchmarks better with CPS bind and pure: - -- Prime sieve (25x) - -- n binds, breakAfterSome, filterAllIn, state transformer (~2x) - -- - {-# INLINE (>>=) #-} - (>>=) (CrossStreamK m) f = - CrossStreamK (bindWith append m (unCrossStreamK . f)) - - {-# INLINE (>>) #-} - (>>) = (*>) - ------------------------------------------------------------------------------- --- Transformers ------------------------------------------------------------------------------- - -instance (MonadIO m) => MonadIO (CrossStreamK m) where - liftIO x = CrossStreamK (fromEffect $ liftIO x) - -instance MonadTrans CrossStreamK where - {-# INLINE lift #-} - lift x = CrossStreamK (fromEffect x) - -instance (MonadThrow m) => MonadThrow (CrossStreamK m) where - throwM = lift . throwM diff --git a/src/Streamly/Internal/Data/Stream/Top.hs b/src/Streamly/Internal/Data/Stream/Top.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Top.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Stream.Top +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Top level module that can depend on all other lower level Stream modules. +-- +-- Design notes: +-- +-- The order of arguments in the join operations should ideally be opposite. It +-- should be such that the infinite stream is the last one. The transformation +-- should be on the last argument, so if you curry the functions with all other +-- arguments we get a @Stream -> Stream@ function. The first stream argument +-- may be considered as a config or modifier for the operation. +-- +-- Benefit of changing the order is that we get a more intuitive Stream -> +-- Stream transformation after currying all other arguments. The inner loop +-- streams become arguments for the transformation, more like local modifiers +-- for the global outer stream as the last argument. Thus we can continue using +-- transformations on the outer stream in a composed pipeline. Otherwise we can +-- use flip to flip the order. +-- +-- The fact that the inner stream can be used in the loop multiple times also +-- tells that this is not the real effectful stream, it is more like a pure +-- stream or an array. In fact we may consider using an Identity streams as +-- inner streams in which case these functions will not look nice. +-- +-- Downsides: +-- +-- * Maybe less intuitive to think about, because we usually think the first +-- stream as the outer loop and second as the inner. +-- * Zip and merge operations will continue using the opposite order. +-- * Need to change the order of cross, crossWith operations as well +-- * It will be inconsistent with Data.List. The functions cannot be used as +-- intuitive operators. +-- +-- The choice is similar to concatMap vs bind. concatMap is pipeline +-- composition friendly but bind is user intuition friendly. Another option is +-- to have other functions with a different argument order e.g. flippedCross +-- instead of cross. +-- +-- If we change the order we have to make sure that we have a consistent +-- convention for set-like and the cross join operations. + +module Streamly.Internal.Data.Stream.Top + ( + -- * Straight Joins + -- | These are set-like operations but not exactly set operations because + -- streams are not necessarily sets, they may have duplicated elements. + -- These operations are generic i.e. they work on streams of unconstrained + -- types, therefore, they have quadratic performance characterstics. For + -- better performance using Set or Map structures see the + -- Streamly.Internal.Data.Stream.Container module. + intersectBy + , deleteFirstsBy + , unionBy + + -- Set like operations on sorted streams + , sortedIntersectBy + , sortedDeleteFirstsBy + , sortedUnionBy + + -- * Cross Joins + , innerJoin + + -- Joins on sorted stream + , innerSortedJoin + , leftSortedJoin + , outerSortedJoin + ) +where + +#include "inline.hs" + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.IORef (newIORef, readIORef, modifyIORef') +import Streamly.Internal.Data.Fold.Type (Fold) +import Streamly.Internal.Data.Stream.Type (Stream(..), Step(..), cross) + +import qualified Data.List as List +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Scanl as Scanl +import qualified Streamly.Internal.Data.Stream.Type as Stream +import qualified Streamly.Internal.Data.Stream.Transform as Stream + +import Prelude hiding (filter, zipWith, concatMap, concat) + +#include "DocTestDataStream.hs" + +------------------------------------------------------------------------------ +-- SQL Joins +------------------------------------------------------------------------------ +-- +-- Some references: +-- * https://en.wikipedia.org/wiki/Relational_algebra +-- * https://en.wikipedia.org/wiki/Join_(SQL) + +-- TODO: OrdSet/IntSet/hashmap based versions of these. With Eq only +-- constraint, the best would be to use an Array with linear search. If the +-- second stream is sorted we can also use a binary search, using Ord +-- constraint or an ordering function. +-- +-- For Storables we can cache the second stream into an unboxed array for +-- possibly faster access/compact representation? +-- +-- If we do not want to keep the stream in memory but always read it from the +-- source (disk/network) every time we iterate through it then we can do that +-- too by reading the stream every time, the stream must have immutable state +-- in that case and the user is responsible for the behavior if the stream +-- source changes during iterations. We can also use an Unfold instead of +-- stream. We probably need a way to distinguish streams that can be read +-- mutliple times without any interference (e.g. unfolding a stream using an +-- immutable handle would work i.e. using pread/pwrite instead of maintaining +-- an offset in the handle). + +-- XXX We can do this concurrently. +-- XXX If the second stream is sorted and passed as an Array we could use +-- binary search if we have an Ord instance or Ordering returning function. The +-- time complexity would then become (m x log n). + +-- | Like 'cross' but emits only those tuples where @a == b@ using the supplied +-- equality predicate. This is essentially a @cross intersection@ of two +-- streams. +-- +-- Definition: +-- +-- >>> innerJoin eq s1 s2 = Stream.filter (\(a, b) -> a `eq` b) $ Stream.cross s1 s2 +-- +-- The second (inner) stream must be finite. Moreover, it must be either pure +-- or capable of multiple evaluations. If not then the caller should cache it +-- in an 'Data.Array.Array', if the type does not have an 'Unbox' instance then +-- use the Generic 'Data.Array.Generic.Array'. Convert the array to stream +-- before calling this function. Caching may also improve performance if the +-- stream is expensive to evaluate. +-- +-- If you care about performance this function should be your last choice among +-- all inner joins. 'Streamly.Internal.Data.Unfold.innerJoin' is a much faster +-- fused alternative. 'innerSortedJoin' is a faster alternative when streams +-- are sorted. 'innerOrdJoin' is an order of magnitude faster alternative when +-- the type has an 'Ord' instance. +-- +-- Note: Conceptually, this is a commutative operation. Result includes all the +-- elements from the left and the right stream. The order of streams can be +-- changed without affecting results, except for the ordering within the tuple. +-- +-- Time: O(m x n) +-- +-- /Pre-release/ +{-# INLINE innerJoin #-} +innerJoin :: Monad m => + (a -> b -> Bool) -> Stream m a -> Stream m b -> Stream m (a, b) +innerJoin eq s1 s2 = Stream.filter (\(a, b) -> a `eq` b) $ cross s1 s2 +{- +innerJoin eq s1 s2 = do + -- ConcatMap works faster than bind + Stream.concatMap (\a -> + Stream.concatMap (\b -> + if a `eq` b + then Stream.fromPure (a, b) + else Stream.nil + ) s2 + ) s1 +-} + +-- | A more efficient 'innerJoin' for sorted streams. +-- +-- Space: O(1) +-- +-- Time: O(m + n) +-- +-- /Unimplemented/ +{-# INLINE innerSortedJoin #-} +innerSortedJoin :: + (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, b) +innerSortedJoin = undefined + +-- | A more efficient 'leftJoin' for sorted streams. +-- +-- Space: O(1) +-- +-- Time: O(m + n) +-- +-- /Unimplemented/ +{-# INLINE leftSortedJoin #-} +leftSortedJoin :: -- Monad m => + (a -> b -> Ordering) -> Stream m a -> Stream m b -> Stream m (a, Maybe b) +leftSortedJoin _eq _s1 _s2 = undefined + +-- | A more efficient 'outerJoin' for sorted streams. +-- +-- Space: O(1) +-- +-- Time: O(m + n) +-- +-- /Unimplemented/ +{-# INLINE outerSortedJoin #-} +outerSortedJoin :: -- Monad m => + (a -> b -> Ordering) + -> Stream m a + -> Stream m b + -> Stream m (Maybe a, Maybe b) +outerSortedJoin _eq _s1 _s2 = undefined + +------------------------------------------------------------------------------ +-- Set operations (special joins) +------------------------------------------------------------------------------ +-- +-- TODO: OrdSet/IntSet/hashmap based versions of these. With Eq only constraint +-- the best would be to use an Array with linear search. If the second stream +-- is sorted we can also use a binary search, using Ord constraint. + +-- | Keep only those elements in the first stream that are present in the +-- second stream too. The second stream is folded to a container using the +-- supplied fold and then the elements in the container are looked up using the +-- supplied lookup function. +-- +-- The first stream must be finite and must not block. +{-# INLINE filterStreamWith #-} +filterStreamWith :: Monad m => + Fold m a (f a) + -> (a -> f a -> Bool) + -> Stream m a + -> Stream m a + -> Stream m a +filterStreamWith fld member s1 s2 = + Stream.concatEffect + $ do + xs <- Stream.fold fld s2 + return $ Stream.filter (`member` xs) s1 + +-- XXX instead of folding the second stream to a list we could use it directly. +-- If the user wants they can generate the stream from an array and also call +-- uniq or nub on it. We can provide a convenience Stream -> Stream to cache +-- a finite stream in an array and serve it from the cache. The user can decide +-- what is best based on the context. They can also choose to use a boxed or +-- unboxed array for caching. To force caching we can make the second stream +-- monad type Identity. But that may be less flexible. One option is to use +-- cachedIntersectBy etc for automatic caching. + +-- | 'intersectBy' returns a subsequence of the first stream which intersects +-- with the second stream. Note that this is not a commutative operation unlike +-- a set intersection, because of duplicate elements in the stream the order of +-- the streams matters. This is similar to 'Data.List.intersectBy'. Note that +-- intersectBy is a special case of 'innerJoin'. +-- +-- >>> f s1 s2 = Stream.fold Fold.toList $ Stream.intersectBy (==) (Stream.fromList s1) (Stream.fromList s2) +-- >>> f [1,3,4,4,5] [2,3,4,5,5] +-- [3,4,4,5] +-- +-- First stream can be infinite, the second stream must be finite and must be +-- capable of multiple evaluations. +-- +-- Space: O(n) where @n@ is the number of elements in the second stream. +-- +-- Time: O(m x n) where @m@ is the number of elements in the first stream and +-- @n@ is the number of elements in the second stream. +-- +-- /Pre-release/ +{-# INLINE intersectBy #-} +intersectBy :: Monad m => + (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a +intersectBy eq = + -- XXX Use an (unboxed) array instead. + filterStreamWith + (Fold.postscanlMaybe (Scanl.uniqBy eq) Fold.toListRev) + (List.any . eq) + +------------------------------------------------------------------------------- +-- Intersection of sorted streams +------------------------------------------------------------------------------- + +-- XXX The sort order is not important as long both the streams have the same +-- sort order. We need to move only in one direction in each stream. +-- XXX Fix the argument order to use the same behavior as intersectBy. + +-- | Like 'intersectBy' but assumes that the input streams are sorted in +-- ascending order. To use it on streams sorted in descending order pass an +-- inverted comparison function returning GT for less than and LT for greater +-- than. +-- +-- Both streams can be infinite. +-- +-- Space: O(1) +-- +-- Time: O(m+n) +-- +-- /Pre-release/ +{-# INLINE_NORMAL sortedIntersectBy #-} +sortedIntersectBy :: Monad m => + (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a +sortedIntersectBy cmp (Stream stepa ta) (Stream stepb tb) = + Stream step + ( ta -- left stream state + , tb -- right stream state + , Nothing -- left value + , Nothing -- right value + ) + + where + + {-# INLINE_LATE step #-} + -- step 1, fetch the first value + step gst (sa, sb, Nothing, b) = do + r <- stepa gst sa + return $ case r of + Yield a sa' -> Skip (sa', sb, Just a, b) -- step 2/3 + Skip sa' -> Skip (sa', sb, Nothing, b) + Stop -> Stop + + -- step 2, fetch the second value + step gst (sa, sb, a@(Just _), Nothing) = do + r <- stepb gst sb + return $ case r of + Yield b sb' -> Skip (sa, sb', a, Just b) -- step 3 + Skip sb' -> Skip (sa, sb', a, Nothing) + Stop -> Stop + + -- step 3, compare the two values + step _ (sa, sb, Just a, Just b) = do + let res = cmp a b + return $ case res of + GT -> Skip (sa, sb, Just a, Nothing) -- step 2 + LT -> Skip (sa, sb, Nothing, Just b) -- step 1 + EQ -> Yield a (sa, sb, Nothing, Just b) -- step 1 + +-- | Returns a subsequence of the first stream, deleting first occurrences of +-- those elements that are present in the second stream. Note that this is not +-- a commutative operation. This is similar to the 'Data.List.deleteFirstsBy'. +-- +-- >>> f xs ys = Stream.fold Fold.toList $ Stream.deleteFirstsBy (==) (Stream.fromList xs) (Stream.fromList ys) +-- >>> f [1,2,2,3,3,5] [1,2,2,3,4] +-- [3,5] +-- +-- The following holds: +-- +-- > deleteFirstsBy (==) (Stream.ordNub s2 `append` s1) s2 === s1 +-- > deleteFirstsBy (==) (Stream.ordNub s2 `interleave` s1) s2 === s1 +-- +-- First stream can be infinite, second stream must be finite. +-- +-- Space: O(m) where @m@ is the number of elements in the first stream. +-- +-- Time: O(m x n) where @m@ is the number of elements in the first stream and +-- @n@ is the number of elements in the second stream. +-- +-- /Pre-release/ +{-# INLINE deleteFirstsBy #-} +deleteFirstsBy :: Monad m => + (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a +deleteFirstsBy eq s2 s1 = + -- XXX s2 can be a sorted mutable array and we can use binary + -- search to find. Mark the element deleted, count the deletions + -- and reconsolidate the array when a min number of elements is + -- deleted. + + -- XXX Use StreamK or list as second argument instead of Stream to avoid + -- concatEffect? + Stream.concatEffect $ do + xs <- Stream.toList s1 + -- It reverses the list but that is fine. + let del x = + List.foldl' (\(ys,res) y -> + if not res && x `eq` y + then (ys, True) + else (y:ys, res)) ([], False) + g (ys,_) x = + let (ys1, deleted) = del x ys + in if deleted + then (ys1, Nothing) + else (ys1, Just x) + in return + $ Stream.catMaybes + $ fmap snd + $ Stream.postscanl' g (xs, Nothing) s2 + +-- | A more efficient 'deleteFirstsBy' for streams sorted in ascending order. +-- +-- Both streams can be infinite. +-- +-- Space: O(1) +-- +-- /Unimplemented/ +{-# INLINE sortedDeleteFirstsBy #-} +sortedDeleteFirstsBy :: -- (Monad m) => + (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a +sortedDeleteFirstsBy _eq _s1 _s2 = undefined + +-- XXX Remove the MonadIO constraint. We can just cache one stream and then +-- implement using differenceEqBy. + +-- | Returns the first stream appended with those unique elements from the +-- second stream that are not already present in the first stream. Note that +-- this is not a commutative operation unlike a set union, argument order +-- matters. The behavior is similar to 'Data.List.unionBy'. +-- +-- Equivalent to the following except that @s2@ is evaluated only once: +-- +-- >>> unionBy eq s1 s2 = s1 `Stream.append` Stream.deleteFirstsBy eq s1 (Stream.ordNub s2) +-- +-- Example: +-- +-- >>> f s1 s2 = Stream.fold Fold.toList $ Stream.unionBy (==) (Stream.fromList s1) (Stream.fromList s2) +-- >>> f [1,2,2,4] [1,1,2,3,3] +-- [1,2,2,4,3] +-- +-- First stream can be infinite, but second stream must be finite. Note that if +-- the first stream is infinite the union means just the first stream. Thus +-- union is useful only when both streams are finite. See 'sortedUnionBy' where +-- union can work on infinite streams if they are sorted. +-- +-- Space: O(n) +-- +-- Time: O(m x n) +-- +-- /Pre-release/ +{-# INLINE unionBy #-} +unionBy :: MonadIO m => + (a -> a -> Bool) -> Stream m a -> Stream m a -> Stream m a +unionBy eq s2 s1 = + Stream.concatEffect + $ do + -- XXX use a rewrite rule such that if a list converted to stream + -- is passed to unionBy then this becomes an identity operation. + xs <- Stream.fold Fold.toList s1 + -- XXX we can use postscanlMAfter' instead of IORef + ref <- liftIO $ newIORef $! List.nubBy eq xs + let f x = do + liftIO $ modifyIORef' ref (List.deleteBy eq x) + return x + s3 = Stream.concatEffect + $ do + xs1 <- liftIO $ readIORef ref + return $ Stream.fromList xs1 + return $ Stream.mapM f s2 `Stream.append` s3 + +-- | A more efficient 'unionBy' for sorted streams. +-- +-- Note that the behavior is different from 'unionBy'. In 'unionBy' we append +-- the unique elements from second stream only after exhausting the first one +-- whereas in sorted streams we can determine unique elements early even when +-- we are going through the first stream. Thus the result is an interleaving of +-- the two streams, merging those elements from the second stream that are not +-- present in the first. +-- +-- Space: O(1) +-- +-- Both streams can be infinite. +-- +-- /Unimplemented/ +{-# INLINE sortedUnionBy #-} +sortedUnionBy :: -- (Monad m) => + (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a +sortedUnionBy _eq _s1 _s2 = undefined diff --git a/src/Streamly/Internal/Data/Stream/Transform.hs b/src/Streamly/Internal/Data/Stream/Transform.hs --- a/src/Streamly/Internal/Data/Stream/Transform.hs +++ b/src/Streamly/Internal/Data/Stream/Transform.hs @@ -1,1056 +1,2289 @@ --- | --- Module : Streamly.Internal.Data.Stream.Transform --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Stream.Transform - ( - -- * Piping - -- | Pass through a 'Pipe'. - transform - - -- * Folding - , foldrS - - -- * Mapping - -- | Stateless one-to-one maps. - , sequence - , mapM - - -- * Mapping Side Effects (Observation) - -- | See also the intersperse*_ combinators. - , trace - , trace_ - , tap - - -- * Scanning - , scan - , scanMany - , postscan - , smapM - , scanlMAfter' - - -- * Filtering - -- | Produce a subset of the stream using criteria based on the values of - -- the elements. We can use a concatMap and scan for filtering but these - -- combinators are more efficient and convenient. - - -- mapMaybeM is a general filtering combinator as we can map the stream to - -- Just/Nothing using any stateful fold and then use this to filter out. - , mapMaybeM - , mapMaybe - , catMaybes - , scanMaybe - - , with - , deleteBy - , filter - , filterM - - -- Stateful/scanning filters - , uniq - , uniqBy - , prune - , repeated - - -- * Trimming - -- | Produce a subset of the stream trimmed at ends. - - , take - , takeWhile - , takeWhileM - , takeWhileLast - , takeWhileAround - , drop - , dropLast - , dropWhile - , dropWhileM - , dropWhileLast - , dropWhileAround - - -- * Position Indexing - , indexed - , indexedR - - -- * Time Indexing - , timestamped - , timestampWith - , timeIndexed - , timeIndexWith - - -- * Searching - , findIndices -- XXX indicesBy - , elemIndices -- XXX indicesOf - - -- * Rolling map - -- | Map using the previous element. - , rollingMapM - , rollingMap - , rollingMap2 - - -- Merge - - -- * Inserting Elements - -- | Produce a superset of the stream. This is the opposite of - -- filtering/sampling. We can always use concatMap and scan for inserting - -- but these combinators are more efficient and convenient. - - -- Element agnostic (Opposite of sampling) - , intersperse - , intersperseM -- XXX naming - , intersperseMWith - - , intersperseMSuffix - , intersperseMSuffixWith - - -- , interspersePrefix - -- , interspersePrefixBySpan - - -- * Inserting Side Effects/Time - , intersperseM_ -- XXX naming - , delay - , intersperseMSuffix_ - , delayPost - , intersperseMPrefix_ - , delayPre - - -- * Element Aware Insertion - -- | Opposite of filtering - , insertBy - -- , intersperseByBefore - -- , intersperseByAfter - - -- Fold and Unfold, Buffering - - -- * Reordering - , reverse - , reverse' - , reassembleBy - - -- * Either Streams - -- Move these to Streamly.Data.Either.Stream? - , catLefts - , catRights - , catEithers - ) -where - -#include "inline.hs" - -import Control.Concurrent (threadDelay) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Either (fromLeft, isLeft, isRight, fromRight) -import Data.Maybe (isJust, fromJust) - -import Streamly.Internal.Data.Fold.Type (Fold) -import Streamly.Internal.Data.Pipe (Pipe) -import Streamly.Internal.Data.Time.Units (AbsTime, RelTime64) - -import qualified Streamly.Internal.Data.Fold as FL --- import qualified Streamly.Internal.Data.Fold.Window as Window -import qualified Streamly.Internal.Data.Stream.StreamD.Transform as D -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - - -import Streamly.Internal.Data.Stream.Bottom -import Streamly.Internal.Data.Stream.Type - -import Prelude hiding - ( filter, drop, dropWhile, take, takeWhile, foldr, map, mapM, sequence - , reverse, foldr1 , repeat, scanl, scanl1, zipWith) - --- --- $setup --- >>> :m --- >>> import Control.Concurrent (threadDelay) --- >>> import Control.Monad (void) --- >>> import Control.Monad.IO.Class (MonadIO (liftIO)) --- >>> import Data.Either (fromLeft, fromRight, isLeft, isRight, either) --- >>> import Data.Function ((&)) --- >>> import Data.Maybe (fromJust, isJust) --- >>> import Prelude hiding (filter, drop, dropWhile, take, takeWhile, foldr, map, mapM, sequence, reverse, foldr1 , scanl, scanl1) --- >>> import Streamly.Internal.Data.Stream (Stream) --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Unfold as Unfold --- >>> import qualified Streamly.Internal.Data.Fold as Fold (filtering) --- >>> import qualified Streamly.Internal.Data.Fold.Window as Window --- >>> import qualified Streamly.Internal.Data.Stream as Stream --- >>> import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) --- --- >>> hSetBuffering stdout LineBuffering - --- XXX because of the use of D.cons for appending, folds and scans have --- quadratic complexity when iterated over a stream. We should use StreamK for --- linear performance on iteration. - ------------------------------------------------------------------------------- --- Piping ------------------------------------------------------------------------------- - --- | Use a 'Pipe' to transform a stream. --- --- /Pre-release/ --- -{-# INLINE transform #-} -transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b -transform pipe xs = fromStreamD $ D.transform pipe (toStreamD xs) - ------------------------------------------------------------------------------- --- Transformation Folds ------------------------------------------------------------------------------- - --- | Right fold to a streaming monad. --- --- > foldrS Stream.cons Stream.nil === id --- --- 'foldrS' can be used to perform stateless stream to stream transformations --- like map and filter in general. It can be coupled with a scan to perform --- stateful transformations. However, note that the custom map and filter --- routines can be much more efficient than this due to better stream fusion. --- --- >>> input = Stream.fromList [1..5] --- >>> Stream.fold Fold.toList $ Stream.foldrS Stream.cons Stream.nil input --- [1,2,3,4,5] --- --- Find if any element in the stream is 'True': --- --- >>> step x xs = if odd x then Stream.fromPure True else xs --- >>> input = Stream.fromList (2:4:5:undefined) :: Stream IO Int --- >>> Stream.fold Fold.toList $ Stream.foldrS step (Stream.fromPure False) input --- [True] --- --- Map (+2) on odd elements and filter out the even elements: --- --- >>> step x xs = if odd x then (x + 2) `Stream.cons` xs else xs --- >>> input = Stream.fromList [1..5] :: Stream IO Int --- >>> Stream.fold Fold.toList $ Stream.foldrS step Stream.nil input --- [3,5,7] --- --- /Pre-release/ -{-# INLINE foldrS #-} -foldrS :: - (a -> Stream m b -> Stream m b) - -> Stream m b - -> Stream m a - -> Stream m b -foldrS f z xs = - fromStreamK - $ K.foldrS - (\y ys -> toStreamK $ f y (fromStreamK ys)) - (toStreamK z) - (toStreamK xs) - ------------------------------------------------------------------------------- --- Transformation by Mapping ------------------------------------------------------------------------------- - --- | --- >>> mapM f = Stream.sequence . fmap f --- --- Apply a monadic function to each element of the stream and replace it with --- the output of the resulting action. --- --- >>> s = Stream.fromList ["a", "b", "c"] --- >>> Stream.fold Fold.drain $ Stream.mapM putStr s --- abc --- -{-# INLINE mapM #-} -mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b -mapM f m = fromStreamK $ D.toStreamK $ D.mapM f $ toStreamD m - --- | --- >>> sequence = Stream.mapM id --- --- Replace the elements of a stream of monadic actions with the outputs of --- those actions. --- --- >>> s = Stream.fromList [putStr "a", putStr "b", putStrLn "c"] --- >>> Stream.fold Fold.drain $ Stream.sequence s --- abc --- -{-# INLINE sequence #-} -sequence :: Monad m => Stream m (m a) -> Stream m a -sequence = mapM id - ------------------------------------------------------------------------------- --- Mapping side effects ------------------------------------------------------------------------------- - --- | Tap the data flowing through a stream into a 'Fold'. For example, you may --- add a tap to log the contents flowing through the stream. The fold is used --- only for effects, its result is discarded. --- --- @ --- Fold m a b --- | --- -----stream m a ---------------stream m a----- --- --- @ --- --- >>> s = Stream.enumerateFromTo 1 2 --- >>> Stream.fold Fold.drain $ Stream.tap (Fold.drainMapM print) s --- 1 --- 2 --- --- Compare with 'trace'. --- -{-# INLINE tap #-} -tap :: Monad m => FL.Fold m a b -> Stream m a -> Stream m a -tap f xs = fromStreamD $ D.tap f (toStreamD xs) - --- | Apply a monadic function to each element flowing through the stream and --- discard the results. --- --- >>> s = Stream.enumerateFromTo 1 2 --- >>> Stream.fold Fold.drain $ Stream.trace print s --- 1 --- 2 --- --- Compare with 'tap'. --- -{-# INLINE trace #-} -trace :: Monad m => (a -> m b) -> Stream m a -> Stream m a -trace f = mapM (\x -> void (f x) >> return x) - --- | Perform a side effect before yielding each element of the stream and --- discard the results. --- --- >>> s = Stream.enumerateFromTo 1 2 --- >>> Stream.fold Fold.drain $ Stream.trace_ (print "got here") s --- "got here" --- "got here" --- --- Same as 'intersperseMPrefix_' but always serial. --- --- See also: 'trace' --- --- /Pre-release/ -{-# INLINE trace_ #-} -trace_ :: Monad m => m b -> Stream m a -> Stream m a -trace_ eff = fromStreamD . D.mapM (\x -> eff >> return x) . toStreamD - -------------------------------------------------------------------------------- --- Scanning -------------------------------------------------------------------------------- - --- | @scanlMAfter' accumulate initial done stream@ is like 'scanlM'' except --- that it provides an additional @done@ function to be applied on the --- accumulator when the stream stops. The result of @done@ is also emitted in --- the stream. --- --- This function can be used to allocate a resource in the beginning of the --- scan and release it when the stream ends or to flush the internal state of --- the scan at the end. --- --- /Pre-release/ --- -{-# INLINE scanlMAfter' #-} -scanlMAfter' :: - Monad m - => (b -> a -> m b) - -> m b - -> (b -> m b) - -> Stream m a - -> Stream m b -scanlMAfter' step initial done stream = - fromStreamD $ D.scanlMAfter' step initial done $ toStreamD stream - ------------------------------------------------------------------------------- --- Scanning with a Fold ------------------------------------------------------------------------------- - --- XXX It may be useful to have a version of scan where we can keep the --- accumulator independent of the value emitted. So that we do not necessarily --- have to keep a value in the accumulator which we are not using. We can pass --- an extraction function that will take the accumulator and the current value --- of the element and emit the next value in the stream. That will also make it --- possible to modify the accumulator after using it. In fact, the step function --- can return new accumulator and the value to be emitted. The signature would --- be more like mapAccumL. - --- | Strict left scan. Scan a stream using the given monadic fold. --- --- >>> s = Stream.fromList [1..10] --- >>> Stream.fold Fold.toList $ Stream.takeWhile (< 10) $ Stream.scan Fold.sum s --- [0,1,3,6] --- --- See also: 'usingStateT' --- - --- EXPLANATION: --- >>> scanl' step z = Stream.scan (Fold.foldl' step z) --- --- Like 'map', 'scanl'' too is a one to one transformation, --- however it adds an extra element. --- --- >>> s = Stream.fromList [1,2,3,4] --- >>> Stream.fold Fold.toList $ scanl' (+) 0 s --- [0,1,3,6,10] --- --- >>> Stream.fold Fold.toList $ scanl' (flip (:)) [] s --- [[],[1],[2,1],[3,2,1],[4,3,2,1]] --- --- The output of 'scanl'' is the initial value of the accumulator followed by --- all the intermediate steps and the final result of 'foldl''. --- --- By streaming the accumulated state after each fold step, we can share the --- state across multiple stages of stream composition. Each stage can modify or --- extend the state, do some processing with it and emit it for the next stage, --- thus modularizing the stream processing. This can be useful in --- stateful or event-driven programming. --- --- Consider the following monolithic example, computing the sum and the product --- of the elements in a stream in one go using a @foldl'@: --- --- >>> foldl' step z = Stream.fold (Fold.foldl' step z) --- >>> foldl' (\(s, p) x -> (s + x, p * x)) (0,1) s --- (10,24) --- --- Using @scanl'@ we can make it modular by computing the sum in the first --- stage and passing it down to the next stage for computing the product: --- --- >>> :{ --- foldl' (\(_, p) (s, x) -> (s, p * x)) (0,1) --- $ scanl' (\(s, _) x -> (s + x, x)) (0,1) --- $ Stream.fromList [1,2,3,4] --- :} --- (10,24) --- --- IMPORTANT: 'scanl'' evaluates the accumulator to WHNF. To avoid building --- lazy expressions inside the accumulator, it is recommended that a strict --- data structure is used for accumulator. --- -{-# INLINE scan #-} -scan :: Monad m => Fold m a b -> Stream m a -> Stream m b -scan fld m = fromStreamD $ D.scan fld $ toStreamD m - --- | Like 'scan' but restarts scanning afresh when the scanning fold --- terminates. --- -{-# INLINE scanMany #-} -scanMany :: Monad m => Fold m a b -> Stream m a -> Stream m b -scanMany fld m = fromStreamD $ D.scanMany fld $ toStreamD m - ------------------------------------------------------------------------------- --- Filtering ------------------------------------------------------------------------------- - --- | Modify a @Stream m a -> Stream m a@ stream transformation that accepts a --- predicate @(a -> b)@ to accept @((s, a) -> b)@ instead, provided a --- transformation @Stream m a -> Stream m (s, a)@. Convenient to filter with --- index or time. --- --- >>> filterWithIndex = Stream.with Stream.indexed Stream.filter --- --- /Pre-release/ -{-# INLINE with #-} -with :: Monad m => - (Stream m a -> Stream m (s, a)) - -> (((s, a) -> b) -> Stream m (s, a) -> Stream m (s, a)) - -> (((s, a) -> b) -> Stream m a -> Stream m a) -with f comb g = fmap snd . comb g . f - --- | Include only those elements that pass a predicate. --- --- >>> filter p = Stream.filterM (return . p) --- >>> filter p = Stream.mapMaybe (\x -> if p x then Just x else Nothing) --- >>> filter p = Stream.scanMaybe (Fold.filtering p) --- -{-# INLINE filter #-} -filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a --- filter p = scanMaybe (FL.filtering p) -filter p m = fromStreamD $ D.filter p $ toStreamD m - --- | Same as 'filter' but with a monadic predicate. --- --- >>> f p x = p x >>= \r -> return $ if r then Just x else Nothing --- >>> filterM p = Stream.mapMaybeM (f p) --- -{-# INLINE filterM #-} -filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a -filterM p m = fromStreamD $ D.filterM p $ toStreamD m - --- | Drop repeated elements that are adjacent to each other using the supplied --- comparison function. --- --- >>> uniq = Stream.uniqBy (==) --- --- To strip duplicate path separators: --- --- >>> input = Stream.fromList "//a//b" --- >>> f x y = x == '/' && y == '/' --- >>> Stream.fold Fold.toList $ Stream.uniqBy f input --- "/a/b" --- --- Space: @O(1)@ --- --- /Pre-release/ --- -{-# INLINE uniqBy #-} -uniqBy :: Monad m => - (a -> a -> Bool) -> Stream m a -> Stream m a --- uniqBy eq = scanMaybe (FL.uniqBy eq) -uniqBy eq = catMaybes . rollingMap f - - where - - f pre curr = - case pre of - Nothing -> Just curr - Just x -> if x `eq` curr then Nothing else Just curr - --- | Drop repeated elements that are adjacent to each other. --- --- >>> uniq = Stream.uniqBy (==) --- -{-# INLINE uniq #-} -uniq :: (Eq a, Monad m) => Stream m a -> Stream m a --- uniq = scanMaybe FL.uniq -uniq = fromStreamD . D.uniq . toStreamD - --- | Strip all leading and trailing occurrences of an element passing a --- predicate and make all other consecutive occurrences uniq. --- --- >> prune p = Stream.dropWhileAround p $ Stream.uniqBy (x y -> p x && p y) --- --- @ --- > Stream.prune isSpace (Stream.fromList " hello world! ") --- "hello world!" --- --- @ --- --- Space: @O(1)@ --- --- /Unimplemented/ -{-# INLINE prune #-} -prune :: - -- (Monad m, Eq a) => - (a -> Bool) -> Stream m a -> Stream m a -prune = error "Not implemented yet!" - --- Possible implementation: --- @repeated = --- Stream.catMaybes . Stream.parseMany (Parser.groupBy (==) Fold.repeated)@ --- --- 'Fold.repeated' should return 'Just' when repeated, and 'Nothing' for a --- single element. - --- | Emit only repeated elements, once. --- --- /Unimplemented/ -repeated :: -- (Monad m, Eq a) => - Stream m a -> Stream m a -repeated = undefined - --- | Deletes the first occurrence of the element in the stream that satisfies --- the given equality predicate. --- --- >>> input = Stream.fromList [1,3,3,5] --- >>> Stream.fold Fold.toList $ Stream.deleteBy (==) 3 input --- [1,3,5] --- -{-# INLINE deleteBy #-} -deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a --- deleteBy cmp x = scanMaybe (FL.deleteBy cmp x) -deleteBy cmp x m = fromStreamD $ D.deleteBy cmp x (toStreamD m) - ------------------------------------------------------------------------------- --- Trimming ------------------------------------------------------------------------------- - --- | Same as 'takeWhile' but with a monadic predicate. --- -{-# INLINE takeWhileM #-} -takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a --- takeWhileM p = scanMaybe (FL.takingEndByM_ (\x -> not <$> p x)) -takeWhileM p m = fromStreamD $ D.takeWhileM p $ toStreamD m - --- | Take all consecutive elements at the end of the stream for which the --- predicate is true. --- --- O(n) space, where n is the number elements taken. --- --- /Unimplemented/ -{-# INLINE takeWhileLast #-} -takeWhileLast :: -- Monad m => - (a -> Bool) -> Stream m a -> Stream m a -takeWhileLast = undefined -- fromStreamD $ D.takeWhileLast n $ toStreamD m - --- | Like 'takeWhile' and 'takeWhileLast' combined. --- --- O(n) space, where n is the number elements taken from the end. --- --- /Unimplemented/ -{-# INLINE takeWhileAround #-} -takeWhileAround :: -- Monad m => - (a -> Bool) -> Stream m a -> Stream m a -takeWhileAround = undefined -- fromStreamD $ D.takeWhileAround n $ toStreamD m - --- | Drop elements in the stream as long as the predicate succeeds and then --- take the rest of the stream. --- -{-# INLINE dropWhile #-} -dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a --- dropWhile p = scanMaybe (FL.droppingWhile p) -dropWhile p m = fromStreamD $ D.dropWhile p $ toStreamD m - --- | Same as 'dropWhile' but with a monadic predicate. --- -{-# INLINE dropWhileM #-} -dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a --- dropWhileM p = scanMaybe (FL.droppingWhileM p) -dropWhileM p m = fromStreamD $ D.dropWhileM p $ toStreamD m - --- | Drop @n@ elements at the end of the stream. --- --- O(n) space, where n is the number elements dropped. --- --- /Unimplemented/ -{-# INLINE dropLast #-} -dropLast :: -- Monad m => - Int -> Stream m a -> Stream m a -dropLast = undefined -- fromStreamD $ D.dropLast n $ toStreamD m - --- | Drop all consecutive elements at the end of the stream for which the --- predicate is true. --- --- O(n) space, where n is the number elements dropped. --- --- /Unimplemented/ -{-# INLINE dropWhileLast #-} -dropWhileLast :: -- Monad m => - (a -> Bool) -> Stream m a -> Stream m a -dropWhileLast = undefined -- fromStreamD $ D.dropWhileLast n $ toStreamD m - --- | Like 'dropWhile' and 'dropWhileLast' combined. --- --- O(n) space, where n is the number elements dropped from the end. --- --- /Unimplemented/ -{-# INLINE dropWhileAround #-} -dropWhileAround :: -- Monad m => - (a -> Bool) -> Stream m a -> Stream m a -dropWhileAround = undefined -- fromStreamD $ D.dropWhileAround n $ toStreamD m - ------------------------------------------------------------------------------- --- Inserting Elements ------------------------------------------------------------------------------- - --- | @insertBy cmp elem stream@ inserts @elem@ before the first element in --- @stream@ that is less than @elem@ when compared using @cmp@. --- --- >>> insertBy cmp x = Stream.mergeBy cmp (Stream.fromPure x) --- --- >>> input = Stream.fromList [1,3,5] --- >>> Stream.fold Fold.toList $ Stream.insertBy compare 2 input --- [1,2,3,5] --- -{-# INLINE insertBy #-} -insertBy ::Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a -insertBy cmp x m = fromStreamD $ D.insertBy cmp x (toStreamD m) - --- | Insert a pure value between successive elements of a stream. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.intersperse ',' input --- "h,e,l,l,o" --- -{-# INLINE intersperse #-} -intersperse :: Monad m => a -> Stream m a -> Stream m a -intersperse a = fromStreamD . D.intersperse a . toStreamD - --- | Insert a side effect before consuming an element of a stream except the --- first one. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.drain $ Stream.trace putChar $ Stream.intersperseM_ (putChar '.') input --- h.e.l.l.o --- --- /Pre-release/ -{-# INLINE intersperseM_ #-} -intersperseM_ :: Monad m => m b -> Stream m a -> Stream m a -intersperseM_ m = fromStreamD . D.intersperseM_ m . toStreamD - --- | Intersperse a monadic action into the input stream after every @n@ --- elements. --- --- >> input = Stream.fromList "hello" --- >> Stream.fold Fold.toList $ Stream.intersperseMWith 2 (return ',') input --- "he,ll,o" --- --- /Unimplemented/ -{-# INLINE intersperseMWith #-} -intersperseMWith :: -- Monad m => - Int -> m a -> Stream m a -> Stream m a -intersperseMWith _n _f _xs = undefined - --- | Insert an effect and its output after consuming an element of a stream. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.trace putChar $ Stream.intersperseMSuffix (putChar '.' >> return ',') input --- h.,e.,l.,l.,o.,"h,e,l,l,o," --- --- /Pre-release/ -{-# INLINE intersperseMSuffix #-} -intersperseMSuffix :: Monad m => m a -> Stream m a -> Stream m a -intersperseMSuffix m = fromStreamD . D.intersperseMSuffix m . toStreamD - --- | Insert a side effect after consuming an element of a stream. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.intersperseMSuffix_ (threadDelay 1000000) input --- "hello" --- --- /Pre-release/ --- -{-# INLINE intersperseMSuffix_ #-} -intersperseMSuffix_ :: Monad m => m b -> Stream m a -> Stream m a -intersperseMSuffix_ m = fromStreamD . D.intersperseMSuffix_ m . toStreamD - --- XXX Use an offset argument, like tapOffsetEvery - --- | Like 'intersperseMSuffix' but intersperses an effectful action into the --- input stream after every @n@ elements and after the last element. --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.intersperseMSuffixWith 2 (return ',') input --- "he,ll,o," --- --- /Pre-release/ --- -{-# INLINE intersperseMSuffixWith #-} -intersperseMSuffixWith :: Monad m - => Int -> m a -> Stream m a -> Stream m a -intersperseMSuffixWith n eff = - fromStreamD . D.intersperseMSuffixWith n eff . toStreamD - --- | Insert a side effect before consuming an element of a stream. --- --- Definition: --- --- >>> intersperseMPrefix_ m = Stream.mapM (\x -> void m >> return x) --- --- >>> input = Stream.fromList "hello" --- >>> Stream.fold Fold.toList $ Stream.trace putChar $ Stream.intersperseMPrefix_ (putChar '.' >> return ',') input --- .h.e.l.l.o"hello" --- --- Same as 'trace_'. --- --- /Pre-release/ --- -{-# INLINE intersperseMPrefix_ #-} -intersperseMPrefix_ :: Monad m => m b -> Stream m a -> Stream m a -intersperseMPrefix_ m = mapM (\x -> void m >> return x) - ------------------------------------------------------------------------------- --- Inserting Time ------------------------------------------------------------------------------- - --- XXX This should be in Prelude, should we export this as a helper function? - --- | Block the current thread for specified number of seconds. -{-# INLINE sleep #-} -sleep :: MonadIO m => Double -> m () -sleep n = liftIO $ threadDelay $ round $ n * 1000000 - --- | Introduce a delay of specified seconds between elements of the stream. --- --- Definition: --- --- >>> sleep n = liftIO $ threadDelay $ round $ n * 1000000 --- >>> delay = Stream.intersperseM_ . sleep --- --- Example: --- --- >>> input = Stream.enumerateFromTo 1 3 --- >>> Stream.fold (Fold.drainMapM print) $ Stream.delay 1 input --- 1 --- 2 --- 3 --- -{-# INLINE delay #-} -delay :: MonadIO m => Double -> Stream m a -> Stream m a -delay = intersperseM_ . sleep - --- | Introduce a delay of specified seconds after consuming an element of a --- stream. --- --- Definition: --- --- >>> sleep n = liftIO $ threadDelay $ round $ n * 1000000 --- >>> delayPost = Stream.intersperseMSuffix_ . sleep --- --- Example: --- --- >>> input = Stream.enumerateFromTo 1 3 --- >>> Stream.fold (Fold.drainMapM print) $ Stream.delayPost 1 input --- 1 --- 2 --- 3 --- --- /Pre-release/ --- -{-# INLINE delayPost #-} -delayPost :: MonadIO m => Double -> Stream m a -> Stream m a -delayPost n = intersperseMSuffix_ $ liftIO $ threadDelay $ round $ n * 1000000 - --- | Introduce a delay of specified seconds before consuming an element of a --- stream. --- --- Definition: --- --- >>> sleep n = liftIO $ threadDelay $ round $ n * 1000000 --- >>> delayPre = Stream.intersperseMPrefix_. sleep --- --- Example: --- --- >>> input = Stream.enumerateFromTo 1 3 --- >>> Stream.fold (Fold.drainMapM print) $ Stream.delayPre 1 input --- 1 --- 2 --- 3 --- --- /Pre-release/ --- -{-# INLINE delayPre #-} -delayPre :: MonadIO m => Double -> Stream m a -> Stream m a -delayPre = intersperseMPrefix_. sleep - ------------------------------------------------------------------------------- --- Reorder in sequence ------------------------------------------------------------------------------- - --- | Buffer until the next element in sequence arrives. The function argument --- determines the difference in sequence numbers. This could be useful in --- implementing sequenced streams, for example, TCP reassembly. --- --- /Unimplemented/ --- -{-# INLINE reassembleBy #-} -reassembleBy - :: -- Monad m => - Fold m a b - -> (a -> a -> Int) - -> Stream m a - -> Stream m b -reassembleBy = undefined - ------------------------------------------------------------------------------- --- Position Indexing ------------------------------------------------------------------------------- - --- | --- >>> f = Fold.foldl' (\(i, _) x -> (i + 1, x)) (-1,undefined) --- >>> indexed = Stream.postscan f --- >>> indexed = Stream.zipWith (,) (Stream.enumerateFrom 0) --- >>> indexedR n = fmap (\(i, a) -> (n - i, a)) . indexed --- --- Pair each element in a stream with its index, starting from index 0. --- --- >>> Stream.fold Fold.toList $ Stream.indexed $ Stream.fromList "hello" --- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')] --- -{-# INLINE indexed #-} -indexed :: Monad m => Stream m a -> Stream m (Int, a) --- indexed = scanMaybe FL.indexing -indexed = fromStreamD . D.indexed . toStreamD - --- | --- >>> f n = Fold.foldl' (\(i, _) x -> (i - 1, x)) (n + 1,undefined) --- >>> indexedR n = Stream.postscan (f n) --- --- >>> s n = Stream.enumerateFromThen n (n - 1) --- >>> indexedR n = Stream.zipWith (,) (s n) --- --- Pair each element in a stream with its index, starting from the --- given index @n@ and counting down. --- --- >>> Stream.fold Fold.toList $ Stream.indexedR 10 $ Stream.fromList "hello" --- [(10,'h'),(9,'e'),(8,'l'),(7,'l'),(6,'o')] --- -{-# INLINE indexedR #-} -indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a) --- indexedR n = scanMaybe (FL.indexingRev n) -indexedR n = fromStreamD . D.indexedR n . toStreamD - -------------------------------------------------------------------------------- --- Time Indexing -------------------------------------------------------------------------------- - --- Note: The timestamp stream must be the second stream in the zip so that the --- timestamp is generated after generating the stream element and not before. --- If we do not do that then the following example will generate the same --- timestamp for first two elements: --- --- Stream.fold Fold.toList $ Stream.timestamped $ Stream.delay $ Stream.enumerateFromTo 1 3 --- --- | Pair each element in a stream with an absolute timestamp, using a clock of --- specified granularity. The timestamp is generated just before the element --- is consumed. --- --- >>> Stream.fold Fold.toList $ Stream.timestampWith 0.01 $ Stream.delay 1 $ Stream.enumerateFromTo 1 3 --- [(AbsTime (TimeSpec {sec = ..., nsec = ...}),1),(AbsTime (TimeSpec {sec = ..., nsec = ...}),2),(AbsTime (TimeSpec {sec = ..., nsec = ...}),3)] --- --- /Pre-release/ --- -{-# INLINE timestampWith #-} -timestampWith :: (MonadIO m) - => Double -> Stream m a -> Stream m (AbsTime, a) -timestampWith g stream = zipWith (flip (,)) stream (absTimesWith g) - --- TBD: check performance vs a custom implementation without using zipWith. --- --- /Pre-release/ --- -{-# INLINE timestamped #-} -timestamped :: (MonadIO m) - => Stream m a -> Stream m (AbsTime, a) -timestamped = timestampWith 0.01 - --- | Pair each element in a stream with relative times starting from 0, using a --- clock with the specified granularity. The time is measured just before the --- element is consumed. --- --- >>> Stream.fold Fold.toList $ Stream.timeIndexWith 0.01 $ Stream.delay 1 $ Stream.enumerateFromTo 1 3 --- [(RelTime64 (NanoSecond64 ...),1),(RelTime64 (NanoSecond64 ...),2),(RelTime64 (NanoSecond64 ...),3)] --- --- /Pre-release/Monad --- -{-# INLINE timeIndexWith #-} -timeIndexWith :: (MonadIO m) - => Double -> Stream m a -> Stream m (RelTime64, a) -timeIndexWith g stream = zipWith (flip (,)) stream (relTimesWith g) - --- | Pair each element in a stream with relative times starting from 0, using a --- 10 ms granularity clock. The time is measured just before the element is --- consumed. --- --- >>> Stream.fold Fold.toList $ Stream.timeIndexed $ Stream.delay 1 $ Stream.enumerateFromTo 1 3 --- [(RelTime64 (NanoSecond64 ...),1),(RelTime64 (NanoSecond64 ...),2),(RelTime64 (NanoSecond64 ...),3)] --- --- /Pre-release/ --- -{-# INLINE timeIndexed #-} -timeIndexed :: (MonadIO m) - => Stream m a -> Stream m (RelTime64, a) -timeIndexed = timeIndexWith 0.01 - ------------------------------------------------------------------------------- --- Searching ------------------------------------------------------------------------------- - --- | Find all the indices where the value of the element in the stream is equal --- to the given value. --- --- >>> elemIndices a = Stream.findIndices (== a) --- -{-# INLINE elemIndices #-} -elemIndices :: (Monad m, Eq a) => a -> Stream m a -> Stream m Int -elemIndices a = findIndices (== a) - ------------------------------------------------------------------------------- --- Rolling map ------------------------------------------------------------------------------- - --- XXX this is not a one-to-one map so calling it map may not be right. --- We can perhaps call it zipWithTail or rollWith. - --- | Apply a function on every two successive elements of a stream. The first --- argument of the map function is the previous element and the second argument --- is the current element. When the current element is the first element, the --- previous element is 'Nothing'. --- --- /Pre-release/ --- -{-# INLINE rollingMap #-} -rollingMap :: Monad m => (Maybe a -> a -> b) -> Stream m a -> Stream m b --- rollingMap f = scanMaybe (FL.slide2 $ Window.rollingMap f) -rollingMap f m = fromStreamD $ D.rollingMap f $ toStreamD m - --- | Like 'rollingMap' but with an effectful map function. --- --- /Pre-release/ --- -{-# INLINE rollingMapM #-} -rollingMapM :: Monad m => (Maybe a -> a -> m b) -> Stream m a -> Stream m b --- rollingMapM f = scanMaybe (FL.slide2 $ Window.rollingMapM f) -rollingMapM f m = fromStreamD $ D.rollingMapM f $ toStreamD m - --- | Like 'rollingMap' but requires at least two elements in the stream, --- returns an empty stream otherwise. --- --- This is the stream equivalent of the list idiom @zipWith f xs (tail xs)@. --- --- /Pre-release/ --- -{-# INLINE rollingMap2 #-} -rollingMap2 :: Monad m => (a -> a -> b) -> Stream m a -> Stream m b -rollingMap2 f m = fromStreamD $ D.rollingMap2 f $ toStreamD m - ------------------------------------------------------------------------------- --- Maybe Streams ------------------------------------------------------------------------------- - --- | Map a 'Maybe' returning function to a stream, filter out the 'Nothing' --- elements, and return a stream of values extracted from 'Just'. --- --- Equivalent to: --- --- >>> mapMaybe f = Stream.catMaybes . fmap f --- -{-# INLINE mapMaybe #-} -mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b -mapMaybe f m = fromStreamD $ D.mapMaybe f $ toStreamD m - --- | Like 'mapMaybe' but maps a monadic function. --- --- Equivalent to: --- --- >>> mapMaybeM f = Stream.catMaybes . Stream.mapM f --- --- >>> mapM f = Stream.mapMaybeM (\x -> Just <$> f x) --- -{-# INLINE_EARLY mapMaybeM #-} -mapMaybeM :: Monad m - => (a -> m (Maybe b)) -> Stream m a -> Stream m b -mapMaybeM f = fmap fromJust . filter isJust . mapM f - ------------------------------------------------------------------------------- --- Either streams ------------------------------------------------------------------------------- - --- | Discard 'Right's and unwrap 'Left's in an 'Either' stream. --- --- >>> catLefts = fmap (fromLeft undefined) . Stream.filter isLeft --- --- /Pre-release/ --- -{-# INLINE catLefts #-} -catLefts :: Monad m => Stream m (Either a b) -> Stream m a -catLefts = fmap (fromLeft undefined) . filter isLeft - --- | Discard 'Left's and unwrap 'Right's in an 'Either' stream. --- --- >>> catRights = fmap (fromRight undefined) . Stream.filter isRight --- --- /Pre-release/ --- -{-# INLINE catRights #-} -catRights :: Monad m => Stream m (Either a b) -> Stream m b -catRights = fmap (fromRight undefined) . filter isRight - --- | Remove the either wrapper and flatten both lefts and as well as rights in --- the output stream. --- --- >>> catEithers = fmap (either id id) --- --- /Pre-release/ --- -{-# INLINE catEithers #-} -catEithers :: Monad m => Stream m (Either a a) -> Stream m a -catEithers = fmap (either id id) +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Stream.Transform +-- Copyright : (c) 2018 Composewell Technologies +-- (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +-- A few functions in this module have been adapted from the vector package +-- (c) Roman Leshchinskiy. See the notes in specific combinators. + +module Streamly.Internal.Data.Stream.Transform + ( + -- * Mapping + -- | Stateless one-to-one maps. + sequence + + -- * Mapping Effects + , tap + , tapOffsetEvery + , trace + , trace_ + + -- * Folding + , foldrS + , foldlS + + -- * Composable Scans + , postscanl + , scanl + , scanlMany + , scanr + , pipe + + -- * Splitting + , splitSepBy_ + + -- * Ad-hoc Scans + -- | Left scans. Stateful, mostly one-to-one maps. + , scanlM' + , scanlMAfter' + , scanl' + , scanlM + , scanlBy + , scanl1M' + , scanl1' + , scanl1M + , scanl1 + + , prescanl' + , prescanlM' + + , postscanlBy + , postscanlM + , postscanl' + , postscanlM' + , postscanlMAfter' + + , postscanlx' + , postscanlMx' + , scanlMx' + , scanlx' + + -- * Filtering + -- delete is for once like insert, filter is for many like intersperse. + + -- | Produce a subset of the stream. + , with + , postscanlMaybe + , filter -- retainBy + , filterM + , deleteBy -- deleteOnceBy/deleteFirstBy? + , uniqBy + , uniq + , prune + , repeated + + -- * Sampling + -- | Value agnostic filtering. + , sampleFromThen + -- keepEvery/filterEvery -- sampling + -- deleteEvery/dropEvery/removeEvery -- dual of intersperseEvery + -- deintersperse - drop infixed elements + + -- * Trimming + -- | Produce a subset of the stream trimmed at ends. + , initNonEmpty + , tailNonEmpty + , drop + , dropWhile + , dropWhileM + + -- * Trimming from end + -- | RingArray array based or buffering operations. + -- + , takeWhileLast + , takeWhileAround + , dropLast + , dropWhileLast + , dropWhileAround + + -- * Inserting Elements + -- insert is for once like delete, intersperse is for many like filter + -- | Produce a superset of the stream. Value agnostic insertion. + , intersperse + , intersperseM + , intersperseEveryM + , intersperseEndByM + , intersperseEndByEveryM + + -- Value aware insertion. + , insertBy -- insertCmpBy + -- insertBeforeBy + -- insertAfterBy + -- intersperseBeforeBy + -- intersperseAfterBy + + -- * Inserting Side Effects + , intersperseM_ + , intersperseEndByM_ + , intersperseBeginByM_ + + , delay + , delayPre + , delayPost + + -- * Reordering + -- | Produce strictly the same set but reordered. + , reverse + , reverseUnbox + , reassembleBy + + -- * Position Indexing + , indexed + , indexedR + + -- * Time Indexing + , timestampWith + , timestamped + , timeIndexWith + , timeIndexed + + -- * Searching + , findIndices + , elemIndices + + -- * Rolling map + -- | Map using the previous element. + , rollingMap + , rollingMapM + , rollingMap2 + + -- * Maybe Streams + , mapMaybe + , mapMaybeM + , catMaybes + + -- * Either Streams + , catLefts + , catRights + , catEithers + + -- * Deprecated + , postscan + , scan + , scanMany + , scanMaybe + , intersperseMSuffix + , intersperseMSuffixWith + , intersperseMSuffix_ + , intersperseMPrefix_ + , strideFromThen + , splitOn + ) +where + +#include "deprecation.h" +#include "inline.hs" + +import Control.Concurrent (threadDelay) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Either (fromLeft, isLeft, isRight, fromRight) +import Data.Functor ((<&>)) +import Data.Maybe (fromJust, isJust) +import Fusion.Plugin.Types (Fuse(..)) + +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Pipe.Type (Pipe(..)) +import Streamly.Internal.Data.Scanl.Type (Scanl(..)) +import Streamly.Internal.Data.Scanr (Scanr(..)) +import Streamly.Internal.Data.SVar.Type (adaptState) +import Streamly.Internal.Data.Time.Units (AbsTime, RelTime64) +import Streamly.Internal.Data.Unbox (Unbox) +import Streamly.Internal.System.IO (defaultChunkSize) + +-- import qualified Data.List as List +import qualified Streamly.Internal.Data.Array.Type as A +import qualified Streamly.Internal.Data.Fold.Type as FL +import qualified Streamly.Internal.Data.Pipe.Type as Pipe +import qualified Streamly.Internal.Data.StreamK.Type as K + +import Prelude hiding + ( drop, dropWhile, filter, map, mapM, reverse + , scanl, scanl1, scanr, sequence, take, takeWhile, zipWith) + +import Streamly.Internal.Data.Stream.Generate + (absTimesWith, relTimesWith) +import Streamly.Internal.Data.Stream.Type + +#include "DocTestDataStream.hs" + +------------------------------------------------------------------------------ +-- Piping +------------------------------------------------------------------------------ + +{-# ANN type PipeState Fuse #-} +data PipeState st sc ps = PipeConsume st sc | PipeProduce st ps + +-- | Use a 'Pipe' to transform a stream. +-- +{-# INLINE_NORMAL pipe #-} +pipe :: Monad m => Pipe m a b -> Stream m a -> Stream m b +pipe (Pipe consume produce initial) (Stream stream_step state) = + Stream step (PipeConsume state initial) + + where + + {-# INLINE goConsume #-} + goConsume st cs x = do + res <- consume cs x + return + $ case res of + Pipe.YieldC s b -> Yield b (PipeConsume st s) + Pipe.SkipC s -> Skip (PipeConsume st s) + Pipe.Stop -> Stop + Pipe.YieldP ps b -> Yield b (PipeProduce st ps) + Pipe.SkipP ps -> Skip (PipeProduce st ps) + + {-# INLINE_LATE step #-} + step gst (PipeConsume st cs) = do + r <- stream_step (adaptState gst) st + case r of + Yield x s -> goConsume s cs x + Skip s -> return $ Skip (PipeConsume s cs) + Stop -> return Stop + step _ (PipeProduce st ps) = do + r <- produce ps + return + $ case r of + Pipe.YieldC cs b -> Yield b (PipeConsume st cs) + Pipe.SkipC cs -> Skip (PipeConsume st cs) + Pipe.Stop -> Stop + Pipe.YieldP ps1 b -> Yield b (PipeProduce st ps1) + Pipe.SkipP ps1 -> Skip (PipeProduce st ps1) + +{-# ANN type RunScanState Fuse #-} +data RunScanState st sc ps = ScanConsume st sc + +-- | Use a lazy right 'Scanr' to transform a stream. +-- +-- The following example extracts the input stream up to a point where the +-- running average of elements is no more than 10: +-- +-- >>> import Data.Maybe (fromJust) +-- >>> let avg = Scanr.teeWith (/) Scanr.sum (fmap fromIntegral Scanr.length) +-- >>> s = Stream.enumerateFromTo 1.0 100.0 +-- >>> :{ +-- Stream.fold Fold.toList +-- $ fmap fst +-- $ Stream.takeWhile (\(_,x) -> x <= 10) +-- $ Stream.scanr (Scanr.tee Scanr.identity avg) s +-- :} +-- [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0] +-- +{-# INLINE_NORMAL scanr #-} +scanr :: Monad m => Scanr m a b -> Stream m a -> Stream m b +scanr (Scanr consume initial) (Stream stream_step state) = + Stream step (ScanConsume state initial) + + where + + {-# INLINE_LATE step #-} + step gst (ScanConsume st cs) = do + r <- stream_step (adaptState gst) st + case r of + Yield x s -> do + res <- consume cs x + return + $ case res of + Yield b cs1 -> Yield b (ScanConsume s cs1) + Skip cs1 -> Skip (ScanConsume s cs1) + Stop -> Stop + Skip s -> return $ Skip (ScanConsume s cs) + Stop -> return Stop + +------------------------------------------------------------------------------ +-- Transformation Folds +------------------------------------------------------------------------------ + +-- Note, this is going to have horrible performance, because of the nature of +-- the stream type (i.e. direct stream vs CPS). Its only for reference, it is +-- likely be practically unusable. +{-# INLINE_NORMAL foldlS #-} +foldlS :: Monad m + => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b +foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin)) + where + step' gst (Left (st, acc)) = do + r <- step (adaptState gst) st + return $ case r of + Yield x s -> Skip (Left (s, fstep acc x)) + Skip s -> Skip (Left (s, acc)) + Stop -> Skip (Right acc) + + step' gst (Right (Stream stp stt)) = do + r <- stp (adaptState gst) stt + return $ case r of + Yield x s -> Yield x (Right (Stream stp s)) + Skip s -> Skip (Right (Stream stp s)) + Stop -> Stop + +------------------------------------------------------------------------------ +-- Transformation by Mapping +------------------------------------------------------------------------------ + +-- | +-- >>> sequence = Stream.mapM id +-- +-- Replace the elements of a stream of monadic actions with the outputs of +-- those actions. +-- +-- >>> s = Stream.fromList [putStr "a", putStr "b", putStrLn "c"] +-- >>> Stream.fold Fold.drain $ Stream.sequence s +-- abc +-- +{-# INLINE_NORMAL sequence #-} +sequence :: Monad m => Stream m (m a) -> Stream m a +sequence (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- step (adaptState gst) st + case r of + Yield x s -> x >>= \a -> return (Yield a s) + Skip s -> return $ Skip s + Stop -> return Stop + +------------------------------------------------------------------------------ +-- Mapping side effects +------------------------------------------------------------------------------ + +data TapState fs st a + = TapInit | Tapping !fs st | TapDone st + +-- XXX Multiple yield points + +-- | Tap the data flowing through a stream into a 'Fold'. For example, you may +-- add a tap to log the contents flowing through the stream. The fold is used +-- only for effects, its result is discarded. +-- +-- @ +-- Fold m a b +-- | +-- -----stream m a ---------------stream m a----- +-- +-- @ +-- +-- >>> s = Stream.enumerateFromTo 1 2 +-- >>> Stream.fold Fold.drain $ Stream.tap (Fold.drainMapM print) s +-- 1 +-- 2 +-- +-- Compare with 'trace'. +-- +{-# INLINE tap #-} +tap :: Monad m => Fold m a b -> Stream m a -> Stream m a +tap (Fold fstep initial _ final) (Stream step state) = Stream step' TapInit + + where + + step' _ TapInit = do + res <- initial + return + $ Skip + $ case res of + FL.Partial s -> Tapping s state + FL.Done _ -> TapDone state + step' gst (Tapping acc st) = do + r <- step gst st + case r of + Yield x s -> do + res <- fstep acc x + return + $ Yield x + $ case res of + FL.Partial fs -> Tapping fs s + FL.Done _ -> TapDone s + Skip s -> return $ Skip (Tapping acc s) + Stop -> do + void $ final acc + return Stop + step' gst (TapDone st) = do + r <- step gst st + return + $ case r of + Yield x s -> Yield x (TapDone s) + Skip s -> Skip (TapDone s) + Stop -> Stop + +data TapOffState fs s a + = TapOffInit + | TapOffTapping !fs s Int + | TapOffDone s + +-- XXX Multiple yield points +{-# INLINE_NORMAL tapOffsetEvery #-} +tapOffsetEvery :: Monad m + => Int -> Int -> Fold m a b -> Stream m a -> Stream m a +tapOffsetEvery offset n (Fold fstep initial _ final) (Stream step state) = + Stream step' TapOffInit + + where + + {-# INLINE_LATE step' #-} + step' _ TapOffInit = do + res <- initial + return + $ Skip + $ case res of + FL.Partial s -> TapOffTapping s state (offset `mod` n) + FL.Done _ -> TapOffDone state + step' gst (TapOffTapping acc st count) = do + r <- step gst st + case r of + Yield x s -> do + next <- + if count <= 0 + then do + res <- fstep acc x + return + $ case res of + FL.Partial sres -> + TapOffTapping sres s (n - 1) + FL.Done _ -> TapOffDone s + else return $ TapOffTapping acc s (count - 1) + return $ Yield x next + Skip s -> return $ Skip (TapOffTapping acc s count) + Stop -> do + void $ final acc + return Stop + step' gst (TapOffDone st) = do + r <- step gst st + return + $ case r of + Yield x s -> Yield x (TapOffDone s) + Skip s -> Skip (TapOffDone s) + Stop -> Stop + +-- | Apply a monadic function to each element flowing through the stream and +-- discard the results. +-- +-- >>> s = Stream.enumerateFromTo 1 2 +-- >>> Stream.fold Fold.drain $ Stream.trace print s +-- 1 +-- 2 +-- +-- Compare with 'tap'. +-- +{-# INLINE trace #-} +trace :: Monad m => (a -> m b) -> Stream m a -> Stream m a +trace f = mapM (\x -> void (f x) >> return x) + +-- | Perform a side effect before yielding each element of the stream and +-- discard the results. +-- +-- >>> s = Stream.enumerateFromTo 1 2 +-- >>> Stream.fold Fold.drain $ Stream.trace_ (print "got here") s +-- "got here" +-- "got here" +-- +-- Same as 'intersperseMPrefix_' but always serial. +-- +-- See also: 'trace' +-- +-- /Pre-release/ +{-# INLINE trace_ #-} +trace_ :: Monad m => m b -> Stream m a -> Stream m a +trace_ eff = mapM (\x -> eff >> return x) + +------------------------------------------------------------------------------ +-- Scanning with a Fold +------------------------------------------------------------------------------ + +data ScanState s f = ScanInit s | ScanDo s !f | ScanDone + +-- NOTE: Lazy postscans can be useful e.g. to use a lazy postscan on "latest". +-- We can keep the initial state undefined in lazy postscans which do not use +-- it at all. Otherwise we have to wrap the accumulator in a Maybe type. +-- Unfortunately, we cannot define lazy scans because the Partial constructor +-- itself is strict. + +-- | Postscan a stream using the given fold. A postscan omits the initial +-- (default) value of the accumulator and includes the final value. +-- +-- >>> Stream.toList $ Stream.postscanl Scanl.latest (Stream.fromList []) +-- [] +-- +-- Compare with 'scan' which includes the initial value as well: +-- +-- >>> Stream.toList $ Stream.scanl Scanl.latest (Stream.fromList []) +-- [Nothing] +-- +-- The following example extracts the input stream up to a point where the +-- running average of elements is no more than 10: +-- +-- >>> import Data.Maybe (fromJust) +-- >>> let avg = Scanl.teeWith (/) Scanl.sum (fmap fromIntegral Scanl.length) +-- >>> s = Stream.enumerateFromTo 1.0 100.0 +-- >>> :{ +-- Stream.fold Fold.toList +-- $ fmap (fromJust . fst) +-- $ Stream.takeWhile (\(_,x) -> x <= 10) +-- $ Stream.postscanl (Scanl.tee Scanl.latest avg) s +-- :} +-- [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0] +-- +{-# INLINE_NORMAL postscanl #-} +postscanl :: Monad m => Scanl m a b -> Stream m a -> Stream m b +postscanl (Scanl fstep initial extract final) (Stream sstep state) = + Stream step (ScanInit state) + + where + + {-# INLINE_LATE step #-} + step _ (ScanInit st) = do + res <- initial + return + $ case res of + FL.Partial fs -> Skip $ ScanDo st fs + FL.Done b -> Yield b ScanDone + step gst (ScanDo st fs) = do + res <- sstep (adaptState gst) st + case res of + Yield x s -> do + r <- fstep fs x + case r of + FL.Partial fs1 -> do + !b <- extract fs1 + return $ Yield b $ ScanDo s fs1 + FL.Done b -> return $ Yield b ScanDone + Skip s -> return $ Skip $ ScanDo s fs + Stop -> final fs >> return Stop + step _ ScanDone = return Stop + +{-# DEPRECATED postscan "Please use postscanl instead" #-} +{-# INLINE_NORMAL postscan #-} +postscan :: Monad m => FL.Fold m a b -> Stream m a -> Stream m b +postscan (FL.Fold fstep initial extract final) = + postscanl (Scanl fstep initial extract final) + +{-# INLINE scanlWith #-} +scanlWith :: Monad m + => Bool -> Scanl m a b -> Stream m a -> Stream m b +scanlWith restart (Scanl fstep initial extract final) (Stream sstep state) = + Stream step (ScanInit state) + + where + + {-# INLINE runStep #-} + runStep st action = do + res <- action + case res of + FL.Partial fs -> do + !b <- extract fs + return $ Yield b $ ScanDo st fs + FL.Done b -> + let next = if restart then ScanInit st else ScanDone + in return $ Yield b next + + {-# INLINE_LATE step #-} + step _ (ScanInit st) = runStep st initial + step gst (ScanDo st fs) = do + res <- sstep (adaptState gst) st + case res of + Yield x s -> runStep s (fstep fs x) + Skip s -> return $ Skip $ ScanDo s fs + Stop -> final fs >> return Stop + step _ ScanDone = return Stop + +{-# DEPRECATED scanWith "Please use scanlWith instead" #-} +{-# INLINE scanWith #-} +scanWith :: Monad m + => Bool -> Fold m a b -> Stream m a -> Stream m b +scanWith restart (Fold fstep initial extract final) = + scanlWith restart (Scanl fstep initial extract final) + +-- XXX It may be useful to have a version of scan where we can keep the +-- accumulator independent of the value emitted. So that we do not necessarily +-- have to keep a value in the accumulator which we are not using. We can pass +-- an extraction function that will take the accumulator and the current value +-- of the element and emit the next value in the stream. That will also make it +-- possible to modify the accumulator after using it. In fact, the step function +-- can return new accumulator and the value to be emitted. The signature would +-- be more like mapAccumL. + +-- | Strict left scan. Scan a stream using the given fold. Scan includes +-- the initial (default) value of the accumulator as well as the final value. +-- Compare with 'postscan' which omits the initial value. +-- +-- >>> s = Stream.fromList [1..10] +-- >>> Stream.fold Fold.toList $ Stream.takeWhile (< 10) $ Stream.scanl Scanl.sum s +-- [0,1,3,6] +-- +-- See also: 'usingStateT' +-- + +-- EXPLANATION: +-- >>> scanl' step z = Stream.scanl (Scanl.mkScanl step z) +-- +-- Like 'map', 'scanl'' too is a one to one transformation, +-- however it adds an extra element. +-- +-- >>> s = Stream.fromList [1,2,3,4] +-- >>> Stream.fold Fold.toList $ scanl' (+) 0 s +-- [0,1,3,6,10] +-- +-- >>> Stream.fold Fold.toList $ scanl' (flip (:)) [] s +-- [[],[1],[2,1],[3,2,1],[4,3,2,1]] +-- +-- The output of 'scanl'' is the initial value of the accumulator followed by +-- all the intermediate steps and the final result of 'foldl''. +-- +-- By streaming the accumulated state after each fold step, we can share the +-- state across multiple stages of stream composition. Each stage can modify or +-- extend the state, do some processing with it and emit it for the next stage, +-- thus modularizing the stream processing. This can be useful in +-- stateful or event-driven programming. +-- +-- Consider the following monolithic example, computing the sum and the product +-- of the elements in a stream in one go using a @foldl'@: +-- +-- >>> foldl' step z = Stream.fold (Scanl.mkScanl step z) +-- >>> foldl' (\(s, p) x -> (s + x, p * x)) (0,1) s +-- (10,24) +-- +-- Using @scanl'@ we can make it modular by computing the sum in the first +-- stage and passing it down to the next stage for computing the product: +-- +-- >>> :{ +-- foldl' (\(_, p) (s, x) -> (s, p * x)) (0,1) +-- $ scanl' (\(s, _) x -> (s + x, x)) (0,1) +-- $ Stream.fromList [1,2,3,4] +-- :} +-- (10,24) +-- +-- IMPORTANT: 'scanl'' evaluates the accumulator to WHNF. To avoid building +-- lazy expressions inside the accumulator, it is recommended that a strict +-- data structure is used for accumulator. +-- +{-# INLINE_NORMAL scanl #-} +scanl :: Monad m + => Scanl m a b -> Stream m a -> Stream m b +scanl = scanlWith False + +-- | Like 'scanl' but restarts scanning afresh when the scanning fold +-- terminates. +-- +{-# INLINE_NORMAL scanlMany #-} +scanlMany :: Monad m + => Scanl m a b -> Stream m a -> Stream m b +scanlMany = scanlWith True + +{-# DEPRECATED scan "Please use scanl instead" #-} +{-# INLINE_NORMAL scan #-} +scan :: Monad m + => FL.Fold m a b -> Stream m a -> Stream m b +scan = scanWith False + +{-# DEPRECATED scanMany "Please use scanlMany instead" #-} +{-# INLINE_NORMAL scanMany #-} +scanMany :: Monad m + => FL.Fold m a b -> Stream m a -> Stream m b +scanMany = scanWith True + +------------------------------------------------------------------------------ +-- Scanning - Prescans +------------------------------------------------------------------------------ + +-- Adapted from the vector package. +-- +-- XXX Is a prescan useful, discarding the last step does not sound useful? I +-- am not sure about the utility of this function, so this is implemented but +-- not exposed. We can expose it if someone provides good reasons why this is +-- useful. +-- +-- XXX We have to execute the stream one step ahead to know that we are at the +-- last step. The vector implementation of prescan executes the last fold step +-- but does not yield the result. This means we have executed the effect but +-- discarded value. This does not sound right. In this implementation we are +-- not executing the last fold step. +{-# INLINE_NORMAL prescanlM' #-} +prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b +prescanlM' f mz (Stream step state) = Stream step' (state, mz) + where + {-# INLINE_LATE step' #-} + step' gst (st, prev) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + acc <- prev + return $ Yield acc (s, f acc x) + Skip s -> return $ Skip (s, prev) + Stop -> return Stop + +{-# INLINE prescanl' #-} +prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b +prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z) + +------------------------------------------------------------------------------ +-- Monolithic postscans (postscan followed by a map) +------------------------------------------------------------------------------ + +-- The performance of a modular postscan followed by a map seems to be +-- equivalent to this monolithic scan followed by map therefore we may not need +-- this implementation. We just have it for performance comparison and in case +-- modular version does not perform well in some situation. +-- +{-# INLINE_NORMAL postscanlMx' #-} +postscanlMx' :: Monad m + => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b +postscanlMx' fstep begin done (Stream step state) = do + Stream step' (state, begin) + where + {-# INLINE_LATE step' #-} + step' gst (st, acc) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + old <- acc + y <- fstep old x + v <- done y + v `seq` y `seq` return (Yield v (s, return y)) + Skip s -> return $ Skip (s, acc) + Stop -> return Stop + +{-# INLINE_NORMAL postscanlx' #-} +postscanlx' :: Monad m + => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b +postscanlx' fstep begin done = + postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) + +-- XXX do we need consM strict to evaluate the begin value? +{-# INLINE scanlMx' #-} +scanlMx' :: Monad m + => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b +scanlMx' fstep begin done s = + (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s + +{-# INLINE scanlx' #-} +scanlx' :: Monad m + => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b +scanlx' fstep begin done = + scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) + +------------------------------------------------------------------------------ +-- postscans +------------------------------------------------------------------------------ + +-- Adapted from the vector package. +{-# INLINE_NORMAL postscanlM' #-} +postscanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b +postscanlM' fstep begin (Stream step state) = + Stream step' Nothing + where + {-# INLINE_LATE step' #-} + step' _ Nothing = do + !x <- begin + return $ Skip (Just (state, x)) + + step' gst (Just (st, acc)) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + !y <- fstep acc x + return $ Yield y (Just (s, y)) + Skip s -> return $ Skip (Just (s, acc)) + Stop -> return Stop + +{-# INLINE_NORMAL postscanl' #-} +postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a +postscanl' f seed = postscanlM' (\a b -> return (f a b)) (return seed) + +{-# ANN type PScanAfterState Fuse #-} +data PScanAfterState m st acc = + PScanAfterStep st (m acc) + | PScanAfterYield acc (PScanAfterState m st acc) + | PScanAfterStop + +-- We can possibly have the "done" function as a Maybe to provide an option to +-- emit or not emit the accumulator when the stream stops. +-- +-- TBD: use a single Yield point +-- +{-# INLINE_NORMAL postscanlMAfter' #-} +postscanlMAfter' :: Monad m + => (b -> a -> m b) -> m b -> (b -> m b) -> Stream m a -> Stream m b +postscanlMAfter' fstep initial done (Stream step1 state1) = do + Stream step (PScanAfterStep state1 initial) + + where + + {-# INLINE_LATE step #-} + step gst (PScanAfterStep st acc) = do + r <- step1 (adaptState gst) st + case r of + Yield x s -> do + !old <- acc + !y <- fstep old x + return (Skip $ PScanAfterYield y (PScanAfterStep s (return y))) + Skip s -> return $ Skip $ PScanAfterStep s acc + -- Strictness is important for fusion + Stop -> do + !v <- acc + !res <- done v + return (Skip $ PScanAfterYield res PScanAfterStop) + step _ (PScanAfterYield acc next) = return $ Yield acc next + step _ PScanAfterStop = return Stop + +{-# INLINE_NORMAL postscanlM #-} +postscanlM :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b +postscanlM fstep begin (Stream step state) = Stream step' Nothing + where + {-# INLINE_LATE step' #-} + step' _ Nothing = do + r <- begin + return $ Skip (Just (state, r)) + + step' gst (Just (st, acc)) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + y <- fstep acc x + return (Yield y (Just (s, y))) + Skip s -> return $ Skip (Just (s, acc)) + Stop -> return Stop + +{-# INLINE_NORMAL postscanlBy #-} +postscanlBy :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a +postscanlBy f seed = postscanlM (\a b -> return (f a b)) (return seed) + +-- | Like 'scanl'' but with a monadic step function and a monadic seed. +-- +{-# INLINE_NORMAL scanlM' #-} +scanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b +scanlM' fstep begin (Stream step state) = Stream step' Nothing + where + {-# INLINE_LATE step' #-} + step' _ Nothing = do + !x <- begin + return $ Yield x (Just (state, x)) + step' gst (Just (st, acc)) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + !y <- fstep acc x + return $ Yield y (Just (s, y)) + Skip s -> return $ Skip (Just (s, acc)) + Stop -> return Stop + +-- | @scanlMAfter' accumulate initial done stream@ is like 'scanlM'' except +-- that it provides an additional @done@ function to be applied on the +-- accumulator when the stream stops. The result of @done@ is also emitted in +-- the stream. +-- +-- This function can be used to allocate a resource in the beginning of the +-- scan and release it when the stream ends or to flush the internal state of +-- the scan at the end. +-- +-- /Pre-release/ +-- +{-# INLINE scanlMAfter' #-} +scanlMAfter' :: Monad m + => (b -> a -> m b) -> m b -> (b -> m b) -> Stream m a -> Stream m b +scanlMAfter' fstep initial done s = + initial `consM` postscanlMAfter' fstep initial done s + +-- >>> scanl' f z xs = z `Stream.cons` postscanl' f z xs + +-- | Strict left scan. Like 'map', 'scanl'' too is a one to one transformation, +-- however it adds an extra element. +-- +-- >>> Stream.toList $ Stream.scanl' (+) 0 $ Stream.fromList [1,2,3,4] +-- [0,1,3,6,10] +-- +-- >>> Stream.toList $ Stream.scanl' (flip (:)) [] $ Stream.fromList [1,2,3,4] +-- [[],[1],[2,1],[3,2,1],[4,3,2,1]] +-- +-- The output of 'scanl'' is the initial value of the accumulator followed by +-- all the intermediate steps and the final result of 'foldl''. +-- +-- By streaming the accumulated state after each fold step, we can share the +-- state across multiple stages of stream composition. Each stage can modify or +-- extend the state, do some processing with it and emit it for the next stage, +-- thus modularizing the stream processing. This can be useful in +-- stateful or event-driven programming. +-- +-- Consider the following monolithic example, computing the sum and the product +-- of the elements in a stream in one go using a @foldl'@: +-- +-- >>> Stream.fold (Fold.foldl' (\(s, p) x -> (s + x, p * x)) (0,1)) $ Stream.fromList [1,2,3,4] +-- (10,24) +-- +-- Using @scanl'@ we can make it modular by computing the sum in the first +-- stage and passing it down to the next stage for computing the product: +-- +-- >>> :{ +-- Stream.fold (Fold.foldl' (\(_, p) (s, x) -> (s, p * x)) (0,1)) +-- $ Stream.scanl' (\(s, _) x -> (s + x, x)) (0,1) +-- $ Stream.fromList [1,2,3,4] +-- :} +-- (10,24) +-- +-- IMPORTANT: 'scanl'' evaluates the accumulator to WHNF. To avoid building +-- lazy expressions inside the accumulator, it is recommended that a strict +-- data structure is used for accumulator. +-- +-- >>> scanl' step z = Stream.scanl (Scanl.mkScanl step z) +-- >>> scanl' f z xs = Stream.scanlM' (\a b -> return (f a b)) (return z) xs +-- +-- See also: 'usingStateT' +-- +{-# INLINE scanl' #-} +scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b +scanl' f seed = scanlM' (\a b -> return (f a b)) (return seed) + +{-# INLINE_NORMAL scanlM #-} +scanlM :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b +scanlM fstep begin (Stream step state) = Stream step' Nothing + where + {-# INLINE_LATE step' #-} + step' _ Nothing = do + x <- begin + return $ Yield x (Just (state, x)) + step' gst (Just (st, acc)) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + y <- fstep acc x + return $ Yield y (Just (s, y)) + Skip s -> return $ Skip (Just (s, acc)) + Stop -> return Stop + +{-# INLINE scanlBy #-} +scanlBy :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b +scanlBy f seed = scanlM (\a b -> return (f a b)) (return seed) + +-- Adapted from the vector package +{-# INLINE_NORMAL scanl1M #-} +scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a +scanl1M fstep (Stream step state) = Stream step' (state, Nothing) + where + {-# INLINE_LATE step' #-} + step' gst (st, Nothing) = do + r <- step gst st + case r of + Yield x s -> return $ Yield x (s, Just x) + Skip s -> return $ Skip (s, Nothing) + Stop -> return Stop + + step' gst (st, Just acc) = do + r <- step gst st + case r of + Yield y s -> do + z <- fstep acc y + return $ Yield z (s, Just z) + Skip s -> return $ Skip (s, Just acc) + Stop -> return Stop + +{-# INLINE scanl1 #-} +scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a +scanl1 f = scanl1M (\x y -> return (f x y)) + +-- Adapted from the vector package + +-- | Like 'scanl1'' but with a monadic step function. +-- +{-# INLINE_NORMAL scanl1M' #-} +scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a +scanl1M' fstep (Stream step state) = Stream step' (state, Nothing) + where + {-# INLINE_LATE step' #-} + step' gst (st, Nothing) = do + r <- step gst st + case r of + Yield x s -> x `seq` return $ Yield x (s, Just x) + Skip s -> return $ Skip (s, Nothing) + Stop -> return Stop + + step' gst (st, Just acc) = acc `seq` do + r <- step gst st + case r of + Yield y s -> do + z <- fstep acc y + z `seq` return $ Yield z (s, Just z) + Skip s -> return $ Skip (s, Just acc) + Stop -> return Stop + +-- | Like 'scanl'' but for a non-empty stream. The first element of the stream +-- is used as the initial value of the accumulator. Does nothing if the stream +-- is empty. +-- +-- >>> Stream.toList $ Stream.scanl1' (+) $ Stream.fromList [1,2,3,4] +-- [1,3,6,10] +-- +{-# INLINE scanl1' #-} +scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a +scanl1' f = scanl1M' (\x y -> return (f x y)) + +------------------------------------------------------------------------------- +-- Filtering +------------------------------------------------------------------------------- + +-- | Modify a @Stream m a -> Stream m a@ stream transformation that accepts a +-- predicate @(a -> b)@ to accept @((s, a) -> b)@ instead, provided a +-- transformation @Stream m a -> Stream m (s, a)@. Convenient to filter with +-- index or time. +-- +-- >>> filterWithIndex = Stream.with Stream.indexed Stream.filter +-- +-- /Pre-release/ +{-# INLINE with #-} +with :: Monad m => + (Stream m a -> Stream m (s, a)) + -> (((s, a) -> b) -> Stream m (s, a) -> Stream m (s, a)) + -> (((s, a) -> b) -> Stream m a -> Stream m a) +with f comb g = fmap snd . comb g . f + +-- Adapted from the vector package + +-- | Same as 'filter' but with a monadic predicate. +-- +-- >>> f p x = p x >>= \r -> return $ if r then Just x else Nothing +-- >>> filterM p = Stream.mapMaybeM (f p) +-- +{-# INLINE_NORMAL filterM #-} +filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +filterM f (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- step gst st + case r of + Yield x s -> do + b <- f x + return $ if b + then Yield x s + else Skip s + Skip s -> return $ Skip s + Stop -> return Stop + +-- | Include only those elements that pass a predicate. +-- +-- >>> filter p = Stream.filterM (return . p) +-- >>> filter p = Stream.mapMaybe (\x -> if p x then Just x else Nothing) +-- >>> filter p = Stream.postscanlMaybe (Scanl.filtering p) +-- +{-# INLINE filter #-} +filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +filter f = filterM (return . f) +-- filter p = scanMaybe (FL.filtering p) + +-- | Drop repeated elements that are adjacent to each other using the supplied +-- comparison function. +-- +-- >>> uniq = Stream.uniqBy (==) +-- +-- To strip duplicate path separators: +-- +-- >>> input = Stream.fromList "//a//b" +-- >>> f x y = x == '/' && y == '/' +-- >>> Stream.fold Fold.toList $ Stream.uniqBy f input +-- "/a/b" +-- +-- Space: @O(1)@ +-- +-- /Pre-release/ +-- +{-# INLINE uniqBy #-} +uniqBy :: Monad m => + (a -> a -> Bool) -> Stream m a -> Stream m a +-- uniqBy eq = scanMaybe (FL.uniqBy eq) +uniqBy eq = catMaybes . rollingMap f + + where + + f pre curr = + case pre of + Nothing -> Just curr + Just x -> if x `eq` curr then Nothing else Just curr + +-- Adapted from the vector package + +-- | Drop repeated elements that are adjacent to each other. +-- +-- >>> uniq = Stream.uniqBy (==) +-- +{-# INLINE_NORMAL uniq #-} +uniq :: (Eq a, Monad m) => Stream m a -> Stream m a +-- uniq = scanMaybe FL.uniq +uniq (Stream step state) = Stream step' (Nothing, state) + where + {-# INLINE_LATE step' #-} + step' gst (Nothing, st) = do + r <- step gst st + case r of + Yield x s -> return $ Yield x (Just x, s) + Skip s -> return $ Skip (Nothing, s) + Stop -> return Stop + step' gst (Just x, st) = do + r <- step gst st + case r of + Yield y s | x == y -> return $ Skip (Just x, s) + | otherwise -> return $ Yield y (Just y, s) + Skip s -> return $ Skip (Just x, s) + Stop -> return Stop + +-- | Deletes the first occurrence of the element in the stream that satisfies +-- the given equality predicate. +-- +-- >>> input = Stream.fromList [1,3,3,5] +-- >>> Stream.fold Fold.toList $ Stream.deleteBy (==) 3 input +-- [1,3,5] +-- +{-# INLINE_NORMAL deleteBy #-} +deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a +-- deleteBy cmp x = scanMaybe (FL.deleteBy cmp x) +deleteBy eq x (Stream step state) = Stream step' (state, False) + where + {-# INLINE_LATE step' #-} + step' gst (st, False) = do + r <- step gst st + case r of + Yield y s -> return $ + if eq x y then Skip (s, True) else Yield y (s, False) + Skip s -> return $ Skip (s, False) + Stop -> return Stop + + step' gst (st, True) = do + r <- step gst st + case r of + Yield y s -> return $ Yield y (s, True) + Skip s -> return $ Skip (s, True) + Stop -> return Stop + +-- | Strip all leading and trailing occurrences of an element passing a +-- predicate and make all other consecutive occurrences uniq. +-- +-- >> prune p = Stream.dropWhileAround p $ Stream.uniqBy (x y -> p x && p y) +-- +-- @ +-- > Stream.prune isSpace (Stream.fromList " hello world! ") +-- "hello world!" +-- +-- @ +-- +-- Space: @O(1)@ +-- +-- /Unimplemented/ +{-# INLINE prune #-} +prune :: + -- (Monad m, Eq a) => + (a -> Bool) -> Stream m a -> Stream m a +prune = error "Not implemented yet!" + +-- Possible implementation: +-- @repeated = +-- Stream.catMaybes . Stream.parseMany (Parser.groupBy (==) Fold.repeated)@ +-- +-- 'Fold.repeated' should return 'Just' when repeated, and 'Nothing' for a +-- single element. + +-- | Emit only repeated elements, once. +-- +-- /Unimplemented/ +repeated :: -- (Monad m, Eq a) => + Stream m a -> Stream m a +repeated = undefined + +------------------------------------------------------------------------------ +-- Sampling +------------------------------------------------------------------------------ + +-- XXX We can implement this using addition instead of "mod" to make it more +-- efficient. + +-- | @sampleFromThen offset stride@ takes the element at @offset@ index and +-- then every element at strides of @stride@. +-- +-- >>> Stream.fold Fold.toList $ Stream.sampleFromThen 2 3 $ Stream.enumerateFromTo 0 10 +-- [2,5,8] +-- +{-# INLINE sampleFromThen #-} +sampleFromThen, strideFromThen :: Monad m => + Int -> Int -> Stream m a -> Stream m a +sampleFromThen offset stride = + with indexed filter + (\(i, _) -> i >= offset && (i - offset) `mod` stride == 0) + +RENAME(strideFromThen,sampleFromThen) + +------------------------------------------------------------------------------ +-- Trimming +------------------------------------------------------------------------------ + +-- | init for non-empty streams, fails for empty stream case. +-- +{-# INLINE initNonEmpty #-} +initNonEmpty :: Monad m => Stream m a -> Stream m a +initNonEmpty (Stream step1 state1) = Stream step (Nothing, state1) + + where + + step gst (Nothing, s1) = do + r <- step1 (adaptState gst) s1 + return $ + case r of + Yield x s -> Skip (Just x, s) + Skip s -> Skip (Nothing, s) + Stop -> error "initNonEmpty: empty Stream" + + step gst (Just a, s1) = do + r <- step1 (adaptState gst) s1 + return $ + case r of + Yield x s -> Yield a (Just x, s) + Skip s -> Skip (Just a, s) + Stop -> Stop + +-- | tail for non-empty streams, fails for empty stream case. +-- +-- See also 'tail' for a non-partial version of this function.. +{-# INLINE tailNonEmpty #-} +tailNonEmpty :: Monad m => Stream m a -> Stream m a +tailNonEmpty (Stream step1 state1) = Stream step (Nothing, state1) + + where + + step gst (Nothing, s1) = do + r <- step1 (adaptState gst) s1 + return $ + case r of + Yield x s -> Skip (Just x, s) + Skip s -> Skip (Nothing, s) + Stop -> error "tailNonEmpty: empty Stream" + + step gst (Just a, s1) = do + r <- step1 (adaptState gst) s1 + return $ + case r of + Yield x s -> Yield x (Just x, s) + Skip s -> Skip (Just a, s) + Stop -> Stop + +-- | Take all consecutive elements at the end of the stream for which the +-- predicate is true. +-- +-- O(n) space, where n is the number elements taken. +-- +-- /Unimplemented/ +{-# INLINE takeWhileLast #-} +takeWhileLast :: -- Monad m => + (a -> Bool) -> Stream m a -> Stream m a +takeWhileLast = undefined -- fromStreamD $ D.takeWhileLast n $ toStreamD m + +-- | Like 'takeWhile' and 'takeWhileLast' combined. +-- +-- O(n) space, where n is the number elements taken from the end. +-- +-- /Unimplemented/ +{-# INLINE takeWhileAround #-} +takeWhileAround :: -- Monad m => + (a -> Bool) -> Stream m a -> Stream m a +takeWhileAround = undefined -- fromStreamD $ D.takeWhileAround n $ toStreamD m + +-- Adapted from the vector package + +-- | Discard first 'n' elements from the stream and take the rest. +-- +{-# INLINE_NORMAL drop #-} +drop :: Monad m => Int -> Stream m a -> Stream m a +drop n (Stream step state) = Stream step' (state, Just n) + where + {-# INLINE_LATE step' #-} + step' gst (st, Just i) + | i > 0 = do + r <- step gst st + return $ + case r of + Yield _ s -> Skip (s, Just (i - 1)) + Skip s -> Skip (s, Just i) + Stop -> Stop + | otherwise = return $ Skip (st, Nothing) + + step' gst (st, Nothing) = do + r <- step gst st + return $ + case r of + Yield x s -> Yield x (s, Nothing) + Skip s -> Skip (s, Nothing) + Stop -> Stop + +-- Adapted from the vector package +data DropWhileState s a + = DropWhileDrop s + | DropWhileYield a s + | DropWhileNext s + +-- | Same as 'dropWhile' but with a monadic predicate. +-- +{-# INLINE_NORMAL dropWhileM #-} +dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +-- dropWhileM p = scanMaybe (FL.droppingWhileM p) +dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state) + where + {-# INLINE_LATE step' #-} + step' gst (DropWhileDrop st) = do + r <- step gst st + case r of + Yield x s -> do + b <- f x + if b + then return $ Skip (DropWhileDrop s) + else return $ Skip (DropWhileYield x s) + Skip s -> return $ Skip (DropWhileDrop s) + Stop -> return Stop + + step' gst (DropWhileNext st) = do + r <- step gst st + case r of + Yield x s -> return $ Skip (DropWhileYield x s) + Skip s -> return $ Skip (DropWhileNext s) + Stop -> return Stop + + step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st) + +-- | Drop elements in the stream as long as the predicate succeeds and then +-- take the rest of the stream. +-- +{-# INLINE dropWhile #-} +dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +-- dropWhile p = scanMaybe (FL.droppingWhile p) +dropWhile f = dropWhileM (return . f) + +-- | Drop @n@ elements at the end of the stream. +-- +-- O(n) space, where n is the number elements dropped. +-- +-- /Unimplemented/ +{-# INLINE dropLast #-} +dropLast :: -- Monad m => + Int -> Stream m a -> Stream m a +dropLast = undefined -- fromStreamD $ D.dropLast n $ toStreamD m + +-- | Drop all consecutive elements at the end of the stream for which the +-- predicate is true. +-- +-- O(n) space, where n is the number elements dropped. +-- +-- /Unimplemented/ +{-# INLINE dropWhileLast #-} +dropWhileLast :: -- Monad m => + (a -> Bool) -> Stream m a -> Stream m a +dropWhileLast = undefined -- fromStreamD $ D.dropWhileLast n $ toStreamD m + +-- | Like 'dropWhile' and 'dropWhileLast' combined. +-- +-- O(n) space, where n is the number elements dropped from the end. +-- +-- /Unimplemented/ +{-# INLINE dropWhileAround #-} +dropWhileAround :: -- Monad m => + (a -> Bool) -> Stream m a -> Stream m a +dropWhileAround = undefined -- fromStreamD $ D.dropWhileAround n $ toStreamD m + +------------------------------------------------------------------------------ +-- Inserting Elements +------------------------------------------------------------------------------ + +-- | @insertBy cmp elem stream@ inserts @elem@ before the first element in +-- @stream@ that is less than @elem@ when compared using @cmp@. +-- +-- >>> insertBy cmp x = Stream.mergeBy cmp (Stream.fromPure x) +-- +-- >>> input = Stream.fromList [1,3,5] +-- >>> Stream.fold Fold.toList $ Stream.insertBy compare 2 input +-- [1,2,3,5] +-- +{-# INLINE_NORMAL insertBy #-} +insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a +insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing) + where + {-# INLINE_LATE step' #-} + step' gst (st, False, _) = do + r <- step gst st + case r of + Yield x s -> case cmp a x of + GT -> return $ Yield x (s, False, Nothing) + _ -> return $ Yield a (s, True, Just x) + Skip s -> return $ Skip (s, False, Nothing) + Stop -> return $ Yield a (st, True, Nothing) + + step' _ (_, True, Nothing) = return Stop + + step' gst (st, True, Just prev) = do + r <- step gst st + case r of + Yield x s -> return $ Yield prev (s, True, Just x) + Skip s -> return $ Skip (s, True, Just prev) + Stop -> return $ Yield prev (st, True, Nothing) + +data LoopState x s = FirstYield s + | InterspersingYield s + | YieldAndCarry x s + +-- | Effectful variant of 'intersperse'. Insert an effect and its output +-- between successive elements of a stream. It does nothing if stream has less +-- than two elements. +-- +-- Definition: +-- +-- >>> intersperseM x = Stream.interleaveSepBy (Stream.repeatM x) +-- +{-# INLINE_NORMAL intersperseM #-} +intersperseM :: Monad m => m a -> Stream m a -> Stream m a +intersperseM m (Stream step state) = Stream step' (FirstYield state) + where + {-# INLINE_LATE step' #-} + step' gst (FirstYield st) = do + r <- step gst st + return $ + case r of + Yield x s -> Skip (YieldAndCarry x s) + Skip s -> Skip (FirstYield s) + Stop -> Stop + + step' gst (InterspersingYield st) = do + r <- step gst st + case r of + Yield x s -> do + a <- m + return $ Yield a (YieldAndCarry x s) + Skip s -> return $ Skip $ InterspersingYield s + Stop -> return Stop + + step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st) + +-- | Insert a pure value between successive elements of a stream. It does +-- nothing if stream has less than two elements. +-- +-- Definition: +-- +-- >>> intersperse x = Stream.intersperseM (return x) +-- >>> intersperse x = Stream.unfoldEachSepBy x Unfold.identity +-- >>> intersperse x = Stream.unfoldEachSepBySeq x Unfold.identity +-- >>> intersperse x = Stream.interleaveSepBy (Stream.repeat x) +-- +-- Example: +-- +-- >>> f x y = Stream.toList $ Stream.intersperse x $ Stream.fromList y +-- >>> f ',' "abc" +-- "a,b,c" +-- >>> f ',' "a" +-- "a" +-- +{-# INLINE intersperse #-} +intersperse :: Monad m => a -> Stream m a -> Stream m a +intersperse a = intersperseM (return a) + +-- | Perform a side effect between two successive elements of a stream. It does +-- nothing if the stream has less than two elements. +-- +-- >>> f x y = Stream.fold Fold.drain $ Stream.trace putChar $ Stream.intersperseM_ x $ Stream.fromList y +-- >>> f (putChar '.') "abc" +-- a.b.c +-- >>> f (putChar '.') "a" +-- a +-- +-- /Pre-release/ +{-# INLINE_NORMAL intersperseM_ #-} +intersperseM_ :: Monad m => m b -> Stream m a -> Stream m a +intersperseM_ m (Stream step1 state1) = Stream step (Left (pure (), state1)) + where + {-# INLINE_LATE step #-} + step gst (Left (eff, st)) = do + r <- step1 gst st + case r of + Yield x s -> eff >> return (Yield x (Right s)) + Skip s -> return $ Skip (Left (eff, s)) + Stop -> return Stop + + step _ (Right st) = return $ Skip $ Left (void m, st) + +-- | Intersperse a monadic action into the input stream after every @n@ +-- elements. +-- +-- Definition: +-- +-- >> intersperseEveryM n x = Stream.interleaveEverySepBy n (Stream.repeatM x) +-- +-- Idioms: +-- +-- >>> intersperseM = Stream.intersperseEveryM 1 +-- >>> intersperse x = Stream.intersperseEveryM 1 (return x) +-- +-- Usage: +-- +-- >> input = Stream.fromList "hello" +-- >> Stream.toList $ Stream.intersperseEveryM 2 (return ',') input +-- "he,ll,o" +-- +-- /Unimplemented/ +{-# INLINE intersperseEveryM #-} +intersperseEveryM :: -- Monad m => + Int -> m a -> Stream m a -> Stream m a +intersperseEveryM _n _f _xs = undefined + +data SuffixState s a + = SuffixElem s + | SuffixSuffix s + | SuffixYield a (SuffixState s a) + +-- | Insert an effect and its output after every element of a stream. +-- +-- Definition: +-- +-- >>> intersperseEndByM x = Stream.interleaveEndBy (Stream.repeatM x) +-- +-- Usage: +-- +-- >>> f x y = Stream.toList $ Stream.intersperseEndByM (pure x) $ Stream.fromList y +-- >>> f ',' "abc" +-- "a,b,c," +-- >>> f ',' "a" +-- "a," +-- +-- /Pre-release/ +{-# INLINE_NORMAL intersperseEndByM #-} +intersperseEndByM, intersperseMSuffix :: forall m a. Monad m => + m a -> Stream m a -> Stream m a +intersperseEndByM action (Stream step state) = Stream step' (SuffixElem state) + where + {-# INLINE_LATE step' #-} + step' gst (SuffixElem st) = do + r <- step gst st + return $ case r of + Yield x s -> Skip (SuffixYield x (SuffixSuffix s)) + Skip s -> Skip (SuffixElem s) + Stop -> Stop + + step' _ (SuffixSuffix st) = do + action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st)) + + step' _ (SuffixYield x next) = return $ Yield x next + +RENAME(intersperseMSuffix,intersperseEndByM) + +-- | Insert an effect after every element of a stream. +-- +-- Example: +-- +-- >>> f x y = Stream.fold Fold.drain $ Stream.trace putChar $ Stream.intersperseEndByM_ x $ Stream.fromList y +-- >>> f (putChar '.') "abc" +-- a.b.c. +-- >>> f (putChar '.') "a" +-- a. +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL intersperseEndByM_ #-} +intersperseEndByM_, intersperseMSuffix_ :: Monad m => m b -> Stream m a -> Stream m a +intersperseEndByM_ m (Stream step1 state1) = Stream step (Left state1) + where + {-# INLINE_LATE step #-} + step gst (Left st) = do + r <- step1 gst st + case r of + Yield x s -> return $ Yield x (Right s) + Skip s -> return $ Skip $ Left s + Stop -> return Stop + + step _ (Right st) = m >> return (Skip (Left st)) + +RENAME(intersperseMSuffix_,intersperseEndByM_) + +data SuffixSpanState s a + = SuffixSpanElem s Int + | SuffixSpanSuffix s + | SuffixSpanYield a (SuffixSpanState s a) + | SuffixSpanLast + | SuffixSpanStop + +-- | Like 'intersperseEndByM' but intersperses an effectful action into the +-- input stream after every @n@ elements and also after the last element. +-- +-- Example: +-- +-- >>> input = Stream.fromList "hello" +-- >>> Stream.toList $ Stream.intersperseEndByEveryM 2 (return ',') input +-- "he,ll,o," +-- >>> f n x y = Stream.toList $ Stream.intersperseEndByEveryM n (pure x) $ Stream.fromList y +-- >>> f 2 ',' "abcdef" +-- "ab,cd,ef," +-- >>> f 2 ',' "abcdefg" +-- "ab,cd,ef,g," +-- >>> f 2 ',' "a" +-- "a," +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL intersperseEndByEveryM #-} +intersperseEndByEveryM, intersperseMSuffixWith :: forall m a. Monad m + => Int -> m a -> Stream m a -> Stream m a +intersperseEndByEveryM n action (Stream step state) = + Stream step' (SuffixSpanElem state n) + where + {-# INLINE_LATE step' #-} + step' gst (SuffixSpanElem st i) | i > 0 = do + r <- step gst st + return $ case r of + Yield x s -> Skip (SuffixSpanYield x (SuffixSpanElem s (i - 1))) + Skip s -> Skip (SuffixSpanElem s i) + Stop -> if i == n then Stop else Skip SuffixSpanLast + step' _ (SuffixSpanElem st _) = return $ Skip (SuffixSpanSuffix st) + + step' _ (SuffixSpanSuffix st) = do + action >>= \r -> return $ Skip (SuffixSpanYield r (SuffixSpanElem st n)) + + step' _ SuffixSpanLast = do + action >>= \r -> return $ Skip (SuffixSpanYield r SuffixSpanStop) + + step' _ (SuffixSpanYield x next) = return $ Yield x next + + step' _ SuffixSpanStop = return Stop + +RENAME(intersperseMSuffixWith,intersperseEndByEveryM) + +-- | Insert a side effect before every element of a stream. +-- +-- Definition: +-- +-- >>> intersperseBeginByM_ = Stream.trace_ +-- >>> intersperseBeginByM_ m = Stream.mapM (\x -> void m >> return x) +-- +-- Usage: +-- +-- >>> f x y = Stream.fold Fold.drain $ Stream.trace putChar $ Stream.intersperseBeginByM_ x $ Stream.fromList y +-- >>> f (putChar '.') "abc" +-- .a.b.c +-- +-- Same as 'trace_'. +-- +-- /Pre-release/ +-- +{-# INLINE intersperseBeginByM_ #-} +intersperseBeginByM_, intersperseMPrefix_ :: Monad m => + m b -> Stream m a -> Stream m a +intersperseBeginByM_ m = mapM (\x -> void m >> return x) + +RENAME(intersperseMPrefix_,intersperseBeginByM_) + +------------------------------------------------------------------------------ +-- Inserting Time +------------------------------------------------------------------------------ + +-- XXX This should be in Prelude, should we export this as a helper function? + +-- | Block the current thread for specified number of seconds. +{-# INLINE sleep #-} +sleep :: MonadIO m => Double -> m () +sleep n = liftIO $ threadDelay $ round $ n * 1000000 + +-- | Introduce a delay of specified seconds between elements of the stream. +-- +-- Definition: +-- +-- >>> sleep n = liftIO $ threadDelay $ round $ n * 1000000 +-- >>> delay = Stream.intersperseM_ . sleep +-- +-- Example: +-- +-- >>> input = Stream.enumerateFromTo 1 3 +-- >>> Stream.fold (Fold.drainMapM print) $ Stream.delay 1 input +-- 1 +-- 2 +-- 3 +-- +{-# INLINE delay #-} +delay :: MonadIO m => Double -> Stream m a -> Stream m a +delay = intersperseM_ . sleep + +-- | Introduce a delay of specified seconds after consuming an element of a +-- stream. +-- +-- Definition: +-- +-- >>> sleep n = liftIO $ threadDelay $ round $ n * 1000000 +-- >>> delayPost = Stream.intersperseEndByM_ . sleep +-- +-- Example: +-- +-- >>> input = Stream.enumerateFromTo 1 3 +-- >>> Stream.fold (Fold.drainMapM print) $ Stream.delayPost 1 input +-- 1 +-- 2 +-- 3 +-- +-- /Pre-release/ +-- +{-# INLINE delayPost #-} +delayPost :: MonadIO m => Double -> Stream m a -> Stream m a +delayPost n = intersperseMSuffix_ $ liftIO $ threadDelay $ round $ n * 1000000 + +-- | Introduce a delay of specified seconds before consuming an element of a +-- stream. +-- +-- Definition: +-- +-- >>> sleep n = liftIO $ threadDelay $ round $ n * 1000000 +-- >>> delayPre = Stream.intersperseBeginByM_ . sleep +-- +-- Example: +-- +-- >>> input = Stream.enumerateFromTo 1 3 +-- >>> Stream.fold (Fold.drainMapM print) $ Stream.delayPre 1 input +-- 1 +-- 2 +-- 3 +-- +-- /Pre-release/ +-- +{-# INLINE delayPre #-} +delayPre :: MonadIO m => Double -> Stream m a -> Stream m a +delayPre = intersperseMPrefix_. sleep + +------------------------------------------------------------------------------ +-- Reordering +------------------------------------------------------------------------------ + +-- | Returns the elements of the stream in reverse order. The stream must be +-- finite. Note that this necessarily buffers the entire stream in memory. +-- +-- Definition: +-- +-- >>> reverse m = Stream.concatEffect $ Stream.fold Fold.toListRev m >>= return . Stream.fromList +-- +{-# INLINE_NORMAL reverse #-} +reverse :: Monad m => Stream m a -> Stream m a +reverse m = concatEffect $ fold FL.toListRev m <&> fromList +{- +reverse m = Stream step Nothing + where + {-# INLINE_LATE step #-} + step _ Nothing = do + xs <- foldl' (flip (:)) [] m + return $ Skip (Just xs) + step _ (Just (x:xs)) = return $ Yield x (Just xs) + step _ (Just []) = return Stop +-} + +-- | Like 'reverse' but several times faster, requires an 'Unbox' instance. +-- +-- /O(n) space/ +-- +-- /Pre-release/ +{-# INLINE reverseUnbox #-} +reverseUnbox :: (MonadIO m, Unbox a) => Stream m a -> Stream m a +reverseUnbox = + A.concatRev -- unfoldMany A.readerRev + . fromStreamK + . K.reverse + . toStreamK + . A.chunksOf defaultChunkSize + +-- | Buffer until the next element in sequence arrives. The function argument +-- determines the difference in sequence numbers. This could be useful in +-- implementing sequenced streams, for example, TCP reassembly. +-- +-- /Unimplemented/ +-- +{-# INLINE reassembleBy #-} +reassembleBy + :: -- Monad m => + Fold m a b + -> (a -> a -> Int) + -> Stream m a + -> Stream m b +reassembleBy = undefined + +------------------------------------------------------------------------------ +-- Position Indexing +------------------------------------------------------------------------------ + +-- Adapted from the vector package + +-- | +-- >>> f = Scanl.mkScanl (\(i, _) x -> (i + 1, x)) (-1,undefined) +-- >>> indexed = Stream.postscanl f +-- >>> indexed = Stream.zipWith (,) (Stream.enumerateFrom 0) +-- >>> indexedR n = fmap (\(i, a) -> (n - i, a)) . indexed +-- +-- Pair each element in a stream with its index, starting from index 0. +-- +-- >>> Stream.fold Fold.toList $ Stream.indexed $ Stream.fromList "hello" +-- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')] +-- +{-# INLINE_NORMAL indexed #-} +indexed :: Monad m => Stream m a -> Stream m (Int, a) +-- indexed = scanMaybe FL.indexing +indexed (Stream step state) = Stream step' (state, 0) + where + {-# INLINE_LATE step' #-} + step' gst (st, i) = i `seq` do + r <- step (adaptState gst) st + case r of + Yield x s -> return $ Yield (i, x) (s, i+1) + Skip s -> return $ Skip (s, i) + Stop -> return Stop + +-- Adapted from the vector package + +-- | +-- >>> f n = Scanl.mkScanl (\(i, _) x -> (i - 1, x)) (n + 1,undefined) +-- >>> indexedR n = Stream.postscanl (f n) +-- +-- >>> s n = Stream.enumerateFromThen n (n - 1) +-- >>> indexedR n = Stream.zipWith (,) (s n) +-- +-- Pair each element in a stream with its index, starting from the +-- given index @n@ and counting down. +-- +-- >>> Stream.fold Fold.toList $ Stream.indexedR 10 $ Stream.fromList "hello" +-- [(10,'h'),(9,'e'),(8,'l'),(7,'l'),(6,'o')] +-- +{-# INLINE_NORMAL indexedR #-} +indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a) +-- indexedR n = scanMaybe (FL.indexingRev n) +indexedR m (Stream step state) = Stream step' (state, m) + where + {-# INLINE_LATE step' #-} + step' gst (st, i) = i `seq` do + r <- step (adaptState gst) st + case r of + Yield x s -> let i' = i - 1 + in return $ Yield (i, x) (s, i') + Skip s -> return $ Skip (s, i) + Stop -> return Stop + +------------------------------------------------------------------------------- +-- Time Indexing +------------------------------------------------------------------------------- + +-- Note: The timestamp stream must be the second stream in the zip so that the +-- timestamp is generated after generating the stream element and not before. +-- If we do not do that then the following example will generate the same +-- timestamp for first two elements: +-- +-- Stream.fold Fold.toList $ Stream.timestamped $ Stream.delay $ Stream.enumerateFromTo 1 3 + +-- | Pair each element in a stream with an absolute timestamp, using a clock of +-- specified granularity. The timestamp is generated just before the element +-- is consumed. +-- +-- >>> Stream.fold Fold.toList $ Stream.timestampWith 0.01 $ Stream.delay 1 $ Stream.enumerateFromTo 1 3 +-- [(AbsTime (TimeSpec {sec = ..., nsec = ...}),1),(AbsTime (TimeSpec {sec = ..., nsec = ...}),2),(AbsTime (TimeSpec {sec = ..., nsec = ...}),3)] +-- +-- /Pre-release/ +-- +{-# INLINE timestampWith #-} +timestampWith :: (MonadIO m) + => Double -> Stream m a -> Stream m (AbsTime, a) +timestampWith g stream = zipWith (flip (,)) stream (absTimesWith g) + +-- TBD: check performance vs a custom implementation without using zipWith. +-- +-- /Pre-release/ +-- +{-# INLINE timestamped #-} +timestamped :: (MonadIO m) + => Stream m a -> Stream m (AbsTime, a) +timestamped = timestampWith 0.01 + +-- | Pair each element in a stream with relative times starting from 0, using a +-- clock with the specified granularity. The time is measured just before the +-- element is consumed. +-- +-- >>> Stream.fold Fold.toList $ Stream.timeIndexWith 0.01 $ Stream.delay 1 $ Stream.enumerateFromTo 1 3 +-- [(RelTime64 (NanoSecond64 ...),1),(RelTime64 (NanoSecond64 ...),2),(RelTime64 (NanoSecond64 ...),3)] +-- +-- /Pre-release/ +-- +{-# INLINE timeIndexWith #-} +timeIndexWith :: (MonadIO m) + => Double -> Stream m a -> Stream m (RelTime64, a) +timeIndexWith g stream = zipWith (flip (,)) stream (relTimesWith g) + +-- | Pair each element in a stream with relative times starting from 0, using a +-- 10 ms granularity clock. The time is measured just before the element is +-- consumed. +-- +-- >>> Stream.fold Fold.toList $ Stream.timeIndexed $ Stream.delay 1 $ Stream.enumerateFromTo 1 3 +-- [(RelTime64 (NanoSecond64 ...),1),(RelTime64 (NanoSecond64 ...),2),(RelTime64 (NanoSecond64 ...),3)] +-- +-- /Pre-release/ +-- +{-# INLINE timeIndexed #-} +timeIndexed :: (MonadIO m) + => Stream m a -> Stream m (RelTime64, a) +timeIndexed = timeIndexWith 0.01 + +------------------------------------------------------------------------------ +-- Searching +------------------------------------------------------------------------------ + +-- | Find all the indices where the element in the stream satisfies the given +-- predicate. +-- +-- >>> findIndices p = Stream.postscanlMaybe (Scanl.findIndices p) +-- +{-# INLINE_NORMAL findIndices #-} +findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int +findIndices p (Stream step state) = Stream step' (state, 0) + where + {-# INLINE_LATE step' #-} + step' gst (st, i) = i `seq` do + r <- step (adaptState gst) st + return $ case r of + Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1) + Skip s -> Skip (s, i) + Stop -> Stop + +-- | Find all the indices where the value of the element in the stream is equal +-- to the given value. +-- +-- >>> elemIndices a = Stream.findIndices (== a) +-- +{-# INLINE elemIndices #-} +elemIndices :: (Monad m, Eq a) => a -> Stream m a -> Stream m Int +elemIndices a = findIndices (== a) + +------------------------------------------------------------------------------ +-- Rolling map +------------------------------------------------------------------------------ + +data RollingMapState s a = RollingMapGo s a + +-- | Like 'rollingMap' but with an effectful map function. +-- +-- /Pre-release/ +-- +{-# INLINE rollingMapM #-} +rollingMapM :: Monad m => (Maybe a -> a -> m b) -> Stream m a -> Stream m b +-- rollingMapM f = scanMaybe (FL.slide2 $ Window.rollingMapM f) +rollingMapM f (Stream step1 state1) = Stream step (RollingMapGo state1 Nothing) + + where + + step gst (RollingMapGo s1 curr) = do + r <- step1 (adaptState gst) s1 + case r of + Yield x s -> do + !res <- f curr x + return $ Yield res $ RollingMapGo s (Just x) + Skip s -> return $ Skip $ RollingMapGo s curr + Stop -> return Stop + +-- rollingMap is a special case of an incremental sliding fold. It can be +-- written as: +-- +-- > fld f = slidingWindow 1 (Scanl.mkScanl (\_ (x,y) -> f y x) +-- > rollingMap f = Stream.postscan (fld f) undefined + +-- | Apply a function on every two successive elements of a stream. The first +-- argument of the map function is the previous element and the second argument +-- is the current element. When the current element is the first element, the +-- previous element is 'Nothing'. +-- +-- /Pre-release/ +-- +{-# INLINE rollingMap #-} +rollingMap :: Monad m => (Maybe a -> a -> b) -> Stream m a -> Stream m b +-- rollingMap f = scanMaybe (FL.slide2 $ Window.rollingMap f) +rollingMap f = rollingMapM (\x y -> return $ f x y) + +-- | Like 'rollingMap' but requires at least two elements in the stream, +-- returns an empty stream otherwise. +-- +-- This is the stream equivalent of the list idiom @zipWith f xs (tail xs)@. +-- +-- /Pre-release/ +-- +{-# INLINE rollingMap2 #-} +rollingMap2 :: Monad m => (a -> a -> b) -> Stream m a -> Stream m b +rollingMap2 f = catMaybes . rollingMap g + + where + + g Nothing _ = Nothing + g (Just x) y = Just (f x y) + +------------------------------------------------------------------------------ +-- Maybe Streams +------------------------------------------------------------------------------ + +-- XXX Will this always fuse properly? + +-- | Map a 'Maybe' returning function to a stream, filter out the 'Nothing' +-- elements, and return a stream of values extracted from 'Just'. +-- +-- Equivalent to: +-- +-- >>> mapMaybe f = Stream.catMaybes . fmap f +-- +{-# INLINE_NORMAL mapMaybe #-} +mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b +mapMaybe f = fmap fromJust . filter isJust . map f + +-- | Like 'mapMaybe' but maps a monadic function. +-- +-- Equivalent to: +-- +-- >>> mapMaybeM f = Stream.catMaybes . Stream.mapM f +-- +-- >>> mapM f = Stream.mapMaybeM (\x -> Just <$> f x) +-- +{-# INLINE_NORMAL mapMaybeM #-} +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b +mapMaybeM f = fmap fromJust . filter isJust . mapM f + +-- | In a stream of 'Maybe's, discard 'Nothing's and unwrap 'Just's. +-- +-- >>> catMaybes = Stream.mapMaybe id +-- >>> catMaybes = fmap fromJust . Stream.filter isJust +-- +-- /Pre-release/ +-- +{-# INLINE catMaybes #-} +catMaybes :: Monad m => Stream m (Maybe a) -> Stream m a +-- catMaybes = fmap fromJust . filter isJust +catMaybes (Stream step state) = Stream step1 state + + where + + {-# INLINE_LATE step1 #-} + step1 gst st = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + return + $ case x of + Just a -> Yield a s + Nothing -> Skip s + Skip s -> return $ Skip s + Stop -> return Stop + +-- | Use a filtering scan on a stream. +-- +-- >>> postscanlMaybe f = Stream.catMaybes . Stream.postscanl f +-- +{-# INLINE postscanlMaybe #-} +postscanlMaybe :: Monad m => Scanl m a (Maybe b) -> Stream m a -> Stream m b +postscanlMaybe f = catMaybes . postscanl f + +{-# DEPRECATED scanMaybe "Use postscanlMaybe instead" #-} +{-# INLINE scanMaybe #-} +scanMaybe :: Monad m => Fold m a (Maybe b) -> Stream m a -> Stream m b +scanMaybe f = catMaybes . postscan f + +------------------------------------------------------------------------------ +-- Either streams +------------------------------------------------------------------------------ + +-- | Discard 'Right's and unwrap 'Left's in an 'Either' stream. +-- +-- >>> catLefts = fmap (fromLeft undefined) . Stream.filter isLeft +-- +-- /Pre-release/ +-- +{-# INLINE catLefts #-} +catLefts :: Monad m => Stream m (Either a b) -> Stream m a +catLefts = fmap (fromLeft undefined) . filter isLeft + +-- | Discard 'Left's and unwrap 'Right's in an 'Either' stream. +-- +-- >>> catRights = fmap (fromRight undefined) . Stream.filter isRight +-- +-- /Pre-release/ +-- +{-# INLINE catRights #-} +catRights :: Monad m => Stream m (Either a b) -> Stream m b +catRights = fmap (fromRight undefined) . filter isRight + +-- | Remove the either wrapper and flatten both lefts and as well as rights in +-- the output stream. +-- +-- >>> catEithers = fmap (either id id) +-- +-- /Pre-release/ +-- +{-# INLINE catEithers #-} +catEithers :: Monad m => Stream m (Either a a) -> Stream m a +catEithers = fmap (either id id) + +------------------------------------------------------------------------------ +-- Splitting +------------------------------------------------------------------------------ + +-- Design note: If we use splitSepBy_ on an empty stream what should be the +-- result? Let's try the splitOn function in the "split" package: +-- +-- > splitOn "a" "" +-- [""] +-- +-- Round tripping the result through intercalate gives identity: +-- +-- > intercalate "a" [""] +-- "" +-- +-- Now let's try intercalate on empty list: +-- +-- > intercalate "a" [] +-- "" +-- +-- Round tripping it with splitOn is not identity: +-- +-- > splitOn "a" "" +-- [""] +-- +-- Because intercalate flattens the two layers, both [] and [""] produce the +-- same result after intercalate. Therefore, inverse of intercalate is not +-- possible. We have to choose one of the two options for splitting an empty +-- stream. +-- +-- Choosing empty stream as the result of splitting empty stream makes better +-- sense. This is different from the split package's choice. Splitting an empty +-- stream resulting into a non-empty stream seems a bit odd. Also, splitting +-- empty stream to empty stream is consistent with splitEndBy operation as +-- well. + +{-# ANN type SplitSepBy Fuse #-} +data SplitSepBy s fs b a + = SplitSepByInit s + | SplitSepByInitFold0 s + | SplitSepByInitFold1 s fs + | SplitSepByCheck s a fs + | SplitSepByNext s fs + | SplitSepByYield b (SplitSepBy s fs b a) + | SplitSepByDone + +-- | Split on an infixed separator element, dropping the separator. The +-- supplied 'Fold' is applied on the split segments. Splits the stream on +-- separator elements determined by the supplied predicate, separator is +-- considered as infixed between two segments: +-- +-- Definition: +-- +-- +-- Usage: +-- +-- >>> splitOn p xs = Stream.fold Fold.toList $ Stream.splitSepBy_ p Fold.toList (Stream.fromList xs) +-- >>> splitOn (== '.') "a.b" +-- ["a","b"] +-- +-- Splitting an empty stream results in an empty stream i.e. zero splits: +-- +-- >>> splitOn (== '.') "" +-- [] +-- +-- If the stream does not contain the separator then it results in a single +-- split: +-- +-- >>> splitOn (== '.') "abc" +-- ["abc"] +-- +-- If one or both sides of the separator are missing then the empty segment on +-- that side is folded to the default output of the fold: +-- +-- >>> splitOn (== '.') "." +-- ["",""] +-- +-- >>> splitOn (== '.') ".a" +-- ["","a"] +-- +-- >>> splitOn (== '.') "a." +-- ["a",""] +-- +-- >>> splitOn (== '.') "a..b" +-- ["a","","b"] +-- +-- 'splitSepBy_' is an inverse of 'unfoldEachSepBy': +-- +-- > Stream.unfoldEachSepBy '.' Unfold.fromList . Stream.splitSepBy_ (== '.') Fold.toList === id +-- +-- Assuming the input stream does not contain the separator: +-- +-- > Stream.splitSepBy_ (== '.') Fold.toList . Stream.unfoldEachSepBy '.' Unfold.fromList === id +-- +{-# INLINE splitSepBy_ #-} +splitSepBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +-- We can express the infix splitting in terms of optional suffix split +-- fold. After applying a suffix split fold repeatedly if the last segment +-- ends with a suffix then we need to return the default output of the fold +-- after that to make it an infix split. +-- +-- Alternately, we can also express it using an optional prefix split fold. +-- If the first segment starts with a prefix then we need to emit the +-- default output of the fold before that to make it an infix split, and +-- then apply prefix split fold repeatedly. +-- +splitSepBy_ predicate (Fold fstep initial _ final) (Stream step1 state1) = + Stream step (SplitSepByInit state1) + + where + + -- Note: there is a question of whether we should initialize the fold + -- before we run the stream or only after the stream yields an element. If + -- we initialize it before then we may have to discard an effect if the + -- stream does not yield anything. If we initialize it after then we may + -- have to discard the stream element if the fold terminates without + -- consuming anything. Though the state machine is simpler if we initialize + -- the fold first. Also, in most common cases the fold is not effectful. + -- On the other hand, in most cases the fold will not terminate without + -- consuming anything. So both ways are similar. + {-# INLINE_LATE step #-} + step _ (SplitSepByInit st) = do + fres <- initial + return + $ Skip + $ case fres of + FL.Done b -> SplitSepByYield b (SplitSepByInit st) + FL.Partial fs -> SplitSepByInitFold1 st fs + + step _ (SplitSepByInitFold0 st) = do + fres <- initial + return + $ Skip + $ case fres of + FL.Done b -> SplitSepByYield b (SplitSepByInitFold0 st) + FL.Partial fs -> SplitSepByNext st fs + + step gst (SplitSepByInitFold1 st fs) = do + r <- step1 (adaptState gst) st + case r of + Yield x s -> return $ Skip $ SplitSepByCheck s x fs + Skip s -> return $ Skip (SplitSepByInitFold1 s fs) + Stop -> final fs >> return Stop + + step _ (SplitSepByCheck st x fs) = do + if predicate x + then do + b <- final fs + return $ Skip $ SplitSepByYield b (SplitSepByInitFold0 st) + else do + fres <- fstep fs x + return + $ Skip + $ case fres of + FL.Done b -> SplitSepByYield b (SplitSepByInitFold0 st) + FL.Partial fs1 -> SplitSepByNext st fs1 + + step gst (SplitSepByNext st fs) = do + r <- step1 (adaptState gst) st + case r of + Yield x s -> return $ Skip $ SplitSepByCheck s x fs + Skip s -> return $ Skip (SplitSepByNext s fs) + Stop -> do + b <- final fs + return $ Skip $ SplitSepByYield b SplitSepByDone + + step _ (SplitSepByYield b next) = return $ Yield b next + step _ SplitSepByDone = return Stop + +{-# DEPRECATED splitOn "Please use splitSepBy_ instead. Note the difference in behavior on splitting empty stream." #-} +{-# INLINE splitOn #-} +splitOn :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +splitOn predicate f = + foldManyPost (FL.takeEndBy_ predicate f) diff --git a/src/Streamly/Internal/Data/Stream/Transformer.hs b/src/Streamly/Internal/Data/Stream/Transformer.hs --- a/src/Streamly/Internal/Data/Stream/Transformer.hs +++ b/src/Streamly/Internal/Data/Stream/Transformer.hs @@ -1,44 +1,62 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Internal.Data.Stream.Transformer --- Copyright : (c) 2019 Composewell Technologies +-- Copyright : (c) 2018 Composewell Technologies -- License : BSD-3-Clause -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC +-- +-- Transform the underlying monad of a stream using a monad transfomer. module Streamly.Internal.Data.Stream.Transformer ( + -- * Fold to Transformer Monad foldlT , foldrT + -- * Inner Monad Operations , liftInner - , usingReaderT + , runReaderT + , usingReaderT + , withReaderT + , localReaderT + , evalStateT - , usingStateT , runStateT + , usingStateT ) where -import Control.Monad.Trans.Class (MonadTrans) +#include "inline.hs" + +import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.State.Strict (StateT) -import Streamly.Internal.Data.Stream.Type (Stream, fromStreamD, toStreamD) +import GHC.Types (SPEC(..)) +import Streamly.Internal.Data.SVar.Type (defState, adaptState) -import qualified Streamly.Internal.Data.Stream.StreamD.Transformer as D +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.State.Strict as State --- $setup --- >>> :m --- >>> import Control.Monad.Trans.Class (lift) --- >>> import Control.Monad.Trans.Identity (runIdentityT) --- >>> import qualified Streamly.Internal.Data.Stream as Stream +import Streamly.Internal.Data.Stream.Type +#include "DocTestDataStream.hs" + -- | Lazy left fold to a transformer monad. -- -{-# INLINE foldlT #-} +{-# INLINE_NORMAL foldlT #-} foldlT :: (Monad m, Monad (s m), MonadTrans s) => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b -foldlT f z s = D.foldlT f z (toStreamD s) +foldlT fstep begin (Stream step state) = go SPEC begin state + where + go !_ acc st = do + r <- lift $ step defState st + case r of + Yield x s -> go SPEC (fstep acc x) s + Skip s -> go SPEC acc s + Stop -> acc -- | Right fold to a transformer monad. This is the most general right fold -- function. 'foldrS' is a special case of 'foldrT', however 'foldrS' @@ -53,22 +71,38 @@ -- monads e.g. to a different streaming type. -- -- /Pre-release/ -{-# INLINE foldrT #-} -foldrT :: (Monad m, Monad (s m), MonadTrans s) - => (a -> s m b -> s m b) -> s m b -> Stream m a -> s m b -foldrT f z s = D.foldrT f z (toStreamD s) +{-# INLINE_NORMAL foldrT #-} +foldrT :: (Monad m, Monad (t m), MonadTrans t) + => (a -> t m b -> t m b) -> t m b -> Stream m a -> t m b +foldrT f final (Stream step state) = go SPEC state + where + {-# INLINE_LATE go #-} + go !_ st = do + r <- lift $ step defState st + case r of + Yield x s -> f x (go SPEC s) + Skip s -> go SPEC s + Stop -> final ------------------------------------------------------------------------------- --- Add and remove a monad transformer ------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +-- Transform Inner Monad +------------------------------------------------------------------------------- -- | Lift the inner monad @m@ of @Stream m a@ to @t m@ where @t@ is a monad -- transformer. -- -{-# INLINE liftInner #-} +{-# INLINE_NORMAL liftInner #-} liftInner :: (Monad m, MonadTrans t, Monad (t m)) => Stream m a -> Stream (t m) a -liftInner xs = fromStreamD $ D.liftInner (toStreamD xs) +liftInner (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- lift $ step (adaptState gst) st + return $ case r of + Yield x s -> Yield x s + Skip s -> Skip s + Stop -> Stop ------------------------------------------------------------------------------ -- Sharing read only state in a stream @@ -76,16 +110,21 @@ -- | Evaluate the inner monad of a stream as 'ReaderT'. -- -{-# INLINE runReaderT #-} +{-# INLINE_NORMAL runReaderT #-} runReaderT :: Monad m => m s -> Stream (ReaderT s m) a -> Stream m a -runReaderT s xs = fromStreamD $ D.runReaderT s (toStreamD xs) +runReaderT env (Stream step state) = Stream step' (state, env) + where + {-# INLINE_LATE step' #-} + step' gst (st, action) = do + sv <- action + r <- Reader.runReaderT (step (adaptState gst) st) sv + return $ case r of + Yield x s -> Yield x (s, return sv) + Skip s -> Skip (s, return sv) + Stop -> Stop -- | Run a stream transformation using a given environment. -- --- See also: 'Serial.map' --- --- / Internal/ --- {-# INLINE usingReaderT #-} usingReaderT :: Monad m @@ -95,6 +134,28 @@ -> Stream m a usingReaderT r f xs = runReaderT r $ f $ liftInner xs +-- | Modify the environment of the underlying ReaderT monad. +{-# INLINABLE withReaderT #-} +withReaderT :: Monad m => + (r2 -> r1) -> Stream (ReaderT r1 m) a -> Stream (ReaderT r2 m) a +withReaderT f (Stream step state) = Stream step1 state + + where + + {-# INLINE_LATE step1 #-} + step1 gst st = do + r <- Reader.withReaderT f (step (adaptState gst) st) + return $ case r of + Yield x s -> Yield x s + Skip s -> Skip s + Stop -> Stop + +-- | Modify the environment of the underlying ReaderT monad. +{-# INLINABLE localReaderT #-} +localReaderT :: Monad m => + (r -> r) -> Stream (ReaderT r m) a -> Stream (ReaderT r m) a +localReaderT = withReaderT + ------------------------------------------------------------------------------ -- Sharing read write state in a stream ------------------------------------------------------------------------------ @@ -103,12 +164,34 @@ -- -- >>> evalStateT s = fmap snd . Stream.runStateT s -- --- / Internal/ +{-# INLINE_NORMAL evalStateT #-} +evalStateT :: Monad m => m s -> Stream (StateT s m) a -> Stream m a +evalStateT initial (Stream step state) = Stream step' (state, initial) + where + {-# INLINE_LATE step' #-} + step' gst (st, action) = do + sv <- action + (r, !sv') <- State.runStateT (step (adaptState gst) st) sv + return $ case r of + Yield x s -> Yield x (s, return sv') + Skip s -> Skip (s, return sv') + Stop -> Stop + +-- | Evaluate the inner monad of a stream as 'StateT' and emit the resulting +-- state and value pair after each step. -- -{-# INLINE evalStateT #-} -evalStateT :: Monad m => m s -> Stream (StateT s m) a -> Stream m a --- evalStateT s = fmap snd . runStateT s -evalStateT s xs = fromStreamD $ D.evalStateT s (toStreamD xs) +{-# INLINE_NORMAL runStateT #-} +runStateT :: Monad m => m s -> Stream (StateT s m) a -> Stream m (s, a) +runStateT initial (Stream step state) = Stream step' (state, initial) + where + {-# INLINE_LATE step' #-} + step' gst (st, action) = do + sv <- action + (r, !sv') <- State.runStateT (step (adaptState gst) st) sv + return $ case r of + Yield x s -> Yield (sv', x) (s, return sv') + Skip s -> Skip (s, return sv') + Stop -> Stop -- | Run a stateful (StateT) stream transformation using a given state. -- @@ -116,20 +199,11 @@ -- -- See also: 'scan' -- --- / Internal/ --- {-# INLINE usingStateT #-} usingStateT :: Monad m => m s - -> (Stream (StateT s m) a -> Stream (StateT s m) a) - -> Stream m a + -> (Stream (StateT s m) a -> Stream (StateT s m) b) -> Stream m a + -> Stream m b usingStateT s f = evalStateT s . f . liftInner - --- | Evaluate the inner monad of a stream as 'StateT' and emit the resulting --- state and value pair after each step. --- -{-# INLINE runStateT #-} -runStateT :: Monad m => m s -> Stream (StateT s m) a -> Stream m (s, a) -runStateT s xs = fromStreamD $ D.runStateT s (toStreamD xs) diff --git a/src/Streamly/Internal/Data/Stream/Type.hs b/src/Streamly/Internal/Data/Stream/Type.hs --- a/src/Streamly/Internal/Data/Stream/Type.hs +++ b/src/Streamly/Internal/Data/Stream/Type.hs @@ -1,491 +1,2704 @@ -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Streamly.Internal.Data.Stream.Type --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Stream.Type - ( - -- * Stream Type - Stream -- XXX To be removed - , StreamK - - -- * Type Conversion - , fromStreamK - , toStreamK - , fromStreamD - , toStreamD - , fromStream - , toStream - , Streamly.Internal.Data.Stream.Type.fromList - - -- * Construction - , cons - , consM - , nil - , nilM - , fromPure - , fromEffect - - -- * Applicative - , crossApply - , crossApplySnd - , crossApplyFst - , crossWith - , cross - - -- * Bind/Concat - , bindWith - , concatMapWith - - -- * Double folds - , eqBy - , cmpBy - ) -where - -#include "inline.hs" - -import Control.Applicative (liftA2) -import Data.Foldable (Foldable(foldl'), fold) -import Data.Functor.Identity (Identity(..), runIdentity) -import Data.Maybe (fromMaybe) -import Data.Semigroup (Endo(..)) -import GHC.Exts (IsList(..), IsString(..), oneShot) -import Streamly.Internal.BaseCompat ((#.)) -import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) -import Text.Read - ( Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec - , readListPrecDefault) - -import qualified Streamly.Internal.Data.Stream.Common as P -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - --- $setup --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Internal.Data.Unfold as Unfold --- >>> import qualified Streamly.Internal.Data.Stream as Stream - ------------------------------------------------------------------------------- --- Stream ------------------------------------------------------------------------------- - --- | Semigroup instance appends two streams: --- --- >>> (<>) = Stream.append --- -newtype StreamK m a = StreamK (K.StreamK m a) - -- XXX when deriving do we inherit an INLINE? - deriving (Semigroup, Monoid) - -type Stream = StreamK - ------------------------------------------------------------------------------- --- Conversions ------------------------------------------------------------------------------- - -{-# INLINE_EARLY fromStreamK #-} -fromStreamK :: K.StreamK m a -> Stream m a -fromStreamK = StreamK - -{-# INLINE_EARLY toStreamK #-} -toStreamK :: Stream m a -> K.StreamK m a -toStreamK (StreamK k) = k - -{-# INLINE_EARLY fromStreamD #-} -fromStreamD :: Monad m => D.Stream m a -> Stream m a -fromStreamD = fromStreamK . D.toStreamK - -{-# INLINE_EARLY toStreamD #-} -toStreamD :: Applicative m => Stream m a -> D.Stream m a -toStreamD = D.fromStreamK . toStreamK - -{-# INLINE fromStream #-} -fromStream :: Monad m => D.Stream m a -> Stream m a -fromStream = fromStreamD - -{-# INLINE toStream #-} -toStream :: Applicative m => Stream m a -> D.Stream m a -toStream = toStreamD - ------------------------------------------------------------------------------- --- Generation ------------------------------------------------------------------------------- - --- | --- >>> fromList = Prelude.foldr Stream.cons Stream.nil --- --- Construct a stream from a list of pure values. This is more efficient than --- 'fromFoldable'. --- -{-# INLINE fromList #-} -fromList :: Monad m => [a] -> Stream m a -fromList = fromStreamK . P.fromList - ------------------------------------------------------------------------------- --- Comparison ------------------------------------------------------------------------------- - --- | Compare two streams for equality --- -{-# INLINE eqBy #-} -eqBy :: Monad m => - (a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool -eqBy f m1 m2 = D.eqBy f (toStreamD m1) (toStreamD m2) - --- | Compare two streams --- -{-# INLINE cmpBy #-} -cmpBy - :: Monad m - => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering -cmpBy f m1 m2 = D.cmpBy f (toStreamD m1) (toStreamD m2) - ------------------------------------------------------------------------------- --- Functor ------------------------------------------------------------------------------- - -instance Monad m => Functor (Stream m) where - {-# INLINE fmap #-} - -- IMPORTANT: do not use eta reduction. - fmap f m = fromStreamD $ D.mapM (return . f) $ toStreamD m - - {-# INLINE (<$) #-} - (<$) = fmap . const - ------------------------------------------------------------------------------- --- Lists ------------------------------------------------------------------------------- - --- Serial streams can act like regular lists using the Identity monad - --- XXX Show instance is 10x slower compared to read, we can do much better. --- The list show instance itself is really slow. - --- XXX The default definitions of "<" in the Ord instance etc. do not perform --- well, because they do not get inlined. Need to add INLINE in Ord class in --- base? - -instance IsList (Stream Identity a) where - type (Item (Stream Identity a)) = a - - {-# INLINE fromList #-} - fromList xs = StreamK $ P.fromList xs - - {-# INLINE toList #-} - toList (StreamK xs) = runIdentity $ P.toList xs - -instance Eq a => Eq (Stream Identity a) where - {-# INLINE (==) #-} - (==) (StreamK xs) (StreamK ys) = runIdentity $ P.eqBy (==) xs ys - -instance Ord a => Ord (Stream Identity a) where - {-# INLINE compare #-} - compare (StreamK xs) (StreamK ys) = runIdentity $ P.cmpBy compare xs ys - - {-# INLINE (<) #-} - x < y = - case compare x y of - LT -> True - _ -> False - - {-# INLINE (<=) #-} - x <= y = - case compare x y of - GT -> False - _ -> True - - {-# INLINE (>) #-} - x > y = - case compare x y of - GT -> True - _ -> False - - {-# INLINE (>=) #-} - x >= y = - case compare x y of - LT -> False - _ -> True - - {-# INLINE max #-} - max x y = if x <= y then y else x - - {-# INLINE min #-} - min x y = if x <= y then x else y - -instance Show a => Show (Stream Identity a) where - showsPrec p dl = showParen (p > 10) $ - showString "fromList " . shows (toList dl) - -instance Read a => Read (Stream Identity a) where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - Streamly.Internal.Data.Stream.Type.fromList <$> readPrec - - readListPrec = readListPrecDefault - -instance (a ~ Char) => IsString (Stream Identity a) where - {-# INLINE fromString #-} - fromString xs = StreamK $ P.fromList xs - -------------------------------------------------------------------------------- --- Foldable -------------------------------------------------------------------------------- - --- The default Foldable instance has several issues: --- 1) several definitions do not have INLINE on them, so we provide --- re-implementations with INLINE pragmas. --- 2) the definitions of sum/product/maximum/minimum are inefficient as they --- use right folds, they cannot run in constant memory. We provide --- implementations using strict left folds here. - -instance (Foldable m, Monad m) => Foldable (Stream m) where - - {-# INLINE foldMap #-} - foldMap f (StreamK xs) = fold $ P.foldr (mappend . f) mempty xs - - {-# INLINE foldr #-} - foldr f z t = appEndo (foldMap (Endo #. f) t) z - - {-# INLINE foldl' #-} - foldl' f z0 xs = foldr f' id xs z0 - where f' x k = oneShot $ \z -> k $! f z x - - {-# INLINE length #-} - length = foldl' (\n _ -> n + 1) 0 - - {-# INLINE elem #-} - elem = any . (==) - - {-# INLINE maximum #-} - maximum = - fromMaybe (errorWithoutStackTrace "maximum: empty stream") - . toMaybe - . foldl' getMax Nothing' - - where - - getMax Nothing' x = Just' x - getMax (Just' mx) x = Just' $! max mx x - - {-# INLINE minimum #-} - minimum = - fromMaybe (errorWithoutStackTrace "minimum: empty stream") - . toMaybe - . foldl' getMin Nothing' - - where - - getMin Nothing' x = Just' x - getMin (Just' mn) x = Just' $! min mn x - - {-# INLINE sum #-} - sum = foldl' (+) 0 - - {-# INLINE product #-} - product = foldl' (*) 1 - -------------------------------------------------------------------------------- --- Traversable -------------------------------------------------------------------------------- - -instance Traversable (Stream Identity) where - {-# INLINE traverse #-} - traverse f (StreamK xs) = - fmap StreamK $ runIdentity $ P.foldr consA (pure mempty) xs - - where - - consA x ys = liftA2 K.cons (f x) ys - -------------------------------------------------------------------------------- --- Construction -------------------------------------------------------------------------------- - -infixr 5 `cons` - --- | A right associative prepend operation to add a pure value at the head of --- an existing stream:: --- --- >>> s = 1 `Stream.cons` 2 `Stream.cons` 3 `Stream.cons` Stream.nil --- >>> Stream.fold Fold.toList s --- [1,2,3] --- --- It can be used efficiently with 'Prelude.foldr': --- --- >>> fromFoldable = Prelude.foldr Stream.cons Stream.nil --- --- Same as the following but more efficient: --- --- >>> cons x xs = return x `Stream.consM` xs --- --- /CPS/ --- -{-# INLINE_NORMAL cons #-} -cons :: a -> Stream m a -> Stream m a -cons x = fromStreamK . K.cons x . toStreamK - -infixr 5 `consM` - --- | A right associative prepend operation to add an effectful value at the --- head of an existing stream:: --- --- >>> s = putStrLn "hello" `consM` putStrLn "world" `consM` Stream.nil --- >>> Stream.fold Fold.drain s --- hello --- world --- --- It can be used efficiently with 'Prelude.foldr': --- --- >>> fromFoldableM = Prelude.foldr Stream.consM Stream.nil --- --- Same as the following but more efficient: --- --- >>> consM x xs = Stream.fromEffect x `Stream.append` xs --- --- /CPS/ --- -{-# INLINE consM #-} -{-# SPECIALIZE consM :: IO a -> Stream IO a -> Stream IO a #-} -consM :: Monad m => m a -> Stream m a -> Stream m a -consM m = fromStreamK . K.consM m . toStreamK - --- | A stream that terminates without producing any output or side effect. --- --- >>> Stream.fold Fold.toList Stream.nil --- [] --- -{-# INLINE_NORMAL nil #-} -nil :: Stream m a -nil = fromStreamK K.nil - --- | A stream that terminates without producing any output, but produces a side --- effect. --- --- >>> Stream.fold Fold.toList (Stream.nilM (print "nil")) --- "nil" --- [] --- --- /Pre-release/ -{-# INLINE_NORMAL nilM #-} -nilM :: Monad m => m b -> Stream m a -nilM = fromStreamK . K.nilM - --- | Create a singleton stream from a pure value. --- --- >>> fromPure a = a `cons` Stream.nil --- >>> fromPure = pure --- >>> fromPure = fromEffect . pure --- -{-# INLINE_NORMAL fromPure #-} -fromPure :: a -> Stream m a -fromPure = fromStreamK . K.fromPure - --- | Create a singleton stream from a monadic action. --- --- >>> fromEffect m = m `consM` Stream.nil --- >>> fromEffect = Stream.sequence . Stream.fromPure --- --- >>> Stream.fold Fold.drain $ Stream.fromEffect (putStrLn "hello") --- hello --- -{-# INLINE_NORMAL fromEffect #-} -fromEffect :: Monad m => m a -> Stream m a -fromEffect = fromStreamK . K.fromEffect - -------------------------------------------------------------------------------- --- Applicative -------------------------------------------------------------------------------- - --- | Apply a stream of functions to a stream of values and flatten the results. --- --- Note that the second stream is evaluated multiple times. --- --- >>> crossApply = Stream.crossWith id --- -{-# INLINE crossApply #-} -crossApply :: Stream m (a -> b) -> Stream m a -> Stream m b -crossApply m1 m2 = - fromStreamK $ K.crossApply (toStreamK m1) (toStreamK m2) - -{-# INLINE crossApplySnd #-} -crossApplySnd :: Stream m a -> Stream m b -> Stream m b -crossApplySnd m1 m2 = - fromStreamK $ K.crossApplySnd (toStreamK m1) (toStreamK m2) - -{-# INLINE crossApplyFst #-} -crossApplyFst :: Stream m a -> Stream m b -> Stream m a -crossApplyFst m1 m2 = - fromStreamK $ K.crossApplyFst (toStreamK m1) (toStreamK m2) - --- | --- Definition: --- --- >>> crossWith f m1 m2 = fmap f m1 `Stream.crossApply` m2 --- --- Note that the second stream is evaluated multiple times. --- -{-# INLINE crossWith #-} -crossWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c -crossWith f m1 m2 = fmap f m1 `crossApply` m2 - --- | Given a @Stream m a@ and @Stream m b@ generate a stream with all possible --- combinations of the tuple @(a, b)@. --- --- Definition: --- --- >>> cross = Stream.crossWith (,) --- --- The second stream is evaluated multiple times. If that is not desired it can --- be cached in an 'Data.Array.Array' and then generated from the array before --- calling this function. Caching may also improve performance if the stream is --- expensive to evaluate. --- --- See 'Streamly.Internal.Data.Unfold.cross' for a much faster fused --- alternative. --- --- Time: O(m x n) --- --- /Pre-release/ -{-# INLINE cross #-} -cross :: Monad m => Stream m a -> Stream m b -> Stream m (a, b) -cross = crossWith (,) - -------------------------------------------------------------------------------- --- Bind/Concat -------------------------------------------------------------------------------- - --- | --- --- /CPS/ -{-# INLINE bindWith #-} -bindWith - :: (Stream m b -> Stream m b -> Stream m b) - -> Stream m a - -> (a -> Stream m b) - -> Stream m b -bindWith par m1 f = - fromStreamK - $ K.bindWith - (\s1 s2 -> toStreamK $ par (fromStreamK s1) (fromStreamK s2)) - (toStreamK m1) - (toStreamK . f) - --- | @concatMapWith mixer generator stream@ is a two dimensional looping --- combinator. The @generator@ function is used to generate streams from the --- elements in the input @stream@ and the @mixer@ function is used to merge --- those streams. --- --- /CPS/ -{-# INLINE concatMapWith #-} -concatMapWith - :: (Stream m b -> Stream m b -> Stream m b) - -> (a -> Stream m b) - -> Stream m a - -> Stream m b -concatMapWith par f xs = bindWith par xs f +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Streamly.Internal.Data.Stream.Type +-- Copyright : (c) 2018 Composewell Technologies +-- (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +-- The stream type is inspired by the vector package. A few functions in this +-- module have been originally adapted from the vector package (c) Roman +-- Leshchinskiy. See the notes in specific functions. + +module Streamly.Internal.Data.Stream.Type + ( + -- * Type + Step (..) + -- XXX UnStream is exported to avoid a performance issue in some + -- combinators if we use the pattern synonym "Stream". + , Stream (Stream, UnStream) + + -- * Nested + , Nested(..) + + -- * To StreamK + , fromStreamK + , toStreamK + + -- * From Unfold + , unfold + + -- * Construction + -- ** Primitives + , nilM + , consM + + -- ** From Values + , fromPure + , fromEffect + + -- ** From Containers + , Streamly.Internal.Data.Stream.Type.fromList + + -- * Elimination + -- ** Primitives + , uncons + + -- ** Strict Left Folds + , Streamly.Internal.Data.Stream.Type.fold + , foldBreak + , foldAddLazy + , foldAdd + , foldEither + + , Streamly.Internal.Data.Stream.Type.foldl' + , foldlM' + , foldlx' + , foldlMx' + + -- ** Lazy Right Folds + , foldrM + , foldrMx + , Streamly.Internal.Data.Stream.Type.foldr + , foldrS + + -- ** Specific Folds + , drain + , head + , headElse + , Streamly.Internal.Data.Stream.Type.toList + + -- * Mapping + , map + , mapM + + -- * Stateful Filters + , take + , takeWhile + , takeWhileM + , takeEndBy_ + , takeEndBy + , takeEndByM + + -- * Combining Two Streams + -- ** Appending + -- | Append a stream after another. A special case of concatMap or + -- unfoldEach Note, appending more than two streams is called @concat@ + -- which could be called appendMany or appendAll in append terminology and + -- is equivalent to @concatMap id@. Append is equivalent to @mergeBy fst@. + , AppendState(..) + , append + + -- ** Zipping + -- | Zip corresponding elements of two streams. + , zipWithM + , zipWith + + -- ** Cross Product + , crossApply + , crossApplyFst + , crossApplySnd + , crossWith + , cross + , FairUnfoldState (..) + , fairCrossWithM + , fairCrossWith + , fairCross + , loop -- forEach + , loopBy + + -- * Unfold Many + , ConcatMapUState (..) + , unfoldEach + + -- * UnfoldCross + , unfoldCross + + -- * ConcatMap + -- | Generate streams by mapping a stream generator on each element of an + -- input stream, append the resulting streams and flatten. + , concatEffect + , concatMap + , concatMapM + , concat + + -- * ConcatFor + , concatFor + , concatForM + + -- * Unfold Iterate + , unfoldIterate + , bfsUnfoldIterate + , altBfsUnfoldIterate + + -- * Concat Iterate + , concatIterateScan + , concatIterate + , bfsConcatIterate + , altBfsConcatIterate + + -- * Fold Many + , FoldMany (..) -- for inspection testing + , FoldManyPost (..) + , foldMany + , foldManyPost + , foldManySepBy + , groupsOf + , refoldMany + , refoldIterateM + + -- * Fold Iterate + , bfsReduceIterate + , bfsFoldIterate + + -- * Splitting + , indexEndBy + , indexEndBy_ + + -- * Multi-stream folds + -- | These should probably be expressed using zipping operations. + , eqBy + , cmpBy + + -- * Utilities + , splitAt + + -- * Deprecated + , sliceOnSuffix + , unfoldMany + , indexOnSuffix + , CrossStream + , mkCross + , unCross + , reduceIterateBfs + , unfoldIterateDfs + , unfoldIterateBfs + , unfoldIterateBfsRev + , concatIterateDfs + , concatIterateBfs + , concatIterateBfsRev + ) +where + +#include "deprecation.h" +#include "inline.hs" + +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Bifunctor (first) +import Data.Foldable (Foldable(foldl'), fold, foldr) +import Data.Functor (($>)) +import Data.Functor.Identity (Identity(..)) +#if __GLASGOW_HASKELL__ >= 810 +import Data.Kind (Type) +#endif +import Data.Maybe (fromMaybe) +import Data.Semigroup (Endo(..)) +import Fusion.Plugin.Types (Fuse(..)) +import GHC.Base (build) +import GHC.Exts (IsList(..), IsString(..), oneShot) +import GHC.Types (SPEC(..)) +import Prelude hiding + (head, map, mapM, take, concatMap, takeWhile, zipWith, concat, splitAt) +import Text.Read + ( Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec + , readListPrecDefault) + +import Streamly.Internal.BaseCompat ((#.)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) +import Streamly.Internal.Data.Refold.Type (Refold(..)) +import Streamly.Internal.Data.Stream.Step (Step (..)) +import Streamly.Internal.Data.SVar.Type (State, adaptState, defState) +import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) + +import qualified Streamly.Internal.Data.Fold.Type as FL hiding (foldr) +import qualified Streamly.Internal.Data.StreamK.Type as K +import qualified Streamly.Internal.Data.Unfold.Type as Unfold + +#include "DocTestDataStream.hs" + +------------------------------------------------------------------------------ +-- The direct style stream type +------------------------------------------------------------------------------ + +-- gst = global state + +-- | A stream consists of a step function that generates the next step given a +-- current state, and the current state. +data Stream m a = + forall s. UnStream (State K.StreamK m a -> s -> m (Step s a)) s + +-- XXX This causes perf trouble when pattern matching with "Stream" in a +-- recursive way, e.g. in uncons, foldBreak, concatMap. We need to get rid of +-- this. +unShare :: Stream m a -> Stream m a +unShare (UnStream step state) = UnStream step' state + where step' gst = step (adaptState gst) + +pattern Stream :: (State K.StreamK m a -> s -> m (Step s a)) -> s -> Stream m a +pattern Stream step state <- (unShare -> UnStream step state) + where Stream = UnStream + +{-# COMPLETE Stream #-} + +------------------------------------------------------------------------------ +-- Primitives +------------------------------------------------------------------------------ + +-- | A stream that terminates without producing any output, but produces a side +-- effect. +-- +-- >>> nilM action = Stream.before action Stream.nil +-- >>> Stream.fold Fold.toList (Stream.nilM (print "nil")) +-- "nil" +-- [] +-- +-- /Pre-release/ +{-# INLINE_NORMAL nilM #-} +nilM :: Applicative m => m b -> Stream m a +nilM m = Stream (\_ _ -> m $> Stop) () + +infixr 5 `consM` + +-- XXX see https://github.com/composewell/streamly/issues/3126 - for using a +-- list or maybe an effect "m (Stream m a)" along with "step" in the stream +-- structure for better cons and append performance. + +-- | Like 'cons' but fuses an effect instead of a pure value. +{-# INLINE_NORMAL consM #-} +consM :: Applicative m => m a -> Stream m a -> Stream m a +consM m (Stream step state) = Stream step1 Nothing + + where + + {-# INLINE_LATE step1 #-} + step1 _ Nothing = (`Yield` Just state) <$> m + step1 gst (Just st) = do + (\case + Yield a s -> Yield a (Just s) + Skip s -> Skip (Just s) + Stop -> Stop) <$> step gst st + +-- | Decompose a stream into its head and tail. If the stream is empty, returns +-- 'Nothing'. If the stream is non-empty, returns @Just (a, ma)@, where @a@ is +-- the head of the stream and @ma@ its tail. +-- +-- Properties: +-- +-- >>> Nothing <- Stream.uncons Stream.nil +-- >>> Just ("a", t) <- Stream.uncons (Stream.cons "a" Stream.nil) +-- +-- This can be used to consume the stream in an imperative manner one element +-- at a time, as it just breaks down the stream into individual elements and we +-- can loop over them as we deem fit. For example, this can be used to convert +-- a streamly stream into other stream types. +-- +-- All the folds in this module can be expressed in terms of 'uncons', however, +-- this is generally less efficient than specific folds because it takes apart +-- the stream one element at a time, therefore, does not take adavantage of +-- stream fusion. +-- +-- 'foldBreak' is a more general way of consuming a stream piecemeal. +-- +-- >>> :{ +-- uncons xs = do +-- r <- Stream.foldBreak Fold.one xs +-- return $ case r of +-- (Nothing, _) -> Nothing +-- (Just h, t) -> Just (h, t) +-- :} +-- +{-# INLINE_NORMAL uncons #-} +uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a)) +uncons (UnStream step state) = go SPEC state + where + go !_ st = do + r <- step defState st + case r of + Yield x s -> return $ Just (x, Stream step s) + Skip s -> go SPEC s + Stop -> return Nothing + +------------------------------------------------------------------------------ +-- From 'Unfold' +------------------------------------------------------------------------------ + +data UnfoldState s = UnfoldNothing | UnfoldJust s + +-- | Convert an 'Unfold' into a stream by supplying it an input seed. +-- +-- >>> s = Stream.unfold Unfold.replicateM (3, putStrLn "hello") +-- >>> Stream.fold Fold.drain s +-- hello +-- hello +-- hello +-- +{-# INLINE_NORMAL unfold #-} +unfold :: Applicative m => Unfold m a b -> a -> Stream m b +unfold (Unfold ustep inject) seed = Stream step UnfoldNothing + + where + + {-# INLINE_LATE step #-} + step _ UnfoldNothing = Skip . UnfoldJust <$> inject seed + step _ (UnfoldJust st) = do + (\case + Yield x s -> Yield x (UnfoldJust s) + Skip s -> Skip (UnfoldJust s) + Stop -> Stop) <$> ustep st + +------------------------------------------------------------------------------ +-- From Values +------------------------------------------------------------------------------ + +-- | Create a singleton stream from a pure value. +-- +-- >>> fromPure a = a `Stream.cons` Stream.nil +-- >>> fromPure = pure +-- >>> fromPure = Stream.fromEffect . pure +-- +{-# INLINE_NORMAL fromPure #-} +fromPure :: Applicative m => a -> Stream m a +fromPure x = Stream (\_ s -> pure $ step undefined s) True + where + {-# INLINE_LATE step #-} + step _ True = Yield x False + step _ False = Stop + +-- | Create a singleton stream from a monadic action. +-- +-- >>> fromEffect m = m `Stream.consM` Stream.nil +-- >>> fromEffect = Stream.sequence . Stream.fromPure +-- +-- >>> Stream.fold Fold.drain $ Stream.fromEffect (putStrLn "hello") +-- hello +-- +{-# INLINE_NORMAL fromEffect #-} +fromEffect :: Applicative m => m a -> Stream m a +fromEffect m = Stream step True + + where + + {-# INLINE_LATE step #-} + step _ True = (`Yield` False) <$> m + step _ False = pure Stop + +------------------------------------------------------------------------------ +-- From Containers +------------------------------------------------------------------------------ + +-- Adapted from the vector package. + +-- | Construct a stream from a list of pure values. +{-# INLINE_LATE fromList #-} +fromList :: Applicative m => [a] -> Stream m a +#ifdef USE_UNFOLDS_EVERYWHERE +fromList = unfold Unfold.fromList +#else +fromList = Stream step + where + {-# INLINE_LATE step #-} + step _ (x:xs) = pure $ Yield x xs + step _ [] = pure Stop +#endif + +------------------------------------------------------------------------------ +-- Conversions From/To +------------------------------------------------------------------------------ + +-- | Convert a CPS encoded StreamK to direct style step encoded StreamD +{-# INLINE_LATE fromStreamK #-} +fromStreamK :: Applicative m => K.StreamK m a -> Stream m a +fromStreamK = Stream step + where + step gst m1 = + let stop = pure Stop + single a = pure $ Yield a K.nil + yieldk a r = pure $ Yield a r + in K.foldStreamShared gst yieldk single stop m1 + +-- | Convert a direct style step encoded StreamD to a CPS encoded StreamK +{-# INLINE_LATE toStreamK #-} +toStreamK :: Monad m => Stream m a -> K.StreamK m a +toStreamK (Stream step state) = go state + where + go st = K.MkStream $ \gst yld _ stp -> + let go' ss = do + r <- step gst ss + case r of + Yield x s -> yld x (go s) + Skip s -> go' s + Stop -> stp + in go' st + +{-# RULES "fromStreamK/toStreamK fusion" + forall s. toStreamK (fromStreamK s) = s #-} +{-# RULES "toStreamK/fromStreamK fusion" + forall s. fromStreamK (toStreamK s) = s #-} + +------------------------------------------------------------------------------ +-- Running a 'Fold' +------------------------------------------------------------------------------ + +-- | Fold resulting in either breaking the stream or continuation of the fold. +-- Instead of supplying the input stream in one go we can run the fold multiple +-- times, each time supplying the next segment of the input stream. If the fold +-- has not yet finished it returns a fold that can be run again otherwise it +-- returns the fold result and the residual stream. +-- +-- /Internal/ +{-# INLINE_NORMAL foldEither #-} +foldEither :: Monad m => + Fold m a b -> Stream m a -> m (Either (Fold m a b) (b, Stream m a)) +foldEither (Fold fstep begin done final) (UnStream step state) = do + res <- begin + case res of + FL.Partial fs -> go SPEC fs state + FL.Done fb -> return $! Right (fb, Stream step state) + + where + + {-# INLINE go #-} + go !_ !fs st = do + r <- step defState st + case r of + Yield x s -> do + res <- fstep fs x + case res of + FL.Done b -> return $! Right (b, Stream step s) + FL.Partial fs1 -> go SPEC fs1 s + Skip s -> go SPEC fs s + Stop -> + let f = Fold fstep (return $ FL.Partial fs) done final + in return $! Left f + +-- | Like 'fold' but also returns the remaining stream. The resulting stream +-- would be 'Stream.nil' if the stream finished before the fold. +-- +{-# INLINE_NORMAL foldBreak #-} +foldBreak :: Monad m => Fold m a b -> Stream m a -> m (b, Stream m a) +foldBreak fld strm = do + r <- foldEither fld strm + case r of + Right res -> return res + Left (Fold _ initial _ final) -> do + res <- initial + case res of + FL.Done _ -> error "foldBreak: unreachable state" + FL.Partial s -> do + b <- final s + return (b, nil) + + where + + nil = Stream (\_ _ -> return Stop) () + +-- >>> fold f = Fold.extractM . Stream.foldAddLazy f +-- >>> fold f = Stream.fold Fold.one . Stream.foldMany0 f +-- >>> fold f = Fold.extractM <=< Stream.foldAdd f + +-- | Fold a stream using the supplied left 'Fold' and reducing the resulting +-- expression strictly at each step. The behavior is similar to 'foldl''. A +-- 'Fold' can terminate early without consuming the full stream. See the +-- documentation of individual 'Fold's for termination behavior. +-- +-- Definitions: +-- +-- >>> fold f = fmap fst . Stream.foldBreak f +-- >>> fold f = Stream.parse (Parser.fromFold f) +-- +-- Example: +-- +-- >>> Stream.fold Fold.sum (Stream.enumerateFromTo 1 100) +-- 5050 +-- +{-# INLINE_NORMAL fold #-} +fold :: Monad m => Fold m a b -> Stream m a -> m b +fold fld strm = do + (b, _) <- foldBreak fld strm + return b + +-- | Append a stream to a fold lazily to build an accumulator incrementally. +-- +-- Example, to continue folding a list of streams on the same sum fold: +-- +-- >>> streams = [Stream.fromList [1..5], Stream.fromList [6..10]] +-- >>> f = Prelude.foldl Stream.foldAddLazy Fold.sum streams +-- >>> Stream.fold f Stream.nil +-- 55 +-- +{-# INLINE_NORMAL foldAddLazy #-} +foldAddLazy :: Monad m => Fold m a b -> Stream m a -> Fold m a b +foldAddLazy (Fold fstep finitial fextract ffinal) (Stream sstep state) = + Fold fstep initial fextract ffinal + + where + + initial = do + res <- finitial + case res of + FL.Partial fs -> go SPEC fs state + FL.Done fb -> return $ FL.Done fb + + {-# INLINE go #-} + go !_ !fs st = do + r <- sstep defState st + case r of + Yield x s -> do + res <- fstep fs x + case res of + FL.Done b -> return $ FL.Done b + FL.Partial fs1 -> go SPEC fs1 s + Skip s -> go SPEC fs s + Stop -> return $ FL.Partial fs + +-- >>> foldAdd f = Stream.foldAddLazy f >=> Fold.reduce + +-- | +-- >>> foldAdd = flip Fold.addStream +-- +foldAdd :: Monad m => Fold m a b -> Stream m a -> m (Fold m a b) +foldAdd f = + Streamly.Internal.Data.Stream.Type.fold (FL.duplicate f) + +------------------------------------------------------------------------------ +-- Right Folds +------------------------------------------------------------------------------ + +-- Adapted from the vector package. +-- +-- XXX Use of SPEC constructor in folds causes 2x performance degradation in +-- one shot operations, but helps immensely in operations composed of multiple +-- combinators or the same combinator many times. There seems to be an +-- opportunity to optimize here, can we get both, better perf for single ops +-- as well as composed ops? Without SPEC, all single operation benchmarks +-- become 2x faster. + +-- The way we want a left fold to be strict, dually we want the right fold to +-- be lazy. The correct signature of the fold function to keep it lazy must be +-- (a -> m b -> m b) instead of (a -> b -> m b). We were using the latter +-- earlier, which is incorrect. In the latter signature we have to feed the +-- value to the fold function after evaluating the monadic action, depending on +-- the bind behavior of the monad, the action may get evaluated immediately +-- introducing unnecessary strictness to the fold. If the implementation is +-- lazy the following example, must work: +-- +-- S.foldrM (\x t -> if x then return t else return False) (return True) +-- (S.fromList [False,undefined] :: Stream IO Bool) + +-- | Right associative/lazy pull fold. @foldrM build final stream@ constructs +-- an output structure using the step function @build@. @build@ is invoked with +-- the next input element and the remaining (lazy) tail of the output +-- structure. It builds a lazy output expression using the two. When the "tail +-- structure" in the output expression is evaluated it calls @build@ again thus +-- lazily consuming the input @stream@ until either the output expression built +-- by @build@ is free of the "tail" or the input is exhausted in which case +-- @final@ is used as the terminating case for the output structure. For more +-- details see the description in the previous section. +-- +-- Example, determine if any element is 'odd' in a stream: +-- +-- >>> s = Stream.fromList (2:4:5:undefined) +-- >>> step x xs = if odd x then return True else xs +-- >>> Stream.foldrM step (return False) s +-- True +-- +-- >>> import Control.Monad (join) +-- >>> foldrM f z = join . Stream.foldr f z +-- +{-# INLINE_NORMAL foldrM #-} +foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b +-- foldrM f z = join . Streamly.Internal.Data.Stream.StreamD.Type.foldr f z +foldrM f z (Stream step state) = go SPEC state + where + {-# INLINE_LATE go #-} + go !_ st = do + r <- step defState st + case r of + Yield x s -> f x (go SPEC s) + Skip s -> go SPEC s + Stop -> z + +{-# INLINE_NORMAL foldrMx #-} +foldrMx :: Monad m + => (a -> m x -> m x) -> m x -> (m x -> m b) -> Stream m a -> m b +foldrMx fstep final convert (Stream step state) = convert $ go SPEC state + where + {-# INLINE_LATE go #-} + go !_ st = do + r <- step defState st + case r of + Yield x s -> fstep x (go SPEC s) + Skip s -> go SPEC s + Stop -> final + +-- XXX Should we make all argument strict wherever we use SPEC? + +-- Note that foldr works on pure values, therefore it becomes necessarily +-- strict when the monad m is strict. In that case it cannot terminate early, +-- it would evaluate all of its input. Though, this should work fine with lazy +-- monads. For example, if "any" is implemented using "foldr" instead of +-- "foldrM" it performs the same with Identity monad but performs 1000x slower +-- with IO monad. + +-- | Right fold, lazy for lazy monads and pure streams, and strict for strict +-- monads. +-- +-- Please avoid using this routine in strict monads like IO unless you need a +-- strict right fold. This is provided only for use in lazy monads (e.g. +-- Identity) or pure streams. Note that with this signature it is not possible +-- to implement a lazy foldr when the monad @m@ is strict. In that case it +-- would be strict in its accumulator and therefore would necessarily consume +-- all its input. +-- +-- >>> foldr f z = Stream.foldrM (\a b -> f a <$> b) (return z) +-- +-- Note: This is similar to Fold.foldr' (the right fold via left fold), but +-- could be more efficient. +-- +{-# INLINE_NORMAL foldr #-} +foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b +foldr f z = foldrM (liftA2 f . return) (return z) + +-- this performs horribly, should not be used +{-# INLINE_NORMAL foldrS #-} +foldrS + :: Monad m + => (a -> Stream m b -> Stream m b) + -> Stream m b + -> Stream m a + -> Stream m b +foldrS f final (Stream step state) = go SPEC state + where + {-# INLINE_LATE go #-} + go !_ st = concatEffect $ fmap g $ step defState st + + g r = + case r of + Yield x s -> f x (go SPEC s) + Skip s -> go SPEC s + Stop -> final + +------------------------------------------------------------------------------ +-- Left Folds +------------------------------------------------------------------------------ + +-- XXX run begin action only if the stream is not empty. +{-# INLINE_NORMAL foldlMx' #-} +foldlMx' :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> m b +foldlMx' fstep begin done (Stream step state) = + begin >>= \x -> go SPEC x state + where + -- XXX !acc? + {-# INLINE_LATE go #-} + go !_ acc st = acc `seq` do + r <- step defState st + case r of + Yield x s -> do + acc' <- fstep acc x + go SPEC acc' s + Skip s -> go SPEC acc s + Stop -> done acc + +{-# INLINE foldlx' #-} +foldlx' :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> m b +foldlx' fstep begin done = + foldlMx' (\b a -> return (fstep b a)) (return begin) (return . done) + +-- Adapted from the vector package. +-- XXX implement in terms of foldlMx'? +{-# INLINE_NORMAL foldlM' #-} +foldlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> m b +foldlM' fstep mbegin (Stream step state) = do + begin <- mbegin + go SPEC begin state + where + {-# INLINE_LATE go #-} + go !_ acc st = acc `seq` do + r <- step defState st + case r of + Yield x s -> do + acc' <- fstep acc x + go SPEC acc' s + Skip s -> go SPEC acc s + Stop -> return acc + +{-# INLINE foldl' #-} +foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b +foldl' fstep begin = foldlM' (\b a -> return (fstep b a)) (return begin) + +------------------------------------------------------------------------------ +-- Special folds +------------------------------------------------------------------------------ + +-- >>> drain = mapM_ (\_ -> return ()) + +-- | +-- Definitions: +-- +-- >>> drain = Stream.fold Fold.drain +-- >>> drain = Stream.foldrM (\_ xs -> xs) (return ()) +-- +-- Run a stream, discarding the results. +-- +{-# INLINE_LATE drain #-} +drain :: Monad m => Stream m a -> m () +-- drain = foldrM (\_ xs -> xs) (return ()) +drain (Stream step state) = go SPEC state + where + go !_ st = do + r <- step defState st + case r of + Yield _ s -> go SPEC s + Skip s -> go SPEC s + Stop -> return () + +{-# INLINE_NORMAL head #-} +head :: Monad m => Stream m a -> m (Maybe a) +#ifdef USE_FOLDS_EVERYWHERE +head = fold Fold.one +#else +head = foldrM (\x _ -> return (Just x)) (return Nothing) +#endif + +{-# INLINE_NORMAL headElse #-} +headElse :: Monad m => a -> Stream m a -> m a +headElse a = foldrM (\x _ -> return x) (return a) + +------------------------------------------------------------------------------ +-- To Containers +------------------------------------------------------------------------------ + +-- This toList impl is faster (30% on streaming-benchmarks) than the +-- corresponding left fold. The left fold retains an additional argument in the +-- recursive loop. +-- +-- Core for the right fold loop: +-- +-- main_$s$wgo1 +-- = \ sc_s3e6 sc1_s3e5 -> +-- case ># sc1_s3e5 100000# of { +-- __DEFAULT -> +-- case main_$s$wgo1 sc_s3e6 (+# sc1_s3e5 1#) of +-- +-- Core for the left fold loop: +-- +-- main_$s$wgo1 +-- = \ sc_s3oT sc1_s3oS sc2_s3oR -> +-- case sc2_s3oR of fs2_a2lw { __DEFAULT -> +-- case ># sc1_s3oS 100000# of { +-- __DEFAULT -> +-- let { wild_a2og = I# sc1_s3oS } in +-- main_$s$wgo1 +-- sc_s3oT (+# sc1_s3oS 1#) (\ x_X9 -> fs2_a2lw (: wild_a2og x_X9)); + +-- | +-- Definitions: +-- +-- >>> toList = Stream.foldr (:) [] +-- >>> toList = Stream.fold Fold.toList +-- +-- Convert a stream into a list in the underlying monad. The list can be +-- consumed lazily in a lazy monad (e.g. 'Identity'). In a strict monad (e.g. +-- IO) the whole list is generated and buffered before it can be consumed. +-- +-- /Warning!/ working on large lists accumulated as buffers in memory could be +-- very inefficient, consider using "Streamly.Data.Array" instead. +-- +-- Note that this could a bit more efficient compared to @Stream.fold +-- Fold.toList@, and it can fuse with pure list consumers. +-- +{-# INLINE_NORMAL toList #-} +toList :: Monad m => Stream m a -> m [a] +toList = Streamly.Internal.Data.Stream.Type.foldr (:) [] + +-- Use foldr/build fusion to fuse with list consumers +-- This can be useful when using the IsList instance +{-# INLINE_LATE toListFB #-} +toListFB :: (a -> b -> b) -> b -> Stream Identity a -> b +toListFB c n (Stream step state) = go state + where + go st = case runIdentity (step defState st) of + Yield x s -> x `c` go s + Skip s -> go s + Stop -> n + +{-# RULES "toList Identity" Streamly.Internal.Data.Stream.Type.toList = toListId #-} +{-# INLINE_EARLY toListId #-} +toListId :: Stream Identity a -> Identity [a] +toListId s = Identity $ build (\c n -> toListFB c n s) + +------------------------------------------------------------------------------ +-- Multi-stream folds +------------------------------------------------------------------------------ + +-- Adapted from the vector package. + +-- | Compare two streams for equality +{-# INLINE_NORMAL eqBy #-} +eqBy :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool +eqBy eq (Stream step1 t1) (Stream step2 t2) = eq_loop0 SPEC t1 t2 + where + eq_loop0 !_ s1 s2 = do + r <- step1 defState s1 + case r of + Yield x s1' -> eq_loop1 SPEC x s1' s2 + Skip s1' -> eq_loop0 SPEC s1' s2 + Stop -> eq_null s2 + + eq_loop1 !_ x s1 s2 = do + r <- step2 defState s2 + case r of + Yield y s2' + | eq x y -> eq_loop0 SPEC s1 s2' + | otherwise -> return False + Skip s2' -> eq_loop1 SPEC x s1 s2' + Stop -> return False + + eq_null s2 = do + r <- step2 defState s2 + case r of + Yield _ _ -> return False + Skip s2' -> eq_null s2' + Stop -> return True + +-- Adapted from the vector package. + +-- | Compare two streams lexicographically. +{-# INLINE_NORMAL cmpBy #-} +cmpBy + :: Monad m + => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering +cmpBy cmp (Stream step1 t1) (Stream step2 t2) = cmp_loop0 SPEC t1 t2 + where + cmp_loop0 !_ s1 s2 = do + r <- step1 defState s1 + case r of + Yield x s1' -> cmp_loop1 SPEC x s1' s2 + Skip s1' -> cmp_loop0 SPEC s1' s2 + Stop -> cmp_null s2 + + cmp_loop1 !_ x s1 s2 = do + r <- step2 defState s2 + case r of + Yield y s2' -> case x `cmp` y of + EQ -> cmp_loop0 SPEC s1 s2' + c -> return c + Skip s2' -> cmp_loop1 SPEC x s1 s2' + Stop -> return GT + + cmp_null s2 = do + r <- step2 defState s2 + case r of + Yield _ _ -> return LT + Skip s2' -> cmp_null s2' + Stop -> return EQ + +------------------------------------------------------------------------------ +-- Transformations +------------------------------------------------------------------------------ + +-- Adapted from the vector package. + +-- | +-- >>> mapM f = Stream.sequence . fmap f +-- +-- Apply a monadic function to each element of the stream and replace it with +-- the output of the resulting action. +-- +-- >>> s = Stream.fromList ["a", "b", "c"] +-- >>> Stream.fold Fold.drain $ Stream.mapM putStr s +-- abc +-- +-- This is functional equivalent of an imperative loop. +-- +{-# INLINE_NORMAL mapM #-} +mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b +mapM f (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- step (adaptState gst) st + case r of + Yield x s -> f x >>= \a -> return $ Yield a s + Skip s -> return $ Skip s + Stop -> return Stop + +{-# INLINE map #-} +map :: Monad m => (a -> b) -> Stream m a -> Stream m b +map f = mapM (return . f) + +-- (Functor m) based implementation of fmap does not fuse well in +-- streaming-benchmarks. XXX need to investigate why. +instance Monad m => Functor (Stream m) where + {-# INLINE fmap #-} + fmap = map + + {-# INLINE (<$) #-} + (<$) = fmap . const + +------------------------------------------------------------------------------ +-- Lists +------------------------------------------------------------------------------ + +-- XXX Show instance is 10x slower compared to read, we can do much better. +-- The list show instance itself is really slow. + +-- XXX The default definitions of "<" in the Ord instance etc. do not perform +-- well, because they do not get inlined. Need to add INLINE in Ord class in +-- base? + +instance IsList (Stream Identity a) where + type (Item (Stream Identity a)) = a + + {-# INLINE fromList #-} + fromList = Streamly.Internal.Data.Stream.Type.fromList + + {-# INLINE toList #-} + toList = runIdentity . Streamly.Internal.Data.Stream.Type.toList + +instance Eq a => Eq (Stream Identity a) where + {-# INLINE (==) #-} + (==) xs ys = runIdentity $ eqBy (==) xs ys + +instance Ord a => Ord (Stream Identity a) where + {-# INLINE compare #-} + compare xs ys = runIdentity $ cmpBy compare xs ys + + {-# INLINE (<) #-} + x < y = + case compare x y of + LT -> True + _ -> False + + {-# INLINE (<=) #-} + x <= y = + case compare x y of + GT -> False + _ -> True + + {-# INLINE (>) #-} + x > y = + case compare x y of + GT -> True + _ -> False + + {-# INLINE (>=) #-} + x >= y = + case compare x y of + LT -> False + _ -> True + + {-# INLINE max #-} + max x y = if x <= y then y else x + + {-# INLINE min #-} + min x y = if x <= y then x else y + +instance Show a => Show (Stream Identity a) where + showsPrec p dl = showParen (p > 10) $ + showString "fromList " . shows (GHC.Exts.toList dl) + +instance Read a => Read (Stream Identity a) where + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + Streamly.Internal.Data.Stream.Type.fromList <$> readPrec + + readListPrec = readListPrecDefault + +instance (a ~ Char) => IsString (Stream Identity a) where + {-# INLINE fromString #-} + fromString = Streamly.Internal.Data.Stream.Type.fromList + +------------------------------------------------------------------------------- +-- Foldable +------------------------------------------------------------------------------- + +-- The default Foldable instance has several issues: +-- 1) several definitions do not have INLINE on them, so we provide +-- re-implementations with INLINE pragmas. +-- 2) the definitions of sum/product/maximum/minimum are inefficient as they +-- use right folds, they cannot run in constant memory. We provide +-- implementations using strict left folds here. + +-- There is no Traversable instance because, there is no scalable cons for +-- StreamD, use toList and fromList instead. + +instance (Foldable m, Monad m) => Foldable (Stream m) where + + {-# INLINE foldMap #-} + foldMap f = + Data.Foldable.fold + . Streamly.Internal.Data.Stream.Type.foldr (mappend . f) mempty + + {-# INLINE foldr #-} + foldr f z t = appEndo (foldMap (Endo #. f) t) z + + {-# INLINE foldl' #-} + foldl' f z0 xs = Data.Foldable.foldr f' id xs z0 + where f' x k = oneShot $ \z -> k $! f z x + + {-# INLINE length #-} + length = Data.Foldable.foldl' (\n _ -> n + 1) 0 + + {-# INLINE elem #-} + elem = any . (==) + + {-# INLINE maximum #-} + maximum = + fromMaybe (errorWithoutStackTrace "maximum: empty stream") + . toMaybe + . Data.Foldable.foldl' getMax Nothing' + + where + + getMax Nothing' x = Just' x + getMax (Just' mx) x = Just' $! max mx x + + {-# INLINE minimum #-} + minimum = + fromMaybe (errorWithoutStackTrace "minimum: empty stream") + . toMaybe + . Data.Foldable.foldl' getMin Nothing' + + where + + getMin Nothing' x = Just' x + getMin (Just' mn) x = Just' $! min mn x + + {-# INLINE sum #-} + sum = Data.Foldable.foldl' (+) 0 + + {-# INLINE product #-} + product = Data.Foldable.foldl' (*) 1 + +------------------------------------------------------------------------------- +-- Filtering +------------------------------------------------------------------------------- + +-- Adapted from the vector package. + +-- | Take first 'n' elements from the stream and discard the rest. +-- +{-# INLINE_NORMAL take #-} +take :: Applicative m => Int -> Stream m a -> Stream m a +take n (Stream step state) = n `seq` Stream step' (state, 0) + + where + + {-# INLINE_LATE step' #-} + step' gst (st, i) | i < n = do + (\case + Yield x s -> Yield x (s, i + 1) + Skip s -> Skip (s, i) + Stop -> Stop) <$> step gst st + step' _ (_, _) = pure Stop + +-- Adapted from the vector package. + +-- | Same as 'takeWhile' but with a monadic predicate. +-- +{-# INLINE_NORMAL takeWhileM #-} +takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +-- takeWhileM p = scanMaybe (FL.takingEndByM_ (\x -> not <$> p x)) +takeWhileM f (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- step gst st + case r of + Yield x s -> do + b <- f x + return $ if b then Yield x s else Stop + Skip s -> return $ Skip s + Stop -> return Stop + +-- | End the stream as soon as the predicate fails on an element. +-- +{-# INLINE takeWhile #-} +takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +takeWhile f = takeWhileM (return . f) + +-- Like takeWhile but with an inverted condition and also taking +-- the matching element. + +{-# INLINE_NORMAL takeEndByM #-} +takeEndByM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +takeEndByM f (Stream step state) = Stream step' (Just state) + where + {-# INLINE_LATE step' #-} + step' gst (Just st) = do + r <- step gst st + case r of + Yield x s -> do + b <- f x + return $ + if not b + then Yield x (Just s) + else Yield x Nothing + Skip s -> return $ Skip (Just s) + Stop -> return Stop + + step' _ Nothing = return Stop + +{-# INLINE takeEndBy #-} +takeEndBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +takeEndBy f = takeEndByM (return . f) + +-- | +-- >>> takeEndBy_ f = Stream.takeWhile (not . f) +-- +{-# INLINE takeEndBy_ #-} +takeEndBy_ :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +takeEndBy_ f = takeWhile (not . f) + +------------------------------------------------------------------------------ +-- Appending +------------------------------------------------------------------------------ + +data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2 + +-- Performance Note: From an implementation perspective, +-- StreamK.'Streamly.Data.StreamK.append' translates into a function call +-- whereas Stream.'append' translates into a conditional branch (jump). +-- However, the overhead of the function call in StreamK.append is incurred +-- only once, while the overhead of the conditional branch in fused append is +-- incurred for each element in the stream. As a result, StreamK.append has a +-- linear time complexity of O(n), while fused append has a quadratic time +-- complexity of O(n^2), where @n@ represents the number of 'append's used. + +-- | WARNING! O(n^2) time complexity wrt number of streams. Suitable for +-- statically fusing a small number of streams. Use the O(n) complexity +-- StreamK.'Streamly.Data.StreamK.append' otherwise. +-- +-- Fuses two streams sequentially, yielding all elements from the first +-- stream, and then all elements from the second stream. +-- +-- >>> s1 = Stream.fromList [1,2] +-- >>> s2 = Stream.fromList [3,4] +-- >>> Stream.fold Fold.toList $ s1 `Stream.append` s2 +-- [1,2,3,4] +-- +{-# INLINE_NORMAL append #-} +append :: Monad m => Stream m a -> Stream m a -> Stream m a +append (Stream step1 state1) (Stream step2 state2) = + Stream step (AppendFirst state1) + + where + + {-# INLINE_LATE step #-} + step gst (AppendFirst st) = do + r <- step1 gst st + return $ case r of + Yield a s -> Yield a (AppendFirst s) + Skip s -> Skip (AppendFirst s) + Stop -> Skip (AppendSecond state2) + + step gst (AppendSecond st) = do + r <- step2 gst st + return $ case r of + Yield a s -> Yield a (AppendSecond s) + Skip s -> Skip (AppendSecond s) + Stop -> Stop + +------------------------------------------------------------------------------ +-- Zipping +------------------------------------------------------------------------------ + +-- | Like 'zipWith' but using a monadic zipping function. +-- +{-# INLINE_NORMAL zipWithM #-} +zipWithM :: Monad m + => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c +zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing) + where + {-# INLINE_LATE step #-} + step gst (sa, sb, Nothing) = do + r <- stepa (adaptState gst) sa + return $ + case r of + Yield x sa' -> Skip (sa', sb, Just x) + Skip sa' -> Skip (sa', sb, Nothing) + Stop -> Stop + + step gst (sa, sb, Just x) = do + r <- stepb (adaptState gst) sb + case r of + Yield y sb' -> do + z <- f x y + return $ Yield z (sa, sb', Nothing) + Skip sb' -> return $ Skip (sa, sb', Just x) + Stop -> return Stop + +{-# RULES "zipWithM xs xs" + forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-} + +-- | WARNING! O(n^2) time complexity wrt number of streams. Suitable for +-- statically fusing a small number of streams. Use the O(n) complexity +-- StreamK.'Streamly.Data.StreamK.zipWith' otherwise. +-- +-- Stream @a@ is evaluated first, followed by stream @b@, the resulting +-- elements @a@ and @b@ are then zipped using the supplied zip function and the +-- result @c@ is yielded to the consumer. +-- +-- If stream @a@ or stream @b@ ends, the zipped stream ends. If stream @b@ ends +-- first, the element @a@ from previous evaluation of stream @a@ is discarded. +-- +-- >>> s1 = Stream.fromList [1,2,3] +-- >>> s2 = Stream.fromList [4,5,6] +-- >>> Stream.fold Fold.toList $ Stream.zipWith (+) s1 s2 +-- [5,7,9] +-- +{-# INLINE zipWith #-} +zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c +zipWith f = zipWithM (\a b -> return (f a b)) + +------------------------------------------------------------------------------ +-- Combine N Streams - concatAp +------------------------------------------------------------------------------ + +-- XXX unfoldApplyEach + +-- | Apply a stream of functions to a stream of values and flatten the results. +-- +-- Note that the second stream is evaluated multiple times. +-- +-- >>> crossApply = Stream.crossWith id +-- +{-# INLINE_NORMAL crossApply #-} +crossApply :: Functor f => Stream f (a -> b) -> Stream f a -> Stream f b +crossApply (Stream stepa statea) (Stream stepb stateb) = + Stream step' (Left statea) + + where + + {-# INLINE_LATE step' #-} + step' gst (Left st) = fmap + (\case + Yield f s -> Skip (Right (f, s, stateb)) + Skip s -> Skip (Left s) + Stop -> Stop) + (stepa (adaptState gst) st) + step' gst (Right (f, os, st)) = fmap + (\case + Yield a s -> Yield (f a) (Right (f, os, s)) + Skip s -> Skip (Right (f,os, s)) + Stop -> Skip (Left os)) + (stepb (adaptState gst) st) + +-- This is shared by all fairUnfold, fairConcat combinators. +data FairUnfoldState o i = + FairUnfoldInit o ([i] -> [i]) + | FairUnfoldNext o ([i] -> [i]) [i] + | FairUnfoldDrain ([i] -> [i]) [i] + +-- XXX will it perform better if we write it in the same way as crossApply? +-- crossApply is faster than unfoldCross in equation solving benchmarks. + +-- | Like 'fairCrossWith' but with monadic function argument. +-- +{-# INLINE_NORMAL fairCrossWithM #-} +fairCrossWithM :: Monad m => + (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c +fairCrossWithM f (Stream step1 state1) (Stream step2 state2) = + Stream step (FairUnfoldInit state1 id) + + where + + {-# INLINE_LATE step #-} + step gst (FairUnfoldInit o ls) = do + r <- step1 (adaptState gst) o + return $ case r of + Yield b o' -> Skip (FairUnfoldNext o' id (ls [(b,state2)])) + Skip o' -> Skip (FairUnfoldInit o' ls) + Stop -> Skip (FairUnfoldDrain id (ls [])) + + step _ (FairUnfoldNext o ys []) = + return $ Skip (FairUnfoldInit o ys) + + step gst (FairUnfoldNext o ys ((b,st):ls)) = do + r <- step2 (adaptState gst) st + case r of + Yield c s -> + f b c >>= \x -> + return $ Yield x (FairUnfoldNext o (ys . ((b, s) :)) ls) + Skip s -> return $ Skip (FairUnfoldNext o ys ((b,s) : ls)) + Stop -> return $ Skip (FairUnfoldNext o ys ls) + + step _ (FairUnfoldDrain ys []) = + case ys [] of + [] -> return Stop + xs -> return $ Skip (FairUnfoldDrain id xs) + + step gst (FairUnfoldDrain ys ((b,st):ls)) = do + r <- step2 (adaptState gst) st + case r of + Yield c s -> + f b c >>= \x -> + return $ Yield x (FairUnfoldDrain (ys . ((b,s) :)) ls) + Skip s -> return $ Skip (FairUnfoldDrain ys ((b,s) : ls)) + Stop -> return $ Skip (FairUnfoldDrain ys ls) + +{-# INLINE_NORMAL crossApplySnd #-} +crossApplySnd :: Functor f => Stream f a -> Stream f b -> Stream f b +crossApplySnd (Stream stepa statea) (Stream stepb stateb) = + Stream step (Left statea) + + where + + {-# INLINE_LATE step #-} + step gst (Left st) = + fmap + (\case + Yield _ s -> Skip (Right (s, stateb)) + Skip s -> Skip (Left s) + Stop -> Stop) + (stepa (adaptState gst) st) + step gst (Right (ostate, st)) = + fmap + (\case + Yield b s -> Yield b (Right (ostate, s)) + Skip s -> Skip (Right (ostate, s)) + Stop -> Skip (Left ostate)) + (stepb gst st) + +{-# INLINE_NORMAL crossApplyFst #-} +crossApplyFst :: Functor f => Stream f a -> Stream f b -> Stream f a +crossApplyFst (Stream stepa statea) (Stream stepb stateb) = + Stream step (Left statea) + + where + + {-# INLINE_LATE step #-} + step gst (Left st) = + fmap + (\case + Yield b s -> Skip (Right (s, stateb, b)) + Skip s -> Skip (Left s) + Stop -> Stop) + (stepa gst st) + step gst (Right (ostate, st, b)) = + fmap + (\case + Yield _ s -> Yield b (Right (ostate, s, b)) + Skip s -> Skip (Right (ostate, s, b)) + Stop -> Skip (Left ostate)) + (stepb (adaptState gst) st) + +{- +instance Applicative f => Applicative (Stream f) where + {-# INLINE pure #-} + pure = fromPure + + {-# INLINE (<*>) #-} + (<*>) = crossApply + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + + {-# INLINE (*>) #-} + (*>) = crossApplySnd + + {-# INLINE (<*) #-} + (<*) = crossApplyFst +-} + +-- XXX We can use @Stream Identity b@ as the second stream to avoid running +-- effects multiple times. Or it could be an array or an unfold i.e. +-- unfoldCross. + +-- | +-- Definition: +-- +-- >>> crossWith f m1 m2 = fmap f m1 `Stream.crossApply` m2 +-- +-- Note that the second stream is evaluated multiple times. +-- +-- Also see "Streamly.Data.Unfold.crossWith" for fast fusible static cross +-- product option. +-- +{-# INLINE crossWith #-} +crossWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c +crossWith f m1 m2 = fmap f m1 `crossApply` m2 + +-- | Like 'crossWith' but interleaves the outer and inner loops fairly. See +-- 'fairConcatFor' for more details. +-- +{-# INLINE fairCrossWith #-} +fairCrossWith :: Monad m => + (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c +fairCrossWith f = fairCrossWithM (\a b -> return $ f a b) + +-- | Given a @Stream m a@ and @Stream m b@ generate a stream with all possible +-- combinations of the tuple @(a, b)@. +-- +-- Definition: +-- +-- >>> cross = Stream.crossWith (,) +-- +-- The second stream is evaluated multiple times. If that is not desired it can +-- be cached in an 'Data.Array.Array' and then generated from the array before +-- calling this function. Caching may also improve performance if the stream is +-- expensive to evaluate. +-- +-- Time: O(m x n) +-- +-- /Pre-release/ +{-# INLINE cross #-} +cross :: Monad m => Stream m a -> Stream m b -> Stream m (a, b) +cross = crossWith (,) + +-- | Like 'cross' but interleaves the outer and inner loops fairly. See +-- 'fairConcatFor' for more details. +{-# INLINE fairCross #-} +fairCross :: Monad m => Stream m a -> Stream m b -> Stream m (a, b) +fairCross = fairCrossWith (,) + +-- crossWith/cross should ideally use Stream m b as the first stream, because +-- we are transforming Stream m a using that. We provide loop with arguments +-- flipped. + +-- crossMap or crossInner? + +-- | Loop the supplied stream (first argument) around each element of the input +-- stream (second argument) generating tuples. This is an argument flipped +-- version of 'cross'. +{-# INLINE loop #-} +loop :: Monad m => Stream m b -> Stream m a -> Stream m (a, b) +loop = crossWith (\b a -> (a,b)) + +-- | Loop by unfold. Unfold a value into a stream and nest it with the input +-- stream. This is much faster than 'loop' due to stream fusion. +{-# INLINE loopBy #-} +loopBy :: Monad m => Unfold m x b -> x -> Stream m a -> Stream m (a, b) +loopBy u x s = + let u1 = Unfold.lmap snd u + u2 = Unfold.map (first fst) (Unfold.carry u1) + in unfoldEach u2 $ fmap (, x) s + +------------------------------------------------------------------------------ +-- Combine N Streams - unfoldEach +------------------------------------------------------------------------------ + +{-# ANN type ConcatMapUState Fuse #-} +data ConcatMapUState o i = + ConcatMapUOuter o + | ConcatMapUInner o i + +-- | @unfoldEach unfold stream@ uses @unfold@ to map the input stream elements +-- to streams and then flattens the generated streams into a single output +-- stream. + +-- This is like 'concatMap' but uses an unfold with an explicit state to +-- generate the stream instead of a 'Stream' type generator. This allows better +-- optimization via fusion. This can be many times more efficient than +-- 'concatMap'. +-- +-- 'unfoldEach' is equivalent in expressive power to 'concatMap'. However, +-- using it as concatMap — by lifting a function 'f :: a -> Stream m b' into +-- an 'Unfold' — results in the same degraded performance as 'concatMap': + +-- | Like 'concatMap' but uses an 'Unfold' for stream generation. Unlike +-- 'concatMap' this can fuse the 'Unfold' code with the inner loop and +-- therefore provide many times better performance. +-- +-- >>> concatMap f = Stream.unfoldEach (Unfold.lmap f Unfold.fromStream) +-- +-- Here is an example of a two level nested loop much faster than +-- 'concatMap' based nesting. +-- +-- >>> :{ +-- outerLoop = +-- flip Stream.mapM (Stream.fromList [1,2,3]) $ \x -> do +-- liftIO $ putStrLn (show x) +-- return x +-- innerUnfold = Unfold.carry $ Unfold.lmap (const [4,5,6]) Unfold.fromList +-- innerLoop = +-- flip Unfold.mapM innerUnfold $ \(x, y) -> do +-- when (x == 1) $ liftIO $ putStrLn (show y) +-- pure $ (x, y) +-- :} +-- +-- >>> Stream.toList $ Stream.unfoldEach innerLoop outerLoop +-- 1 +-- 4 +-- 5 +-- 6 +-- 2 +-- 3 +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +{-# INLINE_NORMAL unfoldEach #-} +unfoldEach, unfoldMany :: Monad m => Unfold m a b -> Stream m a -> Stream m b +unfoldEach (Unfold istep inject) (Stream ostep ost) = + Stream step (ConcatMapUOuter ost) + where + {-# INLINE_LATE step #-} + step gst (ConcatMapUOuter o) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- inject a + i `seq` return (Skip (ConcatMapUInner o' i)) + Skip o' -> return $ Skip (ConcatMapUOuter o') + Stop -> return Stop + + step _ (ConcatMapUInner o i) = do + r <- istep i + return $ case r of + Yield x i' -> Yield x (ConcatMapUInner o i') + Skip i' -> Skip (ConcatMapUInner o i') + Stop -> Skip (ConcatMapUOuter o) + +RENAME(unfoldMany,unfoldEach) + +-- XXX unfoldEach generates faster code than unfoldCross with +-- everything unboxed i.e. 0 allocations. + +-- | Generates a cross product of two streams and then unfolds each tuple. +-- +-- A two level nested loop much faster than 'concatMap' based nesting. +-- +-- >>> :{ +-- outerLoop = +-- flip Stream.mapM (Stream.fromList [1,2,3]) $ \x -> do +-- liftIO $ putStrLn (show x) +-- return x +-- innerLoop = +-- flip Stream.mapM (Stream.fromList [4,5,6]) $ \y -> do +-- -- liftIO $ putStrLn (show y) +-- return y +-- innerUnfold = +-- flip Unfold.mapM Unfold.identity $ \(x,y) -> do +-- when (x == 1) $ liftIO $ putStrLn (show y) +-- pure $ (x, y) +-- :} +-- +-- >>> Stream.toList $ Stream.unfoldCross innerUnfold outerLoop innerLoop +-- 1 +-- 4 +-- 5 +-- 6 +-- 2 +-- 3 +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +-- Note: 'unfoldEach' may generate faster code, so use that when possible. +-- Also see "Streamly.Data.Unfold.cross" for fast fusible static cross product +-- option. +-- +{-# INLINE unfoldCross #-} +unfoldCross :: Monad m => + Unfold m (a,b) c -> Stream m a -> Stream m b -> Stream m c +unfoldCross unf m1 m2 = unfoldEach unf $ crossWith (,) m1 m2 + +------------------------------------------------------------------------------ +-- Combine N Streams - concatMap +------------------------------------------------------------------------------ + +-- Adapted from the vector package. + +-- If we are iterating over n elements flat vs m nesting of n^{1/m} elements. +-- The total iterations in the nesting case will be +-- let x = n^{1/m} in {x + x^2 + x^3 + ... + x^m} = x * {(x^m - 1)/(x-1)} +-- i.e. (n-1)/(1-1/x) which is not very high. However, the decision tree in the +-- state of concatMap is traversed from root to leaf for each element, and the +-- state updates also updates the tree from leaf to root upon yielding an +-- element which makes the allocations as well as CPU performance quadratic. + +-- | Map a stream producing monadic function on each element of the stream +-- and then flatten the results into a single stream. Since the stream +-- generation function is monadic, unlike 'concatMap', it can produce an +-- effect at the beginning of each iteration of the inner loop. +-- +-- See 'unfoldEach' for a faster alternative. +-- +{-# INLINE_NORMAL concatMapM #-} +concatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b +concatMapM f (Stream step state) = Stream step' (Left state) + where + {-# INLINE_LATE step' #-} + step' gst (Left st) = do + r <- step (adaptState gst) st + case r of + Yield a s -> do + b_stream <- f a + return $ Skip (Right (b_stream, s)) + Skip s -> return $ Skip (Left s) + Stop -> return Stop + + -- XXX using the pattern synonym "Stream" causes a major performance issue + -- here even if the synonym does not include an adaptState call. Need to + -- find out why. Is that something to be fixed in GHC? + step' gst (Right (UnStream inner_step inner_st, st)) = do + r <- inner_step (adaptState gst) inner_st + case r of + Yield b inner_s -> + return $ Yield b (Right (Stream inner_step inner_s, st)) + Skip inner_s -> + return $ Skip (Right (Stream inner_step inner_s, st)) + Stop -> return $ Skip (Left st) + +-- | Map a stream producing function on each element of the stream and then +-- flatten the results into a single stream. +-- +-- >>> concatMap f = Stream.concat . fmap f +-- >>> concatMap f = Stream.concatMapM (return . f) +-- >>> concatMap f = Stream.unfoldEach (Unfold.lmap f Unfold.fromStream) +-- +-- See argument flipped version 'concatFor' for more detailed documentation. +-- +-- NOTE: We recommend using 'unfoldEach' or 'unfoldCross' instead of +-- 'concatMap' especially in performance critical code. 'unfoldEach' is much +-- faster than 'concatMap' and matches its expressive power in terms of +-- generating dependent inner streams, there is one important distinction +-- though: the nesting structure when using 'unfoldEach' is fixed statically in +-- the code. In contrast, 'concatMap' allows dynamic and arbitrary nesting +-- through monadic composition. This means that deeply nested or +-- programmatically determined levels of nesting are easier to express and +-- compose with 'concatMap', though often at the cost of performance and +-- fusion. +-- +{-# INLINE concatMap #-} +concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b +concatMap f = concatMapM (return . f) + +-- XXX Add smap/sfor (mapAccum) as a more ergonomic substitute for scan, not +-- exposing the state in the output stream. +-- XXX add sconcatMap/sconcatFor as stateful alternatives. + +-- | Map a stream generating function on each element of a stream and +-- concatenate the results. This is the same as the bind function of the monad +-- instance. It is just a flipped 'concatMap' but more convenient to use for +-- nested use case, feels like an imperative @for@ loop. It is in fact +-- equivalent to @concat . for@. +-- +-- >>> concatFor = flip Stream.concatMap +-- +-- A concatenating @for@ loop: +-- +-- >>> :{ +-- Stream.toList $ +-- Stream.concatFor (Stream.fromList [1,2,3]) $ \x -> +-- Stream.fromPure x +-- :} +-- [1,2,3] +-- +-- Use 'unfoldEach' instead of 'concatFor' where possible, unfoldEach is much +-- faster due to fusion. +-- +-- Nested concatenating @for@ loops: +-- +-- >>> :{ +-- Stream.toList $ +-- Stream.concatFor (Stream.fromList [1,2,3]) $ \x -> +-- Stream.concatFor (Stream.fromList [4,5,6]) $ \y -> +-- Stream.fromPure (x, y) +-- :} +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +-- If total iterations are kept the same, each increase in the nesting level +-- increases the cost by roughly 2 times. +-- +-- For significantly faster multi-level nesting, prefer using the better +-- fusible, applicative-like 'crossWith' over 'concatFor' where possible. +-- +-- 'concatFor' is monad-like: it allows expressing dependencies between the +-- outer and the inner loops of the nesting, it means that the stream generated +-- by the inner loop is dynamically governed by the outer loop. This expressive +-- power comes at a significant performance cost. +-- +-- NOTE: We recommend using 'unfoldEach' or 'unfoldCross' instead of +-- 'concatFor' especially in performance critical code. 'unfoldEach' is much +-- faster than 'concatFor' and matches its expressive power in terms of +-- generating dependent inner streams, there is one important distinction +-- though: the nesting structure when using 'unfoldEach' is fixed statically in +-- the code. In contrast, 'concatFor' allows dynamic and arbitrary nesting +-- through monadic composition. This means that deeply nested or +-- programmatically determined levels of nesting are easier to express and +-- compose with 'concatFor', though often at the cost of performance and +-- fusion. +-- +-- +{-# INLINE concatFor #-} +concatFor :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b +concatFor = flip concatMap + +-- NOTE: A monad instance can do with just concatMap because we lift an effect +-- explicitly using liftIO and then bind/applicative concats it. Not sure if it +-- gets fused and the overhead of additional concat removed. However, for +-- explicit use concatForM is more ergonomic as we do not need to lift and +-- concat, we can just use the do notation in the underlying monad.. + +-- | Like 'concatFor' but maps an effectful function. It allows conveniently +-- mixing monadic effects with streams. +-- +-- >>> import Control.Monad.IO.Class (liftIO) +-- >>> :{ +-- Stream.toList $ +-- Stream.concatForM (Stream.fromList [1,2,3]) $ \x -> do +-- liftIO $ putStrLn (show x) +-- pure $ Stream.fromPure x +-- :} +-- 1 +-- 2 +-- 3 +-- [1,2,3] +-- +-- Nested concatentating @for@ loops: +-- +-- >>> :{ +-- Stream.toList $ +-- Stream.concatForM (Stream.fromList [1,2,3]) $ \x -> do +-- liftIO $ putStrLn (show x) +-- pure $ Stream.concatForM (Stream.fromList [4,5,6]) $ \y -> do +-- when (x == 1) $ liftIO $ putStrLn (show y) +-- pure $ Stream.fromPure (x, y) +-- :} +-- 1 +-- 4 +-- 5 +-- 6 +-- 2 +-- 3 +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +{-# INLINE concatForM #-} +concatForM :: Monad m => Stream m a -> (a -> m (Stream m b)) -> Stream m b +concatForM = flip concatMapM + +-- | Flatten a stream of streams to a single stream. +-- +-- >>> concat = Stream.concatMap id +-- +-- /Pre-release/ +{-# INLINE concat #-} +concat :: Monad m => Stream m (Stream m a) -> Stream m a +concat = concatMap id + +-- >>> concatEffect = Stream.concat . lift -- requires (MonadTrans t) +-- >>> concatEffect = join . lift -- requires (MonadTrans t, Monad (Stream m)) + +-- | Flatten a stream generated by an effect i.e. concat the effect monad with +-- the stream monad. +-- +-- >>> concatEffect = Stream.concat . Stream.fromEffect +-- >>> concatEffect eff = Stream.concatMapM (\() -> eff) (Stream.fromPure ()) +-- +-- See also: 'concat', 'sequence' +-- +{-# INLINE concatEffect #-} +concatEffect :: Monad m => m (Stream m a) -> Stream m a +concatEffect generator = concatMapM (\() -> generator) (fromPure ()) + +{- +-- NOTE: even though concatMap for StreamD is 4x faster compared to StreamK, +-- the monad instance does not seem to be significantly faster. +instance Monad m => Monad (Stream m) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + (>>=) = flip concatMap + + {-# INLINE (>>) #-} + (>>) = (*>) +-} + +------------------------------------------------------------------------------ +-- Traversing a tree top down +------------------------------------------------------------------------------ + +-- Next stream is to be generated by the return value of the previous stream. A +-- general intuitive way of doing that could be to use an appending monad +-- instance for streams where the result of the previous stream is used to +-- generate the next one. In the first pass we can just emit the values in the +-- stream and keep building a buffered list/stream, once done we can then +-- process the buffered stream. + +-- | Generate a stream from an initial state, scan and concat the stream, +-- generate a stream again from the final state of the previous scan and repeat +-- the process. +{-# INLINE_NORMAL concatIterateScan #-} +concatIterateScan :: Monad m => + (b -> a -> m b) + -> (b -> m (Maybe (b, Stream m a))) + -> b + -> Stream m a +concatIterateScan scanner generate initial = Stream step (Left initial) + + where + + {-# INLINE_LATE step #-} + step _ (Left acc) = do + r <- generate acc + case r of + Nothing -> return Stop + Just v -> return $ Skip (Right v) + + step gst (Right (st, UnStream inner_step inner_st)) = do + r <- inner_step (adaptState gst) inner_st + case r of + Yield b inner_s -> do + acc <- scanner st b + return $ Yield b (Right (acc, Stream inner_step inner_s)) + Skip inner_s -> + return $ Skip (Right (st, Stream inner_step inner_s)) + Stop -> return $ Skip (Left st) + +-- Note: The iterate function returns a Maybe Stream instead of returning a nil +-- stream for indicating a leaf node. This is to optimize so that we do not +-- have to store any state. This makes the stored state proportional to the +-- number of non-leaf nodes rather than total number of nodes. + +-- | Same as 'concatIterateBfs' except that the traversal of the last +-- element on a level is emitted first and then going backwards up to the first +-- element (reversed ordering). This may be slightly faster than +-- 'concatIterateBfs'. +-- +{-# INLINE_NORMAL altBfsConcatIterate #-} +altBfsConcatIterate, concatIterateBfsRev :: Monad m => + (a -> Maybe (Stream m a)) + -> Stream m a + -> Stream m a +altBfsConcatIterate f stream = Stream step (stream, []) + + where + + {-# INLINE_LATE step #-} + step gst (UnStream step1 st, xs) = do + r <- step1 (adaptState gst) st + case r of + Yield a s -> do + let xs1 = + case f a of + Nothing -> xs + Just x -> x:xs + return $ Yield a (Stream step1 s, xs1) + Skip s -> return $ Skip (Stream step1 s, xs) + Stop -> + case xs of + (y:ys) -> return $ Skip (y, ys) + [] -> return Stop + +RENAME(concatIterateBfsRev,altBfsConcatIterate) + +-- | Similar to 'concatIterate' except that it traverses the stream in +-- breadth first style (BFS). First, all the elements in the input stream are +-- emitted, and then their traversals are emitted. +-- +-- Example, list a directory tree using BFS: +-- +-- >>> f = either (Just . Dir.readEitherPaths id) (const Nothing) +-- >>> input = Stream.fromEffect (Left <$> Path.fromString ".") +-- >>> ls = Stream.bfsConcatIterate f input +-- +-- /Pre-release/ +{-# INLINE_NORMAL bfsConcatIterate #-} +bfsConcatIterate, concatIterateBfs :: Monad m => + (a -> Maybe (Stream m a)) + -> Stream m a + -> Stream m a +bfsConcatIterate f stream = Stream step (stream, [], []) + + where + + {-# INLINE_LATE step #-} + step gst (UnStream step1 st, xs, ys) = do + r <- step1 (adaptState gst) st + case r of + Yield a s -> do + let ys1 = + case f a of + Nothing -> ys + Just y -> y:ys + return $ Yield a (Stream step1 s, xs, ys1) + Skip s -> return $ Skip (Stream step1 s, xs, ys) + Stop -> + case xs of + (x:xs1) -> return $ Skip (x, xs1, ys) + [] -> + case reverse ys of + (x:xs1) -> return $ Skip (x, xs1, []) + [] -> return Stop + +RENAME(concatIterateBfs,bfsConcatIterate) + +-- | Traverse the stream in depth first style (DFS). Map each element in the +-- input stream to a stream and flatten, recursively map the resulting elements +-- as well to a stream and flatten until no more streams are generated. +-- +-- Example, list a directory tree using DFS: +-- +-- >>> f = either (Just . Dir.readEitherPaths id) (const Nothing) +-- >>> input = Stream.fromEffect (Left <$> Path.fromString ".") +-- >>> ls = Stream.concatIterate f input +-- +-- This is equivalent to using @concatIterateWith StreamK.append@. +-- +-- /Pre-release/ +{-# INLINE_NORMAL concatIterate #-} +concatIterate, concatIterateDfs :: Monad m => + (a -> Maybe (Stream m a)) + -> Stream m a + -> Stream m a +concatIterate f stream = Stream step (stream, []) + + where + + {-# INLINE_LATE step #-} + step gst (UnStream step1 st, xs) = do + r <- step1 (adaptState gst) st + case r of + Yield a s -> do + let st1 = + case f a of + Nothing -> (Stream step1 s, xs) + Just x -> (x, Stream step1 s:xs) + return $ Yield a st1 + Skip s -> return $ Skip (Stream step1 s, xs) + Stop -> + case xs of + (y:ys) -> return $ Skip (y, ys) + [] -> return Stop + +RENAME(concatIterateDfs,concatIterate) + +{-# ANN type IterateUnfoldState Fuse #-} +data IterateUnfoldState o i = + IterateUnfoldOuter o + | IterateUnfoldInner o i [i] + +-- | Same as 'concatIterate' but more efficient due to stream fusion. +-- +-- Example, list a directory tree using DFS: +-- +-- >>> f = Unfold.either (Dir.eitherReaderPaths id) Unfold.nil +-- >>> input = Stream.fromEffect (Left <$> Path.fromString ".") +-- >>> ls = Stream.unfoldIterate f input +-- +-- /Pre-release/ +{-# INLINE_NORMAL unfoldIterate #-} +unfoldIterate, unfoldIterateDfs :: Monad m => + Unfold m a a + -> Stream m a + -> Stream m a +unfoldIterate (Unfold istep inject) (Stream ostep ost) = + Stream step (IterateUnfoldOuter ost) + + where + + {-# INLINE_LATE step #-} + step gst (IterateUnfoldOuter o) = do + r <- ostep (adaptState gst) o + case r of + Yield a s -> do + i <- inject a + i `seq` return (Yield a (IterateUnfoldInner s i [])) + Skip s -> return $ Skip (IterateUnfoldOuter s) + Stop -> return Stop + + step _ (IterateUnfoldInner o i ii) = do + r <- istep i + case r of + Yield x s -> do + i1 <- inject x + i1 `seq` return $ Yield x (IterateUnfoldInner o i1 (s:ii)) + Skip s -> return $ Skip (IterateUnfoldInner o s ii) + Stop -> + case ii of + (y:ys) -> return $ Skip (IterateUnfoldInner o y ys) + [] -> return $ Skip (IterateUnfoldOuter o) + +RENAME(unfoldIterateDfs,unfoldIterate) + +{-# ANN type IterateUnfoldBFSRevState Fuse #-} +data IterateUnfoldBFSRevState o i = + IterateUnfoldBFSRevOuter o [i] + | IterateUnfoldBFSRevInner i [i] + +-- | Like 'bfsUnfoldIterate' but processes the children in reverse order, +-- therefore, may be slightly faster. +-- +-- /Pre-release/ +{-# INLINE_NORMAL altBfsUnfoldIterate #-} +altBfsUnfoldIterate, unfoldIterateBfsRev :: Monad m => + Unfold m a a + -> Stream m a + -> Stream m a +altBfsUnfoldIterate (Unfold istep inject) (Stream ostep ost) = + Stream step (IterateUnfoldBFSRevOuter ost []) + + where + + {-# INLINE_LATE step #-} + step gst (IterateUnfoldBFSRevOuter o ii) = do + r <- ostep (adaptState gst) o + case r of + Yield a s -> do + i <- inject a + i `seq` return (Yield a (IterateUnfoldBFSRevOuter s (i:ii))) + Skip s -> return $ Skip (IterateUnfoldBFSRevOuter s ii) + Stop -> + case ii of + (y:ys) -> return $ Skip (IterateUnfoldBFSRevInner y ys) + [] -> return Stop + + step _ (IterateUnfoldBFSRevInner i ii) = do + r <- istep i + case r of + Yield x s -> do + i1 <- inject x + i1 `seq` return $ Yield x (IterateUnfoldBFSRevInner s (i1:ii)) + Skip s -> return $ Skip (IterateUnfoldBFSRevInner s ii) + Stop -> + case ii of + (y:ys) -> return $ Skip (IterateUnfoldBFSRevInner y ys) + [] -> return Stop + +RENAME(unfoldIterateBfsRev,altBfsUnfoldIterate) + +{-# ANN type IterateUnfoldBFSState Fuse #-} +data IterateUnfoldBFSState o i = + IterateUnfoldBFSOuter o [i] + | IterateUnfoldBFSInner i [i] [i] + +-- | Like 'unfoldIterate' but uses breadth first style traversal. +-- +-- /Pre-release/ +{-# INLINE_NORMAL bfsUnfoldIterate #-} +bfsUnfoldIterate, unfoldIterateBfs :: Monad m => + Unfold m a a + -> Stream m a + -> Stream m a +bfsUnfoldIterate (Unfold istep inject) (Stream ostep ost) = + Stream step (IterateUnfoldBFSOuter ost []) + + where + + {-# INLINE_LATE step #-} + step gst (IterateUnfoldBFSOuter o rii) = do + r <- ostep (adaptState gst) o + case r of + Yield a s -> do + i <- inject a + i `seq` return (Yield a (IterateUnfoldBFSOuter s (i:rii))) + Skip s -> return $ Skip (IterateUnfoldBFSOuter s rii) + Stop -> + case reverse rii of + (y:ys) -> return $ Skip (IterateUnfoldBFSInner y ys []) + [] -> return Stop + + step _ (IterateUnfoldBFSInner i ii rii) = do + r <- istep i + case r of + Yield x s -> do + i1 <- inject x + i1 `seq` return $ Yield x (IterateUnfoldBFSInner s ii (i1:rii)) + Skip s -> return $ Skip (IterateUnfoldBFSInner s ii rii) + Stop -> + case ii of + (y:ys) -> return $ Skip (IterateUnfoldBFSInner y ys rii) + [] -> + case reverse rii of + (y:ys) -> return $ Skip (IterateUnfoldBFSInner y ys []) + [] -> return Stop + +RENAME(unfoldIterateBfs,bfsUnfoldIterate) + +------------------------------------------------------------------------------ +-- Folding a tree bottom up +------------------------------------------------------------------------------ + +-- | Binary BFS style reduce, folds a level entirely using the supplied fold +-- function, collecting the outputs as next level of the tree, then repeats the +-- same process on the next level. The last elements of a previously folded +-- level are folded first. +{-# INLINE_NORMAL bfsReduceIterate #-} +bfsReduceIterate, reduceIterateBfs :: Monad m => + (a -> a -> m a) -> Stream m a -> m (Maybe a) +bfsReduceIterate f (Stream step state) = go SPEC state [] Nothing + + where + + go _ st xs Nothing = do + r <- step defState st + case r of + Yield x1 s -> go SPEC s xs (Just x1) + Skip s -> go SPEC s xs Nothing + Stop -> + case xs of + [] -> return Nothing + _ -> goBuf SPEC xs [] + go _ st xs (Just x1) = do + r2 <- step defState st + case r2 of + Yield x2 s -> do + x <- f x1 x2 + go SPEC s (x:xs) Nothing + Skip s -> go SPEC s xs (Just x1) + Stop -> + case xs of + [] -> return (Just x1) + _ -> goBuf SPEC (x1:xs) [] + + goBuf _ [] ys = goBuf SPEC ys [] + goBuf _ [x1] ys = do + case ys of + [] -> return (Just x1) + (x2:xs) -> do + y <- f x1 x2 + goBuf SPEC xs [y] + goBuf _ (x1:x2:xs) ys = do + y <- f x1 x2 + goBuf SPEC xs (y:ys) + +RENAME(reduceIterateBfs,bfsReduceIterate) + +-- | N-Ary BFS style iterative fold, if the input stream finished before the +-- fold then it returns Left otherwise Right. If the fold returns Left we +-- terminate. +-- +-- /Unimplemented/ +bfsFoldIterate :: + Fold m a (Either a a) -> Stream m a -> m (Maybe a) +bfsFoldIterate = undefined + +------------------------------------------------------------------------------ +-- Grouping/Splitting +------------------------------------------------------------------------------ + +-- s = stream state, fs = fold state +{-# ANN type FoldManyPost Fuse #-} +#if __GLASGOW_HASKELL__ >= 810 +type FoldManyPost :: Type -> Type -> Type -> Type -> Type +#endif +data FoldManyPost s fs b a + = FoldManyPostStart s + | FoldManyPostLoop s fs + | FoldManyPostYield b (FoldManyPost s fs b a) + | FoldManyPostDone + +-- Note that using a closed fold e.g. @Fold.take 0@, would result in an +-- infinite stream without consuming the input. +-- +-- We can call foldManyPost as foldMany0, but we should probably remove it. +-- Like foldMany0, "scan" should ideally be "scan0" always resulting in a +-- non-empty stream, and "postscan" should be called just "scan" because it is +-- much more common. But those names cannot be changed now. + +-- | Like 'foldMany' but evaluates the fold even if the fold did not receive +-- any input, therefore, always results in a non-empty output even on an empty +-- stream (default result of the fold). +-- +-- Example, empty stream, compare with 'foldMany': +-- +-- >>> f = Fold.take 2 Fold.toList +-- >>> fmany = Stream.fold Fold.toList . Stream.foldManyPost f +-- >>> fmany $ Stream.fromList [] +-- [[]] +-- +-- Example, last empty fold is included, compare with 'foldMany': +-- +-- >>> fmany $ Stream.fromList [1..4] +-- [[1,2],[3,4],[]] +-- +-- Example, last fold non-empty, same as 'foldMany': +-- +-- >>> fmany $ Stream.fromList [1..5] +-- [[1,2],[3,4],[5]] +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL foldManyPost #-} +foldManyPost :: Monad m => Fold m a b -> Stream m a -> Stream m b +foldManyPost (Fold fstep initial _ final) (Stream step state) = + Stream step' (FoldManyPostStart state) + + where + + {-# INLINE consume #-} + consume x s fs = do + res <- fstep fs x + return + $ Skip + $ case res of + FL.Done b -> FoldManyPostYield b (FoldManyPostStart s) + FL.Partial ps -> FoldManyPostLoop s ps + + {-# INLINE_LATE step' #-} + step' _ (FoldManyPostStart st) = do + r <- initial + return + $ Skip + $ case r of + FL.Done b -> FoldManyPostYield b (FoldManyPostStart st) + FL.Partial fs -> FoldManyPostLoop st fs + step' gst (FoldManyPostLoop st fs) = do + r <- step (adaptState gst) st + case r of + Yield x s -> consume x s fs + Skip s -> return $ Skip (FoldManyPostLoop s fs) + Stop -> do + b <- final fs + return $ Skip (FoldManyPostYield b FoldManyPostDone) + step' _ (FoldManyPostYield b next) = return $ Yield b next + step' _ FoldManyPostDone = return Stop + +-- | Apply fold f1 infix separated by fold f2. +-- +-- /Unimplemented/ +{-# INLINE_NORMAL foldManySepBy #-} +foldManySepBy :: -- Monad m => + Fold m a b -> Fold m a b -> Stream m a -> Stream m b +foldManySepBy _f1 _f2 = undefined + +{-# ANN type FoldMany Fuse #-} +#if __GLASGOW_HASKELL__ >= 810 +type FoldMany :: Type -> Type -> Type -> Type -> Type +#endif +data FoldMany s fs b a + = FoldManyStart s + | FoldManyFirst fs s + | FoldManyLoop s fs + | FoldManyYield b (FoldMany s fs b a) + | FoldManyDone + +-- XXX Nested foldMany does not fuse. + +-- | Apply a terminating 'Fold' repeatedly on a stream and emit the results in +-- the output stream. If the last fold is empty, it's result is not emitted. +-- This means if the input stream is empty the result is also an empty stream. +-- See 'foldManyPost' for an alternate behavior which always results in a +-- non-empty stream even if the input stream is empty. +-- +-- Definition: +-- +-- >>> foldMany f = Stream.parseMany (Parser.fromFold f) +-- +-- Example, empty stream, omits the empty fold value: +-- +-- >>> f = Fold.take 2 Fold.toList +-- >>> fmany = Stream.fold Fold.toList . Stream.foldMany f +-- >>> fmany $ Stream.fromList [] +-- [] +-- +-- Example, omits the last empty fold value: +-- +-- >>> fmany $ Stream.fromList [1..4] +-- [[1,2],[3,4]] +-- +-- Example, last fold non-empty: +-- +-- >>> fmany $ Stream.fromList [1..5] +-- [[1,2],[3,4],[5]] +-- +-- Note that using a closed fold e.g. @Fold.take 0@, would result in an +-- infinite stream on a non-empty input stream. +-- +{-# INLINE_NORMAL foldMany #-} +foldMany :: Monad m => Fold m a b -> Stream m a -> Stream m b +foldMany (Fold fstep initial _ final) (Stream step state) = + Stream step' (FoldManyStart state) + + where + + {-# INLINE consume #-} + consume x s fs = do + res <- fstep fs x + return + $ Skip + $ case res of + FL.Done b -> FoldManyYield b (FoldManyStart s) + FL.Partial ps -> FoldManyLoop s ps + + {-# INLINE_LATE step' #-} + step' _ (FoldManyStart st) = do + r <- initial + return + $ Skip + $ case r of + FL.Done b -> FoldManyYield b (FoldManyStart st) + FL.Partial fs -> FoldManyFirst fs st + step' gst (FoldManyFirst fs st) = do + r <- step (adaptState gst) st + case r of + Yield x s -> consume x s fs + Skip s -> return $ Skip (FoldManyFirst fs s) + Stop -> final fs >> return Stop + step' gst (FoldManyLoop st fs) = do + r <- step (adaptState gst) st + case r of + Yield x s -> consume x s fs + Skip s -> return $ Skip (FoldManyLoop s fs) + Stop -> do + b <- final fs + return $ Skip (FoldManyYield b FoldManyDone) + step' _ (FoldManyYield b next) = return $ Yield b next + step' _ FoldManyDone = return Stop + +-- | Group the input stream into groups of @n@ elements each and then fold each +-- group using the provided fold function. +-- +-- Definition: +-- +-- >>> groupsOf n f = Stream.foldMany (Fold.take n f) +-- +-- Usage: +-- +-- >>> Stream.toList $ Stream.groupsOf 2 Fold.toList (Stream.enumerateFromTo 1 10) +-- [[1,2],[3,4],[5,6],[7,8],[9,10]] +-- +-- This can be considered as an n-fold version of 'take' where we apply +-- 'take' repeatedly on the leftover stream until the stream exhausts. +-- +{-# INLINE groupsOf #-} +groupsOf :: Monad m => Int -> Fold m a b -> Stream m a -> Stream m b +groupsOf n f = foldMany (FL.take n f) + +-- Keep the argument order consistent with refoldIterateM. + +-- | Like 'foldMany' but for the 'Refold' type. The supplied action is used as +-- the initial value for each refold. +-- +-- /Internal/ +{-# INLINE_NORMAL refoldMany #-} +refoldMany :: Monad m => Refold m x a b -> m x -> Stream m a -> Stream m b +refoldMany (Refold fstep inject extract) action (Stream step state) = + Stream step' (FoldManyStart state) + + where + + {-# INLINE consume #-} + consume x s fs = do + res <- fstep fs x + return + $ Skip + $ case res of + FL.Done b -> FoldManyYield b (FoldManyStart s) + FL.Partial ps -> FoldManyLoop s ps + + {-# INLINE_LATE step' #-} + step' _ (FoldManyStart st) = do + r <- action >>= inject + return + $ Skip + $ case r of + FL.Done b -> FoldManyYield b (FoldManyStart st) + FL.Partial fs -> FoldManyFirst fs st + step' gst (FoldManyFirst fs st) = do + r <- step (adaptState gst) st + case r of + Yield x s -> consume x s fs + Skip s -> return $ Skip (FoldManyFirst fs s) + Stop -> return Stop + step' gst (FoldManyLoop st fs) = do + r <- step (adaptState gst) st + case r of + Yield x s -> consume x s fs + Skip s -> return $ Skip (FoldManyLoop s fs) + Stop -> do + b <- extract fs + return $ Skip (FoldManyYield b FoldManyDone) + step' _ (FoldManyYield b next) = return $ Yield b next + step' _ FoldManyDone = return Stop + +{-# ANN type CIterState Fuse #-} +data CIterState s f fs b + = CIterInit s f + | CIterConsume s fs + | CIterYield b (CIterState s f fs b) + | CIterStop + +-- | Like 'foldIterateM' but using the 'Refold' type instead. This could be +-- much more efficient due to stream fusion. +-- +-- /Internal/ +{-# INLINE_NORMAL refoldIterateM #-} +refoldIterateM :: + Monad m => Refold m b a b -> m b -> Stream m a -> Stream m b +refoldIterateM (Refold fstep finject fextract) initial (Stream step state) = + Stream stepOuter (CIterInit state initial) + + where + + {-# INLINE iterStep #-} + iterStep st action = do + res <- action + return + $ Skip + $ case res of + FL.Partial fs -> CIterConsume st fs + FL.Done fb -> CIterYield fb $ CIterInit st (return fb) + + {-# INLINE_LATE stepOuter #-} + stepOuter _ (CIterInit st action) = do + iterStep st (action >>= finject) + stepOuter gst (CIterConsume st fs) = do + r <- step (adaptState gst) st + case r of + Yield x s -> iterStep s (fstep fs x) + Skip s -> return $ Skip $ CIterConsume s fs + Stop -> do + b <- fextract fs + return $ Skip $ CIterYield b CIterStop + stepOuter _ (CIterYield a next) = return $ Yield a next + stepOuter _ CIterStop = return Stop + +-- | The refold @indexerBy f n@ takes an (index, len) tuple as initial input, +-- and returns @(index + len + n, b)@ as output where @b@ is the output of the +-- fold. +{-# INLINE indexerBy #-} +indexerBy :: Monad m => + Fold m a Int -> Int -> Refold m (Int, Int) a (Int, Int) +indexerBy (Fold step1 initial1 extract1 _final) n = + Refold step inject extract + + where + + inject (i, len) = do + r <- initial1 + return $ case r of + FL.Partial s -> FL.Partial $ Tuple' (i + len + n) s + FL.Done l -> FL.Done (i, l) + + step (Tuple' i s) x = do + r <- step1 s x + return $ case r of + FL.Partial s1 -> FL.Partial $ Tuple' i s1 + FL.Done len -> FL.Done (i, len) + + extract (Tuple' i s) = (i,) <$> extract1 s + +-- | Like 'splitEndBy_' but generates a stream of (index, len) tuples marking +-- the places where the predicate matches in the stream. +-- +-- >>> Stream.toList $ Stream.indexEndBy_ (== '/') $ Stream.fromList "/home/harendra" +-- [(0,0),(1,4),(6,8)] +-- +-- /Pre-release/ +{-# INLINE indexEndBy_ #-} +indexEndBy_, indexOnSuffix :: Monad m => + (a -> Bool) -> Stream m a -> Stream m (Int, Int) +indexEndBy_ predicate = + refoldIterateM + (indexerBy (FL.takeEndBy_ predicate FL.length) 1) + (return (-1, 0)) + +RENAME(indexOnSuffix,indexEndBy_) + +-- Alternate implementation +{-# INLINE_NORMAL _indexEndBy_ #-} +_indexEndBy_ :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) +_indexEndBy_ p (Stream step1 state1) = Stream step (Just (state1, 0, 0)) + + where + + {-# INLINE_LATE step #-} + step gst (Just (st, i, len)) = i `seq` len `seq` do + r <- step1 (adaptState gst) st + return + $ case r of + Yield x s -> + if p x + then Yield (i, len + 1) (Just (s, i + len + 1, 0)) + else Skip (Just (s, i, len + 1)) + Skip s -> Skip (Just (s, i, len)) + Stop -> if len == 0 then Stop else Yield (i, len) Nothing + step _ Nothing = return Stop + +{-# DEPRECATED sliceOnSuffix "Please use indexEndBy_ instead." #-} +sliceOnSuffix :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int) +sliceOnSuffix = indexEndBy_ + +-- | Like 'splitEndBy' but generates a stream of (index, len) tuples marking +-- the places where the predicate matches in the stream. +-- +-- >>> Stream.toList $ Stream.indexEndBy (== '/') $ Stream.fromList "/home/harendra" +-- [(0,1),(1,5),(6,8)] +-- +-- /Pre-release/ +{-# INLINE indexEndBy #-} +indexEndBy :: Monad m => + (a -> Bool) -> Stream m a -> Stream m (Int, Int) +indexEndBy predicate = + refoldIterateM + (indexerBy (FL.takeEndBy predicate FL.length) 0) + (return (0, 0)) + +------------------------------------------------------------------------------ +-- Stream with a cross product style monad instance +------------------------------------------------------------------------------ + +-- XXX Nested performs better than the StreamK.Nested when nesting two +-- loops, however, StreamK.Nested seems to be better for more than two nestings, +-- need to do more perf investigation. + +-- | A newtype wrapper for the 'Stream' type with a cross product style monad +-- instance. +-- +-- A 'Monad' bind behaves like a @for@ loop: +-- +-- >>> :{ +-- Stream.fold Fold.toList $ Stream.unNested $ do +-- x <- Stream.Nested $ Stream.fromList [1,2] +-- -- Perform the following actions for each x in the stream +-- return x +-- :} +-- [1,2] +-- +-- Nested monad binds behave like nested @for@ loops: +-- +-- >>> :{ +-- Stream.fold Fold.toList $ Stream.unNested $ do +-- x <- Stream.Nested $ Stream.fromList [1,2] +-- y <- Stream.Nested $ Stream.fromList [3,4] +-- -- Perform the following actions for each x, for each y +-- return (x, y) +-- :} +-- [(1,3),(1,4),(2,3),(2,4)] +-- +newtype Nested m a = Nested {unNested :: Stream m a} + deriving (Functor, Foldable) + +{-# DEPRECATED CrossStream "Use Nested instead." #-} +type CrossStream = Nested + +{-# DEPRECATED mkCross "Use Nested instead." #-} +{-# INLINE mkCross #-} +mkCross :: Stream m a -> Nested m a +mkCross = Nested + +{-# INLINE unCross #-} +unCross :: Nested m a -> Stream m a +unCross = unNested + +-- Pure (Identity monad) stream instances +deriving instance IsList (Nested Identity a) +deriving instance (a ~ Char) => IsString (Nested Identity a) +deriving instance Eq a => Eq (Nested Identity a) +deriving instance Ord a => Ord (Nested Identity a) + +-- Do not use automatic derivation for this to show as "fromList" rather than +-- "fromList Identity". +instance Show a => Show (Nested Identity a) where + {-# INLINE show #-} + show (Nested xs) = show xs + +instance Read a => Read (Nested Identity a) where + {-# INLINE readPrec #-} + readPrec = fmap Nested readPrec + +------------------------------------------------------------------------------ +-- Applicative +------------------------------------------------------------------------------ + +-- Note: we need to define all the typeclass operations because we want to +-- INLINE them. +instance Monad m => Applicative (Nested m) where + {-# INLINE pure #-} + pure x = Nested (fromPure x) + + {-# INLINE (<*>) #-} + (Nested s1) <*> (Nested s2) = + Nested (crossApply s1 s2) + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + + {-# INLINE (*>) #-} + (Nested s1) *> (Nested s2) = + Nested (crossApplySnd s1 s2) + + {-# INLINE (<*) #-} + (Nested s1) <* (Nested s2) = + Nested (crossApplyFst s1 s2) + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + +instance Monad m => Monad (Nested m) where + return = pure + + -- Benchmarks better with StreamD bind and pure: + -- toList, filterAllout, *>, *<, >> (~2x) + -- + + -- Benchmarks better with CPS bind and pure: + -- Prime sieve (25x) + -- n binds, breakAfterSome, filterAllIn, state transformer (~2x) + -- + {-# INLINE (>>=) #-} + (>>=) (Nested m) f = Nested (concatMap (unNested . f) m) + + {-# INLINE (>>) #-} + (>>) = (*>) + +------------------------------------------------------------------------------ +-- Transformers +------------------------------------------------------------------------------ + +instance (MonadIO m) => MonadIO (Nested m) where + liftIO x = Nested (fromEffect $ liftIO x) + +instance MonadTrans Nested where + {-# INLINE lift #-} + lift x = Nested (fromEffect x) + +instance (MonadThrow m) => MonadThrow (Nested m) where + throwM = lift . throwM + +------------------------------------------------------------------------------ +-- Utilities +------------------------------------------------------------------------------ + +-- | Inlined definition. Without the inline "serially/parser/take" benchmark +-- degrades and parseMany does not fuse. Even using "inline" at the callsite +-- does not help. +{-# INLINE splitAt #-} +splitAt :: String -> Int -> [a] -> ([a],[a]) +splitAt desc n ls + | n < 0 = seekOver n + | n == 0 = ([], ls) + | otherwise = splitAt' n ls + + where + + splitAt' :: Int -> [a] -> ([a], [a]) + splitAt' 0 [] = ([], []) + splitAt' m [] = seekUnder n m + splitAt' 1 (x:xs) = ([x], xs) + splitAt' m (x:xs) = (x:xs', xs'') + + where + + (xs', xs'') = splitAt' (m - 1) xs + + seekOver x = + error $ desc ++ ": bug in parser, seeking [" + ++ show (negate x) + ++ "] elements in future" + + seekUnder x y = + error $ desc ++ ": bug in parser, backtracking [" + ++ show x + ++ "] elements. Goes [" + ++ show y + ++ "] elements beyond backtrack buffer" diff --git a/src/Streamly/Internal/Data/Stream/Zip.hs b/src/Streamly/Internal/Data/Stream/Zip.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Zip.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Streamly.Internal.Data.Stream.Zip --- Copyright : (c) 2017 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- To run examples in this module: --- --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Stream as Stream --- >>> import qualified Streamly.Internal.Data.Stream.Zip as Stream --- -module Streamly.Internal.Data.Stream.Zip - ( - ZipStream (..) - , ZipSerialM - , ZipSerial - ) -where - -import Data.Functor.Identity (Identity(..)) -import GHC.Exts (IsList(..), IsString(..)) -import Streamly.Internal.Data.Stream.Type (Stream) -import Text.Read - ( Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec - , readListPrecDefault) - -import qualified Streamly.Internal.Data.Stream.Bottom as Stream -import qualified Streamly.Internal.Data.Stream.Generate as Stream - --- $setup --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Stream as Stream --- >>> import qualified Streamly.Internal.Data.Stream.Zip as Stream - ------------------------------------------------------------------------------- --- Serially Zipping Streams ------------------------------------------------------------------------------- - --- | For 'ZipStream': --- --- @ --- (<>) = 'Streamly.Data.Stream.append' --- (\<*>) = 'Streamly.Data.Stream.zipWith' id --- @ --- --- Applicative evaluates the streams being zipped serially: --- --- >>> s1 = Stream.ZipStream $ Stream.fromFoldable [1, 2] --- >>> s2 = Stream.ZipStream $ Stream.fromFoldable [3, 4] --- >>> s3 = Stream.ZipStream $ Stream.fromFoldable [5, 6] --- >>> s = (,,) <$> s1 <*> s2 <*> s3 --- >>> Stream.fold Fold.toList (Stream.unZipStream s) --- [(1,3,5),(2,4,6)] --- -newtype ZipStream m a = ZipStream {unZipStream :: Stream m a} - deriving (Functor, Semigroup, Monoid) - -deriving instance IsList (ZipStream Identity a) -deriving instance (a ~ Char) => IsString (ZipStream Identity a) -deriving instance Eq a => Eq (ZipStream Identity a) -deriving instance Ord a => Ord (ZipStream Identity a) -deriving instance (Foldable m, Monad m) => Foldable (ZipStream m) -deriving instance Traversable (ZipStream Identity) - -instance Show a => Show (ZipStream Identity a) where - showsPrec p dl = showParen (p > 10) $ - showString "fromList " . shows (toList dl) - -instance Read a => Read (ZipStream Identity a) where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - fromList <$> readPrec - readListPrec = readListPrecDefault - -type ZipSerialM = ZipStream - --- | An IO stream whose applicative instance zips streams serially. --- -type ZipSerial = ZipSerialM IO - -instance Monad m => Applicative (ZipStream m) where - pure = ZipStream . Stream.repeat - - {-# INLINE (<*>) #-} - ZipStream m1 <*> ZipStream m2 = ZipStream $ Stream.zipWith id m1 m2 diff --git a/src/Streamly/Internal/Data/StreamK.hs b/src/Streamly/Internal/Data/StreamK.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/StreamK.hs @@ -0,0 +1,1397 @@ +{-# LANGUAGE CPP #-} +{- HLINT ignore "Eta reduce" -} +-- | +-- Module : Streamly.Internal.Data.StreamK +-- Copyright : (c) 2017 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.StreamK + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + module Streamly.Internal.Data.StreamK.Type + -- * Transformer + , module Streamly.Internal.Data.StreamK.Transformer + + -- * From containers + , fromStream + + -- * Specialized Generation + , repeatM + , replicate + , replicateM + , fromIndices + , fromIndicesM + , iterate + , iterateM + + -- * Elimination + -- ** General Folds + , foldr1 + , fold + , foldBreak + , foldEither + , foldConcat + , ParserK.toParserK -- XXX move the code to this module + , parseDBreak + , parseD + , parseBreak + , parseBreakPos + , parse + , parsePos + + -- ** Specialized Folds + , head + , elem + , notElem + , all + , any + , last + , minimum + , minimumBy + , maximum + , maximumBy + , findIndices + , lookup + , findM + , find + , (!!) + + -- ** To Containers + , toList + , toStream + + -- ** Map and Fold + , mapM_ + + -- * Transformation + -- ** By folding (scans) + , scanl' + , scanlx' + + -- ** Filtering + , filter + , take + , takeWhile + , drop + , dropWhile + + -- ** Mapping + , mapM + , sequence + + -- ** Inserting + , intersperseM + , intersperse + , insertBy + + -- ** Deleting + , deleteBy + + -- ** Reordering + , sortBy + , sortOn + + -- ** Map and Filter + , mapMaybe + + -- ** Zipping + , zipWith + , zipWithM + + -- ** Merging + , mergeBy + , mergeByM + + -- ** Transformation comprehensions + , the + + -- ** Transforming Inner Monad + , morphInner + + -- * Exceptions + , handle + + -- * Resource Management + , bracketIO + + -- * Deprecated + , hoist + , parseBreakChunks + , parseChunks + , parseBreakChunksGeneric + , parseChunksGeneric + ) +where + +#include "ArrayMacros.h" +#include "inline.hs" +#include "assert.hs" +#include "deprecation.h" + +import Control.Exception (mask_, Exception) +import Control.Monad (void, join) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Ord (comparing) +import GHC.Types (SPEC(..)) +import Streamly.Internal.Data.Array.Type (Array(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.IOFinalizer (newIOFinalizer, runIOFinalizer) +import Streamly.Internal.Data.ParserK.Type (ParserK) +import Streamly.Internal.Data.Producer.Type (Producer(..)) +import Streamly.Internal.Data.SVar.Type (adaptState, defState) +import Streamly.Internal.Data.Unbox (Unbox) + +import qualified Control.Monad.Catch as MC +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.Array.Generic as GenArr +import qualified Streamly.Internal.Data.Fold.Type as FL +import qualified Streamly.Internal.Data.Parser as Parser +import qualified Streamly.Internal.Data.ParserDrivers as Drivers +import qualified Streamly.Internal.Data.Parser.Type as PR +import qualified Streamly.Internal.Data.ParserK.Type as ParserK +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Prelude + +import Prelude + hiding (Foldable(..), last, map, mapM, mapM_, repeat, sequence, + take, filter, all, any, takeWhile, drop, dropWhile, + notElem, head, tail, init, zipWith, lookup, + (!!), replicate, reverse, concatMap, iterate, splitAt) +import Data.Foldable (length) +import Streamly.Internal.Data.StreamK.Type +import Streamly.Internal.Data.StreamK.Transformer +import Streamly.Internal.Data.Parser (ParseError(..), ParseErrorPos(..)) + +#include "DocTestDataStreamK.hs" + +-- | Convert a fused 'Stream' to 'StreamK'. +-- +-- For example: +-- +-- >>> s1 = StreamK.fromStream $ Stream.fromList [1,2] +-- >>> s2 = StreamK.fromStream $ Stream.fromList [3,4] +-- >>> Stream.fold Fold.toList $ StreamK.toStream $ s1 `StreamK.append` s2 +-- [1,2,3,4] +-- +{-# INLINE fromStream #-} +fromStream :: Monad m => Stream.Stream m a -> StreamK m a +fromStream = Stream.toStreamK + +-- | Convert a 'StreamK' to a fused 'Stream'. +-- +{-# INLINE toStream #-} +toStream :: Applicative m => StreamK m a -> Stream.Stream m a +toStream = Stream.fromStreamK + +------------------------------------------------------------------------------- +-- Generation +------------------------------------------------------------------------------- + +{- +-- Generalization of concurrent streams/SVar via unfoldr. +-- +-- Unfold a value into monadic actions and then run the resulting monadic +-- actions to generate a stream. Since the step of generating the monadic +-- action and running them are decoupled we can run the monadic actions +-- cooncurrently. For example, the seed could be a list of monadic actions or a +-- pure stream of monadic actions. +-- +-- We can have different flavors of this depending on the stream type t. The +-- concurrent version could be async or ahead etc. Depending on how we queue +-- back the feedback portion b, it could be DFS or BFS style. +-- +unfoldrA :: (b -> Maybe (m a, b)) -> b -> StreamK m a +unfoldrA = undefined +-} + +------------------------------------------------------------------------------- +-- Special generation +------------------------------------------------------------------------------- + +-- | +-- >>> repeatM = StreamK.sequence . StreamK.repeat +-- >>> repeatM = fix . StreamK.consM +-- >>> repeatM = cycle1 . StreamK.fromEffect +-- +-- Generate a stream by repeatedly executing a monadic action forever. +-- +-- >>> :{ +-- repeatAction = +-- StreamK.repeatM (threadDelay 1000000 >> print 1) +-- & StreamK.take 10 +-- & StreamK.fold Fold.drain +-- :} +-- +repeatM :: Monad m => m a -> StreamK m a +repeatM = repeatMWith consM + +{-# INLINE replicateM #-} +replicateM :: Monad m => Int -> m a -> StreamK m a +replicateM = replicateMWith consM +{-# INLINE replicate #-} +replicate :: Int -> a -> StreamK m a +replicate n a = go n + where + go cnt = if cnt <= 0 then nil else a `cons` go (cnt - 1) + +{-# INLINE fromIndicesM #-} +fromIndicesM :: Monad m => (Int -> m a) -> StreamK m a +fromIndicesM = fromIndicesMWith consM +{-# INLINE fromIndices #-} +fromIndices :: (Int -> a) -> StreamK m a +fromIndices gen = go 0 + where + go n = gen n `cons` go (n + 1) + +-- | +-- >>> iterate f x = x `StreamK.cons` iterate f x +-- +-- Generate an infinite stream with @x@ as the first element and each +-- successive element derived by applying the function @f@ on the previous +-- element. +-- +-- >>> StreamK.toList $ StreamK.take 5 $ StreamK.iterate (+1) 1 +-- [1,2,3,4,5] +-- +{-# INLINE iterate #-} +iterate :: (a -> a) -> a -> StreamK m a +iterate step = go + where + go !s = cons s (go (step s)) + +-- | +-- >>> iterateM f m = m >>= \a -> return a `StreamK.consM` iterateM f (f a) +-- +-- Generate an infinite stream with the first element generated by the action +-- @m@ and each successive element derived by applying the monadic function +-- @f@ on the previous element. +-- +-- >>> :{ +-- StreamK.iterateM (\x -> print x >> return (x + 1)) (return 0) +-- & StreamK.take 3 +-- & StreamK.toList +-- :} +-- 0 +-- 1 +-- [0,1,2] +-- +{-# INLINE iterateM #-} +iterateM :: Monad m => (a -> m a) -> m a -> StreamK m a +iterateM = iterateMWith consM + +------------------------------------------------------------------------------- +-- Elimination by Folding +------------------------------------------------------------------------------- + +{-# INLINE foldr1 #-} +foldr1 :: Monad m => (a -> a -> a) -> StreamK m a -> m (Maybe a) +foldr1 step m = do + r <- uncons m + case r of + Nothing -> return Nothing + Just (h, t) -> fmap Just (go h t) + where + go p m1 = + let stp = return p + single a = return $ step a p + yieldk a r = fmap (step p) (go a r) + in foldStream defState yieldk single stp m1 + +-- | Fold a stream using the supplied left 'Fold' and reducing the resulting +-- expression strictly at each step. The behavior is similar to 'foldl''. A +-- 'Fold' can terminate early without consuming the full stream. See the +-- documentation of individual 'Fold's for termination behavior. +-- +-- Definitions: +-- +-- >>> fold f = fmap fst . StreamK.foldBreak f +-- >>> fold f = StreamK.parseD (Parser.fromFold f) +-- +-- Example: +-- +-- >>> StreamK.fold Fold.sum $ StreamK.fromStream $ Stream.enumerateFromTo 1 100 +-- 5050 +-- +{-# INLINABLE fold #-} +fold :: Monad m => FL.Fold m a b -> StreamK m a -> m b +fold (FL.Fold step begin _ final) m = do + res <- begin + case res of + FL.Partial fs -> go fs m + FL.Done fb -> return fb + + where + go !acc m1 = + let stop = final acc + single a = step acc a + >>= \case + FL.Partial s -> final s + FL.Done b1 -> return b1 + yieldk a r = step acc a + >>= \case + FL.Partial s -> go s r + FL.Done b1 -> return b1 + in foldStream defState yieldk single stop m1 + +-- | Fold resulting in either breaking the stream or continuation of the fold. +-- Instead of supplying the input stream in one go we can run the fold multiple +-- times, each time supplying the next segment of the input stream. If the fold +-- has not yet finished it returns a fold that can be run again otherwise it +-- returns the fold result and the residual stream. +-- +-- /Internal/ +{-# INLINE foldEither #-} +foldEither :: Monad m => + Fold m a b -> StreamK m a -> m (Either (Fold m a b) (b, StreamK m a)) +foldEither (FL.Fold step begin done final) m = do + res <- begin + case res of + FL.Partial fs -> go fs m + FL.Done fb -> return $ Right (fb, m) + + where + + go !acc m1 = + let stop = + let f = Fold step (return $ FL.Partial acc) done final + in return $ Left f + single a = + step acc a + >>= \case + FL.Partial s -> + let f = Fold step (return $ FL.Partial s) done final + in return $ Left f + FL.Done b1 -> return $ Right (b1, nil) + yieldk a r = + step acc a + >>= \case + FL.Partial s -> go s r + FL.Done b1 -> return $ Right (b1, r) + in foldStream defState yieldk single stop m1 + +-- | Like 'fold' but also returns the remaining stream. The resulting stream +-- would be 'StreamK.nil' if the stream finished before the fold. +-- +{-# INLINE foldBreak #-} +foldBreak :: Monad m => Fold m a b -> StreamK m a -> m (b, StreamK m a) +foldBreak fld strm = do + r <- foldEither fld strm + case r of + Right res -> return res + Left (Fold _ initial _ final) -> do + res <- initial + case res of + FL.Done _ -> error "foldBreak: unreachable state" + FL.Partial s -> do + b <- final s + return (b, nil) + +-- XXX Array folds can be implemented using this. +-- foldContainers? Specialized to foldArrays. + +-- | Generate streams from individual elements of a stream and fold the +-- concatenation of those streams using the supplied fold. Return the result of +-- the fold and residual stream. +-- +-- For example, this can be used to efficiently fold an Array Word8 stream +-- using Word8 folds. +-- +-- /Internal/ +{-# INLINE foldConcat #-} +foldConcat :: Monad m => + Producer m a b -> Fold m b c -> StreamK m a -> m (c, StreamK m a) +foldConcat + (Producer pstep pinject pextract) + (Fold fstep begin _ final) + stream = do + + res <- begin + case res of + FL.Partial fs -> go fs stream + FL.Done fb -> return (fb, stream) + + where + + go !acc m1 = do + let stop = do + r <- final acc + return (r, nil) + single a = do + st <- pinject a + res <- go1 SPEC acc st + case res of + Left fs -> do + r <- final fs + return (r, nil) + Right (b, s) -> do + x <- pextract s + return (b, fromPure x) + yieldk a r = do + st <- pinject a + res <- go1 SPEC acc st + case res of + Left fs -> go fs r + Right (b, s) -> do + x <- pextract s + return (b, x `cons` r) + in foldStream defState yieldk single stop m1 + + {-# INLINE go1 #-} + go1 !_ !fs st = do + r <- pstep st + case r of + Stream.Yield x s -> do + res <- fstep fs x + case res of + FL.Done b -> return $ Right (b, s) + FL.Partial fs1 -> go1 SPEC fs1 s + Stream.Skip s -> go1 SPEC fs s + Stream.Stop -> return $ Left fs + +------------------------------------------------------------------------------ +-- Specialized folds +------------------------------------------------------------------------------ + +{-# INLINE head #-} +head :: Monad m => StreamK m a -> m (Maybe a) +-- head = foldrM (\x _ -> return $ Just x) (return Nothing) +head m = + let stop = return Nothing + single a = return (Just a) + yieldk a _ = return (Just a) + in foldStream defState yieldk single stop m + +{-# INLINE elem #-} +elem :: (Monad m, Eq a) => a -> StreamK m a -> m Bool +elem e = go + where + go m1 = + let stop = return False + single a = return (a == e) + yieldk a r = if a == e then return True else go r + in foldStream defState yieldk single stop m1 + +{-# INLINE notElem #-} +notElem :: (Monad m, Eq a) => a -> StreamK m a -> m Bool +notElem e = go + where + go m1 = + let stop = return True + single a = return (a /= e) + yieldk a r = if a == e then return False else go r + in foldStream defState yieldk single stop m1 + +{-# INLINABLE all #-} +all :: Monad m => (a -> Bool) -> StreamK m a -> m Bool +all p = go + where + go m1 = + let single a | p a = return True + | otherwise = return False + yieldk a r | p a = go r + | otherwise = return False + in foldStream defState yieldk single (return True) m1 + +{-# INLINABLE any #-} +any :: Monad m => (a -> Bool) -> StreamK m a -> m Bool +any p = go + where + go m1 = + let single a | p a = return True + | otherwise = return False + yieldk a r | p a = return True + | otherwise = go r + in foldStream defState yieldk single (return False) m1 + +-- | Extract the last element of the stream, if any. +{-# INLINE last #-} +last :: Monad m => StreamK m a -> m (Maybe a) +last = foldlx' (\_ y -> Just y) Nothing id + +{-# INLINE minimum #-} +minimum :: (Monad m, Ord a) => StreamK m a -> m (Maybe a) +minimum = go Nothing + where + go Nothing m1 = + let stop = return Nothing + single a = return (Just a) + yieldk a r = go (Just a) r + in foldStream defState yieldk single stop m1 + + go (Just res) m1 = + let stop = return (Just res) + single a = + if res <= a + then return (Just res) + else return (Just a) + yieldk a r = + if res <= a + then go (Just res) r + else go (Just a) r + in foldStream defState yieldk single stop m1 + +{-# INLINE minimumBy #-} +minimumBy + :: (Monad m) + => (a -> a -> Ordering) -> StreamK m a -> m (Maybe a) +minimumBy cmp = go Nothing + where + go Nothing m1 = + let stop = return Nothing + single a = return (Just a) + yieldk a r = go (Just a) r + in foldStream defState yieldk single stop m1 + + go (Just res) m1 = + let stop = return (Just res) + single a = case cmp res a of + GT -> return (Just a) + _ -> return (Just res) + yieldk a r = case cmp res a of + GT -> go (Just a) r + _ -> go (Just res) r + in foldStream defState yieldk single stop m1 + +{-# INLINE maximum #-} +maximum :: (Monad m, Ord a) => StreamK m a -> m (Maybe a) +maximum = go Nothing + where + go Nothing m1 = + let stop = return Nothing + single a = return (Just a) + yieldk a r = go (Just a) r + in foldStream defState yieldk single stop m1 + + go (Just res) m1 = + let stop = return (Just res) + single a = + if res <= a + then return (Just a) + else return (Just res) + yieldk a r = + if res <= a + then go (Just a) r + else go (Just res) r + in foldStream defState yieldk single stop m1 + +{-# INLINE maximumBy #-} +maximumBy :: Monad m => (a -> a -> Ordering) -> StreamK m a -> m (Maybe a) +maximumBy cmp = go Nothing + where + go Nothing m1 = + let stop = return Nothing + single a = return (Just a) + yieldk a r = go (Just a) r + in foldStream defState yieldk single stop m1 + + go (Just res) m1 = + let stop = return (Just res) + single a = case cmp res a of + GT -> return (Just res) + _ -> return (Just a) + yieldk a r = case cmp res a of + GT -> go (Just res) r + _ -> go (Just a) r + in foldStream defState yieldk single stop m1 + +{-# INLINE (!!) #-} +(!!) :: Monad m => StreamK m a -> Int -> m (Maybe a) +m !! i = go i m + where + go n m1 = + let single a | n == 0 = return $ Just a + | otherwise = return Nothing + yieldk a x | n < 0 = return Nothing + | n == 0 = return $ Just a + | otherwise = go (n - 1) x + in foldStream defState yieldk single (return Nothing) m1 + +{-# INLINE lookup #-} +lookup :: (Monad m, Eq a) => a -> StreamK m (a, b) -> m (Maybe b) +lookup e = go + where + go m1 = + let single (a, b) | a == e = return $ Just b + | otherwise = return Nothing + yieldk (a, b) x | a == e = return $ Just b + | otherwise = go x + in foldStream defState yieldk single (return Nothing) m1 + +{-# INLINE findM #-} +findM :: Monad m => (a -> m Bool) -> StreamK m a -> m (Maybe a) +findM p = go + where + go m1 = + let single a = do + b <- p a + if b then return $ Just a else return Nothing + yieldk a x = do + b <- p a + if b then return $ Just a else go x + in foldStream defState yieldk single (return Nothing) m1 + +{-# INLINE find #-} +find :: Monad m => (a -> Bool) -> StreamK m a -> m (Maybe a) +find p = findM (return . p) + +{-# INLINE findIndices #-} +findIndices :: (a -> Bool) -> StreamK m a -> StreamK m Int +findIndices p = go 0 + where + go offset m1 = mkStream $ \st yld sng stp -> + let single a | p a = sng offset + | otherwise = stp + yieldk a x | p a = yld offset $ go (offset + 1) x + | otherwise = foldStream (adaptState st) yld sng stp $ + go (offset + 1) x + in foldStream (adaptState st) yieldk single stp m1 + +------------------------------------------------------------------------------ +-- Map and Fold +------------------------------------------------------------------------------ + +-- | Apply a monadic action to each element of the stream and discard the +-- output of the action. +{-# INLINE mapM_ #-} +mapM_ :: Monad m => (a -> m b) -> StreamK m a -> m () +mapM_ f = go + where + go m1 = + let stop = return () + single a = void (f a) + yieldk a r = f a >> go r + in foldStream defState yieldk single stop m1 + +{-# INLINE mapM #-} +mapM :: Monad m => (a -> m b) -> StreamK m a -> StreamK m b +mapM = mapMWith consM + +------------------------------------------------------------------------------ +-- Converting folds +------------------------------------------------------------------------------ + +{-# INLINABLE toList #-} +toList :: Monad m => StreamK m a -> m [a] +toList = foldr (:) [] + +-- Based on suggestions by David Feuer and Pranay Sashank +{-# INLINE morphInner #-} +morphInner, hoist :: (Monad m, Monad n) + => (forall x. m x -> n x) -> StreamK m a -> StreamK n a +morphInner f str = + mkStream $ \st yld sng stp -> + let single = return . sng + yieldk a s = return $ yld a (hoist f s) + stop = return stp + state = adaptState st + in join . f $ foldStreamShared state yieldk single stop str +RENAME(hoist,morphInner) + +------------------------------------------------------------------------------- +-- Transformation by folding (Scans) +------------------------------------------------------------------------------- + +{-# INLINE scanlx' #-} +scanlx' :: (x -> a -> x) -> x -> (x -> b) -> StreamK m a -> StreamK m b +scanlx' step begin done m = + cons (done begin) $ go m begin + where + go m1 !acc = mkStream $ \st yld sng stp -> + let single a = sng (done $ step acc a) + yieldk a r = + let s = step acc a + in yld (done s) (go r s) + in foldStream (adaptState st) yieldk single stp m1 + +{-# INLINE scanl' #-} +scanl' :: (b -> a -> b) -> b -> StreamK m a -> StreamK m b +scanl' step begin = scanlx' step begin id + +------------------------------------------------------------------------------- +-- Filtering +------------------------------------------------------------------------------- + +{-# INLINE filter #-} +filter :: (a -> Bool) -> StreamK m a -> StreamK m a +filter p = go + where + go m1 = mkStream $ \st yld sng stp -> + let single a | p a = sng a + | otherwise = stp + yieldk a r | p a = yld a (go r) + | otherwise = foldStream st yieldk single stp r + in foldStream st yieldk single stp m1 + +{-# INLINE take #-} +take :: Int -> StreamK m a -> StreamK m a +take = go + where + go n1 m1 = mkStream $ \st yld sng stp -> + let yieldk a r = yld a (go (n1 - 1) r) + in if n1 <= 0 + then stp + else foldStream st yieldk sng stp m1 + +{-# INLINE takeWhile #-} +takeWhile :: (a -> Bool) -> StreamK m a -> StreamK m a +takeWhile p = go + where + go m1 = mkStream $ \st yld sng stp -> + let single a | p a = sng a + | otherwise = stp + yieldk a r | p a = yld a (go r) + | otherwise = stp + in foldStream st yieldk single stp m1 + +{-# INLINE drop #-} +drop :: Int -> StreamK m a -> StreamK m a +drop n m = unShare (go n m) + where + go n1 m1 = mkStream $ \st yld sng stp -> + let single _ = stp + yieldk _ r = foldStreamShared st yld sng stp $ go (n1 - 1) r + -- Somehow "<=" check performs better than a ">" + in if n1 <= 0 + then foldStreamShared st yld sng stp m1 + else foldStreamShared st yieldk single stp m1 + +{-# INLINE dropWhile #-} +dropWhile :: (a -> Bool) -> StreamK m a -> StreamK m a +dropWhile p = go + where + go m1 = mkStream $ \st yld sng stp -> + let single a | p a = stp + | otherwise = sng a + yieldk a r | p a = foldStream st yieldk single stp r + | otherwise = yld a r + in foldStream st yieldk single stp m1 + +------------------------------------------------------------------------------- +-- Mapping +------------------------------------------------------------------------------- + +-- Be careful when modifying this, this uses a consM (|:) deliberately to allow +-- other stream types to overload it. +{-# INLINE sequence #-} +sequence :: Monad m => StreamK m (m a) -> StreamK m a +sequence = go + where + go m1 = mkStream $ \st yld sng stp -> + let single ma = ma >>= sng + yieldk ma r = foldStreamShared st yld sng stp $ ma `consM` go r + in foldStream (adaptState st) yieldk single stp m1 + +------------------------------------------------------------------------------- +-- Inserting +------------------------------------------------------------------------------- + +{-# INLINE intersperseM #-} +intersperseM :: Monad m => m a -> StreamK m a -> StreamK m a +intersperseM a = prependingStart + where + prependingStart m1 = mkStream $ \st yld sng stp -> + let yieldk i x = + foldStreamShared st yld sng stp $ return i `consM` go x + in foldStream st yieldk sng stp m1 + go m2 = mkStream $ \st yld sng stp -> + let single i = foldStreamShared st yld sng stp $ a `consM` fromPure i + yieldk i x = + foldStreamShared + st yld sng stp $ a `consM` return i `consM` go x + in foldStream st yieldk single stp m2 + +{-# INLINE intersperse #-} +intersperse :: Monad m => a -> StreamK m a -> StreamK m a +intersperse a = intersperseM (return a) + +{-# INLINE insertBy #-} +insertBy :: (a -> a -> Ordering) -> a -> StreamK m a -> StreamK m a +insertBy cmp x = go + where + go m1 = mkStream $ \st yld _ _ -> + let single a = case cmp x a of + GT -> yld a (fromPure x) + _ -> yld x (fromPure a) + stop = yld x nil + yieldk a r = case cmp x a of + GT -> yld a (go r) + _ -> yld x (a `cons` r) + in foldStream st yieldk single stop m1 + +------------------------------------------------------------------------------ +-- Deleting +------------------------------------------------------------------------------ + +{-# INLINE deleteBy #-} +deleteBy :: (a -> a -> Bool) -> a -> StreamK m a -> StreamK m a +deleteBy eq x = go + where + go m1 = mkStream $ \st yld sng stp -> + let single a = if eq x a then stp else sng a + yieldk a r = if eq x a + then foldStream st yld sng stp r + else yld a (go r) + in foldStream st yieldk single stp m1 + +------------------------------------------------------------------------------- +-- Map and Filter +------------------------------------------------------------------------------- + +{-# INLINE mapMaybe #-} +mapMaybe :: (a -> Maybe b) -> StreamK m a -> StreamK m b +mapMaybe f = go + where + go m1 = mkStream $ \st yld sng stp -> + let single a = maybe stp sng (f a) + yieldk a r = case f a of + Just b -> yld b $ go r + Nothing -> foldStream (adaptState st) yieldk single stp r + in foldStream (adaptState st) yieldk single stp m1 + +------------------------------------------------------------------------------- +-- Exception Handling +------------------------------------------------------------------------------- + +-- | Like Streamly.Data.Stream.'Streamly.Data.Stream.handle' but with one +-- significant difference, this function observes exceptions from the consumer +-- of the stream as well. +-- +-- You can also convert 'StreamK' to 'Stream' and use exception handling from +-- 'Stream' module: +-- +-- >>> handle f s = StreamK.fromStream $ Stream.handle (\e -> StreamK.toStream (f e)) (StreamK.toStream s) +-- +{-# INLINABLE handle #-} +handle :: (MonadCatch m, Exception e) + => (e -> m (StreamK m a)) -> StreamK m a -> StreamK m a +handle f stream = go stream + + where + + go m1 = mkStream $ \st yld sng stp -> + let yieldk a r = yld a $ go r + in do + res <- MC.try (foldStream (adaptState st) yieldk sng stp m1) + case res of + Right r -> return r + Left e -> do + r <- f e + foldStream (adaptState st) yld sng stp r + +------------------------------------------------------------------------------- +-- Resource Management +------------------------------------------------------------------------------- + +-- If we are folding the stream and we do not drain the entire stream (e.g. if +-- the fold terminates before the stream) then the finalizer will run on GC. +-- +-- XXX To implement a prompt cleanup, we will have to yield a cleanup function +-- via the yield continuation. A chain of cleanup functions can be built and +-- the entire chain can be invoked when the stream ends voluntarily or if +-- someone decides to abandon the stream. + +-- | Like Streamly.Data.Stream.'Streamly.Data.Stream.bracketIO' but with one +-- significant difference, this function observes exceptions from the consumer +-- of the stream as well. Therefore, it cleans up the resource promptly when +-- the consumer encounters an exception. +-- +-- You can also convert 'StreamK' to 'Stream' and use resource handling from +-- 'Stream' module: +-- +-- >>> bracketIO bef aft bet = StreamK.fromStream $ Stream.bracketIO bef aft (StreamK.toStream . bet) +-- +{-# INLINABLE bracketIO #-} +bracketIO :: (MonadIO m, MonadCatch m) + => IO b -> (b -> IO c) -> (b -> StreamK m a) -> StreamK m a +bracketIO bef aft bet = + concatEffect $ do + (r, ref) <- liftIO $ mask_ $ do + r <- bef + ref <- newIOFinalizer (aft r) + return (r, ref) + return $ go ref (bet r) + + where + + go ref m1 = mkStream $ \st yld sng stp -> + let + -- We can discard exceptions on continuations to make it equivalent + -- to StreamD, but it seems like a desirable behavior. + stop = liftIO (runIOFinalizer ref) >> stp + single a = liftIO (runIOFinalizer ref) >> sng a + yieldk a r = yld a $ go ref r + in do + -- Do not call the finalizer twice if it has already been + -- called via stop continuation and stop continuation itself + -- generated an exception. runIOFinalizer takes care of that. + res <- MC.try (foldStream (adaptState st) yieldk single stop m1) + case res of + Right r -> return r + Left (e :: MC.SomeException) -> + liftIO (runIOFinalizer ref) >> MC.throwM e + +------------------------------------------------------------------------------ +-- Serial Zipping +------------------------------------------------------------------------------ + +-- | Zipping of @n@ streams can be performed by combining the streams pair +-- wise using 'mergeMapWith' with O(n * log n) time complexity. If used +-- with 'concatMapWith' it will have O(n^2) performance. +{-# INLINE zipWith #-} +zipWith :: Monad m => (a -> b -> c) -> StreamK m a -> StreamK m b -> StreamK m c +zipWith f = zipWithM (\a b -> return (f a b)) + +{-# INLINE zipWithM #-} +zipWithM :: Monad m => + (a -> b -> m c) -> StreamK m a -> StreamK m b -> StreamK m c +zipWithM f = go + + where + + go mx my = mkStream $ \st yld sng stp -> do + let merge a ra = + let single2 b = f a b >>= sng + yield2 b rb = f a b >>= \x -> yld x (go ra rb) + in foldStream (adaptState st) yield2 single2 stp my + let single1 a = merge a nil + yield1 = merge + foldStream (adaptState st) yield1 single1 stp mx + +------------------------------------------------------------------------------ +-- Merging +------------------------------------------------------------------------------ + +{-# INLINE mergeByM #-} +mergeByM :: Monad m => + (a -> a -> m Ordering) -> StreamK m a -> StreamK m a -> StreamK m a +mergeByM cmp = go + + where + + go mx my = mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp my + single x = foldStream st yld sng stp (goX0 x my) + yield x rx = foldStream st yld sng stp (goX x rx my) + foldStream st yield single stop mx + + goX0 x my = mkStream $ \st yld sng _ -> do + let stop = sng x + single y = do + r <- cmp x y + case r of + GT -> yld y (fromPure x) + _ -> yld x (fromPure y) + yield y ry = do + r <- cmp x y + case r of + GT -> yld y (goX0 x ry) + _ -> yld x (y `cons` ry) + in foldStream st yield single stop my + + goX x mx my = mkStream $ \st yld _ _ -> do + let stop = yld x mx + single y = do + r <- cmp x y + case r of + GT -> yld y (x `cons` mx) + _ -> yld x (goY0 mx y) + yield y ry = do + r <- cmp x y + case r of + GT -> yld y (goX x mx ry) + _ -> yld x (goY mx y ry) + in foldStream st yield single stop my + + goY0 mx y = mkStream $ \st yld sng _ -> do + let stop = sng y + single x = do + r <- cmp x y + case r of + GT -> yld y (fromPure x) + _ -> yld x (fromPure y) + yield x rx = do + r <- cmp x y + case r of + GT -> yld y (x `cons` rx) + _ -> yld x (goY0 rx y) + in foldStream st yield single stop mx + + goY mx y my = mkStream $ \st yld _ _ -> do + let stop = yld y my + single x = do + r <- cmp x y + case r of + GT -> yld y (goX0 x my) + _ -> yld x (y `cons` my) + yield x rx = do + r <- cmp x y + case r of + GT -> yld y (goX x rx my) + _ -> yld x (goY rx y my) + in foldStream st yield single stop mx + +-- | Merging of @n@ streams can be performed by combining the streams pair +-- wise using 'mergeMapWith' to give O(n * log n) time complexity. If used +-- with 'concatMapWith' it will have O(n^2) performance. +-- +{-# INLINE mergeBy #-} +mergeBy :: (a -> a -> Ordering) -> StreamK m a -> StreamK m a -> StreamK m a +-- XXX GHC: This has slightly worse performance than replacing "r <- cmp x y" +-- with "let r = cmp x y" in the monadic version. The definition below is +-- exactly the same as mergeByM except this change. +-- mergeBy cmp = mergeByM (\a b -> return $ cmp a b) +mergeBy cmp = go + + where + + go mx my = mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp my + single x = foldStream st yld sng stp (goX0 x my) + yield x rx = foldStream st yld sng stp (goX x rx my) + foldStream st yield single stop mx + + goX0 x my = mkStream $ \st yld sng _ -> do + let stop = sng x + single y = do + case cmp x y of + GT -> yld y (fromPure x) + _ -> yld x (fromPure y) + yield y ry = do + case cmp x y of + GT -> yld y (goX0 x ry) + _ -> yld x (y `cons` ry) + in foldStream st yield single stop my + + goX x mx my = mkStream $ \st yld _ _ -> do + let stop = yld x mx + single y = do + case cmp x y of + GT -> yld y (x `cons` mx) + _ -> yld x (goY0 mx y) + yield y ry = do + case cmp x y of + GT -> yld y (goX x mx ry) + _ -> yld x (goY mx y ry) + in foldStream st yield single stop my + + goY0 mx y = mkStream $ \st yld sng _ -> do + let stop = sng y + single x = do + case cmp x y of + GT -> yld y (fromPure x) + _ -> yld x (fromPure y) + yield x rx = do + case cmp x y of + GT -> yld y (x `cons` rx) + _ -> yld x (goY0 rx y) + in foldStream st yield single stop mx + + goY mx y my = mkStream $ \st yld _ _ -> do + let stop = yld y my + single x = do + case cmp x y of + GT -> yld y (goX0 x my) + _ -> yld x (y `cons` my) + yield x rx = do + case cmp x y of + GT -> yld y (goX x rx my) + _ -> yld x (goY rx y my) + in foldStream st yield single stop mx + +------------------------------------------------------------------------------ +-- Transformation comprehensions +------------------------------------------------------------------------------ + +{-# INLINE the #-} +the :: (Eq a, Monad m) => StreamK m a -> m (Maybe a) +the m = do + r <- uncons m + case r of + Nothing -> return Nothing + Just (h, t) -> go h t + where + go h m1 = + let single a | h == a = return $ Just h + | otherwise = return Nothing + yieldk a r | h == a = go h r + | otherwise = return Nothing + in foldStream defState yieldk single (return $ Just h) m1 + +------------------------------------------------------------------------------ +-- Alternative & MonadPlus +------------------------------------------------------------------------------ + +_alt :: StreamK m a -> StreamK m a -> StreamK m a +_alt m1 m2 = mkStream $ \st yld sng stp -> + let stop = foldStream st yld sng stp m2 + in foldStream st yld sng stop m1 + +------------------------------------------------------------------------------ +-- MonadError +------------------------------------------------------------------------------ + +{- +-- XXX handle and test cross thread state transfer +withCatchError + :: MonadError e m + => StreamK m a -> (e -> StreamK m a) -> StreamK m a +withCatchError m h = + mkStream $ \_ stp sng yld -> + let run x = unStream x Nothing stp sng yieldk + handle r = r `catchError` \e -> run $ h e + yieldk a r = yld a (withCatchError r h) + in handle $ run m +-} + +------------------------------------------------------------------------------- +-- Parsing +------------------------------------------------------------------------------- + +-- | Run a 'Parser' over a stream and return rest of the Stream. +{-# INLINE_NORMAL parseDBreak #-} +parseDBreak + :: Monad m + => PR.Parser a m b + -> StreamK m a + -> m (Either ParseErrorPos b, StreamK m a) +parseDBreak (PR.Parser pstep initial extract) stream = do + res <- initial + case res of + PR.IPartial s -> goStream stream [] s 0 + PR.IDone b -> return (Right b, stream) + PR.IError err -> return (Left (ParseErrorPos 0 err), stream) + + where + + {-# INLINE splitAt #-} + splitAt = Stream.splitAt "Data.StreamK.parseDBreak" + + -- "buf" contains last few items in the stream that we may have to + -- backtrack to. + -- + -- XXX currently we are using a dumb list based approach for backtracking + -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. + -- That will allow us more efficient random back and forth movement. + goStream st buf !pst i = + let stop = do + r <- extract pst + case r of + PR.FError err -> do + let src = Prelude.reverse buf + return (Left (ParseErrorPos i err), fromList src) + PR.FDone m b -> do + let n = (- m) + assertM(n <= length buf) + let src0 = Prelude.take n buf + src = Prelude.reverse src0 + return (Right b, fromList src) + PR.FContinue 0 s -> goStream nil buf s i + PR.FContinue m s -> do + let n = (- m) + assertM(n <= length buf) + let (src0, buf1) = splitAt n buf + src = Prelude.reverse src0 + goBuf nil buf1 src s (i + m) + single x = yieldk x nil + yieldk x r = do + res <- pstep pst x + case res of + PR.SPartial 1 s -> goStream r [] s (i + 1) + PR.SPartial m s -> do + let n = 1 - m + assertM(n <= length (x:buf)) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 + goBuf r [] src s (i + m) + PR.SContinue 1 s -> goStream r (x:buf) s (i + 1) + PR.SContinue m s -> do + let n = 1 - m + assertM(n <= length (x:buf)) + let (src0, buf1) = splitAt n (x:buf) + src = Prelude.reverse src0 + goBuf r buf1 src s (i + m) + PR.SDone 1 b -> return (Right b, r) + PR.SDone m b -> do + let n = 1 - m + assertM(n <= length (x:buf)) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 + return (Right b, append (fromList src) r) + PR.SError err -> do + let src = Prelude.reverse (x:buf) + return (Left (ParseErrorPos (i + 1) err), append (fromList src) r) + in foldStream defState yieldk single stop st + + goBuf st buf [] !pst i = goStream st buf pst i + goBuf st buf (x:xs) !pst i = do + pRes <- pstep pst x + case pRes of + PR.SPartial 1 s -> goBuf st [] xs s (i + 1) + PR.SPartial m s -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 ++ xs + goBuf st [] src s (i + m) + PR.SContinue 1 s -> goBuf st (x:buf) xs s (i + 1) + PR.SContinue m s -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let (src0, buf1) = splitAt n (x:buf) + src = Prelude.reverse src0 ++ xs + goBuf st buf1 src s (i + m) + PR.SDone m b -> do + let n = 1 - m + assert (n <= length (x:buf)) (return ()) + let src0 = Prelude.take n (x:buf) + src = Prelude.reverse src0 ++ xs + return (Right b, append (fromList src) st) + PR.SError err -> do + let src = Prelude.reverse buf ++ x:xs + return (Left (ParseErrorPos (i + 1) err), append (fromList src) st) + +-- Using ParserD or ParserK on StreamK may not make much difference. We should +-- perhaps use only chunked parsing on StreamK. We can always convert a stream +-- to chunks before parsing. Or just have a ParserK element parser for StreamK +-- and convert ParserD to ParserK for element parsing using StreamK. +{-# INLINE parseD #-} +parseD :: Monad m => + Parser.Parser a m b -> StreamK m a -> m (Either ParseErrorPos b) +parseD f = fmap fst . parseDBreak f + +------------------------------------------------------------------------------- +-- ParserK Chunked +------------------------------------------------------------------------------- + +-- XXX parseDBreakChunks may be faster than converting parserD to toParserK and +-- using parseBreakChunks. We can also use parseBreak as an alternative to the +-- monad instance of ParserD. + +-- | Run a 'ParserK' over a chunked 'StreamK' and return the parse result and +-- the remaining Stream. +{-# DEPRECATED parseBreakChunks "Use Streamly.Data.Array.parseBreak instead" #-} +{-# INLINE_NORMAL parseBreakChunks #-} +parseBreakChunks + :: (Monad m, Unbox a) + => ParserK (Array a) m b + -> StreamK m (Array a) + -> m (Either ParseError b, StreamK m (Array a)) +parseBreakChunks = Array.parseBreak + +{-# DEPRECATED parseChunks "Use Streamly.Data.Array.parse instead" #-} +{-# INLINE parseChunks #-} +parseChunks :: (Monad m, Unbox a) => + ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b) +parseChunks = Array.parse + +------------------------------------------------------------------------------- +-- ParserK Singular +------------------------------------------------------------------------------- + +-- | Similar to 'parseBreak' but works on singular elements. +-- +{-# INLINE parseBreak #-} +parseBreak + :: forall m a b. Monad m + => ParserK.ParserK a m b + -> StreamK m a + -> m (Either ParseError b, StreamK m a) +parseBreak = Drivers.parseBreakStreamK + +-- | Like 'parseBreak' but includes stream position information in the error +-- messages. +-- +{-# INLINE parseBreakPos #-} +parseBreakPos + :: forall m a b. Monad m + => ParserK.ParserK a m b + -> StreamK m a + -> m (Either ParseErrorPos b, StreamK m a) +parseBreakPos = Drivers.parseBreakStreamKPos + +-- | Run a 'ParserK' over a 'StreamK'. Please use 'parseChunks' where possible, +-- for better performance. +{-# INLINE parse #-} +parse :: Monad m => + ParserK.ParserK a m b -> StreamK m a -> m (Either ParseError b) +parse f = fmap fst . parseBreak f + +-- | Like 'parse' but includes stream position information in the error +-- messages. +-- +{-# INLINE parsePos #-} +parsePos :: Monad m => + ParserK.ParserK a m b -> StreamK m a -> m (Either ParseErrorPos b) +parsePos f = fmap fst . parseBreakPos f + +------------------------------------------------------------------------------- +-- ParserK Chunked Generic +------------------------------------------------------------------------------- + +-- | Similar to 'parseBreak' but works on generic arrays +-- +{-# DEPRECATED parseBreakChunksGeneric "Use Streamly.Data.Array.Generic.parseBreak" #-} +{-# INLINE_NORMAL parseBreakChunksGeneric #-} +parseBreakChunksGeneric + :: forall m a b. Monad m + => ParserK.ParserK (GenArr.Array a) m b + -> StreamK m (GenArr.Array a) + -> m (Either ParseError b, StreamK m (GenArr.Array a)) +parseBreakChunksGeneric = GenArr.parseBreak + +{-# DEPRECATED parseChunksGeneric "Use Streamly.Data.Array.Generic.parse" #-} +{-# INLINE parseChunksGeneric #-} +parseChunksGeneric :: + (Monad m) + => ParserK.ParserK (GenArr.Array a) m b + -> StreamK m (GenArr.Array a) + -> m (Either ParseError b) +parseChunksGeneric = GenArr.parse + +------------------------------------------------------------------------------- +-- Sorting +------------------------------------------------------------------------------- + +-- | Sort the input stream using a supplied comparison function. +-- +-- Sorting can be achieved by simply: +-- +-- >>> sortBy cmp = StreamK.mergeMapWith (StreamK.mergeBy cmp) StreamK.fromPure +-- +-- However, this combinator uses a parser to first split the input stream into +-- down and up sorted segments and then merges them to optimize sorting when +-- pre-sorted sequences exist in the input stream. +-- +-- /O(n) space/ +-- +{-# INLINE sortBy #-} +sortBy :: Monad m => (a -> a -> Ordering) -> StreamK m a -> StreamK m a +-- sortBy f = Stream.concatPairsWith (Stream.mergeBy f) Stream.fromPure +sortBy cmp = + let p = + Parser.groupByRollingEither + (\x -> (< GT) . cmp x) + FL.toStreamKRev + FL.toStreamK + in mergeMapWith (mergeBy cmp) id + . Stream.toStreamK + . Stream.catRights -- its a non-failing backtracking parser + . Stream.parseMany (fmap (either id id) p) + . Stream.fromStreamK + +{-# INLINE sortOn #-} +sortOn :: (Monad m, Ord b) => (a -> b) -> StreamK m a -> StreamK m a +sortOn f = + fmap snd + . sortBy (comparing fst) + . fmap (\x -> let y = f x in y `seq` (y, x)) diff --git a/src/Streamly/Internal/Data/StreamK/Alt.hs b/src/Streamly/Internal/Data/StreamK/Alt.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/StreamK/Alt.hs @@ -0,0 +1,244 @@ +-- | +-- Module : Streamly.StreamDK.Type +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A CPS style stream using a constructor based representation instead of a +-- function based representation. +-- +-- Streamly internally uses two fundamental stream representations, (1) streams +-- with an open or arbitrary control flow (we call it StreamK), (2) streams +-- with a structured or closed loop control flow (we call it StreamD). The +-- higher level stream types can use any of these representations under the +-- hood and can interconvert between the two. +-- +-- StreamD: +-- +-- StreamD is a non-recursive data type in which the state of the stream and +-- the step function are separate. When the step function is called, a stream +-- element and the new stream state is yielded. The generated element and the +-- state are passed to the next consumer in the loop. The state is threaded +-- around in the loop until control returns back to the original step function +-- to run the next step. This creates a structured closed loop representation +-- (like "for" loops in C) with state of each step being hidden/abstracted or +-- existential within that step. This creates a loop representation identical +-- to the "for" or "while" loop constructs in imperative languages, the states +-- of the steps combined together constitute the state of the loop iteration. +-- +-- Internally most combinators use a closed loop representation because it +-- provides very high efficiency due to stream fusion. The performance of this +-- representation is competitive to the C language implementations. +-- +-- Pros and Cons of StreamD: +-- +-- 1) stream-fusion: This representation can be optimized very efficiently by +-- the compiler because the state is explicitly separated from step functions, +-- represented using pure data constructors and visible to the compiler, the +-- stream steps can be fused using case-of-case transformations and the state +-- can be specialized using spec-constructor optimization, yielding a C like +-- tight loop/state machine with no constructors, the state is used unboxed and +-- therefore no unnecessary allocation. +-- +-- 2) Because of a closed representation consing too many elements in this type +-- of stream does not scale, it will have quadratic performance slowdown. Each +-- cons creates a layer that needs to return the control back to the caller. +-- Another implementation of cons is possible but that will have to box/unbox +-- the state and will not fuse. So effectively cons breaks fusion. +-- +-- 3) unconsing an item from the stream breaks fusion, we have to "pause" the +-- loop, rebox and save the state. +-- +-- 3) Exception handling is easy to implement in this model because control +-- flow is structured in the loop and cannot be arbitrary. Therefore, +-- implementing "bracket" is natural. +-- +-- 4) Round-robin scheduling for co-operative multitasking is easy to implement. +-- +-- 5) It fuses well with the direct style Fold implementation. +-- +-- StreamK/StreamDK: +-- +-- StreamDK i.e. the stream defined in this module, like StreamK, is a +-- recursive data type which has no explicit state defined using constructors, +-- each step yields an element and a computation representing the rest of the +-- stream. Stream state is part of the function representing the rest of the +-- stream. This creates an open computation representation, or essentially a +-- continuation passing style computation. After the stream step is executed, +-- the caller is free to consume the produced element and then send the control +-- wherever it wants, there is no restriction on the control to return back +-- somewhere, the control is free to go anywhere. The caller may decide not to +-- consume the rest of the stream. This representation is more like a "goto" +-- based implementation in imperative languages. +-- +-- Pros and Cons of StreamK: +-- +-- 1) The way StreamD can be optimized using stream-fusion, this type can be +-- optimized using foldr/build fusion. However, foldr/build has not yet been +-- fully implemented for StreamK/StreamDK. +-- +-- 2) Using cons is natural in this representation, unlike in StreamD it does +-- not have a quadratic slowdown. Currently, we in fact wrap StreamD in StreamK +-- to support a better cons operation. +-- +-- 3) Similarly, uncons is natural in this representation. +-- +-- 4) Exception handling is not easy to implement because of the "goto" nature +-- of CPS. +-- +-- 5) Composable folds are not implemented/proven, however, intuition says that +-- a push style CPS representation should be able to be used along with StreamK +-- to efficiently implement composable folds. + +module Streamly.Internal.Data.StreamK.Alt + ( + -- * Stream Type + + Stream + , Step (..) + + -- * Construction + , nil + , cons + , consM + , unfoldr + , unfoldrM + , replicateM + + -- * Folding + , uncons + , foldrS + + -- * Specific Folds + , drain + ) +where + +#include "inline.hs" + +-- XXX Use Cons and Nil instead of Yield and Stop? +data Step m a = Yield a (Stream m a) | Stop + +newtype Stream m a = Stream (m (Step m a)) + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +nil :: Monad m => Stream m a +nil = Stream $ return Stop + +{-# INLINE_NORMAL cons #-} +cons :: Monad m => a -> Stream m a -> Stream m a +cons x xs = Stream $ return $ Yield x xs + +consM :: Monad m => m a -> Stream m a -> Stream m a +consM eff xs = Stream $ eff >>= \x -> return $ Yield x xs + +unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a +unfoldrM next state = Stream (step' state) + where + step' st = do + r <- next st + return $ case r of + Just (x, s) -> Yield x (Stream (step' s)) + Nothing -> Stop +{- +unfoldrM next s0 = buildM $ \yld stp -> + let go s = do + r <- next s + case r of + Just (a, b) -> yld a (go b) + Nothing -> stp + in go s0 +-} + +{-# INLINE unfoldr #-} +unfoldr :: Monad m => (b -> Maybe (a, b)) -> b -> Stream m a +unfoldr next s0 = build $ \yld stp -> + let go s = + case next s of + Just (a, b) -> yld a (go b) + Nothing -> stp + in go s0 + +replicateM :: Monad m => Int -> a -> Stream m a +replicateM n x = Stream (step n) + where + step i = return $ + if i <= 0 + then Stop + else Yield x (Stream (step (i - 1))) + +------------------------------------------------------------------------------- +-- Folding +------------------------------------------------------------------------------- + +uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a)) +uncons (Stream step) = do + r <- step + return $ case r of + Yield x xs -> Just (x, xs) + Stop -> Nothing + +-- | Lazy right associative fold to a stream. +{-# INLINE_NORMAL foldrS #-} +foldrS :: Monad m + => (a -> Stream m b -> Stream m b) + -> Stream m b + -> Stream m a + -> Stream m b +foldrS f streamb = go + where + go (Stream stepa) = Stream $ do + r <- stepa + case r of + Yield x xs -> let Stream step = f x (go xs) in step + Stop -> let Stream step = streamb in step + +{-# INLINE_LATE foldrM #-} +foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b +foldrM fstep acc = go + where + go (Stream step) = do + r <- step + case r of + Yield x xs -> fstep x (go xs) + Stop -> acc + +{-# INLINE_NORMAL build #-} +build :: Monad m + => forall a. (forall b. (a -> b -> b) -> b -> b) -> Stream m a +build g = g cons nil + +{-# RULES +"foldrM/build" forall k z (g :: forall b. (a -> b -> b) -> b -> b). + foldrM k z (build g) = g k z #-} + +{- +-- To fuse foldrM with unfoldrM we need the type m1 to be polymorphic such that +-- it is either Monad m or Stream m. So that we can use cons/nil as well as +-- monadic construction function as its arguments. +-- +{-# INLINE_NORMAL buildM #-} +buildM :: Monad m + => forall a. (forall b. (a -> m1 b -> m1 b) -> m1 b -> m1 b) -> Stream m a +buildM g = g cons nil +-} + +------------------------------------------------------------------------------- +-- Specific folds +------------------------------------------------------------------------------- + +{-# INLINE drain #-} +drain :: Monad m => Stream m a -> m () +drain = foldrM (\_ xs -> xs) (return ()) +{- +drain (Stream step) = do + r <- step + case r of + Yield _ next -> drain next + Stop -> return () + -} diff --git a/src/Streamly/Internal/Data/StreamK/Transformer.hs b/src/Streamly/Internal/Data/StreamK/Transformer.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/StreamK/Transformer.hs @@ -0,0 +1,91 @@ +-- | +-- Module : Streamly.Internal.Data.StreamK.Transformer +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.StreamK.Transformer + ( + foldlT + , foldrT + + , liftInner + , evalStateT + + , localReaderT + ) +where + +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.State.Strict (StateT) +import Streamly.Internal.Data.StreamK.Type + (StreamK(..), nil, cons, uncons, concatEffect, foldStream, mkStream) +import Control.Monad.Trans.Reader (ReaderT, local) + +import qualified Control.Monad.Trans.State.Strict as State + +-- | Lazy left fold to an arbitrary transformer monad. +{-# INLINE foldlT #-} +foldlT :: (Monad m, Monad (s m), MonadTrans s) + => (s m b -> a -> s m b) -> s m b -> StreamK m a -> s m b +foldlT step = go + where + go acc m1 = do + res <- lift $ uncons m1 + case res of + Just (h, t) -> go (step acc h) t + Nothing -> acc + +-- | Right associative fold to an arbitrary transformer monad. +{-# INLINE foldrT #-} +foldrT :: (Monad m, Monad (s m), MonadTrans s) + => (a -> s m b -> s m b) -> s m b -> StreamK m a -> s m b +foldrT step final = go + where + go m1 = do + res <- lift $ uncons m1 + case res of + Just (h, t) -> step h (go t) + Nothing -> final + +------------------------------------------------------------------------------ +-- Lifting inner monad +------------------------------------------------------------------------------ + +{-# INLINE evalStateT #-} +evalStateT :: Monad m => m s -> StreamK (StateT s m) a -> StreamK m a +evalStateT = go + + where + + go st m1 = concatEffect $ fmap f (st >>= State.runStateT (uncons m1)) + + f (res, s1) = + case res of + Just (h, t) -> cons h (go (return s1) t) + Nothing -> nil + +{-# INLINE liftInner #-} +liftInner :: (Monad m, MonadTrans t, Monad (t m)) => + StreamK m a -> StreamK (t m) a +liftInner = go + + where + + go m1 = concatEffect $ fmap f $ lift $ uncons m1 + + f res = + case res of + Just (h, t) -> cons h (go t) + Nothing -> nil + +-- | Modify the environment of the underlying ReaderT monad. +{-# INLINABLE localReaderT #-} +localReaderT :: (r -> r) -> StreamK (ReaderT r m) a -> StreamK (ReaderT r m) a +localReaderT f m = + mkStream $ \st yld sng stp -> + let single = local f . sng + yieldk a r = local f $ yld a (localReaderT f r) + in foldStream st yieldk single (local f stp) m diff --git a/src/Streamly/Internal/Data/StreamK/Type.hs b/src/Streamly/Internal/Data/StreamK/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/StreamK/Type.hs @@ -0,0 +1,3126 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Streamly.Internal.Data.StreamK.Type +-- Copyright : (c) 2017 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +-- Continuation passing style (CPS) stream implementation. The symbol 'K' below +-- denotes a function as well as a Kontinuation. +-- +module Streamly.Internal.Data.StreamK.Type + ( + -- * StreamK type + Stream + , StreamK (..) + + -- * Nested type wrapper + , Nested(..) + , FairNested(..) -- experimental, do not release, associativity issues + + -- * foldr/build Fusion + , mkStream + , foldStream + , foldStreamShared + , foldrM + , foldrS + , foldrSShared + , foldrSM + , build + , buildS + , buildM + , buildSM + , augmentS + , augmentSM + , unShare + + -- * Construction + -- ** Primitives + , fromStopK + , fromYieldK + , consK + , cons + , (.:) + , consM + , consMBy + , nil + , nilM + + -- ** Unfolding + , unfoldr + , unfoldrMWith + , unfoldrM + + -- ** From Values + , fromEffect + , fromPure + , repeat + , repeatMWith + , replicateMWith + + -- ** From Indices + , fromIndicesMWith + + -- ** Iteration + , iterateMWith + + -- ** From Containers + , fromFoldable + , fromFoldableM + , Streamly.Internal.Data.StreamK.Type.fromList + + -- ** Cyclic + , mfix + + -- * Elimination + -- ** Primitives + , uncons + + -- ** Strict Left Folds + , Streamly.Internal.Data.StreamK.Type.foldl' + , foldlx' + , foldlMx' + , foldlM' + + -- ** Lazy Right Folds + , Streamly.Internal.Data.StreamK.Type.foldr + + -- ** Specific Folds + , drain + , null + , headNonEmpty + , tail + , tailNonEmpty + , init + , initNonEmpty + + -- * Mapping + , map + , mapMWith + , mapMSerial + , mapMAccum + + -- * Combining Two Streams + -- ** Appending + , conjoin + , append + + -- ** Interleave + , interleave + , interleaveEndBy' + , interleaveSepBy + + -- ** Cross Product + , crossApplyWith + , crossApply + , crossApplySnd + , crossApplyFst + , crossWith + , cross + + -- * Concat + + -- ** Concat Effects + , before + , concatEffect + , concatMapEffect + + -- ** ConcatMap + , concatMapWith + , concatMap + , bfsConcatMap + , fairConcatMap + , concatMapMAccum + + -- ** concatFor (bind) + , concatFor + , bfsConcatFor + , fairConcatFor + , concatForWith + + -- ** concatForM + , concatForM + , bfsConcatForM + , fairConcatForM + , concatForWithM + + -- ** Iterated concat + , concatIterateWith + , concatIterateLeftsWith + , concatIterateScanWith + + -- * Merge + , mergeMapWith + , mergeIterateWith + + -- * Buffered Operations + , foldlS + , reverse + + -- * Deprecated + , interleaveFst + , interleaveMin + , CrossStreamK + , mkCross + , unCross + , bindWith + ) +where + +#include "inline.hs" +#include "deprecation.h" + +import Control.Applicative (Alternative(..)) +import Control.Monad ((>=>), ap, MonadPlus(..)) +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Trans.Class (MonadTrans(lift)) +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Foldable (Foldable(foldl'), fold, foldr) +import Data.Function (fix) +import Data.Functor.Identity (Identity(..)) +#if __GLASGOW_HASKELL__ >= 810 +import Data.Kind (Type) +#endif +import Data.Maybe (fromMaybe) +import Data.Semigroup (Endo(..)) +import GHC.Exts (IsList(..), IsString(..), oneShot, inline) +import Streamly.Internal.BaseCompat ((#.)) +import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) +import Streamly.Internal.Data.SVar.Type (State, adaptState, defState) +import Text.Read + ( Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec + , readListPrecDefault) + +import qualified Control.Monad.Fail as Fail +import qualified Prelude + +import Prelude hiding + (map, mapM, concatMap, foldr, repeat, null, reverse, tail, init) + +#include "DocTestDataStreamK.hs" + +------------------------------------------------------------------------------ +-- Basic stream type +------------------------------------------------------------------------------ + +-- It uses stop, singleton and yield continuations equivalent to the following +-- direct style type: +-- +-- @ +-- data StreamK m a = Stop | Singleton a | Yield a (StreamK m a) +-- @ +-- +-- To facilitate parallel composition we maintain a local state in an 'SVar' +-- that is shared across and is used for synchronization of the streams being +-- composed. +-- +-- The singleton case can be expressed in terms of stop and yield but we have +-- it as a separate case to optimize composition operations for streams with +-- single element. We build singleton streams in the implementation of 'pure' +-- for Applicative and Monad, and in 'lift' for MonadTrans. + +-- XXX can we replace it with a direct style type? With foldr/build fusion. +-- StreamK (m (Maybe (a, StreamK m a))) +-- XXX remove the State param. + +-- | Continuation Passing Style (CPS) version of "Streamly.Data.Stream.Stream". +-- Unlike "Streamly.Data.Stream.Stream", 'StreamK' can be composed recursively +-- without affecting performance. +-- +-- Semigroup instance appends two streams: +-- +-- >>> (<>) = Stream.append +-- +{-# DEPRECATED Stream "Please use StreamK instead." #-} +type Stream = StreamK + +newtype StreamK m a = + MkStream (forall r. + State StreamK m a -- state + -> (a -> StreamK m a -> m r) -- yield + -> (a -> m r) -- singleton + -> m r -- stop + -> m r + ) + +mkStream + :: (forall r. State StreamK m a + -> (a -> StreamK m a -> m r) + -> (a -> m r) + -> m r + -> m r) + -> StreamK m a +mkStream = MkStream + +-- | A terminal function that has no continuation to follow. +#if __GLASGOW_HASKELL__ >= 810 +type StopK :: (Type -> Type) -> Type +#endif +type StopK m = forall r. m r -> m r + +-- | A monadic continuation, it is a function that yields a value of type "a" +-- and calls the argument (a -> m r) as a continuation with that value. We can +-- also think of it as a callback with a handler (a -> m r). Category +-- theorists call it a codensity type, a special type of right kan extension. +#if __GLASGOW_HASKELL__ >= 810 +type YieldK :: (Type -> Type) -> Type -> Type +#endif +type YieldK m a = forall r. (a -> m r) -> m r + +_wrapM :: Monad m => m a -> YieldK m a +_wrapM m = (m >>=) + +-- | Make an empty stream from a stop function. +fromStopK :: StopK m -> StreamK m a +fromStopK k = mkStream $ \_ _ _ stp -> k stp + +-- | Make a singleton stream from a callback function. The callback function +-- calls the one-shot yield continuation to yield an element. +fromYieldK :: YieldK m a -> StreamK m a +fromYieldK k = mkStream $ \_ _ sng _ -> k sng + +-- | Add a yield function at the head of the stream. +consK :: YieldK m a -> StreamK m a -> StreamK m a +consK k r = mkStream $ \_ yld _ _ -> k (`yld` r) + +-- XXX Build a stream from a repeating callback function. + +------------------------------------------------------------------------------ +-- Construction +------------------------------------------------------------------------------ + +infixr 5 `cons` + +-- faster than consM because there is no bind. + +-- | A right associative prepend operation to add a pure value at the head of +-- an existing stream: +-- +-- >>> s = 1 `StreamK.cons` 2 `StreamK.cons` 3 `StreamK.cons` StreamK.nil +-- >>> Stream.fold Fold.toList (StreamK.toStream s) +-- [1,2,3] +-- +-- Unlike "Streamly.Data.Stream" cons StreamK cons can be used +-- recursively: +-- +-- >>> repeat x = let xs = StreamK.cons x xs in xs +-- >>> fromFoldable = Prelude.foldr StreamK.cons StreamK.nil +-- +-- cons is same as the following but more efficient: +-- +-- >>> cons x xs = return x `StreamK.consM` xs +-- +{-# INLINE_NORMAL cons #-} +cons :: a -> StreamK m a -> StreamK m a +cons a r = mkStream $ \_ yield _ _ -> yield a r + +infixr 5 .: + +-- | Operator equivalent of 'cons'. +-- +-- @ +-- > toList $ 1 .: 2 .: 3 .: nil +-- [1,2,3] +-- @ +-- +{-# INLINE (.:) #-} +(.:) :: a -> StreamK m a -> StreamK m a +(.:) = cons + +-- | A stream that terminates without producing any output or side effect. +-- +-- >>> Stream.fold Fold.toList (StreamK.toStream StreamK.nil) +-- [] +-- +{-# INLINE_NORMAL nil #-} +nil :: StreamK m a +nil = mkStream $ \_ _ _ stp -> stp + +-- | A stream that terminates without producing any output, but produces a side +-- effect. +-- +-- >>> Stream.fold Fold.toList (StreamK.toStream (StreamK.nilM (print "nil"))) +-- "nil" +-- [] +-- +-- /Pre-release/ +{-# INLINE_NORMAL nilM #-} +nilM :: Applicative m => m b -> StreamK m a +nilM m = mkStream $ \_ _ _ stp -> m *> stp + +-- Create a singleton stream from a pure value. +-- +-- >>> fromPure a = a `StreamK.cons` StreamK.nil +-- >>> fromPure = pure +-- >>> fromPure = StreamK.fromEffect . pure +-- +{-# INLINE_NORMAL fromPure #-} +fromPure :: a -> StreamK m a +fromPure a = mkStream $ \_ _ single _ -> single a + +-- Create a singleton stream from a monadic action. +-- +-- >>> fromEffect m = m `StreamK.consM` StreamK.nil +-- +-- >>> Stream.fold Fold.drain $ StreamK.toStream $ StreamK.fromEffect (putStrLn "hello") +-- hello +-- +{-# INLINE_NORMAL fromEffect #-} +fromEffect :: Monad m => m a -> StreamK m a +fromEffect m = mkStream $ \_ _ single _ -> m >>= single + +infixr 5 `consM` + +-- NOTE: specializing the function outside the instance definition seems to +-- improve performance quite a bit at times, even if we have the same +-- SPECIALIZE in the instance definition. + +-- | A right associative prepend operation to add an effectful value at the +-- head of an existing stream:: +-- +-- >>> s = putStrLn "hello" `StreamK.consM` putStrLn "world" `StreamK.consM` StreamK.nil +-- >>> Stream.fold Fold.drain (StreamK.toStream s) +-- hello +-- world +-- +-- It can be used efficiently with 'Prelude.foldr': +-- +-- >>> fromFoldableM = Prelude.foldr StreamK.consM StreamK.nil +-- +-- Same as the following but more efficient: +-- +-- >>> consM x xs = StreamK.fromEffect x `StreamK.append` xs +-- +{-# INLINE consM #-} +{-# SPECIALIZE consM :: IO a -> StreamK IO a -> StreamK IO a #-} +consM :: Monad m => m a -> StreamK m a -> StreamK m a +consM m r = MkStream $ \_ yld _ _ -> m >>= (`yld` r) + +-- XXX specialize to IO? +{-# INLINE consMBy #-} +consMBy :: Monad m => + (StreamK m a -> StreamK m a -> StreamK m a) -> m a -> StreamK m a -> StreamK m a +consMBy f m r = fromEffect m `f` r + +------------------------------------------------------------------------------ +-- Folding a stream +------------------------------------------------------------------------------ + +-- | Fold a stream by providing an SVar, a stop continuation, a singleton +-- continuation and a yield continuation. The stream would share the current +-- SVar passed via the State. +{-# INLINE_EARLY foldStreamShared #-} +foldStreamShared + :: State StreamK m a + -> (a -> StreamK m a -> m r) + -> (a -> m r) + -> m r + -> StreamK m a + -> m r +foldStreamShared s yield single stop (MkStream k) = k s yield single stop + +-- | Fold a stream by providing a State, stop continuation, a singleton +-- continuation and a yield continuation. The stream will not use the SVar +-- passed via State. +{-# INLINE foldStream #-} +foldStream + :: State StreamK m a + -> (a -> StreamK m a -> m r) + -> (a -> m r) + -> m r + -> StreamK m a + -> m r +foldStream s yield single stop (MkStream k) = + k (adaptState s) yield single stop + +------------------------------------------------------------------------------- +-- foldr/build fusion +------------------------------------------------------------------------------- + +-- XXX perhaps we can just use foldrSM/buildM everywhere as they are more +-- general and cover foldrS/buildS as well. + +-- | The function 'f' decides how to reconstruct the stream. We could +-- reconstruct using a shared state (SVar) or without sharing the state. +-- +{-# INLINE foldrSWith #-} +foldrSWith :: + (forall r. State StreamK m b + -> (b -> StreamK m b -> m r) + -> (b -> m r) + -> m r + -> StreamK m b + -> m r) + -> (a -> StreamK m b -> StreamK m b) + -> StreamK m b + -> StreamK m a + -> StreamK m b +foldrSWith f step final m = go m + where + go m1 = mkStream $ \st yld sng stp -> + let run x = f st yld sng stp x + stop = run final + single a = run $ step a final + yieldk a r = run $ step a (go r) + -- XXX if type a and b are the same we do not need adaptState, can we + -- save some perf with that? + -- XXX since we are using adaptState anyway here we can use + -- foldStreamShared instead, will that save some perf? + in foldStream (adaptState st) yieldk single stop m1 + +-- XXX we can use rewrite rules just for foldrSWith, if the function f is the +-- same we can rewrite it. + +-- | Fold sharing the SVar state within the reconstructed stream +{-# INLINE_NORMAL foldrSShared #-} +foldrSShared :: + (a -> StreamK m b -> StreamK m b) + -> StreamK m b + -> StreamK m a + -> StreamK m b +foldrSShared = foldrSWith foldStreamShared + +-- XXX consM is a typeclass method, therefore rewritten already. Instead maybe +-- we can make consM polymorphic using rewrite rules. +-- {-# RULES "foldrSShared/id" foldrSShared consM nil = \x -> x #-} +{-# RULES "foldrSShared/nil" + forall k z. foldrSShared k z nil = z #-} +{-# RULES "foldrSShared/single" + forall k z x. foldrSShared k z (fromPure x) = k x z #-} +-- {-# RULES "foldrSShared/app" [1] +-- forall ys. foldrSShared consM ys = \xs -> xs `conjoin` ys #-} + +-- | Right fold to a streaming monad. +-- +-- > foldrS StreamK.cons StreamK.nil === id +-- +-- 'foldrS' can be used to perform stateless stream to stream transformations +-- like map and filter in general. It can be coupled with a scan to perform +-- stateful transformations. However, note that the custom map and filter +-- routines can be much more efficient than this due to better stream fusion. +-- +-- >>> input = StreamK.fromStream $ Stream.fromList [1..5] +-- >>> Stream.fold Fold.toList $ StreamK.toStream $ StreamK.foldrS StreamK.cons StreamK.nil input +-- [1,2,3,4,5] +-- +-- Find if any element in the stream is 'True': +-- +-- >>> step x xs = if odd x then StreamK.fromPure True else xs +-- >>> input = StreamK.fromStream (Stream.fromList (2:4:5:undefined)) :: StreamK IO Int +-- >>> Stream.fold Fold.toList $ StreamK.toStream $ StreamK.foldrS step (StreamK.fromPure False) input +-- [True] +-- +-- Map (+2) on odd elements and filter out the even elements: +-- +-- >>> step x xs = if odd x then (x + 2) `StreamK.cons` xs else xs +-- >>> input = StreamK.fromStream (Stream.fromList [1..5]) :: StreamK IO Int +-- >>> Stream.fold Fold.toList $ StreamK.toStream $ StreamK.foldrS step StreamK.nil input +-- [3,5,7] +-- +-- /Pre-release/ +{-# INLINE_NORMAL foldrS #-} +foldrS :: + (a -> StreamK m b -> StreamK m b) + -> StreamK m b + -> StreamK m a + -> StreamK m b +foldrS = foldrSWith foldStream + +{-# RULES "foldrS/id" foldrS cons nil = \x -> x #-} +{-# RULES "foldrS/nil" forall k z. foldrS k z nil = z #-} +-- See notes in GHC.Base about this rule +-- {-# RULES "foldr/cons" +-- forall k z x xs. foldrS k z (x `cons` xs) = k x (foldrS k z xs) #-} +{-# RULES "foldrS/single" forall k z x. foldrS k z (fromPure x) = k x z #-} +-- {-# RULES "foldrS/app" [1] +-- forall ys. foldrS cons ys = \xs -> xs `conjoin` ys #-} + +------------------------------------------------------------------------------- +-- foldrS with monadic cons i.e. consM +------------------------------------------------------------------------------- + +{-# INLINE foldrSMWith #-} +foldrSMWith :: Monad m + => (forall r. State StreamK m b + -> (b -> StreamK m b -> m r) + -> (b -> m r) + -> m r + -> StreamK m b + -> m r) + -> (m a -> StreamK m b -> StreamK m b) + -> StreamK m b + -> StreamK m a + -> StreamK m b +foldrSMWith f step final m = go m + where + go m1 = mkStream $ \st yld sng stp -> + let run x = f st yld sng stp x + stop = run final + single a = run $ step (return a) final + yieldk a r = run $ step (return a) (go r) + in foldStream (adaptState st) yieldk single stop m1 + +{-# INLINE_NORMAL foldrSM #-} +foldrSM :: Monad m + => (m a -> StreamK m b -> StreamK m b) + -> StreamK m b + -> StreamK m a + -> StreamK m b +foldrSM = foldrSMWith foldStream + +-- {-# RULES "foldrSM/id" foldrSM consM nil = \x -> x #-} +{-# RULES "foldrSM/nil" forall k z. foldrSM k z nil = z #-} +{-# RULES "foldrSM/single" forall k z x. foldrSM k z (fromEffect x) = k x z #-} +-- {-# RULES "foldrSM/app" [1] +-- forall ys. foldrSM consM ys = \xs -> xs `conjoin` ys #-} + +-- Like foldrSM but sharing the SVar state within the recostructed stream. +{-# INLINE_NORMAL foldrSMShared #-} +foldrSMShared :: Monad m + => (m a -> StreamK m b -> StreamK m b) + -> StreamK m b + -> StreamK m a + -> StreamK m b +foldrSMShared = foldrSMWith foldStreamShared + +-- {-# RULES "foldrSM/id" foldrSM consM nil = \x -> x #-} +{-# RULES "foldrSMShared/nil" + forall k z. foldrSMShared k z nil = z #-} +{-# RULES "foldrSMShared/single" + forall k z x. foldrSMShared k z (fromEffect x) = k x z #-} +-- {-# RULES "foldrSM/app" [1] +-- forall ys. foldrSM consM ys = \xs -> xs `conjoin` ys #-} + +------------------------------------------------------------------------------- +-- build +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL build #-} +build :: forall m a. (forall b. (a -> b -> b) -> b -> b) -> StreamK m a +build g = g cons nil + +{-# RULES "foldrM/build" + forall k z (g :: forall b. (a -> b -> b) -> b -> b). + foldrM k z (build g) = g k z #-} + +{-# RULES "foldrS/build" + forall k z (g :: forall b. (a -> b -> b) -> b -> b). + foldrS k z (build g) = g k z #-} + +{-# RULES "foldrS/cons/build" + forall k z x (g :: forall b. (a -> b -> b) -> b -> b). + foldrS k z (x `cons` build g) = k x (g k z) #-} + +{-# RULES "foldrSShared/build" + forall k z (g :: forall b. (a -> b -> b) -> b -> b). + foldrSShared k z (build g) = g k z #-} + +{-# RULES "foldrSShared/cons/build" + forall k z x (g :: forall b. (a -> b -> b) -> b -> b). + foldrSShared k z (x `cons` build g) = k x (g k z) #-} + +-- build a stream by applying cons and nil to a build function +{-# INLINE_NORMAL buildS #-} +buildS :: + ((a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) + -> StreamK m a +buildS g = g cons nil + +{-# RULES "foldrS/buildS" + forall k z + (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + foldrS k z (buildS g) = g k z #-} + +{-# RULES "foldrS/cons/buildS" + forall k z x + (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + foldrS k z (x `cons` buildS g) = k x (g k z) #-} + +{-# RULES "foldrSShared/buildS" + forall k z + (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + foldrSShared k z (buildS g) = g k z #-} + +{-# RULES "foldrSShared/cons/buildS" + forall k z x + (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + foldrSShared k z (x `cons` buildS g) = k x (g k z) #-} + +-- build a stream by applying consM and nil to a build function +{-# INLINE_NORMAL buildSM #-} +buildSM :: Monad m + => ((m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) + -> StreamK m a +buildSM g = g consM nil + +{-# RULES "foldrSM/buildSM" + forall k z + (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + foldrSM k z (buildSM g) = g k z #-} + +{-# RULES "foldrSMShared/buildSM" + forall k z + (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + foldrSMShared k z (buildSM g) = g k z #-} + +-- Disabled because this may not fire as consM is a class Op +{- +{-# RULES "foldrS/consM/buildSM" + forall k z x (g :: (m a -> t m a -> t m a) -> t m a -> t m a) + . foldrSM k z (x `consM` buildSM g) + = k x (g k z) +#-} +-} + +-- Build using monadic build functions (continuations) instead of +-- reconstructing a stream. +{-# INLINE_NORMAL buildM #-} +buildM :: Monad m + => (forall r. (a -> StreamK m a -> m r) + -> (a -> m r) + -> m r + -> m r + ) + -> StreamK m a +buildM g = mkStream $ \st yld sng stp -> + g (\a r -> foldStream st yld sng stp (return a `consM` r)) sng stp + +-- | Like 'buildM' but shares the SVar state across computations. +{-# INLINE_NORMAL sharedMWith #-} +sharedMWith :: Monad m + => (m a -> StreamK m a -> StreamK m a) + -> (forall r. (a -> StreamK m a -> m r) + -> (a -> m r) + -> m r + -> m r + ) + -> StreamK m a +sharedMWith cns g = mkStream $ \st yld sng stp -> + g (\a r -> foldStreamShared st yld sng stp (return a `cns` r)) sng stp + +------------------------------------------------------------------------------- +-- augment +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL augmentS #-} +augmentS :: + ((a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) + -> StreamK m a + -> StreamK m a +augmentS g xs = g cons xs + +{-# RULES "augmentS/nil" + forall (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + augmentS g nil = buildS g + #-} + +{-# RULES "foldrS/augmentS" + forall k z xs + (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + foldrS k z (augmentS g xs) = g k (foldrS k z xs) + #-} + +{-# RULES "augmentS/buildS" + forall (g :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) + (h :: (a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + augmentS g (buildS h) = buildS (\c n -> g c (h c n)) + #-} + +{-# INLINE_NORMAL augmentSM #-} +augmentSM :: Monad m => + ((m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) + -> StreamK m a -> StreamK m a +augmentSM g xs = g consM xs + +{-# RULES "augmentSM/nil" + forall + (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + augmentSM g nil = buildSM g + #-} + +{-# RULES "foldrSM/augmentSM" + forall k z xs + (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + foldrSM k z (augmentSM g xs) = g k (foldrSM k z xs) + #-} + +{-# RULES "augmentSM/buildSM" + forall + (g :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a) + (h :: (m a -> StreamK m a -> StreamK m a) -> StreamK m a -> StreamK m a). + augmentSM g (buildSM h) = buildSM (\c n -> g c (h c n)) + #-} + +------------------------------------------------------------------------------- +-- Experimental foldrM/buildM +------------------------------------------------------------------------------- + +-- | Lazy right fold with a monadic step function. +{-# INLINE_NORMAL foldrM #-} +foldrM :: (a -> m b -> m b) -> m b -> StreamK m a -> m b +foldrM step acc m = go m + where + go m1 = + let stop = acc + single a = step a acc + yieldk a r = step a (go r) + in foldStream defState yieldk single stop m1 + +{-# INLINE_NORMAL foldrMKWith #-} +foldrMKWith + :: (State StreamK m a + -> (a -> StreamK m a -> m b) + -> (a -> m b) + -> m b + -> StreamK m a + -> m b) + -> (a -> m b -> m b) + -> m b + -> ((a -> StreamK m a -> m b) -> (a -> m b) -> m b -> m b) + -> m b +foldrMKWith f step acc = go + where + go k = + let stop = acc + single a = step a acc + yieldk a r = step a (go (\yld sng stp -> f defState yld sng stp r)) + in k yieldk single stop + +{- +{-# RULES "foldrM/buildS" + forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a) + . foldrM k z (buildS g) + = g k z +#-} +-} +-- XXX in which case will foldrM/buildM fusion be useful? +{-# RULES "foldrM/buildM" + forall step acc (g :: (forall r. + (a -> StreamK m a -> m r) + -> (a -> m r) + -> m r + -> m r + )). + foldrM step acc (buildM g) = foldrMKWith foldStream step acc g + #-} + +{- +{-# RULES "foldrM/sharedM" + forall step acc (g :: (forall r. + (a -> StreamK m a -> m r) + -> (a -> m r) + -> m r + -> m r + )). + foldrM step acc (sharedM g) = foldrMKWith foldStreamShared step acc g + #-} +-} + +------------------------------------------------------------------------------ +-- Left fold +------------------------------------------------------------------------------ + +-- | Strict left fold with an extraction function. Like the standard strict +-- left fold, but applies a user supplied extraction function (the third +-- argument) to the folded value at the end. This is designed to work with the +-- @foldl@ library. The suffix @x@ is a mnemonic for extraction. +-- +-- Note that the accumulator is always evaluated including the initial value. +{-# INLINE foldlx' #-} +foldlx' :: forall m a b x. Monad m + => (x -> a -> x) -> x -> (x -> b) -> StreamK m a -> m b +foldlx' step begin done = + foldlMx' (\x a -> return (step x a)) (return begin) (return . done) + +-- | Strict left associative fold. +{-# INLINE foldl' #-} +foldl' :: Monad m => (b -> a -> b) -> b -> StreamK m a -> m b +foldl' step begin = foldlx' step begin id + +-- | Like 'foldx', but with a monadic step function. +{-# INLINE foldlMx' #-} +foldlMx' :: Monad m + => (x -> a -> m x) -> m x -> (x -> m b) -> StreamK m a -> m b +foldlMx' step begin done stream = + -- Note: Unrolling improves the last benchmark significantly. + let stop = begin >>= done + single a = begin >>= \x -> step x a >>= done + yieldk a r = begin >>= \x -> step x a >>= go r + in foldStream defState yieldk single stop stream + + where + + go m1 !acc = + let stop = done $! acc + single a = step acc a >>= done + yieldk a r = step acc a >>= go r + in foldStream defState yieldk single stop m1 + +-- | Like 'foldl'' but with a monadic step function. +{-# INLINE foldlM' #-} +foldlM' :: Monad m => (b -> a -> m b) -> m b -> StreamK m a -> m b +foldlM' step begin = foldlMx' step begin return + +------------------------------------------------------------------------------ +-- Specialized folds +------------------------------------------------------------------------------ + +-- XXX use foldrM to implement folds where possible +-- XXX This (commented) definition of drain and mapM_ perform much better on +-- some benchmarks but worse on others. Need to investigate why, maybe there is +-- an optimization opportunity that we can exploit. +-- drain = foldrM (\_ xs -> return () >> xs) (return ()) + +-- +-- > drain = foldl' (\_ _ -> ()) () +-- > drain = mapM_ (\_ -> return ()) +{-# INLINE drain #-} +drain :: Monad m => StreamK m a -> m () +drain = foldrM (\_ xs -> xs) (return ()) +{- +drain = go + where + go m1 = + let stop = return () + single _ = return () + yieldk _ r = go r + in foldStream defState yieldk single stop m1 +-} + +{-# INLINE null #-} +null :: Monad m => StreamK m a -> m Bool +-- null = foldrM (\_ _ -> return True) (return False) +null m = + let stop = return True + single _ = return False + yieldk _ _ = return False + in foldStream defState yieldk single stop m + +------------------------------------------------------------------------------ +-- Semigroup +------------------------------------------------------------------------------ + +infixr 6 `append` + +-- | Unlike the fused "Streamly.Data.Stream" append, StreamK append can be used +-- at scale, recursively, with linear performance: +-- +-- >>> cycle xs = let ys = xs `StreamK.append` ys in ys +-- +-- 'concatMapWith' 'append' (same as concatMap) flattens a stream of streams in a +-- depth-first manner i.e. it yields each stream fully and then the next and so +-- on. Given a stream of three streams: +-- +-- @ +-- 1. [1,2,3] +-- 2. [4,5,6] +-- 3. [7,8,9] +-- @ +-- +-- The resulting stream will be @[1,2,3,4,5,6,7,8,9]@. +-- +-- Best used in a right associative manner. +-- +{-# INLINE append #-} +append :: StreamK m a -> StreamK m a -> StreamK m a +-- XXX This doubles the time of toNullAp benchmark, may not be fusing properly +-- serial xs ys = augmentS (\c n -> foldrS c n xs) ys +append m1 m2 = + mkStream $ \st yld sng stp -> + let stop = foldStream st yld sng stp m2 + single a = yld a m2 + yieldk a r = yld a (go r) + in foldStream st yieldk single stop m1 + + where + + go m = + mkStream $ \st yld sng stp -> + let stop = foldStream st yld sng stp m2 + single a = yld a m2 + yieldk a r = yld a (go r) + in foldStream st yieldk single stop m + +-- join/merge/append streams depending on consM +{-# INLINE conjoin #-} +conjoin :: Monad m => StreamK m a -> StreamK m a -> StreamK m a +conjoin xs = augmentSM (\c n -> foldrSM c n xs) + +instance Semigroup (StreamK m a) where + (<>) = append + +------------------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------------------ + +instance Monoid (StreamK m a) where + mempty = nil + mappend = (<>) + +------------------------------------------------------------------------------- +-- Functor +------------------------------------------------------------------------------- + +-- IMPORTANT: This is eta expanded on purpose. This should not be eta +-- reduced. This will cause a lot of regressions, probably because of some +-- rewrite rules. Ideally don't run hlint on this file. +{-# INLINE_LATE mapFB #-} +mapFB :: forall b m a. + (b -> StreamK m b -> StreamK m b) + -> (a -> b) + -> a + -> StreamK m b + -> StreamK m b +mapFB c f = \x ys -> c (f x) ys + +{-# RULES +"mapFB/mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f . g) +"mapFB/id" forall c. mapFB c (\x -> x) = c + #-} + +{-# INLINE map #-} +map :: (a -> b) -> StreamK m a -> StreamK m b +map f xs = buildS (\c n -> foldrS (mapFB c f) n xs) + +-- XXX This definition might potentially be more efficient, but the cost in the +-- benchmark is dominated by unfoldrM cost so we cannot correctly determine +-- differences in the mapping cost. We should perhaps deduct the cost of +-- unfoldrM from the benchmarks and then compare. +{- +map f m = go m + where + go m1 = + mkStream $ \st yld sng stp -> + let single = sng . f + yieldk a r = yld (f a) (go r) + in foldStream (adaptState st) yieldk single stp m1 +-} + +{-# INLINE_LATE mapMFB #-} +mapMFB :: Monad m => (m b -> t m b -> t m b) -> (a -> m b) -> m a -> t m b -> t m b +mapMFB c f x = c (x >>= f) + +{-# RULES + "mapMFB/mapMFB" forall c f g. mapMFB (mapMFB c f) g = mapMFB c (f >=> g) + #-} +-- XXX These rules may never fire because pure/return type class rules will +-- fire first. +{- +"mapMFB/pure" forall c. mapMFB c (\x -> pure x) = c +"mapMFB/return" forall c. mapMFB c (\x -> return x) = c +-} + +-- This is experimental serial version supporting fusion. +-- +-- XXX what if we do not want to fuse two concurrent mapMs? +-- XXX we can combine two concurrent mapM only if the SVar is of the same type +-- So for now we use it only for serial streams. +-- XXX fusion would be easier for monomoprhic stream types. +-- {-# RULES "mapM serial" mapM = mapMSerial #-} +{-# INLINE mapMSerial #-} +mapMSerial :: Monad m => (a -> m b) -> StreamK m a -> StreamK m b +mapMSerial f xs = buildSM (\c n -> foldrSMShared (mapMFB c f) n xs) + +{-# INLINE mapMWith #-} +mapMWith :: + (m b -> StreamK m b -> StreamK m b) + -> (a -> m b) + -> StreamK m a + -> StreamK m b +mapMWith cns f = foldrSShared (\x xs -> f x `cns` xs) nil + +{- +-- See note under map definition above. +mapMWith cns f = go + where + go m1 = mkStream $ \st yld sng stp -> + let single a = f a >>= sng + yieldk a r = foldStreamShared st yld sng stp $ f a `cns` go r + in foldStream (adaptState st) yieldk single stp m1 +-} + +-- XXX in fact use the Stream type everywhere and only use polymorphism in the +-- high level modules/prelude. +instance Monad m => Functor (StreamK m) where + fmap = map + +-- $smapM_Notes +-- +-- The stateful step function can be simplified to @(s -> a -> m b)@ to provide +-- a read-only environment. However, that would just be 'mapM'. +-- +-- The initial action could be @m (s, Maybe b)@, and we can also add a final +-- action @s -> m (Maybe b)@. This can be used to get pre/post scan like +-- functionality and also to flush the state in the end like scanlMAfter'. +-- We can also use it along with a fusible version of bracket to get +-- scanlMAfter' like functionality. See issue #677. +-- +-- This can be further generalized to a type similar to Fold/Parser, giving it +-- filtering and parsing capability as well (this is in fact equivalent to +-- parseMany): +-- +-- smapM :: (s -> a -> m (Step s b)) -> m s -> t m a -> t m b +-- + +-- | A stateful map aka scan but with a slight difference. +-- +-- This is similar to a scan except that instead of emitting the state it emits +-- a separate result. This is also similar to mapAccumL but does not return the +-- final value of the state. +-- +-- Separation of state from the output makes it easier to think in terms of a +-- shared state, and also makes it easier to keep the state fully strict and +-- the output lazy. +-- +-- /Unimplemented/ +-- +{-# INLINE mapMAccum #-} +mapMAccum :: -- Monad m => + (s -> a -> m (s, b)) + -> m s + -> StreamK m a + -> StreamK m b +mapMAccum _step _initial _stream = undefined +{- + -- XXX implement this directly instead of using scanlM' + -- Once we have postscanlM' with monadic initial we can use this code + -- let r = postscanlM' + -- (\(s, _) a -> step s a) + -- (fmap (,undefined) initial) + -- stream + let r = postscanlM' + (\(s, _) a -> step s a) + (fmap (,undefined) initial) + stream + in map snd r +-} + +-- | Like 'concatMapWith' but carries a state which can be used to share +-- information across multiple steps of concat. +-- +-- @ +-- concatSmapMWith combine f initial = concatMapWith combine id . smapM f initial +-- @ +-- +-- /Unimplemented/ +-- +{-# INLINE concatMapMAccum #-} +concatMapMAccum :: -- (Monad m) => + (StreamK m b -> StreamK m b -> StreamK m b) + -> (s -> a -> m (s, StreamK m b)) + -> m s + -> StreamK m a + -> StreamK m b +concatMapMAccum combine f initial = + concatMapWith combine id . mapMAccum f initial + +------------------------------------------------------------------------------ +-- Lists +------------------------------------------------------------------------------ + +-- Serial streams can act like regular lists using the Identity monad + +-- XXX Show instance is 10x slower compared to read, we can do much better. +-- The list show instance itself is really slow. + +-- XXX The default definitions of "<" in the Ord instance etc. do not perform +-- well, because they do not get inlined. Need to add INLINE in Ord class in +-- base? + +instance IsList (StreamK Identity a) where + type (Item (StreamK Identity a)) = a + + {-# INLINE fromList #-} + fromList = fromFoldable + + {-# INLINE toList #-} + toList = Data.Foldable.foldr (:) [] + +-- XXX Fix these +{- +instance Eq a => Eq (StreamK Identity a) where + {-# INLINE (==) #-} + (==) xs ys = runIdentity $ eqBy (==) xs ys + +instance Ord a => Ord (StreamK Identity a) where + {-# INLINE compare #-} + compare xs ys = runIdentity $ cmpBy compare xs ys + + {-# INLINE (<) #-} + x < y = + case compare x y of + LT -> True + _ -> False + + {-# INLINE (<=) #-} + x <= y = + case compare x y of + GT -> False + _ -> True + + {-# INLINE (>) #-} + x > y = + case compare x y of + GT -> True + _ -> False + + {-# INLINE (>=) #-} + x >= y = + case compare x y of + LT -> False + _ -> True + + {-# INLINE max #-} + max x y = if x <= y then y else x + + {-# INLINE min #-} + min x y = if x <= y then x else y +-} + +instance Show a => Show (StreamK Identity a) where + showsPrec p dl = showParen (p > 10) $ + showString "fromList " . shows (toList dl) + +instance Read a => Read (StreamK Identity a) where + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + GHC.Exts.fromList <$> readPrec + + readListPrec = readListPrecDefault + +instance (a ~ Char) => IsString (StreamK Identity a) where + {-# INLINE fromString #-} + fromString = GHC.Exts.fromList + +------------------------------------------------------------------------------- +-- Foldable +------------------------------------------------------------------------------- + +-- | Lazy right associative fold. +{-# INLINE foldr #-} +foldr :: Monad m => (a -> b -> b) -> b -> StreamK m a -> m b +foldr step acc = foldrM (\x xs -> xs >>= \b -> return (step x b)) (return acc) + +-- The default Foldable instance has several issues: +-- 1) several definitions do not have INLINE on them, so we provide +-- re-implementations with INLINE pragmas. +-- 2) the definitions of sum/product/maximum/minimum are inefficient as they +-- use right folds, they cannot run in constant memory. We provide +-- implementations using strict left folds here. + +instance (Foldable m, Monad m) => Foldable (StreamK m) where + + {-# INLINE foldMap #-} + foldMap f = + fold + . Streamly.Internal.Data.StreamK.Type.foldr (mappend . f) mempty + + {-# INLINE foldr #-} + foldr f z t = appEndo (foldMap (Endo #. f) t) z + + {-# INLINE foldl' #-} + foldl' f z0 xs = Data.Foldable.foldr f' id xs z0 + where f' x k = oneShot $ \z -> k $! f z x + + {-# INLINE length #-} + length = Data.Foldable.foldl' (\n _ -> n + 1) 0 + + {-# INLINE elem #-} + elem = any . (==) + + {-# INLINE maximum #-} + maximum = + fromMaybe (errorWithoutStackTrace "maximum: empty stream") + . toMaybe + . Data.Foldable.foldl' getMax Nothing' + + where + + getMax Nothing' x = Just' x + getMax (Just' mx) x = Just' $! max mx x + + {-# INLINE minimum #-} + minimum = + fromMaybe (errorWithoutStackTrace "minimum: empty stream") + . toMaybe + . Data.Foldable.foldl' getMin Nothing' + + where + + getMin Nothing' x = Just' x + getMin (Just' mn) x = Just' $! min mn x + + {-# INLINE sum #-} + sum = Data.Foldable.foldl' (+) 0 + + {-# INLINE product #-} + product = Data.Foldable.foldl' (*) 1 + +------------------------------------------------------------------------------- +-- Traversable +------------------------------------------------------------------------------- + +instance Traversable (StreamK Identity) where + {-# INLINE traverse #-} + traverse f xs = + runIdentity + $ Streamly.Internal.Data.StreamK.Type.foldr + consA (pure mempty) xs + + where + + consA x ys = liftA2 cons (f x) ys + +------------------------------------------------------------------------------- +-- Nesting +------------------------------------------------------------------------------- + +-- | Detach a stream from an SVar +{-# INLINE unShare #-} +unShare :: StreamK m a -> StreamK m a +unShare x = mkStream $ \st yld sng stp -> + foldStream st yld sng stp x + +-- XXX the function stream and value stream can run in parallel +{-# INLINE crossApplyWith #-} +crossApplyWith :: + (StreamK m b -> StreamK m b -> StreamK m b) + -> StreamK m (a -> b) + -> StreamK m a + -> StreamK m b +crossApplyWith par fstream stream = go1 fstream + + where + + go1 m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + single f = foldShared $ unShare (go2 f stream) + yieldk f r = foldShared $ unShare (go2 f stream) `par` go1 r + in foldStream (adaptState st) yieldk single stp m + + go2 f m = + mkStream $ \st yld sng stp -> + let single a = sng (f a) + yieldk a r = yld (f a) (go2 f r) + in foldStream (adaptState st) yieldk single stp m + +-- | Apply a stream of functions to a stream of values and flatten the results. +-- +-- Note that the second stream is evaluated multiple times. +-- +-- Definition: +-- +-- >>> crossApply = StreamK.crossApplyWith StreamK.append +-- >>> crossApply = Stream.crossWith id +-- +{-# INLINE crossApply #-} +crossApply :: + StreamK m (a -> b) + -> StreamK m a + -> StreamK m b +crossApply fstream stream = go1 fstream + + where + + go1 m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + single f = foldShared $ go3 f stream + yieldk f r = foldShared $ go2 f r stream + in foldStream (adaptState st) yieldk single stp m + + go2 f r1 m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + stop = foldShared $ go1 r1 + single a = yld (f a) (go1 r1) + yieldk a r = yld (f a) (go2 f r1 r) + in foldStream (adaptState st) yieldk single stop m + + go3 f m = + mkStream $ \st yld sng stp -> + let single a = sng (f a) + yieldk a r = yld (f a) (go3 f r) + in foldStream (adaptState st) yieldk single stp m + +{-# INLINE crossApplySnd #-} +crossApplySnd :: + StreamK m a + -> StreamK m b + -> StreamK m b +crossApplySnd fstream stream = go1 fstream + + where + + go1 m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + single _ = foldShared stream + yieldk _ r = foldShared $ go2 r stream + in foldStream (adaptState st) yieldk single stp m + + go2 r1 m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + stop = foldShared $ go1 r1 + single a = yld a (go1 r1) + yieldk a r = yld a (go2 r1 r) + in foldStream st yieldk single stop m + +{-# INLINE crossApplyFst #-} +crossApplyFst :: + StreamK m a + -> StreamK m b + -> StreamK m a +crossApplyFst fstream stream = go1 fstream + + where + + go1 m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + single f = foldShared $ go3 f stream + yieldk f r = foldShared $ go2 f r stream + in foldStream st yieldk single stp m + + go2 f r1 m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + stop = foldShared $ go1 r1 + single _ = yld f (go1 r1) + yieldk _ r = yld f (go2 f r1 r) + in foldStream (adaptState st) yieldk single stop m + + go3 f m = + mkStream $ \st yld sng stp -> + let single _ = sng f + yieldk _ r = yld f (go3 f r) + in foldStream (adaptState st) yieldk single stp m + +-- | +-- Definition: +-- +-- >>> crossWith f m1 m2 = fmap f m1 `StreamK.crossApply` m2 +-- +-- Note that the second stream is evaluated multiple times. +-- +{-# INLINE crossWith #-} +crossWith :: Monad m => (a -> b -> c) -> StreamK m a -> StreamK m b -> StreamK m c +crossWith f m1 m2 = fmap f m1 `crossApply` m2 + +-- | Given a @StreamK m a@ and @StreamK m b@ generate a stream with all possible +-- combinations of the tuple @(a, b)@. +-- +-- Definition: +-- +-- >>> cross = StreamK.crossWith (,) +-- +-- The second stream is evaluated multiple times. If that is not desired it can +-- be cached in an 'Data.Array.Array' and then generated from the array before +-- calling this function. Caching may also improve performance if the stream is +-- expensive to evaluate. +-- +-- See 'Streamly.Internal.Data.Unfold.cross' for a much faster fused +-- alternative. +-- +-- Time: O(m x n) +-- +-- /Pre-release/ +{-# INLINE cross #-} +cross :: Monad m => StreamK m a -> StreamK m b -> StreamK m (a, b) +cross = crossWith (,) + +-- XXX This is just concatMapWith with arguments flipped. We need to keep this +-- instead of using a concatMap style definition because the bind +-- implementation in Async and WAsync streams show significant perf degradation +-- if the argument order is changed. +{-# INLINE concatForWith #-} +bindWith, concatForWith :: + (StreamK m b -> StreamK m b -> StreamK m b) + -> StreamK m a + -> (a -> StreamK m b) + -> StreamK m b +concatForWith combine m1 f = go m1 +{- + -- There is a small improvement by unrolling the first iteration + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + single a = foldShared $ unShare (f a) + yieldk a r = foldShared $ unShare (f a) `combine` go r + in foldStreamShared (adaptState st) yieldk single stp m1 +-} + + where + + go m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + single a = foldShared $ unShare (f a) + yieldk a r = foldShared $ unShare (f a) `combine` go r + in foldStreamShared (adaptState st) yieldk single stp m + +RENAME(bindWith,concatForWith) + +-- XXX express in terms of foldrS? +-- XXX can we use a different stream type for the generated stream being +-- falttened so that we can combine them differently and keep the resulting +-- stream different? +-- XXX do we need specialize to IO? +-- XXX can we optimize when c and a are same, by removing the forall using +-- rewrite rules with type applications? + +-- | Perform a 'concatMap' using a specified concat strategy. The first +-- argument specifies a merge or concat function that is used to merge the +-- streams generated by the map function. +-- +-- For example, interleaving n streams in a left biased manner: +-- +-- >>> lists = mk [[1,5],[2,6],[3,7],[4,8]] +-- >>> un $ StreamK.concatMapWith StreamK.interleave mk lists +-- [1,2,5,3,6,4,7,8] +-- +-- For a fair interleaving example see 'bfsConcatMap' and 'mergeMapWith'. +-- +{-# INLINE concatMapWith #-} +concatMapWith + :: + (StreamK m b -> StreamK m b -> StreamK m b) + -> (a -> StreamK m b) + -> StreamK m a + -> StreamK m b +concatMapWith par f xs = concatForWith par xs f + +-- | Like 'concatForWith' but maps an effectful function. +{-# INLINE concatForWithM #-} +concatForWithM :: Monad m => + (StreamK m b -> StreamK m b -> StreamK m b) + -> StreamK m a + -> (a -> m (StreamK m b)) + -> StreamK m b +concatForWithM combine s f = concatForWith combine s (concatEffect . f) + +-- | +-- If total iterations are kept the same, each increase in the nesting level +-- increases the cost by roughly 1.5 times. +-- +{-# INLINE concatMap #-} +concatMap :: (a -> StreamK m b) -> StreamK m a -> StreamK m b +concatMap = concatMapWith append + +{- +-- Fused version. +-- XXX This fuses but when the stream is nil this performs poorly. +-- The filterAllOut benchmark degrades. Need to investigate and fix that. +{-# INLINE concatMap #-} +concatMap :: IsStream t => (a -> t m b) -> t m a -> t m b +concatMap f xs = buildS + (\c n -> foldrS (\x b -> foldrS c b (f x)) n xs) + +-- Stream polymorphic concatMap implementation +-- XXX need to use buildSM/foldrSMShared for parallel behavior +-- XXX unShare seems to degrade the fused performance +{-# INLINE_EARLY concatMap_ #-} +concatMap_ :: IsStream t => (a -> t m b) -> t m a -> t m b +concatMap_ f xs = buildS + (\c n -> foldrSShared (\x b -> foldrSShared c b (unShare $ f x)) n xs) +-} + +-- | Map a stream generating function on each element of a stream and +-- concatenate the results. This is the same as the bind function of the monad +-- instance. It is just a flipped 'concatMap' but more convenient to use for +-- nested use case, feels like an imperative @for@ loop. +-- +-- >>> concatFor = flip StreamK.concatMap +-- +-- A concatenating @for@ loop: +-- +-- >>> :{ +-- un $ +-- StreamK.concatFor (mk [1,2,3]) $ \x -> +-- StreamK.fromPure x +-- :} +-- [1,2,3] +-- +-- Nested concatenating @for@ loops: +-- +-- >>> :{ +-- un $ +-- StreamK.concatFor (mk [1,2,3]) $ \x -> +-- StreamK.concatFor (mk [4,5,6]) $ \y -> +-- StreamK.fromPure (x, y) +-- :} +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +{-# INLINE concatFor #-} +concatFor :: StreamK m a -> (a -> StreamK m b) -> StreamK m b +concatFor = concatForWith append + +-- | Like 'concatFor' but maps an effectful function. It allows conveniently +-- mixing monadic effects with streams. +-- +-- >>> import Control.Monad.IO.Class (liftIO) +-- >>> :{ +-- un $ +-- StreamK.concatForM (mk [1,2,3]) $ \x -> do +-- liftIO $ putStrLn (show x) +-- pure $ StreamK.fromPure x +-- :} +-- 1 +-- 2 +-- 3 +-- [1,2,3] +-- +-- Nested concatentating @for@ loops: +-- +-- >>> :{ +-- un $ +-- StreamK.concatForM (mk [1,2,3]) $ \x -> do +-- liftIO $ putStrLn (show x) +-- pure $ StreamK.concatFor (mk [4,5,6]) $ \y -> +-- StreamK.fromPure (x, y) +-- :} +-- 1 +-- 2 +-- 3 +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +{-# INLINE concatForM #-} +concatForM :: Monad m => StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b +concatForM s f = + -- This should be better than implementing a custom concatForWithM because + -- here we do not need to inline concatFor, "concatEffect . f" should get + -- fused right here. + concatFor s (concatEffect . f) + +-- XXX Instead of using "mergeMapWith interleave" we can implement an N-way +-- interleaving CPS combinator which behaves like unfoldEachInterleave. Instead +-- of pairing up the streams we just need to go yielding one element from each +-- stream and storing the remaining streams and then keep doing rounds through +-- those in a round robin fashion. This would be much like wAsync. + +-- | Combine streams in pairs using a binary combinator, the resulting streams +-- are then combined again in pairs recursively until we get to a single +-- combined stream. The composition would thus form a binary tree. +-- +-- For example, 'mergeMapWith interleave' gives the following result: +-- +-- >>> lists = mk [[1,2,3],[4,5,6],[7,8,9],[10,11,12]] +-- >>> un $ StreamK.mergeMapWith StreamK.interleave mk lists +-- [1,7,4,10,2,8,5,11,3,9,6,12] +-- +-- The above example is equivalent to the following pairings: +-- +-- >>> pair1 = mk [1,2,3] `StreamK.interleave` mk [4,5,6] +-- >>> pair2 = mk [7,8,9] `StreamK.interleave` mk [10,11,12] +-- >>> un $ pair1 `StreamK.interleave` pair2 +-- [1,7,4,10,2,8,5,11,3,9,6,12] +-- +-- If the number of streams being combined is not a power of 2, the binary tree +-- composed by mergeMapWith is not balanced, therefore, the output may not look +-- fairly interleaved, it will be biased towards the unpaired streams: +-- +-- >>> lists = mk [[1,2,3],[4,5,6],[7,8,9]] +-- >>> un $ StreamK.mergeMapWith StreamK.interleave mk lists +-- [1,7,4,8,2,9,5,3,6] +-- +-- An efficient merge sort can be implemented by using 'mergeBy' as the +-- combining function: +-- +-- >>> combine = StreamK.mergeBy compare +-- >>> un $ StreamK.mergeMapWith combine StreamK.fromPure (mk [5,1,7,9,2]) +-- [1,2,5,7,9] +-- +-- /Caution: the stream of streams must be finite/ +-- +-- /Pre-release/ +-- +{-# INLINE mergeMapWith #-} +mergeMapWith + :: + (StreamK m b -> StreamK m b -> StreamK m b) + -> (a -> StreamK m b) + -> StreamK m a + -> StreamK m b +mergeMapWith combine f str = go (leafPairs str) + + where + + go stream = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + single a = foldShared $ unShare a + yieldk a r = foldShared $ go1 a r + in foldStream (adaptState st) yieldk single stp stream + + go1 a1 stream = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + stop = foldShared $ unShare a1 + single a = foldShared $ unShare a1 `combine` a + yieldk a r = + foldShared $ go $ combine a1 a `cons` nonLeafPairs r + in foldStream (adaptState st) yieldk single stop stream + + -- Exactly the same as "go" except that stop continuation extracts the + -- stream. + leafPairs stream = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + single a = sng (f a) + yieldk a r = foldShared $ leafPairs1 a r + in foldStream (adaptState st) yieldk single stp stream + + leafPairs1 a1 stream = + mkStream $ \st yld sng _ -> + let stop = sng (f a1) + single a = sng (f a1 `combine` f a) + yieldk a r = yld (f a1 `combine` f a) $ leafPairs r + in foldStream (adaptState st) yieldk single stop stream + + -- Exactly the same as "leafPairs" except that it does not map "f" + nonLeafPairs stream = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + single a = sng a + yieldk a r = foldShared $ nonLeafPairs1 a r + in foldStream (adaptState st) yieldk single stp stream + + nonLeafPairs1 a1 stream = + mkStream $ \st yld sng _ -> + let stop = sng a1 + single a = sng (a1 `combine` a) + yieldk a r = yld (a1 `combine` a) $ nonLeafPairs r + in foldStream (adaptState st) yieldk single stop stream + +-- | See 'bfsConcatFor' for detailed documentation. +-- +-- >>> bfsConcatMap = flip StreamK.bfsConcatFor +-- +{-# INLINE bfsConcatMap #-} +bfsConcatMap :: + (a -> StreamK m b) + -> StreamK m a + -> StreamK m b +bfsConcatMap f m1 = go id m1 + + where + + go xs m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + stop = foldStream st yld sng stp (goLoop id (xs [])) + single a = foldShared $ goLast xs (f a) + yieldk a r = foldShared $ goNext xs r (f a) + in foldStream (adaptState st) yieldk single stop m + + -- generate first element from cur stream, and then put it back in the + -- queue xs. + goNext xs m cur = + mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp (go xs m) + single a = yld a (go xs m) + yieldk a r = yld a (go (xs . (r :)) m) + foldStream st yieldk single stop cur + + goLast xs cur = + mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp (goLoop id (xs [])) + single a = yld a (goLoop id (xs [])) + yieldk a r = yld a (goLoop id ((xs . (r :)) [])) + foldStream st yieldk single stop cur + + -- Loop through all streams in the queue ys until they are over + goLoop ys [] = + -- We will do this optimization only after two iterations are + -- over, if doing this earlier is helpful we can do it in + -- goLast as well, before calling goLoop. + let xs = ys [] + in case xs of + [] -> nil + (z:[]) -> z + (z1:z2:[]) -> interleave z1 z2 + zs -> goLoop id zs + goLoop ys (x:xs) = + mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp (goLoop ys xs) + single a = yld a (goLoop ys xs) + yieldk a r = yld a (goLoop (ys . (r :)) xs) + foldStream st yieldk single stop x + +-- | While 'concatFor' flattens a stream of streams in a depth first manner, +-- 'bfsConcatFor' flattens it in a breadth-first manner. It yields one item +-- from the first stream, then one item from the next stream and so on. In +-- nested loops it has the effect of prioritizing the new outer loop iteration +-- over the inner loops, thus inverting the looping. +-- Given a stream of three streams: +-- +-- @ +-- 1. [1,2,3] +-- 2. [4,5,6] +-- 3. [7,8,9] +-- @ +-- +-- The resulting stream is @(1,4,7),(2,5,8),(3,6,9)@. The parenthesis are added +-- to emphasize the iterations. +-- +-- For example: +-- +-- >>> stream = mk [[1,2,3],[4,5,6],[7,8,9]] +-- >>> :{ +-- un $ +-- StreamK.bfsConcatFor stream $ \x -> +-- StreamK.fromStream $ Stream.fromList x +-- :} +-- [1,4,7,2,5,8,3,6,9] +-- +-- Compare with 'concatForWith' 'interleave' which explores the depth +-- exponentially more compared to the breadth, such that each stream yields +-- twice as many items compared to the next stream. +-- +-- See also the equivalent fused version 'Data.Stream.unfoldEachInterleave'. +-- +{-# INLINE bfsConcatFor #-} +bfsConcatFor :: StreamK m a -> (a -> StreamK m b) -> StreamK m b +bfsConcatFor = flip bfsConcatMap + +-- | Like 'bfsConcatFor' but maps a monadic function. +{-# INLINE bfsConcatForM #-} +bfsConcatForM :: Monad m => StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b +bfsConcatForM s f = bfsConcatMap (concatEffect . f) s + +-- | See 'fairConcatFor' for detailed documentation. +-- +-- >>> fairConcatMap = flip StreamK.fairConcatFor +-- +{-# INLINE fairConcatMap #-} +fairConcatMap :: + (a -> StreamK m b) + -> StreamK m a + -> StreamK m b +fairConcatMap f m1 = go id m1 + + where + + go xs m = + mkStream $ \st yld sng stp -> + let foldShared = foldStreamShared st yld sng stp + stop = foldStream st yld sng stp (goLoop id (xs [])) + single a = foldShared $ goLoop id (xs [f a]) + yieldk a r = foldShared $ goNext r id (xs [f a]) + in foldStream (adaptState st) yieldk single stop m + + goNext m ys [] = go ys m + goNext m ys (x:xs) = + mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp (goNext m ys xs) + single a = yld a (goNext m ys xs) + yieldk a r = yld a (goNext m (ys . (r :)) xs) + foldStream st yieldk single stop x + + -- Loop through all streams in the queue ys until they are over + goLoop ys [] = + -- We will do this optimization only after two iterations are + -- over, if doing this earlier is helpful we can do it in + -- goLast as well, before calling goLoop. + let xs = ys [] + in case xs of + [] -> nil + (z:[]) -> z + (z1:z2:[]) -> interleave z1 z2 + zs -> goLoop id zs + goLoop ys (x:xs) = + mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp (goLoop ys xs) + single a = yld a (goLoop ys xs) + yieldk a r = yld a (goLoop (ys . (r :)) xs) + foldStream st yieldk single stop x + +-- | 'fairConcatFor' is like 'concatFor' but traverses the depth and breadth of +-- nesting equally. Therefore, the outer and the inner loops in a nested loop +-- get equal priority. It can be used to nest infinite streams without starving +-- outer streams due to inner ones. +-- +-- Given a stream of three streams: +-- +-- @ +-- 1. [1,2,3] +-- 2. [4,5,6] +-- 3. [7,8,9] +-- @ +-- +-- Here, outer loop is the stream of streams and the inner loops are the +-- individual streams. The traversal sweeps the diagonals in the above grid to +-- give equal chance to outer and inner loops. The resulting stream is +-- @(1),(2,4),(3,5,7),(6,8),(9)@, diagonals are parenthesized for emphasis. +-- +-- == Looping +-- +-- A single stream case is equivalent to 'concatFor': +-- +-- >>> un $ StreamK.fairConcatFor (mk [1,2]) $ \x -> StreamK.fromPure x +-- [1,2] +-- +-- == Fair Nested Looping +-- +-- Multiple streams nest like @for@ loops. The result is a cross product of the +-- streams. However, the ordering of the results of the cross product is such +-- that each stream gets consumed equally. In other words, inner iterations of +-- a nested loop get the same priority as the outer iterations. Inner +-- iterations do not finish completely before the outer iterations start. +-- +-- >>> :{ +-- un $ do +-- StreamK.fairConcatFor (mk [1,2,3]) $ \x -> +-- StreamK.fairConcatFor (mk [4,5,6]) $ \y -> +-- StreamK.fromPure (x, y) +-- :} +-- [(1,4),(1,5),(2,4),(1,6),(2,5),(3,4),(2,6),(3,5),(3,6)] +-- +-- == Nesting Infinite Streams +-- +-- Example with infinite streams. Print all pairs in the cross product with sum +-- less than a specified number. +-- +-- >>> :{ +-- Stream.toList +-- $ Stream.takeWhile (\(x,y) -> x + y < 6) +-- $ StreamK.toStream +-- $ StreamK.fairConcatFor (mk [1..]) $ \x -> +-- StreamK.fairConcatFor (mk [1..]) $ \y -> +-- StreamK.fromPure (x, y) +-- :} +-- [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(1,4),(2,3),(3,2),(4,1)] +-- +-- == How the nesting works? +-- +-- If we look at the cross product of [1,2,3], [4,5,6], the streams being +-- combined using 'fairConcatFor' are the following sequential loop iterations: +-- +-- @ +-- (1,4) (1,5) (1,6) -- first iteration of the outer loop +-- (2,4) (2,5) (2,6) -- second iteration of the outer loop +-- (3,4) (3,5) (3,6) -- third iteration of the outer loop +-- @ +-- +-- The result is a triangular or diagonal traversal of these iterations: +-- +-- @ +-- [(1,4),(1,5),(2,4),(1,6),(2,5),(3,4),(2,6),(3,5),(3,6)] +-- @ +-- +-- == Non-Termination Cases +-- +-- If one of the two interleaved streams does not produce an output at all and +-- continues forever then the other stream will never get scheduled. This is +-- because a stream is unscheduled only after it produces an output. This can +-- lead to non-terminating programs, an example is provided below. +-- +-- >>> :{ +-- oddsIf x = mk (if x then [1,3..] else [2,4..]) +-- filterEven x = if even x then StreamK.fromPure x else StreamK.nil +-- :} +-- +-- >>> :{ +-- evens = +-- StreamK.fairConcatFor (mk [True,False]) $ \r -> +-- StreamK.concatFor (oddsIf r) filterEven +-- :} +-- +-- The @evens@ function does not terminate because, when r is True, the nested +-- 'concatFor' is a non-productive infinite loop, therefore, the outer loop +-- never gets a chance to generate the @False@ value. +-- +-- But the following refactoring of the above code works as expected: +-- +-- >>> :{ +-- mixed = +-- StreamK.fairConcatFor (mk [True,False]) $ \r -> +-- StreamK.concatFor (oddsIf r) StreamK.fromPure +-- :} +-- +-- >>> evens = StreamK.fairConcatFor mixed filterEven +-- >>> Stream.toList $ Stream.take 3 $ StreamK.toStream evens +-- [2,4,6] +-- +-- This works because in @mixed@ both the streams being interleaved are +-- productive. +-- +-- Care should be taken how you write your program, keep in mind the scheduling +-- implications. To avoid such scheduling problems in serial interleaving, you +-- can use concurrent interleaving instead i.e. parFairConcatFor. Due to +-- concurrent threads the other branch will make progress even if one is an +-- infinite loop producing nothing. +-- +-- == Logic Programming +-- +-- Streamly provides all operations for logic programming. It provides +-- functionality equivalent to 'LogicT' type from the 'logict' package. +-- The @MonadLogic@ operations can be implemented using the available stream +-- operations. For example, 'uncons' is @msplit@, 'interleave' corresponds to +-- the @interleave@ operation of MonadLogic, 'fairConcatFor' is the +-- fair bind (@>>-@) operation. +-- +-- == Related Operations +-- +-- 'concatForWith' 'interleave' is another way to interleave two serial +-- streams. In this case, the inner loop iterations get exponentially more +-- priority over the outer iterations of the nested loop. This is biased +-- towards the inner loops - this is exactly how the logic-t and list-t +-- implementation of fair bind works. +-- +{-# INLINE fairConcatFor #-} +fairConcatFor :: StreamK m a -> (a -> StreamK m b) -> StreamK m b +fairConcatFor = flip fairConcatMap + +-- | Like 'fairConcatFor' but maps a monadic function. +{-# INLINE fairConcatForM #-} +fairConcatForM :: Monad m => StreamK m a -> (a -> m (StreamK m b)) -> StreamK m b +fairConcatForM s f = fairConcatMap (concatEffect . f) s + +{- +instance Monad m => Applicative (StreamK m) where + {-# INLINE pure #-} + pure = fromPure + + {-# INLINE (<*>) #-} + (<*>) = crossApply + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + + {-# INLINE (*>) #-} + (*>) = crossApplySnd + + {-# INLINE (<*) #-} + (<*) = crossApplyFst + +-- NOTE: even though concatMap for StreamD is 3x faster compared to StreamK, +-- the monad instance of StreamD is slower than StreamK after foldr/build +-- fusion. +instance Monad m => Monad (StreamK m) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + (>>=) = flip concatMap +-} + +{- +-- Like concatMap but generates stream using an unfold function. Similar to +-- unfoldMany but for StreamK. +concatUnfoldr :: IsStream t + => (b -> t m (Maybe (a, b))) -> t m b -> t m a +concatUnfoldr = undefined +-} + +------------------------------------------------------------------------------ +-- concatIterate - Map and flatten Trees of Streams +------------------------------------------------------------------------------ + +-- | Yield an input element in the output stream, map a stream generator on it +-- and repeat the process on the resulting stream. Resulting streams are +-- flattened using the 'concatMapWith' combinator. This can be used for a depth +-- first style (DFS) traversal of a tree like structure. +-- +-- Example, list a directory tree using DFS: +-- +-- >>> f = StreamK.fromStream . either (Dir.readEitherPaths id) (const Stream.nil) +-- >>> input = StreamK.fromEffect (Left <$> Path.fromString ".") +-- >>> ls = StreamK.concatIterateWith StreamK.append f input +-- +-- Note that 'iterateM' is a special case of 'concatIterateWith': +-- +-- >>> iterateM f = StreamK.concatIterateWith StreamK.append (StreamK.fromEffect . f) . StreamK.fromEffect +-- +-- /Pre-release/ +-- +{-# INLINE concatIterateWith #-} +concatIterateWith :: + (StreamK m a -> StreamK m a -> StreamK m a) + -> (a -> StreamK m a) + -> StreamK m a + -> StreamK m a +concatIterateWith combine f = iterateStream + + where + + iterateStream = concatMapWith combine generate + + generate x = x `cons` iterateStream (f x) + +-- | Like 'concatIterateWith' but uses the pairwise flattening combinator +-- 'mergeMapWith' for flattening the resulting streams. This can be used for a +-- balanced traversal of a tree like structure. +-- +-- Example, list a directory tree using balanced traversal: +-- +-- >>> f = StreamK.fromStream . either (Dir.readEitherPaths id) (const Stream.nil) +-- >>> input = StreamK.fromEffect (Left <$> Path.fromString ".") +-- >>> ls = StreamK.mergeIterateWith StreamK.interleave f input +-- +-- /Pre-release/ +-- +{-# INLINE mergeIterateWith #-} +mergeIterateWith :: + (StreamK m a -> StreamK m a -> StreamK m a) + -> (a -> StreamK m a) + -> StreamK m a + -> StreamK m a +mergeIterateWith combine f = iterateStream + + where + + iterateStream = mergeMapWith combine generate + + generate x = x `cons` iterateStream (f x) + +------------------------------------------------------------------------------ +-- Flattening Graphs +------------------------------------------------------------------------------ + +-- To traverse graphs we need a state to be carried around in the traversal. +-- For example, we can use a hashmap to store the visited status of nodes. + +-- XXX rename to concateIterateAccum? Like mapMAccum + +-- | Like 'iterateMap' but carries a state in the stream generation function. +-- This can be used to traverse graph like structures, we can remember the +-- visited nodes in the state to avoid cycles. +-- +-- Note that a combination of 'iterateMap' and 'usingState' can also be used to +-- traverse graphs. However, this function provides a more localized state +-- instead of using a global state. +-- +-- See also: 'mfix' +-- +-- /Pre-release/ +-- +{-# INLINE concatIterateScanWith #-} +concatIterateScanWith + :: Monad m + => (StreamK m a -> StreamK m a -> StreamK m a) + -> (b -> a -> m (b, StreamK m a)) + -> m b + -> StreamK m a + -> StreamK m a +concatIterateScanWith combine f initial stream = + concatEffect $ do + b <- initial + iterateStream (b, stream) + + where + + iterateStream (b, s) = pure $ concatMapWith combine (generate b) s + + generate b a = a `cons` feedback b a + + feedback b a = concatEffect $ f b a >>= iterateStream + +------------------------------------------------------------------------------ +-- Either streams +------------------------------------------------------------------------------ + +-- Keep concating either streams as long as rights are generated, stop as soon +-- as a left is generated and concat the left stream. +-- +-- See also: 'handle' +-- +-- /Unimplemented/ +-- +{- +concatMapEitherWith + :: (forall x. t m x -> t m x -> t m x) + -> (a -> t m (Either (StreamK m b) b)) + -> StreamK m a + -> StreamK m b +concatMapEitherWith = undefined +-} + +-- XXX We should prefer using the Maybe stream returning signatures over this. +-- This API should perhaps be removed in favor of those. + +-- | In an 'Either' stream iterate on 'Left's. This is a special case of +-- 'concatIterateWith': +-- +-- >>> concatIterateLeftsWith combine f = StreamK.concatIterateWith combine (either f (const StreamK.nil)) +-- +-- To traverse a directory tree: +-- +-- >>> input = StreamK.fromEffect (Left <$> Path.fromString ".") +-- >>> ls = StreamK.concatIterateLeftsWith StreamK.append (StreamK.fromStream . Dir.readEither id) input +-- +-- /Pre-release/ +-- +{-# INLINE concatIterateLeftsWith #-} +concatIterateLeftsWith + :: (b ~ Either a c) + => (StreamK m b -> StreamK m b -> StreamK m b) + -> (a -> StreamK m b) + -> StreamK m b + -> StreamK m b +concatIterateLeftsWith combine f = + concatIterateWith combine (either f (const nil)) + +------------------------------------------------------------------------------ +-- Interleaving +------------------------------------------------------------------------------ + +infixr 6 `interleave` + +-- We can have a variant of interleave where m elements yield from the first +-- stream and n elements yielding from the second stream. We can also have time +-- slicing variants of positional interleaving, e.g. run first stream for m +-- seconds and run the second stream for n seconds. +-- +-- TBD; give an example to show second stream is half consumed. +-- +-- a1,a2,a3,a4,a5,a6,a7,a8 +-- b1,b2,b3,b4,b5,b6,b7,b8 +-- c1,c2,c3,c4,c5,c6,c7,c8 +-- d1,d2,d3,d4,d5,d6,d7,d8 +-- e1,e2,e3,e4,e5,e6,e7,e8 +-- f1,f2,f3,f4,f5,f6,f7,f8 +-- g1,g2,g3,g4,g5,g6,g7,g8 +-- h1,h2,h3,h4,h5,h6,h7,h8 +-- +-- Produces: (..) +-- + +-- | Interleave two streams fairly, yielding one item from each in a +-- round-robin fashion: +-- +-- >>> un $ StreamK.interleave (mk [1,3,5]) (mk [2,4,6]) +-- [1,2,3,4,5,6] +-- >>> un $ StreamK.interleave (mk [1,3]) (mk [2,4,6]) +-- [1,2,3,4,6] +-- >>> un $ StreamK.interleave (mk []) (mk [2,4,6]) +-- [2,4,6] +-- +-- 'interleave' is right associative when used as an infix operator. +-- +-- >>> un $ mk [1,2,3] `StreamK.interleave` mk [4,5,6] `StreamK.interleave` mk [7,8,9] +-- [1,4,2,7,3,5,8,6,9] +-- +-- Because of right association, the first stream yields as many items as the +-- next two streams combined. +-- +-- Be careful when refactoring code involving a chain of three or more +-- 'interleave' operations as it is not associative i.e. right associated code +-- may not produce the same result as left associated. This is a direct +-- consequence of the disbalance of scheduling in the previous example. If left +-- associated the above example would produce: +-- +-- >>> un $ (mk [1,2,3] `StreamK.interleave` mk [4,5,6]) `StreamK.interleave` mk [7,8,9] +-- [1,7,4,8,2,9,5,3,6] +-- +-- Note: Use concatMap based interleaving instead of the binary operator to +-- interleave more than two streams to avoid associativity issues. +-- +-- 'concatMapWith' 'interleave' flattens a stream of streams using 'interleave' +-- in a right associative manner. Given a stream of three streams: +-- +-- @ +-- 1. [1,2,3] +-- 2. [4,5,6] +-- 3. [7,8,9] +-- @ +-- +-- The resulting sequence is @[1,4,2,7,3,5,8,6,9]@. +-- +-- For this reason, the right associated flattening with 'interleave' can work +-- with infinite number of streams without opening too many streams at the same +-- time. Each stream is consumed twice as much as the next one; if we are +-- combining an infinite number of streams of size @n@ then at most @log n@ +-- streams will be opened at any given time, because the first stream will +-- finish by the time the stream after @log n@ th stream is opened. +-- +-- Compare with 'bfsConcatMap' and 'mergeMapWith' 'interleave'. +-- +-- For interleaving many streams, the best way is to use 'bfsConcatMap'. +-- +-- See also the fused version 'Streamly.Data.Stream.interleave'. +{-# INLINE interleave #-} +interleave :: StreamK m a -> StreamK m a -> StreamK m a +interleave m1 m2 = mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp m2 + single a = yld a m2 + yieldk a r = yld a (interleave m2 r) + foldStream st yieldk single stop m1 + +-- Examples: +-- +-- >>> fromList = StreamK.fromStream . Stream.fromList +-- >>> toList = Stream.toList . StreamK.toStream +-- >>> f x y = toList $ StreamK.interleaveSepBy (fromList x) (fromList y) +-- +-- -- This is broken. +-- >> f "..." "abc" +-- "a.b.c" + +-- >>> f ".." "abc" +-- "a.b.c" +-- >>> f "." "abc" +-- "a.bc" +-- +{-# INLINE interleaveSepBy #-} +interleaveSepBy :: StreamK m a -> StreamK m a -> StreamK m a +interleaveSepBy m2 m1 = mkStream $ \st yld sng stp -> do + let yieldFirst a r = yld a (yieldSecond r m2) + in foldStream st yieldFirst sng stp m1 + + where + + yieldSecond s1 s2 = mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp s1 + single a = yld a s1 + yieldk a r = yld a (interleave s1 r) + in foldStream st yieldk single stop s2 + +infixr 6 `interleaveFst` + +{-# DEPRECATED interleaveFst "Please use flip interleaveSepBy instead." #-} +{-# INLINE interleaveFst #-} +interleaveFst :: StreamK m a -> StreamK m a -> StreamK m a +interleaveFst = flip interleaveSepBy + +-- | +-- +-- Examples: +-- +-- >>> fromList = StreamK.fromStream . Stream.fromList +-- >>> toList = Stream.toList . StreamK.toStream +-- >>> f x y = toList $ StreamK.interleaveEndBy' (fromList x) (fromList y) +-- >>> f "..." "abc" +-- "a.b.c." +-- >>> f "..." "ab" +-- "a.b." +-- +-- Currently broken, generates an additional element at the end:: +-- +-- >> f ".." "abc" +-- "a.b." +-- +{-# INLINE interleaveEndBy' #-} +interleaveEndBy' :: StreamK m a -> StreamK m a -> StreamK m a +interleaveEndBy' m2 m1 = mkStream $ \st yld _ stp -> do + let stop = stp + -- "single a" is defined as "yld a (interleaveMin m2 nil)" instead of + -- "sng a" to keep the behaviour consistent with the yield + -- continuation. + single a = yld a (interleaveEndBy' nil m2) + yieldk a r = yld a (interleaveEndBy' r m2) + foldStream st yieldk single stop m1 + +infixr 6 `interleaveMin` + +{-# DEPRECATED interleaveMin "Please use flip interleaveEndBy' instead." #-} +{-# INLINE interleaveMin #-} +interleaveMin :: StreamK m a -> StreamK m a -> StreamK m a +interleaveMin = flip interleaveEndBy' + +------------------------------------------------------------------------------- +-- Generation +------------------------------------------------------------------------------- + +-- | +-- >>> :{ +-- unfoldr step s = +-- case step s of +-- Nothing -> StreamK.nil +-- Just (a, b) -> a `StreamK.cons` unfoldr step b +-- :} +-- +-- Build a stream by unfolding a /pure/ step function @step@ starting from a +-- seed @s@. The step function returns the next element in the stream and the +-- next seed value. When it is done it returns 'Nothing' and the stream ends. +-- For example, +-- +-- >>> :{ +-- let f b = +-- if b > 2 +-- then Nothing +-- else Just (b, b + 1) +-- in StreamK.toList $ StreamK.unfoldr f 0 +-- :} +-- [0,1,2] +-- +{-# INLINE unfoldr #-} +unfoldr :: (b -> Maybe (a, b)) -> b -> StreamK m a +unfoldr next s0 = build $ \yld stp -> + let go s = + case next s of + Just (a, b) -> yld a (go b) + Nothing -> stp + in go s0 + +{-# INLINE unfoldrMWith #-} +unfoldrMWith :: Monad m => + (m a -> StreamK m a -> StreamK m a) + -> (b -> m (Maybe (a, b))) + -> b + -> StreamK m a +unfoldrMWith cns step = go + + where + + go s = sharedMWith cns $ \yld _ stp -> do + r <- step s + case r of + Just (a, b) -> yld a (go b) + Nothing -> stp + +-- | Build a stream by unfolding a /monadic/ step function starting from a +-- seed. The step function returns the next element in the stream and the next +-- seed value. When it is done it returns 'Nothing' and the stream ends. For +-- example, +-- +-- >>> :{ +-- let f b = +-- if b > 2 +-- then return Nothing +-- else return (Just (b, b + 1)) +-- in StreamK.toList $ StreamK.unfoldrM f 0 +-- :} +-- [0,1,2] +-- +{-# INLINE unfoldrM #-} +unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> StreamK m a +unfoldrM = unfoldrMWith consM + +-- | Generate an infinite stream by repeating a pure value. +-- +-- >>> repeat x = let xs = StreamK.cons x xs in xs +-- +-- /Pre-release/ +{-# INLINE repeat #-} +repeat :: a -> StreamK m a +repeat x = let xs = cons x xs in xs + +-- | Like 'repeatM' but takes a stream 'cons' operation to combine the actions +-- in a stream specific manner. A serial cons would repeat the values serially +-- while an async cons would repeat concurrently. +-- +-- /Pre-release/ +repeatMWith :: (m a -> t m a -> t m a) -> m a -> t m a +repeatMWith cns = go + + where + + go m = m `cns` go m + +{-# INLINE replicateMWith #-} +replicateMWith :: (m a -> StreamK m a -> StreamK m a) -> Int -> m a -> StreamK m a +replicateMWith cns n m = go n + + where + + go cnt = if cnt <= 0 then nil else m `cns` go (cnt - 1) + +{-# INLINE fromIndicesMWith #-} +fromIndicesMWith :: + (m a -> StreamK m a -> StreamK m a) -> (Int -> m a) -> StreamK m a +fromIndicesMWith cns gen = go 0 + + where + + go i = mkStream $ \st stp sng yld -> do + foldStreamShared st stp sng yld (gen i `cns` go (i + 1)) + +{-# INLINE iterateMWith #-} +iterateMWith :: Monad m => + (m a -> StreamK m a -> StreamK m a) -> (a -> m a) -> m a -> StreamK m a +iterateMWith cns step = go + + where + + go s = mkStream $ \st stp sng yld -> do + !next <- s + foldStreamShared st stp sng yld (return next `cns` go (step next)) + +-- | head for non-empty streams, fails for empty stream case. +-- +{-# INLINE headNonEmpty #-} +headNonEmpty :: Monad m => StreamK m a -> m a +headNonEmpty = foldrM (\x _ -> return x) (error "headNonEmpty: empty stream") + +-- | init for non-empty streams, fails for empty stream case. +-- +-- See also 'init' for a non-partial version of this function.. +{-# INLINE initNonEmpty #-} +initNonEmpty :: Stream m a -> Stream m a +initNonEmpty = go0 + + where + + go0 m = mkStream $ \st yld sng stp -> + let stop = error "initNonEmpty: Empty Stream." + single _ = stp + yieldk a r = foldStream st yld sng stp (go1 a r) + in foldStream st yieldk single stop m + + go1 a r = mkStream $ \st yld sng stp -> + let stop = stp + single _ = sng a + yieldk a1 r1 = yld a (go1 a1 r1) + in foldStream st yieldk single stop r + +-- | tail for non-empty streams, fails for empty stream case. +-- +-- See also 'tail' for a non-partial version of this function.. +-- +-- Note: this is same as "drop 1" with error on empty stream. +{-# INLINE tailNonEmpty #-} +tailNonEmpty :: StreamK m a -> StreamK m a +tailNonEmpty m = mkStream $ \st yld sng stp -> + let stop = error "tailNonEmpty: empty stream" + single _ = stp + yieldk _ r = foldStream st yld sng stp r + in foldStream st yieldk single stop m + +-- | We can define cyclic structures using @let@: +-- +-- >>> :set -fno-warn-unrecognised-warning-flags +-- >>> :set -fno-warn-x-partial +-- >>> let (a, b) = ([1, b], head a) in (a, b) +-- ([1,1],1) +-- +-- The function @fix@ defined as: +-- +-- >>> fix f = let x = f x in x +-- +-- ensures that the argument of a function and its output refer to the same +-- lazy value @x@ i.e. the same location in memory. Thus @x@ can be defined +-- in terms of itself, creating structures with cyclic references. +-- +-- >>> f ~(a, b) = ([1, b], head a) +-- >>> fix f +-- ([1,1],1) +-- +-- 'Control.Monad.mfix' is essentially the same as @fix@ but for monadic +-- values. +-- +-- Using 'mfix' for streams we can construct a stream in which each element of +-- the stream is defined in a cyclic fashion. The argument of the function +-- being fixed represents the current element of the stream which is being +-- returned by the stream monad. Thus, we can use the argument to construct +-- itself. +-- +-- In the following example, the argument @action@ of the function @f@ +-- represents the tuple @(x,y)@ returned by it in a given iteration. We define +-- the first element of the tuple in terms of the second. +-- +-- >>> import System.IO.Unsafe (unsafeInterleaveIO) +-- +-- >>> :{ +-- main = Stream.fold (Fold.drainMapM print) $ StreamK.toStream $ StreamK.mfix f +-- where +-- f action = StreamK.unNested $ do +-- let incr n act = fmap ((+n) . snd) $ unsafeInterleaveIO act +-- x <- StreamK.Nested $ StreamK.fromStream $ Stream.sequence $ Stream.fromList [incr 1 action, incr 2 action] +-- y <- StreamK.Nested $ StreamK.fromStream $ Stream.fromList [4,5] +-- return (x, y) +-- :} +-- +-- Note: you cannot achieve this by just changing the order of the monad +-- statements because that would change the order in which the stream elements +-- are generated. +-- +-- Note that the function @f@ must be lazy in its argument, that's why we use +-- 'unsafeInterleaveIO' on @action@ because IO monad is strict. +-- +-- /Pre-release/ +{-# INLINE mfix #-} +mfix :: Monad m => (m a -> StreamK m a) -> StreamK m a +mfix f = mkStream $ \st yld sng stp -> + let single a = foldStream st yld sng stp $ a `cons` ys + yieldk a _ = foldStream st yld sng stp $ a `cons` ys + in foldStream st yieldk single stp xs + + where + + -- fix the head element of the stream + xs = fix (f . headNonEmpty) + + -- now fix the tail recursively + ys = mfix (tailNonEmpty . f) + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +-- | +-- >>> fromFoldable = Prelude.foldr StreamK.cons StreamK.nil +-- +-- Construct a stream from a 'Foldable' containing pure values: +-- +{-# INLINE fromFoldable #-} +fromFoldable :: Foldable f => f a -> StreamK m a +fromFoldable = Prelude.foldr cons nil + +{-# INLINE fromFoldableM #-} +fromFoldableM :: (Foldable f, Monad m) => f (m a) -> StreamK m a +fromFoldableM = Prelude.foldr consM nil + +{-# INLINE fromList #-} +fromList :: [a] -> StreamK m a +fromList = fromFoldable + +------------------------------------------------------------------------------- +-- Deconstruction +------------------------------------------------------------------------------- + +{-# INLINE uncons #-} +uncons :: Applicative m => StreamK m a -> m (Maybe (a, StreamK m a)) +uncons m = + let stop = pure Nothing + single a = pure (Just (a, nil)) + yieldk a r = pure (Just (a, r)) + in foldStream defState yieldk single stop m + +-- Note that this is not a StreamK -> StreamK because then we cannot handle the +-- empty stream case without making this a partial function. +-- +-- See tailNonEmpty as well above. + +-- | Same as: +-- +-- >>> tail = fmap (fmap snd) . StreamK.uncons +-- +{-# INLINE tail #-} +tail :: Applicative m => StreamK m a -> m (Maybe (StreamK m a)) +tail = + let stop = pure Nothing + single _ = pure $ Just nil + yieldk _ r = pure $ Just r + in foldStream defState yieldk single stop + +-- Note that this is not a StreamK -> StreamK because then we cannot handle the +-- empty stream case without making this a partial function. +-- +-- XXX How do we implement unsnoc? Make StreamK a monad and return the +-- remaining stream as a result value in the monad? + +-- | Extract all but the last element of the stream, if any. This will end up +-- evaluating the last element as well to find out that it is last. +-- +-- /Pre-release/ +{-# INLINE init #-} +init :: Applicative m => StreamK m a -> m (Maybe (StreamK m a)) +init = go1 + where + go1 m1 = do + (\case + Nothing -> Nothing + Just (h, t) -> Just $ go h t) <$> uncons m1 + go p m1 = mkStream $ \_ yld sng stp -> + let single _ = sng p + yieldk a x = yld p $ go a x + in foldStream defState yieldk single stp m1 + +------------------------------------------------------------------------------ +-- Reordering +------------------------------------------------------------------------------ + +-- | Lazy left fold to a stream. +{-# INLINE foldlS #-} +foldlS :: + (StreamK m b -> a -> StreamK m b) -> StreamK m b -> StreamK m a -> StreamK m b +foldlS step = go + where + go acc rest = mkStream $ \st yld sng stp -> + let run x = foldStream st yld sng stp x + stop = run acc + single a = run $ step acc a + yieldk a r = run $ go (step acc a) r + in foldStream (adaptState st) yieldk single stop rest + +{-# INLINE reverse #-} +reverse :: StreamK m a -> StreamK m a +reverse = foldlS (flip cons) nil + +------------------------------------------------------------------------------ +-- Running effects +------------------------------------------------------------------------------ + +-- | Run an action before evaluating the stream. +{-# INLINE before #-} +before :: Monad m => m b -> StreamK m a -> StreamK m a +before action stream = + mkStream $ \st yld sng stp -> + action >> foldStreamShared st yld sng stp stream + +-- XXX Rename to "impure" (opposite of pure) or "purely". +{-# INLINE concatEffect #-} +concatEffect :: Monad m => m (StreamK m a) -> StreamK m a +concatEffect action = + mkStream $ \st yld sng stp -> + action >>= foldStreamShared st yld sng stp + +{-# INLINE concatMapEffect #-} +concatMapEffect :: Monad m => (b -> StreamK m a) -> m b -> StreamK m a +concatMapEffect f action = + mkStream $ \st yld sng stp -> + action >>= foldStreamShared st yld sng stp . f + +------------------------------------------------------------------------------ +-- Stream with a cross product style monad instance +------------------------------------------------------------------------------ + +-- XXX add Alternative, MonadPlus - should we use interleave as the Semigroup +-- append operation in FairNested? + +-- | 'Nested' is a list-transformer monad, it serves the same purpose as the +-- @ListT@ type from the @list-t@ package. It is similar to the standard +-- Haskell lists' monad instance. 'Nested' monad behaves like nested @for@ loops +-- implementing a computation based on a cross product over multiple streams. +-- +-- >>> mk = StreamK.Nested . StreamK.fromStream . Stream.fromList +-- >>> un = Stream.toList . StreamK.toStream . StreamK.unNested +-- +-- == Looping +-- +-- In the following code the variable @x@ assumes values of the elements of the +-- stream one at a time and runs the code that follows; using that value. It is +-- equivalent to a @for@ loop: +-- +-- >>> :{ +-- un $ do +-- x <- mk [1,2,3] -- for each element in the stream +-- return x +-- :} +-- [1,2,3] +-- +-- == Nested Looping +-- +-- Multiple streams can be nested like nested @for@ loops. The result is a +-- cross product of the streams. +-- +-- >>> :{ +-- un $ do +-- x <- mk [1,2,3] -- outer loop, for each element in the stream +-- y <- mk [4,5,6] -- inner loop, for each element in the stream +-- return (x, y) +-- :} +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +-- Note that an infinite stream in an inner loop will block the outer streams +-- from moving to the next iteration. +-- +-- == How it works? +-- +-- The bind operation of the monad is flipped 'concatMapWith' 'append'. The +-- concatMap operation maps the lines involving y as a function of x over the +-- stream [1,2,3]. The streams generated so are combined using the 'append' +-- operation. If we desugar the above monad code using bind explicitly, it +-- becomes clear how it works: +-- +-- >>> import Streamly.Internal.Data.StreamK (Nested(..)) +-- >>> (Nested m) >>= f = Nested $ StreamK.concatMapWith StreamK.append (unNested . f) m +-- >>> un (mk [1,2,3] >>= (\x -> (mk [4,5,6] >>= \y -> return (x,y)))) +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +-- You can achieve the looping and nested looping by directly using concatMap +-- but the monad and the \"do notation\" gives you better ergonomics. +-- +-- == Interleaving of loop iterations +-- +-- If we look at the cross product of [1,2,3], [4,5,6], the streams being +-- combined using 'append' are the @for@ loop iterations as follows: +-- +-- @ +-- (1,4) (1,5) (1,6) -- first iteration of the outer loop +-- (2,4) (2,5) (2,6) -- second iteration of the outer loop +-- (3,4) (3,5) (3,6) -- third iteration of the outer loop +-- @ +-- +-- The result is equivalent to sequentially appending all the iterations of the +-- nested @for@ loop: +-- +-- @ +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- @ +-- +-- == Logic Programming +-- +-- 'Nested' also serves the purpose of 'LogicT' type from the 'logict' package. +-- The @MonadLogic@ operations can be implemented using the available stream +-- operations. For example, 'uncons' is @msplit@, 'interleave' corresponds to +-- the @interleave@ operation of MonadLogic, 'fairConcatFor' is the +-- fair bind (@>>-@) operation. The 'FairNested' type provides a monad with fair +-- bind. +-- +-- == Related Functionality +-- +-- A custom type can be created using 'bfsConcatMap' as the monad bind +-- operation then the nested loops would get inverted - the innermost loop +-- becomes the outermost and vice versa. +-- +-- See 'FairNested' if you want all the streams to get equal chance to execute +-- even if they are infinite. +newtype Nested m a = Nested {unNested :: StreamK m a} + deriving (Functor, Semigroup, Monoid, Foldable) + +{-# DEPRECATED CrossStreamK "Use Nested instead." #-} +type CrossStreamK = Nested + +{-# DEPRECATED mkCross "Use Nested instead." #-} +-- | Wrap the 'StreamK' type in a 'Nested' newtype to enable cross +-- product style applicative and monad instances. +-- +-- This is a type level operation with no runtime overhead. +{-# INLINE mkCross #-} +mkCross :: StreamK m a -> Nested m a +mkCross = Nested + +-- | Unwrap the 'StreamK' type from 'CrossStreamK' newtype. +-- +-- This is a type level operation with no runtime overhead. +{-# INLINE unCross #-} +unCross :: CrossStreamK m a -> StreamK m a +unCross = unNested + +-- Pure (Identity monad) stream instances +deriving instance Traversable (Nested Identity) +deriving instance IsList (Nested Identity a) +deriving instance (a ~ Char) => IsString (Nested Identity a) +-- deriving instance Eq a => Eq (Nested Identity a) +-- deriving instance Ord a => Ord (Nested Identity a) + +-- Do not use automatic derivation for this to show as "fromList" rather than +-- "fromList Identity". +instance Show a => Show (Nested Identity a) where + {-# INLINE show #-} + show (Nested xs) = show xs + +instance Read a => Read (Nested Identity a) where + {-# INLINE readPrec #-} + readPrec = fmap Nested readPrec + +------------------------------------------------------------------------------ +-- Applicative +------------------------------------------------------------------------------ + +-- Note: we need to define all the typeclass operations because we want to +-- INLINE them. +instance Monad m => Applicative (Nested m) where + {-# INLINE pure #-} + pure x = Nested (fromPure x) + + {-# INLINE (<*>) #-} + (Nested s1) <*> (Nested s2) = + Nested (crossApply s1 s2) + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + + {-# INLINE (*>) #-} + (Nested s1) *> (Nested s2) = + Nested (crossApplySnd s1 s2) + + {-# INLINE (<*) #-} + (Nested s1) <* (Nested s2) = + Nested (crossApplyFst s1 s2) + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + +instance Monad m => Monad (Nested m) where + return = pure + + -- Benchmarks better with CPS bind and pure: + -- Prime sieve (25x) + -- n binds, breakAfterSome, filterAllIn, state transformer (~2x) + -- + {-# INLINE (>>=) #-} + (>>=) (Nested m) f = + Nested (bindWith append m (unNested . f)) + + {-# INLINE (>>) #-} + (>>) = (*>) + +------------------------------------------------------------------------------ +-- Alternative and MonadPlus +------------------------------------------------------------------------------ + +instance (Monad m) => Fail.MonadFail (Nested m) where + fail _ = inline mempty + +instance (Monad m, Functor m) => Alternative (Nested m) where + empty = inline mempty + (<|>) = inline mappend + +instance (Monad m) => MonadPlus (Nested m) where + mzero = inline mempty + mplus = inline mappend + +------------------------------------------------------------------------------ +-- Transformers +------------------------------------------------------------------------------ + +instance (MonadIO m) => MonadIO (Nested m) where + liftIO x = Nested (fromEffect $ liftIO x) + +instance MonadTrans Nested where + {-# INLINE lift #-} + lift x = Nested (fromEffect x) + +instance (MonadThrow m) => MonadThrow (Nested m) where + throwM = lift . throwM + +------------------------------------------------------------------------------ +-- Stream with a fair cross product style monad instance +------------------------------------------------------------------------------ + +-- XXX We can fix the termination issues by adding a "skip" continuation in the +-- stream. Adding a "block" continuation can allow for blocking IO. Both of +-- these together will provide a co-operative scheduling. However, adding skip +-- will regress performance in heavy filtering cases. If that's important we +-- can create another type StreamK' for skip continuation. That type can use +-- conversion from Stream type for everything except append and concatMap. + +-- | 'FairNested' is like the 'Nested' type but explores the depth and breadth of +-- the cross product grid equally, so that each of the stream being crossed is +-- consumed equally. It can be used to nest infinite streams without starving +-- one due to the other. +-- +-- >>> mk = StreamK.FairNested . StreamK.fromStream . Stream.fromList +-- >>> un = Stream.toList . StreamK.toStream . StreamK.unFairNested +-- +-- == Looping +-- +-- A single stream case is equivalent to 'Nested', it is a simple @for@ loop +-- over the stream: +-- +-- >>> :{ +-- un $ do +-- x <- mk [1,2] -- for each element in the stream +-- return x +-- :} +-- [1,2] +-- +-- == Fair Nested Looping +-- +-- Multiple streams nest like @for@ loops. The result is a cross product of the +-- streams. However, the ordering of the results of the cross product is such +-- that each stream gets consumed equally. In other words, inner iterations of +-- a nested loop get the same priority as the outer iterations. Inner +-- iterations do not finish completely before the outer iterations start. +-- +-- >>> :{ +-- un $ do +-- x <- mk [1,2,3] -- outer, for each element in the stream +-- y <- mk [4,5,6] -- inner, for each element in the stream +-- -- Perform the following actions for each x, for each y +-- return (x, y) +-- :} +-- [(1,4),(1,5),(2,4),(1,6),(2,5),(3,4),(2,6),(3,5),(3,6)] +-- +-- == Nesting Infinite Streams +-- +-- Example with infinite streams. Print all pairs in the cross product with sum +-- less than a specified number. +-- +-- >>> :{ +-- Stream.toList +-- $ Stream.takeWhile (\(x,y) -> x + y < 6) +-- $ StreamK.toStream $ StreamK.unFairNested +-- $ do +-- x <- mk [1..] -- infinite stream +-- y <- mk [1..] -- infinite stream +-- return (x, y) +-- :} +-- [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(1,4),(2,3),(3,2),(4,1)] +-- +-- == How it works? +-- +-- 'FairNested' uses 'fairConcatFor' as the monad bind operation. +-- If we look at the cross product of [1,2,3], [4,5,6], the streams being +-- combined using 'concatMapDigaonal' are the sequential loop iterations: +-- +-- @ +-- (1,4) (1,5) (1,6) -- first iteration of the outer loop +-- (2,4) (2,5) (2,6) -- second iteration of the outer loop +-- (3,4) (3,5) (3,6) -- third iteration of the outer loop +-- @ +-- +-- The result is a triangular or diagonal traversal of these iterations: +-- +-- @ +-- [(1,4),(1,5),(2,4),(1,6),(2,5),(3,4),(2,6),(3,5),(3,6)] +-- @ +-- +-- == Associativity Issues +-- +-- WARNING! The FairNested monad breaks the associativity law intentionally for +-- usefulness, it is associative only up to permutation equivalence. In this +-- monad the association order of statements might make a difference to the +-- ordering of the results because of changing the way in which streams are +-- scheduled. The same issues arise when you use the 'interleave' operation +-- directly, association order matters - however, here it can be more subtle as +-- the programmer may not see it directly. +-- +-- >>> un (mk [1,2] >>= (\x -> mk [x, x + 1] >>= (\y -> mk [y, y + 2]))) +-- [1,3,2,2,4,4,3,5] +-- >>> un ((mk [1,2] >>= (\x -> mk [x, x + 1])) >>= (\y -> mk [y, y + 2])) +-- [1,3,2,4,2,4,3,5] +-- +-- This type is designed to be used for use cases where ordering of results +-- does not matter, we want to explore different streams to find specific +-- results, but the order in which we find or present the results may not be +-- important. Re-association of statements in this monad may change how different +-- branches are scheduled, which may change the scheduling priority of some +-- streams over others, this may end up starving some branches - in the worst +-- case some branches may be fully starved by some infinite branches producing +-- nothing - resulting in a non-terminating program. +-- +-- == Non-Termination Cases +-- +-- If an infinite stream that does not produce a value at all is interleaved +-- with another stream then the entire computation gets stuck forever because +-- the interleave operation schedules the second stream only after the first +-- stream yields a value. This can lead to non-terminating programs, an example +-- is provided below. +-- +-- >>> :{ +-- toS = StreamK.toStream . StreamK.unFairNested +-- odds x = mk (if x then [1,3..] else [2,4..]) +-- filterEven x = if even x then pure x else StreamK.FairNested StreamK.nil +-- :} +-- +-- When writing code with do notation, keep in mind that when we bind a +-- variable to a monadic value, all the following code that depends on this +-- variable is associated together and connected to it via a monad bind. +-- Consider the following code: +-- +-- >>> :{ +-- evens = toS $ do +-- r <- mk [True,False] +-- -- The next two statements depending on the variable r are associated +-- -- together and bound to the previous line using a monad bind. +-- x <- odds r +-- filterEven x +-- :} +-- +-- This code does not terminate because, when r is True, @odds@ and +-- @filterEven@ together constitute an infinite inner loop, coninuously working +-- but not yielding any value at all, this stream is interleaved with the outer +-- loop, therefore, the outer loop does not get a chance to move to the next +-- iteration. +-- +-- But the following code works as expected: +-- +-- >>> :{ +-- evens = toS $ do +-- x <- mk [True,False] >>= odds +-- filterEven x +-- :} +-- +-- >>> Stream.toList $ Stream.take 3 $ evens +-- [2,4,6] +-- +-- This works because both the lists being interleaved continue to produce +-- values in the outer loop and the inner loop keeps filtering them. +-- +-- Care should be taken how you write your program, keep in mind the scheduling +-- implications. To avoid such scheduling problems in the serial FairNested type +-- use the concurrent version i.e. FairParallel described in +-- 'Streamly.Data.Stream.MkType' module. Due to concurrent evaluation each +-- branch will make progress even if one is an infinite loop producing nothing. +-- +-- == Related Operations +-- +-- We can create a custom type with 'concatMapWith' 'interleave' as the monad +-- bind operation then the inner loop iterations get exponentially more +-- priority over the outer iterations of the nested loop. This is not fully +-- fair, it is biased - this is exactly how the logic-t and list-t +-- implementation of fair bind works. + +newtype FairNested m a = FairNested {unFairNested :: StreamK m a} + deriving (Functor, Foldable) + +-- Pure (Identity monad) stream instances +deriving instance Traversable (FairNested Identity) +deriving instance IsList (FairNested Identity a) +deriving instance (a ~ Char) => IsString (FairNested Identity a) +-- deriving instance Eq a => Eq (FairNested Identity a) +-- deriving instance Ord a => Ord (FairNested Identity a) + +-- Do not use automatic derivation for this to show as "fromList" rather than +-- "fromList Identity". +instance Show a => Show (FairNested Identity a) where + {-# INLINE show #-} + show (FairNested xs) = show xs + +instance Read a => Read (FairNested Identity a) where + {-# INLINE readPrec #-} + readPrec = fmap FairNested readPrec + +------------------------------------------------------------------------------ +-- Applicative +------------------------------------------------------------------------------ + +-- Note: we need to define all the typeclass operations because we want to +-- INLINE them. +instance Monad m => Applicative (FairNested m) where + {-# INLINE pure #-} + pure x = FairNested (fromPure x) + + -- XXX implement more efficient version of these + (<*>) = ap + {- + {-# INLINE (<*>) #-} + (FairNested s1) <*> (FairNested s2) = + FairNested (crossApply s1 s2) + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + + {-# INLINE (*>) #-} + (FairNested s1) *> (FairNested s2) = + FairNested (crossApplySnd s1 s2) + + {-# INLINE (<*) #-} + (FairNested s1) <* (FairNested s2) = + FairNested (crossApplyFst s1 s2) + -} + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + +instance Monad m => Monad (FairNested m) where + return = pure + + {-# INLINE (>>=) #-} + (>>=) (FairNested m) f = FairNested (fairConcatMap (unFairNested . f) m) + + -- {-# INLINE (>>) #-} + -- (>>) = (*>) + +------------------------------------------------------------------------------ +-- Transformers +------------------------------------------------------------------------------ + +instance (MonadIO m) => MonadIO (FairNested m) where + liftIO x = FairNested (fromEffect $ liftIO x) + +instance MonadTrans FairNested where + {-# INLINE lift #-} + lift x = FairNested (fromEffect x) + +instance (MonadThrow m) => MonadThrow (FairNested m) where + throwM = lift . throwM diff --git a/src/Streamly/Internal/Data/Time/Clock.hs b/src/Streamly/Internal/Data/Time/Clock.hs --- a/src/Streamly/Internal/Data/Time/Clock.hs +++ b/src/Streamly/Internal/Data/Time/Clock.hs @@ -9,8 +9,7 @@ module Streamly.Internal.Data.Time.Clock ( -- * System clock - Clock(..) - , getTime + module Streamly.Internal.Data.Time.Clock.Type -- * Async clock , asyncClock @@ -30,12 +29,13 @@ import Control.Concurrent (threadDelay, ThreadId) import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, tryPutMVar) import Control.Monad (forever, when, void) -import Streamly.Internal.Data.Time.Clock.Type (Clock(..), getTime) import Streamly.Internal.Data.Time.Units (MicroSecond64(..), fromAbsTime, addToAbsTime, toRelTime) import Streamly.Internal.Control.ForkIO (forkIOManaged) -import qualified Streamly.Internal.Data.IORef.Unboxed as Unboxed +import qualified Streamly.Internal.Data.IORef as Unboxed + +import Streamly.Internal.Data.Time.Clock.Type ------------------------------------------------------------------------------ -- Async clock diff --git a/src/Streamly/Internal/Data/Time/Clock/Type.hsc b/src/Streamly/Internal/Data/Time/Clock/Type.hsc --- a/src/Streamly/Internal/Data/Time/Clock/Type.hsc +++ b/src/Streamly/Internal/Data/Time/Clock/Type.hsc @@ -228,7 +228,7 @@ #elif HS_CLOCK_OSX -- XXX perform error checks inside c implementation -foreign import ccall +foreign import ccall unsafe clock_gettime_darwin :: #{type clock_id_t} -> Ptr TimeSpec -> IO () {-# INLINABLE getTime #-} @@ -238,10 +238,10 @@ #elif HS_CLOCK_WINDOWS -- XXX perform error checks inside c implementation -foreign import ccall clock_gettime_win32_monotonic :: Ptr TimeSpec -> IO () -foreign import ccall clock_gettime_win32_realtime :: Ptr TimeSpec -> IO () -foreign import ccall clock_gettime_win32_processtime :: Ptr TimeSpec -> IO () -foreign import ccall clock_gettime_win32_threadtime :: Ptr TimeSpec -> IO () +foreign import ccall unsafe clock_gettime_win32_monotonic :: Ptr TimeSpec -> IO () +foreign import ccall unsafe clock_gettime_win32_realtime :: Ptr TimeSpec -> IO () +foreign import ccall unsafe clock_gettime_win32_processtime :: Ptr TimeSpec -> IO () +foreign import ccall unsafe clock_gettime_win32_threadtime :: Ptr TimeSpec -> IO () {-# INLINABLE getTime #-} getTime :: Clock -> IO AbsTime diff --git a/src/Streamly/Internal/Data/Time/Units.hs b/src/Streamly/Internal/Data/Time/Units.hs --- a/src/Streamly/Internal/Data/Time/Units.hs +++ b/src/Streamly/Internal/Data/Time/Units.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedTuples #-} - -- | -- Module : Streamly.Internal.Data.Time.Units -- Copyright : (c) 2019 Composewell Technologies @@ -52,7 +49,7 @@ import Data.Int import Foreign.Storable (Storable) -import Streamly.Internal.Data.Unboxed (Unbox) +import Streamly.Internal.Data.Unbox (Unbox) import Streamly.Internal.Data.Time.TimeSpec ------------------------------------------------------------------------------- diff --git a/src/Streamly/Internal/Data/Unbox.hs b/src/Streamly/Internal/Data/Unbox.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Unbox.hs @@ -0,0 +1,923 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{- HLINT ignore -} + +-- | +-- Module : Streamly.Internal.Data.Unbox +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Unbox + ( + -- ** Unbox type class + Unbox(..) + + -- ** Peek and poke utilities + , BoundedPtr (..) + -- Peek + , Peeker (..) + , read + , readUnsafe + , skipByte + , runPeeker + -- Poke + , pokeBoundedPtrUnsafe + , pokeBoundedPtr + + -- ** Generic Deriving + , PeekRep(..) + , PokeRep(..) + , SizeOfRep(..) + , genericSizeOf + , genericPeekByteIndex + , genericPokeByteIndex + ) where + +#include "MachDeps.h" +#include "HsBaseConfig.h" +#include "ArrayMacros.h" + +import Control.Monad (void, when) +import Data.Complex (Complex((:+))) +import Data.Functor ((<&>)) +import Data.Functor.Const (Const(..)) +import Data.Functor.Identity (Identity(..)) +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import Foreign.C.Types (CChar(..), CWchar(..)) +import Foreign.Ptr (IntPtr(..), WordPtr(..)) +import GHC.Base (IO(..)) +import GHC.Fingerprint.Type (Fingerprint(..)) +import GHC.Int (Int16(..), Int32(..), Int64(..), Int8(..)) +import GHC.Real (Ratio(..)) +import GHC.Stable (StablePtr(..)) +import GHC.Word (Word16(..), Word32(..), Word64(..), Word8(..)) +#if MIN_VERSION_base(4,21,0) +import GHC.IO.SubSystem (IoSubSystem (..)) +#elif MIN_VERSION_base(4,15,0) +import GHC.RTS.Flags (IoSubSystem(..)) +#endif +import Streamly.Internal.Data.Builder (Builder (..)) + +import GHC.Generics +import GHC.Exts +import GHC.TypeLits +import Prelude hiding (read) + +import Streamly.Internal.Data.MutByteArray.Type (MutByteArray(..)) +#ifdef DEBUG +import qualified Streamly.Internal.Data.MutByteArray.Type as MutByteArray +#endif + +-------------------------------------------------------------------------------- +-- The Unbox type class +-------------------------------------------------------------------------------- + +-- XXX generate error if the size is < 1 + +-- = Design notes = +-- +-- == Fixed length data types == +-- +-- The main goal of the Unbox type class is to be used in arrays. Invariants +-- for the sizeOf value required for use in arrays: +-- +-- * size is independent of the value, it is determined by the type only. So +-- that we can store values of the same type in fixed length array cells. +-- * recursive data types cannot be fixed length, therefore, cannot be +-- serialized using this type class. +-- * size cannot be zero. So that the length of an array storing the element +-- and the number of elements can be related. +-- +-- Note, for general serializable types the size cannot be fixed e.g. we may +-- want to serialize a list. This type class can be considered a special case +-- of a more general serialization type class. +-- +-- == Stream vs Array == +-- +-- In theory we could convert a type to and from a byte stream and use that +-- to implement boxing, unboxing. But composing a stream from parts of the +-- structure is much more inefficient than writing them to a memory location. +-- However, it should be possible to efficiently parse a Haskell type from an +-- array using chunk folds. +-- +-- Also, this type class allows each primitive type to have its own specific +-- efficient implementation to read and write the type to the mutable byte +-- array using special GHC byte array operations. For example, see the Unbox +-- instances of Char, Int, Word types. +-- +-- == MutableByteArray vs ForeignPtr == +-- +-- The Unbox typeclass uses MutableByteArray but could use ForeignPtr or +-- any other representation of memory. We could make this a multiparameter type +-- class if necessary. +-- +-- If the type class would have to support reading and writing to a Ptr as well, +-- basically what Storable does. We will also need to touch the anchoring ptr at +-- the right points which is prone to errors. However, it should be simple to +-- implement unmanaged/read-only memory arrays by allowing a Ptr type in +-- ArrayContents, though it would require all instances to support reading from +-- a Ptr. +-- +-- == Byte Offset vs Element Index == +-- +-- There is a reason for using byte offset instead of element index in read and +-- write operations in the type class. If we use element index, slicing of the +-- array becomes rigid. We can only slice the array at addresses that are +-- aligned with the type, therefore, we cannot slice at misaligned location and +-- then cast the slice into another type which does not necessarily align with +-- the original type. +-- +-- == Alignment == +-- +-- As a side note, there seem to be no performance advantage of alignment +-- anymore, see +-- https://lemire.me/blog/2012/05/31/data-alignment-for-speed-myth-or-reality/ +-- +-- = Unboxed Records = +-- +-- Unboxed types can be treated as unboxed records. We can provide a more +-- convenient API to access different parts from the Unboxed representation +-- without having to unbox the entire type. The type can have nested parts +-- therefore, we will need a general way (some sort of lenses) to address the +-- parts. +-- +-- = Lazy Boxing = +-- +-- When converting an unboxed representation to a boxed representation we can +-- use lazy construction. Each constructor of the constructed computation may +-- just hold a lazy computation to actually construct it on demand. This could +-- be useful for larger structures where we may need only small parts of it. +-- +-- Same thing can be done for serialize type class as well but it will require +-- size fields at each nesting level, aggregating the size upwards. + +-- | The 'Unbox' type class provides operations for serialization (unboxing) +-- and deserialization (boxing) of fixed-length, non-recursive Haskell data +-- types to and from their byte stream representation. +-- +-- Unbox uses fixed size encoding, therefore, size is independent of the value, +-- it must be determined solely by the type. This restriction makes types with +-- 'Unbox' instances suitable for storing in arrays. Note that sum types may +-- have multiple constructors of different sizes, the size of a sum type is +-- computed as the maximum required by any constructor. +-- +-- The 'peekAt' operation reads as many bytes from the mutable byte +-- array as the @size@ of the data type and builds a Haskell data type from +-- these bytes. 'pokeAt' operation converts a Haskell data type to its +-- binary representation which consists of @size@ bytes and then stores +-- these bytes into the mutable byte array. These operations do not check the +-- bounds of the array, the user of the type class is expected to check the +-- bounds before peeking or poking. +-- +-- IMPORTANT: The serialized data's byte ordering remains the same as the host +-- machine's byte order. Therefore, it can not be deserialized from host +-- machines with a different byte ordering. +-- +-- Instances can be derived via Generics, Template Haskell, or written +-- manually. Note that the data type must be non-recursive. WARNING! Generic +-- and Template Haskell deriving, both hang for recursive data types. Deriving +-- via Generics is more convenient but Template Haskell should be preferred +-- over Generics for the following reasons: +-- +-- 1. Instances derived via Template Haskell provide better and more reliable +-- performance. +-- 2. Generic deriving allows only 256 fields or constructor tags whereas +-- template Haskell has no limit. +-- +-- Here is an example, for deriving an instance of this type class using +-- generics: +-- +-- >>> import GHC.Generics (Generic) +-- >>> :{ +-- data Object = Object +-- { _int0 :: Int +-- , _int1 :: Int +-- } deriving Generic +-- :} +-- +-- >>> import Streamly.Data.MutByteArray (Unbox(..)) +-- >>> instance Unbox Object +-- +-- To derive the instance via Template Haskell: +-- +-- @ +-- import Streamly.Data.MutByteArray (deriveUnbox) +-- \$(deriveUnbox [d|instance Unbox Object|]) +-- @ +-- +-- See 'Streamly.Data.MutByteArray.deriveUnbox' for more information on deriving +-- using Template Haskell. +-- +-- If you want to write the instance manually: +-- +-- >>> :{ +-- instance Unbox Object where +-- sizeOf _ = 16 +-- peekAt i arr = do +-- -- Check the array bounds +-- x0 <- peekAt i arr +-- x1 <- peekAt (i + 8) arr +-- return $ Object x0 x1 +-- pokeAt i arr (Object x0 x1) = do +-- -- Check the array bounds +-- pokeAt i arr x0 +-- pokeAt (i + 8) arr x1 +-- :} +-- +class Unbox a where + -- | Get the size. Size cannot be zero, should be at least 1 byte. + sizeOf :: Proxy a -> Int + + {-# INLINE sizeOf #-} + default sizeOf :: (SizeOfRep (Rep a)) => Proxy a -> Int + sizeOf = genericSizeOf + + -- | @peekAt byte-offset array@ reads an element of type @a@ from the + -- given byte offset in the array. + -- + -- IMPORTANT: The implementation of this interface may not check the bounds + -- of the array, the caller must not assume that. + peekAt :: Int -> MutByteArray -> IO a + + {-# INLINE peekAt #-} + default peekAt :: (Generic a, PeekRep (Rep a)) => + Int -> MutByteArray -> IO a + peekAt i arr = genericPeekByteIndex arr i + + peekByteIndex :: Int -> MutByteArray -> IO a + peekByteIndex = peekAt + + -- | @pokeAt byte-offset array@ writes an element of type @a@ to the + -- given byte offset in the array. + -- + -- IMPORTANT: The implementation of this interface may not check the bounds + -- of the array, the caller must not assume that. + pokeAt :: Int -> MutByteArray -> a -> IO () + + pokeByteIndex :: Int -> MutByteArray -> a -> IO () + pokeByteIndex = pokeAt + + {-# INLINE pokeAt #-} + default pokeAt :: (Generic a, PokeRep (Rep a)) => + Int -> MutByteArray -> a -> IO () + pokeAt i arr = genericPokeByteIndex arr i + +{-# DEPRECATED peekByteIndex "Use peekAt." #-} +{-# DEPRECATED pokeByteIndex "Use pokeAt." #-} + +-- _size is the length from array start to the last accessed byte. +{-# INLINE checkBounds #-} +checkBounds :: String -> Int -> MutByteArray -> IO () +checkBounds _label _size _arr = do +#ifdef DEBUG + sz <- MutByteArray.length _arr + if (_size > sz) + then error + $ _label + ++ ": accessing array at offset = " + ++ show (_size - 1) + ++ " max valid offset = " ++ show (sz - 1) + else return () +#else + return () +#endif + +#define DERIVE_UNBOXED(_type, _constructor, _readArray, _writeArray, _sizeOf) \ +instance Unbox _type where { \ +; {-# INLINE peekAt #-} \ +; peekAt off@(I# n) arr@(MutByteArray mbarr) = \ + checkBounds "peek" (off + sizeOf (Proxy :: Proxy _type)) arr \ + >> (IO $ \s -> \ + case _readArray mbarr n s of \ + { (# s1, i #) -> (# s1, _constructor i #) }) \ +; {-# INLINE pokeAt #-} \ +; pokeAt off@(I# n) arr@(MutByteArray mbarr) (_constructor val) = \ + checkBounds "poke" (off + sizeOf (Proxy :: Proxy _type)) arr \ + >> (IO $ \s -> (# _writeArray mbarr n val s, () #)) \ +; {-# INLINE sizeOf #-} \ +; sizeOf _ = _sizeOf \ +} + +#define DERIVE_WRAPPED_UNBOX(_constraint, _type, _constructor, _innerType) \ +instance _constraint Unbox _type where \ +; {-# INLINE peekAt #-} \ +; peekAt i arr = \ + checkBounds "peek" (i + sizeOf (Proxy :: Proxy _type)) arr \ + >> _constructor <$> peekAt i arr \ +; {-# INLINE pokeAt #-} \ +; pokeAt i arr (_constructor a) = \ + checkBounds "poke" (i + sizeOf (Proxy :: Proxy _type)) arr \ + >> pokeAt i arr a \ +; {-# INLINE sizeOf #-} \ +; sizeOf _ = SIZE_OF(_innerType) + +#define DERIVE_BINARY_UNBOX(_constraint, _type, _constructor, _innerType) \ +instance _constraint Unbox _type where { \ +; {-# INLINE peekAt #-} \ +; peekAt i arr = \ + checkBounds "peek" (i + sizeOf (Proxy :: Proxy _type)) arr >> \ + peekAt i arr >>= \ + (\p1 -> peekAt (i + SIZE_OF(_innerType)) arr <&> _constructor p1) \ +; {-# INLINE pokeAt #-} \ +; pokeAt i arr (_constructor p1 p2) = \ + checkBounds "poke" (i + sizeOf (Proxy :: Proxy _type)) arr >> \ + pokeAt i arr p1 >> \ + pokeAt (i + SIZE_OF(_innerType)) arr p2 \ +; {-# INLINE sizeOf #-} \ +; sizeOf _ = 2 * SIZE_OF(_innerType) \ +} + +------------------------------------------------------------------------------- +-- Unbox instances for primitive types +------------------------------------------------------------------------------- + +DERIVE_UNBOXED( Char + , C# + , readWord8ArrayAsWideChar# + , writeWord8ArrayAsWideChar# + , SIZEOF_HSCHAR) + +DERIVE_UNBOXED( Int8 + , I8# + , readInt8Array# + , writeInt8Array# + , 1) + +DERIVE_UNBOXED( Int16 + , I16# + , readWord8ArrayAsInt16# + , writeWord8ArrayAsInt16# + , 2) + +DERIVE_UNBOXED( Int32 + , I32# + , readWord8ArrayAsInt32# + , writeWord8ArrayAsInt32# + , 4) + +DERIVE_UNBOXED( Int + , I# + , readWord8ArrayAsInt# + , writeWord8ArrayAsInt# + , SIZEOF_HSINT) + +DERIVE_UNBOXED( Int64 + , I64# + , readWord8ArrayAsInt64# + , writeWord8ArrayAsInt64# + , 8) + +DERIVE_UNBOXED( Word + , W# + , readWord8ArrayAsWord# + , writeWord8ArrayAsWord# + , SIZEOF_HSWORD) + +DERIVE_UNBOXED( Word8 + , W8# + , readWord8Array# + , writeWord8Array# + , 1) + +DERIVE_UNBOXED( Word16 + , W16# + , readWord8ArrayAsWord16# + , writeWord8ArrayAsWord16# + , 2) + +DERIVE_UNBOXED( Word32 + , W32# + , readWord8ArrayAsWord32# + , writeWord8ArrayAsWord32# + , 4) + +DERIVE_UNBOXED( Word64 + , W64# + , readWord8ArrayAsWord64# + , writeWord8ArrayAsWord64# + , 8) + +DERIVE_UNBOXED( Double + , D# + , readWord8ArrayAsDouble# + , writeWord8ArrayAsDouble# + , SIZEOF_HSDOUBLE) + +DERIVE_UNBOXED( Float + , F# + , readWord8ArrayAsFloat# + , writeWord8ArrayAsFloat# + , SIZEOF_HSFLOAT) + +------------------------------------------------------------------------------- +-- Unbox instances for derived types +------------------------------------------------------------------------------- + +DERIVE_UNBOXED( (StablePtr a) + , StablePtr + , readWord8ArrayAsStablePtr# + , writeWord8ArrayAsStablePtr# + , SIZEOF_HSSTABLEPTR) + +DERIVE_UNBOXED( (Ptr a) + , Ptr + , readWord8ArrayAsAddr# + , writeWord8ArrayAsAddr# + , SIZEOF_HSPTR) + +DERIVE_UNBOXED( (FunPtr a) + , FunPtr + , readWord8ArrayAsAddr# + , writeWord8ArrayAsAddr# + , SIZEOF_HSFUNPTR) + +DERIVE_WRAPPED_UNBOX(,IntPtr,IntPtr,Int) +DERIVE_WRAPPED_UNBOX(,WordPtr,WordPtr,Word) +DERIVE_WRAPPED_UNBOX(Unbox a =>,(Identity a),Identity,a) +#if MIN_VERSION_base(4,14,0) +DERIVE_WRAPPED_UNBOX(Unbox a =>,(Down a),Down,a) +#endif +DERIVE_WRAPPED_UNBOX(Unbox a =>,(Const a b),Const,a) + +-- XXX Add more CTypes +DERIVE_WRAPPED_UNBOX(,CChar,CChar,HTYPE_CHAR) +DERIVE_WRAPPED_UNBOX(,CWchar,CWchar,HTYPE_WCHAR_T) + +DERIVE_BINARY_UNBOX(forall a. Unbox a =>,(Complex a),(:+),a) +DERIVE_BINARY_UNBOX(forall a. Unbox a =>,(Ratio a),(:%),a) +DERIVE_BINARY_UNBOX(,Fingerprint,Fingerprint,Word64) + +instance Unbox () where + + {-# INLINE peekAt #-} + peekAt i arr = + checkBounds "peek ()" (i + sizeOf (Proxy :: Proxy ())) arr >> return () + + {-# INLINE pokeAt #-} + pokeAt i arr _ = + checkBounds "poke ()" (i + sizeOf (Proxy :: Proxy ())) arr >> return () + + {-# INLINE sizeOf #-} + sizeOf _ = 1 + +#if MIN_VERSION_base(4,15,0) + +instance Unbox IoSubSystem where + + {-# INLINE peekAt #-} + peekAt i arr = + checkBounds + "peek IoSubSystem" (i + sizeOf (Proxy :: Proxy IoSubSystem)) arr + >> toEnum <$> peekAt i arr + + {-# INLINE pokeAt #-} + pokeAt i arr a = + checkBounds + "poke IoSubSystem" (i + sizeOf (Proxy :: Proxy IoSubSystem)) arr + >> pokeAt i arr (fromEnum a) + + {-# INLINE sizeOf #-} + sizeOf _ = sizeOf (Proxy :: Proxy Int) +#endif + +instance Unbox Bool where + + {-# INLINE peekAt #-} + peekAt i arr = do + checkBounds "peek Bool" (i + sizeOf (Proxy :: Proxy Bool)) arr + res <- peekAt i arr + return $ res /= (0 :: Int8) + + {-# INLINE pokeAt #-} + pokeAt i arr a = + checkBounds "poke Bool" (i + sizeOf (Proxy :: Proxy Bool)) arr + >> if a + then pokeAt i arr (1 :: Int8) + else pokeAt i arr (0 :: Int8) + + {-# INLINE sizeOf #-} + sizeOf _ = 1 + +-------------------------------------------------------------------------------- +-- Generic deriving +-------------------------------------------------------------------------------- + +-- Utilities to build or parse a type safely and easily. + +-- XXX Use Array instead. + +-- | A location inside a mutable byte array with the bound of the array. Is it +-- cheaper to just get the bound using the size of the array whenever needed? +data BoundedPtr = + BoundedPtr + MutByteArray -- byte array + Int -- current pos + Int -- position after end + +-------------------------------------------------------------------------------- +-- Peeker monad +-------------------------------------------------------------------------------- + +-- | Chains peek functions that pass the current position to the next function +newtype Peeker a = Peeker (Builder BoundedPtr IO a) + deriving (Functor, Applicative, Monad) + +{-# INLINE readUnsafe #-} +readUnsafe :: Unbox a => Peeker a +readUnsafe = Peeker (Builder step) + + where + + {-# INLINE step #-} + step :: forall a. Unbox a => BoundedPtr -> IO (a, BoundedPtr) + step (BoundedPtr arr pos end) = do + let next = pos + sizeOf (Proxy :: Proxy a) +#ifdef DEBUG + when (next > end) + $ error $ "readUnsafe: reading beyond limit. next = " + ++ show next + ++ " end = " ++ show end +#endif + r <- peekAt pos arr + return (r, BoundedPtr arr next end) + +{-# INLINE read #-} +read :: Unbox a => Peeker a +read = Peeker (Builder step) + + where + + {-# INLINE step #-} + step :: forall a. Unbox a => BoundedPtr -> IO (a, BoundedPtr) + step (BoundedPtr arr pos end) = do + let next = pos + sizeOf (Proxy :: Proxy a) + when (next > end) + $ error $ "read: reading beyond limit. next = " + ++ show next + ++ " end = " ++ show end + r <- peekAt pos arr + return (r, BoundedPtr arr next end) + +{-# INLINE skipByte #-} +skipByte :: Peeker () +skipByte = Peeker (Builder step) + + where + + {-# INLINE step #-} + step :: BoundedPtr -> IO ((), BoundedPtr) + step (BoundedPtr arr pos end) = do + let next = pos + 1 +#ifdef DEBUG + when (next > end) + $ error $ "skipByte: reading beyond limit. next = " + ++ show next + ++ " end = " ++ show end +#endif + return ((), BoundedPtr arr next end) + +{-# INLINE runPeeker #-} +runPeeker :: Peeker a -> BoundedPtr -> IO a +runPeeker (Peeker (Builder f)) ptr = fmap fst (f ptr) + +-------------------------------------------------------------------------------- +-- Poke utilities +-------------------------------------------------------------------------------- + +-- XXX Use MutArray instead of BoundedPtr. + +-- XXX Using a Poker monad may be useful when we have to compute the size to be +-- poked as we go and then poke the size at a previous location. For variable +-- sized object serialization we may also want to reallocate the array and +-- return the newly allocated array in the output. + +-- Does not check writing beyond bound. +{-# INLINE pokeBoundedPtrUnsafe #-} +pokeBoundedPtrUnsafe :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr +pokeBoundedPtrUnsafe a (BoundedPtr arr pos end) = do + let next = pos + sizeOf (Proxy :: Proxy a) +#ifdef DEBUG + when (next > end) + $ error $ "pokeBoundedPtrUnsafe: reading beyond limit. next = " + ++ show next + ++ " end = " ++ show end +#endif + pokeAt pos arr a + return (BoundedPtr arr next end) + +{-# INLINE pokeBoundedPtr #-} +pokeBoundedPtr :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr +pokeBoundedPtr a (BoundedPtr arr pos end) = do + let next = pos + sizeOf (Proxy :: Proxy a) + when (next > end) $ error "pokeBoundedPtr writing beyond limit" + pokeAt pos arr a + return (BoundedPtr arr next end) + +-------------------------------------------------------------------------------- +-- Check the number of constructors in a sum type +-------------------------------------------------------------------------------- + +-- Count the constructors of a sum type. +type family SumArity (a :: Type -> Type) :: Nat where + SumArity (C1 _ _) = 1 + -- Requires UndecidableInstances + SumArity (f :+: g) = SumArity f + SumArity g + +type family TypeErrorMessage (a :: Symbol) :: Constraint where + TypeErrorMessage a = TypeError ('Text a) + +type family ArityCheck (b :: Bool) :: Constraint where + ArityCheck 'True = () + ArityCheck 'False = TypeErrorMessage + "Generic Unbox deriving does not support > 256 constructors." + +-- Type constraint to restrict the sum type arity so that the constructor tag +-- can fit in a single byte. +-- Note that Arity starts from 1 and constructor tags start from 0. So if max +-- arity is 256 then max constructor tag would be 255. +-- XXX Use variable length encoding to support more than 256 constructors. +type MaxArity256 n = ArityCheck (n <=? 256) + +-------------------------------------------------------------------------------- +-- Generic Deriving of Unbox instance +-------------------------------------------------------------------------------- + +-- Unbox uses fixed size encoding, therefore, when a (sum) type has multiple +-- constructors, the size of the type is computed as the maximum required by +-- any constructor. Therefore, size is independent of the value, it can be +-- determined solely by the type. + +-- | Implementation of sizeOf that works on the generic representation of an +-- ADT. +class SizeOfRep (f :: Type -> Type) where + sizeOfRep :: f x -> Int + +-- Meta information wrapper, go inside +instance SizeOfRep f => SizeOfRep (M1 i c f) where + {-# INLINE sizeOfRep #-} + sizeOfRep _ = sizeOfRep (undefined :: f x) + +-- Primitive type "a". +instance Unbox a => SizeOfRep (K1 i a) where + {-# INLINE sizeOfRep #-} + sizeOfRep _ = sizeOf (Proxy :: Proxy a) + +-- Void: data type without constructors. Values of this type cannot exist, +-- therefore the size is undefined. We should never be serializing structures +-- with elements of this type. +instance SizeOfRep V1 where + {-# INLINE sizeOfRep #-} + sizeOfRep = error "sizeOfRep: a value of a Void type must not exist" + +-- Note that when a sum type has many unit constructors only a single byte is +-- required to encode the type as only the constructor tag is stored. +instance SizeOfRep U1 where + {-# INLINE sizeOfRep #-} + sizeOfRep _ = 0 + +-- Product type +instance (SizeOfRep f, SizeOfRep g) => SizeOfRep (f :*: g) where + {-# INLINE sizeOfRep #-} + sizeOfRep _ = sizeOfRep (undefined :: f x) + sizeOfRep (undefined :: g x) + +------------------------------------------------------------------------------- + +class SizeOfRepSum (f :: Type -> Type) where + sizeOfRepSum :: f x -> Int + +-- Constructor +instance SizeOfRep a => SizeOfRepSum (C1 c a) where + {-# INLINE sizeOfRepSum #-} + sizeOfRepSum = sizeOfRep + +instance (SizeOfRepSum f, SizeOfRepSum g) => SizeOfRepSum (f :+: g) where + {-# INLINE sizeOfRepSum #-} + sizeOfRepSum _ = + max (sizeOfRepSum (undefined :: f x)) (sizeOfRepSum (undefined :: g x)) + +------------------------------------------------------------------------------- + +instance (MaxArity256 (SumArity (f :+: g)), SizeOfRepSum f, SizeOfRepSum g) => + SizeOfRep (f :+: g) where + + -- The size of a sum type is the max of any of the constructor size. + -- sizeOfRepSum type class operation is used here instead of sizeOfRep so + -- that we account the constructor index byte only for the first time and + -- avoid including it for the subsequent sum constructors. + {-# INLINE sizeOfRep #-} + sizeOfRep _ = + -- One byte for the constructor id and then the constructor value. + sizeOf (Proxy :: Proxy Word8) + + max (sizeOfRepSum (undefined :: f x)) + (sizeOfRepSum (undefined :: g x)) + +-- Unit: constructors without arguments. +-- Theoretically the size can be 0, but we use 1 to simplify the implementation +-- of an array of unit type elements. With a non-zero size we can count the number +-- of elements in the array based on the size of the array. Otherwise we will +-- have to store a virtual length in the array, but keep the physical size of +-- the array as 0. Or we will have to make a special handling for zero sized +-- elements to make the size as 1. Or we can disallow arrays with elements +-- having size 0. +-- +-- Some examples: +-- +-- data B = B -- one byte +-- data A = A B -- one byte +-- data X = X1 | X2 -- one byte (constructor tag only) +-- +{-# INLINE genericSizeOf #-} +genericSizeOf :: forall a. (SizeOfRep (Rep a)) => Proxy a -> Int +genericSizeOf _ = + let s = sizeOfRep (undefined :: Rep a x) + in if s == 0 then 1 else s + +-------------------------------------------------------------------------------- +-- Generic poke +-------------------------------------------------------------------------------- + +class PokeRep (f :: Type -> Type) where + pokeRep :: f a -> BoundedPtr -> IO BoundedPtr + +instance PokeRep f => PokeRep (M1 i c f) where + {-# INLINE pokeRep #-} + pokeRep f = pokeRep (unM1 f) + +instance Unbox a => PokeRep (K1 i a) where + {-# INLINE pokeRep #-} + pokeRep a = pokeBoundedPtrUnsafe (unK1 a) + +instance PokeRep V1 where + {-# INLINE pokeRep #-} + pokeRep = error "pokeRep: a value of a Void type should not exist" + +instance PokeRep U1 where + {-# INLINE pokeRep #-} + pokeRep _ x = pure x + +instance (PokeRep f, PokeRep g) => PokeRep (f :*: g) where + {-# INLINE pokeRep #-} + pokeRep (f :*: g) ptr = pokeRep f ptr >>= pokeRep g + +------------------------------------------------------------------------------- + +class KnownNat n => PokeRepSum (n :: Nat) (f :: Type -> Type) where + -- "n" is the constructor tag to be poked. + pokeRepSum :: Proxy n -> f a -> BoundedPtr -> IO BoundedPtr + +instance (KnownNat n, PokeRep a) => PokeRepSum n (C1 c a) where + {-# INLINE pokeRepSum #-} + pokeRepSum _ x ptr = do + let tag = fromInteger (natVal (Proxy :: Proxy n)) :: Word8 + pokeBoundedPtrUnsafe tag ptr >>= pokeRep x + +instance (PokeRepSum n f, PokeRepSum (n + SumArity f) g) + => PokeRepSum n (f :+: g) where + {-# INLINE pokeRepSum #-} + pokeRepSum _ (L1 x) ptr = + pokeRepSum (Proxy :: Proxy n) x ptr + pokeRepSum _ (R1 x) ptr = + pokeRepSum (Proxy :: Proxy (n + SumArity f)) x ptr + +------------------------------------------------------------------------------- + +instance (MaxArity256 (SumArity (f :+: g)), PokeRepSum 0 (f :+: g)) => + PokeRep (f :+: g) where + + {-# INLINE pokeRep #-} + pokeRep = pokeRepSum (Proxy :: Proxy 0) + +{-# INLINE genericPokeObject #-} +genericPokeObject :: (Generic a, PokeRep (Rep a)) => + a -> BoundedPtr -> IO BoundedPtr +genericPokeObject a = pokeRep (from a) + +genericPokeObj :: (Generic a, PokeRep (Rep a)) => a -> BoundedPtr -> IO () +genericPokeObj a ptr = void $ genericPokeObject a ptr + +{-# INLINE genericPokeByteIndex #-} +genericPokeByteIndex :: (Generic a, PokeRep (Rep a)) => + MutByteArray -> Int -> a -> IO () +genericPokeByteIndex arr index x = do + -- XXX Should we use unsafe poke? +#ifdef DEBUG + end <- MutByteArray.length arr + genericPokeObj x (BoundedPtr arr index end) +#else + genericPokeObj x (BoundedPtr arr index undefined) +#endif + +-------------------------------------------------------------------------------- +-- Generic peek +-------------------------------------------------------------------------------- + +class PeekRep (f :: Type -> Type) where + -- Like pokeRep, we can use the following signature instead of using Peeker + -- peekRep :: BoundedPtr -> IO (BoundedPtr, f a) + peekRep :: Peeker (f x) + +instance PeekRep f => PeekRep (M1 i c f) where + {-# INLINE peekRep #-} + peekRep = fmap M1 peekRep + +instance Unbox a => PeekRep (K1 i a) where + {-# INLINE peekRep #-} + peekRep = fmap K1 readUnsafe + +instance PeekRep V1 where + {-# INLINE peekRep #-} + peekRep = error "peekRep: a value of a Void type should not exist" + +instance PeekRep U1 where + {-# INLINE peekRep #-} + peekRep = pure U1 + +instance (PeekRep f, PeekRep g) => PeekRep (f :*: g) where + {-# INLINE peekRep #-} + peekRep = (:*:) <$> peekRep <*> peekRep + +------------------------------------------------------------------------------- + +class KnownNat n => PeekRepSum (n :: Nat) (f :: Type -> Type) where + -- "n" is the constructor tag to be matched. + peekRepSum :: Proxy n -> Word8 -> Peeker (f a) + +instance (KnownNat n, PeekRep a) => PeekRepSum n (C1 c a) where + {-# INLINE peekRepSum #-} + peekRepSum _ _ = peekRep + {- + -- These error checks are expensive, to avoid these + -- we validate the max value of the tag in peekRep. + -- XXX Add tests to cover all cases + peekRepSum _ tag + | tag == curTag = peekRep + | tag > curTag = + error $ "Unbox instance peek: Constructor tag index " + ++ show tag ++ " out of range, max tag index is " + ++ show curTag + | otherwise = error "peekRepSum: bug" + + where + + curTag = fromInteger (natVal (Proxy :: Proxy n)) + -} + +instance (PeekRepSum n f, PeekRepSum (n + SumArity f) g) + => PeekRepSum n (f :+: g) where + {-# INLINE peekRepSum #-} + peekRepSum curProxy tag + | tag < firstRightTag = + L1 <$> peekRepSum curProxy tag + | otherwise = + R1 <$> peekRepSum (Proxy :: Proxy (n + SumArity f)) tag + + where + + firstRightTag = fromInteger (natVal (Proxy :: Proxy (n + SumArity f))) + +------------------------------------------------------------------------------- + +instance ( MaxArity256 (SumArity (f :+: g)) + , KnownNat (SumArity (f :+: g)) + , PeekRepSum 0 (f :+: g)) + => PeekRep (f :+: g) where + {-# INLINE peekRep #-} + peekRep = do + tag :: Word8 <- readUnsafe + -- XXX test with 256 and more constructors + let arity :: Int = + fromInteger (natVal (Proxy :: Proxy (SumArity (f :+: g)))) + when (fromIntegral tag >= arity) + $ error $ "peek: Tag " ++ show tag + ++ " is greater than the max tag " ++ show (arity - 1) + ++ " for the data type" + peekRepSum (Proxy :: Proxy 0) tag -- DataKinds + +{-# INLINE genericPeeker #-} +genericPeeker :: (Generic a, PeekRep (Rep a)) => Peeker a +genericPeeker = to <$> peekRep + +{-# INLINE genericPeekBoundedPtr #-} +genericPeekBoundedPtr :: (Generic a, PeekRep (Rep a)) => BoundedPtr -> IO a +genericPeekBoundedPtr = runPeeker genericPeeker + +{-# INLINE genericPeekByteIndex #-} +genericPeekByteIndex :: (Generic a, PeekRep (Rep a)) => + MutByteArray -> Int -> IO a +genericPeekByteIndex arr index = do + -- XXX Should we use unsafe peek? +#ifdef DEBUG + end <- MutByteArray.length arr + genericPeekBoundedPtr (BoundedPtr arr index end) +#else + genericPeekBoundedPtr (BoundedPtr arr index undefined) +#endif diff --git a/src/Streamly/Internal/Data/Unbox/TH.hs b/src/Streamly/Internal/Data/Unbox/TH.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Unbox/TH.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Streamly.Internal.Data.Unbox.TH +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Unbox.TH + ( deriveUnbox + + -- th-helpers + , DataCon(..) + , DataType(..) + , reifyDataType + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Data.Bifunctor (second) +import Data.List (elemIndex) +import Data.Proxy (Proxy(..)) +import Data.Word (Word16, Word32, Word64, Word8) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Streamly.Internal.Data.Unbox + +-------------------------------------------------------------------------------- +-- th-utilities +-------------------------------------------------------------------------------- + +-- Note: We don't support template-haskell < 2.14 (GHC < 8.6) + +-- The following are copied to remove the dependency on th-utilities. +-- The code has been copied from th-abstraction and th-utilities. + +-- Some CPP macros in the following code are not required but are kept +-- anyway. They can be removed if deemed as a maintainance burden. + +#if MIN_VERSION_template_haskell(2,17,0) +type TyVarBndr_ flag = TyVarBndr flag +#else +type TyVarBndr_ flag = TyVarBndr +#endif + +-- | Case analysis for a 'TyVarBndr'. If the value is a @'PlainTV' n _@, apply +-- the first function to @n@; if it is @'KindedTV' n _ k@, apply the second +-- function to @n@ and @k@. +elimTV :: (Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r +#if MIN_VERSION_template_haskell(2,17,0) +elimTV ptv _ktv (PlainTV n _) = ptv n +elimTV _ptv ktv (KindedTV n _ k) = ktv n k +#else +elimTV ptv _ktv (PlainTV n) = ptv n +elimTV _ptv ktv (KindedTV n k) = ktv n k +#endif + +-- | Extract the type variable name from a 'TyVarBndr', ignoring the +-- kind signature if one exists. +tvName :: TyVarBndr_ flag -> Name +tvName = elimTV id const + +-- | Get the 'Name' of a 'TyVarBndr' +tyVarBndrName :: TyVarBndr_ flag -> Name +tyVarBndrName = tvName + +-- | Simplified info about a 'DataD'. Omits deriving, strictness, +-- kind info, and whether it's @data@ or @newtype@. +data DataType = DataType + { dtName :: Name + , dtTvs :: [Name] + , dtCxt :: Cxt + , dtCons :: [DataCon] + } deriving (Eq, Show, Ord) --, Data, Typeable, Generic) + +-- | Simplified info about a 'Con'. Omits deriving, strictness, and kind +-- info. This is much nicer than consuming 'Con' directly, because it +-- unifies all the constructors into one. +data DataCon = DataCon + { dcName :: Name + , dcTvs :: [Name] + , dcCxt :: Cxt + , dcFields :: [(Maybe Name, Type)] + } deriving (Eq, Show, Ord) --, Data, Typeable, Generic) + + +-- | Convert a 'Con' to a list of 'DataCon'. The result is a list +-- because 'GadtC' and 'RecGadtC' can define multiple constructors. +conToDataCons :: Con -> [DataCon] +conToDataCons = \case + NormalC name slots -> + [DataCon name [] [] (map (\(_, ty) -> (Nothing, ty)) slots)] + RecC name fields -> + [DataCon name [] [] (map (\(n, _, ty) -> (Just n, ty)) fields)] + InfixC (_, ty1) name (_, ty2) -> + [DataCon name [] [] [(Nothing, ty1), (Nothing, ty2)]] + ForallC tvs preds con -> + map (\(DataCon name tvs0 preds0 fields) -> + DataCon name (tvs0 ++ map tyVarBndrName tvs) (preds0 ++ preds) fields) (conToDataCons con) +#if MIN_VERSION_template_haskell(2,11,0) + GadtC ns slots _ -> + map (\dn -> DataCon dn [] [] (map (\(_, ty) -> (Nothing, ty)) slots)) ns + RecGadtC ns fields _ -> + map (\dn -> DataCon dn [] [] (map (\(fn, _, ty) -> (Just fn, ty)) fields)) ns +#endif + +-- | Reify the given data or newtype declaration, and yields its +-- 'DataType' representation. +reifyDataType :: Name -> Q DataType +reifyDataType name = do + info <- reify name + case infoToDataType info of + Nothing -> fail $ "Expected to reify a datatype. Instead got:\n" ++ pprint info + Just x -> return x + +infoToDataType :: Info -> Maybe DataType +infoToDataType info = case info of +#if MIN_VERSION_template_haskell(2,11,0) + TyConI (DataD preds name tvs _kind cons _deriving) -> +#else + TyConI (DataD preds name tvs cons _deriving) -> +#endif + Just $ DataType name (map tyVarBndrName tvs) preds (concatMap conToDataCons cons) +#if MIN_VERSION_template_haskell(2,11,0) + TyConI (NewtypeD preds name tvs _kind con _deriving) -> +#else + TyConI (NewtypeD preds name tvs con _deriving) -> +#endif + Just $ DataType name (map tyVarBndrName tvs) preds (conToDataCons con) + _ -> Nothing + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +type Field = (Maybe Name, Type) + +_arr :: Name +_arr = mkName "arr" + +_tag :: Name +_tag = mkName "tag" + +_initialOffset :: Name +_initialOffset = mkName "initialOffset" + +_val :: Name +_val = mkName "val" + +mkOffsetName :: Int -> Name +mkOffsetName i = mkName ("offset" ++ show i) + +mkFieldName :: Int -> Name +mkFieldName i = mkName ("field" ++ show i) + +-------------------------------------------------------------------------------- +-- Domain specific helpers +-------------------------------------------------------------------------------- + +exprGetSize :: Type -> Q Exp +exprGetSize ty = appE (varE 'sizeOf) [|Proxy :: Proxy $(pure ty)|] + +getTagSize :: Int -> Int +getTagSize numConstructors + | numConstructors == 1 = 0 + | fromIntegral (maxBound :: Word8) >= numConstructors = 1 + | fromIntegral (maxBound :: Word16) >= numConstructors = 2 + | fromIntegral (maxBound :: Word32) >= numConstructors = 4 + | fromIntegral (maxBound :: Word64) >= numConstructors = 8 + | otherwise = error "Too many constructors" + +getTagType :: Int -> Name +getTagType numConstructors + | numConstructors == 1 = error "No tag for 1 constructor" + | fromIntegral (maxBound :: Word8) >= numConstructors = ''Word8 + | fromIntegral (maxBound :: Word16) >= numConstructors = ''Word16 + | fromIntegral (maxBound :: Word32) >= numConstructors = ''Word32 + | fromIntegral (maxBound :: Word64) >= numConstructors = ''Word64 + | otherwise = error "Too many constructors" + +mkOffsetDecls :: Int -> [Field] -> [Q Dec] +mkOffsetDecls tagSize fields = + init + ((:) (valD + (varP (mkOffsetName 0)) + (normalB + [|$(litE (IntegerL (fromIntegral tagSize))) + + $(varE _initialOffset)|]) + []) + (fmap mkOffsetExpr (zip [1 ..] fields))) + + where + + mkOffsetExpr (i, (_, ty)) = + valD + (varP (mkOffsetName i)) + (normalB [|$(varE (mkOffsetName (i - 1))) + $(exprGetSize ty)|]) + [] + +-------------------------------------------------------------------------------- +-- Size +-------------------------------------------------------------------------------- + +isUnitType :: [DataCon] -> Bool +isUnitType [DataCon _ _ _ []] = True +isUnitType _ = False + +mkSizeOfExpr :: Type -> [DataCon] -> Q Exp +mkSizeOfExpr headTy constructors = + case constructors of + [] -> + [|error + ("Attempting to get size with no constructors (" ++ + $(lift (pprint headTy)) ++ ")")|] + -- One constructor with no fields is a unit type. Size of a unit type is + -- 1. + [con@(DataCon _ _ _ fields)] -> + case fields of + [] -> litE (IntegerL 1) + _ -> [|$(sizeOfConstructor con)|] + _ -> [|$(litE (IntegerL (fromIntegral tagSize))) + $(sizeOfHeadDt)|] + + where + + tagSize = getTagSize (length constructors) + sizeOfField (_, ty) = exprGetSize ty + sizeOfConstructor (DataCon _ _ _ fields) = + appE (varE 'sum) (listE (map sizeOfField fields)) + -- The size of any Unbox type is atleast 1 + sizeOfHeadDt = + appE (varE 'maximum) (listE (map sizeOfConstructor constructors)) + +-------------------------------------------------------------------------------- +-- Peek +-------------------------------------------------------------------------------- + +mkPeekExprOne :: Int -> DataCon -> Q Exp +mkPeekExprOne tagSize (DataCon cname _ _ fields) = + case fields of + -- XXX Should we peek and check if the byte value is 0? + [] -> [|pure $(conE cname)|] + _ -> + letE + (mkOffsetDecls tagSize fields) + (foldl + (\acc i -> [|$(acc) <*> $(peekField i)|]) + [|$(conE cname) <$> $(peekField 0)|] + [1 .. (length fields - 1)]) + + where + + peekField i = [|peekAt $(varE (mkOffsetName i)) $(varE _arr)|] + +mkPeekExpr :: Type -> [DataCon] -> Q Exp +mkPeekExpr headTy cons = + case cons of + [] -> + [|error + ("Attempting to peek type with no constructors (" ++ + $(lift (pprint headTy)) ++ ")")|] + [con] -> mkPeekExprOne 0 con + _ -> + doE + [ bindS + (varP _tag) + [|peekAt $(varE _initialOffset) $(varE _arr)|] + , noBindS + (caseE + (sigE (varE _tag) (conT tagType)) + (fmap peekMatch (zip [0 ..] cons) ++ [peekErr])) + ] + + where + + lenCons = length cons + tagType = getTagType lenCons + tagSize = getTagSize lenCons + peekMatch (i, con) = + match (litP (IntegerL i)) (normalB (mkPeekExprOne tagSize con)) [] + peekErr = + match + wildP + (normalB + [|error + ("Found invalid tag while peeking (" ++ + $(lift (pprint headTy)) ++ ")")|]) + [] + +-------------------------------------------------------------------------------- +-- Poke +-------------------------------------------------------------------------------- + +mkPokeExprTag :: Name -> Int -> Q Exp +mkPokeExprTag tagType tagVal = pokeTag + + where + + pokeTag = + [|pokeAt + $(varE _initialOffset) + $(varE _arr) + $(sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType))|] + +mkPokeExprFields :: Int -> [Field] -> Q Exp +mkPokeExprFields tagSize fields = do + case fields of + [] -> [|pure ()|] + _ -> + letE + (mkOffsetDecls tagSize fields) + (doE $ map (noBindS . pokeField) [0 .. (numFields - 1)]) + + where + + numFields = length fields + pokeField i = + [|pokeAt + $(varE (mkOffsetName i)) + $(varE _arr) + $(varE (mkFieldName i))|] + +mkPokeMatch :: Name -> Int -> Q Exp -> Q Match +mkPokeMatch cname numFields exp0 = + match + (conP cname (map (varP . mkFieldName) [0 .. (numFields - 1)])) + (normalB exp0) + [] + +mkPokeExpr :: Type -> [DataCon] -> Q Exp +mkPokeExpr headTy cons = + case cons of + [] -> + [|error + ("Attempting to poke type with no constructors (" ++ + $(lift (pprint headTy)) ++ ")")|] + -- XXX We don't gaurentee encoded equivalilty for Unbox. Does it still + -- make sense to encode a default value for unit constructor? + [DataCon _ _ _ []] -> [|pure ()|] -- mkPokeExprTag ''Word8 0 + [DataCon cname _ _ fields] -> + caseE + (varE _val) + [mkPokeMatch cname (length fields) (mkPokeExprFields 0 fields)] + _ -> + caseE + (varE _val) + (fmap (\(tagVal, DataCon cname _ _ fields) -> + mkPokeMatch + cname + (length fields) + (doE [ noBindS $ mkPokeExprTag tagType tagVal + , noBindS $ mkPokeExprFields tagSize fields + ])) + (zip [0 ..] cons)) + + where + + lenCons = length cons + tagType = getTagType lenCons + tagSize = getTagSize lenCons + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + +-- | A general function to derive Unbox instances where you can control which +-- Constructors of the datatype to consider and what the Context for the 'Unbox' +-- instance would be. +-- +-- Consider the datatype: +-- @ +-- data CustomDataType a b +-- = CDTConstructor1 +-- | CDTConstructor2 Bool +-- | CDTConstructor3 Bool b +-- deriving (Show, Eq) +-- @ +-- +-- Usage: +-- @ +-- $(deriveUnboxInternal +-- [AppT (ConT ''Unbox) (VarT (mkName "b"))] +-- (AppT +-- (AppT (ConT ''CustomDataType) (VarT (mkName "a"))) +-- (VarT (mkName "b"))) +-- [ DataCon 'CDTConstructor1 [] [] [] +-- , DataCon 'CDTConstructor2 [] [] [(Nothing, (ConT ''Bool))] +-- , DataCon +-- 'CDTConstructor3 +-- [] +-- [] +-- [(Nothing, (ConT ''Bool)), (Nothing, (VarT (mkName "b")))] +-- ]) +-- @ +deriveUnboxInternal :: Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec] +deriveUnboxInternal headTy cons mkDec = do + sizeOfMethod <- mkSizeOfExpr headTy cons + peekMethod <- mkPeekExpr headTy cons + pokeMethod <- mkPokeExpr headTy cons + let methods = + -- INLINE on sizeOf actually worsens some benchmarks, and improves + -- none + [ -- PragmaD (InlineP 'sizeOf Inline FunLike AllPhases) + FunD 'sizeOf [Clause [WildP] (NormalB sizeOfMethod) []] + , PragmaD (InlineP 'peekAt Inline FunLike AllPhases) + , FunD + 'peekAt + [ Clause + (if isUnitType cons + then [WildP, WildP] + else [VarP _initialOffset, VarP _arr]) + (NormalB peekMethod) + [] + ] + , PragmaD (InlineP 'pokeAt Inline FunLike AllPhases) + , FunD + 'pokeAt + [ Clause + (if isUnitType cons + then [WildP, WildP, WildP] + else [VarP _initialOffset, VarP _arr, VarP _val]) + (NormalB pokeMethod) + [] + ] + ] + mkDec methods + +-- | Given an 'Unbox' instance declaration splice without the methods (e.g. +-- @[d|instance Unbox a => Unbox (Maybe a)|]@), generate an instance +-- declaration including all the type class method implementations. +-- +-- Usage: +-- +-- @ +-- \$(deriveUnbox [d|instance Unbox a => Unbox (Maybe a)|]) +-- @ +deriveUnbox :: Q [Dec] -> Q [Dec] +deriveUnbox mDecs = do + dec <- mDecs + case dec of + [InstanceD mo preds headTyWC []] -> do + let headTy = unwrap dec headTyWC + (mainTyName, subs) = getMainTypeName dec headTy + dt <- reifyDataType mainTyName + let tyVars = dtTvs dt + mapper = mapperWith (VarT <$> tyVars) subs + cons = map (modifyConVariables mapper) (dtCons dt) + deriveUnboxInternal headTy cons (mkInst mo preds headTyWC) + _ -> errorMessage dec + + where + + mapperWith l1 l2 a = + case elemIndex a l1 of + Nothing -> a + -- XXX Capture this case and give a relavant error. + Just i -> l2 !! i + + mapType f (AppT t1 t2) = AppT (mapType f t1) (mapType f t2) + mapType f (InfixT t1 n t2) = InfixT (mapType f t1) n (mapType f t2) + mapType f (UInfixT t1 n t2) = UInfixT (mapType f t1) n (mapType f t2) + mapType f (ParensT t) = ParensT (mapType f t) + mapType f v = f v + + modifyConVariables f con = + con { dcFields = map (second (mapType f)) (dcFields con) } + + mkInst mo preds headTyWC methods = + pure [InstanceD mo preds headTyWC methods] + + errorMessage dec = + error $ unlines + [ "Error: deriveUnbox:" + , "" + , ">> " ++ pprint dec + , "" + , "The supplied declaration not a valid instance declaration." + , "Provide a valid Haskell instance declaration without a body." + , "" + , "Examples:" + , "instance Unbox (Proxy a)" + , "instance Unbox a => Unbox (Identity a)" + , "instance Unbox (TableT Identity)" + ] + + unwrap _ (AppT (ConT _) r) = r + unwrap dec _ = errorMessage dec + + getMainTypeName dec = go [] + + where + + go xs (ConT nm) = (nm, xs) + go xs (AppT l r) = go (r:xs) l + go _ _ = errorMessage dec diff --git a/src/Streamly/Internal/Data/Unboxed.hs b/src/Streamly/Internal/Data/Unboxed.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Unboxed.hs +++ /dev/null @@ -1,855 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} - --- | TODO: Implement TH based instance derivation for better performance. - -module Streamly.Internal.Data.Unboxed - ( Unbox(..) - , peekWith - , pokeWith - , MutableByteArray(..) - , touch - , getMutableByteArray# - , pin - , unpin - , newUnpinnedBytes - , newPinnedBytes - , newAlignedPinnedBytes - , nil - - -- * Type Parser and Builder - , BoundedPtr (..) - - , Peeker (..) - , read - , readUnsafe - , skipByte - , runPeeker - - , pokeBoundedPtrUnsafe - , pokeBoundedPtr - - -- * Generic Unbox instances - , genericSizeOf - , genericPeekByteIndex - , genericPokeByteIndex - - -- Classess used for generic deriving. - , PeekRep(..) - , PokeRep(..) - , SizeOfRep(..) - ) where - -#include "MachDeps.h" -#include "ArrayMacros.h" - -import Control.Monad (void, when) -import Data.Complex (Complex((:+))) -import Data.Functor ((<&>)) -import Data.Functor.Const (Const(..)) -import Data.Functor.Identity (Identity(..)) -import Data.Kind (Type) -import Data.Proxy (Proxy (..)) -import Foreign.Ptr (IntPtr(..), WordPtr(..)) -import GHC.Base (IO(..)) -import GHC.Fingerprint.Type (Fingerprint(..)) -import GHC.Int (Int16(..), Int32(..), Int64(..), Int8(..)) -import GHC.Real (Ratio(..)) -import GHC.Stable (StablePtr(..)) -import GHC.Word (Word16(..), Word32(..), Word64(..), Word8(..)) -#if MIN_VERSION_base(4,15,0) -import GHC.RTS.Flags (IoSubSystem(..)) -#endif -import Streamly.Internal.Data.Builder (Builder (..)) -import System.IO.Unsafe (unsafePerformIO) - -import GHC.Generics -import GHC.Exts -import GHC.TypeLits -import Prelude hiding (read) - --------------------------------------------------------------------------------- --- The ArrayContents type --------------------------------------------------------------------------------- - --- XXX can use UnliftedNewtypes -data MutableByteArray = MutableByteArray (MutableByteArray# RealWorld) - -{-# INLINE getMutableByteArray# #-} -getMutableByteArray# :: MutableByteArray -> MutableByteArray# RealWorld -getMutableByteArray# (MutableByteArray mbarr) = mbarr - -{-# INLINE touch #-} -touch :: MutableByteArray -> IO () -touch (MutableByteArray contents) = - IO $ \s -> case touch# contents s of s' -> (# s', () #) - --- | Return the size of the array in bytes. -{-# INLINE sizeOfMutableByteArray #-} -sizeOfMutableByteArray :: MutableByteArray -> IO Int -sizeOfMutableByteArray (MutableByteArray arr) = - IO $ \s -> - case getSizeofMutableByteArray# arr s of - (# s1, i #) -> (# s1, I# i #) - --------------------------------------------------------------------------------- --- Creation --------------------------------------------------------------------------------- - -{-# NOINLINE nil #-} -nil :: MutableByteArray -nil = unsafePerformIO $ newUnpinnedBytes 0 - -{-# INLINE newUnpinnedBytes #-} -newUnpinnedBytes :: Int -> IO MutableByteArray -newUnpinnedBytes nbytes | nbytes < 0 = - errorWithoutStackTrace "newUnpinnedBytes: size must be >= 0" -newUnpinnedBytes (I# nbytes) = IO $ \s -> - case newByteArray# nbytes s of - (# s', mbarr# #) -> - let c = MutableByteArray mbarr# - in (# s', c #) - -{-# INLINE newPinnedBytes #-} -newPinnedBytes :: Int -> IO MutableByteArray -newPinnedBytes nbytes | nbytes < 0 = - errorWithoutStackTrace "newPinnedBytes: size must be >= 0" -newPinnedBytes (I# nbytes) = IO $ \s -> - case newPinnedByteArray# nbytes s of - (# s', mbarr# #) -> - let c = MutableByteArray mbarr# - in (# s', c #) - -{-# INLINE newAlignedPinnedBytes #-} -newAlignedPinnedBytes :: Int -> Int -> IO MutableByteArray -newAlignedPinnedBytes nbytes _align | nbytes < 0 = - errorWithoutStackTrace "newAlignedPinnedBytes: size must be >= 0" -newAlignedPinnedBytes (I# nbytes) (I# align) = IO $ \s -> - case newAlignedPinnedByteArray# nbytes align s of - (# s', mbarr# #) -> - let c = MutableByteArray mbarr# - in (# s', c #) - -------------------------------------------------------------------------------- --- Pinning & Unpinning -------------------------------------------------------------------------------- - -{-# INLINE isPinned #-} -isPinned :: MutableByteArray -> Bool -isPinned (MutableByteArray arr#) = - let pinnedInt = I# (isMutableByteArrayPinned# arr#) - in pinnedInt == 1 - - -{-# INLINE cloneMutableArrayWith# #-} -cloneMutableArrayWith# - :: (Int# -> State# RealWorld -> (# State# RealWorld - , MutableByteArray# RealWorld #)) - -> MutableByteArray# RealWorld - -> State# RealWorld - -> (# State# RealWorld, MutableByteArray# RealWorld #) -cloneMutableArrayWith# alloc# arr# s# = - case getSizeofMutableByteArray# arr# s# of - (# s1#, i# #) -> - case alloc# i# s1# of - (# s2#, arr1# #) -> - case copyMutableByteArray# arr# 0# arr1# 0# i# s2# of - s3# -> (# s3#, arr1# #) - -{-# INLINE pin #-} -pin :: MutableByteArray -> IO MutableByteArray -pin arr@(MutableByteArray marr#) = - if isPinned arr - then return arr - else IO - $ \s# -> - case cloneMutableArrayWith# newPinnedByteArray# marr# s# of - (# s1#, marr1# #) -> (# s1#, MutableByteArray marr1# #) - -{-# INLINE unpin #-} -unpin :: MutableByteArray -> IO MutableByteArray -unpin arr@(MutableByteArray marr#) = - if not (isPinned arr) - then return arr - else IO - $ \s# -> - case cloneMutableArrayWith# newByteArray# marr# s# of - (# s1#, marr1# #) -> (# s1#, MutableByteArray marr1# #) - --------------------------------------------------------------------------------- --- The Unbox type class --------------------------------------------------------------------------------- - --- XXX generate error if the size is < 1 - --- In theory we could convert a type to and from a byte stream and use that --- to implement boxing, unboxing. But that would be inefficient. This type --- class allows each primitive type to have its own specific efficient --- implementation to read and write the type to memory. --- --- This is a typeclass that uses MutableByteArray but could use ForeignPtr or --- any other representation of memory. We could make this a multiparameter type --- class if necessary. --- --- If the type class would have to support reading and writing to a Ptr as well, --- basically what Storable does. We will also need to touch the anchoring ptr at --- the right points which is prone to errors. However, it should be simple to --- implement unmanaged/read-only memory arrays by allowing a Ptr type in --- ArrayContents, though it would require all instances to support reading from --- a Ptr. --- --- There is a reason for using byte offset instead of element index in read and --- write operations in the type class. If we use element index slicing of the --- array becomes rigid. We can only slice the array at addresses that are --- aligned with the type, therefore, we cannot slice at misaligned location and --- then cast the slice into another type which does not ncessarily align with --- the original type. --- --- As a side note, there seem to be no performance advantage of alignment --- anymore, see --- https://lemire.me/blog/2012/05/31/data-alignment-for-speed-myth-or-reality/ --- - --- The main goal of the Unbox type class is to be used in arrays. Invariants --- for the sizeOf value required for use in arrays: --- --- * size is independent of the value, it is determined by the type only. So --- that we can store values of the same type in fixed length array cells. --- * size cannot be zero. So that the length of an array storing the element --- and the number of elements can be related. --- --- Note, for general serializable types the size cannot be fixed e.g. we may --- want to serialize a list. This type class can be considered a special case --- of a more general serialization type class. - --- | A type implementing the 'Unbox' interface supplies operations for reading --- and writing the type from and to a mutable byte array (an unboxed --- representation of the type) in memory. The read operation 'peekByteIndex' --- deserializes the boxed type from the mutable byte array. The write operation --- 'pokeByteIndex' serializes the boxed type to the mutable byte array. --- --- Instances can be derived via 'Generic'. Note that the data type must be --- non-recursive. Here is an example, for deriving an instance of this type --- class. --- --- >>> import GHC.Generics (Generic) --- >>> :{ --- data Object = Object --- { _int0 :: Int --- , _int1 :: Int --- } deriving Generic --- :} --- --- WARNING! Generic deriving hangs for recursive data types. --- --- >>> import Streamly.Data.Array (Unbox(..)) --- >>> instance Unbox Object --- --- If you want to write the instance manually: --- --- >>> :{ --- instance Unbox Object where --- sizeOf _ = 16 --- peekByteIndex i arr = do --- x0 <- peekByteIndex i arr --- x1 <- peekByteIndex (i + 8) arr --- return $ Object x0 x1 --- pokeByteIndex i arr (Object x0 x1) = do --- pokeByteIndex i arr x0 --- pokeByteIndex (i + 8) arr x1 --- :} --- -class Unbox a where - -- | Get the size. Size cannot be zero. - sizeOf :: Proxy a -> Int - - default sizeOf :: (SizeOfRep (Rep a)) => Proxy a -> Int - sizeOf = genericSizeOf - - -- | Read an element of type "a" from a MutableByteArray given the byte - -- index. - -- - -- IMPORTANT: The implementation of this interface may not check the bounds - -- of the array, the caller must not assume that. - peekByteIndex :: Int -> MutableByteArray -> IO a - - default peekByteIndex :: (Generic a, PeekRep (Rep a)) => - Int -> MutableByteArray -> IO a - peekByteIndex i arr = genericPeekByteIndex arr i - - -- | Write an element of type "a" to a MutableByteArray given the byte - -- index. - -- - -- IMPORTANT: The implementation of this interface may not check the bounds - -- of the array, the caller must not assume that. - pokeByteIndex :: Int -> MutableByteArray -> a -> IO () - - default pokeByteIndex :: (Generic a, PokeRep (Rep a)) => - Int -> MutableByteArray -> a -> IO () - pokeByteIndex i arr = genericPokeByteIndex arr i - -#define DERIVE_UNBOXED(_type, _constructor, _readArray, _writeArray, _sizeOf) \ -instance Unbox _type where { \ -; {-# INLINE peekByteIndex #-} \ -; peekByteIndex (I# n) (MutableByteArray mbarr) = IO $ \s -> \ - case _readArray mbarr n s of \ - { (# s1, i #) -> (# s1, _constructor i #) } \ -; {-# INLINE pokeByteIndex #-} \ -; pokeByteIndex (I# n) (MutableByteArray mbarr) (_constructor val) = \ - IO $ \s -> (# _writeArray mbarr n val s, () #) \ -; {-# INLINE sizeOf #-} \ -; sizeOf _ = _sizeOf \ -} - -#define DERIVE_WRAPPED_UNBOX(_constraint, _type, _constructor, _innerType) \ -instance _constraint Unbox _type where \ -; {-# INLINE peekByteIndex #-} \ -; peekByteIndex i arr = _constructor <$> peekByteIndex i arr \ -; {-# INLINE pokeByteIndex #-} \ -; pokeByteIndex i arr (_constructor a) = pokeByteIndex i arr a \ -; {-# INLINE sizeOf #-} \ -; sizeOf _ = SIZE_OF(_innerType) - -#define DERIVE_BINARY_UNBOX(_constraint, _type, _constructor, _innerType) \ -instance _constraint Unbox _type where { \ -; {-# INLINE peekByteIndex #-} \ -; peekByteIndex i arr = \ - peekByteIndex i arr >>= \ - (\p1 -> peekByteIndex (i + SIZE_OF(_innerType)) arr \ - <&> _constructor p1) \ -; {-# INLINE pokeByteIndex #-} \ -; pokeByteIndex i arr (_constructor p1 p2) = \ - pokeByteIndex i arr p1 >> \ - pokeByteIndex (i + SIZE_OF(_innerType)) arr p2 \ -; {-# INLINE sizeOf #-} \ -; sizeOf _ = 2 * SIZE_OF(_innerType) \ -} - -------------------------------------------------------------------------------- --- Unbox instances for primitive types -------------------------------------------------------------------------------- - -DERIVE_UNBOXED( Char - , C# - , readWord8ArrayAsWideChar# - , writeWord8ArrayAsWideChar# - , SIZEOF_HSCHAR) - -DERIVE_UNBOXED( Int8 - , I8# - , readInt8Array# - , writeInt8Array# - , 1) - -DERIVE_UNBOXED( Int16 - , I16# - , readWord8ArrayAsInt16# - , writeWord8ArrayAsInt16# - , 2) - -DERIVE_UNBOXED( Int32 - , I32# - , readWord8ArrayAsInt32# - , writeWord8ArrayAsInt32# - , 4) - -DERIVE_UNBOXED( Int - , I# - , readWord8ArrayAsInt# - , writeWord8ArrayAsInt# - , SIZEOF_HSINT) - -DERIVE_UNBOXED( Int64 - , I64# - , readWord8ArrayAsInt64# - , writeWord8ArrayAsInt64# - , 8) - -DERIVE_UNBOXED( Word - , W# - , readWord8ArrayAsWord# - , writeWord8ArrayAsWord# - , SIZEOF_HSWORD) - -DERIVE_UNBOXED( Word8 - , W8# - , readWord8Array# - , writeWord8Array# - , 1) - -DERIVE_UNBOXED( Word16 - , W16# - , readWord8ArrayAsWord16# - , writeWord8ArrayAsWord16# - , 2) - -DERIVE_UNBOXED( Word32 - , W32# - , readWord8ArrayAsWord32# - , writeWord8ArrayAsWord32# - , 4) - -DERIVE_UNBOXED( Word64 - , W64# - , readWord8ArrayAsWord64# - , writeWord8ArrayAsWord64# - , 8) - -DERIVE_UNBOXED( Double - , D# - , readWord8ArrayAsDouble# - , writeWord8ArrayAsDouble# - , SIZEOF_HSDOUBLE) - -DERIVE_UNBOXED( Float - , F# - , readWord8ArrayAsFloat# - , writeWord8ArrayAsFloat# - , SIZEOF_HSFLOAT) - -------------------------------------------------------------------------------- --- Unbox instances for derived types -------------------------------------------------------------------------------- - -DERIVE_UNBOXED( (StablePtr a) - , StablePtr - , readWord8ArrayAsStablePtr# - , writeWord8ArrayAsStablePtr# - , SIZEOF_HSSTABLEPTR) - -DERIVE_UNBOXED( (Ptr a) - , Ptr - , readWord8ArrayAsAddr# - , writeWord8ArrayAsAddr# - , SIZEOF_HSPTR) - -DERIVE_UNBOXED( (FunPtr a) - , FunPtr - , readWord8ArrayAsAddr# - , writeWord8ArrayAsAddr# - , SIZEOF_HSFUNPTR) - -DERIVE_WRAPPED_UNBOX(,IntPtr,IntPtr,Int) -DERIVE_WRAPPED_UNBOX(,WordPtr,WordPtr,Word) -DERIVE_WRAPPED_UNBOX(Unbox a =>,(Identity a),Identity,a) -#if MIN_VERSION_base(4,14,0) -DERIVE_WRAPPED_UNBOX(Unbox a =>,(Down a),Down,a) -#endif -DERIVE_WRAPPED_UNBOX(Unbox a =>,(Const a b),Const,a) -DERIVE_BINARY_UNBOX(forall a. Unbox a =>,(Complex a),(:+),a) -DERIVE_BINARY_UNBOX(forall a. Unbox a =>,(Ratio a),(:%),a) -DERIVE_BINARY_UNBOX(,Fingerprint,Fingerprint,Word64) - -instance Unbox () where - - {-# INLINE peekByteIndex #-} - peekByteIndex _ _ = return () - - {-# INLINE pokeByteIndex #-} - pokeByteIndex _ _ _ = return () - - {-# INLINE sizeOf #-} - sizeOf _ = 1 - -#if MIN_VERSION_base(4,15,0) -instance Unbox IoSubSystem where - - {-# INLINE peekByteIndex #-} - peekByteIndex i arr = toEnum <$> peekByteIndex i arr - - {-# INLINE pokeByteIndex #-} - pokeByteIndex i arr a = pokeByteIndex i arr (fromEnum a) - - {-# INLINE sizeOf #-} - sizeOf _ = sizeOf (Proxy :: Proxy Int) -#endif - -instance Unbox Bool where - - {-# INLINE peekByteIndex #-} - peekByteIndex i arr = do - res <- peekByteIndex i arr - return $ res /= (0 :: Int8) - - {-# INLINE pokeByteIndex #-} - pokeByteIndex i arr a = - if a - then pokeByteIndex i arr (1 :: Int8) - else pokeByteIndex i arr (0 :: Int8) - - {-# INLINE sizeOf #-} - sizeOf _ = 1 - --------------------------------------------------------------------------------- --- Functions --------------------------------------------------------------------------------- - -{-# INLINE peekWith #-} -peekWith :: Unbox a => MutableByteArray -> Int -> IO a -peekWith arr i = peekByteIndex i arr - -{-# INLINE pokeWith #-} -pokeWith :: Unbox a => MutableByteArray -> Int -> a -> IO () -pokeWith arr i = pokeByteIndex i arr - --------------------------------------------------------------------------------- --- Generic deriving --------------------------------------------------------------------------------- - --- Utilities to build or parse a type safely and easily. - --- | A location inside a mutable byte array with the bound of the array. Is it --- cheaper to just get the bound using the size of the array whenever needed? -data BoundedPtr = - BoundedPtr - MutableByteArray -- byte array - Int -- current pos - Int -- position after end - --------------------------------------------------------------------------------- --- Peeker monad --------------------------------------------------------------------------------- - --- | Chains peek functions that pass the current position to the next function -newtype Peeker a = Peeker (Builder BoundedPtr IO a) - deriving (Functor, Applicative, Monad) - -{-# INLINE readUnsafe #-} -readUnsafe :: Unbox a => Peeker a -readUnsafe = Peeker (Builder step) - - where - - {-# INLINE step #-} - step :: forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a) - step (BoundedPtr arr pos end) = do - let next = pos + sizeOf (Proxy :: Proxy a) - r <- peekByteIndex pos arr - return (BoundedPtr arr next end, r) - -{-# INLINE read #-} -read :: Unbox a => Peeker a -read = Peeker (Builder step) - - where - - {-# INLINE step #-} - step :: forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a) - step (BoundedPtr arr pos end) = do - let next = pos + sizeOf (Proxy :: Proxy a) - when (next > end) $ error "peekObject reading beyond limit" - r <- peekByteIndex pos arr - return (BoundedPtr arr next end, r) - -{-# INLINE skipByte #-} -skipByte :: Peeker () -skipByte = Peeker (Builder step) - - where - - {-# INLINE step #-} - step :: BoundedPtr -> IO (BoundedPtr, ()) - step (BoundedPtr arr pos end) = do - let next = pos + 1 - when (next > end) - $ error $ "skipByte: reading beyond limit. next = " - ++ show next - ++ " end = " ++ show end - return (BoundedPtr arr next end, ()) - -{-# INLINE runPeeker #-} -runPeeker :: Peeker a -> BoundedPtr -> IO a -runPeeker (Peeker (Builder f)) ptr = fmap snd (f ptr) - --------------------------------------------------------------------------------- --- Poke utilities --------------------------------------------------------------------------------- - --- XXX Using a Poker monad may be useful when we have to compute the size to be --- poked as we go and then poke the size at a previous location. For variable --- sized object serialization we may also want to reallocate the array and --- return the newly allocated array in the output. - --- Does not check writing beyond bound. -{-# INLINE pokeBoundedPtrUnsafe #-} -pokeBoundedPtrUnsafe :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr -pokeBoundedPtrUnsafe a (BoundedPtr arr pos end) = do - let next = pos + sizeOf (Proxy :: Proxy a) - pokeByteIndex pos arr a - return (BoundedPtr arr next end) - -{-# INLINE pokeBoundedPtr #-} -pokeBoundedPtr :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr -pokeBoundedPtr a (BoundedPtr arr pos end) = do - let next = pos + sizeOf (Proxy :: Proxy a) - when (next > end) $ error "pokeBoundedPtr writing beyond limit" - pokeByteIndex pos arr a - return (BoundedPtr arr next end) - --------------------------------------------------------------------------------- --- Check the number of constructors in a sum type --------------------------------------------------------------------------------- - --- Count the constructors of a sum type. -type family SumArity (a :: Type -> Type) :: Nat where - SumArity (C1 _ _) = 1 - -- Requires UndecidableInstances - SumArity (f :+: g) = SumArity f + SumArity g - -type family TypeErrorMessage (a :: Symbol) :: Constraint where - TypeErrorMessage a = TypeError ('Text a) - -type family ArityCheck (b :: Bool) :: Constraint where - ArityCheck 'True = () - ArityCheck 'False = TypeErrorMessage - "Generic Unbox deriving does not support > 256 constructors." - --- Type constraint to restrict the sum type arity so that the constructor tag --- can fit in a single byte. -type MaxArity256 n = ArityCheck (n <=? 255) - --------------------------------------------------------------------------------- --- Generic Deriving of Unbox instance --------------------------------------------------------------------------------- - --- Unbox uses fixed size encoding, therefore, when a (sum) type has multiple --- constructors, the size of the type is computed as the maximum required by --- any constructor. Therefore, size is independent of the value, it can be --- determined solely by the type. - --- | Implementation of sizeOf that works on the generic representation of an --- ADT. -class SizeOfRep (f :: Type -> Type) where - sizeOfRep :: f x -> Int - --- Meta information wrapper, go inside -instance SizeOfRep f => SizeOfRep (M1 i c f) where - {-# INLINE sizeOfRep #-} - sizeOfRep _ = sizeOfRep (undefined :: f x) - --- Primitive type "a". -instance Unbox a => SizeOfRep (K1 i a) where - {-# INLINE sizeOfRep #-} - sizeOfRep _ = sizeOf (Proxy :: Proxy a) - --- Void: data type without constructors. Values of this type cannot exist, --- therefore the size is undefined. We should never be serializing structures --- with elements of this type. -instance SizeOfRep V1 where - {-# INLINE sizeOfRep #-} - sizeOfRep = error "sizeOfRep: a value of a Void type must not exist" - --- Note that when a sum type has many unit constructors only a single byte is --- required to encode the type as only the constructor tag is stored. -instance SizeOfRep U1 where - {-# INLINE sizeOfRep #-} - sizeOfRep _ = 0 - --- Product type -instance (SizeOfRep f, SizeOfRep g) => SizeOfRep (f :*: g) where - {-# INLINE sizeOfRep #-} - sizeOfRep _ = sizeOfRep (undefined :: f x) + sizeOfRep (undefined :: g x) - -------------------------------------------------------------------------------- - -class SizeOfRepSum (f :: Type -> Type) where - sizeOfRepSum :: f x -> Int - --- Constructor -instance SizeOfRep a => SizeOfRepSum (C1 c a) where - {-# INLINE sizeOfRepSum #-} - sizeOfRepSum = sizeOfRep - -instance (SizeOfRepSum f, SizeOfRepSum g) => SizeOfRepSum (f :+: g) where - {-# INLINE sizeOfRepSum #-} - sizeOfRepSum _ = - max (sizeOfRepSum (undefined :: f x)) (sizeOfRepSum (undefined :: g x)) - -------------------------------------------------------------------------------- - -instance (MaxArity256 (SumArity (f :+: g)), SizeOfRepSum f, SizeOfRepSum g) => - SizeOfRep (f :+: g) where - - -- The size of a sum type is the max of any of the constructor size. - -- sizeOfRepSum type class operation is used here instead of sizeOfRep so - -- that we add the constructor index byte only for the first time and avoid - -- including it for the subsequent sum constructors. - {-# INLINE sizeOfRep #-} - sizeOfRep _ = - -- One byte for the constructor id and then the constructor value. - sizeOf (Proxy :: Proxy Word8) + - max (sizeOfRepSum (undefined :: f x)) - (sizeOfRepSum (undefined :: g x)) - --- Unit: constructors without arguments. --- Theoretically the size can be 0, but we use 1 to simplify the implementation --- of an array of unit type elements. With a non-zero size we can count the number --- of elements in the array based on the size of the array. Otherwise we will --- have to store a virtual length in the array, but keep the physical size of --- the array as 0. Or we will have to make a special handling for zero sized --- elements to make the size as 1. Or we can disallow arrays with elements --- having size 0. --- -{-# INLINE genericSizeOf #-} -genericSizeOf :: forall a. (SizeOfRep (Rep a)) => Proxy a -> Int -genericSizeOf _ = - let s = sizeOfRep (undefined :: Rep a x) - in if s == 0 then 1 else s - --------------------------------------------------------------------------------- --- Generic poke --------------------------------------------------------------------------------- - -class PokeRep (f :: Type -> Type) where - pokeRep :: f a -> BoundedPtr -> IO BoundedPtr - -instance PokeRep f => PokeRep (M1 i c f) where - {-# INLINE pokeRep #-} - pokeRep f = pokeRep (unM1 f) - -instance Unbox a => PokeRep (K1 i a) where - {-# INLINE pokeRep #-} - pokeRep a = pokeBoundedPtr (unK1 a) - -instance PokeRep V1 where - {-# INLINE pokeRep #-} - pokeRep = error "pokeRep: a value of a Void type should not exist" - -instance PokeRep U1 where - {-# INLINE pokeRep #-} - pokeRep _ x = pure x - -instance (PokeRep f, PokeRep g) => PokeRep (f :*: g) where - {-# INLINE pokeRep #-} - pokeRep (f :*: g) ptr = pokeRep f ptr >>= pokeRep g - -------------------------------------------------------------------------------- - -class KnownNat n => PokeRepSum (n :: Nat) (f :: Type -> Type) where - -- "n" is the constructor tag to be poked. - pokeRepSum :: Proxy n -> f a -> BoundedPtr -> IO BoundedPtr - -instance (KnownNat n, PokeRep a) => PokeRepSum n (C1 c a) where - {-# INLINE pokeRepSum #-} - pokeRepSum _ x ptr = do - pokeBoundedPtr (fromInteger (natVal (Proxy :: Proxy n)) :: Word8) ptr - >>= pokeRep x - -instance (KnownNat n, PokeRepSum n f, PokeRepSum (n + SumArity f) g) - => PokeRepSum n (f :+: g) where - {-# INLINE pokeRepSum #-} - pokeRepSum _ (L1 x) ptr = - pokeRepSum (Proxy :: Proxy n) x ptr - pokeRepSum _ (R1 x) ptr = - pokeRepSum (Proxy :: Proxy (n + SumArity f)) x ptr - -------------------------------------------------------------------------------- - -instance (MaxArity256 (SumArity (f :+: g)), PokeRepSum 0 (f :+: g)) => - PokeRep (f :+: g) where - - {-# INLINE pokeRep #-} - pokeRep = pokeRepSum (Proxy :: Proxy 0) - -{-# INLINE genericPokeObject #-} -genericPokeObject :: (Generic a, PokeRep (Rep a)) => - a -> BoundedPtr -> IO BoundedPtr -genericPokeObject a = pokeRep (from a) - -genericPokeObj :: (Generic a, PokeRep (Rep a)) => a -> BoundedPtr -> IO () -genericPokeObj a ptr = void $ genericPokeObject a ptr - -{-# INLINE genericPokeByteIndex #-} -genericPokeByteIndex :: (Generic a, PokeRep (Rep a)) => - MutableByteArray -> Int -> a -> IO () -genericPokeByteIndex arr index x = do - -- XXX Should we use unsafe poke? - end <- sizeOfMutableByteArray arr - genericPokeObj x (BoundedPtr arr index end) - --------------------------------------------------------------------------------- --- Generic peek --------------------------------------------------------------------------------- - -class PeekRep (f :: Type -> Type) where - peekRep :: Peeker (f x) - -instance PeekRep f => PeekRep (M1 i c f) where - {-# INLINE peekRep #-} - peekRep = fmap M1 peekRep - -instance Unbox a => PeekRep (K1 i a) where - {-# INLINE peekRep #-} - peekRep = fmap K1 read - -instance PeekRep V1 where - {-# INLINE peekRep #-} - peekRep = error "peekRep: a value of a Void type should not exist" - -instance PeekRep U1 where - {-# INLINE peekRep #-} - peekRep = pure U1 - -instance (PeekRep f, PeekRep g) => PeekRep (f :*: g) where - {-# INLINE peekRep #-} - peekRep = (:*:) <$> peekRep <*> peekRep - -------------------------------------------------------------------------------- - -class KnownNat n => PeekRepSum (n :: Nat) (f :: Type -> Type) where - -- "n" is the constructor tag to be matched. - peekRepSum :: Proxy n -> Word8 -> Peeker (f a) - -instance (KnownNat n, PeekRep a) => PeekRepSum n (C1 c a) where - {-# INLINE peekRepSum #-} - peekRepSum _ tag - | tag == curTag = peekRep - | tag > curTag = - error $ "Unbox instance peek: Constructor tag index " - ++ show tag ++ " out of range, max tag index is " - ++ show curTag - | otherwise = error "peekRepSum: bug" - - where - - curTag = fromInteger (natVal (Proxy :: Proxy n)) - -instance (KnownNat n, PeekRepSum n f, PeekRepSum (n + SumArity f) g) - => PeekRepSum n (f :+: g) where - {-# INLINE peekRepSum #-} - peekRepSum curProxy tag - | tag < firstRightTag = - L1 <$> peekRepSum curProxy tag - | otherwise = - R1 <$> peekRepSum (Proxy :: Proxy (n + SumArity f)) tag - - where - - firstRightTag = fromInteger (natVal (Proxy :: Proxy (n + SumArity f))) - -------------------------------------------------------------------------------- - -instance (MaxArity256 (SumArity (f :+: g)), PeekRepSum 0 (f :+: g)) - => PeekRep (f :+: g) where - {-# INLINE peekRep #-} - peekRep = do - tag <- read - peekRepSum (Proxy :: Proxy 0) tag - -{-# INLINE genericPeeker #-} -genericPeeker :: (Generic a, PeekRep (Rep a)) => Peeker a -genericPeeker = to <$> peekRep - -{-# INLINE genericPeekBoundedPtr #-} -genericPeekBoundedPtr :: (Generic a, PeekRep (Rep a)) => BoundedPtr -> IO a -genericPeekBoundedPtr = runPeeker genericPeeker - -{-# INLINE genericPeekByteIndex #-} -genericPeekByteIndex :: (Generic a, PeekRep (Rep a)) => - MutableByteArray -> Int -> IO a -genericPeekByteIndex arr index = do - -- XXX Should we use unsafe peek? - end <- sizeOfMutableByteArray arr - genericPeekBoundedPtr (BoundedPtr arr index end) diff --git a/src/Streamly/Internal/Data/Unfold.hs b/src/Streamly/Internal/Data/Unfold.hs --- a/src/Streamly/Internal/Data/Unfold.hs +++ b/src/Streamly/Internal/Data/Unfold.hs @@ -16,69 +16,28 @@ -- $setup -- * Unfold Type - Step(..) - , Unfold + module Streamly.Internal.Data.Unfold.Type -- * Unfolds -- One to one correspondence with -- "Streamly.Internal.Data.Stream.Generate" -- ** Basic Constructors - , mkUnfoldM - , mkUnfoldrM - , unfoldrM - , unfoldr - , functionM - , function - , identity , nilM , nil , consM - -- ** From Values - , fromEffect - , fromPure - -- ** Generators -- | Generate a monadic stream from a seed. , repeatM + , repeat , replicateM , fromIndicesM , iterateM -- ** Enumerations - , Enumerable (..) - - -- ** Enumerate Num - , enumerateFromNum - , enumerateFromThenNum - , enumerateFromStepNum - - -- ** Enumerating 'Bounded 'Integral' Types - , enumerateFromIntegralBounded - , enumerateFromThenIntegralBounded - , enumerateFromToIntegralBounded - , enumerateFromThenToIntegralBounded - - -- ** Enumerating 'Unounded Integral' Types - , enumerateFromIntegral - , enumerateFromThenIntegral - , enumerateFromToIntegral - , enumerateFromThenToIntegral - - -- ** Enumerating 'Small Integral' Types - , enumerateFromSmallBounded - , enumerateFromThenSmallBounded - , enumerateFromToSmall - , enumerateFromThenToSmall - - -- ** Enumerating 'Fractional' Types - , enumerateFromFractional - , enumerateFromThenFractional - , enumerateFromToFractional - , enumerateFromThenToFractional + , module Streamly.Internal.Data.Unfold.Enumeration -- ** From Containers - , fromList , fromListM -- ** From Memory @@ -91,11 +50,6 @@ -- * Combinators -- ** Mapping on Input - , lmap - , lmapM - , both - , first - , second , discardFirst , discardSecond , swap @@ -105,20 +59,11 @@ -- * Folding , fold - -- XXX Add "WithInput" versions of all these, map2, postscan2, takeWhile2, - -- filter2 etc. Alternatively, we can use the default operations with - -- input, but that might make the common case more inconvenient. - -- ** Mapping on Output - , map - , map2 - , mapM - , mapM2 - , postscanlM' , postscan - , scan - , scanMany + , scanl + , scanlMany , foldMany -- pipe @@ -126,8 +71,6 @@ , either -- ** Filtering - , takeWhileM - , takeWhile , take , filter , filterM @@ -135,23 +78,11 @@ , dropWhile , dropWhileM - -- ** Zipping - , zipWithM - , zipWith - -- ** Cross product - , crossWithM - , crossWith - , cross - , joinInnerGeneric - , crossApply + , innerJoin - -- ** Nesting - , ConcatState (..) - , many - , many2 - , concatMapM - , bind + -- ** Zip + , zipRepeat -- ** Resource Management -- | 'bracket' is the most general resource management operation, all other @@ -176,6 +107,10 @@ -- stream of arrays before flattening it to a stream of chars. , onException , handle + + -- ** Deprecated + , scan + , scanMany ) where @@ -187,29 +122,34 @@ import Data.Functor (($>)) import GHC.Types (SPEC(..)) import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Scanl.Type (Scanl(..)) import Streamly.Internal.Data.IOFinalizer (newIOFinalizer, runIOFinalizer, clearingIOFinalizer) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream(..), Step(..)) +import Streamly.Internal.Data.Stream.Type (Stream(..)) import Streamly.Internal.Data.SVar.Type (defState) import qualified Control.Monad.Catch as MC import qualified Data.Tuple as Tuple import qualified Streamly.Internal.Data.Fold.Type as FL -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.Stream.Type as D +import qualified Streamly.Internal.Data.StreamK.Type as K import qualified Prelude import Streamly.Internal.Data.Unfold.Enumeration import Streamly.Internal.Data.Unfold.Type import Prelude hiding (map, mapM, takeWhile, take, filter, const, zipWith - , drop, dropWhile, either) + , drop, dropWhile, either, scanl, repeat) import Control.Monad.IO.Class (MonadIO (liftIO)) import Foreign (Storable, peek, sizeOf) import Foreign.Ptr #include "DocTestDataUnfold.hs" +------------------------------------------------------------------------------- +-- Input operations +------------------------------------------------------------------------------- + -- | Convert an 'Unfold' into an unfold accepting a tuple as an argument, -- using the argument of the original fold as the second element of tuple and -- discarding the first element of the tuple. @@ -270,7 +210,7 @@ -- {-# INLINE_NORMAL fold #-} fold :: Monad m => Fold m b c -> Unfold m a b -> a -> m c -fold (Fold fstep initial extract) (Unfold ustep inject) a = do +fold (Fold fstep initial _ final) (Unfold ustep inject) a = do res <- initial case res of FL.Partial x -> inject a >>= go SPEC x @@ -288,7 +228,7 @@ FL.Partial fs1 -> go SPEC fs1 s FL.Done c -> return c Skip s -> go SPEC fs s - Stop -> extract fs + Stop -> final fs -- {-# ANN type FoldMany Fuse #-} data FoldMany s fs b a @@ -303,7 +243,7 @@ -- /Pre-release/ {-# INLINE_NORMAL foldMany #-} foldMany :: Monad m => Fold m b c -> Unfold m a b -> Unfold m a c -foldMany (Fold fstep initial extract) (Unfold ustep inject1) = +foldMany (Fold fstep initial _ final) (Unfold ustep inject1) = Unfold step inject where @@ -334,14 +274,14 @@ case r of Yield x s -> consume x s fs Skip s -> return $ Skip (FoldManyFirst fs s) - Stop -> return Stop + Stop -> final fs >> return Stop step (FoldManyLoop st fs) = do r <- ustep st case r of Yield x s -> consume x s fs Skip s -> return $ Skip (FoldManyLoop s fs) Stop -> do - b <- extract fs + b <- final fs return $ Skip (FoldManyYield b FoldManyDone) step (FoldManyYield b next) = return $ Yield b next step FoldManyDone = return Stop @@ -382,7 +322,7 @@ -- /Pre-release/ {-# INLINE_NORMAL postscan #-} postscan :: Monad m => Fold m b c -> Unfold m a b -> Unfold m a c -postscan (Fold stepF initial extract) (Unfold stepU injectU) = +postscan (Fold stepF initial extract final) (Unfold stepU injectU) = Unfold step inject where @@ -405,15 +345,15 @@ v <- extract fs1 return $ Yield v (Just (fs1, s)) Skip s -> return $ Skip (Just (fs, s)) - Stop -> return Stop + Stop -> final fs >> return Stop step Nothing = return Stop data ScanState s f = ScanInit s | ScanDo s !f | ScanDone {-# INLINE_NORMAL scanWith #-} -scanWith :: Monad m => Bool -> Fold m b c -> Unfold m a b -> Unfold m a c -scanWith restart (Fold fstep initial extract) (Unfold stepU injectU) = +scanWith :: Monad m => Bool -> Scanl m b c -> Unfold m a b -> Unfold m a c +scanWith restart (Scanl fstep initial extract final) (Unfold stepU injectU) = Unfold step inject where @@ -438,34 +378,46 @@ case res of Yield x s -> runStep s (fstep fs x) Skip s -> return $ Skip $ ScanDo s fs - Stop -> return Stop + Stop -> final fs >> return Stop step ScanDone = return Stop -- | Scan the output of an 'Unfold' to change it in a stateful manner. -- Once fold is done it will restart from its initial state. -- --- >>> u = Unfold.scanMany (Fold.take 2 Fold.sum) Unfold.fromList +-- >>> u = Unfold.scanlMany (Scanl.take 2 Scanl.sum) Unfold.fromList -- >>> Unfold.fold Fold.toList u [1,2,3,4,5] -- [0,1,3,0,3,7,0,5] -- -- /Pre-release/ +{-# INLINE_NORMAL scanlMany #-} +scanlMany :: Monad m => Scanl m b c -> Unfold m a b -> Unfold m a c +scanlMany = scanWith True + +-- When we remove extract from Fold this function should be removed. +{-# DEPRECATED scanMany "Please use scanlMany instead" #-} {-# INLINE_NORMAL scanMany #-} scanMany :: Monad m => Fold m b c -> Unfold m a b -> Unfold m a c -scanMany = scanWith True +scanMany (Fold s i e f) = scanWith True (Scanl s i e f) -- scan2 :: Monad m => Refold m a b c -> Unfold m a b -> Unfold m a c -- | Scan the output of an 'Unfold' to change it in a stateful manner. -- Once fold is done it will stop. -- --- >>> u = Unfold.scan (Fold.take 2 Fold.sum) Unfold.fromList +-- >>> u = Unfold.scanl (Scanl.take 2 Scanl.sum) Unfold.fromList -- >>> Unfold.fold Fold.toList u [1,2,3,4,5] -- [0,1,3] -- -- /Pre-release/ +{-# INLINE_NORMAL scanl #-} +scanl :: Monad m => Scanl m b c -> Unfold m a b -> Unfold m a c +scanl = scanWith False + +-- When we remove extract from Fold this function should be removed. +{-# DEPRECATED scan "Please use scanl instead" #-} {-# INLINE_NORMAL scan #-} scan :: Monad m => Fold m b c -> Unfold m a b -> Unfold m a c -scan = scanWith False +scan (Fold s i e f) = scanWith False (Scanl s i e f) -- | Scan the output of an 'Unfold' to change it in a stateful manner. -- @@ -584,7 +536,7 @@ where - inject seed = pure seed + inject = pure {-# INLINE_LATE step #-} step (i, action) = @@ -603,6 +555,32 @@ {-# INLINE_LATE step #-} step action = (`Yield` action) <$> action +{-# INLINE repeat #-} +repeat :: Applicative m => Unfold m a a +repeat = lmap pure repeatM + +-- | Takes a tuple whose first element is repeated and the second element is +-- passed through the supplied unfold. +-- +-- >>> zipRepeat = fmap (\(x,y) -> (fst x, y)) . Unfold.carry . Unfold.lmap snd +-- >>> zipRepeat = Unfold.zipArrowWith (,) Unfold.repeat +-- +{-# INLINE_NORMAL zipRepeat #-} +zipRepeat :: Functor m => Unfold m a b -> Unfold m (c,a) (c,b) +-- zipRepeat = zipArrowWith (,) repeat +zipRepeat (Unfold ustep uinject) = Unfold step (\(c,a) -> (c,) <$> uinject a) + + where + + func a r = + case r of + Yield x s -> Yield (a, x) (a, s) + Skip s -> Skip (a, s) + Stop -> Stop + + {-# INLINE_LATE step #-} + step (a, st) = fmap (func a) (ustep st) + -- | Generates an infinite stream starting with the given seed and applying the -- given function repeatedly. -- @@ -742,10 +720,12 @@ dropWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b dropWhile f = dropWhileM (return . f) -{-# INLINE_NORMAL joinInnerGeneric #-} -joinInnerGeneric :: Monad m => +-- | Cross intersection of two unfolds. See +-- 'Streamly.Internal.Data.Stream.innerJoin' for more details. +{-# INLINE_NORMAL innerJoin #-} +innerJoin :: Monad m => (b -> c -> Bool) -> Unfold m a b -> Unfold m a c -> Unfold m a (b, c) -joinInnerGeneric eq s1 s2 = filter (\(a, b) -> a `eq` b) $ cross s1 s2 +innerJoin eq s1 s2 = filter (\(a, b) -> a `eq` b) $ cross s1 s2 ------------------------------------------------------------------------------ -- Exceptions diff --git a/src/Streamly/Internal/Data/Unfold/Enumeration.hs b/src/Streamly/Internal/Data/Unfold/Enumeration.hs --- a/src/Streamly/Internal/Data/Unfold/Enumeration.hs +++ b/src/Streamly/Internal/Data/Unfold/Enumeration.hs @@ -65,7 +65,6 @@ import Data.Word import Numeric.Natural import Data.Functor.Identity (Identity(..)) -import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) import Streamly.Internal.Data.Unfold.Type import Prelude hiding (map, mapM, takeWhile, take, filter, const, zipWith @@ -88,7 +87,7 @@ -- the value overflows it keeps enumerating in a cycle: -- -- @ --- >>> Stream.fold Fold.toList $ Stream.take 10 $ Stream.unfold Unfold.enumerateFromStepNum (255::Word8,1) +-- >>> Stream.toList $ Stream.take 10 $ Stream.unfold Unfold.enumerateFromStepNum (255::Word8,1) -- [255,0,1,2,3,4,5,6,7,8] -- -- @ @@ -125,7 +124,7 @@ -- -- Example: -- @ --- >>> Stream.fold Fold.toList $ Stream.take 10 $ Stream.unfold enumerateFromThenNum (255::Word8,0) +-- >>> Stream.toList $ Stream.take 10 $ Stream.unfold enumerateFromThenNum (255::Word8,0) -- [255,0,1,2,3,4,5,6,7,8] -- -- @ @@ -152,7 +151,7 @@ -- -- @ -- >>> enumerateFromNum = lmap (\from -> (from, 1)) Unfold.enumerateFromStepNum --- >>> Stream.fold Fold.toList $ Stream.take 6 $ Stream.unfold enumerateFromNum (0.9) +-- >>> Stream.toList $ Stream.take 6 $ Stream.unfold enumerateFromNum (0.9) -- [0.9,1.9,2.9,3.9,4.9,5.9] -- -- @ @@ -162,7 +161,7 @@ -- -- @ -- >>> enumerateFromNum = lmap (\from -> (from, from + 1)) Unfold.enumerateFromThenNum --- >>> Stream.fold Fold.toList $ Stream.take 6 $ Stream.unfold enumerateFromNum (0.9) +-- >>> Stream.toList $ Stream.take 6 $ Stream.unfold enumerateFromNum (0.9) -- [0.9,1.9,2.9,3.8999999999999995,4.8999999999999995,5.8999999999999995] -- -- @ @@ -284,7 +283,7 @@ -- specified upper limit rounded to the nearest integral value: -- -- @ --- >>> Stream.fold Fold.toList $ Stream.unfold Unfold.enumerateFromToFractional (0.1, 6.3) +-- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromToFractional (0.1, 6.3) -- [0.1,1.1,2.1,3.1,4.1,5.1,6.1] -- -- @ @@ -389,24 +388,15 @@ -- @from@, enumerating up to 'maxBound' when the type is 'Bounded' or -- generating an infinite stream when the type is not 'Bounded'. -- - -- >>> import qualified Streamly.Data.Stream as Stream - -- >>> import qualified Streamly.Internal.Data.Unfold as Unfold - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFrom (0 :: Int) + -- >>> Stream.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFrom (0 :: Int) -- [0,1,2,3] -- - -- @ - -- -- For 'Fractional' types, enumeration is numerically stable. However, no -- overflow or underflow checks are performed. -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFrom 1.1 + -- >>> Stream.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFrom 1.1 -- [1.1,2.1,3.1,4.1] -- - -- @ - -- -- /Pre-release/ -- enumerateFrom :: Monad m => Unfold m a a @@ -415,27 +405,18 @@ -- @from@, enumerating the type up to the value @to@. If @to@ is smaller than -- @from@ then an empty stream is returned. -- - -- >>> import qualified Streamly.Data.Stream as Stream - -- >>> import qualified Streamly.Internal.Data.Unfold as Unfold - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.unfold Unfold.enumerateFromTo (0, 4) + -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromTo (0, 4) -- [0,1,2,3,4] -- - -- @ - -- -- For 'Fractional' types, the last element is equal to the specified @to@ -- value after rounding to the nearest integral value. -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.unfold Unfold.enumerateFromTo (1.1, 4) + -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromTo (1.1, 4) -- [1.1,2.1,3.1,4.1] -- - -- >>> Stream.fold Fold.toList $ Stream.unfold Unfold.enumerateFromTo (1.1, 4.6) + -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromTo (1.1, 4.6) -- [1.1,2.1,3.1,4.1,5.1] -- - -- @ - -- -- /Pre-release/ enumerateFromTo :: Monad m => Unfold m (a, a) a @@ -445,18 +426,12 @@ -- after @from@. For 'Bounded' types the stream ends when 'maxBound' is -- reached, for unbounded types it keeps enumerating infinitely. -- - -- >>> import qualified Streamly.Data.Stream as Stream - -- >>> import qualified Streamly.Internal.Data.Unfold as Unfold - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFromThen (0, 2) + -- >>> Stream.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFromThen (0, 2) -- [0,2,4,6] -- - -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFromThen (0,(-2)) + -- >>> Stream.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFromThen (0,(-2)) -- [0,-2,-4,-6] -- - -- @ - -- -- /Pre-release/ enumerateFromThen :: Monad m => Unfold m (a, a) a @@ -465,17 +440,11 @@ -- @to@. Enumeration can occur downwards or upwards depending on whether @then@ -- comes before or after @from@. -- - -- >>> import qualified Streamly.Data.Stream as Stream - -- >>> import qualified Streamly.Internal.Data.Unfold as Unfold - -- - -- @ - -- >>> Stream.fold Fold.toList $ Stream.unfold Unfold.enumerateFromThenTo (0, 2, 6) + -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromThenTo (0, 2, 6) -- [0,2,4,6] -- - -- >>> Stream.fold Fold.toList $ Stream.unfold Unfold.enumerateFromThenTo (0, (-2), (-6)) + -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromThenTo (0, (-2), (-6)) -- [0,-2,-4,-6] - -- - -- @ -- -- /Pre-release/ enumerateFromThenTo :: Monad m => Unfold m (a, a, a) a diff --git a/src/Streamly/Internal/Data/Unfold/Type.hs b/src/Streamly/Internal/Data/Unfold/Type.hs --- a/src/Streamly/Internal/Data/Unfold/Type.hs +++ b/src/Streamly/Internal/Data/Unfold/Type.hs @@ -26,7 +26,7 @@ -- much less efficient when compared to combinators using 'Unfold'. For -- example, the 'Streamly.Data.Stream.concatMap' combinator which uses @a -> t m b@ -- (where @t@ is a stream type) to generate streams is much less efficient --- compared to 'Streamly.Data.Stream.unfoldMany'. +-- compared to 'Streamly.Data.Stream.unfoldEach'. -- -- On the other hand, transformation operations on stream types are as -- efficient as transformations on 'Unfold'. @@ -39,17 +39,13 @@ module Streamly.Internal.Data.Unfold.Type ( - -- * Setup - -- | To execute the code examples provided in this module in ghci, please - -- run the following commands first. - -- - -- $setup - -- * General Notes -- $notes -- * Type - Unfold (..) + -- StreamD Step type re-exported + Step(..) + , Unfold (..) -- * Basic Constructors , mkUnfoldM @@ -66,34 +62,36 @@ -- * From Containers , fromList + , fromTuple -- * Transformations , lmap , lmapM , map - , map2 , mapM - , mapM2 , both + , supply , first , second + , carry -- * Trimming - , takeWhileMWithInput , takeWhileM , takeWhile -- * Nesting + , interleave , ConcatState (..) - , many - , many2 - , manyInterleave - -- , manyInterleave2 + , unfoldEach + , unfoldEachInterleave -- Applicative , crossApplySnd , crossApplyFst , crossWithM + , fairCrossWithM + , fairCrossWith + , fairCross , crossWith , cross , crossApply @@ -103,11 +101,22 @@ , concatMap , bind + , zipArrowWithM + , zipArrowWith , zipWithM , zipWith + + -- * Deprecated + , many + , many2 + , manyInterleave + , map2 + , mapM2 + , takeWhileMWithInput ) where +#include "deprecation.h" #include "inline.hs" -- import Control.Arrow (Arrow(..)) @@ -115,8 +124,7 @@ import Control.Monad ((>=>)) import Data.Void (Void) import Fusion.Plugin.Types (Fuse(..)) -import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) +import Streamly.Internal.Data.Stream.Step (Step(..)) import Prelude hiding (map, mapM, concatMap, zipWith, takeWhile) @@ -150,13 +158,13 @@ -- -- This allows an important optimization to occur in several cases, making the -- 'Unfold' a more efficient abstraction. Consider the 'concatMap' and --- 'unfoldMany' operations, the latter is more efficient. 'concatMap' +-- 'unfoldEach' operations, the latter is more efficient. 'concatMap' -- generates a new stream object from each element in the stream by applying -- the supplied function to the element, the stream object includes the "step" -- function as well as the initial "state" of the stream. Since the stream is -- generated dynamically the compiler does not know the step function or the -- state type statically at compile time, therefore, it cannot inline it. On --- the other hand in case of 'unfoldMany' the compiler has visibility into +-- the other hand in case of 'unfoldEach' the compiler has visibility into -- the unfold's state generation function, therefore, the compiler knows all -- the types statically and it can inline the inject as well as the step -- functions, generating efficient code. Essentially, the stream is not opaque @@ -221,6 +229,8 @@ -- Basic constructors ------------------------------------------------------------------------------ +-- XXX unfoldWith? + -- | Make an unfold from @step@ and @inject@ functions. -- -- /Pre-release/ @@ -279,32 +289,35 @@ -- >>> Unfold.fold Fold.toList u [1..5] -- [2,3,4,5,6] -- --- @ --- lmap f = Unfold.many (Unfold.function f) --- @ +-- Definition: -- +-- >>> lmap f = Unfold.unfoldEach (Unfold.function f) +-- {-# INLINE_NORMAL lmap #-} lmap :: (a -> c) -> Unfold m c b -> Unfold m a b lmap f (Unfold ustep uinject) = Unfold ustep (uinject Prelude.. f) -- | Map an action on the input argument of the 'Unfold'. -- --- @ --- lmapM f = Unfold.many (Unfold.functionM f) --- @ +-- Definition: -- +-- lmapM f = Unfold.unfoldEach (Unfold.functionM f) +-- {-# INLINE_NORMAL lmapM #-} lmapM :: Monad m => (a -> m c) -> Unfold m c b -> Unfold m a b lmapM f (Unfold ustep uinject) = Unfold ustep (f >=> uinject) -- | Supply the seed to an unfold closing the input end of the unfold. -- --- @ --- both a = Unfold.lmap (Prelude.const a) --- @ +-- >>> supply a = Unfold.lmap (Prelude.const a) -- -- /Pre-release/ -- +{-# INLINE_NORMAL supply #-} +supply :: a -> Unfold m a b -> Unfold m () b +supply a = lmap (Prelude.const a) + +{-# DEPRECATED both "Use supply instead." #-} {-# INLINE_NORMAL both #-} both :: a -> Unfold m a b -> Unfold m Void b both a = lmap (Prelude.const a) @@ -341,9 +354,13 @@ -- Filter input ------------------------------------------------------------------------------ +-- | +-- >>> takeWhileMWithInput f u = Unfold.map snd $ Unfold.takeWhileM (\(a,b) -> f a b) (Unfold.carry u) {-# INLINE_NORMAL takeWhileMWithInput #-} takeWhileMWithInput :: Monad m => (a -> b -> m Bool) -> Unfold m a b -> Unfold m a b +takeWhileMWithInput f u = map snd $ takeWhileM (\(a,b) -> f a b) (carry u) +{- takeWhileMWithInput f (Unfold step1 inject1) = Unfold step inject where @@ -361,6 +378,7 @@ return $ if b then Yield x (Tuple' a s) else Stop Skip s -> return $ Skip (Tuple' a s) Stop -> return Stop +-} -- | Same as 'takeWhile' but with a monadic predicate. -- @@ -393,8 +411,11 @@ -- Functor ------------------------------------------------------------------------------ +{-# DEPRECATED mapM2 "Use carry with mapM instead." #-} {-# INLINE_NORMAL mapM2 #-} mapM2 :: Monad m => (a -> b -> m c) -> Unfold m a b -> Unfold m a c +mapM2 f = mapM (uncurry f) . carry +{- mapM2 f (Unfold ustep uinject) = Unfold step inject where inject a = do @@ -408,12 +429,11 @@ Yield x s -> f inp x >>= \a -> return $ Yield a (inp, s) Skip s -> return $ Skip (inp, s) Stop -> return Stop +-} -- | Apply a monadic function to each element of the stream and replace it -- with the output of the resulting action. -- --- >>> mapM f = Unfold.mapM2 (const f) --- {-# INLINE_NORMAL mapM #-} mapM :: Monad m => (b -> m c) -> Unfold m a b -> Unfold m a c -- mapM f = mapM2 (const f) @@ -427,37 +447,37 @@ Skip s -> return $ Skip s Stop -> return Stop --- XXX We can also introduce a withInput combinator which will output the input --- seed along with the output as a tuple. - --- | +-- | Carry the input along with the output as the first element of the output +-- tuple. -- --- >>> map2 f = Unfold.mapM2 (\a b -> pure (f a b)) +-- carry = Unfold.lmap (\x -> (x,x)) . Unfold.zipRepeat -- --- Note that the seed may mutate (e.g. if the seed is a Handle or IORef) as --- stream is generated from it, so we need to be careful when reusing the seed --- while the stream is being generated from it. +-- Note that the input seed may mutate (e.g. if the seed is a Handle or IORef) +-- as stream is generated from it, so we need to be careful when reusing the +-- seed while the stream is being generated from it. -- -{-# INLINE_NORMAL map2 #-} -map2 :: Functor m => (a -> b -> c) -> Unfold m a b -> Unfold m a c --- map2 f = mapM2 (\a b -> pure (f a b)) -map2 f (Unfold ustep uinject) = Unfold step (\a -> (a,) <$> uinject a) +{-# INLINE_NORMAL carry #-} +carry :: Functor m => Unfold m a b -> Unfold m a (a,b) +carry (Unfold ustep uinject) = Unfold step (\a -> (a,) <$> uinject a) where func a r = case r of - Yield x s -> Yield (f a x) (a, s) + Yield x s -> Yield (a, x) (a, s) Skip s -> Skip (a, s) Stop -> Stop {-# INLINE_LATE step #-} step (a, st) = fmap (func a) (ustep st) +{-# DEPRECATED map2 "Use carry with map instead." #-} +{-# INLINE_NORMAL map2 #-} +map2 :: Functor m => (a -> b -> c) -> Unfold m a b -> Unfold m a c +map2 f = map (uncurry f) . carry + -- | Map a function on the output of the unfold (the type @b@). -- --- >>> map f = Unfold.map2 (const f) --- -- /Pre-release/ {-# INLINE_NORMAL map #-} map :: Functor m => (b -> c) -> Unfold m a b -> Unfold m a c @@ -503,9 +523,25 @@ -- > fromPure = fromEffect . pure -- -- /Pre-release/ +{-# INLINE fromPure #-} fromPure :: Applicative m => b -> Unfold m a b fromPure = fromEffect Prelude.. pure +data TupleState a = TupleBoth a a | TupleOne a | TupleNone + +-- | Convert a tuple to a 'Stream'. +-- +{-# INLINE_LATE fromTuple #-} +fromTuple :: Applicative m => Unfold m (a,a) a +fromTuple = Unfold step (\(x,y) -> pure $ TupleBoth x y) + + where + + {-# INLINE_LATE step #-} + step (TupleBoth x y) = pure $ Yield x (TupleOne y) + step (TupleOne y) = pure $ Yield y TupleNone + step TupleNone = pure Stop + -- XXX Check if "unfold (fromList [1..10])" fuses, if it doesn't we can use -- rewrite rules to rewrite list enumerations to unfold enumerations. @@ -539,12 +575,18 @@ Unfold m a b -> Unfold m a c -> Unfold m a b crossApplyFst (Unfold _step1 _inject1) (Unfold _step2 _inject2) = undefined +{- {-# ANN type Many2State Fuse #-} data Many2State x s1 s2 = Many2Outer x s1 | Many2Inner x s1 s2 +-} +{-# DEPRECATED many2 "Use carry with unfoldEach instead." #-} {-# INLINE_NORMAL many2 #-} -many2 :: Monad m => Unfold m (a, b) c -> Unfold m a b -> Unfold m a c -many2 (Unfold step2 inject2) (Unfold step1 inject1) = Unfold step inject +many2 :: Monad m => + Unfold m (a, b) c -> Unfold m a b -> Unfold m a c +many2 u1 u2 = unfoldEach u1 (carry u2) +{- +unfoldEach2 (Unfold step2 inject2) (Unfold step1 inject1) = Unfold step inject where @@ -568,15 +610,16 @@ Yield x s -> Yield x (Many2Inner a ost s) Skip s -> Skip (Many2Inner a ost s) Stop -> Skip (Many2Outer a ost) +-} data Cross a s1 b s2 = CrossOuter a s1 | CrossInner a s1 b s2 +-- >> f1 f u = Unfold.mapM (\((_, c), b) -> f b c) Unfold.carry (Unfold.lmap fst u)) +-- >> crossWithM f u = Unfold.unfoldEach2 (f1 f u) + -- | Create a cross product (vector product or cartesian product) of the -- output streams of two unfolds using a monadic combining function. -- --- >>> f1 f u = Unfold.mapM2 (\(_, c) b -> f b c) (Unfold.lmap fst u) --- >>> crossWithM f u = Unfold.many2 (f1 f u) --- -- /Pre-release/ {-# INLINE_NORMAL crossWithM #-} crossWithM :: Monad m => @@ -607,6 +650,59 @@ Skip s -> return $ Skip (CrossInner a s1 b s) Stop -> return $ Skip (CrossOuter a s1) +data FairUnfoldState a o i = + FairUnfoldInit a o ([i] -> [i]) + | FairUnfoldNext a o ([i] -> [i]) [i] + | FairUnfoldDrain ([i] -> [i]) [i] + +{-# INLINE_NORMAL fairCrossWithM #-} +fairCrossWithM :: Monad m => + (b -> c -> m d) -> Unfold m a b -> Unfold m a c -> Unfold m a d +fairCrossWithM f (Unfold step1 inject1) (Unfold step2 inject2) = + Unfold step inject + + where + + inject a = do + s1 <- inject1 a + return $ FairUnfoldInit a s1 id + + {-# INLINE_LATE step #-} + step (FairUnfoldInit a o ls) = do + r <- step1 o + case r of + Yield b o' -> do + i <- inject2 a + i `seq` return (Skip (FairUnfoldNext a o' id (ls [(b,i)]))) + Skip o' -> return $ Skip (FairUnfoldInit a o' ls) + Stop -> return $ Skip (FairUnfoldDrain id (ls [])) + + step (FairUnfoldNext a o ys []) = + return $ Skip (FairUnfoldInit a o ys) + + step (FairUnfoldNext a o ys ((b,st):ls)) = do + r <- step2 st + case r of + Yield c s -> + f b c >>= \x -> + return $ Yield x (FairUnfoldNext a o (ys . ((b, s) :)) ls) + Skip s -> return $ Skip (FairUnfoldNext a o ys ((b,s) : ls)) + Stop -> return $ Skip (FairUnfoldNext a o ys ls) + + step (FairUnfoldDrain ys []) = + case ys [] of + [] -> return Stop + xs -> return $ Skip (FairUnfoldDrain id xs) + + step (FairUnfoldDrain ys ((b,st):ls)) = do + r <- step2 st + case r of + Yield c s -> + f b c >>= \x -> + return $ Yield x (FairUnfoldDrain (ys . ((b,s) :)) ls) + Skip s -> return $ Skip (FairUnfoldDrain ys ((b,s) : ls)) + Stop -> return $ Skip (FairUnfoldDrain ys ls) + -- | Like 'crossWithM' but uses a pure combining function. -- -- > crossWith f = crossWithM (\b c -> return $ f b c) @@ -622,6 +718,11 @@ (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d crossWith f = crossWithM (\b c -> return $ f b c) +{-# INLINE fairCrossWith #-} +fairCrossWith :: Monad m => + (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d +fairCrossWith f = fairCrossWithM (\b c -> return $ f b c) + -- | See 'crossWith'. -- -- Definition: @@ -641,6 +742,11 @@ cross :: Monad m => Unfold m a b -> Unfold m a c -> Unfold m a (b, c) cross = crossWith (,) +{-# INLINE_NORMAL fairCross #-} +fairCross :: Monad m => Unfold m a b -> Unfold m a c -> Unfold m a (b, c) +fairCross = fairCrossWith (,) + +{-# INLINE crossApply #-} crossApply :: Monad m => Unfold m a (b -> c) -> Unfold m a b -> Unfold m a c crossApply u1 u2 = fmap (\(a, b) -> a b) (cross u1 u2) @@ -796,12 +902,10 @@ -- | Apply the first unfold to each output element of the second unfold and -- flatten the output in a single stream. -- --- >>> many u = Unfold.many2 (Unfold.lmap snd u) --- -{-# INLINE_NORMAL many #-} -many :: Monad m => Unfold m b c -> Unfold m a b -> Unfold m a c +{-# INLINE_NORMAL unfoldEach #-} +unfoldEach, many :: Monad m => Unfold m b c -> Unfold m a b -> Unfold m a c -- many u1 = many2 (lmap snd u1) -many (Unfold step2 inject2) (Unfold step1 inject1) = Unfold step inject +unfoldEach (Unfold step2 inject2) (Unfold step1 inject1) = Unfold step inject where @@ -826,6 +930,8 @@ Skip s -> Skip (ConcatInner ost s) Stop -> Skip (ConcatOuter ost) +RENAME(many,unfoldEach) + {- -- XXX There are multiple possible ways to combine the unfolds, "many" appends -- them, we could also have other variants of "many" e.g. manyInterleave. @@ -844,15 +950,52 @@ -- Zipping ------------------------------------------------------------------------------- +-- XXX call the original zipWith as distribute and this one as zip? or this +-- could be called divide. +-- +{-# INLINE_NORMAL zipArrowWithM #-} +zipArrowWithM :: Monad m + => (b -> c -> m d) -> Unfold m a1 b -> Unfold m a2 c -> Unfold m (a1,a2) d +zipArrowWithM f (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject + + where + + inject (x,y) = do + s1 <- inject1 x + s2 <- inject2 y + return (s1, s2, Nothing) + + {-# INLINE_LATE step #-} + step (s1, s2, Nothing) = do + r <- step1 s1 + return $ + case r of + Yield x s -> Skip (s, s2, Just x) + Skip s -> Skip (s, s2, Nothing) + Stop -> Stop + + step (s1, s2, Just x) = do + r <- step2 s2 + case r of + Yield y s -> do + z <- f x y + return $ Yield z (s1, s, Nothing) + Skip s -> return $ Skip (s1, s, Just x) + Stop -> return Stop + -- | Distribute the input to two unfolds and then zip the outputs to a single -- stream using a monadic zip function. -- +-- >>> zipWithM f u1 u2 = Unfold.lmap (\x -> (x,x)) (Unfold.zipArrowWithM f u1 u2) +-- -- Stops as soon as any of the unfolds stops. -- -- /Pre-release/ {-# INLINE_NORMAL zipWithM #-} zipWithM :: Monad m => (b -> c -> m d) -> Unfold m a b -> Unfold m a c -> Unfold m a d +zipWithM f u1 u2 = lmap (\x -> (x,x)) (zipArrowWithM f u1 u2) +{- zipWithM f (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject where @@ -879,6 +1022,7 @@ return $ Yield z (s1, s, Nothing) Skip s -> return $ Skip (s1, s, Just x) Stop -> return Stop +-} -- | Like 'zipWithM' but with a pure zip function. -- @@ -895,6 +1039,11 @@ => (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d zipWith f = zipWithM (\a b -> return (f a b)) +{-# INLINE zipArrowWith #-} +zipArrowWith :: Monad m + => (b -> c -> d) -> Unfold m a1 b -> Unfold m a2 c -> Unfold m (a1,a2) d +zipArrowWith f = zipArrowWithM (\a b -> return (f a b)) + ------------------------------------------------------------------------------- -- Arrow ------------------------------------------------------------------------------- @@ -935,25 +1084,69 @@ -- -- Similarly we can also have other binary combining ops like append, mergeBy. -- We already have zipWith. --- +data InterleaveState s1 s2 = + InterleaveFirst s1 s2 + | InterleaveSecond s1 s2 + | InterleaveSecondOnly s2 + | InterleaveFirstOnly s1 + +-- | Interleave the streams generated by two unfolds. +{-# INLINE_NORMAL interleave #-} +interleave :: Monad m => Unfold m a c -> Unfold m b c -> Unfold m (a,b) c +interleave (Unfold step1 inject1) (Unfold step2 inject2) = + Unfold step inject + + where + + inject (a,b) = do + s1 <- inject1 a + s2 <- inject2 b + return (InterleaveFirst s1 s2) + + {-# INLINE_LATE step #-} + step (InterleaveFirst st1 st2) = do + r <- step1 st1 + return $ case r of + Yield a s -> Yield a (InterleaveSecond s st2) + Skip s -> Skip (InterleaveFirst s st2) + Stop -> Skip (InterleaveSecondOnly st2) + + step (InterleaveSecond st1 st2) = do + r <- step2 st2 + return $ case r of + Yield a s -> Yield a (InterleaveFirst st1 s) + Skip s -> Skip (InterleaveSecond st1 s) + Stop -> Skip (InterleaveFirstOnly st1) + + step (InterleaveFirstOnly st1) = do + r <- step1 st1 + return $ case r of + Yield a s -> Yield a (InterleaveFirstOnly s) + Skip s -> Skip (InterleaveFirstOnly s) + Stop -> Stop + + step (InterleaveSecondOnly st2) = do + r <- step2 st2 + return $ case r of + Yield a s -> Yield a (InterleaveSecondOnly s) + Skip s -> Skip (InterleaveSecondOnly s) + Stop -> Stop + data ManyInterleaveState o i = ManyInterleaveOuter o [i] | ManyInterleaveInner o [i] | ManyInterleaveInnerL [i] [i] | ManyInterleaveInnerR [i] [i] --- | 'Streamly.Internal.Data.Stream.unfoldManyInterleave' for +-- | See 'Streamly.Internal.Data.Stream.unfoldEachInterleave' for -- documentation and notes. -- --- This is almost identical to unfoldManyInterleave in StreamD module. --- --- The 'many' combinator is in fact 'manyAppend' to be more explicit in naming. --- -- /Internal/ -{-# INLINE_NORMAL manyInterleave #-} -manyInterleave :: Monad m => Unfold m a b -> Unfold m c a -> Unfold m c b -manyInterleave (Unfold istep iinject) (Unfold ostep oinject) = +{-# INLINE_NORMAL unfoldEachInterleave #-} +unfoldEachInterleave, manyInterleave :: Monad m => + Unfold m a b -> Unfold m c a -> Unfold m c b +unfoldEachInterleave (Unfold istep iinject) (Unfold ostep oinject) = Unfold step inject where @@ -1001,3 +1194,5 @@ Yield x s -> Yield x (ManyInterleaveInnerR (s:ls) rs) Skip s -> Skip (ManyInterleaveInnerR ls (s:rs)) Stop -> Skip (ManyInterleaveInnerR ls rs) + +RENAME(manyInterleave,unfoldEachInterleave) diff --git a/src/Streamly/Internal/FileSystem/Dir.hs b/src/Streamly/Internal/FileSystem/Dir.hs --- a/src/Streamly/Internal/FileSystem/Dir.hs +++ b/src/Streamly/Internal/FileSystem/Dir.hs @@ -6,10 +6,10 @@ -- -- License : BSD3 -- Maintainer : streamly@composewell.com --- Stability : pre-release -- Portability : GHC module Streamly.Internal.FileSystem.Dir +{-# DEPRECATED "Please use \"Streamly.Internal.FileSystem.DirIO\" instead." #-} ( -- * Streams read @@ -83,153 +83,51 @@ ) where +import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (bimap) -import Data.Either (isRight, isLeft, fromLeft, fromRight) import Streamly.Data.Stream (Stream) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import System.FilePath (()) - -import qualified Streamly.Data.Unfold as UF -import qualified Streamly.Internal.Data.Unfold as UF (mapM2) import qualified Streamly.Data.Stream as S -import qualified System.Directory as Dir -import Prelude hiding (read) - -{- -{-# INLINABLE readArrayUpto #-} -readArrayUpto :: Int -> Handle -> IO (Array Word8) -readArrayUpto size h = do - ptr <- mallocPlainForeignPtrBytes size - -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8)) - withForeignPtr ptr $ \p -> do - n <- hGetBufSome h p size - let v = Array - { aStart = ptr - , arrEnd = p `plusPtr` n - , arrBound = p `plusPtr` size - } - -- XXX shrink only if the diff is significant - shrinkToFit v - -------------------------------------------------------------------------------- --- Stream of Arrays IO -------------------------------------------------------------------------------- - --- | @toChunksWithBufferOf size h@ reads a stream of arrays from file handle @h@. --- The maximum size of a single array is specified by @size@. The actual size --- read may be less than or equal to @size@. -{-# INLINE _toChunksWithBufferOf #-} -_toChunksWithBufferOf :: MonadIO m => Int -> Handle -> Stream m (Array Word8) -_toChunksWithBufferOf size h = go - where - -- XXX use cons/nil instead - go = mkStream $ \_ yld _ stp -> do - arr <- liftIO $ readArrayUpto size h - if A.length arr == 0 - then stp - else yld arr go - --- | @toChunksWithBufferOf size handle@ reads a stream of arrays from the file --- handle @handle@. The maximum size of a single array is limited to @size@. --- The actual size read may be less than or equal to @size@. --- --- @since 0.7.0 -{-# INLINE_NORMAL toChunksWithBufferOf #-} -toChunksWithBufferOf :: MonadIO m => Int -> Handle -> Stream m (Array Word8) -toChunksWithBufferOf size h = D.fromStreamD (D.Stream step ()) - where - {-# INLINE_LATE step #-} - step _ _ = do - arr <- liftIO $ readArrayUpto size h - return $ - case A.length arr of - 0 -> D.Stop - _ -> D.Yield arr () - --- | Unfold the tuple @(bufsize, handle)@ into a stream of 'Word8' arrays. --- Read requests to the IO device are performed using a buffer of size --- @bufsize@. The size of an array in the resulting stream is always less than --- or equal to @bufsize@. --- --- @since 0.7.0 -{-# INLINE_NORMAL readChunksWithBufferOf #-} -readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Handle) (Array Word8) -readChunksWithBufferOf = Unfold step return - where - {-# INLINE_LATE step #-} - step (size, h) = do - arr <- liftIO $ readArrayUpto size h - return $ - case A.length arr of - 0 -> D.Stop - _ -> D.Yield arr (size, h) +import Streamly.Internal.FileSystem.Path (Path) --- XXX read 'Array a' instead of Word8 --- --- | @toChunks handle@ reads a stream of arrays from the specified file --- handle. The maximum size of a single array is limited to --- @defaultChunkSize@. The actual size read may be less than or equal to --- @defaultChunkSize@. --- --- > toChunks = toChunksWithBufferOf defaultChunkSize --- --- @since 0.7.0 -{-# INLINE toChunks #-} -toChunks :: MonadIO m => Handle -> Stream m (Array Word8) -toChunks = toChunksWithBufferOf defaultChunkSize +import qualified Streamly.Internal.FileSystem.Path as Path +import qualified Streamly.Internal.FileSystem.DirIO as DirIO +import qualified Streamly.Internal.Data.Unfold as Unfold --- | Unfolds a handle into a stream of 'Word8' arrays. Requests to the IO --- device are performed using a buffer of size --- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. The --- size of arrays in the resulting stream are therefore less than or equal to --- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. --- --- @since 0.7.0 -{-# INLINE readChunks #-} -readChunks :: MonadIO m => Unfold m Handle (Array Word8) -readChunks = UF.first readChunksWithBufferOf defaultChunkSize +import Prelude hiding (read) -------------------------------------------------------------------------------- --- Read a Directory to Stream -------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- --- TODO for concurrent streams implement readahead IO. We can send multiple --- read requests at the same time. For serial case we can use async IO. We can --- also control the read throughput in mbps or IOPS. +{-# INLINE ePathMap #-} +ePathMap :: Either Path Path -> Either FilePath FilePath +ePathMap (Left a) = Left (Path.toString a) +ePathMap (Right a) = Right (Path.toString a) --- | Unfolds the tuple @(bufsize, handle)@ into a byte stream, read requests --- to the IO device are performed using buffers of @bufsize@. --- --- @since 0.7.0 -{-# INLINE readWithBufferOf #-} -readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8 -readWithBufferOf = UF.many readChunksWithBufferOf A.read +{-# INLINE pMapUnfold #-} +pMapUnfold :: MonadCatch m => Unfold m Path Path -> Unfold m FilePath FilePath +pMapUnfold = fmap Path.toString . Unfold.lmapM Path.fromString --- | @toStreamWithBufferOf bufsize handle@ reads a byte stream from a file --- handle, reads are performed in chunks of up to @bufsize@. --- --- /Pre-release/ -{-# INLINE toStreamWithBufferOf #-} -toStreamWithBufferOf :: MonadIO m => Int -> Handle -> Stream m Word8 -toStreamWithBufferOf chunkSize h = AS.concat $ toChunksWithBufferOf chunkSize h --} +{-# INLINE pMapUnfoldE #-} +pMapUnfoldE + :: MonadCatch m + => Unfold m Path (Either Path Path) + -> Unfold m FilePath (Either FilePath FilePath) +pMapUnfoldE = fmap ePathMap . Unfold.lmapM Path.fromString --- read child node names from a dir filtering out . and .. --- --- . and .. are an implementation artifact, and should probably not be used in --- user level abstractions. --- --- . does not seem to have any useful purpose. If we have the path of the dir --- then we will resolve it to get the inode of the dir so the . entry would be --- redundant. If we have the inode of the dir to read the dir then it is --- redundant. Is this for cross check when doing fsck? --- --- For .. we have the readAncestors API, we should not have this in the --- readChildren API. +-------------------------------------------------------------------------------- +-- Functions +-------------------------------------------------------------------------------- --- XXX exception handling +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +#define CONF id +#else +#define CONF (DirIO.followSymlinks True) +#endif -- | Read a directory emitting a stream with names of the children. Filter out -- "." and ".." entries. @@ -237,16 +135,8 @@ -- /Internal/ -- {-# INLINE reader #-} -reader :: MonadIO m => Unfold m FilePath FilePath -reader = - -- XXX use proper streaming read of the dir - UF.filter (\x -> x /= "." && x /= "..") - $ UF.lmapM (liftIO . Dir.getDirectoryContents) UF.fromList - --- XXX We can use a more general mechanism to filter the contents of a --- directory. We can just stat each child and pass on the stat information. We --- can then use that info to do a general filtering. "find" like filters can be --- created. +reader :: (MonadIO m, MonadCatch m) => Unfold m FilePath FilePath +reader = fmap Path.toString $ Unfold.lmapM Path.fromString DirIO.reader -- | Read directories as Left and files as Right. Filter out "." and ".." -- entries. @@ -254,19 +144,13 @@ -- /Internal/ -- {-# INLINE eitherReader #-} -eitherReader :: MonadIO m => Unfold m FilePath (Either FilePath FilePath) -eitherReader = UF.mapM2 classify reader +eitherReader :: (MonadIO m, MonadCatch m) => Unfold m FilePath (Either FilePath FilePath) +eitherReader = pMapUnfoldE (DirIO.eitherReader CONF) - where - classify dir x = do - r <- liftIO $ Dir.doesDirectoryExist (dir ++ "/" ++ x) - return $ if r then Left x else Right x - {-# INLINE eitherReaderPaths #-} -eitherReaderPaths :: MonadIO m => Unfold m FilePath (Either FilePath FilePath) -eitherReaderPaths = - UF.mapM2 (\dir -> return . bimap (dir ) (dir )) eitherReader +eitherReaderPaths ::(MonadIO m, MonadCatch m) => Unfold m FilePath (Either FilePath FilePath) +eitherReaderPaths = pMapUnfoldE (DirIO.eitherReaderPaths CONF) -- -- | Read files only. @@ -274,27 +158,27 @@ -- /Internal/ -- {-# INLINE fileReader #-} -fileReader :: MonadIO m => Unfold m FilePath FilePath -fileReader = fmap (fromRight undefined) $ UF.filter isRight eitherReader +fileReader :: (MonadIO m, MonadCatch m) => Unfold m FilePath FilePath +fileReader = pMapUnfold (DirIO.fileReader CONF) -- | Read directories only. Filter out "." and ".." entries. -- -- /Internal/ -- {-# INLINE dirReader #-} -dirReader :: MonadIO m => Unfold m FilePath FilePath -dirReader = fmap (fromLeft undefined) $ UF.filter isLeft eitherReader +dirReader :: (MonadIO m, MonadCatch m) => Unfold m FilePath FilePath +dirReader = pMapUnfold (DirIO.dirReader CONF) -- | Raw read of a directory. -- -- /Pre-release/ {-# INLINE read #-} -read :: MonadIO m => FilePath -> Stream m FilePath +read :: (MonadIO m, MonadCatch m) => FilePath -> Stream m FilePath read = S.unfold reader {-# DEPRECATED toStream "Please use 'read' instead" #-} {-# INLINE toStream #-} -toStream :: MonadIO m => String -> Stream m String +toStream :: (MonadIO m, MonadCatch m) => String -> Stream m String toStream = read -- | Read directories as Left and files as Right. Filter out "." and ".." @@ -302,18 +186,18 @@ -- -- /Pre-release/ {-# INLINE readEither #-} -readEither :: MonadIO m => FilePath -> Stream m (Either FilePath FilePath) +readEither :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Either FilePath FilePath) readEither = S.unfold eitherReader -- | Like 'readEither' but prefix the names of the files and directories with -- the supplied directory path. {-# INLINE readEitherPaths #-} -readEitherPaths :: MonadIO m => FilePath -> Stream m (Either FilePath FilePath) +readEitherPaths :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Either FilePath FilePath) readEitherPaths dir = fmap (bimap (dir ) (dir )) $ readEither dir {-# DEPRECATED toEither "Please use 'readEither' instead" #-} {-# INLINE toEither #-} -toEither :: MonadIO m => FilePath -> Stream m (Either FilePath FilePath) +toEither :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Either FilePath FilePath) toEither = readEither -- | Read files only. @@ -321,12 +205,12 @@ -- /Internal/ -- {-# INLINE readFiles #-} -readFiles :: MonadIO m => FilePath -> Stream m FilePath +readFiles :: (MonadIO m, MonadCatch m) => FilePath -> Stream m FilePath readFiles = S.unfold fileReader {-# DEPRECATED toFiles "Please use 'readFiles' instead" #-} {-# INLINE toFiles #-} -toFiles :: MonadIO m => FilePath -> Stream m FilePath +toFiles :: (MonadIO m, MonadCatch m) => FilePath -> Stream m FilePath toFiles = readFiles -- | Read directories only. @@ -334,130 +218,10 @@ -- /Internal/ -- {-# INLINE readDirs #-} -readDirs :: MonadIO m => FilePath -> Stream m FilePath +readDirs :: (MonadIO m, MonadCatch m) => FilePath -> Stream m FilePath readDirs = S.unfold dirReader {-# DEPRECATED toDirs "Please use 'readDirs' instead" #-} {-# INLINE toDirs #-} -toDirs :: MonadIO m => String -> Stream m String +toDirs :: (MonadIO m, MonadCatch m) => String -> Stream m String toDirs = readDirs - -{- -------------------------------------------------------------------------------- --- Writing -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- --- Array IO (output) -------------------------------------------------------------------------------- - --- | Write an 'Array' to a file handle. --- --- @since 0.7.0 -{-# INLINABLE writeArray #-} -writeArray :: Storable a => Handle -> Array a -> IO () -writeArray _ arr | A.length arr == 0 = return () -writeArray h Array{..} = withForeignPtr aStart $ \p -> hPutBuf h p aLen - where - aLen = - let p = unsafeForeignPtrToPtr aStart - in arrEnd `minusPtr` p - -------------------------------------------------------------------------------- --- Stream of Arrays IO -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- --- Writing -------------------------------------------------------------------------------- - --- | Write a stream of arrays to a handle. --- --- @since 0.7.0 -{-# INLINE fromChunks #-} -fromChunks :: (MonadIO m, Storable a) - => Handle -> Stream m (Array a) -> m () -fromChunks h m = S.mapM_ (liftIO . writeArray h) m - --- | @fromChunksWithBufferOf bufsize handle stream@ writes a stream of arrays --- to @handle@ after coalescing the adjacent arrays in chunks of @bufsize@. --- The chunk size is only a maximum and the actual writes could be smaller as --- we do not split the arrays to fit exactly to the specified size. --- --- @since 0.7.0 -{-# INLINE fromChunksWithBufferOf #-} -fromChunksWithBufferOf :: (MonadIO m, Storable a) - => Int -> Handle -> Stream m (Array a) -> m () -fromChunksWithBufferOf n h xs = fromChunks h $ AS.compact n xs - --- | @fromStreamWithBufferOf bufsize handle stream@ writes @stream@ to @handle@ --- in chunks of @bufsize@. A write is performed to the IO device as soon as we --- collect the required input size. --- --- @since 0.7.0 -{-# INLINE fromStreamWithBufferOf #-} -fromStreamWithBufferOf :: MonadIO m => Int -> Handle -> Stream m Word8 -> m () -fromStreamWithBufferOf n h m = fromChunks h $ S.chunksOf n m --- fromStreamWithBufferOf n h m = fromChunks h $ AS.chunksOf n m - --- > write = 'writeWithBufferOf' A.defaultChunkSize --- --- | Write a byte stream to a file handle. Accumulates the input in chunks of --- up to 'Streamly.Internal.Data.Array.Type.defaultChunkSize' before writing. --- --- NOTE: This may perform better than the 'write' fold, you can try this if you --- need some extra perf boost. --- --- @since 0.7.0 -{-# INLINE fromStream #-} -fromStream :: MonadIO m => Handle -> Stream m Word8 -> m () -fromStream = fromStreamWithBufferOf defaultChunkSize - --- | Write a stream of arrays to a handle. Each array in the stream is written --- to the device as a separate IO request. --- --- @since 0.7.0 -{-# INLINE writeChunks #-} -writeChunks :: (MonadIO m, Storable a) => Handle -> Fold m (Array a) () -writeChunks h = FL.drainBy (liftIO . writeArray h) - --- | @writeChunksWithBufferOf bufsize handle@ writes a stream of arrays --- to @handle@ after coalescing the adjacent arrays in chunks of @bufsize@. --- We never split an array, if a single array is bigger than the specified size --- it emitted as it is. Multiple arrays are coalesed as long as the total size --- remains below the specified size. --- --- @since 0.7.0 -{-# INLINE writeChunksWithBufferOf #-} -writeChunksWithBufferOf :: (MonadIO m, Storable a) - => Int -> Handle -> Fold m (Array a) () -writeChunksWithBufferOf n h = lpackArraysChunksOf n (writeChunks h) - --- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes. --- --- XXX test this --- Note that if you use a chunk size less than 8K (GHC's default buffer --- size) then you are advised to use 'NOBuffering' mode on the 'Handle' in case you --- do not want buffering to occur at GHC level as well. Same thing applies to --- writes as well. - --- | @writeWithBufferOf reqSize handle@ writes the input stream to @handle@. --- Bytes in the input stream are collected into a buffer until we have a chunk --- of @reqSize@ and then written to the IO device. --- --- @since 0.7.0 -{-# INLINE writeWithBufferOf #-} -writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 () -writeWithBufferOf n h = FL.groupsOf n (writeNUnsafe n) (writeChunks h) - --- > write = 'writeWithBufferOf' A.defaultChunkSize --- --- | Write a byte stream to a file handle. Accumulates the input in chunks of --- up to 'Streamly.Internal.Data.Array.Type.defaultChunkSize' before writing --- to the IO device. --- --- @since 0.7.0 -{-# INLINE write #-} -write :: MonadIO m => Handle -> Fold m Word8 () -write = writeWithBufferOf defaultChunkSize --} diff --git a/src/Streamly/Internal/FileSystem/DirIO.hs b/src/Streamly/Internal/FileSystem/DirIO.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/DirIO.hs @@ -0,0 +1,532 @@ +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.FileSystem.DirIO +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- API Design notes: +-- +-- The paths returned by "read" can be absolute (/usr/bin/ls), relative to +-- current directory (./bin/ls) or path segments relative to current dir +-- (bin/ls). To accomodate all the cases we can provide a prefix to attach +-- to the paths being generated. Alternatively, we could take the approach +-- of the higher layer doing that, but it is more efficient to allocate the +-- path buffer once rather than modifying it later. We can do this by +-- passing a fold to transform the output. +-- +-- Also it may be more efficient to apply a filter to the paths right here +-- instead of applying it in a layer above. Cut the output at the source +-- rather than generate and then discard it later. We can do this by +-- passing a fold to filter the input. +-- +-- When reading a symlink directory we can resolve the symlink and read the +-- destination directory or we can just emit the file it is pointing to and +-- the read can happen next at the higher level, in the traversal logic +-- (concatIterate). Not sure if one approach has any significant perf impact +-- over the other. Similar thinking applies to a mount point as well. Also, if +-- we resolve the symlinks in concatIterate, then each resolution will be +-- counted as depth level increment whereas if we resolve that at lower level +-- then it won't. We can do this by passing an option to modify the behavior. +-- +-- When resolving cyclic directory symlinks one way to curtail it is ELOOP +-- which gives up if it encounters too many level. Another way is to use +-- the inode information to check if we are traversing an already traversed +-- inode, this is in general helpful in a graph traversal. We can ignore +-- ELOOP by passing an option but it may be inefficient because we may +-- encounter the loop from any node in the cycle. +-- +-- If we encounter an error reading a directory because of permission +-- issues should we ignore it in this low level API or catch it in the +-- higher level traversal functionality? Similarly, if there are broken +-- symlinks, where to handle the error? Need to check performance when +-- handling it in ListDir. Suppressing the error at the lower level may be +-- more efficient than propagating it up and then handling it there. We can +-- do this by passing an option. +-- +-- Returning the metadata: +-- +-- Specific scans can be used to return the metadata in the output stream if +-- needed. However, we may need three different APIs: +-- one with fast metadata, and +-- another with full metadata. In the two cases the fold input would be +-- different. +-- +-- * readMinimal: read only the path names, no metadata +-- * readStandard: read the path and minimal metadata +-- * readFull: read full metadata +-- +-- NOTE: Full metadata can be read by mapping a stat call to a stream of paths +-- rather than via readdir API. Does it help the performance to do it in the +-- readdir API? + +-- Design pattern: +-- +-- By passing a scan we can process the output right at the source and produce +-- a cooked output. Otherwise we may have to produce a stream of intermediate +-- structures which may have more per item overhead and that overhead may not +-- get eliminated by fusion. For example, a fold can directly write the CString +-- from readdir to the output buffer whereas if we output the Path then we will +-- incur an overhead of intermediate structure. + +module Streamly.Internal.FileSystem.DirIO + ( + -- XXX Create a Metadata or Meta module for stat, access, getxattr, chmod, + -- chown, utime, rename operations. + -- + -- * Metadata + -- getMetadata GetMetadata (followSymlinks, noAutoMount - see fstatat) + + -- * Configuration + module Streamly.Internal.FileSystem.DirOptions + + -- * Streams + , read + + -- Is there a benefit in providing a low level recursive read or + -- concatIterate is good enough? Could be more efficient for non-concurrent + -- reads by using a local loop. Or during concurrent reads use + -- non-concurrent reads as we go deeper down in the tree. + -- , readAttrsRecursive + + , readFiles + , readDirs + , readEither + , readEitherPaths + , readEitherChunks + + -- We can implement this in terms of readAttrsRecursive without losing + -- perf. + -- , readEitherRecursive -- Options: acyclic, follow symlinks + -- , readAncestors -- read the parent chain using the .. entry. + -- , readAncestorsAttrs + + -- * Unfolds + -- | Use the more convenient stream APIs instead of unfolds where possible. + , reader + , fileReader + , dirReader + , eitherReader + , eitherReaderPaths + + {- + , toStreamWithBufferOf + + , readChunks + , readChunksWithBufferOf + + , toChunksWithBufferOf + , toChunks + + , write + , writeWithBufferOf + + -- Byte stream write (Streams) + , fromStream + , fromStreamWithBufferOf + + -- -- * Array Write + , writeArray + , writeChunks + , writeChunksWithBufferOf + + -- -- * Array stream Write + , fromChunks + , fromChunksWithBufferOf + -} + ) +where + +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Bifunctor (bimap) +import Data.Either (isRight, isLeft, fromLeft, fromRight) +import Streamly.Data.Stream (Stream) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.FileSystem.Path (Path) +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +import qualified Streamly.Internal.Data.Fold as Fold +import Streamly.Internal.FileSystem.Windows.ReadDir (eitherReader, reader) +#else +import Streamly.Internal.FileSystem.Posix.ReadDir + ( readEitherChunks, eitherReader, reader) +#endif +import qualified Streamly.Internal.Data.Stream as S +import qualified Streamly.Data.Unfold as UF +import qualified Streamly.Internal.FileSystem.Path as Path + +import Streamly.Internal.FileSystem.DirOptions +import Prelude hiding (read) + +{- +{-# INLINABLE readArrayUpto #-} +readArrayUpto :: Int -> Handle -> IO (Array Word8) +readArrayUpto size h = do + ptr <- mallocPlainForeignPtrBytes size + -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8)) + withForeignPtr ptr $ \p -> do + n <- hGetBufSome h p size + let v = Array + { aStart = ptr + , arrEnd = p `plusPtr` n + , arrBound = p `plusPtr` size + } + -- XXX shrink only if the diff is significant + shrinkToFit v + +------------------------------------------------------------------------------- +-- Stream of Arrays IO +------------------------------------------------------------------------------- + +-- | @toChunksWithBufferOf size h@ reads a stream of arrays from file handle @h@. +-- The maximum size of a single array is specified by @size@. The actual size +-- read may be less than or equal to @size@. +{-# INLINE _toChunksWithBufferOf #-} +_toChunksWithBufferOf :: MonadIO m => Int -> Handle -> Stream m (Array Word8) +_toChunksWithBufferOf size h = go + where + -- XXX use cons/nil instead + go = mkStream $ \_ yld _ stp -> do + arr <- liftIO $ readArrayUpto size h + if A.length arr == 0 + then stp + else yld arr go + +-- | @toChunksWithBufferOf size handle@ reads a stream of arrays from the file +-- handle @handle@. The maximum size of a single array is limited to @size@. +-- The actual size read may be less than or equal to @size@. +-- +-- @since 0.7.0 +{-# INLINE_NORMAL toChunksWithBufferOf #-} +toChunksWithBufferOf :: MonadIO m => Int -> Handle -> Stream m (Array Word8) +toChunksWithBufferOf size h = D.fromStreamD (D.Stream step ()) + where + {-# INLINE_LATE step #-} + step _ _ = do + arr <- liftIO $ readArrayUpto size h + return $ + case A.length arr of + 0 -> D.Stop + _ -> D.Yield arr () + +-- | Unfold the tuple @(bufsize, handle)@ into a stream of 'Word8' arrays. +-- Read requests to the IO device are performed using a buffer of size +-- @bufsize@. The size of an array in the resulting stream is always less than +-- or equal to @bufsize@. +-- +-- @since 0.7.0 +{-# INLINE_NORMAL readChunksWithBufferOf #-} +readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Handle) (Array Word8) +readChunksWithBufferOf = Unfold step return + where + {-# INLINE_LATE step #-} + step (size, h) = do + arr <- liftIO $ readArrayUpto size h + return $ + case A.length arr of + 0 -> D.Stop + _ -> D.Yield arr (size, h) + +-- XXX read 'Array a' instead of Word8 + +-- | @toChunks handle@ reads a stream of arrays from the specified file +-- handle. The maximum size of a single array is limited to +-- @defaultChunkSize@. The actual size read may be less than or equal to +-- @defaultChunkSize@. +-- +-- > toChunks = toChunksWithBufferOf defaultChunkSize +-- +-- @since 0.7.0 +{-# INLINE toChunks #-} +toChunks :: MonadIO m => Handle -> Stream m (Array Word8) +toChunks = toChunksWithBufferOf defaultChunkSize + +-- | Unfolds a handle into a stream of 'Word8' arrays. Requests to the IO +-- device are performed using a buffer of size +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. The +-- size of arrays in the resulting stream are therefore less than or equal to +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. +-- +-- @since 0.7.0 +{-# INLINE readChunks #-} +readChunks :: MonadIO m => Unfold m Handle (Array Word8) +readChunks = UF.first readChunksWithBufferOf defaultChunkSize + +------------------------------------------------------------------------------- +-- Read a Directory to Stream +------------------------------------------------------------------------------- + +-- TODO for concurrent streams implement readahead IO. We can send multiple +-- read requests at the same time. For serial case we can use async IO. We can +-- also control the read throughput in mbps or IOPS. + +-- | Unfolds the tuple @(bufsize, handle)@ into a byte stream, read requests +-- to the IO device are performed using buffers of @bufsize@. +-- +-- @since 0.7.0 +{-# INLINE readWithBufferOf #-} +readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8 +readWithBufferOf = UF.many readChunksWithBufferOf A.read + +-- | @toStreamWithBufferOf bufsize handle@ reads a byte stream from a file +-- handle, reads are performed in chunks of up to @bufsize@. +-- +-- /Pre-release/ +{-# INLINE toStreamWithBufferOf #-} +toStreamWithBufferOf :: MonadIO m => Int -> Handle -> Stream m Word8 +toStreamWithBufferOf chunkSize h = AS.concat $ toChunksWithBufferOf chunkSize h +-} + +-- read child node names from a dir filtering out . and .. +-- +-- . and .. are an implementation artifact, and should probably not be used in +-- user level abstractions. +-- +-- . does not seem to have any useful purpose. If we have the path of the dir +-- then we will resolve it to get the inode of the dir so the . entry would be +-- redundant. If we have the inode of the dir to read the dir then it is +-- redundant. Is this for cross check when doing fsck? +-- +-- For .. we have the readAncestors API, we should not have this in the +-- readChildren API. + +-- XXX exception handling + +-- XXX We can use a more general mechanism to filter the contents of a +-- directory. We can just stat each child and pass on the stat information. We +-- can then use that info to do a general filtering. "find" like filters can be +-- created. + +{-# INLINE eitherReaderPaths #-} +eitherReaderPaths ::(MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> + Unfold m Path (Either Path Path) +eitherReaderPaths f = + let () = Path.join + in fmap (\(dir, x) -> bimap (dir ) (dir ) x) + $ UF.carry (eitherReader f) + +-- +-- | Read files only. +-- +-- /Internal/ +-- +{-# INLINE fileReader #-} +fileReader :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> + Unfold m Path Path +fileReader f = fmap (fromRight undefined) $ UF.filter isRight (eitherReader f) + +-- | Read directories only. Filter out "." and ".." entries. +-- +-- /Internal/ +-- +{-# INLINE dirReader #-} +dirReader :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> + Unfold m Path Path +dirReader f = fmap (fromLeft undefined) $ UF.filter isLeft (eitherReader f) + +-- | Raw read of a directory. +-- +-- /Pre-release/ +{-# INLINE read #-} +read :: (MonadIO m, MonadCatch m) => + Path -> Stream m Path +read = S.unfold reader + +-- | Read directories as Left and files as Right. Filter out "." and ".." +-- entries. The output contains the names of the directories and files. +-- +-- /Pre-release/ +{-# INLINE readEither #-} +readEither :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> + Path -> Stream m (Either Path Path) +readEither f = S.unfold (eitherReader f) + +-- | Like 'readEither' but prefix the names of the files and directories with +-- the supplied directory path. +{-# INLINE readEitherPaths #-} +readEitherPaths :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> + Path -> Stream m (Either Path Path) +readEitherPaths f dir = + let () = Path.join + in fmap (bimap (dir ) (dir )) $ readEither f dir + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +-- XXX Implement a custom version of readEitherChunks (like for Posix) for +-- windows as well. Also implement readEitherByteChunks. +-- +-- XXX For a fast custom implementation of traversal, the Right could be the +-- final array chunk including all files and dirs to be written to IO. The Left +-- could be list of dirs to be traversed. +-- +-- This is a generic (but slower?) version of readEitherChunks using +-- eitherReaderPaths. +{-# INLINE readEitherChunks #-} +readEitherChunks :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> + [Path] -> Stream m (Either [Path] [Path]) +readEitherChunks f dirs = + -- XXX Need to use a take to limit the group size. There will be separate + -- limits for dir and files groups. + S.groupsWhile grouper collector + $ S.unfoldEach (eitherReaderPaths f) + $ S.fromList dirs + + where + + -- XXX We can use a refold "Either dirs files" and yield the one that fills + -- and pass the remainder to the next Refold. + grouper first next = + case first of + Left _ -> isLeft next + Right _ -> isRight next + + collector = Fold.foldl' step (Right []) + + step b x = + case x of + Left x1 -> + case b of + Right _ -> Left [x1] -- initial + _ -> either (\xs -> Left (x1:xs)) Right b + Right x1 -> fmap (x1:) b +#endif + +-- | Read files only. +-- +-- /Internal/ +-- +{-# INLINE readFiles #-} +readFiles :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> + Path -> Stream m Path +readFiles f = S.unfold (fileReader f) + +-- | Read directories only. +-- +-- /Internal/ +-- +{-# INLINE readDirs #-} +readDirs :: (MonadIO m, MonadCatch m) => (ReadOptions -> ReadOptions) -> + Path -> Stream m Path +readDirs f = S.unfold (dirReader f) + +{- +------------------------------------------------------------------------------- +-- Writing +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Array IO (output) +------------------------------------------------------------------------------- + +-- | Write an 'Array' to a file handle. +-- +-- @since 0.7.0 +{-# INLINABLE writeArray #-} +writeArray :: Storable a => Handle -> Array a -> IO () +writeArray _ arr | A.length arr == 0 = return () +writeArray h Array{..} = withForeignPtr aStart $ \p -> hPutBuf h p aLen + where + aLen = + let p = unsafeForeignPtrToPtr aStart + in arrEnd `minusPtr` p + +------------------------------------------------------------------------------- +-- Stream of Arrays IO +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Writing +------------------------------------------------------------------------------- + +-- | Write a stream of arrays to a handle. +-- +-- @since 0.7.0 +{-# INLINE fromChunks #-} +fromChunks :: (MonadIO m, Storable a) + => Handle -> Stream m (Array a) -> m () +fromChunks h m = S.mapM_ (liftIO . writeArray h) m + +-- | @fromChunksWithBufferOf bufsize handle stream@ writes a stream of arrays +-- to @handle@ after coalescing the adjacent arrays in chunks of @bufsize@. +-- The chunk size is only a maximum and the actual writes could be smaller as +-- we do not split the arrays to fit exactly to the specified size. +-- +-- @since 0.7.0 +{-# INLINE fromChunksWithBufferOf #-} +fromChunksWithBufferOf :: (MonadIO m, Storable a) + => Int -> Handle -> Stream m (Array a) -> m () +fromChunksWithBufferOf n h xs = fromChunks h $ AS.compact n xs + +-- | @fromStreamWithBufferOf bufsize handle stream@ writes @stream@ to @handle@ +-- in chunks of @bufsize@. A write is performed to the IO device as soon as we +-- collect the required input size. +-- +-- @since 0.7.0 +{-# INLINE fromStreamWithBufferOf #-} +fromStreamWithBufferOf :: MonadIO m => Int -> Handle -> Stream m Word8 -> m () +fromStreamWithBufferOf n h m = fromChunks h $ S.pinnedChunksOf n m +-- fromStreamWithBufferOf n h m = fromChunks h $ AS.chunksOf n m + +-- > write = 'writeWithBufferOf' A.defaultChunkSize +-- +-- | Write a byte stream to a file handle. Accumulates the input in chunks of +-- up to 'Streamly.Internal.Data.Array.Type.defaultChunkSize' before writing. +-- +-- NOTE: This may perform better than the 'write' fold, you can try this if you +-- need some extra perf boost. +-- +-- @since 0.7.0 +{-# INLINE fromStream #-} +fromStream :: MonadIO m => Handle -> Stream m Word8 -> m () +fromStream = fromStreamWithBufferOf defaultChunkSize + +-- | Write a stream of arrays to a handle. Each array in the stream is written +-- to the device as a separate IO request. +-- +-- @since 0.7.0 +{-# INLINE writeChunks #-} +writeChunks :: (MonadIO m, Storable a) => Handle -> Fold m (Array a) () +writeChunks h = FL.drainBy (liftIO . writeArray h) + +-- | @writeChunksWithBufferOf bufsize handle@ writes a stream of arrays +-- to @handle@ after coalescing the adjacent arrays in chunks of @bufsize@. +-- We never split an array, if a single array is bigger than the specified size +-- it emitted as it is. Multiple arrays are coalesed as long as the total size +-- remains below the specified size. +-- +-- @since 0.7.0 +{-# INLINE writeChunksWithBufferOf #-} +writeChunksWithBufferOf :: (MonadIO m, Storable a) + => Int -> Handle -> Fold m (Array a) () +writeChunksWithBufferOf n h = lpackArraysChunksOf n (writeChunks h) + +-- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes. +-- +-- XXX test this +-- Note that if you use a chunk size less than 8K (GHC's default buffer +-- size) then you are advised to use 'NOBuffering' mode on the 'Handle' in case you +-- do not want buffering to occur at GHC level as well. Same thing applies to +-- writes as well. + +-- | @writeWithBufferOf reqSize handle@ writes the input stream to @handle@. +-- Bytes in the input stream are collected into a buffer until we have a chunk +-- of @reqSize@ and then written to the IO device. +-- +-- @since 0.7.0 +{-# INLINE writeWithBufferOf #-} +writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 () +writeWithBufferOf n h = FL.groupsOf n (pinnedWriteNUnsafe n) (writeChunks h) + +-- > write = 'writeWithBufferOf' A.defaultChunkSize +-- +-- | Write a byte stream to a file handle. Accumulates the input in chunks of +-- up to 'Streamly.Internal.Data.Array.Type.defaultChunkSize' before writing +-- to the IO device. +-- +-- @since 0.7.0 +{-# INLINE write #-} +write :: MonadIO m => Handle -> Fold m Word8 () +write = writeWithBufferOf defaultChunkSize +-} diff --git a/src/Streamly/Internal/FileSystem/DirOptions.hs b/src/Streamly/Internal/FileSystem/DirOptions.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/DirOptions.hs @@ -0,0 +1,125 @@ +-- | +-- Module : Streamly.Internal.FileSystem.DirOptions +-- Copyright : (c) 2024 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC + +module Streamly.Internal.FileSystem.DirOptions + ( + ReadOptions (..) + , followSymlinks + , ignoreMissing + , ignoreSymlinkLoops + , ignoreInaccessible + , defaultReadOptions + ) +where + +-- NOTE: If we are following symlinks, then we want to determine the type of +-- the link destination not the link itself, so we need to use stat instead of +-- lstat for resolving the symlink. +-- +-- For recursive traversal, instead of classifying the dirents using stat, we +-- can leave them unclassified, and deal with ENOTDIR when doing an opendir. We +-- can just ignore that error if it is not a dir. This way we do not need to do +-- stat at all. Or we can basically say don't try to determine the type of +-- symlinks and always try to read symlinks as dirs. We can have an option for +-- classifying symlinks or DT_UNKNOWN as potential dirs. + +-- When resolving a symlink we may encounter errors only if the directory entry +-- is a symlink. If the directory entry is not a symlink then stat on it will +-- have permissions, it will not give ELOOP or ENOENT unless the file was +-- deleted or recreated after we read the dirent. + +-- | Options controlling the behavior of directory read. +data ReadOptions = + ReadOptions + { _followSymlinks :: Bool + , _ignoreELOOP :: Bool + , _ignoreENOENT :: Bool + , _ignoreEACCESS :: Bool + } + +-- | Control how symbolic links are handled when determining the type +-- of a directory entry. +-- +-- * If set to 'True', symbolic links are resolved before classification. +-- This means a symlink pointing to a directory will be treated as a +-- directory, and a symlink pointing to a file will be treated as a +-- non-directory. +-- +-- * If set to 'False', all symbolic links are classified as non-directories, +-- without attempting to resolve their targets. +-- +-- Enabling resolution may cause additional errors to occur due to +-- insufficient permissions, broken links, or symlink loops. Such errors +-- can be ignored or handled using the appropriate options. +-- +-- The default is 'False'. +-- +-- On Windows this option has no effect as of now, symlinks are not followed to +-- determine the type. +followSymlinks :: Bool -> ReadOptions -> ReadOptions +followSymlinks x opts = opts {_followSymlinks = x} + +-- | When the 'followSymlinks' option is enabled and a directory entry is a +-- symbolic link, we resolve it to determine the type of the symlink target. +-- This option controls the behavior when encountering symlink loop errors +-- during resolution. +-- +-- When set to 'True', symlink loop errors are ignored, and the type of the +-- entry is reported as not a directory. When set to 'False', the directory +-- read operation fails with an error. +-- +-- The default is 'True'. +-- +-- On Windows this option has no effect as of now, symlinks are not followed to +-- determine the type. +ignoreSymlinkLoops :: Bool -> ReadOptions -> ReadOptions +ignoreSymlinkLoops x opts = opts {_ignoreELOOP = x} + +-- | When the 'followSymlinks' option is enabled and a directory entry is a +-- symbolic link, we resolve it to determine the type of the symlink target. +-- This option controls the behavior when encountering broken symlink errors +-- during resolution. +-- +-- When set to 'True', broken symlink errors are ignored, and the type of the +-- entry is reported as not a directory. When set to 'False', the directory +-- read operation fails with an error. +-- +-- The default is 'True'. +-- +-- On Windows this option has no effect as of now, symlinks are not followed to +-- determine the type. +ignoreMissing :: Bool -> ReadOptions -> ReadOptions +ignoreMissing x opts = opts {_ignoreENOENT = x} + +-- | When the 'followSymlinks' option is enabled and a directory entry is a +-- symbolic link, we resolve it to determine the type of the symlink target. +-- This option controls the behavior when encountering permission errors +-- during resolution. +-- +-- When set to 'True', any permission errors are ignored, and the type of the +-- entry is reported as not a directory. When set to 'False', the directory +-- read operation fails with an error. +-- +-- The default is 'True'. +-- +-- On Windows this option has no effect as of now, symlinks are not followed to +-- determine the type. +ignoreInaccessible :: Bool -> ReadOptions -> ReadOptions +ignoreInaccessible x opts = opts {_ignoreEACCESS = x} + +-- XXX find ignores errors when following symlinks, by default. +-- NOTE: The defaultReadOptions emulates the behaviour of "find". +-- +defaultReadOptions :: ReadOptions +defaultReadOptions = + ReadOptions + { _followSymlinks = False + , _ignoreELOOP = True + , _ignoreENOENT = True + , _ignoreEACCESS = True + } diff --git a/src/Streamly/Internal/FileSystem/File.hs b/src/Streamly/Internal/FileSystem/File.hs --- a/src/Streamly/Internal/FileSystem/File.hs +++ b/src/Streamly/Internal/FileSystem/File.hs @@ -6,7 +6,6 @@ -- -- License : BSD3 -- Maintainer : streamly@composewell.com --- Stability : pre-release -- Portability : GHC -- -- Read and write streams and arrays to and from files specified by their paths @@ -21,6 +20,7 @@ -- module Streamly.Internal.FileSystem.File +{-# DEPRECATED "Please use \"Streamly.Internal.FileSystem.FileIO\" instead." #-} ( -- * Streaming IO -- | Stream data to or from a file or device sequentially. When reading, @@ -76,11 +76,11 @@ , fromChunks -- ** Append To File - , append - , appendWith + , writeAppend + , writeAppendWith -- , appendShared - , appendArray - , appendChunks + , writeAppendArray + , writeAppendChunks -- * Deprecated , readWithBufferOf @@ -96,25 +96,27 @@ import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO(..)) +import Data.Kind (Type) import Data.Word (Word8) -import System.IO (Handle, openFile, IOMode(..), hClose) +import System.IO + (Handle, IOMode(..), openFile, hClose, hSetBuffering, BufferMode(..)) import Prelude hiding (read) import qualified Control.Monad.Catch as MC import qualified System.IO as SIO import Streamly.Data.Fold (groupsOf, drain) -import Streamly.Internal.Data.Array.Type (Array(..), writeNUnsafe) +import Streamly.Internal.Data.Array.Type (Array(..)) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Data.Stream (Stream) -import Streamly.Internal.Data.Unboxed (Unbox) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) import Streamly.Internal.System.IO (defaultChunkSize) -import qualified Streamly.Data.Array as A +import qualified Streamly.Internal.Data.Array as A import qualified Streamly.Data.Stream as S import qualified Streamly.Data.Unfold as UF +import qualified Streamly.Internal.Data.Array.Type as IA (chunksOf') import qualified Streamly.Internal.Data.Unfold as UF (bracketIO) import qualified Streamly.Internal.Data.Fold.Type as FL (Step(..), snoc, reduce) @@ -149,8 +151,15 @@ {-# INLINE withFile #-} withFile :: (MonadIO m, MonadCatch m) => FilePath -> IOMode -> (Handle -> Stream m a) -> Stream m a -withFile file mode = S.bracketIO (openFile file mode) hClose +withFile file mode = S.bracketIO open hClose + where + + open = do + h <- openFile file mode + hSetBuffering h NoBuffering + return h + -- | Transform an 'Unfold' from a 'Handle' to an unfold from a 'FilePath'. The -- resulting unfold opens a handle in 'ReadMode', uses it using the supplied -- unfold and then makes sure that the handle is closed on normal termination @@ -162,8 +171,16 @@ {-# INLINE usingFile #-} usingFile :: (MonadIO m, MonadCatch m) => Unfold m Handle a -> Unfold m FilePath a -usingFile = UF.bracketIO (`openFile` ReadMode) hClose +usingFile = UF.bracketIO open hClose + where + + open file = do + h <- openFile file ReadMode + hSetBuffering h NoBuffering + return h + + {-# INLINE usingFile2 #-} usingFile2 :: (MonadIO m, MonadCatch m) => Unfold m (x, Handle) a -> Unfold m (x, FilePath) a @@ -173,6 +190,7 @@ before (x, file) = do h <- openFile file ReadMode + hSetBuffering h NoBuffering return (x, h) after (_, h) = hClose h @@ -186,6 +204,7 @@ before (x, y, z, file) = do h <- openFile file ReadMode + hSetBuffering h NoBuffering return (x, y, z, h) after (_, _, _, h) = hClose h @@ -205,16 +224,16 @@ -- /Pre-release/ -- {-# INLINABLE putChunk #-} -putChunk :: FilePath -> Array a -> IO () +putChunk :: forall (a :: Type). FilePath -> Array a -> IO () putChunk file arr = SIO.withFile file WriteMode (`FH.putChunk` arr) -- | append an array to a file. -- -- /Pre-release/ -- -{-# INLINABLE appendArray #-} -appendArray :: FilePath -> Array a -> IO () -appendArray file arr = SIO.withFile file AppendMode (`FH.putChunk` arr) +{-# INLINABLE writeAppendArray #-} +writeAppendArray :: forall (a :: Type). FilePath -> Array a -> IO () +writeAppendArray file arr = SIO.withFile file AppendMode (`FH.putChunk` arr) ------------------------------------------------------------------------------- -- Stream of Arrays IO @@ -337,11 +356,7 @@ -- /Pre-release/ {-# INLINE reader #-} reader :: (MonadIO m, MonadCatch m) => Unfold m FilePath Word8 -reader = UF.many A.reader (usingFile FH.chunkReader) - -{-# INLINE concatChunks #-} -concatChunks :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a -concatChunks = S.unfoldMany A.reader +reader = UF.unfoldEach A.reader (usingFile FH.chunkReader) -- | Generate a stream of bytes from a file specified by path. The stream ends -- when EOF is encountered. File is locked using multiple reader and single @@ -351,7 +366,7 @@ -- {-# INLINE read #-} read :: (MonadIO m, MonadCatch m) => FilePath -> Stream m Word8 -read file = concatChunks $ withFile file ReadMode FH.readChunks +read file = A.concat $ withFile file ReadMode FH.readChunks {-# DEPRECATED toBytes "Please use 'read' instead" #-} {-# INLINE toBytes #-} @@ -374,7 +389,7 @@ ------------------------------------------------------------------------------- {-# INLINE fromChunksMode #-} -fromChunksMode :: (MonadIO m, MonadCatch m) +fromChunksMode :: forall m (a :: Type). (MonadIO m, MonadCatch m) => IOMode -> FilePath -> Stream m (Array a) -> m () fromChunksMode mode file xs = S.fold drain $ withFile file mode (\h -> S.mapM (FH.putChunk h) xs) @@ -384,7 +399,7 @@ -- /Pre-release/ -- {-# INLINE fromChunks #-} -fromChunks :: (MonadIO m, MonadCatch m) +fromChunks :: forall m (a :: Type). (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array a) -> m () fromChunks = fromChunksMode WriteMode @@ -405,7 +420,7 @@ {-# INLINE fromBytesWith #-} fromBytesWith :: (MonadIO m, MonadCatch m) => Int -> FilePath -> Stream m Word8 -> m () -fromBytesWith n file xs = fromChunks file $ S.chunksOf n xs +fromBytesWith n file xs = fromChunks file $ IA.chunksOf' n xs {-# DEPRECATED fromBytesWithBufferOf "Please use 'fromBytesWith' instead" #-} {-# INLINE fromBytesWithBufferOf #-} @@ -436,24 +451,28 @@ -- -- /Pre-release/ {-# INLINE writeChunks #-} -writeChunks :: (MonadIO m, MonadCatch m) +writeChunks :: forall m (a :: Type). (MonadIO m, MonadCatch m) => FilePath -> Fold m (Array a) () -writeChunks path = Fold step initial extract +writeChunks path = Fold step initial extract final where initial = do h <- liftIO (openFile path WriteMode) + liftIO $ hSetBuffering h NoBuffering fld <- FL.reduce (FH.writeChunks h) `MC.onException` liftIO (hClose h) return $ FL.Partial (fld, h) step (fld, h) x = do r <- FL.snoc fld x `MC.onException` liftIO (hClose h) return $ FL.Partial (r, h) - extract (Fold _ initial1 extract1, h) = do + + extract _ = return () + + final (Fold _ initial1 _ final1, h) = do liftIO $ hClose h res <- initial1 case res of - FL.Partial fs -> extract1 fs - FL.Done fb -> return fb + FL.Partial fs -> final1 fs + FL.Done () -> return () -- | @writeWith chunkSize handle@ writes the input stream to @handle@. -- Bytes in the input stream are collected into a buffer until we have a chunk @@ -464,7 +483,7 @@ writeWith :: (MonadIO m, MonadCatch m) => Int -> FilePath -> Fold m Word8 () writeWith n path = - groupsOf n (writeNUnsafe n) (writeChunks path) + groupsOf n (A.unsafeCreateOf' n) (writeChunks path) {-# DEPRECATED writeWithBufferOf "Please use 'writeWith' instead" #-} {-# INLINE writeWithBufferOf #-} @@ -488,10 +507,10 @@ -- -- /Pre-release/ -- -{-# INLINE appendChunks #-} -appendChunks :: (MonadIO m, MonadCatch m) +{-# INLINE writeAppendChunks #-} +writeAppendChunks :: forall m (a :: Type). (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array a) -> m () -appendChunks = fromChunksMode AppendMode +writeAppendChunks = fromChunksMode AppendMode -- | Like 'append' but provides control over the write buffer. Output will -- be written to the IO device as soon as we collect the specified number of @@ -499,10 +518,11 @@ -- -- /Pre-release/ -- -{-# INLINE appendWith #-} -appendWith :: (MonadIO m, MonadCatch m) +{-# INLINE writeAppendWith #-} +writeAppendWith :: (MonadIO m, MonadCatch m) => Int -> FilePath -> Stream m Word8 -> m () -appendWith n file xs = appendChunks file $ S.chunksOf n xs +writeAppendWith n file xs = + writeAppendChunks file $ IA.chunksOf' n xs -- | Append a byte stream to a file. Combines the bytes in chunks of size up to -- 'A.defaultChunkSize' before writing. If the file exists then the new data @@ -511,9 +531,9 @@ -- -- /Pre-release/ -- -{-# INLINE append #-} -append :: (MonadIO m, MonadCatch m) => FilePath -> Stream m Word8 -> m () -append = appendWith defaultChunkSize +{-# INLINE writeAppend #-} +writeAppend :: (MonadIO m, MonadCatch m) => FilePath -> Stream m Word8 -> m () +writeAppend = writeAppendWith defaultChunkSize {- -- | Like 'append' but the file is not locked for exclusive writes. diff --git a/src/Streamly/Internal/FileSystem/File/Common.hs b/src/Streamly/Internal/FileSystem/File/Common.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/File/Common.hs @@ -0,0 +1,97 @@ +module Streamly.Internal.FileSystem.File.Common + ( withFile + , openFile + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Control.Exception (mask, onException, try) +import Control.Monad (when) +import GHC.IO (catchException) +import GHC.IO.Exception (IOException(..)) +import GHC.IO.Handle.Internals (handleFinalizer) +import Streamly.Internal.FileSystem.Path (Path) +import System.IO (IOMode(..), Handle, hSetBinaryMode, hClose) + +import qualified Streamly.Internal.FileSystem.Path as Path + +#if MIN_VERSION_base(4,16,0) +import GHC.IO.Handle.Internals (addHandleFinalizer) +#else +import Control.Concurrent.MVar (MVar, addMVarFinalizer) +import GHC.IO.Handle.Types (Handle__, Handle(..)) +#endif + +------------------------------------------------------------------------------- +-- Utils +------------------------------------------------------------------------------- + +#if !(MIN_VERSION_base(4,16,0)) +type HandleFinalizer = FilePath -> MVar Handle__ -> IO () + +-- | Add a finalizer to a 'Handle'. Specifically, the finalizer +-- will be added to the 'MVar' of a file handle or the write-side +-- 'MVar' of a duplex handle. See Handle Finalizers for details. +addHandleFinalizer :: Handle -> HandleFinalizer -> IO () +addHandleFinalizer handle finalizer = do + addMVarFinalizer mv (finalizer filepath mv) + where + !(filepath, !mv) = case handle of + FileHandle fp m -> (fp, m) + DuplexHandle fp _ write_m -> (fp, write_m) +#endif + +{-# INLINE withOpenFile #-} +withOpenFile + :: Bool + -> Bool + -> (Path -> IOMode -> IO Handle) + -> Path + -> IOMode + -> (Handle -> IO r) + -> IO r +withOpenFile binary close_finally f fp iomode action = + mask $ \restore -> do + h <- f fp iomode + -- XXX In case of withFile it will be closed anyway, so do we even need + -- this? + addHandleFinalizer h handleFinalizer + when binary $ hSetBinaryMode h True + r <- restore (action h) `onException` hClose h + when close_finally $ hClose h + pure r + +addFilePathToIOError :: String -> Path -> IOException -> IOException +addFilePathToIOError fun fp ioe = + let !str = Path.toString fp + in ioe + { ioe_location = fun + , ioe_filename = Just str + } + +{-# INLINE catchWith #-} +catchWith :: String -> Path -> IO a -> IO a +catchWith str path io = + catchException io (ioError . addFilePathToIOError str path) + +{-# INLINE withFile #-} +withFile :: + Bool + -> (Path -> IOMode -> IO Handle) + -> Path + -> IOMode + -> (Handle -> IO r) + -> IO r +withFile binary f path iomode act = + catchWith "withFile" path + (withOpenFile binary True f path iomode (try . act)) + >>= either ioError pure + +{-# INLINE openFile #-} +openFile :: + Bool -> (Path -> IOMode -> IO Handle) -> Path -> IOMode -> IO Handle +openFile binary f path iomode = + catchWith "openFile" path + $ withOpenFile binary False f path iomode pure diff --git a/src/Streamly/Internal/FileSystem/FileIO.hs b/src/Streamly/Internal/FileSystem/FileIO.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/FileIO.hs @@ -0,0 +1,643 @@ +-- | +-- Module : Streamly.Internal.FileSystem.FileIO +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- + +module Streamly.Internal.FileSystem.FileIO + ( + -- * Streaming IO + -- | Stream data to or from a file or device sequentially. When reading, + -- the stream is lazy and generated on-demand as the consumer consumes it. + -- Read IO requests to the IO device are performed in chunks limited to a + -- maximum size of 32KiB, this is referred to as @defaultChunkSize@ in the + -- documentation. One IO request may or may not read the full + -- chunk. If the whole stream is not consumed, it is possible that we may + -- read slightly more from the IO device than what the consumer needed. + -- Unless specified otherwise in the API, writes are collected into chunks + -- of @defaultChunkSize@ before they are written to the IO device. + + -- Streaming APIs work for all kind of devices, seekable or non-seekable; + -- including disks, files, memory devices, terminals, pipes, sockets and + -- fifos. While random access APIs work only for files or devices that have + -- random access or seek capability for example disks, memory devices. + -- Devices like terminals, pipes, sockets and fifos do not have random + -- access capability. + + -- ** File IO Using Handle + withFile + + -- ** Streams + , read + , readChunksWith + , readChunks + + -- ** Unfolds + , readerWith + , reader + -- , readShared + -- , readUtf8 + -- , readLines + -- , readFrames + , chunkReaderWith + , chunkReaderFromToWith + , chunkReader + + -- ** Write To File + , putChunk -- writeChunk? + + -- ** Folds + , write + -- , writeUtf8 + -- , writeUtf8ByLines + -- , writeByFrames + , writeWith + , writeChunks + + -- ** Writing Streams + , fromBytes -- XXX putBytes? + , fromBytesWith -- putBytesWith + , fromChunks -- putChunks? + + -- ** Append To File + , writeAppend + , writeAppendWith + -- , appendShared + , writeAppendArray + , writeAppendChunks + ) +where + +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Word (Word8) +import System.IO (Handle, IOMode(..), hClose, hSetBuffering, BufferMode(..)) +import Prelude hiding (read) + +import qualified Control.Monad.Catch as MC + +import Streamly.Data.Fold (groupsOf, drain) +import Streamly.Internal.Data.Array.Type (Array(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Data.Stream (Stream) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +-- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) +import Streamly.Internal.System.IO (defaultChunkSize) +import Streamly.Internal.FileSystem.Path (Path) + +import qualified Streamly.Internal.Data.Array as A +import qualified Streamly.Data.Stream as S +import qualified Streamly.Data.Unfold as UF +import qualified Streamly.Internal.Data.Unfold as UF (bracketIO) +import qualified Streamly.Internal.Data.Fold.Type as FL + (Step(..), snoc, reduce) +import qualified Streamly.Internal.FileSystem.Handle as FH +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import qualified Streamly.Internal.FileSystem.Posix.File as File +#else +import qualified Streamly.Internal.FileSystem.Windows.File as File +#endif + +#include "inline.hs" + +------------------------------------------------------------------------------- +-- References +------------------------------------------------------------------------------- +-- +-- The following references may be useful to build an understanding about the +-- file API design: +-- +-- http://www.linux-mag.com/id/308/ for blocking/non-blocking IO on linux. +-- https://lwn.net/Articles/612483/ Non-blocking buffered file read operations +-- https://en.wikipedia.org/wiki/C_file_input/output for C APIs. +-- https://docs.oracle.com/javase/tutorial/essential/io/file.html for Java API. +-- https://www.w3.org/TR/FileAPI/ for http file API. + +------------------------------------------------------------------------------- +-- Safe file reading +------------------------------------------------------------------------------- + +-- | @'withFile' name mode act@ opens a file and passes the resulting handle to +-- the computation @act@. The handle is closed on exit from 'withFile', whether +-- by normal termination or by raising an exception. If closing the handle +-- raises an exception, then that exception is raised by 'withFile' rather than +-- any exception raised by 'act'. +-- +-- The file is opened in binary mode as encoding, decoding, and newline +-- translation can be handled explicitly by the streaming APIs. +-- +-- The file is opened without buffering as buffering can be controlled +-- explicitly by the streaming APIs. +-- +-- /Pre-release/ +-- +{-# INLINE withFile #-} +withFile :: (MonadIO m, MonadCatch m) + => Path -> IOMode -> (Handle -> Stream m a) -> Stream m a +withFile file mode = S.bracketIO open hClose + + where + + open = do + h <- File.openBinaryFile file mode + hSetBuffering h NoBuffering + return h + +-- | Transform an 'Unfold' that takes 'Handle' as input to an unfold that takes +-- a 'Path' as input. The resulting unfold opens the file in 'ReadMode', +-- passes it to the supplied unfold and then makes sure that the handle is +-- closed on normal termination or in case of an exception. If closing the +-- handle raises an exception, then this exception will be raised by +-- 'usingFile'. +-- +-- The file is opened in binary mode as encoding, decoding, and newline +-- translation can be handled explicitly by the streaming APIs. +-- +-- The file is opened without buffering as buffering can be controlled +-- explicitly by the streaming APIs. +-- +-- /Pre-release/ +-- +{-# INLINE usingFile #-} +usingFile :: (MonadIO m, MonadCatch m) + => Unfold m Handle a -> Unfold m Path a +usingFile = UF.bracketIO open hClose + + where + + open file = do + h <- File.openBinaryFile file ReadMode + hSetBuffering h NoBuffering + return h + +{-# INLINE usingFile2 #-} +usingFile2 :: (MonadIO m, MonadCatch m) + => Unfold m (x, Handle) a -> Unfold m (x, Path) a +usingFile2 = UF.bracketIO before after + + where + + before (x, file) = do + h <- File.openBinaryFile file ReadMode + hSetBuffering h NoBuffering + return (x, h) + + after (_, h) = hClose h + +{-# INLINE usingFile3 #-} +usingFile3 :: (MonadIO m, MonadCatch m) + => Unfold m (x, y, z, Handle) a -> Unfold m (x, y, z, Path) a +usingFile3 = UF.bracketIO before after + + where + + before (x, y, z, file) = do + h <- File.openBinaryFile file ReadMode + hSetBuffering h NoBuffering + return (x, y, z, h) + + after (_, _, _, h) = hClose h + +------------------------------------------------------------------------------- +-- Array IO (Input) +------------------------------------------------------------------------------- + +-- TODO readArrayOf + +------------------------------------------------------------------------------- +-- Array IO (output) +------------------------------------------------------------------------------- + +-- | Write an array to a file. Overwrites the file if it exists. +-- +-- /Pre-release/ +-- +{-# INLINABLE putChunk #-} +putChunk :: Path -> Array a -> IO () +putChunk file arr = File.withFile file WriteMode (`FH.putChunk` arr) + +-- | Append an array to a file. +-- +-- /Pre-release/ +-- +{-# INLINABLE writeAppendArray #-} +writeAppendArray :: Path -> Array a -> IO () +writeAppendArray file arr = File.withFile file AppendMode (`FH.putChunk` arr) + +------------------------------------------------------------------------------- +-- Stream of Arrays IO +------------------------------------------------------------------------------- + +-- | @readChunksWith size file@ reads a stream of arrays from file @file@. +-- The maximum size of a single array is specified by @size@. The actual size +-- read may be less than or equal to @size@. +-- +-- /Pre-release/ +-- +{-# INLINE readChunksWith #-} +readChunksWith :: (MonadIO m, MonadCatch m) + => Int -> Path -> Stream m (Array Word8) +readChunksWith size file = + withFile file ReadMode (FH.readChunksWith size) + +-- XXX read 'Array a' instead of Word8 +-- +-- | @readChunks file@ reads a stream of arrays from file @file@. +-- The maximum size of a single array is limited to @defaultChunkSize@. The +-- actual size read may be less than @defaultChunkSize@. +-- +-- > readChunks = readChunksWith defaultChunkSize +-- +-- /Pre-release/ +-- +{-# INLINE readChunks #-} +readChunks :: (MonadIO m, MonadCatch m) + => Path -> Stream m (Array Word8) +readChunks = readChunksWith defaultChunkSize + +------------------------------------------------------------------------------- +-- Read File to Stream +------------------------------------------------------------------------------- + +-- TODO for concurrent streams implement readahead IO. We can send multiple +-- read requests at the same time. For serial case we can use async IO. We can +-- also control the read throughput in mbps or IOPS. + +-- | Unfold the tuple @(bufsize, filepath)@ into a stream of 'Word8' arrays. +-- Read requests to the IO device are performed using a buffer of size +-- @bufsize@. The size of an array in the resulting stream is always less than +-- or equal to @bufsize@. +-- +-- /Pre-release/ +-- +{-# INLINE chunkReaderWith #-} +chunkReaderWith :: (MonadIO m, MonadCatch m) + => Unfold m (Int, Path) (Array Word8) +chunkReaderWith = usingFile2 FH.chunkReaderWith + +-- | Unfold the tuple @(from, to, bufsize, filepath)@ into a stream +-- of 'Word8' arrays. +-- Read requests to the IO device are performed using a buffer of size +-- @bufsize@ starting from absolute offset of @from@ till the absolute +-- position of @to@. The size of an array in the resulting stream is always +-- less than or equal to @bufsize@. +-- +-- /Pre-release/ +{-# INLINE chunkReaderFromToWith #-} +chunkReaderFromToWith :: (MonadIO m, MonadCatch m) => + Unfold m (Int, Int, Int, Path) (Array Word8) +chunkReaderFromToWith = usingFile3 FH.chunkReaderFromToWith + +-- | Unfolds a 'Path' into a stream of 'Word8' arrays. Requests to the IO +-- device are performed using a buffer of size +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. The +-- size of arrays in the resulting stream are therefore less than or equal to +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. +-- +-- /Pre-release/ +{-# INLINE chunkReader #-} +chunkReader :: (MonadIO m, MonadCatch m) => Unfold m Path (Array Word8) +chunkReader = usingFile FH.chunkReader + +-- | Unfolds the tuple @(bufsize, filepath)@ into a byte stream, read requests +-- to the IO device are performed using buffers of @bufsize@. +-- +-- /Pre-release/ +{-# INLINE readerWith #-} +readerWith :: (MonadIO m, MonadCatch m) => Unfold m (Int, Path) Word8 +readerWith = usingFile2 FH.readerWith + +-- | Unfolds a file path into a byte stream. IO requests to the device are +-- performed in sizes of +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. +-- +-- /Pre-release/ +{-# INLINE reader #-} +reader :: (MonadIO m, MonadCatch m) => Unfold m Path Word8 +reader = UF.unfoldEach A.reader (usingFile FH.chunkReader) + +-- | Generate a stream of bytes from a file specified by path. The stream ends +-- when EOF is encountered. File is locked using multiple reader and single +-- writer locking mode. +-- +-- /Pre-release/ +-- +{-# INLINE read #-} +read :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 +read file = A.concat $ withFile file ReadMode FH.readChunks + +{- +-- | Generate a stream of elements of the given type from a file 'Handle'. The +-- stream ends when EOF is encountered. File is not locked for exclusive reads, +-- writers can keep writing to the file. +-- +-- @since 0.7.0 +{-# INLINE readShared #-} +readShared :: MonadIO m => Handle -> Stream m Word8 +readShared = undefined +-} + +------------------------------------------------------------------------------- +-- Writing +------------------------------------------------------------------------------- + +{-# INLINE fromChunksMode #-} +fromChunksMode :: (MonadIO m, MonadCatch m) + => IOMode -> Path -> Stream m (Array a) -> m () +fromChunksMode mode file xs = S.fold drain $ + withFile file mode (\h -> S.mapM (FH.putChunk h) xs) + +-- | Write a stream of arrays to a file. Overwrites the file if it exists. +-- +-- /Pre-release/ +-- +{-# INLINE fromChunks #-} +fromChunks :: (MonadIO m, MonadCatch m) + => Path -> Stream m (Array a) -> m () +fromChunks = fromChunksMode WriteMode + +-- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes. +-- +-- XXX test this +-- Note that if you use a chunk size less than 8K (GHC's default buffer +-- size) then you are advised to use 'NOBuffering' mode on the 'Handle' in case you +-- do not want buffering to occur at GHC level as well. Same thing applies to +-- writes as well. + +-- | Like 'write' but provides control over the write buffer. Output will +-- be written to the IO device as soon as we collect the specified number of +-- input elements. +-- +-- /Pre-release/ +-- +{-# INLINE fromBytesWith #-} +fromBytesWith :: (MonadIO m, MonadCatch m) + => Int -> Path -> Stream m Word8 -> m () +fromBytesWith n file xs = fromChunks file $ A.chunksOf' n xs + +-- > write = 'writeWith' defaultChunkSize +-- +-- | Write a byte stream to a file. Combines the bytes in chunks of size +-- up to 'A.defaultChunkSize' before writing. If the file exists it is +-- truncated to zero size before writing. If the file does not exist it is +-- created. File is locked using single writer locking mode. +-- +-- /Pre-release/ +{-# INLINE fromBytes #-} +fromBytes :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 -> m () +fromBytes = fromBytesWith defaultChunkSize + +{- +{-# INLINE write #-} +write :: (MonadIO m, Storable a) => Handle -> Stream m a -> m () +write = toHandleWith A.defaultChunkSize +-} + +-- | Write a stream of chunks to a file. Each chunk in the stream is written +-- immediately to the device as a separate IO request, without coalescing or +-- buffering. +-- +{-# INLINE writeChunks #-} +writeChunks :: (MonadIO m, MonadCatch m) + => Path -> Fold m (Array a) () +writeChunks path = Fold step initial extract final + where + initial = do + h <- liftIO (File.openBinaryFile path WriteMode) + liftIO $ hSetBuffering h NoBuffering + fld <- FL.reduce (FH.writeChunks h) + `MC.onException` liftIO (hClose h) + return $ FL.Partial (fld, h) + step (fld, h) x = do + r <- FL.snoc fld x `MC.onException` liftIO (hClose h) + return $ FL.Partial (r, h) + + extract _ = return () + + final (Fold _ initial1 _ final1, h) = do + liftIO $ hClose h + res <- initial1 + case res of + FL.Partial fs -> final1 fs + FL.Done () -> return () + +-- | @writeWith chunkSize handle@ writes the input stream to @handle@. +-- Bytes in the input stream are collected into a buffer until we have a chunk +-- of size @chunkSize@ and then written to the IO device. +-- +-- /Pre-release/ +{-# INLINE writeWith #-} +writeWith :: (MonadIO m, MonadCatch m) + => Int -> Path -> Fold m Word8 () +writeWith n path = + groupsOf n (A.unsafeCreateOf' n) (writeChunks path) + +-- > write = 'writeWith' A.defaultChunkSize +-- +-- | Write a byte stream to a file. Accumulates the input in chunks of up to +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize' before writing to +-- the IO device. +-- +-- /Pre-release/ +-- +{-# INLINE write #-} +write :: (MonadIO m, MonadCatch m) => Path -> Fold m Word8 () +write = writeWith defaultChunkSize + +-- | Append a stream of arrays to a file. +-- +-- /Pre-release/ +-- +{-# INLINE writeAppendChunks #-} +writeAppendChunks :: (MonadIO m, MonadCatch m) + => Path -> Stream m (Array a) -> m () +writeAppendChunks = fromChunksMode AppendMode + +-- | Like 'append' but provides control over the write buffer. Output will +-- be written to the IO device as soon as we collect the specified number of +-- input elements. +-- +-- /Pre-release/ +-- +{-# INLINE writeAppendWith #-} +writeAppendWith :: (MonadIO m, MonadCatch m) + => Int -> Path -> Stream m Word8 -> m () +writeAppendWith n file xs = + writeAppendChunks file $ A.chunksOf' n xs + +-- | Append a byte stream to a file. Combines the bytes in chunks of size up to +-- 'A.defaultChunkSize' before writing. If the file exists then the new data +-- is appended to the file. If the file does not exist it is created. File is +-- locked using single writer locking mode. +-- +-- /Pre-release/ +-- +{-# INLINE writeAppend #-} +writeAppend :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 -> m () +writeAppend = writeAppendWith defaultChunkSize + +{- +-- | Like 'append' but the file is not locked for exclusive writes. +-- +-- @since 0.7.0 +{-# INLINE appendShared #-} +appendShared :: MonadIO m => Handle -> Stream m Word8 -> m () +appendShared = undefined +-} + +------------------------------------------------------------------------------- +-- IO with encoding/decoding Unicode characters +------------------------------------------------------------------------------- + +{- +-- | +-- > readUtf8 = decodeUtf8 . read +-- +-- Read a UTF8 encoded stream of unicode characters from a file handle. +-- +-- @since 0.7.0 +{-# INLINE readUtf8 #-} +readUtf8 :: MonadIO m => Handle -> Stream m Char +readUtf8 = decodeUtf8 . read + +-- | +-- > writeUtf8 h s = write h $ encodeUtf8 s +-- +-- Encode a stream of unicode characters to UTF8 and write it to the given file +-- handle. Default block buffering applies to the writes. +-- +-- @since 0.7.0 +{-# INLINE writeUtf8 #-} +writeUtf8 :: MonadIO m => Handle -> Stream m Char -> m () +writeUtf8 h s = write h $ encodeUtf8 s + +-- | Write a stream of unicode characters after encoding to UTF-8 in chunks +-- separated by a linefeed character @'\n'@. If the size of the buffer exceeds +-- @defaultChunkSize@ and a linefeed is not yet found, the buffer is written +-- anyway. This is similar to writing to a 'Handle' with the 'LineBuffering' +-- option. +-- +-- @since 0.7.0 +{-# INLINE writeUtf8ByLines #-} +writeUtf8ByLines :: MonadIO m => Handle -> Stream m Char -> m () +writeUtf8ByLines = undefined + +-- | Read UTF-8 lines from a file handle and apply the specified fold to each +-- line. This is similar to reading a 'Handle' with the 'LineBuffering' option. +-- +-- @since 0.7.0 +{-# INLINE readLines #-} +readLines :: MonadIO m => Handle -> Fold m Char b -> Stream m b +readLines h f = foldLines (readUtf8 h) f + +------------------------------------------------------------------------------- +-- Framing on a sequence +------------------------------------------------------------------------------- + +-- | Read a stream from a file handle and split it into frames delimited by +-- the specified sequence of elements. The supplied fold is applied on each +-- frame. +-- +-- @since 0.7.0 +{-# INLINE readFrames #-} +readFrames :: (MonadIO m, Storable a) + => Array a -> Handle -> Fold m a b -> Stream m b +readFrames = undefined -- foldFrames . read + +-- | Write a stream to the given file handle buffering up to frames separated +-- by the given sequence or up to a maximum of @defaultChunkSize@. +-- +-- @since 0.7.0 +{-# INLINE writeByFrames #-} +writeByFrames :: (MonadIO m, Storable a) + => Array a -> Handle -> Stream m a -> m () +writeByFrames = undefined + +------------------------------------------------------------------------------- +-- Random Access IO (Seek) +------------------------------------------------------------------------------- + +-- XXX handles could be shared, so we may not want to use the handle state at +-- all for these APIs. we can use pread and pwrite instead. On windows we will +-- need to use readFile/writeFile with an offset argument. + +------------------------------------------------------------------------------- + +-- | Read the element at the given index treating the file as an array. +-- +-- @since 0.7.0 +{-# INLINE readIndex #-} +readIndex :: Storable a => Handle -> Int -> Maybe a +readIndex arr i = undefined + +-- NOTE: To represent a range to read we have chosen (start, size) instead of +-- (start, end). This helps in removing the ambiguity of whether "end" is +-- included in the range or not. +-- +-- We could avoid specifying the range to be read and instead use "take size" +-- on the stream, but it may end up reading more and then consume it partially. + +-- | @readSliceWith chunkSize handle pos len@ reads up to @len@ bytes +-- from @handle@ starting at the offset @pos@ from the beginning of the file. +-- +-- Reads are performed in chunks of size @chunkSize@. For block devices, to +-- avoid reading partial blocks @chunkSize@ must align with the block size of +-- the underlying device. If the underlying block size is unknown, it is a good +-- idea to keep it a multiple 4KiB. This API ensures that the start of each +-- chunk is aligned with @chunkSize@ from second chunk onwards. +-- +{-# INLINE readSliceWith #-} +readSliceWith :: (MonadIO m, Storable a) + => Int -> Handle -> Int -> Int -> Stream m a +readSliceWith chunkSize h pos len = undefined + +-- | @readSlice h i count@ streams a slice from the file handle @h@ starting +-- at index @i@ and reading up to @count@ elements in the forward direction +-- ending at the index @i + count - 1@. +-- +-- @since 0.7.0 +{-# INLINE readSlice #-} +readSlice :: (MonadIO m, Storable a) + => Handle -> Int -> Int -> Stream m a +readSlice = readSliceWith defaultChunkSize + +-- | @readSliceRev h i count@ streams a slice from the file handle @h@ starting +-- at index @i@ and reading up to @count@ elements in the reverse direction +-- ending at the index @i - count + 1@. +-- +-- @since 0.7.0 +{-# INLINE readSliceRev #-} +readSliceRev :: (MonadIO m, Storable a) + => Handle -> Int -> Int -> Stream m a +readSliceRev h i count = undefined + +-- | Write the given element at the given index in the file. +-- +-- @since 0.7.0 +{-# INLINE writeIndex #-} +writeIndex :: (MonadIO m, Storable a) => Handle -> Int -> a -> m () +writeIndex h i a = undefined + +-- | @writeSlice h i count stream@ writes a stream to the file handle @h@ +-- starting at index @i@ and writing up to @count@ elements in the forward +-- direction ending at the index @i + count - 1@. +-- +-- @since 0.7.0 +{-# INLINE writeSlice #-} +writeSlice :: (Monad m, Storable a) + => Handle -> Int -> Int -> Stream m a -> m () +writeSlice h i len s = undefined + +-- | @writeSliceRev h i count stream@ writes a stream to the file handle @h@ +-- starting at index @i@ and writing up to @count@ elements in the reverse +-- direction ending at the index @i - count + 1@. +-- +-- @since 0.7.0 +{-# INLINE writeSliceRev #-} +writeSliceRev :: (Monad m, Storable a) + => Handle -> Int -> Int -> Stream m a -> m () +writeSliceRev arr i len s = undefined +-} diff --git a/src/Streamly/Internal/FileSystem/Handle.hs b/src/Streamly/Internal/FileSystem/Handle.hs --- a/src/Streamly/Internal/FileSystem/Handle.hs +++ b/src/Streamly/Internal/FileSystem/Handle.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + #include "inline.hs" -- | @@ -25,6 +27,12 @@ -- module Streamly.Internal.FileSystem.Handle ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + -- * Singleton APIs getChunk , getChunkOf @@ -32,8 +40,8 @@ -- * Streams , read - , readWith - , readChunksWith + , readWith -- readConcatChunksOf + , readChunksWith -- readChunksOf , readChunks -- * Unfolds @@ -51,10 +59,10 @@ -- , writeUtf8ByLines -- , writeByFrames -- , writeLines - , writeWith + , writeWith -- writeChunksOf , writeChunks - , writeChunksWith - , writeMaybesWith + , writeChunksWith -- writeCompactChunksOf + , writeMaybesWith -- writeCompactJustsOf -- * Refolds , writer @@ -113,9 +121,10 @@ import Control.Exception (assert) import Control.Monad.IO.Class (MonadIO(..)) import Data.Function ((&)) +import Data.Kind (Type) import Data.Maybe (isNothing, fromJust) import Data.Word (Word8) -import Streamly.Internal.Data.Unboxed (Unbox) +import Streamly.Internal.Data.Unbox (Unbox) import System.IO (Handle, SeekMode(..), hGetBufSome, hPutBuf, hSeek) import Prelude hiding (read) @@ -123,36 +132,23 @@ import Streamly.Internal.Data.Refold.Type (Refold(..)) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import Streamly.Internal.Data.Array.Type - (Array(..), writeNUnsafe, unsafeFreezeWithShrink, byteLength) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Stream.Chunked (lpackArraysChunksOf) + (Array(..), unsafeFreezeWithShrink, byteLength) +import Streamly.Internal.Data.Stream.Type (Stream) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) import Streamly.Internal.System.IO (defaultChunkSize) import qualified Streamly.Data.Fold as FL -import qualified Streamly.Data.Array as A -import qualified Streamly.Internal.Data.Array.Type as A -import qualified Streamly.Internal.Data.Stream.Chunked as AS -import qualified Streamly.Internal.Data.Array.Mut.Type as MArray +import qualified Streamly.Internal.Data.Array as A +import qualified Streamly.Internal.Data.MutArray.Type as MArray import qualified Streamly.Internal.Data.Refold.Type as Refold import qualified Streamly.Internal.Data.Fold.Type as FL(refoldMany) -import qualified Streamly.Internal.Data.Stream.StreamD as S -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import qualified Streamly.Internal.Data.Stream as S +import qualified Streamly.Internal.Data.Stream as D (Stream(..), Step(..)) import qualified Streamly.Internal.Data.Unfold as UF -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K (mkStream) +import qualified Streamly.Internal.Data.StreamK.Type as K (mkStream) --- $setup --- >>> import qualified Streamly.Data.Array as Array --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Unfold as Unfold --- >>> import qualified Streamly.Data.Stream as Stream --- --- >>> import qualified Streamly.Internal.Data.Array.Type as Array (writeNUnsafe) --- >>> import qualified Streamly.Internal.Data.Stream as Stream --- >>> import qualified Streamly.Internal.Data.Unfold as Unfold (first) --- >>> import qualified Streamly.Internal.FileSystem.Handle as Handle --- >>> import qualified Streamly.Internal.System.IO as IO (defaultChunkSize) +#include "DocTestFileSystemHandle.hs" ------------------------------------------------------------------------------- -- References @@ -171,6 +167,8 @@ -- Array IO (Input) ------------------------------------------------------------------------------- +-- XXX add an API that compacts the arrays to an exact size. + -- | Read a 'ByteArray' consisting of one or more bytes from a file handle. If -- no data is available on the handle it blocks until at least one byte becomes -- available. If any data is available then it immediately returns that data @@ -180,14 +178,10 @@ {-# INLINABLE getChunk #-} getChunk :: MonadIO m => Int -> Handle -> m (Array Word8) getChunk size h = liftIO $ do - arr <- MArray.newPinnedBytes size -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8)) - MArray.asPtrUnsafe arr $ \p -> do - n <- hGetBufSome h p size - -- XXX shrink only if the diff is significant - return $ - unsafeFreezeWithShrink $ - arr { MArray.arrEnd = n, MArray.arrBound = size } + arr <- MArray.unsafeCreateWithPtr' size $ \p -> hGetBufSome h p size + -- XXX shrink only if the diff is significant + pure $ unsafeFreezeWithShrink arr -- This could be useful in implementing the "reverse" read APIs or if you want -- to read arrays of exact size instead of compacting them later. Compacting @@ -327,11 +321,11 @@ -- | Unfolds the tuple @(bufsize, handle)@ into a byte stream, read requests -- to the IO device are performed using buffers of @bufsize@. -- --- >>> readerWith = Unfold.many Array.reader Handle.chunkReaderWith +-- >>> readerWith = Unfold.unfoldEach Array.reader Handle.chunkReaderWith -- {-# INLINE readerWith #-} readerWith :: MonadIO m => Unfold m (Int, Handle) Word8 -readerWith = UF.many A.reader chunkReaderWith +readerWith = UF.unfoldEach A.reader chunkReaderWith -- | Same as 'readerWith' -- @@ -340,38 +334,34 @@ readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8 readWithBufferOf = readerWith -{-# INLINE concatChunks #-} -concatChunks :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a -concatChunks = S.unfoldMany A.reader - -- | @readWith bufsize handle@ reads a byte stream from a file -- handle, reads are performed in chunks of up to @bufsize@. -- --- >>> readWith size h = Stream.unfoldMany Array.reader $ Handle.readChunksWith size h +-- >>> readWith size h = Stream.unfoldEach Array.reader $ Handle.readChunksWith size h -- -- /Pre-release/ {-# INLINE readWith #-} readWith :: MonadIO m => Int -> Handle -> Stream m Word8 -readWith size h = concatChunks $ readChunksWith size h +readWith size h = A.concat $ readChunksWith size h -- | Unfolds a file handle into a byte stream. IO requests to the device are -- performed in sizes of -- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. -- --- >>> reader = Unfold.many Array.reader chunkReader +-- >>> reader = Unfold.unfoldEach Array.reader Handle.chunkReader -- {-# INLINE reader #-} reader :: MonadIO m => Unfold m Handle Word8 -reader = UF.many A.reader chunkReader +reader = UF.unfoldEach A.reader chunkReader -- | Generate a byte stream from a file 'Handle'. -- --- >>> read h = Stream.unfoldMany Array.reader $ Handle.readChunks h +-- >>> read h = Stream.unfoldEach Array.reader $ Handle.readChunks h -- -- /Pre-release/ {-# INLINE read #-} read :: MonadIO m => Handle -> Stream m Word8 -read = concatChunks . readChunks +read = A.concat . readChunks ------------------------------------------------------------------------------- -- Writing @@ -384,15 +374,10 @@ -- | Write an 'Array' to a file handle. -- {-# INLINABLE putChunk #-} -putChunk :: MonadIO m => Handle -> Array a -> m () +putChunk :: forall m (a :: Type). MonadIO m => Handle -> Array a -> m () putChunk _ arr | byteLength arr == 0 = return () -putChunk h arr = A.asPtrUnsafe arr $ \ptr -> - liftIO $ hPutBuf h ptr aLen - - where - - -- XXX We should have the length passed by asPtrUnsafe itself. - aLen = A.byteLength arr +putChunk h arr = A.unsafePinnedAsPtr arr $ \ptr byteLen -> + liftIO $ hPutBuf h ptr byteLen ------------------------------------------------------------------------------- -- Stream of Arrays IO @@ -408,7 +393,8 @@ -- >>> putChunks h = Stream.fold (Fold.drainBy (Handle.putChunk h)) -- {-# INLINE putChunks #-} -putChunks :: MonadIO m => Handle -> Stream m (Array a) -> m () +putChunks :: forall m (a :: Type). MonadIO m => + Handle -> Stream m (Array a) -> m () putChunks h = S.fold (FL.drainMapM (putChunk h)) -- XXX AS.compact can be written idiomatically in terms of foldMany, just like @@ -423,17 +409,17 @@ {-# INLINE putChunksWith #-} putChunksWith :: (MonadIO m, Unbox a) => Int -> Handle -> Stream m (Array a) -> m () -putChunksWith n h xs = putChunks h $ AS.compact n xs +putChunksWith n h xs = putChunks h $ A.compactMax n xs +-- > putBytesWith n h m = Handle.putChunks h $ A.pinnedChunksOf n m + -- | @putBytesWith bufsize handle stream@ writes @stream@ to @handle@ -- in chunks of @bufsize@. A write is performed to the IO device as soon as we -- collect the required input size. -- --- >>> putBytesWith n h m = Handle.putChunks h $ Stream.chunksOf n m --- {-# INLINE putBytesWith #-} putBytesWith :: MonadIO m => Int -> Handle -> Stream m Word8 -> m () -putBytesWith n h m = putChunks h $ A.chunksOf n m +putBytesWith n h m = putChunks h $ A.chunksOf' n m -- | Write a byte stream to a file handle. Accumulates the input in chunks of -- up to 'Streamly.Internal.Data.Array.Type.defaultChunkSize' before writing. @@ -453,18 +439,16 @@ -- writeChunks h = Fold.drainBy (Handle.putChunk h) -- {-# INLINE writeChunks #-} -writeChunks :: MonadIO m => Handle -> Fold m (Array a) () +writeChunks :: forall m (a :: Type). MonadIO m => Handle -> Fold m (Array a) () writeChunks h = FL.drainMapM (putChunk h) -- | Like writeChunks but uses the experimental 'Refold' API. -- -- /Internal/ {-# INLINE chunkWriter #-} -chunkWriter :: MonadIO m => Refold m Handle (Array a) () +chunkWriter :: forall m (a :: Type). MonadIO m => Refold m Handle (Array a) () chunkWriter = Refold.drainBy putChunk --- XXX lpackArraysChunksOf should be written idiomatically - -- | @writeChunksWith bufsize handle@ writes a stream of arrays -- to @handle@ after coalescing the adjacent arrays in chunks of @bufsize@. -- We never split an array, if a single array is bigger than the specified size @@ -474,7 +458,10 @@ {-# INLINE writeChunksWith #-} writeChunksWith :: (MonadIO m, Unbox a) => Int -> Handle -> Fold m (Array a) () -writeChunksWith n h = lpackArraysChunksOf n (writeChunks h) +-- writeChunksWith n h = A.lCompactGE n (writeChunks h) +writeChunksWith n h = + FL.postscanl (A.scanCompactMin n) + $ FL.catMaybes (writeChunks h) -- | Same as 'writeChunksWith' -- @@ -492,17 +479,17 @@ -- do not want buffering to occur at GHC level as well. Same thing applies to -- writes as well. --- XXX Maybe we should have a Fold.chunksOf like we have Stream.chunksOf +-- XXX Maybe we should have a Fold.chunksOf like we have Array.chunksOf -- | @writeWith reqSize handle@ writes the input stream to @handle@. -- Bytes in the input stream are collected into a buffer until we have a chunk -- of @reqSize@ and then written to the IO device. -- --- >>> writeWith n h = Fold.groupsOf n (Array.writeNUnsafe n) (Handle.writeChunks h) +-- >>> writeWith n h = Fold.groupsOf n (Array.unsafeCreateOf n) (Handle.writeChunks h) -- {-# INLINE writeWith #-} writeWith :: MonadIO m => Int -> Handle -> Fold m Word8 () -writeWith n h = FL.groupsOf n (writeNUnsafe n) (writeChunks h) +writeWith n h = FL.groupsOf n (A.unsafeCreateOf' n) (writeChunks h) -- | Same as 'writeWith' -- @@ -520,7 +507,7 @@ writeMaybesWith :: (MonadIO m ) => Int -> Handle -> Fold m (Maybe Word8) () writeMaybesWith n h = - let writeNJusts = FL.lmap fromJust $ A.writeN n + let writeNJusts = FL.lmap fromJust $ A.createOf' n writeOnNothing = FL.takeEndBy_ isNothing writeNJusts in FL.many writeOnNothing (writeChunks h) @@ -530,7 +517,7 @@ {-# INLINE writerWith #-} writerWith :: MonadIO m => Int -> Refold m Handle Word8 () writerWith n = - FL.refoldMany (FL.take n $ writeNUnsafe n) chunkWriter + FL.refoldMany (FL.take n $ A.unsafeCreateOf' n) chunkWriter -- | Write a byte stream to a file handle. Accumulates the input in chunks of -- up to 'Streamly.Internal.Data.Array.Type.defaultChunkSize' before writing diff --git a/src/Streamly/Internal/FileSystem/Path.hs b/src/Streamly/Internal/FileSystem/Path.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Path.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.FileSystem.Path +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- == References +-- +-- * https://en.wikipedia.org/wiki/Path_(computing) +-- * https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file +-- * https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-dtyp/62e862f4-2a51-452e-8eeb-dc4ff5ee33cc +-- +-- == Windows and Posix Paths +-- +-- We should be able to manipulate windows paths on posix and posix paths on +-- windows as well. Therefore, we have WindowsPath and PosixPath types which +-- are supported on both platforms. However, the Path module aliases Path to +-- WindowsPath on Windows and PosixPath on Posix. +-- +-- == File System as Tree vs Graph +-- +-- A file system is a tree when there are no hard links or symbolic links. But +-- in the presence of symlinks it could be a DAG or a graph, because directory +-- symlinks can create cycles. +-- +-- == Rooted and Branch paths +-- +-- We make two distinctions for paths, a path may a specific filesystem root +-- attached to it or it may be a free branch without a root attached. +-- +-- A path that has a root attached to it is called a rooted path e.g. /usr is a +-- rooted path, . is a rooted path, ./bin is a rooted path. A rooted path could +-- be absolute e.g. /usr or it could be relative e.g. ./bin . A rooted path +-- always has two components, a specific "root" which could be explicit or +-- implicit, and a path segment relative to the root. A rooted path with a +-- fixed root is known as an absolute path whereas a rooted path with an +-- implicit root e.g. "./bin" is known as a relative path. +-- +-- A path that does not have a root attached but defines steps to go from some +-- place to another is a path branch. For example, "local/bin" is a path branch +-- whereas "./local/bin" is a rooted path. +-- +-- Rooted paths can never be appended to any other path whereas a branch can be +-- appended. +-- +-- == Comparing Paths +-- +-- We can compare two absolute rooted paths or path branches but we cannot +-- compare two relative rooted paths. If each component of the path is the same +-- then the paths are considered to be equal. +-- +-- == Implicit Roots (.) +-- +-- On Posix and Windows "." implicitly refers to the current directory. On +-- Windows a path like @/Users/@ has the drive reference implicit. Such +-- references are contextual and may have different meanings at different +-- times. +-- +-- @./bin@ may refer to a different location depending on what "." is +-- referring to. Thus we should not allow @./bin@ to be appended to another +-- path, @bin@ can be appended though. Similarly, we cannot compare @./bin@ +-- with @./bin@ and say that they are equal because they may be referring to +-- different locations depending on in what context the paths were created. +-- +-- The same arguments apply to paths with implicit drive on Windows. +-- +-- We can treat @.\/bin\/ls@ as an absolute path with "." as an implicit root. +-- The relative path is "bin/ls" which represents steps from somewhere to +-- somewhere else rather than a particular location. We can also call @./bin@ +-- as a "rooted path" as it starts from particular location rather than +-- defining "steps" to go from one place to another. If we want to append such +-- paths we need to first make them explicitly relative by dropping the +-- implicit root. Or we can use unsafeAppend to force it anyway or unsafeCast +-- to convert absolute to relative. +-- +-- On these absolute (Rooted) paths if we use takeRoot, it should return +-- RootCurDir, RootCurDrive and @Root Path@ to distinguish @./@, @/@, @C:/@. We +-- could represent them by different types but that would make the types even +-- more complicated. So runtime checks are are a good balance. +-- +-- Path comparison should return EqTrue, EqFalse or EqUnknown. If we compare +-- these absolute/located paths having implicit roots then result should be +-- EqUnknown or maybe we can just return False?. @./bin@ and @./bin@ should be +-- treated as paths with different roots/drives but same relative path. The +-- programmer can explicitly drop the root and compare the relative paths if +-- they want to check literal equality. +-- +-- Note that a trailing . or a . in the middle of a path is different as it +-- refers to a known name. +-- +-- == Ambiguous References (..) +-- +-- ".." in a path refers to the parent directory relative to the current path. +-- For an absolute root directory ".." refers to the root itself because you +-- cannot go further up. +-- +-- When resolving ".." it always resolves to the parent of a directory as +-- stored in the directory entry. So if we landed in a directory via a symlink, +-- ".." can take us back to a different directory and not to the symlink +-- itself. Thus @a\/b/..@ may not be the same as @a/@. Shells like bash keep +-- track of the old paths explicitly, so you may not see this behavior when +-- using a shell. +-- +-- For this reason we cannot process ".." in the path statically. However, if +-- the components of two paths are exactly the same then they will always +-- resolve to the same target. But two paths with different components could +-- also point to the same target. So if there are ".." in the path we cannot +-- definitively say if they are the same without resolving them. +-- +-- == Exception Handling +-- +-- Path creation routines use MonadThrow which can be interpreted as an Either +-- type. It is rare to actually handle exceptions in path creation functions, +-- we would rather fix the issue, so partial functions should also be fine. But +-- there may be some cases where we are parsing paths from external inputs, +-- reading from a file etc where we may want to handle exceptions. We can +-- always create partial wrappers from these if that is convenient to use. +-- + +#define IS_PORTABLE + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +#define IS_WINDOWS +#include "Streamly/Internal/FileSystem/WindowsPath.hs" +#else +#include "Streamly/Internal/FileSystem/PosixPath.hs" +#endif diff --git a/src/Streamly/Internal/FileSystem/Path/Common.hs b/src/Streamly/Internal/FileSystem/Path/Common.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Path/Common.hs @@ -0,0 +1,1564 @@ +{-# LANGUAGE UnliftedFFITypes #-} +-- | +-- Module : Streamly.Internal.FileSystem.Path.Common +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +module Streamly.Internal.FileSystem.Path.Common + ( + -- * Types + OS (..) + + -- * Validation + , validatePath + , validatePath' + , validateFile + + -- * Construction + , fromArray + , unsafeFromArray + , fromChars + , unsafeFromChars + + -- * Quasiquoters + , mkQ + + -- * Elimination + , toString + , toChars + + -- * Separators + , primarySeparator + , isSeparator + , isSeparatorWord + , dropTrailingSeparators + , dropTrailingBy + , hasTrailingSeparator + , hasLeadingSeparator + + -- * Tests + , isBranch + , isRooted + , isAbsolute + -- , isRelative -- not isAbsolute + , isRootRelative -- XXX hasRelativeRoot + , isRelativeWithDrive -- XXX hasRelativeDriveRoot + , hasDrive + + -- * Joining + , append + , append' + , unsafeAppend + , appendCString + , appendCString' + , unsafeJoinPaths + -- , joinRoot -- XXX append should be enough + + -- * Splitting + + -- Note: splitting the search path does not belong here, it is shell aware + -- operation. search path is separated by : and : is allowed in paths on + -- posix. Shell would escape it which needs to be handled. + + , splitRoot + -- , dropRoot + -- , dropRelRoot -- if relative then dropRoot + , splitHead + , splitTail + , splitPath + , splitPath_ + + -- * Dir and File + , splitFile + , splitDir + + -- * Extensions + , extensionWord + , splitExtension + , splitExtensionBy + -- , addExtension + + -- * Equality + -- , processParentRefs + , normalizeSeparators + -- , normalize -- separators and /./ components (split/combine) + , eqPathBytes + , EqCfg(..) + , eqPath + -- , commonPrefix -- common prefix of two paths + -- , eqPrefix -- common prefix is equal to first path + -- , dropPrefix + + -- * Utilities + , wordToChar + , charToWord + , unsafeIndexChar + + -- * Internal + , unsafeSplitTopLevel + , unsafeSplitDrive + , unsafeSplitUNC + , splitCompact + , splitWithFilter + ) +where + +#include "assert.hs" + +import Control.Monad (when) +import Control.Monad.Catch (MonadThrow(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Char (chr, ord, isAlpha, toUpper) +import Data.Function ((&)) +import Data.Functor.Identity (Identity(..)) +import Data.Word (Word8, Word16) +import Foreign (castPtr) +import Foreign.C (CString, CSize(..)) +import GHC.Base (unsafeChr, Addr#) +import GHC.Ptr (Ptr(..)) +import Language.Haskell.TH (Q, Exp) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Streamly.Internal.Data.Array (Array(..)) +import Streamly.Internal.Data.MutArray (MutArray) +import Streamly.Internal.Data.MutByteArray (Unbox(..)) +import Streamly.Internal.Data.Path (PathException(..)) +import Streamly.Internal.Data.Stream (Stream) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.List as List +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.MutArray as MutArray +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Unicode.Stream as Unicode + +{- $setup +>>> :m + +>>> import Data.Functor.Identity (runIdentity) +>>> import System.IO.Unsafe (unsafePerformIO) +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Unicode.Stream as Unicode +>>> import qualified Streamly.Internal.Data.Array as Array +>>> import qualified Streamly.Internal.FileSystem.Path.Common as Common +>>> import qualified Streamly.Internal.Unicode.Stream as Unicode +>>> import Streamly.Internal.FileSystem.Path (ignoreTrailingSeparators, allowRelativeEquality, ignoreCase) + +>>> packPosix = unsafePerformIO . Stream.fold Array.create . Unicode.encodeUtf8' . Stream.fromList +>>> unpackPosix = runIdentity . Stream.toList . Unicode.decodeUtf8' . Array.read + +>>> packWindows = unsafePerformIO . Stream.fold Array.create . Unicode.encodeUtf16le' . Stream.fromList +>>> unpackWindows = runIdentity . Stream.toList . Unicode.decodeUtf16le' . Array.read +-} + +data OS = Windows | Posix deriving Eq + +------------------------------------------------------------------------------ +-- Parsing Operations +------------------------------------------------------------------------------ + +-- XXX We can use Enum type class to include the Char type as well so that the +-- functions can work on Array Word8/Word16/Char but that may be slow. + +-- XXX Windows is supported only on little endian machines so generally we do +-- not need covnersion from LE to BE format unless we want to manipulate +-- windows paths on big-endian machines. + +-- | Unsafe, may tructate to shorter word types, can only be used safely for +-- characters that fit in the given word size. +charToWord :: Integral a => Char -> a +charToWord c = + let n = ord c + in assert (n <= 255) (fromIntegral n) + +-- | Unsafe, should be a valid character. +wordToChar :: Integral a => a -> Char +wordToChar = unsafeChr . fromIntegral + +------------------------------------------------------------------------------ +-- Array utils +------------------------------------------------------------------------------ + +-- | Index a word in an array and convert it to Char. +unsafeIndexChar :: (Unbox a, Integral a) => Int -> Array a -> Char +unsafeIndexChar i a = wordToChar (Array.unsafeGetIndex i a) + +-- XXX put this in array module, we can have Array.fold and Array.foldM +foldArr :: Unbox a => Fold.Fold Identity a b -> Array a -> b +foldArr f arr = runIdentity $ Array.foldM f arr + +{-# INLINE countLeadingBy #-} +countLeadingBy :: Unbox a => (a -> Bool) -> Array a -> Int +countLeadingBy p = foldArr (Fold.takeEndBy_ (not . p) Fold.length) + +countTrailingBy :: Unbox a => (a -> Bool) -> Array a -> Int +countTrailingBy p = Array.foldRev (Fold.takeEndBy_ (not . p) Fold.length) + +------------------------------------------------------------------------------ +-- Separator parsing +------------------------------------------------------------------------------ + +extensionWord :: Integral a => a +extensionWord = charToWord '.' + +posixSeparator :: Char +posixSeparator = '/' + +windowsSeparator :: Char +windowsSeparator = '\\' + +-- | Primary path separator character, @/@ on Posix and @\\@ on Windows. +-- Windows supports @/@ too as a separator. Please use 'isSeparator' for +-- testing if a char is a separator char. +{-# INLINE primarySeparator #-} +primarySeparator :: OS -> Char +primarySeparator Posix = posixSeparator +primarySeparator Windows = windowsSeparator + +-- | On Posix only @/@ is a path separator but in windows it could be either +-- @/@ or @\\@. +{-# INLINE isSeparator #-} +isSeparator :: OS -> Char -> Bool +isSeparator Posix c = c == posixSeparator +isSeparator Windows c = (c == windowsSeparator) || (c == posixSeparator) + +{-# INLINE isSeparatorWord #-} +isSeparatorWord :: Integral a => OS -> a -> Bool +isSeparatorWord os = isSeparator os . wordToChar + +------------------------------------------------------------------------------ +-- Separator normalization +------------------------------------------------------------------------------ + +-- | If the path is @//@ the result is @/@. If it is @a//@ then the result is +-- @a@. On Windows "c:" and "c:/" are different paths, therefore, we do not +-- drop the trailing separator from "c:/" or for that matter a separator +-- preceded by a ':'. +-- +-- Can't use any arbitrary predicate "p", the logic in this depends on assuming +-- that it is a path separator. +{-# INLINE dropTrailingBy #-} +dropTrailingBy :: (Unbox a, Integral a) => + OS -> (a -> Bool) -> Array a -> Array a +dropTrailingBy os p arr = + let len = Array.length arr + n = countTrailingBy p arr + arr1 = fst $ Array.unsafeBreakAt (len - n) arr + in if n == 0 + then arr + else if n == len -- "////" + then + -- Even though "//" is not allowed as a valid path. + -- We still handle that case in this low level function. + if os == Windows + && n >= 2 + && Array.unsafeGetIndex 0 arr == Array.unsafeGetIndex 1 arr + then fst $ Array.unsafeBreakAt 2 arr -- make it "//" share name + else fst $ Array.unsafeBreakAt 1 arr + -- "c:////" - keep one "/" after colon in ".*:///" otherwise it will + -- change the meaning. "c:/" may also appear, in the middle e.g. + -- in UNC paths. + else if (os == Windows) + && (Array.unsafeGetIndex (len - n - 1) arr == charToWord ':') + then fst $ Array.unsafeBreakAt (len - n + 1) arr + else arr1 + +-- XXX we cannot compact "//" to "/" on windows +{-# INLINE compactTrailingBy #-} +compactTrailingBy :: Unbox a => (a -> Bool) -> Array a -> Array a +compactTrailingBy p arr = + let len = Array.length arr + n = countTrailingBy p arr + in if n <= 1 + then arr + else fst $ Array.unsafeBreakAt (len - n + 1) arr + +{-# INLINE dropTrailingSeparators #-} +dropTrailingSeparators :: (Unbox a, Integral a) => OS -> Array a -> Array a +dropTrailingSeparators os = + dropTrailingBy os (isSeparator os . wordToChar) + +-- | A path starting with a separator. +hasLeadingSeparator :: (Unbox a, Integral a) => OS -> Array a -> Bool +hasLeadingSeparator os a + | Array.null a = False -- empty path should not occur + | isSeparatorWord os (Array.unsafeGetIndex 0 a) = True + | otherwise = False + +{-# INLINE hasTrailingSeparator #-} +hasTrailingSeparator :: (Integral a, Unbox a) => OS -> Array a -> Bool +hasTrailingSeparator os path = + let e = Array.getIndexRev 0 path + in case e of + Nothing -> False + Just x -> isSeparatorWord os x + +{-# INLINE toDefaultSeparator #-} +toDefaultSeparator :: Integral a => a -> a +toDefaultSeparator x = + if isSeparatorWord Windows x + then charToWord (primarySeparator Windows) + else x + +-- | Change all separators in the path to default separator on windows. +{-# INLINE normalizeSeparators #-} +normalizeSeparators :: (Integral a, Unbox a) => Array a -> Array a +normalizeSeparators a = + -- XXX We can check and return the original array if no change is needed. + Array.fromPureStreamN (Array.length a) + $ fmap toDefaultSeparator + $ Array.read a + +------------------------------------------------------------------------------ +-- Windows drive parsing +------------------------------------------------------------------------------ + +-- | @C:...@, does not check array length. +{-# INLINE unsafeHasDrive #-} +unsafeHasDrive :: (Unbox a, Integral a) => Array a -> Bool +unsafeHasDrive a + -- Check colon first for quicker return + | unsafeIndexChar 1 a /= ':' = False + -- XXX If we found a colon anyway this cannot be a valid path unless it has + -- a drive prefix. colon is not a valid path character. + -- XXX check isAlpha perf + | not (isAlpha (unsafeIndexChar 0 a)) = False + | otherwise = True + +-- | A path that starts with a alphabet followed by a colon e.g. @C:...@. +hasDrive :: (Unbox a, Integral a) => Array a -> Bool +hasDrive a = Array.length a >= 2 && unsafeHasDrive a + +-- | A path that contains only an alphabet followed by a colon e.g. @C:@. +isDrive :: (Unbox a, Integral a) => Array a -> Bool +isDrive a = Array.length a == 2 && unsafeHasDrive a + +------------------------------------------------------------------------------ +-- Relative or Absolute +------------------------------------------------------------------------------ + +-- | A path relative to cur dir it is either @.@ or starts with @./@. +isRelativeCurDir :: (Unbox a, Integral a) => OS -> Array a -> Bool +isRelativeCurDir os a + | len == 0 = False -- empty path should not occur + | wordToChar (Array.unsafeGetIndex 0 a) /= '.' = False + | len < 2 = True + | otherwise = isSeparatorWord os (Array.unsafeGetIndex 1 a) + + where + + len = Array.length a + +-- | A non-UNC path starting with a separator. +-- Note that "\\/share/x" is treated as "C:/share/x". +isRelativeCurDriveRoot :: (Unbox a, Integral a) => Array a -> Bool +isRelativeCurDriveRoot a + | len == 0 = False -- empty path should not occur + | len == 1 && sep0 = True + | sep0 && c0 /= c1 = True -- "\\/share/x" is treated as "C:/share/x". + | otherwise = False + + where + + len = Array.length a + c0 = Array.unsafeGetIndex 0 a + c1 = Array.unsafeGetIndex 1 a + sep0 = isSeparatorWord Windows c0 + +-- | @C:@ or @C:a...@. +isRelativeWithDrive :: (Unbox a, Integral a) => Array a -> Bool +isRelativeWithDrive a = + hasDrive a + && ( Array.length a < 3 + || not (isSeparator Windows (unsafeIndexChar 2 a)) + ) + +isRootRelative :: (Unbox a, Integral a) => OS -> Array a -> Bool +isRootRelative Posix a = isRelativeCurDir Posix a +isRootRelative Windows a = + isRelativeCurDir Windows a + || isRelativeCurDriveRoot a + || isRelativeWithDrive a + +-- | @C:\...@. Note that "C:" or "C:a" is not absolute. +isAbsoluteWithDrive :: (Unbox a, Integral a) => Array a -> Bool +isAbsoluteWithDrive a = + Array.length a >= 3 + && unsafeHasDrive a + && isSeparator Windows (unsafeIndexChar 2 a) + +-- | @\\\\...@ or @//...@ +isAbsoluteUNC :: (Unbox a, Integral a) => Array a -> Bool +isAbsoluteUNC a + | Array.length a < 2 = False + | isSeparatorWord Windows c0 && c0 == c1 = True + | otherwise = False + + where + + c0 = Array.unsafeGetIndex 0 a + c1 = Array.unsafeGetIndex 1 a + +-- XXX rename to isRootAbsolute + +-- | Note that on Windows a path starting with a separator is relative to +-- current drive while on Posix this is absolute path as there is only one +-- drive. +isAbsolute :: (Unbox a, Integral a) => OS -> Array a -> Bool +isAbsolute Posix arr = + hasLeadingSeparator Posix arr +isAbsolute Windows arr = + isAbsoluteWithDrive arr || isAbsoluteUNC arr + +------------------------------------------------------------------------------ +-- Location or Segment +------------------------------------------------------------------------------ + +-- XXX API for static processing of .. (normalizeParentRefs) +-- +-- Note: paths starting with . or .. are ambiguous and can be considered +-- segments or rooted. We consider a path starting with "." as rooted, when +-- someone uses "./x" they explicitly mean x in the current directory whereas +-- just "x" can be taken to mean a path segment without any specific root. +-- However, in typed paths the programmer can convey the meaning whether they +-- mean it as a segment or a rooted path. So even "./x" can potentially be used +-- as a segment which can just mean "x". +-- +-- XXX For the untyped Path we can allow appending "./x" to other paths. We can +-- leave this to the programmer. In typed paths we can allow "./x" in segments. +-- XXX Empty path can be taken to mean "." except in case of UNC paths + +isRooted :: (Unbox a, Integral a) => OS -> Array a -> Bool +isRooted Posix a = + hasLeadingSeparator Posix a + || isRelativeCurDir Posix a +isRooted Windows a = + hasLeadingSeparator Windows a + || isRelativeCurDir Windows a + || hasDrive a -- curdir-in-drive relative, drive absolute + +isBranch :: (Unbox a, Integral a) => OS -> Array a -> Bool +isBranch os = not . isRooted os + +------------------------------------------------------------------------------ +-- Split root +------------------------------------------------------------------------------ + +unsafeSplitPrefix :: (Unbox a, Integral a) => + OS -> Int -> Array a -> (Array a, Array a) +unsafeSplitPrefix os prefixLen arr = + Array.unsafeBreakAt cnt arr + + where + + afterDrive = snd $ Array.unsafeBreakAt prefixLen arr + n = countLeadingBy (isSeparatorWord os) afterDrive + cnt = prefixLen + n + +-- Note: We can have normalized splitting functions to normalize as we split +-- for efficiency. But then we will have to allocate new arrays instead of +-- slicing which can make it inefficient. + +-- | Split a path prefixed with a separator into (drive, path) tuple. +-- +-- >>> toListPosix (a,b) = (unpackPosix a, unpackPosix b) +-- >>> splitPosix = toListPosix . Common.unsafeSplitTopLevel Common.Posix . packPosix +-- +-- >>> toListWin (a,b) = (unpackWindows a, unpackWindows b) +-- >>> splitWin = toListWin . Common.unsafeSplitTopLevel Common.Windows . packWindows +-- +-- >>> splitPosix "/" +-- ("/","") +-- +-- >>> splitPosix "//" +-- ("//","") +-- +-- >>> splitPosix "/home" +-- ("/","home") +-- +-- >>> splitPosix "/home/user" +-- ("/","home/user") +-- +-- >>> splitWin "\\" +-- ("\\","") +-- +-- >>> splitWin "\\home" +-- ("\\","home") +unsafeSplitTopLevel :: (Unbox a, Integral a) => + OS -> Array a -> (Array a, Array a) +-- Note on Windows we should be here only when the path starts with exactly one +-- separator, otherwise it would be UNC path. But on posix multiple separators +-- are valid. +unsafeSplitTopLevel os = unsafeSplitPrefix os 1 + +-- In some cases there is no valid drive component e.g. "\\a\\b", though if we +-- consider relative roots then we could use "\\" as the root in this case. In +-- other cases there is no valid path component e.g. "C:" or "\\share\\" though +-- the latter is not a valid path and in the former case we can use "." as the +-- path component. + +-- | Split a path prefixed with drive into (drive, path) tuple. +-- +-- >>> toList (a,b) = (unpackPosix a, unpackPosix b) +-- >>> split = toList . Common.unsafeSplitDrive . packPosix +-- +-- >>> split "C:" +-- ("C:","") +-- +-- >>> split "C:a" +-- ("C:","a") +-- +-- >>> split "C:\\" +-- ("C:\\","") +-- +-- >>> split "C:\\\\" -- this is invalid path +-- ("C:\\\\","") +-- +-- >>> split "C:\\\\a" -- this is invalid path +-- ("C:\\\\","a") +-- +-- >>> split "C:\\/a/b" -- is this valid path? +-- ("C:\\/","a/b") +unsafeSplitDrive :: (Unbox a, Integral a) => Array a -> (Array a, Array a) +unsafeSplitDrive = unsafeSplitPrefix Windows 2 + +-- | Skip separators and then parse the next path segment. +-- Return (segment offset, segment length). +parseSegment :: (Unbox a, Integral a) => Array a -> Int -> (Int, Int) +parseSegment arr sepOff = (segOff, segCnt) + + where + + arr1 = snd $ Array.unsafeBreakAt sepOff arr + sepCnt = countLeadingBy (isSeparatorWord Windows) arr1 + segOff = sepOff + sepCnt + + arr2 = snd $ Array.unsafeBreakAt segOff arr + segCnt = countLeadingBy (not . isSeparatorWord Windows) arr2 + +-- XXX We can split a path as "root, . , rest" or "root, /, rest". +-- XXX We can remove the redundant path separator after the root. With that +-- joining root vs other paths will become similar. But there are some special +-- cases e.g. (1) "C:a" does not have a separator, can we make this "C:.\\a"? +-- (2) In case of "/home" we have "/" as root - while joining root and path we +-- should not add another separator between root and path - thus joining root +-- and path in this case is anyway special. + +-- | Split a path prefixed with "\\" into (drive, path) tuple. +-- +-- >>> toList (a,b) = (unpackPosix a, unpackPosix b) +-- >>> split = toList . Common.unsafeSplitUNC . packPosix +-- +-- >> split "" +-- ("","") +-- +-- >>> split "\\\\" +-- ("\\\\","") +-- +-- >>> split "\\\\server" +-- ("\\\\server","") +-- +-- >>> split "\\\\server\\" +-- ("\\\\server\\","") +-- +-- >>> split "\\\\server\\home" +-- ("\\\\server\\","home") +-- +-- >>> split "\\\\?\\c:" +-- ("\\\\?\\c:","") +-- +-- >>> split "\\\\?\\c:/" +-- ("\\\\?\\c:/","") +-- +-- >>> split "\\\\?\\c:\\home" +-- ("\\\\?\\c:\\","home") +-- +-- >>> split "\\\\?\\UNC/" +-- ("\\\\?\\UNC/","") +-- +-- >>> split "\\\\?\\UNC\\server" +-- ("\\\\?\\UNC\\server","") +-- +-- >>> split "\\\\?\\UNC/server\\home" +-- ("\\\\?\\UNC/server\\","home") +-- +unsafeSplitUNC :: (Unbox a, Integral a) => Array a -> (Array a, Array a) +unsafeSplitUNC arr = + if cnt1 == 1 && unsafeIndexChar 2 arr == '?' + then do + if uncLen == 3 + && unsafeIndexChar uncOff arr == 'U' + && unsafeIndexChar (uncOff + 1) arr == 'N' + && unsafeIndexChar (uncOff + 2) arr == 'C' + then unsafeSplitPrefix Windows (serverOff + serverLen) arr + else unsafeSplitPrefix Windows sepOff1 arr + else unsafeSplitPrefix Windows sepOff arr + + where + + arr1 = snd $ Array.unsafeBreakAt 2 arr + cnt1 = countLeadingBy (not . isSeparatorWord Windows) arr1 + sepOff = 2 + cnt1 + + -- XXX there should be only one separator in a valid path? + -- XXX it should either be UNC or two letter drive in a valid path + (uncOff, uncLen) = parseSegment arr sepOff + sepOff1 = uncOff + uncLen + (serverOff, serverLen) = parseSegment arr sepOff1 + +-- XXX should we make the root Maybe? Both components will have to be Maybe to +-- avoid an empty path. +-- XXX Should we keep the trailing separator in the directory components? + +{-# INLINE splitRoot #-} +splitRoot :: (Unbox a, Integral a) => OS -> Array a -> (Array a, Array a) +-- NOTE: validatePath depends on splitRoot splitting the path without removing +-- any redundant chars etc. It should just split and do nothing else. +-- XXX We can put an assert here "arrLen == rootLen + stemLen". +-- XXX assert (isValidPath path == isValidPath root) +-- +-- NOTE: we cannot drop the trailing "/" on the root even if we want to - +-- because "c:/" will become "c:" and the two are not equivalent. +splitRoot Posix arr + | isRooted Posix arr + = unsafeSplitTopLevel Posix arr + | otherwise = (Array.empty, arr) +splitRoot Windows arr + | isRelativeCurDriveRoot arr || isRelativeCurDir Windows arr + = unsafeSplitTopLevel Windows arr + | hasDrive arr = unsafeSplitDrive arr + | isAbsoluteUNC arr = unsafeSplitUNC arr + | otherwise = (Array.empty, arr) + +------------------------------------------------------------------------------ +-- Split path +------------------------------------------------------------------------------ + +-- | Raw split an array on path separartor word using a filter to filter out +-- some splits. +{-# INLINE splitWithFilter #-} +splitWithFilter + :: (Unbox a, Integral a, Monad m) + => ((Int, Int) -> Bool) + -> Bool + -> OS + -> Array a + -> Stream m (Array a) +splitWithFilter filt withSep os arr = + f (isSeparatorWord os) (Array.read arr) + & Stream.filter filt + & fmap (\(i, len) -> Array.unsafeSliceOffLen i len arr) + + where + + f = if withSep then Stream.indexEndBy else Stream.indexEndBy_ + +-- | Split a path on separator chars and compact contiguous separators and +-- remove /./ components. Note this does not treat the path root in a special +-- way. +{-# INLINE splitCompact #-} +splitCompact + :: (Unbox a, Integral a, Monad m) + => Bool + -> OS + -> Array a + -> Stream m (Array a) +splitCompact withSep os arr = + splitWithFilter (not . shouldFilterOut) withSep os arr + + where + + sepFilter (off, len) = + ( len == 1 + && isSeparator os (unsafeIndexChar off arr) + ) + || + -- Note, last component may have len == 2 but second char may not + -- be slash, so we need to check for slash explicitly. + -- + ( len == 2 + && unsafeIndexChar off arr == '.' + && isSeparator os (unsafeIndexChar (off + 1) arr) + ) + + {-# INLINE shouldFilterOut #-} + shouldFilterOut (off, len) = + len == 0 + -- Note this is needed even when withSep is true - for the last + -- component case. + || (len == 1 && unsafeIndexChar off arr == '.') + -- XXX Ensure that these are statically removed by GHC when withSep + -- is False. + || (withSep && sepFilter (off, len)) + +-- Split a path into its components. +-- +-- Usage: +-- @ +-- splitPathUsing withSep ignoreLeading os arr +-- @ +-- +-- if withSep == True then keep the trailing separators. +-- +-- if ignoreLeading == True we drop all leading separators and relative paths. +-- Example behaviour (psuedo-code): +-- @ +-- > f = splitPathUsing (withSep = False) (ignoreLeading = True) +-- > f "./a/b/c" == ["a","b","c"] +-- > f "./a/./b/c" == ["a","b","c"] +-- > f "/a/./b/c" == ["a","b","c"] +-- > f "/./a/./b/c" == ["a","b","c"] +-- > f "././a/./b/c" == ["a","b","c"] +-- > f "a/./b/c" == ["a","b","c"] +-- @ +-- +-- We can safely set @ignoreLeading = True@ if we splitRoot prior and only pass +-- the stem of the path to this function. +{-# INLINE splitPathUsing #-} +splitPathUsing + :: (Unbox a, Integral a, Monad m) + => Bool + -> Bool + -> OS + -> Array a + -> Stream m (Array a) +splitPathUsing withSep ignoreLeading os arr = + let stream = splitCompact withSep os rest + in if ignoreLeading || Array.null root + then stream + else Stream.cons root1 stream + + where + + -- We should not filter out a leading '.' on Posix or Windows. + -- We should not filter out a '.' in the middle of a UNC root on windows. + -- Therefore, we split the root and treat it in a special way. + (root, rest) = splitRoot os arr + root1 = + if withSep + then compactTrailingBy (isSeparator os . wordToChar) root + else dropTrailingSeparators os root + +{-# INLINE splitPath_ #-} +splitPath_ + :: (Unbox a, Integral a, Monad m) + => OS -> Array a -> Stream m (Array a) +splitPath_ = splitPathUsing False False + +{-# INLINE splitPath #-} +splitPath + :: (Unbox a, Integral a, Monad m) + => OS -> Array a -> Stream m (Array a) +splitPath = splitPathUsing True False + +-- | Split the first non-empty path component. +-- +-- /Unimplemented/ +{-# INLINE splitHead #-} +splitHead :: -- (Unbox a, Integral a) => + OS -> Array a -> (Array a, Maybe (Array a)) +splitHead _os _arr = undefined + +-- | Split the last non-empty path component. +-- +-- /Unimplemented/ +{-# INLINE splitTail #-} +splitTail :: -- (Unbox a, Integral a) => + OS -> Array a -> (Maybe (Array a), Array a) +splitTail _os _arr = undefined + +------------------------------------------------------------------------------ +-- File or Dir +------------------------------------------------------------------------------ + +-- | Returns () if the path can be a valid file, otherwise throws an +-- exception. +validateFile :: (MonadThrow m, Unbox a, Integral a) => OS -> Array a -> m () +validateFile os arr = do + s1 <- + Stream.toList + $ Stream.take 3 + $ Stream.takeWhile (not . isSeparator os) + $ fmap wordToChar + $ Array.readRev arr + -- XXX On posix we just need to check last 3 bytes of the array + -- XXX Display the path in the exception messages. + case s1 of + [] -> throwM $ InvalidPath "A file name cannot have a trailing separator" + '.' : xs -> + case xs of + [] -> throwM $ InvalidPath "A file name cannot have a trailing \".\"" + '.' : [] -> + throwM $ InvalidPath "A file name cannot have a trailing \"..\"" + _ -> pure () + _ -> pure () + + case os of + Windows -> + -- XXX We can exclude a UNC root as well but just the UNC root is + -- not even a valid path. + when (isDrive arr) + $ throwM $ InvalidPath "A drive root is not a valid file name" + Posix -> pure () + +{-# INLINE splitFile #-} +splitFile :: (Unbox a, Integral a) => + OS -> Array a -> Maybe (Maybe (Array a), Array a) +splitFile os arr = + let p x = + if os == Windows + then x == charToWord ':' || isSeparatorWord os x + else isSeparatorWord os x + -- XXX Use Array.revBreakEndBy? + fileLen = runIdentity + $ Stream.fold (Fold.takeEndBy_ p Fold.length) + $ Array.readRev arr + arrLen = Array.length arr + baseLen = arrLen - fileLen + (base, file) = Array.unsafeBreakAt baseLen arr + fileFirst = Array.unsafeGetIndex 0 file + fileSecond = Array.unsafeGetIndex 1 file + in + if fileLen > 0 + -- exclude the file == '.' case + && not (fileLen == 1 && fileFirst == charToWord '.') + -- exclude the file == '..' case + && not (fileLen == 2 + && fileFirst == charToWord '.' + && fileSecond == charToWord '.') + then + if baseLen <= 0 + then Just (Nothing, arr) + else Just (Just $ Array.unsafeSliceOffLen 0 baseLen base, file) -- "/" + else Nothing + +-- | Split a multi-component path into (dir, last component). If the path has a +-- single component and it is a root then return (path, "") otherwise return +-- ("", path). +-- +-- Split a single component into (dir, "") if it can be a dir i.e. it is either +-- a path root, "." or ".." or has a trailing separator. +-- +-- The only difference between splitFile and splitDir: +-- +-- >> splitFile "a/b/" +-- ("a/b/", "") +-- >> splitDir "a/b/" +-- ("a/", "b/") +-- +-- This is equivalent to splitPath and keeping the last component but is usually +-- faster. +-- +-- >>> toList (a,b) = (unpackPosix a, unpackPosix b) +-- >>> splitPosix = toList . Common.splitDir Common.Posix . packPosix +-- +-- >> splitPosix "/" +-- ("/","") +-- +-- >> splitPosix "." +-- (".","") +-- +-- >> splitPosix "/." +-- ("/.","") +-- +-- >> splitPosix "/x" +-- ("/","x") +-- +-- >> splitPosix "/x/" +-- ("/","x/") +-- +-- >> splitPosix "//" +-- ("//","") +-- +-- >> splitPosix "./x" +-- ("./","x") +-- +-- >> splitPosix "x" +-- ("","x") +-- +-- >> splitPosix "x/" +-- ("x/","") +-- +-- >> splitPosix "x/y" +-- ("x/","y") +-- +-- >> splitPosix "x/y/" +-- ("x/","y/") +-- +-- >> splitPosix "x/y//" +-- ("x/","y//") +-- +-- >> splitPosix "x//y" +-- ("x//","y") +-- +-- >> splitPosix "x/./y" +-- ("x/./","y") +-- +-- /Unimplemented/ +{-# INLINE splitDir #-} +splitDir :: -- (Unbox a, Integral a) => + OS -> Array a -> (Array a, Array a) +splitDir _os _arr = undefined + +------------------------------------------------------------------------------ +-- Split extensions +------------------------------------------------------------------------------ + +-- | Like split extension but we can specify the extension char to be used. +{-# INLINE splitExtensionBy #-} +splitExtensionBy :: (Unbox a, Integral a) => + a -> OS -> Array a -> Maybe (Array a, Array a) +splitExtensionBy c os arr = + let p x = x == c || isSeparatorWord os x + -- XXX Use Array.revBreakEndBy_ + extLen = runIdentity + $ Stream.fold (Fold.takeEndBy p Fold.length) + $ Array.readRev arr + arrLen = Array.length arr + baseLen = arrLen - extLen + -- XXX We can use reverse split operation on the array + res@(base, ext) = Array.unsafeBreakAt baseLen arr + baseLast = Array.unsafeGetIndexRev 0 base + extFirst = Array.unsafeGetIndex 0 ext + in + -- For an extension to be present the path must be at least 3 chars. + -- non-empty base followed by extension char followed by non-empty + -- extension. + if arrLen > 2 + -- If ext is empty, then there is no extension and we should not + -- strip an extension char if any at the end of base. + && extLen > 1 + && extFirst == c + -- baseLast is always either base name char or '/' unless empty + -- if baseLen is 0 then we have not found an extension. + && baseLen > 0 + -- If baseLast is '/' then base name is empty which means it is a + -- dot file and there is no extension. + && not (isSeparatorWord os baseLast) + -- On Windows if base is 'c:.' or a UNC path ending in '/c:.' then + -- it is a dot file, no extension. + && not (os == Windows && baseLast == charToWord ':') + then Just res + else Nothing + +{-# INLINE splitExtension #-} +splitExtension :: (Unbox a, Integral a) => OS -> Array a -> Maybe (Array a, Array a) +splitExtension = splitExtensionBy extensionWord + +{- +-- Instead of this keep calling splitExtension until there is no more extension +-- returned. +{-# INLINE splitAllExtensionsBy #-} +splitAllExtensionsBy :: (Unbox a, Integral a) => + Bool -> a -> OS -> Array a -> (Array a, Array a) +-- If the isFileName arg is true, it means that the path supplied does not have +-- any separator chars, so we can do it more efficiently. +splitAllExtensionsBy isFileName extChar os arr = + let file = + if isFileName + then arr + else snd $ splitFile os arr + fileLen = Array.length file + arrLen = Array.length arr + baseLen = foldArr (Fold.takeEndBy_ (== extChar) Fold.length) file + extLen = fileLen - baseLen + in + -- XXX unsafeBreakAt itself should use Array.empty in case of no split + if fileLen > 0 && extLen > 1 && extLen /= fileLen + then (Array.unsafeBreakAt (arrLen - extLen) arr) + else (arr, Array.empty) + +-- | +-- +-- TODO: This function needs to be consistent with splitExtension. It should +-- strip all valid extensions by that definition. +-- +-- splitAllExtensions "x/y.tar.gz" gives ("x/y", ".tar.gz") +-- +-- >>> toList (a,b) = (unpackPosix a, unpackPosix b) +-- >>> splitPosix = toList . Common.splitAllExtensions Common.Posix . packPosix +-- +-- >>> toListWin (a,b) = (unpackWindows a, unpackWindows b) +-- >>> splitWin = toListWin . Common.splitAllExtensions Common.Windows . packWindows +-- +-- >>> splitPosix "/" +-- ("/","") +-- +-- >>> splitPosix "." +-- (".","") +-- +-- >>> splitPosix "x" +-- ("x","") +-- +-- >>> splitPosix "/x" +-- ("/x","") +-- +-- >>> splitPosix "x/" +-- ("x/","") +-- +-- >>> splitPosix "./x" +-- ("./x","") +-- +-- >>> splitPosix "x/." +-- ("x/.","") +-- +-- >>> splitPosix "x/y." +-- ("x/y.","") +-- +-- >>> splitPosix "/x.y" +-- ("/x",".y") +-- +-- >>> splitPosix "x/.y" +-- ("x/.y","") +-- +-- >>> splitPosix ".x" +-- (".x","") +-- +-- >>> splitPosix "x." +-- ("x.","") +-- +-- >>> splitPosix ".x.y" +-- (".x",".y") +-- +-- >>> splitPosix "x/y.z" +-- ("x/y",".z") +-- +-- >>> splitPosix "x.y.z" +-- ("x",".y.z") +-- +-- >>> splitPosix "x..y" -- ?? +-- ("x.",".y") +-- +-- >>> splitPosix ".." +-- ("..","") +-- +-- >>> splitPosix "..." +-- ("...","") +-- +-- >>> splitPosix "...x" +-- ("...x","") +-- +-- >>> splitPosix "x/y.z/" +-- ("x/y.z/","") +-- +-- >>> splitPosix "x/y" +-- ("x/y","") +-- +-- >>> splitWin "x:y" +-- ("x:y","") +-- +-- >>> splitWin "x:.y" +-- ("x:.y","") +-- +{-# INLINE splitAllExtensions #-} +splitAllExtensions :: (Unbox a, Integral a) => + OS -> Array a -> (Array a, Array a) +splitAllExtensions = splitAllExtensionsBy False extensionWord +-} + +------------------------------------------------------------------------------ +-- Construction +------------------------------------------------------------------------------ + +{-# INLINE isInvalidPathChar #-} +isInvalidPathChar :: Integral a => OS -> a -> Bool +isInvalidPathChar Posix x = x == 0 +isInvalidPathChar Windows x = + -- case should be faster than list search + case x of + 34 -> True -- '"' + 42 -> True -- '*' + 58 -> True -- ':' + 60 -> True -- '<' + 62 -> True -- '>' + 63 -> True -- '?' + 124 -> True -- '|' + _ -> x <= charToWord '\US' + +countLeadingValid :: (Unbox a, Integral a) => OS -> Array a -> Int +countLeadingValid os path = + let f = Fold.takeEndBy_ (isInvalidPathChar os) Fold.length + in foldArr f path + +-- XXX Supply it an array for checking and use a more efficient prefix matching +-- check. + +-- | Only for windows. +isInvalidPathComponent :: Integral a => [[a]] +isInvalidPathComponent = fmap (fmap charToWord) + [ "CON","PRN","AUX","NUL","CLOCK$" + , "COM1","COM2","COM3","COM4","COM5","COM6","COM7","COM8","COM9" + , "LPT1","LPT2","LPT3","LPT4","LPT5","LPT6","LPT7","LPT8","LPT9" + ] + +{- HLINT ignore "Use when" -} +validatePathWith :: (MonadThrow m, Integral a, Unbox a) => + Bool -> OS -> Array a -> m () +validatePathWith _ Posix path = + let pathLen = Array.length path + validLen = countLeadingValid Posix path + in if pathLen == 0 + then throwM $ InvalidPath "Empty path" + else if pathLen /= validLen + then throwM $ InvalidPath + $ "Null char found after " ++ show validLen ++ " characters." + else pure () +validatePathWith allowRoot Windows path + | Array.null path = throwM $ InvalidPath "Empty path" + | otherwise = do + if hasDrive path && postDriveSep > 1 -- "C://" + then throwM $ InvalidPath + "More than one separators between drive root and the path" + else if isAbsoluteUNC path + then + if postDriveSep > 1 -- "///x" + then throwM $ InvalidPath + "Path starts with more than two separators" + else if invalidRootComponent -- "//prn/x" + then throwM $ InvalidPath + -- XXX print the invalid component name + "Special filename component found in share root" + else if rootEndSeps /= 1 -- "//share//x" + then throwM $ InvalidPath + $ "Share name is needed and exactly one separator is needed " + ++ "after the share root" + else if not allowRoot && Array.null stem -- "//share/" + then throwM $ InvalidPath + "the share root must be followed by a non-empty path" + else pure () + else pure () + + if stemLen /= validStemLen -- "x/x>y" + then throwM $ InvalidPath + $ "Disallowed char found after " + ++ show (rootLen + validStemLen) + ++ " characters. The invalid char is: " + ++ show (chr (fromIntegral invalidVal)) + ++ " [" ++ show invalidVal ++ "]" + else if invalidComponent -- "x/prn/y" + -- XXX print the invalid component name + then throwM $ InvalidPath "Disallowed Windows filename in path" + else pure () + + where + + postDrive = snd $ Array.unsafeBreakAt 2 path + postDriveSep = countLeadingBy (isSeparatorWord Windows) postDrive + + -- XXX check invalid chars in the path root as well - except . and '?'? + (root, stem) = splitRoot Windows path + rootLen = Array.length root + stemLen = Array.length stem + validStemLen = countLeadingValid Windows stem + invalidVal = fromIntegral (Array.unsafeGetIndex validStemLen stem) :: Word16 + + rootEndSeps = countTrailingBy (isSeparatorWord Windows) root + + -- TBD: We are not currently validating the sharenames against disallowed + -- file names. Apparently windows does not allow even sharenames with those + -- names. To match against sharenames we will have to strip the separators + -- and drive etc from the root. Or we can use the parsing routines + -- themselves to validate. + toUp w16 = + if w16 < 256 + then charToWord $ toUpper (wordToChar w16) + else w16 + + -- Should we strip all space chars as in Data.Char.isSpace? + isSpace x = x == charToWord ' ' + + -- XXX instead of using a list based check, pass the array to the checker. + -- We do not need to upcase the array, it can be done in the checker. Thus + -- we do not need to create a new array, the original slice can be checked. + getBaseName x = + runIdentity + $ Stream.toList + $ fmap toUp + $ Array.read + $ Array.dropAround isSpace + $ fst $ Array.breakEndBy_ (== extensionWord) x + + components = + runIdentity + . Stream.toList + . fmap getBaseName + . splitCompact False Windows + + invalidRootComponent = + List.any (`List.elem` isInvalidPathComponent) (components root) + invalidComponent = + List.any (`List.elem` isInvalidPathComponent) (components stem) + +-- | A valid root, share root or a valid path. +{-# INLINE validatePath #-} +validatePath :: (MonadThrow m, Integral a, Unbox a) => OS -> Array a -> m () +validatePath = validatePathWith True + +{-# INLINE validatePath' #-} +validatePath' :: (MonadThrow m, Integral a, Unbox a) => OS -> Array a -> m () +validatePath' = validatePathWith False + +{-# INLINE unsafeFromArray #-} +unsafeFromArray :: Array a -> Array a +unsafeFromArray = id + +{-# INLINE fromArray #-} +fromArray :: forall m a. (MonadThrow m, Unbox a, Integral a) => + OS -> Array a -> m (Array a) +fromArray os arr = validatePath os arr >> pure arr +{- + let arr1 = Array.unsafeCast arr :: Array a + in validatePath os arr1 >> pure arr1 +fromArray Windows arr = + case Array.cast arr of + Nothing -> + throwM + $ InvalidPath + $ "Encoded path length " ++ show (Array.byteLength arr) + ++ " is not a multiple of 16-bit." + Just x -> validatePath Windows x >> pure x +-} + +{-# INLINE unsafeFromChars #-} +unsafeFromChars :: (Unbox a) => + (Stream Identity Char -> Stream Identity a) + -> Stream Identity Char + -> Array a +unsafeFromChars encode s = + -- The encoded array may be longer than the char count. We are encoding it + -- twice, but it may still be cheaper than reallocating the array or + -- oversizing the array. + let n = runIdentity $ Stream.fold Fold.length (encode s) + in Array.fromPureStreamN n (encode s) + +-- XXX Writing a custom fold for parsing a Posix path may be better for +-- efficient bulk parsing when needed. We need the same code to validate a +-- Chunk where we do not need to create an array. +{-# INLINE fromChars #-} +fromChars :: (MonadThrow m, Unbox a, Integral a) => + OS + -> (Stream Identity Char -> Stream Identity a) + -> Stream Identity Char + -> m (Array a) +fromChars os encode s = + let arr = unsafeFromChars encode s + in fromArray os (Array.unsafeCast arr) + +{-# INLINE toChars #-} +toChars :: (Monad m, Unbox a) => + (Stream m a -> Stream m Char) -> Array a -> Stream m Char +toChars decode arr = decode $ Array.read arr + +{-# INLINE toString #-} +toString :: Unbox a => + (Stream Identity a -> Stream Identity Char) -> Array a -> [Char] +toString decode = runIdentity . Stream.toList . toChars decode + +------------------------------------------------------------------------------ +-- Statically Verified Literals +------------------------------------------------------------------------------ + +-- XXX pass the quote name for errors? +mkQ :: (String -> Q Exp) -> QuasiQuoter +mkQ f = + QuasiQuoter + { quoteExp = f + , quotePat = err "pattern" + , quoteType = err "type" + , quoteDec = err "declaration" + } + + where + + err x _ = fail $ "QuasiQuote used as a " ++ x + ++ ", can be used only as an expression" + +------------------------------------------------------------------------------ +-- Operations of Path +------------------------------------------------------------------------------ + +-- See also cstringLength# in GHC.CString in ghc-prim +foreign import ccall unsafe "string.h strlen" c_strlen_pinned + :: Addr# -> IO CSize + +{-# INLINE appendCStringWith #-} +appendCStringWith :: + (Int -> IO (MutArray Word8)) + -> OS + -> Array Word8 + -> CString + -> IO (Array Word8) +appendCStringWith create os a b@(Ptr addrB#) = do + let lenA = Array.length a + lenB <- fmap fromIntegral $ c_strlen_pinned addrB# + assertM(lenA /= 0 && lenB /= 0) + let len = lenA + 1 + lenB + arr <- create len + arr1 <- MutArray.unsafeSplice arr (Array.unsafeThaw a) + arr2 <- MutArray.unsafeSnoc arr1 (charToWord (primarySeparator os)) + arr3 :: MutArray.MutArray Word8 <- + MutArray.unsafeAppendPtrN arr2 (castPtr b) lenB + return (Array.unsafeFreeze arr3) + +{-# INLINE appendCString #-} +appendCString :: OS -> Array Word8 -> CString -> IO (Array Word8) +appendCString = appendCStringWith MutArray.emptyOf + +{-# INLINE appendCString' #-} +appendCString' :: OS -> Array Word8 -> CString -> IO (Array Word8) +appendCString' = appendCStringWith MutArray.emptyOf' + +{-# INLINE doAppend #-} +doAppend :: (Unbox a, Integral a) => OS -> Array a -> Array a -> Array a +doAppend os a b = unsafePerformIO $ do + let lenA = Array.length a + lenB = Array.length b + assertM(lenA /= 0 && lenB /= 0) + let lastA = Array.unsafeGetIndexRev 0 a + sepA = isSeparatorWord os lastA + sepB = isSeparatorWord os (Array.unsafeGetIndex 0 b) + let len = lenA + 1 + lenB + arr <- MutArray.emptyOf len + arr1 <- MutArray.unsafeSplice arr (Array.unsafeThaw a) + arr2 <- + if lenA /= 0 + && lenB /= 0 + && not sepA + && not sepB + && not (os == Windows && lastA == charToWord ':') + then MutArray.unsafeSnoc arr1 (charToWord (primarySeparator os)) + else pure arr1 + -- Note: if the last char on the first array is ":" and first char on the + -- second array is "/" then we cannot drop the "/". We drop only if both + -- are separators excluding ":". + let arrB = + if sepA && sepB + then snd $ Array.unsafeBreakAt 1 b + else b + arr3 <- MutArray.unsafeSplice arr2 (Array.unsafeThaw arrB) + return (Array.unsafeFreeze arr3) + +{-# INLINE withAppendCheck #-} +withAppendCheck :: (Unbox b, Integral b) => + OS -> (Array b -> String) -> Array b -> a -> a +withAppendCheck os toStr arr f = + if isRooted os arr + then error $ "append: cannot append a rooted path " ++ toStr arr + else f + +{-# INLINE unsafeAppend #-} +unsafeAppend :: (Unbox a, Integral a) => + OS -> (Array a -> String) -> Array a -> Array a -> Array a +unsafeAppend os _toStr = doAppend os + +{-# INLINE append #-} +append :: (Unbox a, Integral a) => + OS -> (Array a -> String) -> Array a -> Array a -> Array a +append os toStr a b = withAppendCheck os toStr b (doAppend os a b) + +{-# INLINE append' #-} +append' :: (Unbox a, Integral a) => + OS -> (Array a -> String) -> Array a -> Array a -> Array a +append' os toStr a b = + let hasSep = countTrailingBy (isSeparatorWord os) a > 0 + hasColon = + os == Windows + && Array.getIndexRev 0 a == Just (charToWord ':') + in if hasSep || hasColon + then withAppendCheck os toStr b (doAppend os a b) + else error + $ "append': first path must be dir like i.e. must have a " + ++ "trailing separator or colon on windows: " ++ toStr a + +-- XXX MonadIO? + +-- | Join paths by path separator. Does not check if the paths being appended +-- are rooted or path segments. Note that splitting and joining may not give +-- exactly the original path but an equivalent, normalized path. +{-# INLINE unsafeJoinPaths #-} +unsafeJoinPaths + :: (Unbox a, Integral a, MonadIO m) + => OS -> Stream m (Array a) -> m (Array a) +unsafeJoinPaths os = + -- XXX This can be implemented more efficiently using an Array intersperse + -- operation. Which can be implemented by directly copying arrays rather + -- than converting them to stream first. Also fromStreamN would be more + -- efficient if we have to use streams. + -- XXX We can remove leading and trailing separators first, if any, except + -- the leading separator from the first path. But it is not necessary. + -- Instead we can avoid adding a separator if it is already present. + Array.fromStream . Array.concatSepBy (charToWord $ primarySeparator os) + +------------------------------------------------------------------------------ +-- Equality +------------------------------------------------------------------------------ + +eqPathBytes :: Array a -> Array a -> Bool +eqPathBytes = Array.byteEq + +-- On posix macOs can have case insensitive comparison. On Windows also +-- case sensitive behavior may depend on the file system being used. + +-- Use eq prefix? + +-- | Options for path comparison operation. By default path comparison uses a +-- strict criteria for equality. The following options are provided to +-- control the strictness. +-- +-- The default configuration is as follows: +-- +-- >>> :{ +-- defaultMod = ignoreTrailingSeparators False +-- . ignoreCase False +-- . allowRelativeEquality False +-- :} +-- +data EqCfg = + EqCfg + { _ignoreTrailingSeparators :: Bool -- ^ Allows "x\/" == "x" + , _ignoreCase :: Bool -- ^ Allows "x" == \"X\" + , _allowRelativeEquality :: Bool + -- ^ A leading dot is ignored, thus ".\/x" == ".\/x" and ".\/x" == "x". + -- On Windows allows "\/x" == \/x" and "C:x == C:x" + + -- , resolveParentReferences -- "x\/..\/y" == "y" + -- , noIgnoreRedundantSeparators -- "x\/\/y" \/= "x\/y" + -- , noIgnoreRedundantDot -- "x\/.\/" \/= "x" + } + +data PosixRoot = PosixRootAbs | PosixRootRel deriving Eq + +data WindowsRoot = + WindowsRootPosix -- /x or ./x + | WindowsRootNonPosix -- C:... or \\... + deriving Eq + +-- | Change to upper case and replace separators by primary separator +{-# INLINE normalizeCaseAndSeparators #-} +normalizeCaseAndSeparators :: Monad m => Array Word16 -> Stream m Char +normalizeCaseAndSeparators = + fmap toUpper + . Unicode.decodeUtf16le' + . fmap toDefaultSeparator + . Array.read + +{-# INLINE normalizeCaseWith #-} +normalizeCaseWith :: (Monad m, Unbox a) => + (Stream m a -> Stream m Char) -> Array a -> Stream m Char +normalizeCaseWith decoder = + fmap toUpper + . decoder + . Array.read + +eqWindowsRootStrict :: (Unbox a, Integral a) => + Bool -> Array a -> Array a -> Bool +eqWindowsRootStrict ignCase a b = + let f = normalizeCaseAndSeparators + in if ignCase + then + -- XXX We probably do not want to equate UNC with UnC etc. + runIdentity + $ Stream.eqBy (==) + (f $ Array.unsafeCast a) (f $ Array.unsafeCast b) + else + runIdentity + $ Stream.eqBy (==) + (fmap toDefaultSeparator $ Array.read a) + (fmap toDefaultSeparator $ Array.read b) + +{-# INLINE eqRootStrict #-} +eqRootStrict :: (Unbox a, Integral a) => + Bool -> OS -> Array a -> Array a -> Bool +eqRootStrict _ Posix a b = + -- a can be "/" and b can be "//" + -- We call this only when the roots are either absolute or null. + Array.null a == Array.null b +eqRootStrict ignCase Windows a b = eqWindowsRootStrict ignCase a b + +-- | Compare Posix roots or Windows roots without a drive or share name. +{-# INLINE eqPosixRootLax #-} +eqPosixRootLax :: (Unbox a, Integral a) => Array a -> Array a -> Bool +eqPosixRootLax a b = getRoot a == getRoot b + + where + + -- Can only be either "", '.', './' or '/' (or Windows separators) + getRoot arr = + if Array.null arr || unsafeIndexChar 0 arr == '.' + then PosixRootRel + else PosixRootAbs + +{-# INLINABLE eqRootLax #-} +eqRootLax :: (Unbox a, Integral a) => Bool -> OS -> Array a -> Array a -> Bool +eqRootLax _ Posix a b = eqPosixRootLax a b +eqRootLax ignCase Windows a b = + let aType = getRootType a + bType = getRootType b + in aType == bType + && ( + (aType == WindowsRootPosix && eqPosixRootLax a b) + || eqWindowsRootStrict ignCase a b + ) + + where + + getRootType arr = + if isAbsoluteUNC arr || hasDrive arr + then WindowsRootNonPosix + else WindowsRootPosix + +{-# INLINE eqComponentsWith #-} +eqComponentsWith :: (Unbox a, Integral a) => + EqCfg + -> (Stream Identity a -> Stream Identity Char) + -> OS + -> Array a + -> Array a + -> Bool +eqComponentsWith EqCfg{..} decoder os a b = + if _ignoreCase + then + let streamEq x y = runIdentity $ Stream.eqBy (==) x y + toComponents = fmap (normalizeCaseWith decoder) . splitter os + -- XXX check perf/fusion + in runIdentity + $ Stream.eqBy streamEq (toComponents a) (toComponents b) + else + runIdentity + $ Stream.eqBy + Array.byteEq (splitter os a) (splitter os b) + where + splitter = splitPathUsing False _allowRelativeEquality + +-- XXX can we do something like SpecConstr for such functions e.g. without +-- inlining the function we can use two copies one for _allowRelativeEquality +-- True and other for False and so on for other values of PathEq. + +{-# INLINE eqPath #-} +eqPath :: (Unbox a, Integral a) => + (Stream Identity a -> Stream Identity Char) + -> OS -> EqCfg -> Array a -> Array a -> Bool +eqPath decoder os eqCfg@(EqCfg{..}) a b = + let (rootA, stemA) = splitRoot os a + (rootB, stemB) = splitRoot os b + + eqRelative = + if _allowRelativeEquality + then eqRootLax _ignoreCase os rootA rootB + else (not (isRootRelative os rootA) + && not (isRootRelative os rootB)) + && eqRootStrict _ignoreCase os rootA rootB + + -- XXX If one ends in a "." and the other ends in ./ (and same for ".." + -- and "../") then they can be equal. We can append a slash in these two + -- cases before comparing. + eqTrailingSep = + _ignoreTrailingSeparators + || hasTrailingSeparator os a == hasTrailingSeparator os b + + in + eqRelative + && eqTrailingSep + && eqComponentsWith eqCfg decoder os stemA stemB diff --git a/src/Streamly/Internal/FileSystem/Path/Node.hs b/src/Streamly/Internal/FileSystem/Path/Node.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Path/Node.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Streamly.Internal.FileSystem.Path.Node +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +#define OS_PATH WindowsPath +#else +#define OS_PATH PosixPath +#endif + +module Streamly.Internal.FileSystem.Path.Node + ( + module Streamly.Internal.FileSystem.OS_PATH.Node + ) +where + +import Streamly.Internal.FileSystem.OS_PATH.Node diff --git a/src/Streamly/Internal/FileSystem/Path/Seg.hs b/src/Streamly/Internal/FileSystem/Path/Seg.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Path/Seg.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Streamly.Internal.FileSystem.Path.Seg +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +#define OS_PATH WindowsPath +#else +#define OS_PATH PosixPath +#endif + +module Streamly.Internal.FileSystem.Path.Seg + ( + module Streamly.Internal.FileSystem.OS_PATH.Seg + ) +where + +import Streamly.Internal.FileSystem.OS_PATH.Seg diff --git a/src/Streamly/Internal/FileSystem/Path/SegNode.hs b/src/Streamly/Internal/FileSystem/Path/SegNode.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Path/SegNode.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Streamly.Internal.FileSystem.Path.SegNode +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +#define OS_PATH WindowsPath +#else +#define OS_PATH PosixPath +#endif + +module Streamly.Internal.FileSystem.Path.SegNode + ( + module Streamly.Internal.FileSystem.OS_PATH.SegNode + ) +where + +import Streamly.Internal.FileSystem.OS_PATH.SegNode diff --git a/src/Streamly/Internal/FileSystem/Posix/Errno.hs b/src/Streamly/Internal/FileSystem/Posix/Errno.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Posix/Errno.hs @@ -0,0 +1,60 @@ +-- | +-- Module : Streamly.Internal.FileSystem.Posix.Errno +-- Copyright : (c) 2024 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC + +module Streamly.Internal.FileSystem.Posix.Errno + ( +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + throwErrnoPath + , throwErrnoPathIfRetry + , throwErrnoPathIfNullRetry + , throwErrnoPathIfMinus1Retry +#endif + ) +where + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import Foreign (Ptr, nullPtr) +import Foreign.C (getErrno, eINTR) +import Foreign.C.Error (errnoToIOError) +import Streamly.Internal.FileSystem.PosixPath (PosixPath(..)) + +import qualified Streamly.Internal.FileSystem.PosixPath as Path + +------------------------------------------------------------------------------- +-- From unix +------------------------------------------------------------------------------- + +-- | Same as 'throwErrno', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPath :: String -> PosixPath -> IO a +throwErrnoPath loc path = + do + errno <- getErrno + -- XXX toString uses strict decoding, may fail + ioError (errnoToIOError loc errno Nothing (Just (Path.toString path))) + +throwErrnoPathIfRetry :: (a -> Bool) -> String -> PosixPath -> IO a -> IO a +throwErrnoPathIfRetry pr loc rpath f = + do + res <- f + if pr res + then do + err <- getErrno + if err == eINTR + then throwErrnoPathIfRetry pr loc rpath f + else throwErrnoPath loc rpath + else return res + +throwErrnoPathIfNullRetry :: String -> PosixPath -> IO (Ptr a) -> IO (Ptr a) +throwErrnoPathIfNullRetry = throwErrnoPathIfRetry (== nullPtr) + +throwErrnoPathIfMinus1Retry :: (Eq a, Num a) => + String -> PosixPath -> IO a -> IO a +throwErrnoPathIfMinus1Retry = throwErrnoPathIfRetry (== -1) +#endif diff --git a/src/Streamly/Internal/FileSystem/Posix/File.hsc b/src/Streamly/Internal/FileSystem/Posix/File.hsc new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Posix/File.hsc @@ -0,0 +1,316 @@ +module Streamly.Internal.FileSystem.Posix.File + ( +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + + -- * File open flags + OpenFlags (..) + , defaultOpenFlags + + -- * File status flags + , setAppend + , setNonBlock + , setSync + + -- * File creation flags + , setCloExec + , setDirectory + , setExcl + , setNoCtty + , setNoFollow + -- setTmpFile + , setTrunc + + -- * File create mode + , defaultCreateMode + + -- ** User Permissions + , setUr + , setUw + , setUx + + , clrUr + , clrUw + , clrUx + + -- ** Group Permissions + , setGr + , setGw + , setGx + + , clrGr + , clrGw + , clrGx + + -- ** Other Permissions + , setOr + , setOw + , setOx + + , clrOr + , clrOw + , clrOx + + -- ** Status bits + , setSuid + , setSgid + , setSticky + + , clrSuid + , clrSgid + , clrSticky + + -- * Fd based Low Level + , openAt + , close + + -- * Handle based + , openFile + , withFile + , openBinaryFile + , withBinaryFile + + -- Re-exported + , Fd +#endif + ) where + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Data.Bits ((.|.), (.&.), complement) +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt(..)) +import GHC.IO.Handle.FD (fdToHandle) +import Streamly.Internal.FileSystem.Posix.Errno (throwErrnoPathIfMinus1Retry) +import Streamly.Internal.FileSystem.PosixPath (PosixPath) +import System.IO (IOMode(..), Handle) +import System.Posix.Types (Fd(..), CMode(..)) + +import qualified Streamly.Internal.FileSystem.File.Common as File +import qualified Streamly.Internal.FileSystem.PosixPath as Path + +-- We want to remain close to the Posix C API. A function based API to set and +-- clear the modes is simple, type safe and directly mirrors the C API. It does +-- not require explicit mapping from Haskell ADT to C types, we can dirctly +-- manipulate the C type. + +#include + +------------------------------------------------------------------------------- +-- Create mode +------------------------------------------------------------------------------- + +-- | Open flags, see posix open system call man page. +newtype FileMode = FileMode CMode + +##define MK_MODE_API(name1,name2,x) \ +{-# INLINE name1 #-}; \ +name1 :: FileMode -> FileMode; \ +name1 (FileMode mode) = FileMode (x .|. mode); \ +{-# INLINE name2 #-}; \ +name2 :: FileMode -> FileMode; \ +name2 (FileMode mode) = FileMode (x .&. complement mode) + +{- +#define S_ISUID 0004000 +#define S_ISGID 0002000 +#define S_ISVTX 0001000 + +#define S_IRWXU 00700 +#define S_IRUSR 00400 +#define S_IWUSR 00200 +#define S_IXUSR 00100 + +#define S_IRWXG 00070 +#define S_IRGRP 00040 +#define S_IWGRP 00020 +#define S_IXGRP 00010 + +#define S_IRWXO 00007 +#define S_IROTH 00004 +#define S_IWOTH 00002 +#define S_IXOTH 00001 + +#define AT_FDCWD (-100) +-} + +MK_MODE_API(setSuid,clrSuid,S_ISUID) +MK_MODE_API(setSgid,clrSgid,S_ISGID) +MK_MODE_API(setSticky,clrSticky,S_ISVTX) + +-- MK_MODE_API(setUrwx,clrUrwx,S_IRWXU) +MK_MODE_API(setUr,clrUr,S_IRUSR) +MK_MODE_API(setUw,clrUw,S_IWUSR) +MK_MODE_API(setUx,clrUx,S_IXUSR) + +-- MK_MODE_API(setGrwx,clrGrwx,S_IRWXU) +MK_MODE_API(setGr,clrGr,S_IRUSR) +MK_MODE_API(setGw,clrGw,S_IWUSR) +MK_MODE_API(setGx,clrGx,S_IXUSR) + +-- MK_MODE_API(setOrwx,clrOrwx,S_IRWXU) +MK_MODE_API(setOr,clrOr,S_IRUSR) +MK_MODE_API(setOw,clrOw,S_IWUSR) +MK_MODE_API(setOx,clrOx,S_IXUSR) + +-- Uses the same default mode as openFileWith in base +defaultCreateMode :: FileMode +defaultCreateMode = FileMode 0o666 + +------------------------------------------------------------------------------- +-- Open Flags +------------------------------------------------------------------------------- + +-- | Open flags, see posix open system call man page. +newtype OpenFlags = OpenFlags CInt + +##define MK_FLAG_API(name,x) \ +{-# INLINE name #-}; \ +name :: OpenFlags -> OpenFlags; \ +name (OpenFlags flags) = OpenFlags (flags .|. x) + +-- foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt +-- These affect the first two bits in flags. +MK_FLAG_API(setReadOnly,#{const O_RDONLY}) +MK_FLAG_API(setWriteOnly,#{const O_WRONLY}) +MK_FLAG_API(setReadWrite,#{const O_RDWR}) + +##define MK_BOOL_FLAG_API(name,x) \ +{-# INLINE name #-}; \ +name :: Bool -> OpenFlags -> OpenFlags; \ +name True (OpenFlags flags) = OpenFlags (flags .|. x); \ +name False (OpenFlags flags) = OpenFlags (flags .&. complement x) + +-- setCreat is internal only, do not export this. This is automatically set +-- when create mode is passed, otherwise cleared. +MK_BOOL_FLAG_API(setCreat,#{const O_CREAT}) + +MK_BOOL_FLAG_API(setExcl,#{const O_EXCL}) +MK_BOOL_FLAG_API(setNoCtty,#{const O_NOCTTY}) +MK_BOOL_FLAG_API(setTrunc,#{const O_TRUNC}) +MK_BOOL_FLAG_API(setAppend,#{const O_APPEND}) +MK_BOOL_FLAG_API(setNonBlock,#{const O_NONBLOCK}) +MK_BOOL_FLAG_API(setDirectory,#{const O_DIRECTORY}) +MK_BOOL_FLAG_API(setNoFollow,#{const O_NOFOLLOW}) +MK_BOOL_FLAG_API(setCloExec,#{const O_CLOEXEC}) +MK_BOOL_FLAG_API(setSync,#{const O_SYNC}) + +-- | Default values for the 'OpenFlags'. +-- +-- By default a 0 value is used, no flag is set. See the open system call man +-- page. +defaultOpenFlags :: OpenFlags +defaultOpenFlags = OpenFlags 0 + +------------------------------------------------------------------------------- +-- Low level (fd returning) file opening APIs +------------------------------------------------------------------------------- + +-- XXX Should we use interruptible open as in base openFile? +foreign import capi unsafe "fcntl.h openat" + c_openat :: CInt -> CString -> CInt -> CMode -> IO CInt + +-- | Open and optionally create (when create mode is specified) a file relative +-- to an optional directory file descriptor. If directory fd is not specified +-- then opens relative to the current directory. +-- {-# INLINE openAtCString #-} +openAtCString :: + Maybe Fd -- ^ Optional directory file descriptor + -> CString -- ^ Pathname to open + -> OpenFlags -- ^ Append, exclusive, etc. + -> Maybe FileMode -- ^ Create mode + -> IO Fd +openAtCString fdMay path flags cmode = + Fd <$> c_openat c_fd path flags1 mode + + where + + c_fd = maybe (#{const AT_FDCWD}) (\ (Fd fd) -> fd) fdMay + FileMode mode = maybe defaultCreateMode id cmode + OpenFlags flags1 = maybe flags (\_ -> setCreat True flags) cmode + +-- | Open a file relative to an optional directory file descriptor. +-- +-- Note: In Haskell, using an fd directly for IO may be problematic as blocking +-- file system operations on the file might block the capability and GC for +-- "unsafe" calls. "safe" calls may be more expensive. Also, you may have to +-- synchronize concurrent access via multiple threads. +-- +{-# INLINE openAt #-} +openAt :: + Maybe Fd -- ^ Optional directory file descriptor + -> PosixPath -- ^ Pathname to open + -> OpenFlags -- ^ Append, exclusive, truncate, etc. + -> Maybe FileMode -- ^ Create mode + -> IO Fd +openAt fdMay path flags cmode = + Path.asCString path $ \cstr -> do + throwErrnoPathIfMinus1Retry "openAt" path + $ openAtCString fdMay cstr flags cmode + + +-- | Open a regular file, return an Fd. +-- +-- Sets O_NOCTTY, O_NONBLOCK flags to be compatible with the base openFile +-- behavior. O_NOCTTY affects opening of terminal special files and O_NONBLOCK +-- affects fifo special files, and mandatory locking. +-- +openFileFdWith :: OpenFlags -> PosixPath -> IOMode -> IO Fd +openFileFdWith oflags path iomode = do + case iomode of + ReadMode -> open1 (setReadOnly oflags1) Nothing + WriteMode -> + open1 (setWriteOnly oflags1) (Just defaultCreateMode) + AppendMode -> + open1 + ((setAppend True . setWriteOnly) oflags1) + (Just defaultCreateMode) + ReadWriteMode -> + open1 (setReadWrite oflags) (Just defaultCreateMode) + + where + + oflags1 = setNoCtty True $ setNonBlock True oflags + open1 = openAt Nothing path + +openFileFd :: PosixPath -> IOMode -> IO Fd +openFileFd = openFileFdWith defaultOpenFlags + +foreign import ccall unsafe "unistd.h close" + c_close :: CInt -> IO CInt + +close :: Fd -> IO () +close (Fd fd) = throwErrnoIfMinus1_ ("close " ++ show fd) (c_close fd) + +------------------------------------------------------------------------------- +-- base openFile compatible, Handle returning, APIs +------------------------------------------------------------------------------- + +-- | Open a regular file, return a Handle. The file is locked, the Handle is +-- NOT set up to close the file on garbage collection. +{-# INLINE openFileHandle #-} +openFileHandle :: PosixPath -> IOMode -> IO Handle +openFileHandle p x = openFileFd p x >>= fdToHandle . fromIntegral + +-- | Like openFile in base package but using Path instead of FilePath. +-- Use hSetBinaryMode on the handle if you want to use binary mode. +openFile :: PosixPath -> IOMode -> IO Handle +openFile = File.openFile False openFileHandle + +-- | Like withFile in base package but using Path instead of FilePath. +-- Use hSetBinaryMode on the handle if you want to use binary mode. +withFile :: PosixPath -> IOMode -> (Handle -> IO r) -> IO r +withFile = File.withFile False openFileHandle + +-- | Like openBinaryFile in base package but using Path instead of FilePath. +openBinaryFile :: PosixPath -> IOMode -> IO Handle +openBinaryFile = File.openFile True openFileHandle + +-- | Like withBinaryFile in base package but using Path instead of FilePath. +withBinaryFile :: PosixPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile = File.withFile True openFileHandle +#endif diff --git a/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc b/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc @@ -0,0 +1,931 @@ +-- | +-- Module : Streamly.Internal.FileSystem.Posix.ReadDir +-- Copyright : (c) 2024 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC + +module Streamly.Internal.FileSystem.Posix.ReadDir + ( +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + readScanWith_ + , readScanWith + , readPlusScanWith + + , DirStream (..) + , openDirStream + , openDirStreamCString + , closeDirStream + , readDirStreamEither + , readEitherChunks + , readEitherByteChunks + , readEitherByteChunksAt + , eitherReader + , reader +#endif + ) +where + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import Control.Monad (unless) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Char (ord) +import Foreign + ( Ptr, Word8, nullPtr, peek, peekByteOff, castPtr, plusPtr, (.&.) + , allocaBytes + ) +import Foreign.C + ( resetErrno, throwErrno, throwErrnoIfMinus1Retry_, throwErrnoIfNullRetry + , Errno(..), getErrno, eINTR, eNOENT, eACCES, eLOOP + , CInt(..), CString, CChar, CSize(..) + ) +import Foreign.Storable (poke) +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Array (Array(..)) +import Streamly.Internal.Data.MutByteArray (MutByteArray) +import Streamly.Internal.Data.Scanl (Scanl) +import Streamly.Internal.Data.Stream (Stream(..), Step(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.FileSystem.Path (Path) +import Streamly.Internal.FileSystem.Posix.Errno (throwErrnoPathIfNullRetry) +import Streamly.Internal.FileSystem.Posix.File + (defaultOpenFlags, openAt, close) +import Streamly.Internal.FileSystem.PosixPath (PosixPath(..)) +import System.Posix.Types (Fd(..), CMode) + +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.MutByteArray as MutByteArray +import qualified Streamly.Internal.Data.Unfold as UF (bracketIO) +import qualified Streamly.Internal.FileSystem.Path.Common as PathC +import qualified Streamly.Internal.FileSystem.PosixPath as Path + +import Streamly.Internal.FileSystem.DirOptions + +#include +#include + +------------------------------------------------------------------------------- + +data {-# CTYPE "DIR" #-} CDir +data {-# CTYPE "struct dirent" #-} CDirent +data {-# CTYPE "struct stat" #-} CStat + +newtype DirStream = DirStream (Ptr CDir) + +-- | Minimal read without any metadata. +{-# INLINE readScanWith_ #-} +readScanWith_ :: -- (MonadIO m, MonadCatch m) => + Scanl m (Path, CString) a + -> (ReadOptions -> ReadOptions) + -> Path + -> Stream m a +readScanWith_ = undefined + +-- | Read with essential metadata. The scan takes the parent dir, the child +-- name, the child metadata and produces an output. The scan can do filtering, +-- formatting of the output, colorizing the output etc. +-- +-- The options are to ignore errors encountered when reading a path, turn the +-- errors into a nil stream instead. +{-# INLINE readScanWith #-} +readScanWith :: -- (MonadIO m, MonadCatch m) => + Scanl m (Path, CString, Ptr CDirent) a + -> (ReadOptions -> ReadOptions) + -> Path + -> Stream m a +readScanWith = undefined + +-- NOTE: See https://www.manpagez.com/man/2/getattrlistbulk/ for BSD/macOS. + +-- | Read with full metadata. +{-# INLINE readPlusScanWith #-} +readPlusScanWith :: -- (MonadIO m, MonadCatch m) => + Scanl m (Path, CString, Ptr CStat) a + -> (ReadOptions -> ReadOptions) + -> Path + -> Stream m a +readPlusScanWith = undefined + +------------------------------------------------------------------------------- +-- readdir operations +------------------------------------------------------------------------------- + +-- XXX Marking the calls "safe" has significant perf impact because it runs on +-- a separate OS thread. "unsafe" is faster but can block the GC if the system +-- call blocks. The effect could be signifcant if the file system is on NFS. Is +-- it possible to have a faster safe - where we know the function is safe but +-- we run it on the current thread, and if it blocks for longer we can snatch +-- the capability and enable GC? +-- +-- IMPORTANT NOTE: Use capi FFI for all readdir APIs. This is required at +-- least on macOS for correctness. We saw random directory entries when ccall +-- was used on macOS 15.3. Looks like it was picking the wrong version of +-- dirent structure. Did not see the problem in CIs on macOS 14.7.2 though. +foreign import capi unsafe "closedir" + c_closedir :: Ptr CDir -> IO CInt + +foreign import capi unsafe "dirent.h opendir" + c_opendir :: CString -> IO (Ptr CDir) + +foreign import capi unsafe "dirent.h fdopendir" + c_fdopendir :: CInt -> IO (Ptr CDir) + +-- XXX The "unix" package uses a wrapper over readdir __hscore_readdir (see +-- cbits/HsUnix.c in unix package) which uses readdir_r in some cases where +-- readdir is not known to be re-entrant. We are not doing that here. We are +-- assuming that readdir is re-entrant which may not be the case on some old +-- unix systems. +foreign import capi unsafe "dirent.h readdir" + c_readdir :: Ptr CDir -> IO (Ptr CDirent) + +-------------------------------------------------------------------------------- +-- Stat +-------------------------------------------------------------------------------- + +foreign import capi unsafe "sys/stat.h lstat" + c_lstat :: CString -> Ptr CStat -> IO CInt + +foreign import capi unsafe "sys/stat.h stat" + c_stat :: CString -> Ptr CStat -> IO CInt + +s_IFMT :: CMode +s_IFMT = #{const S_IFMT} + +s_IFDIR :: CMode +s_IFDIR = #{const S_IFDIR} + +{- +s_IFREG :: CMode +s_IFREG = #{const S_IFREG} + +s_IFLNK :: CMode +s_IFLNK = #{const S_IFLNK} +-} + +-- NOTE: Using fstatat with a dirfd and relative path would be faster. +stat :: Bool -> CString -> IO (Either Errno CMode) +stat followSym cstr = + allocaBytes #{size struct stat} $ \p_stat -> do + resetErrno + result <- + if followSym + then c_stat cstr p_stat + else c_lstat cstr p_stat + if result /= 0 + then do + errno <- getErrno + if errno == eINTR + then stat followSym cstr + else pure $ Left errno + else do + mode <- #{peek struct stat, st_mode} p_stat + pure $ Right (mode .&. s_IFMT) + +-------------------------------------------------------------------------------- +-- Functions +-------------------------------------------------------------------------------- + +-- | The CString must be pinned. +{-# INLINE openDirStreamCString #-} +openDirStreamCString :: CString -> IO DirStream +openDirStreamCString s = do + -- XXX we do not decode the path here, just print it as cstring + -- XXX pass lazy concat of "openDirStream: " ++ s + dirp <- throwErrnoIfNullRetry "openDirStream" $ c_opendir s + return (DirStream dirp) + +-- XXX Path is not null terminated therefore we need to make a copy even if the +-- array is pinned. +-- {-# INLINE openDirStream #-} +openDirStream :: PosixPath -> IO DirStream +openDirStream p = + Array.asCStringUnsafe (Path.toArray p) $ \s -> do + -- openDirStreamCString s + dirp <- throwErrnoPathIfNullRetry "openDirStream" p $ c_opendir s + return (DirStream dirp) + +-- | Note that the supplied Fd is used by DirStream and when we close the +-- DirStream the fd will be closed. +openDirStreamAt :: Fd -> PosixPath -> IO DirStream +openDirStreamAt fd p = do + -- XXX can pass O_DIRECTORY here, is O_NONBLOCK useful for dirs? + -- Note this fd is not automatically closed, we have to take care of + -- exceptions and closing the fd. + fd1 <- openAt (Just fd) p defaultOpenFlags Nothing + -- liftIO $ putStrLn $ "opened: " ++ show fd1 + dirp <- throwErrnoPathIfNullRetry "openDirStreamAt" p + $ c_fdopendir (fromIntegral fd1) + -- XXX can we somehow clone fd1 instead of opening again? + return (DirStream dirp) + +-- | @closeDirStream dp@ calls @closedir@ to close +-- the directory stream @dp@. +closeDirStream :: DirStream -> IO () +closeDirStream (DirStream dirp) = do + throwErrnoIfMinus1Retry_ "closeDirStream" (c_closedir dirp) + +------------------------------------------------------------------------------- +-- determining filetype +------------------------------------------------------------------------------- + +isMetaDir :: Ptr CChar -> IO Bool +isMetaDir dname = do + -- XXX Assuming an encoding that maps "." to ".", this is true for + -- UTF8. + -- Load as soon as possible to optimize memory accesses + c1 <- peek dname + c2 :: Word8 <- peekByteOff dname 1 + if (c1 /= fromIntegral (ord '.')) + then return False + else do + if (c2 == 0) + then return True + else do + if (c2 /= fromIntegral (ord '.')) + then return False + else do + c3 :: Word8 <- peekByteOff dname 2 + if (c3 == 0) + then return True + else return False + +data EntryType = EntryIsDir | EntryIsNotDir | EntryIgnored + +{-# NOINLINE statEntryType #-} +statEntryType + :: ReadOptions -> PosixPath -> Ptr CChar -> IO EntryType +statEntryType conf parent dname = do + -- XXX We can create a pinned array right here since the next call pins + -- it anyway. + path <- appendCString parent dname + Array.asCStringUnsafe (Path.toArray path) $ \cStr -> do + res <- stat (_followSymlinks conf) cStr + case res of + Right mode -> pure $ + if (mode == s_IFDIR) + then EntryIsDir + else EntryIsNotDir + Left errno -> do + if errno == eNOENT + then unless (_ignoreENOENT conf) $ + throwErrno (errMsg path) + else if errno == eACCES + then unless (_ignoreEACCESS conf) $ + throwErrno (errMsg path) + else if errno == eLOOP + then unless (_ignoreELOOP conf) $ + throwErrno (errMsg path) + else throwErrno (errMsg path) + pure $ EntryIgnored + where + + errMsg path = + let pathStr = Path.toString_ path + in "statEntryType: " ++ pathStr + +-- | Checks if dname is a directory, not dir or should be ignored. +{-# INLINE getEntryType #-} +getEntryType + :: ReadOptions + -> PosixPath -> Ptr CChar -> #{type unsigned char} -> IO EntryType +getEntryType conf parent dname dtype = do + let needStat = +#ifdef FORCE_LSTAT_READDIR + True +#else + (dtype == (#const DT_LNK) && _followSymlinks conf) + || dtype == #const DT_UNKNOWN +#endif + + if dtype /= (#const DT_DIR) && not needStat + then pure EntryIsNotDir + else do + isMeta <- liftIO $ isMetaDir dname + if isMeta + then pure EntryIgnored + else if dtype == (#const DT_DIR) + then pure EntryIsDir + else statEntryType conf parent dname + +------------------------------------------------------------------------------- +-- streaming reads +------------------------------------------------------------------------------- + +-- XXX We can use getdents64 directly so that we can use array slices from the +-- same buffer that we passed to the OS. That way we can also avoid any +-- overhead of bracket. +-- XXX Make this as Unfold to avoid returning Maybe +-- XXX Or NOINLINE some parts and inline the rest to fuse it +-- {-# INLINE readDirStreamEither #-} +readDirStreamEither :: + -- DirStream -> IO (Either (Rel (Dir Path)) (Rel (File Path))) + (ReadOptions -> ReadOptions) -> + (PosixPath, DirStream) -> IO (Maybe (Either PosixPath PosixPath)) +readDirStreamEither confMod (curdir, (DirStream dirp)) = loop + + where + + conf = confMod defaultReadOptions + + -- mkPath :: IsPath (Rel (a Path)) => Array Word8 -> Rel (a Path) + -- {-# INLINE mkPath #-} + mkPath :: Array Word8 -> PosixPath + mkPath = Path.unsafeFromArray + + loop = do + resetErrno + ptr <- c_readdir dirp + if (ptr /= nullPtr) + then do + let dname = #{ptr struct dirent, d_name} ptr + dtype :: #{type unsigned char} <- #{peek struct dirent, d_type} ptr + -- dreclen :: #{type unsigned short} <- #{peek struct dirent, d_reclen} ptr + -- It is possible to find the name length using dreclen and then use + -- fromPtrN, but it is not straightforward because the reclen is + -- padded to 8-byte boundary. + name <- Array.fromCString (castPtr dname) + etype <- getEntryType conf curdir dname dtype + case etype of + EntryIsDir -> return (Just (Left (mkPath name))) + EntryIsNotDir -> return (Just (Right (mkPath name))) + EntryIgnored -> loop + else do + errno <- getErrno + if (errno == eINTR) + then loop + else do + let (Errno n) = errno + if (n == 0) + -- then return (Left (mkPath (Array.fromList [46]))) + then return Nothing + else throwErrno "readDirStreamEither" + +-- XXX We can make this code common with windows, the path argument would be +-- redundant for windows case though. +{-# INLINE streamEitherReader #-} +streamEitherReader :: MonadIO m => + (ReadOptions -> ReadOptions) -> + Unfold m (PosixPath, DirStream) (Either Path Path) +streamEitherReader confMod = Unfold step return + where + + step s = do + r <- liftIO $ readDirStreamEither confMod s + case r of + Nothing -> return Stop + Just x -> return $ Yield x s + +{-# INLINE streamReader #-} +streamReader :: MonadIO m => Unfold m (PosixPath, DirStream) Path +streamReader = fmap (either id id) (streamEitherReader id) + +{-# INLINE before #-} +before :: PosixPath -> IO (PosixPath, DirStream) +before parent = (parent,) <$> openDirStream parent + +{-# INLINE after #-} +after :: (PosixPath, DirStream) -> IO () +after (_, dirStream) = closeDirStream dirStream + +-- | Read a directory emitting a stream with names of the children. Filter out +-- "." and ".." entries. +-- +-- /Internal/ +-- +{-# INLINE reader #-} +reader :: (MonadIO m, MonadCatch m) => Unfold m Path Path +reader = + -- XXX Instead of using bracketIO for each iteration of the loop we should + -- instead yield a buffer of dir entries in each iteration and then use an + -- unfold and concat to flatten those entries. That should improve the + -- performance. + UF.bracketIO before after (streamReader) + +-- | Read directories as Left and files as Right. Filter out "." and ".." +-- entries. +-- +-- /Internal/ +-- +{-# INLINE eitherReader #-} +eitherReader :: (MonadIO m, MonadCatch m) => + (ReadOptions -> ReadOptions) -> Unfold m Path (Either Path Path) +eitherReader confMod = + -- XXX The measured overhead of bracketIO is not noticeable, if it turns + -- out to be a problem for small filenames we can use getdents64 to use + -- chunked read to avoid the overhead. + UF.bracketIO before after (streamEitherReader confMod) + +{-# INLINE appendCString #-} +appendCString :: PosixPath -> CString -> IO PosixPath +appendCString (PosixPath a) b = do + arr <- PathC.appendCString PathC.Posix a b + pure $ PosixPath arr + +{-# ANN type ChunkStreamState Fuse #-} +data ChunkStreamState = + ChunkStreamInit [PosixPath] [PosixPath] Int [PosixPath] Int + | ChunkStreamLoop + PosixPath -- current dir path + [PosixPath] -- remaining dirs + (Ptr CDir) -- current dir + [PosixPath] -- dirs buffered + Int -- dir count + [PosixPath] -- files buffered + Int -- file count + +-- XXX We can use a fold for collecting files and dirs. +-- A fold may be useful to translate the output to whatever format we want, we +-- can add a prefix or we can colorize it. The Right output would be the output +-- of the fold which can be any type not just a Path. + +-- XXX We can write a two fold scan to buffer and yield whichever fills first +-- like foldMany, it would be foldEither. +{-# INLINE readEitherChunks #-} +readEitherChunks + :: MonadIO m + => (ReadOptions -> ReadOptions) + -> [PosixPath] -> Stream m (Either [PosixPath] [PosixPath]) +readEitherChunks confMod alldirs = + Stream step (ChunkStreamInit alldirs [] 0 [] 0) + + where + + conf = confMod defaultReadOptions + + -- We want to keep the dir batching as low as possible for better + -- concurrency esp when the number of dirs is low. + dirMax = 4 + fileMax = 1000 + + step _ (ChunkStreamInit (x:xs) dirs ndirs files nfiles) = do + DirStream dirp <- liftIO $ openDirStream x + return $ Skip (ChunkStreamLoop x xs dirp dirs ndirs files nfiles) + + step _ (ChunkStreamInit [] [] _ [] _) = + return Stop + + step _ (ChunkStreamInit [] [] _ files _) = + return $ Yield (Right files) (ChunkStreamInit [] [] 0 [] 0) + + step _ (ChunkStreamInit [] dirs _ files _) = + return $ Yield (Left dirs) (ChunkStreamInit [] [] 0 files 0) + + step _ st@(ChunkStreamLoop curdir xs dirp dirs ndirs files nfiles) = do + liftIO resetErrno + dentPtr <- liftIO $ c_readdir dirp + if (dentPtr /= nullPtr) + then do + let dname = #{ptr struct dirent, d_name} dentPtr + dtype :: #{type unsigned char} <- + liftIO $ #{peek struct dirent, d_type} dentPtr + + etype <- liftIO $ getEntryType conf curdir dname dtype + case etype of + EntryIsDir -> do + path <- liftIO $ appendCString curdir dname + let dirs1 = path : dirs + ndirs1 = ndirs + 1 + in if ndirs1 >= dirMax + then return $ Yield (Left dirs1) + (ChunkStreamLoop curdir xs dirp [] 0 files nfiles) + else return $ Skip + (ChunkStreamLoop curdir xs dirp dirs1 ndirs1 files nfiles) + EntryIsNotDir -> do + path <- liftIO $ appendCString curdir dname + let files1 = path : files + nfiles1 = nfiles + 1 + in if nfiles1 >= fileMax + then return $ Yield (Right files1) + (ChunkStreamLoop curdir xs dirp dirs ndirs [] 0) + else return $ Skip + (ChunkStreamLoop curdir xs dirp dirs ndirs files1 nfiles1) + EntryIgnored -> return $ Skip st + else do + errno <- liftIO getErrno + if (errno == eINTR) + then return $ Skip st + else do + let (Errno n) = errno + -- XXX Exception safety + liftIO $ closeDirStream (DirStream dirp) + if (n == 0) + then return $ Skip (ChunkStreamInit xs dirs ndirs files nfiles) + else liftIO $ throwErrno "readEitherChunks" + +foreign import ccall unsafe "string.h memcpy" c_memcpy + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) + +-- See also cstringLength# in GHC.CString in ghc-prim +foreign import ccall unsafe "string.h strlen" c_strlen + :: Ptr CChar -> IO CSize + +-- Split a list in half. +splitHalf :: [a] -> ([a], [a]) +splitHalf xxs = split xxs xxs + + where + + split (x:xs) (_:_:ys) = + let (f, s) = split xs ys + in (x:f, s) + split xs _ = ([], xs) + +{-# ANN type ChunkStreamByteState Fuse #-} +data ChunkStreamByteState = + ChunkStreamByteInit + | ChunkStreamByteStop + | ChunkStreamByteLoop + PosixPath -- current dir path + [PosixPath] -- remaining dirs + (Ptr CDir) -- current dir stream + MutByteArray + Int + | ChunkStreamReallocBuf + (Ptr CChar) -- pending item + PosixPath -- current dir path + [PosixPath] -- remaining dirs + (Ptr CDir) -- current dir stream + MutByteArray + Int + | ChunkStreamDrainBuf + MutByteArray + Int + +-- XXX Detect cycles. ELOOP can be used to avoid cycles, but we can also detect +-- them proactively. + +-- XXX Since we are separating paths by newlines, it cannot support newlines in +-- paths. Or we can return null separated paths as well. Provide a Mut array +-- API to replace the nulls with newlines in-place. +-- +-- We can pass a fold to make this modular, but if we are passing readdir +-- managed memory then we will have to consume it immediately. Otherwise we can +-- use getdents64 directly and use GHC managed memory instead. +-- +-- A fold may be useful to translate the output to whatever format we want, we +-- can add a prefix or we can colorize it. +-- +-- XXX Use bufSize, recursive traversal, split strategy, output entries +-- separator as config options. When not using concurrently we do not need to +-- split the work at all. +-- +-- XXX Currently we are quite aggressive in splitting the work because we have +-- no knowledge of whether we need to or not. But this leads to more overhead. +-- Instead, we can measure the coarse monotonic and process cpu time after +-- every n system calls or n iterations. If the cpu utilization is low then +-- yield the dirs otherwise dont. We can use an async thread for computing cpu +-- utilization periodically and all other threads can just read it from an +-- IORef. So this can be shared across all such consumers. + +-- | This function may not traverse all the directories supplied and it may +-- traverse the directories recursively. Left contains those directories that +-- were not traversed by this function, these my be the directories that were +-- supplied as input as well as newly discovered directories during traversal. +-- To traverse the entire tree we have to iterate this function on the Left +-- output. +-- +-- Right is a buffer containing directories and files separated by newlines. +-- +{-# INLINE readEitherByteChunks #-} +readEitherByteChunks :: MonadIO m => + (ReadOptions -> ReadOptions) -> + [PosixPath] -> Stream m (Either [PosixPath] (Array Word8)) +readEitherByteChunks confMod alldirs = + Stream step ChunkStreamByteInit + + where + + conf = confMod defaultReadOptions + + -- XXX A single worker may not have enough directories to list at once to + -- fill up a large buffer. We need to change the concurrency model such + -- that a worker should be able to pick up another dir from the queue + -- without emitting an output until the buffer fills. + -- + -- XXX A worker can also pick up multiple work items in one go. However, we + -- also need to keep in mind that any kind of batching might have + -- pathological cases where concurrency may be reduced. + -- + -- XXX Alternatively, we can distribute the dir stream over multiple + -- concurrent folds and return (monadic output) a stream of arrays created + -- from the output channel, then consume that stream by using a monad bind. + + bufSize = 32000 + + copyToBuf dstArr pos dirPath name = do + nameLen <- fmap fromIntegral (liftIO $ c_strlen name) + -- We know it is already pinned. + MutByteArray.unsafeAsPtr dstArr (\ptr -> liftIO $ do + -- XXX We may need to decode and encode the path if the + -- output encoding differs from fs encoding. + let PosixPath (Array dirArr start end) = dirPath + dirLen = end - start + endDir = pos + dirLen + endPos = endDir + nameLen + 2 -- sep + newline + sepOff = ptr `plusPtr` endDir -- separator offset + nameOff = sepOff `plusPtr` 1 -- file name offset + nlOff = nameOff `plusPtr` nameLen -- newline offset + separator = 47 :: Word8 + newline = 10 :: Word8 + if (endPos < bufSize) + then do + -- XXX We can keep a trailing separator on the dir itself. + MutByteArray.unsafePutSlice dirArr start dstArr pos dirLen + poke sepOff separator + _ <- c_memcpy nameOff (castPtr name) (fromIntegral nameLen) + poke nlOff newline + return (Just endPos) + else return Nothing + ) + + step _ ChunkStreamByteInit = do + mbarr <- liftIO $ MutByteArray.new' bufSize + case alldirs of + (x:xs) -> do + DirStream dirp <- liftIO $ openDirStream x + return $ Skip $ ChunkStreamByteLoop x xs dirp mbarr 0 + [] -> return Stop + + step _ ChunkStreamByteStop = return Stop + + step _ (ChunkStreamReallocBuf pending curdir xs dirp mbarr pos) = do + mbarr1 <- liftIO $ MutByteArray.new' bufSize + r1 <- copyToBuf mbarr1 0 curdir pending + case r1 of + Just pos2 -> + return $ Yield (Right (Array mbarr 0 pos)) + -- When we come in this state we have emitted dirs + (ChunkStreamByteLoop curdir xs dirp mbarr1 pos2) + Nothing -> error "Dirname too big for bufSize" + + step _ (ChunkStreamDrainBuf mbarr pos) = + if pos == 0 + then return Stop + else return $ Yield (Right (Array mbarr 0 pos)) ChunkStreamByteStop + + step _ (ChunkStreamByteLoop icurdir ixs idirp mbarr ipos) = do + goOuter icurdir idirp ixs ipos + + where + + -- This is recursed only when we open the next dir + -- Encapsulates curdir and dirp as static arguments + goOuter curdir dirp = goInner + + where + + -- This is recursed each time we find a dir + -- Encapsulates dirs as static argument + goInner dirs = nextEntry + + where + + {-# INLINE nextEntry #-} + nextEntry pos = do + liftIO resetErrno + dentPtr <- liftIO $ c_readdir dirp + if dentPtr /= nullPtr + then handleDentry pos dentPtr + else handleErr pos + + openNextDir pos = + case dirs of + (x:xs) -> do + DirStream dirp1 <- liftIO $ openDirStream x + goOuter x dirp1 xs pos + [] -> + if pos == 0 + then return Stop + else return + $ Yield + (Right (Array mbarr 0 pos)) + ChunkStreamByteStop + + handleErr pos = do + errno <- liftIO getErrno + if (errno /= eINTR) + then do + let (Errno n) = errno + liftIO $ closeDirStream (DirStream dirp) + if (n == 0) + then openNextDir pos + else liftIO $ throwErrno "readEitherByteChunks" + else nextEntry pos + + splitAndRealloc pos dname xs = + case xs of + [] -> + return $ Skip + (ChunkStreamReallocBuf dname curdir + [] dirp mbarr pos) + _ -> do + let (h,t) = splitHalf xs + return $ Yield (Left t) + (ChunkStreamReallocBuf dname curdir + h dirp mbarr pos) + + {-# INLINE handleFileEnt #-} + handleFileEnt pos dname = do + r <- copyToBuf mbarr pos curdir dname + case r of + Just pos1 -> nextEntry pos1 + Nothing -> splitAndRealloc pos dname dirs + + {-# INLINE handleDirEnt #-} + handleDirEnt pos dname = do + path <- liftIO $ appendCString curdir dname + let dirs1 = path : dirs + r <- copyToBuf mbarr pos curdir dname + case r of + Just pos1 -> goInner dirs1 pos1 + Nothing -> splitAndRealloc pos dname dirs1 + + handleDentry pos dentPtr = do + let dname = #{ptr struct dirent, d_name} dentPtr + dtype :: #{type unsigned char} <- + liftIO $ #{peek struct dirent, d_type} dentPtr + + etype <- liftIO $ getEntryType conf curdir dname dtype + case etype of + EntryIsNotDir -> handleFileEnt pos dname + EntryIsDir -> handleDirEnt pos dname + EntryIgnored -> nextEntry pos + +{-# ANN type ByteChunksAt Fuse #-} +data ByteChunksAt = + ByteChunksAtInit0 + | ByteChunksAtInit + Fd + [PosixPath] -- input dirs + -- (Handle, [PosixPath]) -- output dirs + -- Int -- count of output dirs + MutByteArray -- output files and dirs + Int -- position in MutByteArray + | ByteChunksAtLoop + Fd + (Ptr CDir) -- current dir stream + PosixPath -- current dir path + [PosixPath] -- remaining dirs + [PosixPath] -- output dirs + Int -- output dir count + MutByteArray + Int + | ByteChunksAtRealloc + (Ptr CChar) -- pending item + Fd + (Ptr CDir) -- current dir stream + PosixPath -- current dir path + [PosixPath] -- remaining dirs + [PosixPath] -- output dirs + Int -- output dir count + MutByteArray + Int + +-- The advantage of readEitherByteChunks over readEitherByteChunksAt is that we +-- do not need to open the dir handles and thus requires less open fd. +{-# INLINE readEitherByteChunksAt #-} +readEitherByteChunksAt :: MonadIO m => (ReadOptions -> ReadOptions) -> + -- (parent dir path, child dir paths rel to parent) + (PosixPath, [PosixPath]) + -> Stream m (Either (PosixPath, [PosixPath]) (Array Word8)) +readEitherByteChunksAt confMod (ppath, alldirs) = + Stream step (ByteChunksAtInit0) + + where + conf = confMod defaultReadOptions + + bufSize = 4000 + + copyToBuf dstArr pos dirPath name = do + nameLen <- fmap fromIntegral (liftIO $ c_strlen name) + -- XXX prepend ppath to dirPath + let PosixPath (Array dirArr start end) = dirPath + dirLen = end - start + -- XXX We may need to decode and encode the path if the + -- output encoding differs from fs encoding. + -- + -- Account for separator and newline bytes. + byteCount = dirLen + nameLen + 2 + if pos + byteCount <= bufSize + then do + -- XXX append a path separator to a dir path + -- We know it is already pinned. + MutByteArray.unsafeAsPtr dstArr (\ptr -> liftIO $ do + MutByteArray.unsafePutSlice dirArr start dstArr pos dirLen + let ptr1 = ptr `plusPtr` (pos + dirLen) + separator = 47 :: Word8 + poke ptr1 separator + let ptr2 = ptr1 `plusPtr` 1 + _ <- c_memcpy ptr2 (castPtr name) (fromIntegral nameLen) + let ptr3 = ptr2 `plusPtr` nameLen + newline = 10 :: Word8 + poke ptr3 newline + ) + return (Just (pos + byteCount)) + else return Nothing + + step _ ByteChunksAtInit0 = do + -- Note this fd is not automatically closed, we have to take care of + -- exceptions and closing the fd. + pfd <- liftIO $ openAt Nothing ppath defaultOpenFlags Nothing + mbarr <- liftIO $ MutByteArray.new' bufSize + return $ Skip (ByteChunksAtInit pfd alldirs mbarr 0) + + step _ (ByteChunksAtInit ph (x:xs) mbarr pos) = do + (DirStream dirp) <- liftIO $ openDirStreamAt ph x + return $ Skip (ByteChunksAtLoop ph dirp x xs [] 0 mbarr pos) + + step _ (ByteChunksAtInit pfd [] _ 0) = do + liftIO $ close (pfd) + return Stop + + step _ (ByteChunksAtInit pfd [] mbarr pos) = do + return + $ Yield + (Right (Array mbarr 0 pos)) + (ByteChunksAtInit pfd [] mbarr 0) + + step _ (ByteChunksAtRealloc pending pfd dirp curdir xs dirs ndirs mbarr pos) = do + mbarr1 <- liftIO $ MutByteArray.new' bufSize + r1 <- copyToBuf mbarr1 0 curdir pending + case r1 of + Just pos2 -> + return $ Yield (Right (Array mbarr 0 pos)) + (ByteChunksAtLoop pfd dirp curdir xs dirs ndirs mbarr1 pos2) + Nothing -> error "Dirname too big for bufSize" + + step _ st@(ByteChunksAtLoop pfd dirp curdir xs dirs ndirs mbarr pos) = do + liftIO resetErrno + dentPtr <- liftIO $ c_readdir dirp + if (dentPtr /= nullPtr) + then do + let dname = #{ptr struct dirent, d_name} dentPtr + dtype :: #{type unsigned char} <- + liftIO $ #{peek struct dirent, d_type} dentPtr + + -- Keep the file check first as it is more likely + etype <- liftIO $ getEntryType conf curdir dname dtype + case etype of + EntryIsNotDir -> do + r <- copyToBuf mbarr pos curdir dname + case r of + Just pos1 -> + return $ Skip + (ByteChunksAtLoop + pfd dirp curdir xs dirs ndirs mbarr pos1) + Nothing -> + return $ Skip + (ByteChunksAtRealloc + dname pfd dirp curdir xs dirs ndirs mbarr pos) + EntryIsDir -> do + arr <- Array.fromCString (castPtr dname) + let path = Path.unsafeFromArray arr + let dirs1 = path : dirs + ndirs1 = ndirs + 1 + r <- copyToBuf mbarr pos curdir dname + case r of + Just pos1 -> + -- XXX When there is less parallelization at the + -- top of the tree, we should use smaller chunks. + {- + if ndirs > 64 + then do + let fpath = Path.unsafeJoin ppath curdir + return $ Yield + (Left (fpath, dirs1)) + (ByteChunksAtLoop pfd dirp curdir xs [] 0 mbarr pos1) + else + -} + return $ Skip + (ByteChunksAtLoop + pfd dirp curdir xs dirs1 ndirs1 mbarr pos1) + Nothing -> do + return $ Skip + (ByteChunksAtRealloc + dname pfd dirp curdir xs dirs1 ndirs1 mbarr pos) + EntryIgnored -> return $ Skip st + else do + errno <- liftIO getErrno + if (errno == eINTR) + then return $ Skip st + else do + let (Errno n) = errno + -- XXX What if an exception occurs in the code before this? + -- Should we attach a weak IORef to close the fd on GC. + liftIO $ closeDirStream (DirStream dirp) + if (n == 0) + then + -- XXX Yielding on each dir completion may hurt perf when + -- there are many small directories. However, it may also + -- help parallelize more in IO bound case. + if ndirs > 0 + then do + let fpath = Path.unsafeJoin ppath curdir + return $ Yield + (Left (fpath, dirs)) + (ByteChunksAtInit pfd xs mbarr pos) + else return $ Skip (ByteChunksAtInit pfd xs mbarr pos) + else liftIO $ throwErrno "readEitherByteChunks" +#endif diff --git a/src/Streamly/Internal/FileSystem/PosixPath.hs b/src/Streamly/Internal/FileSystem/PosixPath.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/PosixPath.hs @@ -0,0 +1,1611 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +#if defined(IS_PORTABLE) +#define OS_PATH_TYPE Path +#define OS_WORD_TYPE OsWord +#define OS_CSTRING_TYPE OsCString +#define AS_OS_CSTRING asOsCString +#elif defined(IS_WINDOWS) +#define OS_PATH_TYPE WindowsPath +#define OS_WORD_TYPE Word16 +#define OS_CSTRING_TYPE CWString +#define AS_OS_CSTRING asCWString +#else +#define OS_PATH_TYPE PosixPath +#define OS_WORD_TYPE Word8 +#define OS_CSTRING_TYPE CString +#define AS_OS_CSTRING asCString +#endif + +-- Anything other than windows (Linux/macOS/FreeBSD) is Posix +#if defined(IS_WINDOWS) +#define OS_NAME Windows +#define OS_PATH WindowsPath +#define OS_WORD Word16 +#define OS_CSTRING CWString +#define UNICODE_ENCODER encodeUtf16le' +#define UNICODE_DECODER decodeUtf16le' +#define UNICODE_DECODER_LAX decodeUtf16le +#define CODEC_NAME UTF-16LE +#define SEPARATORS @/, \\@ +#else +#define OS_NAME Posix +#define OS_PATH PosixPath +#define OS_WORD Word8 +#define OS_CSTRING CString +#define UNICODE_ENCODER encodeUtf8' +#define UNICODE_DECODER decodeUtf8' +#define UNICODE_DECODER_LAX decodeUtf8 +#define CODEC_NAME UTF-8 +#define SEPARATORS @/@ +#endif + +-- | +-- Module : Streamly.Internal.FileSystem.OS_PATH_TYPE +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- This module implements a OS_PATH_TYPE type representing a file system path for +-- OS_NAME operating systems. The only assumption about the encoding of the +-- path is that it maps the characters SEPARATORS and @.@ to OS_WORD_TYPE +-- representing their ASCII values. Operations are provided to encode and +-- decode using CODEC_NAME encoding. +-- +-- This module has APIs that are equivalent to or can emulate all or most of +-- the filepath package APIs. It has some differences from the filepath +-- package: +-- +-- * Empty paths are not allowed. Paths are validated before construction. +-- * The default Path type itself affords considerable safety regarding the +-- distinction of rooted or non-rooted paths, it also allows distinguishing +-- directory and file paths. +-- * It is designed to provide flexible typing to provide compile time safety +-- for rooted/non-rooted paths and file/dir paths. The Path type is just part +-- of that typed path ecosystem. Though the default Path type itself should be +-- enough for most cases. +-- * It leverages the streamly array module for most of the heavy lifting, +-- it is a thin wrapper on top of that, improving maintainability as well as +-- providing better performance. We can have pinned and unpinned paths, also +-- provide lower level operations for certain cases to interact more +-- efficinetly with low level code. + +module Streamly.Internal.FileSystem.OS_PATH_TYPE + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Type +#if defined(IS_PORTABLE) + OS_WORD_TYPE + , OS_CSTRING_TYPE + , OS_PATH_TYPE +#else + OS_PATH_TYPE (..) +#endif + -- * Conversions + , IsPath (..) + , adapt + + -- * Conversion to OsWord + , charToWord + , wordToChar + + -- * Validation + , validatePath + , isValidPath +#ifdef IS_WINDOWS + , validatePath' + , isValidPath' +#endif + + -- * Construction + , fromArray + , unsafeFromArray + , fromChars + , fromString + , fromString_ + , encodeString + , unsafeFromString + -- , fromCString# + -- , fromCWString# + , readArray + + -- * Statically Verified String Literals + -- | Quasiquoters. + , path + + -- * Statically Verified Strings + -- | Template Haskell expression splices. + + -- Note: We expose these even though we have quasiquoters as these TH + -- helpers are more powerful. They are useful if we are generating strings + -- statically using methods other than literals or if we are doing some + -- text processing on strings before using them. + , pathE + + -- * Elimination + , toArray + , toChars + , toChars_ + , toString + , AS_OS_CSTRING + , toString_ + , showArray + + -- * Separators + -- Do we need to export the separator char functions? They are not + -- essential if operations to split and combine paths are provided. If + -- someone wants to work on paths at low level then they know what they + -- are. We should export the OsWord based operations to work with arrays. + , separator + , isSeparator + , extSeparator + + -- * Dir or non-dir paths + + -- You do not need these, instead use eqPath with ignoreTrailingSeparators. + , dropTrailingSeparators + , hasTrailingSeparator + , addTrailingSeparator + + -- * Path Segment Types + , isRooted + , isUnrooted + + -- * Joining + , joinStr + -- , concat + , unsafeJoin +#ifndef IS_WINDOWS + , joinCStr + , joinCStr' +#endif + , join + , joinDir + , unsafeJoinPaths + + -- * Splitting + -- | Note: you can use 'unsafeJoin' as a replacement for the joinDrive + -- function in the filepath package. + , splitRoot + , splitPath + , splitPath_ + , splitFile + + , splitFirst + , splitLast + + -- ** Extension + , splitExtension + , dropExtension + , addExtension + , replaceExtension + + -- ** Path View + , takeFileName + , takeDirectory + -- , takeDirectory_ -- drops the trailing / + , takeExtension + , takeFileBase + + -- * Equality + , EqCfg + , ignoreTrailingSeparators + , ignoreCase + , allowRelativeEquality + , eqPath + , eqPathBytes + , normalize + ) +where + +import Control.Exception (throw) +import Control.Monad.Catch (MonadThrow(..)) +import Data.Bifunctor (bimap) +import Data.Functor.Identity (Identity(..)) +import Data.Maybe (fromJust, isJust) +#ifndef IS_WINDOWS +import Data.Word (Word8) +import Foreign.C (CString) +#else +import Data.Word (Word16) +import Foreign.C (CWString) +#endif +import Language.Haskell.TH.Syntax (lift) +import Streamly.Internal.Data.Array (Array(..)) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.FileSystem.Path.Common (mkQ, EqCfg(..)) + +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.FileSystem.Path.Common as Common +import qualified Streamly.Internal.Unicode.Stream as Unicode + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Streamly.Internal.Data.Path + +#if defined(IS_PORTABLE) +import Streamly.Internal.FileSystem.OS_PATH (OS_PATH(..)) +#endif + +-- NOTES about C preprocessor use. +-- +-- docspec comment lines cannot use CPP macros, docspec does not expand them +-- before running tests. +-- +-- We cannot use a CPP conditional inside haddock comments because the +-- conditional line replaced by a blank line by CPP and this breaks the haddock +-- comment. Therefore if the comment is slightly different on a different +-- platform we duplicate the entire comment inside a conditional. + +#ifdef IS_PORTABLE +#include "DocTestFileSystemPath.hs" +#elif defined(IS_WINDOWS) +#include "DocTestFileSystemWindowsPath.hs" +#else +#include "DocTestFileSystemPosixPath.hs" +#endif + +#if defined(IS_PORTABLE) +type OS_PATH_TYPE = OS_PATH +type OS_WORD_TYPE = OS_WORD +type OS_CSTRING_TYPE = OS_CSTRING +#else +-- | A type representing file system paths on OS_NAME. +-- +-- A OS_PATH_TYPE is validated before construction unless unsafe constructors are +-- used to create it. For validations performed by the safe construction +-- methods see the 'fromChars' function. +-- +-- Note that in some cases the file system may perform unicode normalization on +-- paths (e.g. Apple HFS), it may cause surprising results as the path used by +-- the user may not have the same bytes as later returned by the file system. +newtype OS_PATH = OS_PATH (Array OS_WORD_TYPE) + +-- XXX The Eq instance may be provided but it will require some sensible +-- defaults for comparison. For example, should we use case sensitive or +-- insensitive comparison? It depends on the underlying file system. For now +-- now we have eqPath operations for equality comparison. + +instance IsPath OS_PATH OS_PATH where + unsafeFromPath = id + fromPath = pure + toPath = id +#endif + +-- XXX Use rewrite rules to eliminate intermediate conversions for better +-- efficiency. If the argument path is already verfied for a property, we +-- should not verify it again e.g. if we adapt (Rooted path) as (Rooted (Dir +-- path)) then we should not verify it to be Rooted again. + +-- XXX castPath? + +-- | Convert a path type to another path type. This operation may fail with a +-- 'PathException' when converting a less restrictive path type to a more +-- restrictive one. This can be used to upgrade or downgrade type safety. +adapt :: (MonadThrow m, IsPath OS_PATH_TYPE a, IsPath OS_PATH_TYPE b) => a -> m b +adapt p = fromPath (toPath p :: OS_PATH_TYPE) + +------------------------------------------------------------------------------ +-- Char to word +------------------------------------------------------------------------------ + +-- | Unsafe, truncates the Char to Word8 on Posix and Word16 on Windows. +charToWord :: Char -> OS_WORD_TYPE +charToWord = Common.charToWord + +-- | Unsafe, should be a valid character. +wordToChar :: OS_WORD_TYPE -> Char +wordToChar = Common.wordToChar + +------------------------------------------------------------------------------ +-- Separators +------------------------------------------------------------------------------ + +-- | The primary path separator word: @/@ on POSIX and @\\@ on Windows. +-- Windows also supports @/@ as a valid separator. Use 'isSeparator' to check +-- for any valid path separator. +{-# INLINE separator #-} +separator :: OS_WORD_TYPE +separator = charToWord $ Common.primarySeparator Common.OS_NAME + +-- | On POSIX, only @/@ is a path separator, whereas on Windows both @/@ and +-- @\\@ are valid separators. +{-# INLINE isSeparator #-} +isSeparator :: OS_WORD_TYPE -> Bool +isSeparator = Common.isSeparatorWord Common.OS_NAME + +-- | File extension separator word. +{-# INLINE extSeparator #-} +extSeparator :: OS_WORD_TYPE +extSeparator = Common.extensionWord + +------------------------------------------------------------------------------ +-- Path parsing utilities +------------------------------------------------------------------------------ + +-- XXX We can have prime suffixed versions where it drops or adds separator +-- unconditionally. Alternatively, we can convert the path to array and use +-- array operations instead. + +-- | Remove all trailing path separators from the given 'Path'. +-- +-- Instead of this operation you may want to use 'eqPath' with +-- 'ignoreTrailingSeparators' option. +-- +-- This operation is careful not to alter the semantic meaning of the path. +-- For example, on Windows: +-- +-- * Dropping the separator from "C:/" would change the meaning of the path +-- from referring to the root of the C: drive to the current directory on C:. +-- * If a path ends with a separator immediately after a colon (e.g., "C:/"), +-- the separator will not be removed. +-- +-- If the input path is invalid, the behavior is not fully guaranteed: +-- +-- * The separator may still be dropped. +-- * In some cases, dropping the separator may make an invalid path valid +-- (e.g., "C:\\\\" or "C:\\/"). +-- +-- This operation may convert a path that implicitly refers to a directory +-- into one that does not. +-- +-- Typically, if the path is @dir//@, the result is @dir@. Special cases include: +-- +-- * On POSIX: dropping from @"//"@ yields @"/"@. +-- * On Windows: dropping from @"C://"@ results in @"C:/"@. +-- +-- Examples: +-- +-- >>> f = Path.toString . Path.dropTrailingSeparators . Path.fromString_ +-- >>> f "./" +-- "." +-- +-- >> f "//" -- On POSIX +-- "/" +-- +{-# INLINE dropTrailingSeparators #-} +dropTrailingSeparators :: OS_PATH_TYPE -> OS_PATH_TYPE +dropTrailingSeparators (OS_PATH arr) = + OS_PATH (Common.dropTrailingSeparators Common.OS_NAME arr) + +-- On windows a share name can also be reported to have a trailing separator, +-- but that is not a valid Path. + +-- | Returns 'True' if the path ends with a trailing separator. +-- +-- This typically indicates that the path is a directory, though this is not +-- guaranteed in all cases. +-- +-- Example: +-- +-- >>> Path.hasTrailingSeparator (Path.fromString_ "foo/") +-- True +-- +-- >>> Path.hasTrailingSeparator (Path.fromString_ "foo") +-- False +{-# INLINE hasTrailingSeparator #-} +hasTrailingSeparator :: OS_PATH_TYPE -> Bool +hasTrailingSeparator (OS_PATH arr) = + Common.hasTrailingSeparator Common.OS_NAME arr + +-- | Add a trailing path separator to a path if it doesn't already have one. +-- +-- Instead of this operation you may want to use 'eqPath' with +-- 'ignoreTrailingSeparators' option. +-- +-- This function avoids modifying the path if doing so would change its meaning +-- or make it invalid. For example, on Windows: +-- +-- * Adding a separator to "C:" would change it from referring to the current +-- directory on the C: drive to the root directory. +-- * Adding a separator to "\\" could turn it into a UNC share path, which may +-- not be intended. +-- * If the path ends with a colon (e.g., "C:"), a separator is not added. +-- +-- This operation typically makes the path behave like an implicit directory path. +{-# INLINE addTrailingSeparator #-} +addTrailingSeparator :: OS_PATH_TYPE -> OS_PATH_TYPE +addTrailingSeparator p@(OS_PATH _arr) = +#ifdef IS_WINDOWS + if Array.unsafeGetIndexRev 0 _arr == Common.charToWord ':' + then p + else unsafeJoin p sep +#else + unsafeJoin p sep +#endif + + where + + sep = fromJust $ fromString [Common.primarySeparator Common.OS_NAME] + +-- Path must not contain null char as system calls treat the path as a null +-- terminated C string. Also, they return null terminated strings as paths. +-- +-- XXX Maintain the Array with null termination? To avoid copying the path for +-- null termination when passing to system calls. Path appends will have to +-- handle the null termination. + +#ifndef IS_WINDOWS +-- | Checks whether the filepath is valid; i.e., whether the operating system +-- permits such a path for listing or creating files. These validations are +-- operating system specific and file system independent. Throws an exception +-- with a detailed explanation if the path is invalid. +-- +-- >>> isValid = isJust . Path.validatePath . Path.encodeString +-- +-- Validations: +-- +-- >>> isValid "" +-- False +-- >>> isValid "\0" +-- False +-- +-- Other than these there may be maximum path component length and maximum path +-- length restrictions enforced by the OS as well as the filesystem which we do +-- not validate. +-- +#else +-- | Checks whether the filepath is valid; i.e., whether the operating system +-- permits such a path for listing or creating files. These validations are +-- operating system specific and file system independent. Throws an exception +-- with a detailed explanation if the path is invalid. +-- +-- >>> isValid = isJust . Path.validatePath . Path.encodeString +-- +-- General validations: +-- +-- >>> isValid "" +-- False +-- >>> isValid "\0" +-- False +-- +-- Windows invalid characters: +-- +-- >>> isValid "c::" +-- False +-- >>> isValid "c:\\x:y" +-- False +-- >>> isValid "x*" +-- False +-- >>> isValid "x\ty" -- control characters +-- False +-- +-- Windows invalid path components: +-- +-- >>> isValid "pRn.txt" +-- False +-- >>> isValid " pRn .txt" +-- False +-- >>> isValid "c:\\x\\pRn" +-- False +-- >>> isValid "c:\\x\\pRn.txt" +-- False +-- >>> isValid "c:\\pRn\\x" +-- False +-- >>> isValid "c:\\ pRn \\x" +-- False +-- >>> isValid "pRn.x.txt" +-- False +-- +-- Windows drive root validations: +-- +-- >>> isValid "c:" +-- True +-- >>> isValid "c:a\\b" +-- True +-- >>> isValid "c:\\" +-- True +-- >>> isValid "c:\\\\" +-- False +-- >>> isValid "c:\\/" +-- False +-- >>> isValid "c:\\\\x" +-- False +-- >>> isValid "c:\\/x" +-- False +-- +-- Mixing path separators: +-- >>> isValid "/x\\y" +-- True +-- >>> isValid "\\/" -- ? +-- True +-- >>> isValid "/\\" -- ? +-- True +-- >>> isValid "\\/x/y" -- ? +-- True +-- >>> isValid "/x/\\y" -- ? +-- True +-- >>> isValid "/x\\/y" -- ? +-- True +-- +-- Windows share path validations: +-- +-- >>> isValid "\\" +-- True +-- >>> isValid "\\\\" +-- False +-- >>> isValid "\\\\\\" +-- False +-- >>> isValid "\\\\x" +-- False +-- >>> isValid "\\\\x\\" +-- True +-- >>> isValid "\\\\x\\y" +-- True +-- >>> isValid "//x/y" +-- True +-- >>> isValid "\\\\prn\\y" +-- False +-- >>> isValid "\\\\x\\\\" +-- False +-- >>> isValid "\\\\x\\\\x" +-- False +-- >>> isValid "\\\\\\x" +-- False +-- +-- Windows short UNC path validations: +-- +-- >>> isValid "\\\\?\\c:" +-- False +-- >>> isValid "\\\\?\\c:\\" +-- True +-- >>> isValid "\\\\?\\c:x" +-- False +-- >>> isValid "\\\\?\\c:\\\\" -- XXX validate this +-- False +-- >>> isValid "\\\\?\\c:\\x" +-- True +-- >>> isValid "\\\\?\\c:\\\\\\" +-- False +-- >>> isValid "\\\\?\\c:\\\\x" +-- False +-- +-- Windows long UNC path validations: +-- +-- >>> isValid "\\\\?\\UnC\\x" -- UnC treated as share name +-- True +-- >>> isValid "\\\\?\\UNC\\x" -- XXX fix +-- False +-- >>> isValid "\\\\?\\UNC\\c:\\x" +-- True +-- +-- DOS local/global device namespace +-- +-- >>> isValid "\\\\.\\x" +-- True +-- >>> isValid "\\\\??\\x" +-- True +-- +-- Other than these there may be maximum path component length and maximum path +-- length restrictions enforced by the OS as well as the filesystem which we do +-- not validate. +-- +#endif +validatePath :: MonadThrow m => Array OS_WORD_TYPE -> m () +validatePath = Common.validatePath Common.OS_NAME + +-- | Returns 'True' if the filepath is valid: +-- +-- >>> isValidPath = isJust . Path.validatePath +-- +isValidPath :: Array OS_WORD_TYPE -> Bool +isValidPath = isJust . validatePath + +-- Note: CPP gets confused by the prime suffix, so we have to put the CPP +-- macros on the next line to get it to work. + +------------------------------------------------------------------------------ +-- Construction +------------------------------------------------------------------------------ + +-- A chunk is essentially an untyped Array i.e. Array Word8. We can either use +-- the term ByteArray for that or just Chunk. The latter is shorter and we have +-- been using it consistently in streamly. We use "bytes" for a stream of +-- bytes. + +-- | /Unsafe/: The user is responsible to make sure that the path is valid as +-- per 'validatePath'. +-- +{-# INLINE unsafeFromArray #-} +unsafeFromArray :: Array OS_WORD_TYPE -> OS_PATH_TYPE +unsafeFromArray = +#ifndef DEBUG + OS_PATH . Common.unsafeFromArray +#else + fromJust . fromArray +#endif + +#ifndef IS_WINDOWS +-- | Convert an encoded array of OS_WORD_TYPE into a value of type +-- OS_PATH_TYPE. The path is validated using 'validatePath'. +-- +-- Each OS_WORD_TYPE should be encoded such that: +-- +-- * The input does not contain a NUL word. +-- * Values from 1-128 are assumed to be ASCII characters. +-- +-- Apart from the above, there are no restrictions on the encoding. +-- +-- To bypass path validation checks, use 'unsafeFromArray'. +-- +-- Throws 'InvalidPath' if 'validatePath' fails on the resulting path. +-- +#else +-- | Convert an encoded array of OS_WORD_TYPE into a value of type +-- OS_PATH_TYPE. The path is validated using 'validatePath'. +-- +-- Each OS_WORD_TYPE should be encoded such that: +-- +-- * The input does not contain a NUL word. +-- * The OS_WORD_TYPE is encoded with little-endian ordering. +-- * Values from 1-128 are assumed to be ASCII characters. +-- +-- Apart from the above, there are no restrictions on the encoding. +-- +-- To bypass path validation checks, use 'unsafeFromArray'. +-- +-- Throws 'InvalidPath' if 'validatePath' fails on the resulting path. +-- +#endif +fromArray :: MonadThrow m => Array OS_WORD_TYPE -> m OS_PATH_TYPE +fromArray arr = OS_PATH <$> Common.fromArray Common.OS_NAME arr + +-- XXX Should be a Fold instead? + +-- | Like 'fromString' but a streaming operation. +-- +-- >>> fromString = Path.fromChars . Stream.fromList +-- +-- We do not sanitize the path i.e. we do not remove duplicate separators, +-- redundant @.@ segments, trailing separators etc because that would require +-- unnecessary checks and modifications to the path which may not be used ever +-- for any useful purpose, it is only needed for path equality and can be done +-- during the equality check. +-- +-- Unicode normalization is not done. If normalization is needed the user can +-- normalize it and then use the 'fromArray' API. +{-# INLINE fromChars #-} +fromChars :: MonadThrow m => Stream Identity Char -> m OS_PATH_TYPE +fromChars s = + OS_PATH <$> Common.fromChars Common.OS_NAME Unicode.UNICODE_ENCODER s + +-- | Create an array from a path string using strict CODEC_NAME encoding. The +-- path is not validated, therefore, it may not be valid according to +-- 'validatePath'. +-- +-- Same as @toArray . unsafeFromString@. +encodeString :: [Char] -> Array OS_WORD_TYPE +encodeString = + Common.unsafeFromChars Unicode.UNICODE_ENCODER + . Stream.fromList + +-- | Like 'fromString' but does not perform any validations mentioned under +-- 'validatePath'. Fails only if unicode encoding fails. +unsafeFromString :: [Char] -> OS_PATH_TYPE +unsafeFromString = +#ifndef DEBUG + OS_PATH + . encodeString +#else + fromJust . fromString +#endif + +-- | Encode a Unicode character string to OS_PATH_TYPE using strict CODEC_NAME +-- encoding. The path is validated using 'validatePath'. +-- +-- * Throws 'InvalidPath' if 'validatePath' fails on the path +-- * Fails if the stream contains invalid unicode characters +-- +fromString :: MonadThrow m => [Char] -> m OS_PATH_TYPE +fromString = fromChars . Stream.fromList + +-- | Like fromString but a pure and partial function that throws an +-- 'InvalidPath' exception. +fromString_ :: [Char] -> OS_PATH_TYPE +fromString_ x = + case fromString x of + Left e -> throw e + Right v -> v + +-- | Append a separator followed by the supplied string to a path. +-- +-- Throws 'InvalidPath' if the resulting path is not a valid path as per +-- 'validatePath'. +-- +joinStr :: OS_PATH_TYPE -> [Char] -> OS_PATH_TYPE +joinStr (OS_PATH a) b = + OS_PATH $ + Common.append Common.OS_NAME + (Common.toString Unicode.UNICODE_DECODER) a (encodeString b) + + +------------------------------------------------------------------------------ +-- Statically Verified Strings +------------------------------------------------------------------------------ + +-- XXX We can lift the array directly, ByteArray has a lift instance. Does that +-- work better? +-- +-- XXX Make this polymorphic and reusable in other modules. + +liftPath :: OS_PATH_TYPE -> Q Exp +liftPath p = + [| unsafeFromString $(lift $ toString p) :: OS_PATH |] + +-- | Generates a Haskell expression of type OS_PATH_TYPE from a String. Equivalent +-- to using 'fromString' on the string passed. +-- +pathE :: String -> Q Exp +pathE = either (error . show) liftPath . fromString + +------------------------------------------------------------------------------ +-- Statically Verified Literals +------------------------------------------------------------------------------ + +-- XXX Define folds or parsers to parse the paths. +-- XXX Build these on top of the str quasiquoter so that we get interpolation +-- for free. Interpolated vars if any have to be of appropriate type depending +-- on the context so that we can splice them safely. + +#ifdef IS_PORTABLE +-- | Generates a OS_PATH_TYPE type from a quoted literal. Equivalent to using +-- 'fromString' on the static literal. +-- +-- >>> Path.toString ([path|/usr/bin|] :: Path) +-- "/usr/bin" +-- +#endif +path :: QuasiQuoter +path = mkQ pathE + +------------------------------------------------------------------------------ +-- Eimination +------------------------------------------------------------------------------ + +-- | Convert the path to an array. +toArray :: OS_PATH_TYPE -> Array OS_WORD_TYPE +toArray (OS_PATH arr) = arr + +-- | Decode the path to a stream of Unicode chars using strict CODEC_NAME decoding. +{-# INLINE toChars #-} +toChars :: Monad m => OS_PATH_TYPE -> Stream m Char +toChars (OS_PATH arr) = Common.toChars Unicode.UNICODE_DECODER arr + +-- | Decode the path to a stream of Unicode chars using lax CODEC_NAME decoding. +toChars_ :: Monad m => OS_PATH_TYPE -> Stream m Char +toChars_ (OS_PATH arr) = Common.toChars Unicode.UNICODE_DECODER_LAX arr + +-- XXX When showing, append a "/" to dir types? + +-- | Decode the path to a Unicode string using strict CODEC_NAME decoding. +toString :: OS_PATH_TYPE -> [Char] +toString = runIdentity . Stream.toList . toChars + +-- | Decode the path to a Unicode string using lax CODEC_NAME decoding. +toString_ :: OS_PATH_TYPE -> [Char] +toString_ = runIdentity . Stream.toList . toChars_ + +-- | Show the path as raw characters without any specific decoding. +-- +-- See also: 'readArray'. +-- +showArray :: OS_PATH_TYPE -> [Char] +showArray (OS_PATH arr) = show arr + +#ifndef IS_WINDOWS +#ifdef IS_PORTABLE +-- | Parse a raw array of bytes as a path type. +-- +-- >>> readArray = fromJust . Path.fromArray . read +-- +-- >>> arr = Path.encodeString "hello" +-- >>> Path.showArray $ (Path.readArray $ show arr :: Path.Path) +-- "fromList [104,101,108,108,111]" +-- +-- See also: 'showArray'. +#endif +readArray :: [Char] -> OS_PATH_TYPE +readArray = fromJust . fromArray . read +#endif + +-- We cannot show decoded path in the Show instance as it may not always +-- succeed and it depends on the encoding which we may not even know. The +-- encoding may depend on the OS and the file system. Also we need Show and +-- Read to be inverses. The best we can provide is to show the bytes as +-- Hex or decimal values. +{- +instance Show OS_PATH where + show (OS_PATH x) = show x +-} + +#ifndef IS_WINDOWS +-- | Use the path as a pinned CString. Useful for using a PosixPath in +-- system calls on Posix. +{-# INLINE AS_OS_CSTRING #-} +AS_OS_CSTRING :: OS_PATH_TYPE -> (OS_CSTRING_TYPE -> IO a) -> IO a +AS_OS_CSTRING p = Array.asCStringUnsafe (toArray p) +#else +-- | Use the path as a pinned CWString. Useful for using a WindowsPath in +-- system calls on Windows. +{-# INLINE AS_OS_CSTRING #-} +AS_OS_CSTRING :: OS_PATH_TYPE -> (OS_CSTRING_TYPE -> IO a) -> IO a +AS_OS_CSTRING p = Array.asCWString (toArray p) +#endif + +------------------------------------------------------------------------------ +-- Operations on Path +------------------------------------------------------------------------------ + +#ifndef IS_WINDOWS +-- | A path that is attached to a root e.g. "\/x" or ".\/x" are rooted paths. +-- "\/" is considered an absolute root and "." as a dynamic root. ".." is not +-- considered a root, "..\/x" or "x\/y" are not rooted paths. +-- +-- >>> isRooted = Path.isRooted . Path.fromString_ +-- +-- >>> isRooted "/" +-- True +-- >>> isRooted "/x" +-- True +-- >>> isRooted "." +-- True +-- >>> isRooted "./x" +-- True +-- +isRooted :: OS_PATH_TYPE -> Bool +isRooted (OS_PATH arr) = Common.isRooted Common.OS_NAME arr +#endif + +-- | A path that is not attached to a root e.g. @a\/b\/c@ or @..\/b\/c@. +-- +-- >>> isUnrooted = not . Path.isRooted +-- +-- >>> isUnrooted = Path.isUnrooted . Path.fromString_ +-- +-- >>> isUnrooted "x" +-- True +-- >>> isUnrooted "x/y" +-- True +-- >>> isUnrooted ".." +-- True +-- >>> isUnrooted "../x" +-- True +-- +isUnrooted :: OS_PATH_TYPE -> Bool +isUnrooted = not . isRooted + +#ifndef IS_WINDOWS +-- | Like 'join' but does not check if the second path is rooted. +-- +-- >>> f a b = Path.toString $ Path.unsafeJoin (Path.fromString_ a) (Path.fromString_ b) +-- +-- >>> f "x" "y" +-- "x/y" +-- >>> f "x/" "y" +-- "x/y" +-- >>> f "x" "/y" +-- "x/y" +-- >>> f "x/" "/y" +-- "x/y" +-- +{-# INLINE unsafeJoin #-} +unsafeJoin :: OS_PATH_TYPE -> OS_PATH_TYPE -> OS_PATH_TYPE +unsafeJoin (OS_PATH a) (OS_PATH b) = + OS_PATH + $ Common.unsafeAppend + Common.OS_NAME (Common.toString Unicode.UNICODE_DECODER) a b + +-- If you want to avoid runtime failure use the typesafe +-- Streamly.FileSystem.OS_PATH_TYPE.Seg module. + +-- | Append a separator followed by another path to a OS_PATH_TYPE. Fails if +-- the second path is a rooted path. Use 'unsafeJoin' to avoid failure if you +-- know it is ok to append the rooted path. +-- +-- >>> f a b = Path.toString $ Path.join a b +-- +-- >>> f [path|/usr|] [path|bin|] +-- "/usr/bin" +-- >>> f [path|/usr/|] [path|bin|] +-- "/usr/bin" +-- >>> fails (f [path|/usr|] [path|/bin|]) +-- True +-- +join :: OS_PATH_TYPE -> OS_PATH_TYPE -> OS_PATH_TYPE +join (OS_PATH a) (OS_PATH b) = + OS_PATH + $ Common.append + Common.OS_NAME (Common.toString Unicode.UNICODE_DECODER) a b + +-- | A stricter version of 'join' which requires the first path to be a +-- directory like path i.e. having a trailing separator. +-- +-- >>> f a b = Path.toString $ Path.joinDir a b +-- +-- >>> fails $ f [path|/usr|] [path|bin|] +-- True +-- +joinDir :: + OS_PATH_TYPE -> OS_PATH_TYPE -> OS_PATH_TYPE +joinDir + (OS_PATH a) (OS_PATH b) = + OS_PATH + $ Common.append' + Common.OS_NAME (Common.toString Unicode.UNICODE_DECODER) a b +#endif + +-- XXX This can be pure, like append. +-- XXX add appendCWString for Windows? + +#ifndef IS_WINDOWS +-- | Append a separator and a CString to the Array. This is like 'unsafeJoin' +-- but always inserts a separator between the two paths even if the first path +-- has a trailing separator or second path has a leading separator. +-- +joinCStr :: OS_PATH_TYPE -> CString -> IO OS_PATH_TYPE +joinCStr (OS_PATH a) str = + fmap OS_PATH + $ Common.appendCString + Common.OS_NAME a str + +-- | Like 'joinCStr' but creates a pinned path. +-- +joinCStr' :: + OS_PATH_TYPE -> CString -> IO OS_PATH_TYPE +joinCStr' + (OS_PATH a) str = + fmap OS_PATH + $ Common.appendCString' + Common.OS_NAME a str +#endif + +-- See unsafeJoinPaths in the Common path module, we need to avoid MonadIo from +-- that to implement this. + +-- | Join paths by path separator. Does not check if the paths being appended +-- are rooted or branches. Note that splitting and joining may not give exactly +-- the original path but an equivalent path. +-- +-- /Unimplemented/ +unsafeJoinPaths :: [OS_PATH_TYPE] -> OS_PATH_TYPE +unsafeJoinPaths = undefined + +------------------------------------------------------------------------------ +-- Splitting path +------------------------------------------------------------------------------ + +#ifndef IS_WINDOWS +-- | If a path is rooted then separate the root and the remaining path, +-- otherwise return 'Nothing'. The non-root +-- part is guaranteed to NOT start with a separator. +-- +-- Some filepath package equivalent idioms: +-- +-- >>> splitDrive = Path.splitRoot +-- >>> joinDrive = Path.unsafeJoin +-- >>> takeDrive = fmap fst . Path.splitRoot +-- >>> dropDrive x = Path.splitRoot x >>= snd +-- >>> hasDrive = isJust . Path.splitRoot +-- >>> isDrive = isNothing . dropDrive +-- +-- >>> toList (a,b) = (Path.toString a, fmap Path.toString b) +-- >>> split = fmap toList . Path.splitRoot . Path.fromString_ +-- +-- >>> split "/" +-- Just ("/",Nothing) +-- +-- >>> split "." +-- Just (".",Nothing) +-- +-- >>> split "./" +-- Just ("./",Nothing) +-- +-- >>> split "/home" +-- Just ("/",Just "home") +-- +-- >>> split "//" +-- Just ("//",Nothing) +-- +-- >>> split "./home" +-- Just ("./",Just "home") +-- +-- >>> split "home" +-- Nothing +-- +splitRoot :: OS_PATH_TYPE -> Maybe (OS_PATH_TYPE, Maybe OS_PATH_TYPE) +splitRoot (OS_PATH x) = + let (a,b) = Common.splitRoot Common.OS_NAME x + in if Array.null a + then Nothing + else if Array.null b + then Just (OS_PATH a, Nothing) + else Just (OS_PATH a, Just (OS_PATH b)) + +-- | Split the path components keeping separators between path components +-- attached to the dir part. Redundant separators are removed, only the first +-- one is kept. Separators are not added either e.g. "." and ".." may not have +-- trailing separators if the original path does not. +-- +-- >>> split = Stream.toList . fmap Path.toString . Path.splitPath . Path.fromString_ +-- +-- >>> split "." +-- ["."] +-- +-- >>> split "././" +-- ["./"] +-- +-- >>> split "./a/b/." +-- ["./","a/","b/"] +-- +-- >>> split ".." +-- [".."] +-- +-- >>> split "../" +-- ["../"] +-- +-- >>> split "a/.." +-- ["a/",".."] +-- +-- >>> split "/" +-- ["/"] +-- +-- >>> split "//" +-- ["/"] +-- +-- >>> split "/x" +-- ["/","x"] +-- +-- >>> split "/./x/" +-- ["/","x/"] +-- +-- >>> split "/x/./y" +-- ["/","x/","y"] +-- +-- >>> split "/x/../y" +-- ["/","x/","../","y"] +-- +-- >>> split "/x///y" +-- ["/","x/","y"] +-- +-- >>> split "/x/\\y" +-- ["/","x/","\\y"] +-- +{-# INLINE splitPath #-} +splitPath :: Monad m => OS_PATH_TYPE -> Stream m OS_PATH_TYPE +splitPath (OS_PATH a) = fmap OS_PATH $ Common.splitPath Common.OS_NAME a + +-- | Split a path into components separated by the path separator. "." +-- components in the path are ignored except when in the leading position. +-- Trailing separators in non-root components are dropped. +-- +-- >>> split = Stream.toList . fmap Path.toString . Path.splitPath_ . Path.fromString_ +-- +-- >>> split "." +-- ["."] +-- +-- >>> split "././" +-- ["."] +-- +-- >>> split ".//" +-- ["."] +-- +-- >>> split "//" +-- ["/"] +-- +-- >>> split "//x/y/" +-- ["/","x","y"] +-- +-- >>> split "./a" +-- [".","a"] +-- +-- >>> split "a/." +-- ["a"] +-- +-- >>> split "/" +-- ["/"] +-- +-- >>> split "/x" +-- ["/","x"] +-- +-- >>> split "/./x/" +-- ["/","x"] +-- +-- >>> split "/x/./y" +-- ["/","x","y"] +-- +-- >>> split "/x/../y" +-- ["/","x","..","y"] +-- +-- >>> split "/x///y" +-- ["/","x","y"] +-- +-- >>> split "/x/\\y" +-- ["/","x","\\y"] +-- +{-# INLINE splitPath_ #-} +splitPath_ :: Monad m => OS_PATH_TYPE -> Stream m OS_PATH_TYPE +splitPath_ (OS_PATH a) = fmap OS_PATH $ Common.splitPath_ Common.OS_NAME a +#endif + +-- | If the path does not look like a directory then return @Just (Maybe dir, +-- file)@ otherwise return 'Nothing'. The path is not a directory if: +-- +-- * the path does not end with a separator +-- * the path does not end with a . or .. component +-- +-- Splits a single component path into @Just (Nothing, path)@ if it does not +-- look like a dir. +-- +-- >>> toList (a,b) = (fmap Path.toString a, Path.toString b) +-- >>> split = fmap toList . Path.splitFile . Path.fromString_ +-- +-- >>> split "/" +-- Nothing +-- +-- >>> split "." +-- Nothing +-- +-- >>> split "/." +-- Nothing +-- +-- >>> split ".." +-- Nothing +-- +-- >> split "//" -- Posix +-- Nothing +-- +-- >>> split "/home" +-- Just (Just "/","home") +-- +-- >>> split "./home" +-- Just (Just "./","home") +-- +-- >>> split "home" +-- Just (Nothing,"home") +-- +-- >>> split "x/" +-- Nothing +-- +-- >>> split "x/y" +-- Just (Just "x/","y") +-- +-- >>> split "x//y" +-- Just (Just "x//","y") +-- +-- >>> split "x/./y" +-- Just (Just "x/./","y") +splitFile :: OS_PATH_TYPE -> Maybe (Maybe OS_PATH_TYPE, OS_PATH_TYPE) +splitFile (OS_PATH a) = + fmap (bimap (fmap OS_PATH) OS_PATH) $ Common.splitFile Common.OS_NAME a + +-- | Split the path into the first component and rest of the path. Treats the +-- entire root or share name, if present, as the first component. +-- +-- /Unimplemented/ +splitFirst :: OS_PATH_TYPE -> (OS_PATH_TYPE, Maybe OS_PATH_TYPE) +splitFirst (OS_PATH a) = + bimap OS_PATH (fmap OS_PATH) $ Common.splitHead Common.OS_NAME a + +-- | Split the path into the last component and rest of the path. Treats the +-- entire root or share name, if present, as the first component. +-- +-- >>> basename = snd . Path.splitLast -- Posix basename +-- >>> dirname = fst . Path.splitLast -- Posix dirname +-- +-- /Unimplemented/ +splitLast :: OS_PATH_TYPE -> (Maybe OS_PATH_TYPE, OS_PATH_TYPE) +splitLast (OS_PATH a) = + bimap (fmap OS_PATH) OS_PATH $ Common.splitTail Common.OS_NAME a + +#ifndef IS_WINDOWS +-- Note: In the cases of "x.y." and "x.y.." we return no extension rather +-- than ".y." or ".y.." as extensions. That is they considered to have no +-- extension. + +-- | Returns @Just(filename, extension)@ if an extension is present otherwise +-- returns 'Nothing'. +-- +-- A file name is considered to have an extension if the file name can be +-- split into a non-empty filename followed by the extension separator "." +-- followed by a non-empty extension with at least one character in addition to +-- the extension separator. +-- The shortest suffix obtained by this rule, starting with the +-- extension separator, is returned as the extension and the remaining prefix +-- part as the filename. +-- +-- A directory name does not have an extension. +-- +-- If you want a @splitExtensions@, you can use splitExtension until the +-- extension returned is Nothing. @dropExtensions@, @isExtensionOf@ can be +-- implemented similarly. +-- +-- >>> toList (a,b) = (Path.toString a, Path.toString b) +-- >>> split = fmap toList . Path.splitExtension . Path.fromString_ +-- +-- >>> split "/" +-- Nothing +-- +-- >>> split "." +-- Nothing +-- +-- >>> split ".." +-- Nothing +-- +-- >>> split "x" +-- Nothing +-- +-- >>> split "/x" +-- Nothing +-- +-- >>> split "x/" +-- Nothing +-- +-- >>> split "./x" +-- Nothing +-- +-- >>> split "x/." +-- Nothing +-- +-- >>> split "x/y." +-- Nothing +-- +-- >>> split "/x.y" +-- Just ("/x",".y") +-- +-- >>> split "/x.y." +-- Nothing +-- +-- >>> split "/x.y.." +-- Nothing +-- +-- >>> split "x/.y" +-- Nothing +-- +-- >>> split ".x" +-- Nothing +-- +-- >>> split "x." +-- Nothing +-- +-- >>> split ".x.y" +-- Just (".x",".y") +-- +-- >>> split "x/y.z" +-- Just ("x/y",".z") +-- +-- >>> split "x.y.z" +-- Just ("x.y",".z") +-- +-- >>> split "x..y" +-- Just ("x.",".y") +-- +-- >>> split "..." +-- Nothing +-- +-- >>> split "..x" +-- Just (".",".x") +-- +-- >>> split "...x" +-- Just ("..",".x") +-- +-- >>> split "x/y.z/" +-- Nothing +-- +-- >>> split "x/y" +-- Nothing +-- +splitExtension :: OS_PATH_TYPE -> Maybe (OS_PATH_TYPE, OS_PATH_TYPE) +splitExtension (OS_PATH a) = + fmap (bimap OS_PATH OS_PATH) $ Common.splitExtension Common.OS_NAME a +#endif + +-- | Take the extension of a file if it has one. +-- +-- >>> takeExtension = fmap snd . Path.splitExtension +-- >>> hasExtension = isJust . Path.splitExtension +-- +-- >>> fmap Path.toString $ Path.takeExtension [path|/home/user/file.txt|] +-- Just ".txt" +-- +-- See 'splitExtension' for more examples. +takeExtension :: OS_PATH_TYPE -> Maybe OS_PATH_TYPE +takeExtension = fmap snd . splitExtension + +-- | Drop the extension of a file if it has one. +-- +-- >>> dropExtension p = maybe p fst $ Path.splitExtension p +-- +-- >>> Path.toString $ Path.dropExtension [path|/home/user/file.txt|] +-- "/home/user/file" +-- +dropExtension :: OS_PATH_TYPE -> OS_PATH_TYPE +dropExtension orig@(OS_PATH a) = + maybe orig (OS_PATH . fst) $ Common.splitExtension Common.OS_NAME a + +-- | Add an extension to a file path. If a non-empty extension does not start +-- with a leading dot then a dot is inserted, otherwise the extension is +-- concatenated with the path. +-- +-- It is an error to add an extension to a path with a trailing separator. +-- +-- /Unimplemented/ +addExtension :: OS_PATH_TYPE -> OS_PATH_TYPE -> OS_PATH_TYPE +addExtension (OS_PATH _a) = undefined + +-- /Unimplemented/ +replaceExtension :: OS_PATH_TYPE -> OS_PATH_TYPE -> OS_PATH_TYPE +replaceExtension (OS_PATH _a) = undefined + +------------------------------------------------------------------------------ +-- Path View +------------------------------------------------------------------------------ + +-- | Extracts the file name component (with extension) from a OS_PATH_TYPE, if +-- present. +-- +-- >>> takeFileName = fmap snd . Path.splitFile +-- >>> replaceDirectory p x = fmap (flip Path.join x) (takeFileName p) +-- +-- >>> fmap Path.toString $ Path.takeFileName [path|/home/user/file.txt|] +-- Just "file.txt" +-- >>> fmap Path.toString $ Path.takeFileName [path|/home/user/|] +-- Nothing +-- +-- See 'splitFile' for more examples. +-- +takeFileName :: OS_PATH_TYPE -> Maybe OS_PATH_TYPE +takeFileName = fmap snd . splitFile + +-- | Extracts the file name dropping the extension, if any, from a +-- OS_PATH_TYPE. +-- +-- >>> takeFileBase = fmap Path.dropExtension . Path.takeFileName +-- +-- >>> fmap Path.toString $ Path.takeFileBase [path|/home/user/file.txt|] +-- Just "file" +-- >>> fmap Path.toString $ Path.takeFileBase [path|/home/user/file|] +-- Just "file" +-- >>> fmap Path.toString $ Path.takeFileBase [path|/home/user/.txt|] +-- Just ".txt" +-- >>> fmap Path.toString $ Path.takeFileBase [path|/home/user/|] +-- Nothing +-- +-- See 'splitFile' for more examples. +-- +takeFileBase :: OS_PATH_TYPE -> Maybe OS_PATH_TYPE +takeFileBase = fmap dropExtension . takeFileName + +-- | Returns the parent directory of the given OS_PATH_TYPE, if any. +-- +-- >>> takeDirectory x = Path.splitFile x >>= fst +-- >>> replaceFileName p x = fmap (flip Path.join x) (takeDirectory p) +-- +-- To get an equivalent to takeDirectory from filepath use +-- 'dropTrailingSeparators' on the result. +-- +-- >>> fmap Path.toString $ Path.takeDirectory [path|/home/user/file.txt|] +-- Just "/home/user/" +-- >>> fmap Path.toString $ Path.takeDirectory [path|file.txt|] +-- Nothing +-- +takeDirectory :: OS_PATH_TYPE -> Maybe OS_PATH_TYPE +takeDirectory x = splitFile x >>= fst + +------------------------------------------------------------------------------ +-- Path equality +------------------------------------------------------------------------------ + +#ifndef IS_WINDOWS +-- | Default equality check configuration. +-- +-- >>> :{ +-- eqCfg = +-- Path.ignoreTrailingSeparators False +-- . Path.ignoreCase False +-- . Path.allowRelativeEquality False +-- :} +-- +#else +-- | Default equality check configuration. +-- +-- >>> :{ +-- eqCfg = +-- Path.ignoreTrailingSeparators False +-- . Path.ignoreCase True +-- . Path.allowRelativeEquality False +-- :} +-- +#endif +eqCfg :: EqCfg +eqCfg = Common.EqCfg + { _ignoreTrailingSeparators = False + , _allowRelativeEquality = False +#ifndef IS_WINDOWS + , _ignoreCase = False +#else + , _ignoreCase = True +#endif + } + +-- | When set to 'False' (default): +-- +-- >>> cfg = Path.ignoreTrailingSeparators False +-- >>> eq a b = Path.eqPath cfg (Path.fromString_ a) (Path.fromString_ b) +-- +-- >>> eq "x/" "x" +-- False +-- +-- When set to 'True': +-- +-- >>> cfg = Path.ignoreTrailingSeparators True +-- >>> eq a b = Path.eqPath cfg (Path.fromString_ a) (Path.fromString_ b) +-- +-- >>> eq "x/" "x" +-- True +-- +-- /Default/: False +ignoreTrailingSeparators :: Bool -> EqCfg -> EqCfg +ignoreTrailingSeparators val conf = conf { _ignoreTrailingSeparators = val } + +-- | When set to 'False', comparison is case sensitive. +-- +-- /Posix Default/: False +-- +-- /Windows Default/: True +ignoreCase :: Bool -> EqCfg -> EqCfg +ignoreCase val conf = conf { _ignoreCase = val } + +-- Note: ignoreLeadingDot or similar names are not good because we want to +-- convey that when it is False "./x" and "./x" are not strictly equal. +-- Similarly, "treatDotRootsEqual" has a problem with the "./x" and "x" +-- comparison, there is not dor root in the second path. + +-- | Allow relative paths to be treated as equal. When this is 'False' relative +-- paths will never match even if they are literally equal e.g. "./x" will not +-- match "./x" because the meaning of "." in both cases could be different +-- depending on what the user meant by current directory in each case. +-- +-- When set to 'False' (default): +-- +-- >>> cfg = Path.allowRelativeEquality False +-- >>> eq a b = Path.eqPath cfg (Path.fromString_ a) (Path.fromString_ b) +-- >>> eq "." "." +-- False +-- >>> eq "./x" "./x" +-- False +-- >>> eq "./x" "x" +-- False +-- +-- When set to 'False' (default): +-- +-- >>> cfg = Path.allowRelativeEquality True +-- >>> eq a b = Path.eqPath cfg (Path.fromString_ a) (Path.fromString_ b) +-- >>> eq "." "." +-- True +-- >>> eq "./x" "./x" +-- True +-- >>> eq "./x" "x" +-- True +-- +-- >>> eq "./x" "././x" +-- True +-- +-- /Default/: False +allowRelativeEquality :: Bool -> EqCfg -> EqCfg +allowRelativeEquality val conf = conf { _allowRelativeEquality = val } + +#ifndef IS_WINDOWS +-- | Checks whether two paths are logically equal. This function takes a +-- configuration modifier to customize the notion of equality. For using the +-- default configuration pass 'id' as the modifier. For details about the +-- defaults, see 'EqCfg'. +-- +-- eqPath performs some normalizations on the paths before comparing them, +-- specifically it drops redundant path separators between path segments and +-- redundant "\/.\/" components between segments. +-- +-- Default config options use strict equality, for strict equality both the +-- paths must be absolute or both must be path segments without a leading root +-- component (e.g. x\/y). Also, both must be files or both must be directories. +-- +-- In addition to the default config options, the following equality semantics +-- are used: +-- +-- * An absolute path and a path relative to "." may be equal depending on the +-- meaning of ".", however this routine treats them as unequal, it does not +-- resolve the "." to a concrete path. +-- +-- * Two paths having ".." components may be equal after processing the ".." +-- components even if we determined them to be unequal. However, if we +-- determined them to be equal then they must be equal. +-- +-- Using default config with case sensitive comparision, if eqPath returns +-- equal then the paths are definitely equal, if it returns unequal then the +-- paths may still be equal under some relaxed equality criterion. +-- +-- >>> :{ +-- eq a b = Path.eqPath id (Path.fromString_ a) (Path.fromString_ b) +-- :} +-- +-- >>> eq "x" "x" +-- True +-- >>> eq ".." ".." +-- True +-- +-- Non-trailing separators and non-leading "." segments are ignored: +-- +-- >>> eq "/x" "//x" +-- True +-- >>> eq "x//y" "x/y" +-- True +-- >>> eq "x/./y" "x/y" +-- True +-- >>> eq "x/y/." "x/y" +-- True +-- +-- Leading dot, relative paths are not equal by default: +-- +-- >>> eq "." "." +-- False +-- >>> eq "./x" "./x" +-- False +-- >>> eq "./x" "x" +-- False +-- +-- Trailing separators are significant by default: +-- +-- >>> eq "x/" "x" +-- False +-- +-- Match is case sensitive by default: +-- +-- >>> eq "x" "X" +-- False +-- +eqPath :: (EqCfg -> EqCfg) -> OS_PATH_TYPE -> OS_PATH_TYPE -> Bool +eqPath cfg (OS_PATH a) (OS_PATH b) = + Common.eqPath Unicode.UNICODE_DECODER + Common.OS_NAME (cfg eqCfg) a b +#endif + +-- | Check two paths for byte level equality. This is the most strict path +-- equality check. +-- +-- >>> eqPath a b = Path.eqPathBytes (Path.fromString_ a) (Path.fromString_ b) +-- +-- >>> eqPath "x//y" "x//y" +-- True +-- +-- >>> eqPath "x//y" "x/y" +-- False +-- +-- >>> eqPath "x/./y" "x/y" +-- False +-- +-- >>> eqPath "x\\y" "x/y" +-- False +-- +-- >>> eqPath "./file" "file" +-- False +-- +-- >>> eqPath "file/" "file" +-- False +-- +eqPathBytes :: OS_PATH_TYPE -> OS_PATH_TYPE -> Bool +eqPathBytes (OS_PATH a) (OS_PATH b) = Common.eqPathBytes a b + +-- | Convert the path to an equivalent but standard format for reliable +-- comparison. This can be implemented if required. Usually, the equality +-- operations should be enough and this may not be needed. +-- +-- /Unimplemented/ +normalize :: EqCfg -> OS_PATH_TYPE -> OS_PATH_TYPE +normalize _cfg (OS_PATH _a) = undefined diff --git a/src/Streamly/Internal/FileSystem/PosixPath/Node.hs b/src/Streamly/Internal/FileSystem/PosixPath/Node.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/PosixPath/Node.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TemplateHaskell #-} +-- For constraints on "append" +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +#if defined(IS_WINDOWS) +#define OS_NAME Windows +#define OS_PATH WindowsPath +#else +#define OS_NAME Posix +#define OS_PATH PosixPath +#endif + +-- | +-- Module : Streamly.Internal.FileSystem.OS_PATH.Node +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- This module provides a type safe path append operation by distinguishing +-- paths between files and directories. Files are represented by the @File +-- OS_PATH@ type and directories are represented by the @Dir OS_PATH@ type. +-- +-- This distinction provides safety against appending a path to a file. Append +-- operation allows appending to only 'Dir' types. +-- +module Streamly.Internal.FileSystem.OS_PATH.Node + ( + -- * Types + File (..) + , Dir (..) + , IsNode + + -- * Statically Verified Path Literals + -- | Quasiquoters. + , dir + , file + + -- * Statically Verified Path Strings + -- | Template Haskell expression splices. + , dirE + , fileE + + -- * Operations + , join + ) +where + +import Control.Monad ((>=>)) +import Language.Haskell.TH (Q, Exp) +import Language.Haskell.TH.Syntax (lift) +import Language.Haskell.TH.Quote (QuasiQuoter) +import Streamly.Internal.Data.Path (IsPath(..)) +import Streamly.Internal.FileSystem.Path.Common (OS(..), mkQ) +import Streamly.Internal.FileSystem.OS_PATH (OS_PATH(..)) + +import qualified Streamly.Internal.FileSystem.Path.Common as Common +import qualified Streamly.Internal.FileSystem.OS_PATH as OsPath + +{- $setup +>>> :m +>>> :set -XQuasiQuotes + +For APIs that have not been released yet. + +>>> import Streamly.Internal.FileSystem.PosixPath (PosixPath) +>>> import Streamly.Internal.FileSystem.PosixPath.Node (File, Dir, file, dir) +>>> import qualified Streamly.Internal.FileSystem.PosixPath as Path +>>> import qualified Streamly.Internal.FileSystem.PosixPath.Node as Node +-} + +newtype File a = File a +newtype Dir a = Dir a + +-- | Constraint to check if a type uses 'File' or 'Dir' as the outermost +-- constructor. +class IsNode a + +instance IsNode (File a) +instance IsNode (Dir a) + +instance IsPath OS_PATH (File OS_PATH) where + unsafeFromPath = File + + fromPath p@(OS_PATH arr) = do + !_ <- Common.validateFile OS_NAME arr + pure $ File p + + toPath (File p) = p + +instance IsPath OS_PATH (Dir OS_PATH) where + unsafeFromPath = Dir + fromPath p = pure (Dir p) + toPath (Dir p) = p + +------------------------------------------------------------------------------ +-- Statically Verified Strings +------------------------------------------------------------------------------ + +-- XXX We can lift the array directly, ByteArray has a lift instance. Does that +-- work better? + +liftDir :: Dir OS_PATH -> Q Exp +liftDir (Dir p) = + [| unsafeFromPath (OsPath.unsafeFromString $(lift $ OsPath.toString $ toPath p)) :: Dir OS_PATH |] + +liftFile :: File OS_PATH -> Q Exp +liftFile (File p) = + [| unsafeFromPath (OsPath.unsafeFromString $(lift $ OsPath.toString $ toPath p)) :: File OS_PATH |] + +-- | Generates a Haskell expression of type @Dir OS_PATH@. +-- +dirE :: String -> Q Exp +dirE = either (error . show) liftDir . (OsPath.fromString >=> fromPath) + +-- | Generates a Haskell expression of type @File OS_PATH@. +-- +fileE :: String -> Q Exp +fileE = either (error . show) liftFile . (OsPath.fromString >=> fromPath) + +------------------------------------------------------------------------------ +-- Statically Verified Literals +------------------------------------------------------------------------------ + +-- XXX Define folds or parsers to parse the paths. +-- XXX Build these on top of the str quasiquoter so that we get interpolation +-- for free. Interpolated vars if any have to be of appropriate type depending +-- on the context so that we can splice them safely. + +-- | Generates a @Dir OS_PATH@ type from a quoted literal. +-- +-- >>> Path.toString (Path.toPath ([dir|usr|] :: Dir PosixPath)) +-- "usr" +-- +dir :: QuasiQuoter +dir = mkQ dirE + +-- | Generates a @File OS_PATH@ type from a quoted literal. +-- +-- >>> Path.toString (Path.toPath ([file|usr|] :: File PosixPath)) +-- "usr" +-- +file :: QuasiQuoter +file = mkQ fileE + +-- The only safety we need for paths is: (1) The first path can only be a Dir +-- type path, and (2) second path can only be a Seg path. + +-- | Append a 'Dir' or 'File' path to a 'Dir' path. +-- +-- >>> Path.toString (Path.toPath (Node.join [dir|/usr|] [dir|bin|] :: Dir PosixPath)) +-- "/usr/bin" +-- >>> Path.toString (Path.toPath (Node.join [dir|/usr|] [file|bin|] :: File PosixPath)) +-- "/usr/bin" +-- +-- Fails if the second path is a specific location and not a path segment. +-- +{-# INLINE join #-} +join :: (IsPath OS_PATH (a OS_PATH), IsNode (a OS_PATH)) => + Dir OS_PATH -> a OS_PATH -> a OS_PATH +join (Dir a) b = + unsafeFromPath $ OsPath.unsafeJoin (toPath a) (toPath b) diff --git a/src/Streamly/Internal/FileSystem/PosixPath/Seg.hs b/src/Streamly/Internal/FileSystem/PosixPath/Seg.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/PosixPath/Seg.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE TemplateHaskell #-} +-- For constraints on "append" +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +#if defined(IS_WINDOWS) +#define OS_NAME Windows +#define OS_PATH WindowsPath +#else +#define OS_NAME Posix +#define OS_PATH PosixPath +#endif + +-- | +-- Module : Streamly.Internal.FileSystem.OS_PATH.Seg +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- This module provides a type safe path append operation by distinguishing +-- paths between rooted paths and branches. Rooted paths are represented by the +-- @Rooted OS_PATH@ type and branches are represented by the @Unrooted OS_PATH@ +-- type. Rooted paths are paths that are attached to specific roots in the file +-- system. Rooted paths could be absolute or relative e.g. @\/usr\/bin@, +-- @.\/local\/bin@, or @.@. Unrootedes are a paths that are not attached to a +-- specific root e.g. @usr\/bin@, @local\/bin@, or @../bin@ are branches. +-- +-- This distinction provides a safe path append operation which cannot fail. +-- These types do not allow appending a rooted path to any other path. Only +-- branches can be appended. +-- +module Streamly.Internal.FileSystem.OS_PATH.Seg + ( + -- * Types + Rooted (..) + , Unrooted (..) + , IsSeg + + -- * Statically Verified Path Literals + -- | Quasiquoters. + , rt + , ur + + -- * Statically Verified Path Strings + -- | Template Haskell expression splices. + , rtE + , urE + + -- * Operations + , join + ) +where + +import Control.Monad ((>=>)) +import Control.Monad.Catch (MonadThrow(..)) +import Language.Haskell.TH (Q, Exp) +import Language.Haskell.TH.Syntax (lift) +import Language.Haskell.TH.Quote (QuasiQuoter) +import Streamly.Internal.Data.Path (IsPath(..), PathException(..)) +import Streamly.Internal.FileSystem.Path.Common (mkQ) +import Streamly.Internal.FileSystem.OS_PATH (OS_PATH(..)) + +import qualified Streamly.Internal.FileSystem.OS_PATH as OsPath + +{- $setup +>>> :m +>>> :set -XQuasiQuotes + +For APIs that have not been released yet. + +>>> import Streamly.Internal.FileSystem.PosixPath (PosixPath) +>>> import Streamly.Internal.FileSystem.PosixPath.Seg (Rooted, Unrooted, rt, ur) +>>> import qualified Streamly.Internal.FileSystem.PosixPath as Path +>>> import qualified Streamly.Internal.FileSystem.PosixPath.Seg as Seg +-} + +newtype Rooted a = Rooted a +newtype Unrooted a = Unrooted a + +instance IsPath OS_PATH (Rooted OS_PATH) where + unsafeFromPath = Rooted + fromPath p = + if OsPath.isRooted p + then pure (Rooted p) + -- XXX Add more detailed error msg with all valid examples. + else throwM $ InvalidPath + $ "Must be a specific location, not a path segment: " + ++ OsPath.toString p + toPath (Rooted p) = p + +instance IsPath OS_PATH (Unrooted OS_PATH) where + unsafeFromPath = Unrooted + fromPath p = + if OsPath.isUnrooted p + then pure (Unrooted p) + -- XXX Add more detailed error msg with all valid examples. + else throwM $ InvalidPath + $ "Must be a path segment, not a specific location: " + ++ OsPath.toString p + toPath (Unrooted p) = p + +-- | Constraint to check if a type has Rooted or Unrooted annotations. +class IsSeg a + +instance IsSeg (Rooted a) +instance IsSeg (Unrooted a) + +------------------------------------------------------------------------------ +-- Statically Verified Strings +------------------------------------------------------------------------------ + +liftRooted :: Rooted OS_PATH -> Q Exp +liftRooted (Rooted p) = + [| unsafeFromPath (OsPath.unsafeFromString $(lift $ OsPath.toString $ toPath p)) :: Rooted OS_PATH |] + +liftUnrooted :: Unrooted OS_PATH -> Q Exp +liftUnrooted (Unrooted p) = + [| unsafeFromPath (OsPath.unsafeFromString $(lift $ OsPath.toString $ toPath p)) :: Unrooted OS_PATH |] + +-- | Generates a Haskell expression of type @Rooted OS_PATH@. +-- +rtE :: String -> Q Exp +rtE = either (error . show) liftRooted . (OsPath.fromString >=> fromPath) + +-- | Generates a Haskell expression of type @Unrooted OS_PATH@. +-- +urE :: String -> Q Exp +urE = either (error . show) liftUnrooted . (OsPath.fromString >=> fromPath) + +------------------------------------------------------------------------------ +-- Statically Verified Literals +------------------------------------------------------------------------------ + +-- XXX Define folds or parsers to parse the paths. +-- XXX Build these on top of the str quasiquoter so that we get interpolation +-- for free. Interpolated vars if any have to be of appropriate type depending +-- on the context so that we can splice them safely. + +-- | Generates a @Rooted Path@ type from a quoted literal. +-- +-- >>> Path.toString (Path.toPath ([rt|/usr|] :: Rooted PosixPath)) +-- "/usr" +-- +rt :: QuasiQuoter +rt = mkQ rtE + +-- | Generates a @Unrooted Path@ type from a quoted literal. +-- +-- >>> Path.toString (Path.toPath ([ur|usr|] :: Unrooted PosixPath)) +-- "usr" +-- +ur :: QuasiQuoter +ur = mkQ urE + +-- The only safety we need for paths is: (1) The first path can only be a Dir +-- type path, and (2) second path can only be a Unrooted path. + +-- | Append a 'Unrooted' type path to a 'Rooted' path or 'Unrooted' path. +-- +-- >>> Path.toString (Path.toPath (Seg.join [rt|/usr|] [ur|bin|] :: Rooted PosixPath)) +-- "/usr/bin" +-- >>> Path.toString (Path.toPath (Seg.join [ur|usr|] [ur|bin|] :: Unrooted PosixPath)) +-- "usr/bin" +-- +{-# INLINE join #-} +join :: + ( + IsSeg (a OS_PATH) + , IsPath OS_PATH (a OS_PATH) + ) => a OS_PATH -> Unrooted OS_PATH -> a OS_PATH +join a (Unrooted c) = + unsafeFromPath $ OsPath.unsafeJoin (toPath a) (toPath c) diff --git a/src/Streamly/Internal/FileSystem/PosixPath/SegNode.hs b/src/Streamly/Internal/FileSystem/PosixPath/SegNode.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/PosixPath/SegNode.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE TemplateHaskell #-} +-- For constraints on "join" +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +#if defined(IS_WINDOWS) +#define OS_NAME Windows +#define OS_PATH WindowsPath +#else +#define OS_NAME Posix +#define OS_PATH PosixPath +#endif + +-- | +-- Module : Streamly.Internal.FileSystem.OS_PATH.SegNode +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- When @Rooted/Unrooted@ and @File/Dir@ both are present, @Rooted/Unrooted@ must be +-- outermost constructors and @File/Dir@ as inner. Thus the types File (Rooted +-- a) or Dir (Rooted a) are not allowed but Rooted (Dir a) and Rooted (File a) are +-- allowed. + +module Streamly.Internal.FileSystem.OS_PATH.SegNode + ( + -- * Statically Verified Path Literals + -- | Quasiquoters. + rtdir + , urdir + , rtfile + , urfile + + -- * Statically Verified Path Strings + -- | Template Haskell expression splices. + , rtdirE + , urdirE + , rtfileE + , urfileE + + -- * Operations + , join + ) +where + +import Control.Monad ((>=>)) +import Language.Haskell.TH.Syntax (lift) +import Streamly.Internal.FileSystem.Path.Common (mkQ) +import Streamly.Internal.FileSystem.OS_PATH (OS_PATH(..)) +import Streamly.Internal.FileSystem.OS_PATH.Seg (Rooted(..), Unrooted(..)) +import Streamly.Internal.FileSystem.OS_PATH.Node (File(..), Dir(..)) + +import qualified Streamly.Internal.FileSystem.OS_PATH as OsPath + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Streamly.Internal.Data.Path + +{- $setup +>>> :m +>>> :set -XQuasiQuotes + +For APIs that have not been released yet. + +>>> import Streamly.Internal.FileSystem.PosixPath (PosixPath) +>>> import Streamly.Internal.FileSystem.PosixPath.Node (Dir, File, dir, file) +>>> import Streamly.Internal.FileSystem.PosixPath.Seg (Rooted, Unrooted, rt, ur) +>>> import Streamly.Internal.FileSystem.PosixPath.SegNode (rtdir, urdir, rtfile, urfile) +>>> import qualified Streamly.Internal.FileSystem.PosixPath as Path +>>> import qualified Streamly.Internal.FileSystem.PosixPath.SegNode as SegNode +-} + +-- Note that (Rooted a) may also be a directory if "a" is (Dir b), but it can also +-- be a file if "a" is (File b). Therefore, the constraints are put on a more +-- specific type e.g. (Rooted OS_PATH) may be a dir. + +{- +-- | Constraint to check if a type represents a directory. +class HasDir a + +instance HasDir (Dir a) +instance HasDir (Rooted (Dir a)) +instance HasDir (Unrooted (Dir a)) +-} + +-- Design notes: +-- +-- There are two ways in which we can lift or upgrade a lower level path to a +-- higher level one. Lift each type directly from the base path e.g. Rooted (Dir +-- PosixPath) can be created directly from PosixPath. This allows us to do dir +-- checks and loc checks at the same time in a monolithic manner. But this also +-- makes us do the Dir checks again if we are lifting from Dir to Rooted. This +-- leads to less complicated constraints, more convenient type conversions. +-- +-- Another alternative is to lift one segment at a time, so we lift PosixPath +-- to Dir and then Dir to Rooted. This way the checks are serialized, we perform +-- the dir checks first and then Rooted checks, we cannot combine them together. +-- The advantage is that when lifting from Dir to Rooted we do not need to do the +-- Dir checks. The disadvantage is less convenient conversion because of +-- stronger typing, we will need two steps - fromPath . fromPath and toPath . +-- toPath to upgrade or downgrade instead of just adapt. +-- +{- +instance IsPath (File OS_PATH) (Rooted (File OS_PATH)) where + unsafeFromPath = Rooted + fromPath (File p) = do + _ :: Rooted OS_PATH <- fromPath p + pure $ Rooted (File p) + toPath (Rooted p) = p + +instance IsPath (Rooted OS_PATH) (Rooted (File OS_PATH)) where + unsafeFromPath = Rooted + fromPath (File p) = do + _ :: File OS_PATH <- fromPath p + pure $ Rooted (File p) + toPath (Rooted p) = p +-} + +-- Assuming that lifting from Dir/File to Rooted/Unrooted is not common and even if it +-- is then the combined cost of doing Dir/Rooted checks would be almost the same +-- as individual checks, we take the first approach. + +instance IsPath OS_PATH (Rooted (File OS_PATH)) where + unsafeFromPath p = Rooted (File p) + fromPath p = do + _ :: File OS_PATH <- fromPath p + _ :: Rooted OS_PATH <- fromPath p + pure $ Rooted (File p) + toPath (Rooted (File p)) = p + +instance IsPath OS_PATH (Rooted (Dir OS_PATH)) where + unsafeFromPath p = Rooted (Dir p) + fromPath p = do + _ :: Dir OS_PATH <- fromPath p + _ :: Rooted OS_PATH <- fromPath p + pure $ Rooted (Dir p) + toPath (Rooted (Dir p)) = p + +instance IsPath OS_PATH (Unrooted (File OS_PATH)) where + unsafeFromPath p = Unrooted (File p) + fromPath p = do + _ :: File OS_PATH <- fromPath p + _ :: Unrooted OS_PATH <- fromPath p + pure $ Unrooted (File p) + toPath (Unrooted (File p)) = p + +instance IsPath OS_PATH (Unrooted (Dir OS_PATH)) where + unsafeFromPath p = Unrooted (Dir p) + fromPath p = do + _ :: Dir OS_PATH <- fromPath p + _ :: Unrooted OS_PATH <- fromPath p + pure $ Unrooted (Dir p) + toPath (Unrooted (Dir p)) = p + +------------------------------------------------------------------------------ +-- Statically Verified Strings +------------------------------------------------------------------------------ + +-- XXX We can lift the array directly, ByteArray has a lift instance. Does that +-- work better? + +liftRootedDir :: Rooted (Dir OS_PATH) -> Q Exp +liftRootedDir (Rooted (Dir p)) = + [| unsafeFromPath (OsPath.unsafeFromString $(lift $ OsPath.toString $ toPath p)) :: Rooted (Dir OS_PATH)|] + +liftUnrootedDir :: Unrooted (Dir OS_PATH) -> Q Exp +liftUnrootedDir (Unrooted (Dir p)) = + [| unsafeFromPath (OsPath.unsafeFromString $(lift $ OsPath.toString $ toPath p)) :: Unrooted (Dir OS_PATH) |] + +liftRootedFile :: Rooted (File OS_PATH) -> Q Exp +liftRootedFile (Rooted (File p)) = + [| unsafeFromPath (OsPath.unsafeFromString $(lift $ OsPath.toString $ toPath p)) :: Rooted (File OS_PATH)|] + +liftUnrootedFile :: Unrooted (File OS_PATH) -> Q Exp +liftUnrootedFile (Unrooted (File p)) = + [| unsafeFromPath (OsPath.unsafeFromString $(lift $ OsPath.toString $ toPath p)) :: Unrooted (File OS_PATH)|] + +-- | Generates a Haskell expression of type @Rooted (Dir OS_PATH)@. +-- +rtdirE :: String -> Q Exp +rtdirE = either (error . show) liftRootedDir . (OsPath.fromString >=> fromPath) + +-- | Generates a Haskell expression of type @Unrooted (Dir OS_PATH)@. +-- +urdirE :: String -> Q Exp +urdirE = either (error . show) liftUnrootedDir . (OsPath.fromString >=> fromPath) + +-- | Generates a Haskell expression of type @Rooted (File OS_PATH)@. +-- +rtfileE :: String -> Q Exp +rtfileE = either (error . show) liftRootedFile . (OsPath.fromString >=> fromPath) + +-- | Generates a Haskell expression of type @Unrooted (File OS_PATH)@. +-- +urfileE :: String -> Q Exp +urfileE = either (error . show) liftUnrootedFile . (OsPath.fromString >=> fromPath) + +------------------------------------------------------------------------------ +-- Statically Verified Literals +------------------------------------------------------------------------------ + +-- XXX Define folds or parsers to parse the paths. +-- XXX Build these on top of the str quasiquoter so that we get interpolation +-- for free. Interpolated vars if any have to be of appropriate type depending +-- on the context so that we can splice them safely. + +-- | Generates a @Rooted (Dir OS_PATH)@ type from a quoted literal. +-- +-- >>> Path.toString (Path.toPath ([rtdir|/usr|] :: Rooted (Dir PosixPath))) +-- "/usr" +-- +rtdir :: QuasiQuoter +rtdir = mkQ rtdirE + +-- | Generates a @Unrooted (Dir OS_PATH)@ type from a quoted literal. +-- +-- >>> Path.toString (Path.toPath ([urdir|usr|] :: Unrooted (Dir PosixPath))) +-- "usr" +-- +urdir :: QuasiQuoter +urdir = mkQ urdirE + +-- | Generates a @Rooted (File OS_PATH)@ type from a quoted literal. +-- +-- >>> Path.toString (Path.toPath ([rtfile|/x.txt|] :: Rooted (File PosixPath))) +-- "/x.txt" +-- +rtfile :: QuasiQuoter +rtfile = mkQ rtfileE + +-- | Generates a @Unrooted (File OS_PATH)@ type from a quoted literal. +-- +-- >>> Path.toString (Path.toPath ([urfile|x.txt|] :: Unrooted (File PosixPath))) +-- "x.txt" +-- +urfile :: QuasiQuoter +urfile = mkQ urfileE + +-- The only safety we need for paths is: (1) The first path can only be a Dir +-- type path, and (2) second path can only be a Unrooted path. + +{- +-- If the first path is 'Rooted' then the return type is also 'Rooted'. +-- +-- If the second path does not have 'File' or 'Dir' information then the return +-- type too cannot have it. +-- +-- >> Path.toString (Path.toPath (SegNode.join [rtdir|/usr|] [br|bin|] :: Rooted PosixPath)) +-- "/usr/bin" +-- >> Path.toString (Path.toPath (SegNode.join [urdir|usr|] [br|bin|] :: Unrooted PosixPath)) +-- "usr/bin" +-- +-- >> Path.toString (Path.toPath (SegNode.join [rt|/usr|] [br|bin|] :: Rooted PosixPath)) +-- "/usr/bin" +-- >> Path.toString (Path.toPath (SegNode.join [br|usr|] [br|bin|] :: Unrooted PosixPath)) +-- "usr/bin" +-- +-- If the second path has 'File' or 'Dir' information then the return type +-- also has it. +-- +-- >> Path.toString (Path.toPath (SegNode.join [rt|/usr|] [urdir|bin|] :: Rooted (Dir PosixPath))) +-- "/usr/bin" +-- >> Path.toString (Path.toPath (SegNode.join [rt|/usr|] [urfile|bin|] :: Rooted (File PosixPath))) +-- "/usr/bin" +-- >> Path.toString (Path.toPath (SegNode.join [br|usr|] [urdir|bin|] :: Unrooted (Dir PosixPath))) +-- "usr/bin" +-- >> Path.toString (Path.toPath (SegNode.join [br|usr|] [urfile|bin|] :: Unrooted (File PosixPath))) +-- "usr/bin" +-- +-- Type error cases: +-- +-- >> SegNode.join [dir|/usr|] [br|bin|] -- first arg must be Rooted/Unrooted +-- >> SegNode.join [file|/usr|] [br|bin|] -- first arg must be Rooted/Unrooted +-- >> SegNode.join [rtfile|/usr|] [br|bin|] -- first arg must be a dir +-- >> SegNode.join [rt|/usr|] [rt|/bin|] -- second arg must be seg +-- >> SegNode.join [rt|/usr|] [dir|bin|] -- second arg must be seg +-- >> SegNode.join [rt|/usr|] [file|bin|] -- second arg must be seg +-- +{-# INLINE join #-} +join :: + ( + IsSeg (a b) + , HasDir (a b) + , IsPath OS_PATH (a b) + , IsPath OS_PATH c + , IsPath OS_PATH (a c) + ) => a b -> Unrooted c -> a c +join a (Unrooted c) = unsafeFromPath $ OS_NAME.unsafeJoin (toPath a) (toPath c) +-} + +-- | Append a branch type path to a directory. +-- +-- >>> Path.toString (Path.toPath (SegNode.join [rtdir|/usr|] [urdir|bin|] :: Rooted (Dir PosixPath))) +-- "/usr/bin" +-- >>> Path.toString (Path.toPath (SegNode.join [rtdir|/usr|] [urfile|bin|] :: Rooted (File PosixPath))) +-- "/usr/bin" +-- >>> Path.toString (Path.toPath (SegNode.join [urdir|usr|] [urdir|bin|] :: Unrooted (Dir PosixPath))) +-- "usr/bin" +-- >>> Path.toString (Path.toPath (SegNode.join [urdir|usr|] [urfile|bin|] :: Unrooted (File PosixPath))) +-- "usr/bin" +-- +{-# INLINE join #-} +join :: + ( + IsPath OS_PATH (a (Dir OS_PATH)) + , IsPath OS_PATH (b OS_PATH) + , IsPath OS_PATH (a (b OS_PATH)) + ) => a (Dir OS_PATH) -> Unrooted (b OS_PATH) -> a (b OS_PATH) +join p1 (Unrooted p2) = + unsafeFromPath $ OsPath.unsafeJoin (toPath p1) (toPath p2) diff --git a/src/Streamly/Internal/FileSystem/Windows/File.hsc b/src/Streamly/Internal/FileSystem/Windows/File.hsc new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -0,0 +1,202 @@ +-- XXX When introducing platform specifc API, see Posix/File.hsc and design in +-- the same consistent way. +module Streamly.Internal.FileSystem.Windows.File + ( +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + -- * Handle based + openFile + , withFile + , openBinaryFile + , withBinaryFile +#endif + ) where + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Control.Concurrent (threadDelay) +import Control.Exception (onException) +import Control.Monad (when, void) +import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) +import System.IO (IOMode(..), Handle) + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem +#else +import GHC.IO.Handle.FD (fdToHandle') +#include +#endif + +import qualified Streamly.Internal.FileSystem.File.Common as File +import qualified Streamly.Internal.FileSystem.WindowsPath as Path + +import Data.Bits +import Foreign.Ptr +import System.Win32 as Win32 hiding (createFile, failIfWithRetry) + +#include + +------------------------------------------------------------------------------- +-- Low level (fd returning) file opening APIs +------------------------------------------------------------------------------- + +-- XXX Note for i386, stdcall is needed instead of ccall, see Win32 +-- package/windows_cconv.h. We support only x86_64 for now. +foreign import ccall unsafe "windows.h CreateFileW" + c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE + +-- | like failIf, but retried on sharing violations. This is necessary for many +-- file operations; see +-- https://www.betaarchive.com/wiki/index.php/Microsoft_KB_Archive/316609 +-- +failIfWithRetry :: (a -> Bool) -> String -> IO a -> IO a +failIfWithRetry needRetry msg action = retryOrFail retries + + where + + delay = 100 * 1000 -- 100 ms + + -- KB article recommends 250/5 + retries = 20 :: Int + + -- retryOrFail :: Int -> IO a + retryOrFail times + | times <= 0 = errorWin msg + | otherwise = do + ret <- action + if not (needRetry ret) + then return ret + else do + err_code <- getLastError + if err_code == 32 + then do + threadDelay delay + retryOrFail (times - 1) + else errorWin msg + +createFile :: + WindowsPath + -> AccessMode + -> ShareMode + -> Maybe LPSECURITY_ATTRIBUTES + -> CreateMode + -> FileAttributeOrFlag + -> Maybe Win32.HANDLE + -> IO Win32.HANDLE +createFile name access share mb_attr mode flag mb_h = + Path.asCWString name $ \c_name -> + failIfWithRetry + (== iNVALID_HANDLE_VALUE) + (unwords ["CreateFile", Path.toString name]) + $ c_CreateFile + c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) + +win2HsHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle +win2HsHandle _fp _iomode h = do +#if defined(__IO_MANAGER_WINIO__) + Win32.hANDLEToHandle h +#else + fd <- _open_osfhandle (fromIntegral (ptrToIntPtr h)) (#const _O_BINARY) + fdToHandle' fd Nothing False (Path.toString _fp) _iomode True +#endif + +fdToHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle +fdToHandle fp iomode h = + win2HsHandle fp iomode h `onException` Win32.closeHandle h + +openFileFd :: Bool -> WindowsPath -> IOMode -> IO Win32.HANDLE +openFileFd existing fp iomode = do + h <- createFile + fp + accessMode + shareMode + Nothing + (if existing then createModeExisting else createMode) + fileAttr + Nothing + when (iomode == AppendMode ) + $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END + return h + + where + + accessMode = + case iomode of + ReadMode -> Win32.gENERIC_READ + WriteMode -> Win32.gENERIC_WRITE + AppendMode -> Win32.gENERIC_WRITE .|. Win32.fILE_APPEND_DATA + ReadWriteMode -> Win32.gENERIC_READ .|. Win32.gENERIC_WRITE + + writeShareMode :: ShareMode + writeShareMode = + Win32.fILE_SHARE_DELETE + .|. Win32.fILE_SHARE_READ + + maxShareMode :: ShareMode + maxShareMode = + Win32.fILE_SHARE_DELETE + .|. Win32.fILE_SHARE_READ + .|. Win32.fILE_SHARE_WRITE + + shareMode = + case iomode of + ReadMode -> Win32.fILE_SHARE_READ + WriteMode -> writeShareMode + AppendMode -> writeShareMode + ReadWriteMode -> maxShareMode + + createMode = + case iomode of + ReadMode -> Win32.oPEN_EXISTING + WriteMode -> Win32.cREATE_ALWAYS + AppendMode -> Win32.oPEN_ALWAYS + ReadWriteMode -> Win32.oPEN_ALWAYS + + createModeExisting = + case iomode of + ReadMode -> Win32.oPEN_EXISTING + WriteMode -> Win32.tRUNCATE_EXISTING + AppendMode -> Win32.oPEN_EXISTING + ReadWriteMode -> Win32.oPEN_EXISTING + + fileAttr = +#if defined(__IO_MANAGER_WINIO__) + (case ioSubSystem of + IoPOSIX -> Win32.fILE_ATTRIBUTE_NORMAL + IoNative -> Win32.fILE_ATTRIBUTE_NORMAL .|. Win32.fILE_FLAG_OVERLAPPED + ) +#else + Win32.fILE_ATTRIBUTE_NORMAL +#endif + +------------------------------------------------------------------------------- +-- base openFile compatible, Handle returning, APIs +------------------------------------------------------------------------------- + +-- | Open a regular file, return a Handle. The file is locked, the Handle is +-- NOT set up to close the file on garbage collection. +{-# INLINE openFileHandle #-} +openFileHandle :: WindowsPath -> IOMode -> IO Handle +openFileHandle p x = openFileFd False p x >>= fdToHandle p x + +-- | Like withFile in base package but using Path instead of FilePath. +-- Use hSetBinaryMode on the handle if you want to use binary mode. +withFile :: WindowsPath -> IOMode -> (Handle -> IO r) -> IO r +withFile = File.withFile False openFileHandle + +-- | Like openFile in base package but using Path instead of FilePath. +-- Use hSetBinaryMode on the handle if you want to use binary mode. +openFile :: WindowsPath -> IOMode -> IO Handle +openFile = File.openFile False openFileHandle + +-- | Like withBinaryFile in base package but using Path instead of FilePath. +withBinaryFile :: WindowsPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile = File.withFile True openFileHandle + +-- | Like openBinaryFile in base package but using Path instead of FilePath. +openBinaryFile :: WindowsPath -> IOMode -> IO Handle +openBinaryFile = File.openFile True openFileHandle +#endif diff --git a/src/Streamly/Internal/FileSystem/Windows/ReadDir.hsc b/src/Streamly/Internal/FileSystem/Windows/ReadDir.hsc new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Windows/ReadDir.hsc @@ -0,0 +1,273 @@ +-- | +-- Module : Streamly.Internal.FileSystem.Windows.ReadDir +-- Copyright : (c) 2024 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC + +module Streamly.Internal.FileSystem.Windows.ReadDir + ( +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + DirStream + , openDirStream + , closeDirStream + , readDirStreamEither + , eitherReader + , reader +#endif + ) +where + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + +import Control.Exception (throwIO) +import Control.Monad (void) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Char (ord, isSpace) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Foreign.C (CInt(..), CWchar(..), Errno(..), errnoToIOError, peekCWString) +import Numeric (showHex) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.Data.Stream (Step(..)) +import Streamly.Internal.FileSystem.Path (Path) +import Streamly.Internal.FileSystem.WindowsPath (WindowsPath(..)) +import System.IO.Error (ioeSetErrorString) + +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.Unfold as UF (bracketIO) +import qualified Streamly.Internal.FileSystem.WindowsPath as Path +import qualified System.Win32 as Win32 (failWith) + +import Streamly.Internal.FileSystem.DirOptions +import Foreign hiding (void) + +#include + +-- Note on A vs W suffix in APIs. +-- CreateFile vs. CreateFileW: CreateFile is a macro that expands to +-- CreateFileA or CreateFileW depending on whether Unicode support (UNICODE and +-- _UNICODE preprocessor macros) is enabled in your project. To ensure +-- consistent Unicode support, explicitly use CreateFileW. + +------------------------------------------------------------------------------ +-- Types +------------------------------------------------------------------------------ + +type BOOL = Bool +type DWORD = Word32 + +type UINT_PTR = Word +type ErrCode = DWORD +type LPCTSTR = Ptr CWchar +type WIN32_FIND_DATA = () +type HANDLE = Ptr () + +------------------------------------------------------------------------------ +-- Windows C APIs +------------------------------------------------------------------------------ + +-- XXX Note for i386, stdcall is needed instead of ccall, see Win32 +-- package/windows_cconv.h. We support only x86_64 for now. +foreign import ccall unsafe "windows.h FindFirstFileW" + c_FindFirstFileW :: LPCTSTR -> Ptr WIN32_FIND_DATA -> IO HANDLE + +foreign import ccall unsafe "windows.h FindNextFileW" + c_FindNextFileW :: HANDLE -> Ptr WIN32_FIND_DATA -> IO BOOL + +foreign import ccall unsafe "windows.h FindClose" + c_FindClose :: HANDLE -> IO BOOL + +foreign import ccall unsafe "windows.h GetLastError" + getLastError :: IO ErrCode + +foreign import ccall unsafe "windows.h LocalFree" + localFree :: Ptr a -> IO (Ptr a) + +------------------------------------------------------------------------------ +-- Haskell C APIs +------------------------------------------------------------------------------ + +foreign import ccall unsafe "maperrno_func" -- in base/cbits/Win32Utils.c + c_maperrno_func :: ErrCode -> IO Errno + +------------------------------------------------------------------------------ +-- Error Handling +------------------------------------------------------------------------------ + +-- XXX getErrorMessage and castUINTPtrToPtr require c code, so left out for +-- now. Once we replace these we can remove dependency on Win32. We can +-- possibly implement these in Haskell by directly calling the Windows API. + +foreign import ccall unsafe "getErrorMessage" + getErrorMessage :: DWORD -> IO (Ptr CWchar) + +foreign import ccall unsafe "castUINTPtrToPtr" + castUINTPtrToPtr :: UINT_PTR -> Ptr a + +failWith :: String -> ErrCode -> IO a +failWith fn_name err_code = do + c_msg <- getErrorMessage err_code + msg <- if c_msg == nullPtr + then return $ "Error 0x" ++ Numeric.showHex err_code "" + else do + msg <- peekCWString c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg + return msg + errno <- c_maperrno_func err_code + let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n + ioerror = errnoToIOError fn_name errno Nothing Nothing + `ioeSetErrorString` msg' + throwIO ioerror + +errorWin :: String -> IO a +errorWin fn_name = do + err_code <- getLastError + failWith fn_name err_code + +failIf :: (a -> Bool) -> String -> IO a -> IO a +failIf p wh act = do + v <- act + if p v then errorWin wh else return v + +iNVALID_HANDLE_VALUE :: HANDLE +iNVALID_HANDLE_VALUE = castUINTPtrToPtr maxBound + +------------------------------------------------------------------------------ +-- Dir stream implementation +------------------------------------------------------------------------------ + +-- XXX Define this as data and unpack three fields? +newtype DirStream = + DirStream (HANDLE, IORef Bool, ForeignPtr WIN32_FIND_DATA) + +openDirStream :: WindowsPath -> IO DirStream +openDirStream p = do + let path = Path.unsafeJoin p $ Path.unsafeFromString "*" + fp_finddata <- mallocForeignPtrBytes (# const sizeof(WIN32_FIND_DATAW) ) + withForeignPtr fp_finddata $ \dataPtr -> do + handle <- + Array.asCStringUnsafe (Path.toArray path) $ \pathPtr -> do + -- XXX Use getLastError to distinguish the case when no + -- matching file is found. See the doc of FindFirstFileW. + failIf + (== iNVALID_HANDLE_VALUE) + ("FindFirstFileW: " ++ Path.toString path) + $ c_FindFirstFileW (castPtr pathPtr) dataPtr + ref <- newIORef True + return $ DirStream (handle, ref, fp_finddata) + +closeDirStream :: DirStream -> IO () +closeDirStream (DirStream (h, _, _)) = void (c_FindClose h) + +-- XXX Keep this in sync with the isMetaDir function in Posix readdir module. +isMetaDir :: Ptr CWchar -> IO Bool +isMetaDir dname = do + -- XXX Assuming UTF16LE encoding + c1 <- peek dname + if (c1 /= fromIntegral (ord '.')) + then return False + else do + c2 :: Word8 <- peekByteOff dname 1 + if (c2 == 0) + then return True + else if (c2 /= fromIntegral (ord '.')) + then return False + else do + c3 :: Word8 <- peekByteOff dname 2 + if (c3 == 0) + then return True + else return False + +readDirStreamEither :: + (ReadOptions -> ReadOptions) -> + DirStream -> IO (Maybe (Either WindowsPath WindowsPath)) +readDirStreamEither _ (DirStream (h, ref, fdata)) = + withForeignPtr fdata $ \ptr -> do + firstTime <- readIORef ref + if firstTime + then do + writeIORef ref False + processEntry ptr + else findNext ptr + + where + + -- XXX: for a symlink the attribute may have a FILE_ATTRIBUTE_DIRECTORY if + -- the symlink was created as a directory symlink, but it might have + -- changed later. To find the real type of the symlink when we have + -- followSymlinks option on we need to check if it is a + -- FILE_ATTRIBUTE_REPARSE_POINT, we need to open the reparse point and find + -- the type. + + processEntry ptr = do + let dname = #{ptr WIN32_FIND_DATAW, cFileName} ptr + dattrs :: #{type DWORD} <- + #{peek WIN32_FIND_DATAW, dwFileAttributes} ptr + name <- Array.fromW16CString dname + if (dattrs .&. (#const FILE_ATTRIBUTE_DIRECTORY) /= 0) + then do + isMeta <- isMetaDir dname + if isMeta + then findNext ptr + else return (Just (Left (Path.unsafeFromArray name))) + else return (Just (Right (Path.unsafeFromArray name))) + + findNext ptr = do + retval <- liftIO $ c_FindNextFileW h ptr + if (retval) + then processEntry ptr + else do + err <- getLastError + if err == (# const ERROR_NO_MORE_FILES ) + then return Nothing + -- XXX Print the path in the error message + else Win32.failWith "findNextFile" err + +{-# INLINE streamEitherReader #-} +streamEitherReader :: MonadIO m => + (ReadOptions -> ReadOptions) -> + Unfold m DirStream (Either Path Path) +streamEitherReader f = Unfold step return + where + + step strm = do + r <- liftIO $ readDirStreamEither f strm + case r of + Nothing -> return Stop + Just x -> return $ Yield x strm + +{-# INLINE streamReader #-} +streamReader :: MonadIO m => Unfold m DirStream Path +streamReader = fmap (either id id) (streamEitherReader id) + +-- | Read a directory emitting a stream with names of the children. Filter out +-- "." and ".." entries. +-- +-- /Internal/ + +{-# INLINE reader #-} +reader :: (MonadIO m, MonadCatch m) => Unfold m Path Path +reader = +-- XXX Instead of using bracketIO for each iteration of the loop we should +-- instead yield a buffer of dir entries in each iteration and then use an +-- unfold and concat to flatten those entries. That should improve the +-- performance. + UF.bracketIO openDirStream closeDirStream streamReader + +-- | Read directories as Left and files as Right. Filter out "." and ".." +-- entries. +-- +-- /Internal/ +-- +{-# INLINE eitherReader #-} +eitherReader :: (MonadIO m, MonadCatch m) => + (ReadOptions -> ReadOptions) -> Unfold m Path (Either Path Path) +eitherReader f = + -- XXX The measured overhead of bracketIO is not noticeable, if it turns + -- out to be a problem for small filenames we can use getdents64 to use + -- chunked read to avoid the overhead. + UF.bracketIO openDirStream closeDirStream (streamEitherReader f) +#endif diff --git a/src/Streamly/Internal/FileSystem/WindowsPath.hs b/src/Streamly/Internal/FileSystem/WindowsPath.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/WindowsPath.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE CPP #-} +#define IS_WINDOWS +#include "Streamly/Internal/FileSystem/PosixPath.hs" + +-- XXX Move these functions to PosixPath.hs and use CPP conditionals for +-- documentation differences, definitions are identical. + +-- Note: We can use powershell for testing path validity. +-- "//share/x" works in powershell. +-- But mixed forward and backward slashes do not work, it is treated as a path +-- relative to current drive e.g. "\\/share/x" is treated as "C:/share/x". +-- +-- XXX Note: Windows may have case sensitive behavior depending on the file +-- system being used. Does it impact any of the case insensitive validations +-- below? +-- +-- XXX ADS - alternate data stream syntax - file.txt:stream . + +-- | Like 'validatePath' but more strict. The path must refer to a file system +-- object. For example, a share root itself is not a valid file system object. +-- it must be followed by a non-empty path. +-- +-- >>> isValid = isJust . Path.validatePath' . Path.encodeString +-- +-- >>> isValid "\\\\" +-- False +-- >>> isValid "\\\\server\\" +-- False +-- >>> isValid "\\\\server\\x" +-- True +-- >>> isValid "\\\\?\\UNC\\server" +-- False +-- +validatePath' :: + MonadThrow m => Array OS_WORD_TYPE -> m () +validatePath' = Common.validatePath' Common.Windows + +-- | Like 'isValidPath' but more strict. +-- +-- >>> isValidPath' = isJust . Path.validatePath' +-- +isValidPath' :: + Array OS_WORD_TYPE -> Bool +isValidPath' = isJust . validatePath' + +-- | Read a raw array of OS_WORD_TYPE as a path type. +-- +-- >>> readArray = fromJust . Path.fromArray . read +-- +-- >>> arr :: Array Word16 = Path.encodeString "hello" +-- >>> Path.showArray $ (Path.readArray $ show arr :: Path.WindowsPath) +-- "fromList [104,101,108,108,111]" +-- +-- See also: 'showArray'. +readArray :: [Char] -> OS_PATH_TYPE +readArray = fromJust . fromArray . read + +-- | A path that is attached to a root. "C:\\" is considered an absolute root +-- and "." as a dynamic root. ".." is not considered a root, "..\/x" or "x\/y" +-- are not rooted paths. +-- +-- Absolute locations: +-- +-- * @C:\\@ local drive +-- * @\\\\share\\@ UNC share +-- * @\\\\?\\C:\\@ Long UNC local drive +-- * @\\\\?\\UNC\\@ Long UNC remote server +-- * @\\\\.\\@ DOS local device namespace +-- * @\\\\??\\@ DOS global namespace +-- +-- Relative locations: +-- +-- * @\\@ relative to current drive root +-- * @.\\@ relative to current directory +-- * @C:@ current directory in drive +-- * @C:file@ relative to current directory in drive +-- +-- >>> isRooted = Path.isRooted . fromJust . Path.fromString +-- +-- Common to Windows and Posix: +-- +-- >>> isRooted "/" +-- True +-- >>> isRooted "/x" +-- True +-- >>> isRooted "." +-- True +-- >>> isRooted "./x" +-- True +-- +-- Windows specific: +-- +-- >>> isRooted "c:" +-- True +-- >>> isRooted "c:x" +-- True +-- >>> isRooted "c:/" +-- True +-- >>> isRooted "//x/y" +-- True +-- +isRooted :: OS_PATH_TYPE -> Bool +isRooted (OS_PATH arr) = Common.isRooted Common.OS_NAME arr + +-- | Like 'join' but does not check if any of the path is empty or if the +-- second path is rooted. +-- +-- >>> f a b = Path.toString $ Path.unsafeJoin (Path.fromString_ a) (Path.fromString_ b) +-- +-- >>> f "x" "y" +-- "x\\y" +-- >>> f "x/" "y" +-- "x/y" +-- >>> f "x" "/y" +-- "x/y" +-- >>> f "x/" "/y" +-- "x/y" +-- +-- Note "c:" and "/x" are both rooted paths, therefore, 'join' cannot be used +-- to join them. Similarly for joining "//x/" and "/y". For these cases use +-- 'unsafeJoin'. 'unsafeJoin' can be used as a replacement for the +-- joinDrive function from the filepath package. +-- +-- >>> f "c:" "/x" +-- "c:/x" +-- >>> f "//x/" "/y" +-- "//x/y" +-- +{-# INLINE unsafeJoin #-} +unsafeJoin :: OS_PATH_TYPE -> OS_PATH_TYPE -> OS_PATH_TYPE +unsafeJoin (OS_PATH a) (OS_PATH b) = + OS_PATH + $ Common.unsafeAppend + Common.OS_NAME (Common.toString Unicode.UNICODE_DECODER) a b + +-- | Append a OS_PATH_TYPE to another. Fails if the second path refers to a rooted +-- path. If you want to avoid runtime failure use the typesafe +-- Streamly.FileSystem.OS_PATH_TYPE.Seg module. Use 'unsafeJoin' to avoid failure +-- if you know it is ok to append the path. +-- +-- Usually, append joins two paths using a separator between the paths. On +-- Windows, joining a drive "c:" with path "x" does not add a separator between +-- the two because "c:x" is different from "c:/x". +-- +-- Note "c:" and "/x" are both rooted paths, therefore, 'join' cannot be used +-- to join them. Similarly for joining "//x/" and "/y". For these cases use +-- 'unsafeJoin'. +-- +-- >>> f a b = Path.toString $ Path.join a b +-- +-- >>> f [path|x|] [path|y|] +-- "x\\y" +-- >>> f [path|x/|] [path|y|] +-- "x/y" +-- >>> f [path|c:|] [path|x|] +-- "c:x" +-- >>> f [path|c:/|] [path|x|] +-- "c:/x" +-- >>> f [path|//x/|] [path|y|] +-- "//x/y" +-- +-- >>> fails $ f [path|c:|] [path|/|] +-- True +-- >>> fails $ f [path|c:|] [path|/x|] +-- True +-- >>> fails $ f [path|c:/|] [path|/x|] +-- True +-- >>> fails $ f [path|//x/|] [path|/y|] +-- True +join :: OS_PATH_TYPE -> OS_PATH_TYPE -> OS_PATH_TYPE +join (OS_PATH a) (OS_PATH b) = + OS_PATH + $ Common.append + Common.OS_NAME (Common.toString Unicode.UNICODE_DECODER) a b + +-- | A stricter version of 'join' which requires the first path to be a +-- directory like path i.e. with a trailing separator. +-- +-- >>> f a b = Path.toString $ Path.joinDir a b +-- +-- >>> fails $ f [path|x|] [path|y|] +-- True +-- +joinDir :: + OS_PATH_TYPE -> OS_PATH_TYPE -> OS_PATH_TYPE +joinDir + (OS_PATH a) (OS_PATH b) = + OS_PATH + $ Common.append' + Common.OS_NAME (Common.toString Unicode.UNICODE_DECODER) a b + +-- | See the eqPath documentation in the +-- "Streamly.Internal.FileSystem.PosixPath" module for details. +-- +-- On Windows, the following is different: +-- +-- * paths are normalized by replacing forward slash path separators by +-- backslashes. +-- * default configuration uses case-insensitive comparison. +-- +-- >>> :{ +-- eq a b = Path.eqPath id (Path.fromString_ a) (Path.fromString_ b) +-- :} +-- +-- The cases that are different from Posix: +-- +-- >>> eq "x\\y" "x/y" +-- True +-- +-- >>> eq "x" "X" +-- True +-- +-- >>> eq "c:" "C:" +-- False +-- +-- >>> eq "c:" "c:" +-- False +-- +-- >>> eq "c:x" "c:x" +-- False +-- +-- >>> :{ +-- cfg = Path.ignoreTrailingSeparators True +-- . Path.ignoreCase True +-- . Path.allowRelativeEquality True +-- eq a b = Path.eqPath cfg (Path.fromString_ a) (Path.fromString_ b) +-- :} +-- +-- >>> eq "./x" "x" +-- True +-- +-- >>> eq "X/" "x" +-- True +-- +-- >>> eq "C:x" "c:X" +-- True +-- +-- >>> eq ".\\x" "./X" +-- True +-- +-- >>> eq "x//y" "x/y" +-- True +-- +-- >>> eq "x/./y" "x/y" +-- True +-- +-- >>> eq "x" "x" +-- True +-- +eqPath :: (EqCfg -> EqCfg) -> OS_PATH_TYPE -> OS_PATH_TYPE -> Bool +eqPath cfg (OS_PATH a) (OS_PATH b) = + Common.eqPath Unicode.UNICODE_DECODER + Common.OS_NAME (cfg eqCfg) a b + +-- | If a path is rooted then separate the root and the remaining path, +-- otherwise root is returned as empty. If the path is rooted then the non-root +-- part is guaranteed to not start with a separator. +-- +-- See "Streamly.Internal.FileSystem.PosixPath" module for common examples. We +-- provide some Windows specific examples here. +-- +-- >>> toList (a,b) = (Path.toString a, fmap Path.toString b) +-- >>> split = fmap toList . Path.splitRoot . Path.fromString_ +-- +-- >>> split "c:" +-- Just ("c:",Nothing) +-- +-- >>> split "c:/" +-- Just ("c:/",Nothing) +-- +-- >>> split "//x/" +-- Just ("//x/",Nothing) +-- +-- >>> split "//x/y" +-- Just ("//x/",Just "y") +-- +splitRoot :: OS_PATH_TYPE -> Maybe (OS_PATH_TYPE, Maybe OS_PATH_TYPE) +splitRoot (OS_PATH x) = + let (a,b) = Common.splitRoot Common.OS_NAME x + in if Array.null a + then Nothing + else if Array.null b + then Just (OS_PATH a, Nothing) + else Just (OS_PATH a, Just (OS_PATH b)) + +-- | Split a path into components separated by the path separator. "." +-- components in the path are ignored except when in the leading position. +-- Trailing separators in non-root components are dropped. +-- +-- >>> split = Stream.toList . fmap Path.toString . Path.splitPath_ . Path.fromString_ +-- +-- >>> split "c:x" +-- ["c:","x"] +-- +-- >>> split "c:/" -- Note, c:/ is not the same as c: +-- ["c:/"] +-- +-- >>> split "c:/x" +-- ["c:/","x"] +-- +-- >>> split "//x/y/" +-- ["//x","y"] +-- +-- >>> split "./a" +-- [".","a"] +-- +-- >>> split "c:./a" +-- ["c:","a"] +-- +-- >>> split "a/." +-- ["a"] +-- +-- >>> split "/x" +-- ["/","x"] +-- +-- >>> split "/x/\\y" +-- ["/","x","y"] +-- +-- >>> split "\\x/\\y" +-- ["\\","x","y"] +-- +{-# INLINE splitPath_ #-} +splitPath_ :: Monad m => OS_PATH_TYPE -> Stream m OS_PATH_TYPE +splitPath_ (OS_PATH a) = fmap OS_PATH $ Common.splitPath_ Common.OS_NAME a + +-- | Split the path components keeping separators between path components +-- attached to the dir part. Redundant separators are removed, only the first +-- one is kept, but separators are not changed to the default on Windows. +-- Separators are not added either e.g. "." and ".." may not have trailing +-- separators if the original path does not. +-- +-- >>> split = Stream.toList . fmap Path.toString . Path.splitPath . Path.fromString_ +-- +-- >>> split "/x" +-- ["/","x"] +-- +-- >>> split "/x/\\y" +-- ["/","x/","y"] +-- +-- >>> split "\\x/\\y" -- this is not valid, multiple seps after share? +-- ["\\","x/","y"] +-- +{-# INLINE splitPath #-} +splitPath :: Monad m => OS_PATH_TYPE -> Stream m OS_PATH_TYPE +splitPath (OS_PATH a) = fmap OS_PATH $ Common.splitPath Common.OS_NAME a + +-- | See "Streamly.Internal.FileSystem.PosixPath" module for detailed +-- documentation and examples. We provide some Windows specific examples here. +-- +-- Note: On Windows we cannot create a file named "prn." or "prn..". Thus it +-- considers anything starting with and including the first "." as the +-- extension and the part before it as the filename. Our definition considers +-- "prn." as a filename without an extension. +-- +-- >>> toList (a,b) = (Path.toString a, Path.toString b) +-- >>> split = fmap toList . Path.splitExtension . Path.fromString_ +-- +-- >>> split "x:y" +-- Nothing +-- +-- >>> split "x:.y" +-- Nothing +-- +splitExtension :: OS_PATH_TYPE -> Maybe (OS_PATH_TYPE, OS_PATH_TYPE) +splitExtension (OS_PATH a) = + fmap (bimap OS_PATH OS_PATH) $ Common.splitExtension Common.OS_NAME a diff --git a/src/Streamly/Internal/FileSystem/WindowsPath/Node.hs b/src/Streamly/Internal/FileSystem/WindowsPath/Node.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/WindowsPath/Node.hs @@ -0,0 +1,2 @@ +#define IS_WINDOWS +#include "Streamly/Internal/FileSystem/PosixPath/Node.hs" diff --git a/src/Streamly/Internal/FileSystem/WindowsPath/Seg.hs b/src/Streamly/Internal/FileSystem/WindowsPath/Seg.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/WindowsPath/Seg.hs @@ -0,0 +1,2 @@ +#define IS_WINDOWS +#include "Streamly/Internal/FileSystem/PosixPath/Seg.hs" diff --git a/src/Streamly/Internal/FileSystem/WindowsPath/SegNode.hs b/src/Streamly/Internal/FileSystem/WindowsPath/SegNode.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/WindowsPath/SegNode.hs @@ -0,0 +1,2 @@ +#define IS_WINDOWS +#include "Streamly/Internal/FileSystem/PosixPath/SegNode.hs" diff --git a/src/Streamly/Internal/Serialize/FromBytes.hs b/src/Streamly/Internal/Serialize/FromBytes.hs deleted file mode 100644 --- a/src/Streamly/Internal/Serialize/FromBytes.hs +++ /dev/null @@ -1,394 +0,0 @@ --- | --- Module : Streamly.Internal.Serialize.FromBytes --- Copyright : (c) 2020 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : pre-release --- Portability : GHC --- --- Decode Haskell data types from byte streams. - -module Streamly.Internal.Serialize.FromBytes - ( - -- * Type class - FromBytes (..) - - -- * Decoders - , unit - , bool - , ordering - , eqWord8 -- XXX rename to word8Eq - , word8 - , word16be - , word16le - , word32be - , word32le - , word64be - , word64le - , word64host - , int8 - , int16be - , int16le - , int32be - , int32le - , int64be - , int64le - , float32be - , float32le - , double64be - , double64le - , charLatin1 - ) -where - -import Control.Monad.IO.Class (MonadIO) -import Data.Bits ((.|.), unsafeShiftL) -import Data.Char (chr) -import Data.Int (Int8, Int16, Int32, Int64) -import GHC.Float (castWord32ToFloat, castWord64ToDouble) -import Data.Word (Word8, Word16, Word32, Word64) -import Streamly.Internal.Data.Parser (Parser) -import Streamly.Internal.Data.Maybe.Strict (Maybe'(..)) -import Streamly.Internal.Data.Tuple.Strict (Tuple' (..)) -import qualified Streamly.Data.Array as A -import qualified Streamly.Internal.Data.Array as A - (unsafeIndex, castUnsafe) -import qualified Streamly.Internal.Data.Parser as PR - (fromPure, either, satisfy, takeEQ) -import qualified Streamly.Internal.Data.Parser.ParserD as PRD - (Parser(..), Initial(..), Step(..)) - --- Note: The () type does not need to have an on-disk representation in theory. --- But we use a concrete representation for it so that we count how many () --- types we have. Or when we have an array of units the array a concrete --- length. - --- | A value of type '()' is encoded as @0@ in binary encoding. --- --- @ --- 0 ==> () --- @ --- --- /Pre-release/ --- -{-# INLINE unit #-} -unit :: Monad m => Parser Word8 m () -unit = eqWord8 0 *> PR.fromPure () - -{-# INLINE word8ToBool #-} -word8ToBool :: Word8 -> Either String Bool -word8ToBool 0 = Right False -word8ToBool 1 = Right True -word8ToBool w = Left ("Invalid Bool encoding " ++ Prelude.show w) - --- | A value of type 'Bool' is encoded as follows in binary encoding. --- --- @ --- 0 ==> False --- 1 ==> True --- @ --- --- /Pre-release/ --- -{-# INLINE bool #-} -bool :: Monad m => Parser Word8 m Bool -bool = PR.either word8ToBool - -{-# INLINE word8ToOrdering #-} -word8ToOrdering :: Word8 -> Either String Ordering -word8ToOrdering 0 = Right LT -word8ToOrdering 1 = Right EQ -word8ToOrdering 2 = Right GT -word8ToOrdering w = Left ("Invalid Ordering encoding " ++ Prelude.show w) - --- | A value of type 'Ordering' is encoded as follows in binary encoding. --- --- @ --- 0 ==> LT --- 1 ==> EQ --- 2 ==> GT --- @ --- --- /Pre-release/ --- -{-# INLINE ordering #-} -ordering :: Monad m => Parser Word8 m Ordering -ordering = PR.either word8ToOrdering - --- XXX should go in a Word8 parser module? --- | Accept the input byte only if it is equal to the specified value. --- --- /Pre-release/ --- -{-# INLINE eqWord8 #-} -eqWord8 :: Monad m => Word8 -> Parser Word8 m Word8 -eqWord8 b = PR.satisfy (== b) - --- | Accept any byte. --- --- /Pre-release/ --- -{-# INLINE word8 #-} -word8 :: Monad m => Parser Word8 m Word8 -word8 = PR.satisfy (const True) - --- | Big endian (MSB first) Word16 -{-# INLINE word16beD #-} -word16beD :: Monad m => PRD.Parser Word8 m Word16 -word16beD = PRD.Parser step initial extract - - where - - initial = return $ PRD.IPartial Nothing' - - step Nothing' a = - -- XXX We can use a non-failing parser or a fold so that we do not - -- have to buffer for backtracking which is inefficient. - return $ PRD.Continue 0 (Just' (fromIntegral a `unsafeShiftL` 8)) - step (Just' w) a = - return $ PRD.Done 0 (w .|. fromIntegral a) - - extract _ = return $ PRD.Error "word16be: end of input" - --- | Parse two bytes as a 'Word16', the first byte is the MSB of the Word16 and --- second byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word16be #-} -word16be :: Monad m => Parser Word8 m Word16 -word16be = word16beD - --- | Little endian (LSB first) Word16 -{-# INLINE word16leD #-} -word16leD :: Monad m => PRD.Parser Word8 m Word16 -word16leD = PRD.Parser step initial extract - - where - - initial = return $ PRD.IPartial Nothing' - - step Nothing' a = - return $ PRD.Continue 0 (Just' (fromIntegral a)) - step (Just' w) a = - return $ PRD.Done 0 (w .|. fromIntegral a `unsafeShiftL` 8) - - extract _ = return $ PRD.Error "word16le: end of input" - --- | Parse two bytes as a 'Word16', the first byte is the LSB of the Word16 and --- second byte is the MSB (little endian representation). --- --- /Pre-release/ --- -{-# INLINE word16le #-} -word16le :: Monad m => Parser Word8 m Word16 -word16le = word16leD - --- | Big endian (MSB first) Word32 -{-# INLINE word32beD #-} -word32beD :: Monad m => PRD.Parser Word8 m Word32 -word32beD = PRD.Parser step initial extract - - where - - initial = return $ PRD.IPartial $ Tuple' 0 24 - - step (Tuple' w sh) a = return $ - if sh /= 0 - then - let w1 = w .|. (fromIntegral a `unsafeShiftL` sh) - in PRD.Continue 0 (Tuple' w1 (sh - 8)) - else PRD.Done 0 (w .|. fromIntegral a) - - extract _ = return $ PRD.Error "word32beD: end of input" - --- | Parse four bytes as a 'Word32', the first byte is the MSB of the Word32 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word32be #-} -word32be :: Monad m => Parser Word8 m Word32 -word32be = word32beD - --- | Little endian (LSB first) Word32 -{-# INLINE word32leD #-} -word32leD :: Monad m => PRD.Parser Word8 m Word32 -word32leD = PRD.Parser step initial extract - - where - - initial = return $ PRD.IPartial $ Tuple' 0 0 - - step (Tuple' w sh) a = return $ - let w1 = w .|. (fromIntegral a `unsafeShiftL` sh) - in if sh /= 24 - then PRD.Continue 0 (Tuple' w1 (sh + 8)) - else PRD.Done 0 w1 - - extract _ = return $ PRD.Error "word32leD: end of input" - --- | Parse four bytes as a 'Word32', the first byte is the MSB of the Word32 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word32le #-} -word32le :: Monad m => Parser Word8 m Word32 -word32le = word32leD - --- | Big endian (MSB first) Word64 -{-# INLINE word64beD #-} -word64beD :: Monad m => PRD.Parser Word8 m Word64 -word64beD = PRD.Parser step initial extract - - where - - initial = return $ PRD.IPartial $ Tuple' 0 56 - - step (Tuple' w sh) a = return $ - if sh /= 0 - then - let w1 = w .|. (fromIntegral a `unsafeShiftL` sh) - in PRD.Continue 0 (Tuple' w1 (sh - 8)) - else PRD.Done 0 (w .|. fromIntegral a) - - extract _ = return $ PRD.Error "word64beD: end of input" - --- | Parse eight bytes as a 'Word64', the first byte is the MSB of the Word64 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word64be #-} -word64be :: Monad m => Parser Word8 m Word64 -word64be = word64beD - --- | Little endian (LSB first) Word64 -{-# INLINE word64leD #-} -word64leD :: Monad m => PRD.Parser Word8 m Word64 -word64leD = PRD.Parser step initial extract - - where - - initial = return $ PRD.IPartial $ Tuple' 0 0 - - step (Tuple' w sh) a = return $ - let w1 = w .|. (fromIntegral a `unsafeShiftL` sh) - in if sh /= 56 - then PRD.Continue 0 (Tuple' w1 (sh + 8)) - else PRD.Done 0 w1 - - extract _ = return $ PRD.Error "word64leD: end of input" - --- | Parse eight bytes as a 'Word64', the first byte is the MSB of the Word64 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word64le #-} -word64le :: Monad m => Parser Word8 m Word64 -word64le = word64leD - -{-# INLINE int8 #-} -int8 :: Monad m => Parser Word8 m Int8 -int8 = fromIntegral <$> word8 - --- | Parse two bytes as a 'Int16', the first byte is the MSB of the Int16 and --- second byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE int16be #-} -int16be :: Monad m => Parser Word8 m Int16 -int16be = fromIntegral <$> word16be - --- | Parse two bytes as a 'Int16', the first byte is the LSB of the Int16 and --- second byte is the MSB (little endian representation). --- --- /Pre-release/ --- -{-# INLINE int16le #-} -int16le :: Monad m => Parser Word8 m Int16 -int16le = fromIntegral <$> word16le - --- | Parse four bytes as a 'Int32', the first byte is the MSB of the Int32 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE int32be #-} -int32be :: Monad m => Parser Word8 m Int32 -int32be = fromIntegral <$> word32be - --- | Parse four bytes as a 'Int32', the first byte is the MSB of the Int32 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE int32le #-} -int32le :: Monad m => Parser Word8 m Int32 -int32le = fromIntegral <$> word32le - --- | Parse eight bytes as a 'Int64', the first byte is the MSB of the Int64 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE int64be #-} -int64be :: Monad m => Parser Word8 m Int64 -int64be = fromIntegral <$> word64be - --- | Parse eight bytes as a 'Int64', the first byte is the MSB of the Int64 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE int64le #-} -int64le :: Monad m => Parser Word8 m Int64 -int64le = fromIntegral <$> word64le - -{-# INLINE float32be #-} -float32be :: MonadIO m => Parser Word8 m Float -float32be = castWord32ToFloat <$> word32be - -{-# INLINE float32le #-} -float32le :: MonadIO m => Parser Word8 m Float -float32le = castWord32ToFloat <$> word32le - -{-# INLINE double64be #-} -double64be :: MonadIO m => Parser Word8 m Double -double64be = castWord64ToDouble <$> word64be - -{-# INLINE double64le #-} -double64le :: MonadIO m => Parser Word8 m Double -double64le = castWord64ToDouble <$> word64le - --- | Accept any byte. --- --- /Pre-release/ --- -{-# INLINE charLatin1 #-} -charLatin1 :: Monad m => Parser Word8 m Char -charLatin1 = fmap (chr . fromIntegral) word8 - -------------------------------------------------------------------------------- --- Host byte order -------------------------------------------------------------------------------- - --- | Parse eight bytes as a 'Word64' in the host byte order. --- --- /Pre-release/ --- -{-# INLINE word64host #-} -word64host :: MonadIO m => Parser Word8 m Word64 -word64host = - fmap (A.unsafeIndex 0 . A.castUnsafe) $ PR.takeEQ 8 (A.writeN 8) - -------------------------------------------------------------------------------- --- Type class -------------------------------------------------------------------------------- - -class FromBytes a where - -- | Decode a byte stream to a Haskell type. - fromBytes :: Parser Word8 m a diff --git a/src/Streamly/Internal/Serialize/ToBytes.hs b/src/Streamly/Internal/Serialize/ToBytes.hs deleted file mode 100644 --- a/src/Streamly/Internal/Serialize/ToBytes.hs +++ /dev/null @@ -1,374 +0,0 @@ --- | --- Module : Streamly.Internal.Serialize.ToBytes --- Copyright : (c) 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : pre-release --- Portability : GHC --- --- Encode Haskell data types to byte streams. - -module Streamly.Internal.Serialize.ToBytes - ( - -- * Type class - ToBytes (..) - - -- * Encoders - , unit - , bool - , ordering - , word8 - , word16be - , word16le - , word32be - , word32le - , word64be - , word64le - , word64host - , int8 - , int16be - , int16le - , int32be - , int32le - , int64be - , int64le - , float32be - , float32le - , double64be - , double64le - , charLatin1 - , charUtf8 - ) -where - -#include "MachDeps.h" - -import Data.Bits (shiftR) -import Data.Char (ord) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Word (Word8, Word16, Word32, Word64) -import GHC.Float (castDoubleToWord64, castFloatToWord32) -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Stream.StreamD (Step(..)) -import Streamly.Internal.Unicode.Stream (readCharUtf8) - -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Streamly.Internal.Data.Stream.StreamD as D - --- XXX Use StreamD directly? - --- | A value of type '()' is encoded as @0@ in binary encoding. --- --- @ --- 0 ==> () --- @ --- --- /Pre-release/ --- -{-# INLINE unit #-} -unit :: Applicative m => Stream m Word8 -unit = Stream.fromPure 0 - -{-# INLINE boolToWord8 #-} -boolToWord8 :: Bool -> Word8 -boolToWord8 False = 0 -boolToWord8 True = 1 - --- | A value of type 'Bool' is encoded as follows in binary encoding. --- --- @ --- 0 ==> False --- 1 ==> True --- @ --- --- /Pre-release/ --- -{-# INLINE bool #-} -bool :: Applicative m => Bool -> Stream m Word8 -bool = Stream.fromPure . boolToWord8 - -{-# INLINE orderingToWord8 #-} -orderingToWord8 :: Ordering -> Word8 -orderingToWord8 LT = 0 -orderingToWord8 EQ = 1 -orderingToWord8 GT = 2 - --- | A value of type 'Ordering' is encoded as follows in binary encoding. --- --- @ --- 0 ==> LT --- 1 ==> EQ --- 2 ==> GT --- @ --- --- /Pre-release/ --- -{-# INLINE ordering #-} -ordering :: Applicative m => Ordering -> Stream m Word8 -ordering = Stream.fromPure . orderingToWord8 - --- | Stream a 'Word8'. --- --- /Pre-release/ --- -{-# INLINE word8 #-} -word8 :: Applicative m => Word8 -> Stream m Word8 -word8 = Stream.fromPure - -data W16State = W16B1 | W16B2 | W16Done - -{-# INLINE word16beD #-} -word16beD :: Applicative m => Word16 -> D.Stream m Word8 -word16beD w = D.Stream step W16B1 - - where - - step _ W16B1 = pure $ Yield (fromIntegral (shiftR w 8) :: Word8) W16B2 - step _ W16B2 = pure $ Yield (fromIntegral w :: Word8) W16Done - step _ W16Done = pure Stop - --- | Stream a 'Word16' as two bytes, the first byte is the MSB of the Word16 --- and second byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word16be #-} -word16be :: Monad m => Word16 -> Stream m Word8 -word16be = word16beD - --- | Little endian (LSB first) Word16 -{-# INLINE word16leD #-} -word16leD :: Applicative m => Word16 -> D.Stream m Word8 -word16leD w = D.Stream step W16B1 - - where - - step _ W16B1 = pure $ Yield (fromIntegral w :: Word8) W16B2 - step _ W16B2 = pure $ Yield (fromIntegral (shiftR w 8) :: Word8) W16Done - step _ W16Done = pure Stop - --- | Stream a 'Word16' as two bytes, the first byte is the LSB of the Word16 --- and second byte is the MSB (little endian representation). --- --- /Pre-release/ --- -{-# INLINE word16le #-} -word16le :: Monad m => Word16 -> Stream m Word8 -word16le = word16leD - -data W32State = W32B1 | W32B2 | W32B3 | W32B4 | W32Done - --- | Big endian (MSB first) Word32 -{-# INLINE word32beD #-} -word32beD :: Applicative m => Word32 -> D.Stream m Word8 -word32beD w = D.Stream step W32B1 - - where - - yield n s = pure $ Yield (fromIntegral (shiftR w n) :: Word8) s - - step _ W32B1 = yield 24 W32B2 - step _ W32B2 = yield 16 W32B3 - step _ W32B3 = yield 8 W32B4 - step _ W32B4 = pure $ Yield (fromIntegral w :: Word8) W32Done - step _ W32Done = pure Stop - --- | Stream a 'Word32' as four bytes, the first byte is the MSB of the Word32 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word32be #-} -word32be :: Monad m => Word32 -> Stream m Word8 -word32be = word32beD - --- | Little endian (LSB first) Word32 -{-# INLINE word32leD #-} -word32leD :: Applicative m => Word32 -> D.Stream m Word8 -word32leD w = D.Stream step W32B1 - - where - - yield n s = pure $ Yield (fromIntegral (shiftR w n) :: Word8) s - - step _ W32B1 = pure $ Yield (fromIntegral w :: Word8) W32B2 - step _ W32B2 = yield 8 W32B3 - step _ W32B3 = yield 16 W32B4 - step _ W32B4 = yield 24 W32Done - step _ W32Done = pure Stop - --- | Stream a 'Word32' as four bytes, the first byte is the MSB of the Word32 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word32le #-} -word32le :: Monad m => Word32 -> Stream m Word8 -word32le = word32leD - -data W64State = - W64B1 | W64B2 | W64B3 | W64B4 | W64B5 | W64B6 | W64B7 | W64B8 | W64Done - --- | Big endian (MSB first) Word64 -{-# INLINE word64beD #-} -word64beD :: Applicative m => Word64 -> D.Stream m Word8 -word64beD w = D.Stream step W64B1 - - where - - yield n s = pure $ Yield (fromIntegral (shiftR w n) :: Word8) s - - step _ W64B1 = yield 56 W64B2 - step _ W64B2 = yield 48 W64B3 - step _ W64B3 = yield 40 W64B4 - step _ W64B4 = yield 32 W64B5 - step _ W64B5 = yield 24 W64B6 - step _ W64B6 = yield 16 W64B7 - step _ W64B7 = yield 8 W64B8 - step _ W64B8 = pure $ Yield (fromIntegral w :: Word8) W64Done - step _ W64Done = pure Stop - --- | Stream a 'Word64' as eight bytes, the first byte is the MSB of the Word64 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word64be #-} -word64be :: Monad m => Word64 -> Stream m Word8 -word64be = word64beD - --- | Little endian (LSB first) Word64 -{-# INLINE word64leD #-} -word64leD :: Applicative m => Word64 -> D.Stream m Word8 -word64leD w = D.Stream step W64B1 - - where - - yield n s = pure $ Yield (fromIntegral (shiftR w n) :: Word8) s - - step _ W64B1 = pure $ Yield (fromIntegral w :: Word8) W64B2 - step _ W64B2 = yield 8 W64B3 - step _ W64B3 = yield 16 W64B4 - step _ W64B4 = yield 24 W64B5 - step _ W64B5 = yield 32 W64B6 - step _ W64B6 = yield 40 W64B7 - step _ W64B7 = yield 48 W64B8 - step _ W64B8 = yield 56 W64Done - step _ W64Done = pure Stop - --- | Stream a 'Word64' as eight bytes, the first byte is the MSB of the Word64 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE word64le #-} -word64le :: Monad m => Word64 -> Stream m Word8 -word64le = word64leD - -{-# INLINE int8 #-} -int8 :: Applicative m => Int8 -> Stream m Word8 -int8 i = word8 (fromIntegral i :: Word8) - --- | Stream a 'Int16' as two bytes, the first byte is the MSB of the Int16 --- and second byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE int16be #-} -int16be :: Monad m => Int16 -> Stream m Word8 -int16be i = word16be (fromIntegral i :: Word16) - --- | Stream a 'Int16' as two bytes, the first byte is the LSB of the Int16 --- and second byte is the MSB (little endian representation). --- --- /Pre-release/ --- -{-# INLINE int16le #-} -int16le :: Monad m => Int16 -> Stream m Word8 -int16le i = word16le (fromIntegral i :: Word16) - --- | Stream a 'Int32' as four bytes, the first byte is the MSB of the Int32 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE int32be #-} -int32be :: Monad m => Int32 -> Stream m Word8 -int32be i = word32be (fromIntegral i :: Word32) - -{-# INLINE int32le #-} -int32le :: Monad m => Int32 -> Stream m Word8 -int32le i = word32le (fromIntegral i :: Word32) - --- | Stream a 'Int64' as eight bytes, the first byte is the MSB of the Int64 --- and last byte is the LSB (big endian representation). --- --- /Pre-release/ --- -{-# INLINE int64be #-} -int64be :: Monad m => Int64 -> Stream m Word8 -int64be i = word64be (fromIntegral i :: Word64) - --- | Stream a 'Int64' as eight bytes, the first byte is the LSB of the Int64 --- and last byte is the MSB (little endian representation). --- --- /Pre-release/ --- -{-# INLINE int64le #-} -int64le :: Monad m => Int64 -> Stream m Word8 -int64le i = word64le (fromIntegral i :: Word64) - --- | Big endian (MSB first) Float -{-# INLINE float32be #-} -float32be :: Monad m => Float -> Stream m Word8 -float32be = word32beD . castFloatToWord32 - --- | Little endian (LSB first) Float -{-# INLINE float32le #-} -float32le :: Monad m => Float -> Stream m Word8 -float32le = word32leD . castFloatToWord32 - --- | Big endian (MSB first) Double -{-# INLINE double64be #-} -double64be :: Monad m => Double -> Stream m Word8 -double64be = word64beD . castDoubleToWord64 - --- | Little endian (LSB first) Double -{-# INLINE double64le #-} -double64le :: Monad m => Double -> Stream m Word8 -double64le = word64leD . castDoubleToWord64 - --- | Encode a Unicode character to stream of bytes in 0-255 range. --- -{-# INLINE charLatin1 #-} -charLatin1 :: Applicative m => Char -> Stream m Word8 -charLatin1 = Stream.fromPure . fromIntegral . ord - -{-# INLINE charUtf8 #-} -charUtf8 :: Monad m => Char -> Stream m Word8 -charUtf8 = Stream.unfold readCharUtf8 - -------------------------------------------------------------------------------- --- Host byte order -------------------------------------------------------------------------------- - --- | Stream a 'Word64' as eight bytes in the host byte order. --- --- /Pre-release/ --- -{-# INLINE word64host #-} -word64host :: Monad m => Word64 -> Stream m Word8 -word64host = -#ifdef WORDS_BIGENDIAN - word64be -#else - word64le -#endif - -------------------------------------------------------------------------------- --- Type class -------------------------------------------------------------------------------- - -class ToBytes a where - -- | Convert a Haskell type to a byte stream. - toBytes :: a -> Stream m Word8 diff --git a/src/Streamly/Internal/Unicode/Array.hs b/src/Streamly/Internal/Unicode/Array.hs --- a/src/Streamly/Internal/Unicode/Array.hs +++ b/src/Streamly/Internal/Unicode/Array.hs @@ -14,6 +14,12 @@ -- module Streamly.Internal.Unicode.Array ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + -- * Streams of Strings lines , words @@ -49,7 +55,7 @@ -- {-# INLINE lines #-} lines :: MonadIO m => Stream m Char -> Stream m (Array Char) -lines = S.lines A.write +lines = S.lines A.create -- | Break a string up into a stream of strings, which were delimited -- by characters representing white space. @@ -61,7 +67,7 @@ -- {-# INLINE words #-} words :: MonadIO m => Stream m Char -> Stream m (Array Char) -words = S.words A.write +words = S.words A.create -- | Flattens the stream of @Array Char@, after appending a terminating -- newline to each string. diff --git a/src/Streamly/Internal/Unicode/Parser.hs b/src/Streamly/Internal/Unicode/Parser.hs --- a/src/Streamly/Internal/Unicode/Parser.hs +++ b/src/Streamly/Internal/Unicode/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Internal.Unicode.Parser -- Copyright : (c) 2021 Composewell Technologies @@ -12,6 +13,12 @@ module Streamly.Internal.Unicode.Parser ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + -- * Generic char , charIgnoreCase @@ -47,16 +54,23 @@ -- * Numeric , signed + , number + , doubleParser , double , decimal , hexadecimal + + -- * Utilities + , mkDouble ) where import Control.Applicative (Alternative(..)) -import Data.Bits (Bits, (.|.), shiftL) +import Data.Bits (Bits, (.|.), shiftL, (.&.)) import Data.Char (ord) -import Streamly.Internal.Data.Parser (Parser) +import Data.Ratio ((%)) +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Parser (Parser(..), Initial(..), Step(..), Final(..)) import qualified Data.Char as Char import qualified Streamly.Data.Fold as Fold @@ -69,6 +83,8 @@ , dropWhile ) +#include "DocTestUnicodeParser.hs" + -------------------------------------------------------------------------------- -- Character classification -------------------------------------------------------------------------------- @@ -263,36 +279,349 @@ signed :: (Num a, Monad m) => Parser Char m a -> Parser Char m a signed p = (negate <$> (char '-' *> p)) <|> (char '+' *> p) <|> p --- | Parse a 'Double'. +-- XXX Change Multiplier to Sign +type Multiplier = Int + +-- XXX We can use Int instead of Integer to make it twice as fast. But then we +-- will have to truncate the significant digits before overflow occurs. +type Number = Integer +type DecimalPlaces = Int +type PowerMultiplier = Int +type Power = Int + +{-# ANN type ScientificParseState Fuse #-} +data ScientificParseState + = SPInitial + | SPSign !Multiplier + | SPAfterSign !Multiplier !Number + | SPDot !Multiplier !Number + | SPAfterDot !Multiplier !Number !DecimalPlaces + | SPExponent !Multiplier !Number !DecimalPlaces + | SPExponentWithSign !Multiplier !Number !DecimalPlaces !PowerMultiplier + | SPAfterExponent !Multiplier !Number !DecimalPlaces !PowerMultiplier !Power + +-- XXX See https://hackage.haskell.org/package/integer-conversion for large +-- integers. + +-- | A generic parser for scientific notation of numbers. Returns (mantissa, +-- exponent) tuple. The result can be mapped to 'Double' or any other number +-- representation e.g. @Scientific@. -- --- This parser accepts an optional leading sign character, followed by --- at most one decimal digit. The syntax is similar to that accepted by --- the 'read' function, with the exception that a trailing @\'.\'@ is --- consumed. +-- For example, using the @scientific@ package: +-- >> parserScientific = uncurry Data.Scientific.scientific <$> 'number' +{-# INLINE number #-} +number :: Monad m => Parser Char m (Integer, Int) +number = Parser (\s a -> return $ step s a) initial (return . extract) + + where + + intToInteger :: Int -> Integer + intToInteger = fromIntegral + + combineNum buf num = buf * 10 + num + + {-# INLINE initial #-} + initial = pure $ IPartial SPInitial + + exitSPInitial msg = + "number: expecting sign or decimal digit, got " ++ msg + exitSPSign msg = + "number: expecting decimal digit, got " ++ msg + exitSPAfterSign multiplier num = (intToInteger multiplier * num, 0) + exitSPAfterDot multiplier num decimalPlaces = + ( intToInteger multiplier * num + , -decimalPlaces + ) + exitSPAfterExponent mult num decimalPlaces powerMult powerNum = + let e = powerMult * powerNum - decimalPlaces + in (intToInteger mult * num, e) + + {-# INLINE step #-} + step SPInitial val = + case val of + '+' -> SContinue 1 (SPSign 1) + '-' -> SContinue 1 (SPSign (-1)) + _ -> do + let num = ord val - 48 + if num >= 0 && num <= 9 + then SPartial 1 $ SPAfterSign 1 (intToInteger num) + else SError $ exitSPInitial $ show val + step (SPSign multiplier) val = + let num = ord val - 48 + in if num >= 0 && num <= 9 + then SPartial 1 $ SPAfterSign multiplier (intToInteger num) + else SError $ exitSPSign $ show val + step (SPAfterSign multiplier buf) val = + case val of + '.' -> SContinue 1 $ SPDot multiplier buf + 'e' -> SContinue 1 $ SPExponent multiplier buf 0 + 'E' -> SContinue 1 $ SPExponent multiplier buf 0 + _ -> + let num = ord val - 48 + in if num >= 0 && num <= 9 + then + SPartial 1 + $ SPAfterSign multiplier (combineNum buf (intToInteger num)) + else SDone 0 $ exitSPAfterSign multiplier buf + step (SPDot multiplier buf) val = + let num = ord val - 48 + in if num >= 0 && num <= 9 + then SPartial 1 $ SPAfterDot multiplier (combineNum buf (intToInteger num)) 1 + else SDone (-1) $ exitSPAfterSign multiplier buf + step (SPAfterDot multiplier buf decimalPlaces) val = + case val of + 'e' -> SContinue 1 $ SPExponent multiplier buf decimalPlaces + 'E' -> SContinue 1 $ SPExponent multiplier buf decimalPlaces + _ -> + let num = ord val - 48 + in if num >= 0 && num <= 9 + then + SPartial 1 + $ SPAfterDot + multiplier + (combineNum buf (intToInteger num)) + (decimalPlaces + 1) + else SDone 0 $ exitSPAfterDot multiplier buf decimalPlaces + step (SPExponent multiplier buf decimalPlaces) val = + case val of + '+' -> SContinue 1 (SPExponentWithSign multiplier buf decimalPlaces 1) + '-' -> SContinue 1 (SPExponentWithSign multiplier buf decimalPlaces (-1)) + _ -> do + let num = ord val - 48 + if num >= 0 && num <= 9 + then SPartial 1 $ SPAfterExponent multiplier buf decimalPlaces 1 num + else SDone (-1) $ exitSPAfterDot multiplier buf decimalPlaces + step (SPExponentWithSign mult buf decimalPlaces powerMult) val = + let num = ord val - 48 + in if num >= 0 && num <= 9 + then SPartial 1 $ SPAfterExponent mult buf decimalPlaces powerMult num + else SDone (-2) $ exitSPAfterDot mult buf decimalPlaces + step (SPAfterExponent mult num decimalPlaces powerMult buf) val = + let n = ord val - 48 + in if n >= 0 && n <= 9 + then + SPartial 1 + $ SPAfterExponent + mult num decimalPlaces powerMult (combineNum buf n) + else + SDone 0 + $ exitSPAfterExponent mult num decimalPlaces powerMult buf + + {-# INLINE extract #-} + extract SPInitial = FError $ exitSPInitial "end of input" + extract (SPSign _) = FError $ exitSPSign "end of input" + extract (SPAfterSign mult num) = FDone 0 $ exitSPAfterSign mult num + extract (SPDot mult num) = FDone (-1) $ exitSPAfterSign mult num + extract (SPAfterDot mult num decimalPlaces) = + FDone 0 $ exitSPAfterDot mult num decimalPlaces + extract (SPExponent mult num decimalPlaces) = + FDone (-1) $ exitSPAfterDot mult num decimalPlaces + extract (SPExponentWithSign mult num decimalPlaces _) = + FDone (-2) $ exitSPAfterDot mult num decimalPlaces + extract (SPAfterExponent mult num decimalPlaces powerMult powerNum) = + FDone 0 $ exitSPAfterExponent mult num decimalPlaces powerMult powerNum + +type MantissaInt = Int +type OverflowPower = Int + +{-# ANN type DoubleParseState Fuse #-} +data DoubleParseState + = DPInitial + | DPSign !Multiplier + | DPAfterSign !Multiplier !MantissaInt !OverflowPower + | DPDot !Multiplier !MantissaInt !OverflowPower + | DPAfterDot !Multiplier !MantissaInt !OverflowPower + | DPExponent !Multiplier !MantissaInt !OverflowPower + | DPExponentWithSign !Multiplier !MantissaInt !OverflowPower !PowerMultiplier + | DPAfterExponent !Multiplier !MantissaInt !OverflowPower !PowerMultiplier !Power + +-- | A fast, custom parser for double precision flaoting point numbers. Returns +-- (mantissa, exponent) tuple. This is much faster than 'number' because it +-- assumes the number will fit in a 'Double' type and uses 'Int' representation +-- to store mantissa. -- --- === Examples +-- Number larger than 'Double' may overflow. Int overflow is not checked in the +-- exponent. -- --- Examples with behaviour identical to 'read', if you feed an empty --- continuation to the first result: +{-# INLINE doubleParser #-} +doubleParser :: Monad m => Parser Char m (Int, Int) +doubleParser = Parser (\s a -> return $ step s a) initial (return . extract) + + where + + -- XXX Assuming Int = Int64 + + -- Up to 58 bits Int won't overflow + -- ghci> (2^59-1)*10+9 :: Int + -- 5764607523034234879 + mask :: Word + mask = 0x7c00000000000000 -- 58 bits, ignore the sign bit + + {-# INLINE combineNum #-} + combineNum :: Int -> Int -> Int -> (Int, Int) + combineNum mantissa power num = + if fromIntegral mantissa .&. mask == 0 + then (mantissa * 10 + num, power) + else (mantissa, power + 1) + + {-# INLINE initial #-} + initial = pure $ IPartial DPInitial + + exitDPInitial msg = + "number: expecting sign or decimal digit, got " ++ msg + exitDPSign msg = + "number: expecting decimal digit, got " ++ msg + exitDPAfterSign multiplier num opower = (fromIntegral multiplier * num, opower) + exitDPAfterDot multiplier num opow = + (fromIntegral multiplier * num , opow) + exitDPAfterExponent mult num opow powerMult powerNum = + (fromIntegral mult * num, opow + powerMult * powerNum) + + {-# INLINE step #-} + step DPInitial val = + case val of + '+' -> SContinue 1 (DPSign 1) + '-' -> SContinue 1 (DPSign (-1)) + _ -> do + let num = ord val - 48 + if num >= 0 && num <= 9 + then SPartial 1 $ DPAfterSign 1 num 0 + else SError $ exitDPInitial $ show val + step (DPSign multiplier) val = + let num = ord val - 48 + in if num >= 0 && num <= 9 + then SPartial 1 $ DPAfterSign multiplier num 0 + else SError $ exitDPSign $ show val + step (DPAfterSign multiplier buf opower) val = + case val of + '.' -> SContinue 1 $ DPDot multiplier buf opower + 'e' -> SContinue 1 $ DPExponent multiplier buf opower + 'E' -> SContinue 1 $ DPExponent multiplier buf opower + _ -> + let num = ord val - 48 + in if num >= 0 && num <= 9 + then + let (buf1, power1) = combineNum buf opower num + in SPartial 1 + $ DPAfterSign multiplier buf1 power1 + else SDone 0 $ exitDPAfterSign multiplier buf opower + step (DPDot multiplier buf opower) val = + let num = ord val - 48 + in if num >= 0 && num <= 9 + then + let (buf1, power1) = combineNum buf opower num + in SPartial 1 $ DPAfterDot multiplier buf1 (power1 - 1) + else SDone (-1) $ exitDPAfterSign multiplier buf opower + step (DPAfterDot multiplier buf opower) val = + case val of + 'e' -> SContinue 1 $ DPExponent multiplier buf opower + 'E' -> SContinue 1 $ DPExponent multiplier buf opower + _ -> + let num = ord val - 48 + in if num >= 0 && num <= 9 + then + let (buf1, power1) = combineNum buf opower num + in SPartial 1 $ DPAfterDot multiplier buf1 (power1 - 1) + else SDone 0 $ exitDPAfterDot multiplier buf opower + step (DPExponent multiplier buf opower) val = + case val of + '+' -> SContinue 1 (DPExponentWithSign multiplier buf opower 1) + '-' -> SContinue 1 (DPExponentWithSign multiplier buf opower (-1)) + _ -> do + let num = ord val - 48 + if num >= 0 && num <= 9 + then SPartial 1 $ DPAfterExponent multiplier buf opower 1 num + else SDone (-1) $ exitDPAfterDot multiplier buf opower + step (DPExponentWithSign mult buf opower powerMult) val = + let num = ord val - 48 + in if num >= 0 && num <= 9 + then SPartial 1 $ DPAfterExponent mult buf opower powerMult num + else SDone (-2) $ exitDPAfterDot mult buf opower + step (DPAfterExponent mult num opower powerMult buf) val = + let n = ord val - 48 + in if n >= 0 && n <= 9 + then + SPartial 1 + $ DPAfterExponent mult num opower powerMult (buf * 10 + n) + else SDone 0 $ exitDPAfterExponent mult num opower powerMult buf + + {-# INLINE extract #-} + extract DPInitial = FError $ exitDPInitial "end of input" + extract (DPSign _) = FError $ exitDPSign "end of input" + extract (DPAfterSign mult num opow) = FDone 0 $ exitDPAfterSign mult num opow + extract (DPDot mult num opow) = FDone (-1) $ exitDPAfterSign mult num opow + extract (DPAfterDot mult num opow) = + FDone 0 $ exitDPAfterDot mult num opow + extract (DPExponent mult num opow) = + FDone (-1) $ exitDPAfterDot mult num opow + extract (DPExponentWithSign mult num opow _) = + FDone (-2) $ exitDPAfterDot mult num opow + extract (DPAfterExponent mult num opow powerMult powerNum) = + FDone 0 $ exitDPAfterExponent mult num opow powerMult powerNum + +-- XXX We can have a `realFloat` parser instead to parse any RealFloat value. +-- And a integral parser to read any integral value. + +-- XXX This is very expensive, takes much more time than the rest of the +-- parsing. Need to look into fromRational. + +-- | @mkDouble mantissa exponent@ converts a mantissa and exponent to a +-- 'Double' value equivalent to @mantissa * 10^exponent@. It does not check for +-- overflow, powers more than 308 will overflow. +{-# INLINE mkDouble #-} +mkDouble :: Integer -> Int -> Double +mkDouble mantissa power = + if power > 0 + then fromRational ((mantissa * 10 ^ power) % 1) + else fromRational (mantissa % 10 ^ (-power)) + +-- | Parse a decimal 'Double' value. This parser accepts an optional sign (+ or +-- -) followed by at least one decimal digit. Decimal digits are optionally +-- followed by a decimal point and at least one decimal digit after the point. +-- This parser accepts the maximal valid input as long as it gives a valid +-- number. Specifcally a trailing decimal point is allowed but not consumed. +-- This function does not accept \"NaN\" or \"Infinity\" string representations +-- of double values. -- --- > IS.parse double (IS.fromList "3") == 3.0 --- > IS.parse double (IS.fromList "3.1") == 3.1 --- > IS.parse double (IS.fromList "3e4") == 30000.0 --- > IS.parse double (IS.fromList "3.1e4") == 31000.0 --- > IS.parse double (IS.fromList "3e") == 30 +-- Definition: -- --- Examples with behaviour identical to 'read': +-- >>> double = uncurry Unicode.mkDouble <$> Unicode.number -- --- > IS.parse (IS.fromList ".3") == error "Parse failed" --- > IS.parse (IS.fromList "e3") == error "Parse failed" +-- Examples: -- --- Example of difference from 'read': +-- >>> p = Stream.parsePos Unicode.double . Stream.fromList -- --- > IS.parse double (IS.fromList "3.foo") == 3.0 +-- >>> p "-1.23e-123" +-- Right (-1.23e-123) -- --- This function does not accept string representations of \"NaN\" or --- \"Infinity\". +-- Trailing input examples: -- --- /Unimplemented/ -double :: Parser Char m Double -double = undefined +-- >>> p "1." +-- Right 1.0 +-- +-- >>> p "1.2.3" +-- Right 1.2 +-- +-- >>> p "1e" +-- Right 1.0 +-- +-- >>> p "1e2.3" +-- Right 100.0 +-- +-- >>> p "1+2" +-- Right 1.0 +-- +-- Error cases: +-- +-- >>> p "" +-- Left (ParseErrorPos 0 "number: expecting sign or decimal digit, got end of input") +-- +-- >>> p ".1" +-- Left (ParseErrorPos 1 "number: expecting sign or decimal digit, got '.'") +-- +-- >>> p "+" +-- Left (ParseErrorPos 1 "number: expecting decimal digit, got end of input") +-- +{-# INLINE double #-} +double :: Monad m => Parser Char m Double +double = fmap (\(m,e) -> mkDouble (fromIntegral m) e) doubleParser diff --git a/src/Streamly/Internal/Unicode/Stream.hs b/src/Streamly/Internal/Unicode/Stream.hs --- a/src/Streamly/Internal/Unicode/Stream.hs +++ b/src/Streamly/Internal/Unicode/Stream.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Internal.Unicode.Stream -- Copyright : (c) 2018 Composewell Technologies @@ -11,10 +12,18 @@ module Streamly.Internal.Unicode.Stream ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- XXX Use to/from instead of encode/decode for more compact naming. + -- * Construction (Decoding) decodeLatin1 - -- ** UTF-8 Decoding + -- ** UTF-8 Byte Stream Decoding , CodingFailureMode(..) , writeCharUtf8' , parseCharUtf8With @@ -22,7 +31,11 @@ , decodeUtf8' , decodeUtf8_ - -- ** Resumable UTF-8 Decoding + -- ** UTF-16 Byte Stream Decoding + , decodeUtf16le' + , decodeUtf16le + + -- ** Resumable UTF-8 Byte Stream Decoding , DecodeError(..) , DecodeState , CodePoint @@ -33,14 +46,15 @@ , decodeUtf8Chunks , decodeUtf8Chunks' , decodeUtf8Chunks_ + -- , fromUtf8ChunksEndByLn -- * Elimination (Encoding) - -- ** Latin1 Encoding + -- ** Latin1 Encoding to Byte Stream , encodeLatin1 , encodeLatin1' , encodeLatin1_ - -- ** UTF-8 Encoding + -- ** UTF-8 Encoding to Byte Stream , readCharUtf8' , readCharUtf8 , readCharUtf8_ @@ -48,6 +62,21 @@ , encodeUtf8' , encodeUtf8_ , encodeStrings + + -- ** UTF-8 Encoding to Chunk Stream + -- , toUtf8Chunks + -- , toUtf8Chunks' + -- , toUtf8Chunks_ + -- , toUtf8ChunksEndByLn + + -- , toPinnedUtf8Chunks + -- , toPinnedUtf8Chunks' + -- , toPinnedUtf8Chunks_ + -- , toPinnedUtf8ChunksEndByLn + + -- ** UTF-16 Encoding to Byte Stream + , encodeUtf16le' + , encodeUtf16le {- -- * Operations on character strings , strip -- (dropAround isSpace) @@ -56,10 +85,10 @@ -- * Transformation , stripHead - , lines - , words - , unlines - , unwords + , lines -- foldLines + , words -- foldWords + , unlines -- unfoldLines + , unwords -- unfoldWords -- * StreamD UTF8 Encoding / Decoding transformations. , decodeUtf8D @@ -74,6 +103,10 @@ -- * Decoding String Literals , fromStr# + -- * Word16 Utilities + , mkEvenW8Chunks + , swapByteOrder + -- * Deprecations , decodeUtf8Lax , encodeLatin1Lax @@ -83,6 +116,10 @@ #include "inline.hs" +-- MachDeps.h includes ghcautoconf.h that defines WORDS_BIGENDIAN for big endian +-- systems. +#include "MachDeps.h" + import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Bits (shiftR, shiftL, (.|.), (.&.)) @@ -90,7 +127,7 @@ #if MIN_VERSION_base(4,17,0) import Data.Char (generalCategory, GeneralCategory(Space)) #endif -import Data.Word (Word8) +import Data.Word (Word8, Word16) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Storable (Storable(..)) #ifndef __GHCJS__ @@ -102,34 +139,28 @@ import GHC.Ptr (Ptr (..), plusPtr) import System.IO.Unsafe (unsafePerformIO) import Streamly.Internal.Data.Array.Type (Array(..)) -import Streamly.Internal.Data.Array.Mut.Type (MutableByteArray) +import Streamly.Internal.Data.MutByteArray.Type (MutByteArray) import Streamly.Internal.Data.Fold (Fold) -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Stream.StreamD (Step (..)) +import Streamly.Internal.Data.Parser (Parser) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.Stream (Step (..)) import Streamly.Internal.Data.SVar.Type (adaptState) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import Streamly.Internal.Data.Unboxed (peekWith) +import Streamly.Internal.Data.Unbox (Unbox(peekAt)) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import Streamly.Internal.System.IO (unsafeInlineIO) import qualified Streamly.Data.Fold as Fold import qualified Streamly.Data.Unfold as Unfold -import qualified Streamly.Internal.Data.Array.Type as Array +import qualified Streamly.Internal.Data.Array as Array import qualified Streamly.Internal.Data.Parser as Parser (Parser) -import qualified Streamly.Internal.Data.Parser.ParserD as ParserD -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Parser as ParserD +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Stream as D import Prelude hiding (lines, words, unlines, unwords) --- $setup --- >>> :m --- >>> :set -XMagicHash --- >>> import Prelude hiding (lines, words, unlines, unwords) --- >>> import qualified Streamly.Data.Stream as Stream --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Internal.Unicode.Stream as Unicode --- >>> import Streamly.Internal.Unicode.Stream +#include "DocTestUnicodeStream.hs" ------------------------------------------------------------------------------- -- Latin1 decoding @@ -462,15 +493,15 @@ handleError err souldBackTrack = case cfm of - ErrorOnCodingFailure -> ParserD.Error err + ErrorOnCodingFailure -> ParserD.SError err TransliterateCodingFailure -> case souldBackTrack of - True -> ParserD.Done 1 replacementChar - False -> ParserD.Done 0 replacementChar + True -> ParserD.SDone 0 replacementChar + False -> ParserD.SDone 1 replacementChar DropOnCodingFailure -> case souldBackTrack of - True -> ParserD.Continue 1 UTF8CharDecodeInit - False -> ParserD.Continue 0 UTF8CharDecodeInit + True -> ParserD.SContinue 0 UTF8CharDecodeInit + False -> ParserD.SContinue 1 UTF8CharDecodeInit {-# INLINE step' #-} step' table UTF8CharDecodeInit x = @@ -480,7 +511,7 @@ -- change with the compiler versions, we need a more reliable -- "likely" primitive to control branch predication. return $ case x > 0x7f of - False -> ParserD.Done 0 $ unsafeChr $ fromIntegral x + False -> ParserD.SDone 1 $ unsafeChr $ fromIntegral x True -> let (Tuple' sv cp) = decode0 table x in case sv of @@ -489,12 +520,12 @@ ++ "Invalid first UTF8 byte" ++ show x in handleError msg False 0 -> error $ prefix ++ "unreachable state" - _ -> ParserD.Continue 0 (UTF8CharDecoding sv cp) + _ -> ParserD.SContinue 1 (UTF8CharDecoding sv cp) step' table (UTF8CharDecoding statePtr codepointPtr) x = return $ let (Tuple' sv cp) = decode1 table statePtr codepointPtr x in case sv of - 0 -> ParserD.Done 0 $ unsafeChr cp + 0 -> ParserD.SDone 1 $ unsafeChr cp 12 -> let msg = prefix ++ "Invalid subsequent UTF8 byte" @@ -504,16 +535,16 @@ ++ "accumulated value" ++ show codepointPtr in handleError msg True - _ -> ParserD.Continue 0 (UTF8CharDecoding sv cp) + _ -> ParserD.SContinue 1 (UTF8CharDecoding sv cp) {-# INLINE extract #-} extract UTF8CharDecodeInit = error $ prefix ++ "Not enough input" extract (UTF8CharDecoding _ _) = case cfm of ErrorOnCodingFailure -> - return $ ParserD.Error $ prefix ++ "Not enough input" + return $ ParserD.FError $ prefix ++ "Not enough input" TransliterateCodingFailure -> - return (ParserD.Done 0 replacementChar) + return (ParserD.FDone 0 replacementChar) -- XXX We shouldn't error out here. There is no way to represent an -- empty parser result unless we return a "Maybe" type. DropOnCodingFailure -> error $ prefix ++ "Not enough input" @@ -523,8 +554,8 @@ -- workflow requires backtracking 1 element. This can be revisited once "Fold" -- supports backtracking. {-# INLINE writeCharUtf8' #-} -writeCharUtf8' :: Monad m => Fold m Word8 Char -writeCharUtf8' = ParserD.toFold (parseCharUtf8WithD ErrorOnCodingFailure) +writeCharUtf8' :: Monad m => Parser Word8 m Char +writeCharUtf8' = parseCharUtf8WithD ErrorOnCodingFailure -- XXX The initial idea was to have "parseCharUtf8" and offload the error -- handling to another parser. So, say we had "parseCharUtf8'", @@ -556,7 +587,7 @@ where - prefix = "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: " + prefix = "Streamly.Internal.Data.Stream.decodeUtf8With: " {-# INLINE handleError #-} handleError e s = @@ -676,6 +707,188 @@ decodeUtf8Lax = decodeUtf8 ------------------------------------------------------------------------------- +-- Decoding Utf16 +------------------------------------------------------------------------------- + +data MkEvenW8ChunksState s w8 arr + = MECSInit s + | MECSBuffer w8 s + | MECSYieldAndInit arr s + | MECSYieldAndBuffer arr w8 s + +-- | Ensure chunks of even length. This can be used before casting the arrays to +-- Word16. Use this API when interacting with external data. +-- +-- The chunks are split and merged accordingly to create arrays of even length. +-- If the sum of length of all the arrays in the stream is odd then the trailing +-- byte of the last array is dropped. +-- +{-# INLINE_NORMAL mkEvenW8Chunks #-} +mkEvenW8Chunks :: Monad m => Stream m (Array Word8) -> Stream m (Array Word8) +mkEvenW8Chunks (D.Stream step state) = D.Stream step1 (MECSInit state) + + where + + {-# INLINE_LATE step1 #-} + step1 gst (MECSInit st) = do + r <- step (adaptState gst) st + return $ + case r of + Yield arr st1 -> + let len = Array.length arr + in if (len .&. 1) == 1 + then let arr1 = Array.unsafeSliceOffLen 0 (len - 1) arr + remElem = Array.unsafeGetIndex (len - 1) arr + in Yield arr1 (MECSBuffer remElem st1) + else Yield arr (MECSInit st1) + Skip s -> Skip (MECSInit s) + Stop -> Stop + step1 gst (MECSBuffer remElem st) = do + r <- step (adaptState gst) st + return $ + case r of + Yield arr st1 | Array.length arr == 0 -> + Skip (MECSBuffer remElem st1) + Yield arr st1 | Array.length arr == 1 -> + let fstElem = Array.unsafeGetIndex 0 arr + w16 = Array.fromList [remElem, fstElem] + in Yield w16 (MECSInit st1) + Yield arr st1 -> + let len = Array.length arr + in if (len .&. 1) == 1 + then let arr1 = Array.unsafeSliceOffLen 1 (len - 1) arr + fstElem = Array.unsafeGetIndex 0 arr + w16 = Array.fromList [remElem, fstElem] + in Yield w16 (MECSYieldAndInit arr1 st1) + else let arr1 = Array.unsafeSliceOffLen 1 (len - 2) arr + fstElem = Array.unsafeGetIndex 0 arr + lstElem = Array.unsafeGetIndex (len - 1) arr + w16 = Array.fromList [remElem, fstElem] + in Yield w16 + (MECSYieldAndBuffer arr1 lstElem st1) + Skip s -> Skip (MECSBuffer remElem s) + Stop -> Stop -- Here the last Word8 is lost + step1 _ (MECSYieldAndInit arr st) = + pure $ Yield arr (MECSInit st) + step1 _ (MECSYieldAndBuffer arr lastElem st) = + pure $ Yield arr (MECSBuffer lastElem st) + +-- | Swap the byte order of Word16 +-- +-- > swapByteOrder 0xABCD == 0xCDAB +-- > swapByteOrder . swapByteOrder == id +{-# INLINE swapByteOrder #-} +swapByteOrder :: Word16 -> Word16 +swapByteOrder w = (w `shiftL` 8) .|. (w `shiftR` 8) + +data DecodeUtf16WithState w c s + = U16NoSurrogate s + | U16HighSurrogate w s + | U16D + | U16YAndC c (DecodeUtf16WithState w c s) + +{-# INLINE_NORMAL decodeUtf16With #-} +decodeUtf16With :: + Monad m + => CodingFailureMode + -> D.Stream m Word16 + -> D.Stream m Char +decodeUtf16With cfm (D.Stream step state) = + D.Stream step1 (U16NoSurrogate state) + + where + + prefix = "Streamly.Internal.Unicode.Stream.decodeUtf16With: " + + {-# INLINE combineSurrogates #-} + combineSurrogates hi lo = + let first10 = fromIntegral (hi - utf16HighSurrogate) `shiftL` 10 + second10 = fromIntegral (lo - utf16LowSurrogate) + in unsafeChr (0x10000 + (first10 .|. second10)) + + {-# INLINE transliterateOrError #-} + transliterateOrError e s = + case cfm of + ErrorOnCodingFailure -> error e + TransliterateCodingFailure -> U16YAndC replacementChar s + DropOnCodingFailure -> s + + {-# INLINE inputUnderflow #-} + inputUnderflow = + case cfm of + ErrorOnCodingFailure -> error $ prefix ++ "Input Underflow" + TransliterateCodingFailure -> U16YAndC replacementChar U16D + DropOnCodingFailure -> U16D + + {-# INLINE_LATE step1 #-} + step1 gst (U16NoSurrogate st) = do + r <- step (adaptState gst) st + pure $ + case r of + Yield x st1 + | x < 0xD800 || x > 0xDFFF -> + Yield (unsafeChr (fromIntegral x)) (U16NoSurrogate st1) + | x >= 0xD800 && x <= 0xDBFF -> + Skip (U16HighSurrogate x st1) + | otherwise -> + let msg = prefix + ++ "Invalid first UTF16 word " ++ show x + in Skip $ + transliterateOrError msg (U16NoSurrogate st1) + Skip st1 -> Skip (U16NoSurrogate st1) + Stop -> Stop + step1 gst (U16HighSurrogate hi st) = do + r <- step (adaptState gst) st + pure $ + case r of + Yield x st1 + | x >= 0xDC00 && x <= 0xDFFF -> + Yield (combineSurrogates hi x) (U16NoSurrogate st1) + | otherwise -> + let msg = prefix + ++ "Invalid subsequent UTF16 word " ++ show x + ++ " in state " ++ show hi + in Skip $ + transliterateOrError msg (U16NoSurrogate st1) + Skip st1 -> Skip (U16HighSurrogate hi st1) + Stop -> Skip inputUnderflow + step1 _ (U16YAndC x st) = pure $ Yield x st + step1 _ U16D = pure Stop + +{-# INLINE decodeUtf16' #-} +decodeUtf16' :: Monad m => Stream m Word16 -> Stream m Char +decodeUtf16' = decodeUtf16With ErrorOnCodingFailure + +{-# INLINE decodeUtf16 #-} +decodeUtf16 :: Monad m => Stream m Word16 -> Stream m Char +decodeUtf16 = decodeUtf16With TransliterateCodingFailure + +-- | Similar to 'decodeUtf16le' but throws an error if an invalid codepoint is +-- encountered. +-- +{-# INLINE decodeUtf16le' #-} +decodeUtf16le' :: Monad m => Stream m Word16 -> Stream m Char +decodeUtf16le' = + decodeUtf16' +#ifdef WORDS_BIGENDIAN + . fmap swapByteOrder +#endif + +-- | Decode a UTF-16 encoded stream to a stream of Unicode characters. Any +-- invalid codepoint encountered is replaced with the unicode replacement +-- character. +-- +-- The Word16s are expected to be in the little-endian byte order. +-- +{-# INLINE decodeUtf16le #-} +decodeUtf16le :: Monad m => Stream m Word16 -> Stream m Char +decodeUtf16le = + decodeUtf16 +#ifdef WORDS_BIGENDIAN + . fmap swapByteOrder +#endif + +------------------------------------------------------------------------------- -- Decoding Array Streams ------------------------------------------------------------------------------- @@ -684,9 +897,9 @@ #endif data FlattenState s = OuterLoop s !(Maybe (DecodeState, CodePoint)) - | InnerLoopDecodeInit s MutableByteArray !Int !Int - | InnerLoopDecodeFirst s MutableByteArray !Int !Int Word8 - | InnerLoopDecoding s MutableByteArray !Int !Int + | InnerLoopDecodeInit s MutByteArray !Int !Int + | InnerLoopDecodeFirst s MutByteArray !Int !Int Word8 + | InnerLoopDecoding s MutByteArray !Int !Int !DecodeState !CodePoint | YAndC !Char (FlattenState s) -- These constructors can be -- encoded in the UTF8DecodeState @@ -720,7 +933,7 @@ case cfm of ErrorOnCodingFailure -> error $ - show "Streamly.Internal.Data.Stream.StreamD." + show "Streamly.Internal.Data.Stream." ++ "decodeUtf8ArraysWith: Input Underflow" TransliterateCodingFailure -> YAndC replacementChar D DropOnCodingFailure -> D @@ -745,7 +958,7 @@ | p == end = do return $ Skip $ OuterLoop st Nothing step' _ _ (InnerLoopDecodeInit st contents p end) = do - x <- liftIO $ peekWith contents p + x <- liftIO $ peekAt p contents -- Note: It is important to use a ">" instead of a "<=" test here for -- GHC to generate code layout for default branch prediction for the -- common case. This is fragile and might change with the compiler @@ -769,7 +982,7 @@ Skip $ transliterateOrError ( - "Streamly.Internal.Data.Stream.StreamD." + "Streamly.Internal.Data.Stream." ++ "decodeUtf8ArraysWith: Invalid UTF8" ++ " codepoint encountered" ) @@ -779,7 +992,7 @@ step' _ _ (InnerLoopDecoding st _ p end sv cp) | p == end = return $ Skip $ OuterLoop st (Just (sv, cp)) step' table _ (InnerLoopDecoding st contents p end statePtr codepointPtr) = do - x <- liftIO $ peekWith contents p + x <- liftIO $ peekAt p contents let (Tuple' sv cp) = decode1 table statePtr codepointPtr x return $ case sv of @@ -792,7 +1005,7 @@ Skip $ transliterateOrError ( - "Streamly.Internal.Data.Stream.StreamD." + "Streamly.Internal.Data.Stream." ++ "decodeUtf8ArraysWith: Invalid UTF8" ++ " codepoint encountered" ) @@ -834,12 +1047,12 @@ -- Encoding Unicode (UTF-8) Characters ------------------------------------------------------------------------------- -data WList = WCons !Word8 !WList | WNil +data WList a = WCons !a !(WList a) | WNil -- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8. {-# INLINE ord2 #-} -ord2 :: Char -> WList +ord2 :: Char -> (WList Word8) ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil)) where n = ord c @@ -847,7 +1060,7 @@ x2 = fromIntegral $ (n .&. 0x3F) + 0x80 {-# INLINE ord3 #-} -ord3 :: Char -> WList +ord3 :: Char -> (WList Word8) ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil))) where n = ord c @@ -856,7 +1069,7 @@ x3 = fromIntegral $ (n .&. 0x3F) + 0x80 {-# INLINE ord4 #-} -ord4 :: Char -> WList +ord4 :: Char -> (WList Word8) ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil)))) where n = ord c @@ -866,7 +1079,7 @@ x4 = fromIntegral $ (n .&. 0x3F) + 0x80 {-# INLINE_NORMAL readCharUtf8With #-} -readCharUtf8With :: Monad m => WList -> Unfold m Char Word8 +readCharUtf8With :: Monad m => (WList Word8) -> Unfold m Char Word8 readCharUtf8With surr = Unfold step inject where @@ -894,7 +1107,7 @@ -- paths (slow path). {-# INLINE_NORMAL encodeUtf8D' #-} encodeUtf8D' :: Monad m => D.Stream m Char -> D.Stream m Word8 -encodeUtf8D' = D.unfoldMany readCharUtf8' +encodeUtf8D' = D.unfoldEach readCharUtf8' -- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. When -- any invalid character (U+D800-U+D8FF) is encountered in the input stream the @@ -913,7 +1126,7 @@ -- {-# INLINE_NORMAL encodeUtf8D #-} encodeUtf8D :: Monad m => D.Stream m Char -> D.Stream m Word8 -encodeUtf8D = D.unfoldMany readCharUtf8 +encodeUtf8D = D.unfoldEach readCharUtf8 -- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any -- Invalid characters (U+D800-U+D8FF) in the input stream are replaced by the @@ -929,7 +1142,7 @@ {-# INLINE_NORMAL encodeUtf8D_ #-} encodeUtf8D_ :: Monad m => D.Stream m Char -> D.Stream m Word8 -encodeUtf8D_ = D.unfoldMany readCharUtf8_ +encodeUtf8D_ = D.unfoldEach readCharUtf8_ -- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any -- Invalid characters (U+D800-U+D8FF) in the input stream are dropped. @@ -946,9 +1159,84 @@ encodeUtf8Lax = encodeUtf8 ------------------------------------------------------------------------------- +-- Encoding to Utf16 +------------------------------------------------------------------------------- + +{-# INLINE utf16LowSurrogate #-} +utf16LowSurrogate :: Word16 +utf16LowSurrogate = 0xDC00 + +{-# INLINE utf16HighSurrogate #-} +utf16HighSurrogate :: Word16 +utf16HighSurrogate = 0xD800 + +{-# INLINE_NORMAL readCharUtf16With #-} +readCharUtf16With :: Monad m => WList Word16 -> Unfold m Char Word16 +readCharUtf16With invalidReplacement = Unfold step inject + + where + + inject c = + return $ case ord c of + x | x < 0xD800 -> fromIntegral x `WCons` WNil + | x > 0xDFFF && x <= 0xFFFF -> fromIntegral x `WCons` WNil + | x >= 0x10000 && x <= 0x10FFFF -> + let u = x - 0x10000 -- 20 bits + h = utf16HighSurrogate + + fromIntegral (u `shiftR` 10) -- 10 bits + l = utf16LowSurrogate + + fromIntegral (u .&. 0x3FF) -- 10 bits + in WCons h $ WCons l WNil + | otherwise -> invalidReplacement + + {-# INLINE_LATE step #-} + step WNil = return Stop + step (WCons x xs) = return $ Yield x xs + +{-# INLINE encodeUtf16' #-} +encodeUtf16' :: Monad m => Stream m Char -> Stream m Word16 +encodeUtf16' = D.unfoldEach (readCharUtf16With errString) + where + errString = + error + $ "Streamly.Internal.Unicode.encodeUtf16': Encountered an \ + invalid character" + +{-# INLINE encodeUtf16 #-} +encodeUtf16 :: Monad m => Stream m Char -> Stream m Word16 +encodeUtf16 = D.unfoldEach (readCharUtf16With WNil) + +-- | Similar to 'encodeUtf16le' but throws an error if any invalid character is +-- encountered. +-- +{-# INLINE encodeUtf16le' #-} +encodeUtf16le' :: Monad m => Stream m Char -> Stream m Word16 +encodeUtf16le' = +#ifdef WORDS_BIGENDIAN + fmap swapByteOrder . +#endif + encodeUtf16' + +-- | Encode a stream of Unicode characters to a UTF-16 encoded stream. Any +-- invalid characters in the input stream are replaced by the Unicode +-- replacement character U+FFFD. +-- +-- The resulting Word16s are encoded in little-endian byte order. +-- +{-# INLINE encodeUtf16le #-} +encodeUtf16le :: Monad m => Stream m Char -> Stream m Word16 +encodeUtf16le = +#ifdef WORDS_BIGENDIAN + fmap swapByteOrder . +#endif + encodeUtf16 + +------------------------------------------------------------------------------- -- Decoding string literals ------------------------------------------------------------------------------- +-- XXX decodeCString# + -- | Read UTF-8 encoded bytes as chars from an 'Addr#' until a 0 byte is -- encountered, the 0 byte is not included in the stream. -- @@ -962,7 +1250,7 @@ -- {-# INLINE fromStr# #-} fromStr# :: MonadIO m => Addr# -> Stream m Char -fromStr# addr = decodeUtf8 $ Stream.fromByteStr# addr +fromStr# addr = decodeUtf8 $ Stream.fromCString# addr ------------------------------------------------------------------------------- -- Encode streams of containers @@ -978,7 +1266,7 @@ -> Unfold m a Char -> a -> m (Array Word8) -encodeObject encode u = Stream.fold Array.write . encode . Stream.unfold u +encodeObject encode u = Stream.fold Array.create . encode . Stream.unfold u -- | Encode a stream of container objects using the supplied encoding scheme. -- Each object is encoded as an @Array Word8@. @@ -1016,7 +1304,7 @@ -- | Remove leading whitespace from a string. -- --- > stripHead = Stream.dropWhile isSpace +-- >>> stripHead = Stream.dropWhile Char.isSpace -- -- /Pre-release/ {-# INLINE stripHead #-} @@ -1026,11 +1314,15 @@ -- | Fold each line of the stream using the supplied 'Fold' -- and stream the result. -- --- >>> Stream.fold Fold.toList $ lines Fold.toList (Stream.fromList "lines\nthis\nstring\n\n\n") --- ["lines","this","string","",""] +-- Definition: -- --- > lines = Stream.splitOnSuffix (== '\n') +-- >>> lines f = Stream.foldMany (Fold.takeEndBy_ (== '\n') f) -- +-- Usage: +-- +-- >>> Stream.toList $ Unicode.lines Fold.toList (Stream.fromList "line1\nline2\nline3\n\n\n") +-- ["line1","line2","line3","",""] +-- -- /Pre-release/ {-# INLINE lines #-} lines :: Monad m => Fold m Char b -> Stream m Char -> Stream m b @@ -1054,14 +1346,17 @@ where uc = fromIntegral (ord c) :: Word --- | Fold each word of the stream using the supplied 'Fold' --- and stream the result. +-- | Fold each word of the stream using the supplied 'Fold'. -- --- >>> Stream.fold Fold.toList $ words Fold.toList (Stream.fromList "fold these words") --- ["fold","these","words"] +-- Definition: -- --- > words = Stream.wordsBy isSpace +-- >>> words = Stream.wordsBy Char.isSpace -- +-- Usage: +-- +-- >>> Stream.toList $ Unicode.words Fold.toList (Stream.fromList " ab cd ef ") +-- ["ab","cd","ef"] +-- -- /Pre-release/ {-# INLINE words #-} words :: Monad m => Fold m Char b -> Stream m Char -> Stream m b @@ -1070,26 +1365,24 @@ -- | Unfold a stream to character streams using the supplied 'Unfold' -- and concat the results suffixing a newline character @\\n@ to each stream. -- --- @ --- unlines = Stream.interposeSuffix '\n' --- unlines = Stream.intercalateSuffix Unfold.fromList "\n" --- @ +-- Definition: -- +-- >>> unlines = Stream.unfoldEachEndBy '\n' +-- >>> unlines = Stream.unfoldEachEndBySeq "\n" Unfold.fromList +-- -- /Pre-release/ {-# INLINE unlines #-} unlines :: MonadIO m => Unfold m a Char -> Stream m a -> Stream m Char -unlines = Stream.interposeSuffix '\n' +unlines = Stream.unfoldEachEndBy '\n' -- | Unfold the elements of a stream to character streams using the supplied -- 'Unfold' and concat the results with a whitespace character infixed between -- the streams. -- --- @ --- unwords = Stream.interpose ' ' --- unwords = Stream.intercalate Unfold.fromList " " --- @ +-- >>> unwords = Stream.unfoldEachSepBy ' ' +-- >>> unwords = Stream.unfoldEachSepBySeq " " Unfold.fromList -- -- /Pre-release/ {-# INLINE unwords #-} unwords :: MonadIO m => Unfold m a Char -> Stream m a -> Stream m Char -unwords = Stream.interpose ' ' +unwords = Stream.unfoldEachSepBy ' ' diff --git a/src/Streamly/Internal/Unicode/String.hs b/src/Streamly/Internal/Unicode/String.hs --- a/src/Streamly/Internal/Unicode/String.hs +++ b/src/Streamly/Internal/Unicode/String.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Internal.Unicode.String -- Copyright : (c) 2022 Composewell Technologies @@ -31,14 +32,21 @@ -- using Haskell functions. module Streamly.Internal.Unicode.String - ( str + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + str ) where import Control.Applicative (Alternative(..)) import Control.Exception (displayException) import Data.Functor.Identity (runIdentity) -import Streamly.Internal.Data.Parser (Parser) +import Streamly.Internal.Data.Parser (Parser, ParseError) import Language.Haskell.TH import Language.Haskell.TH.Quote @@ -49,11 +57,8 @@ import qualified Streamly.Data.Stream as Stream (fromList, parse) import qualified Streamly.Internal.Unicode.Parser as Parser --- $setup --- >>> :m --- >>> :set -XQuasiQuotes --- >>> import Streamly.Internal.Unicode.String --- +#include "DocTestUnicodeString.hs" + -------------------------------------------------------------------------------- -- Parsing -------------------------------------------------------------------------------- @@ -101,9 +106,12 @@ strExp :: [StrSegment] -> Q Exp strExp xs = appE [| concat |] $ listE $ map strSegmentExp xs +parseStr :: String -> Either ParseError [StrSegment] +parseStr = runIdentity . Stream.parse strParser . Stream.fromList + expandVars :: String -> Q Exp -expandVars ln = - case runIdentity $ Stream.parse strParser (Stream.fromList ln) of +expandVars input = + case parseStr input of Left e -> fail $ "str QuasiQuoter parse error: " ++ displayException e Right x -> @@ -135,9 +143,6 @@ -- world!|] -- :} -- "hello world!" --- --- Bugs: because of a bug in parsers, a lone # at the end of input gets --- removed. -- str :: QuasiQuoter str = diff --git a/src/Streamly/Unicode/Parser.hs b/src/Streamly/Unicode/Parser.hs --- a/src/Streamly/Unicode/Parser.hs +++ b/src/Streamly/Unicode/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Unicode.Parser -- Copyright : (c) 2021 Composewell Technologies @@ -12,9 +13,15 @@ module Streamly.Unicode.Parser ( - -- * Single Chars + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup - -- Any char + -- * Single Chars + + -- Any char char , charIgnoreCase @@ -50,6 +57,7 @@ -- * Digit Sequences (Numbers) , decimal , hexadecimal + , double -- * Modifiers , signed @@ -57,3 +65,5 @@ where import Streamly.Internal.Unicode.Parser + +#include "DocTestUnicodeParser.hs" diff --git a/src/Streamly/Unicode/Stream.hs b/src/Streamly/Unicode/Stream.hs --- a/src/Streamly/Unicode/Stream.hs +++ b/src/Streamly/Unicode/Stream.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Unicode.Stream -- Copyright : (c) 2020 Composewell Technologies @@ -24,14 +25,11 @@ -- routines in this module and then written to IO devices or to arrays in -- memory. -- --- If you have to store a 'Char' stream in memory you can convert it into a --- 'String' using 'Streamly.Data.Fold.toList' fold. The 'String' type can be --- more efficient than pinned arrays for short and short lived strings. --- --- For longer or long lived streams you can 'Streamly.Data.Stream.fold' the +-- If you have to store a 'Char' stream in memory you can +-- 'Streamly.Data.Stream.fold' the -- 'Char' stream as @Array Char@ using the array 'Streamly.Data.Array.write' --- fold. The 'Array' type provides a more compact representation and pinned --- memory reducing GC overhead. If space efficiency is a concern you can use +-- fold. The 'Array' type provides a more compact representation +-- reducing GC overhead. If space efficiency is a concern you can use -- 'encodeUtf8'' on the 'Char' stream before writing it to an 'Array' providing -- an even more compact representation. -- @@ -69,16 +67,21 @@ -- Some experimental APIs to conveniently process text using the -- @Array Char@ represenation directly can be found in -- "Streamly.Internal.Unicode.Array". - --- XXX an unpinned array representation can be useful to store short and short --- lived strings in memory. -- module Streamly.Unicode.Stream ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + -- * Construction (Decoding) decodeLatin1 , decodeUtf8 , decodeUtf8' + , decodeUtf16le + , decodeUtf16le' , decodeUtf8Chunks -- * Elimination (Encoding) @@ -86,6 +89,8 @@ , encodeLatin1' , encodeUtf8 , encodeUtf8' + , encodeUtf16le + , encodeUtf16le' , encodeStrings {- -- * Operations on character strings @@ -105,3 +110,5 @@ import Streamly.Internal.Unicode.Stream import Prelude hiding (lines, words, unlines, unwords) + +#include "DocTestUnicodeStream.hs" diff --git a/src/Streamly/Unicode/String.hs b/src/Streamly/Unicode/String.hs --- a/src/Streamly/Unicode/String.hs +++ b/src/Streamly/Unicode/String.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Streamly.Unicode.String -- Copyright : (c) 2022 Composewell Technologies @@ -7,10 +8,23 @@ -- Portability : GHC -- -- Convenient template Haskell quasiquoters to format strings. +-- +-- The 'str' quasiquoter retains newlines in the string when the line is split +-- across multiple lines. The @unwords . lines@ idiom can be used on the +-- resulting string to collapse it into a single line. module Streamly.Unicode.String - ( str + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + str ) where import Streamly.Internal.Unicode.String + +#include "DocTestUnicodeString.hs" diff --git a/src/config.h.in b/src/config.h.in --- a/src/config.h.in +++ b/src/config.h.in @@ -1,6 +1,6 @@ /* src/config.h.in. Generated from configure.ac by autoheader. */ -/* Define to 1 if you have the `clock_gettime' function. */ +/* Define to 1 if you have the 'clock_gettime' function. */ #undef HAVE_CLOCK_GETTIME /* Define to 1 if you have the header file. */ @@ -51,7 +51,7 @@ /* Define to the version of this package. */ #undef PACKAGE_VERSION -/* Define to 1 if all of the C90 standard headers exist (not just the ones +/* Define to 1 if all of the C89 standard headers exist (not just the ones required in a freestanding environment). This macro is provided for backward compatibility; new code need not use it. */ #undef STDC_HEADERS diff --git a/src/deprecation.h b/src/deprecation.h new file mode 100644 --- /dev/null +++ b/src/deprecation.h @@ -0,0 +1,9 @@ +#define RENAME(_old, _new) \ +{-# DEPRECATED _old "Please use _new instead." #-}; \ +{-# INLINE _old #-}; \ +_old = _new + +#define RENAME_PRIME(_old, _new) \ +{-# DEPRECATED _old "Please use _new' instead." #-}; \ +{-# INLINE _old #-}; \ +_old = _new' diff --git a/src/doctest/DocTestControlException.hs b/src/doctest/DocTestControlException.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestControlException.hs @@ -0,0 +1,13 @@ +{- $setup + +>>> :m +>>> import Control.Monad (when) +>>> import Control.Concurrent (threadDelay) +>>> import Data.Function ((&)) +>>> import System.IO (hClose, IOMode(..), openFile) + +>>> import Streamly.Data.Stream (Stream) +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Control.Exception as Exception +-} diff --git a/src/doctest/DocTestDataArray.hs b/src/doctest/DocTestDataArray.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataArray.hs @@ -0,0 +1,22 @@ +{- $setup +>>> :m +>>> :set -XFlexibleContexts +>>> :set -XMagicHash +>>> import Data.Function ((&)) +>>> import Data.Functor.Identity (Identity(..)) +>>> import System.IO.Unsafe (unsafePerformIO) + +>>> import Streamly.Data.Array (Array) +>>> import Streamly.Data.Stream (Stream) + +>>> import qualified Streamly.Data.Array as Array +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.ParserK as ParserK +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.StreamK as StreamK + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.Array as Array +>>> import qualified Streamly.Internal.Data.Stream as Stream +-} diff --git a/src/doctest/DocTestDataFold.hs b/src/doctest/DocTestDataFold.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataFold.hs @@ -0,0 +1,33 @@ +{- $setup +>>> :m +>>> :set -XFlexibleContexts +>>> import Control.Monad (void) +>>> import qualified Data.Foldable as Foldable +>>> import Data.Bifunctor(bimap) +>>> import Data.Function ((&)) +>>> import Data.Functor.Identity (Identity, runIdentity) +>>> import Data.IORef (newIORef, readIORef, writeIORef) +>>> import Data.Maybe (fromJust, isJust) +>>> import Data.Monoid (Endo(..), Last(..), Sum(..)) + +>>> import Streamly.Data.Array (Array) +>>> import Streamly.Data.Fold (Fold, Tee(..)) +>>> import Streamly.Data.Stream (Stream) + +>>> import qualified Data.Map as Map +>>> import qualified Data.Set as Set +>>> import qualified Data.IntSet as IntSet +>>> import qualified Streamly.Data.Array as Array +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.MutArray as MutArray +>>> import qualified Streamly.Data.Parser as Parser +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.StreamK as StreamK +>>> import qualified Streamly.Data.Unfold as Unfold + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.Fold as Fold +>>> import qualified Streamly.Internal.Data.Scanl as Scanl +>>> import qualified Streamly.Internal.Data.Stream as Stream +-} diff --git a/src/doctest/DocTestDataMutArray.hs b/src/doctest/DocTestDataMutArray.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataMutArray.hs @@ -0,0 +1,11 @@ +{- $setup +>>> :m +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.MutArray as MutArray +>>> import qualified Streamly.Data.Stream as Stream + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.Fold as Fold +>>> import qualified Streamly.Internal.Data.MutArray as MutArray +-} diff --git a/src/doctest/DocTestDataMutArrayGeneric.hs b/src/doctest/DocTestDataMutArrayGeneric.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataMutArrayGeneric.hs @@ -0,0 +1,10 @@ +{- $setup +>>> :m +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.MutArray.Generic as MutArray +>>> import qualified Streamly.Data.Stream as Stream + +For APIs that have not been released yet. + +>>> import Streamly.Internal.Data.MutArray.Generic as MutArray +-} diff --git a/src/doctest/DocTestDataParser.hs b/src/doctest/DocTestDataParser.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataParser.hs @@ -0,0 +1,20 @@ +{- $setup +>>> :m +>>> import Control.Applicative ((<|>)) +>>> import Data.Bifunctor (second) +>>> import Data.Char (isSpace) +>>> import qualified Data.Foldable as Foldable +>>> import qualified Data.Maybe as Maybe + +>>> import Streamly.Data.Fold (Fold) +>>> import Streamly.Data.Parser (Parser) + +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Parser as Parser +>>> import qualified Streamly.Data.Stream as Stream + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.Fold as Fold +>>> import qualified Streamly.Internal.Data.Parser as Parser +-} diff --git a/src/doctest/DocTestDataParserK.hs b/src/doctest/DocTestDataParserK.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataParserK.hs @@ -0,0 +1,18 @@ +{- $setup +>>> :m +>>> import Control.Applicative ((<|>)) +>>> import Data.Char (isDigit, isAlpha) + +>>> import Streamly.Data.Parser (Parser) +>>> import Streamly.Data.ParserK (ParserK) + +>>> import qualified Streamly.Data.Parser as Parser +>>> import qualified Streamly.Data.ParserK as ParserK +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.StreamK as StreamK +>>> import qualified Streamly.Unicode.Parser as Parser + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.ParserK as ParserK +-} diff --git a/src/doctest/DocTestDataScanl.hs b/src/doctest/DocTestDataScanl.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataScanl.hs @@ -0,0 +1,36 @@ +{- $setup +>>> :m +>>> :set -XFlexibleContexts +>>> import Control.Monad (void) +>>> import qualified Data.Foldable as Foldable +>>> import Data.Bifunctor(bimap) +>>> import Data.Function ((&)) +>>> import Data.Functor.Identity (Identity, runIdentity) +>>> import Data.IORef (newIORef, readIORef, writeIORef) +>>> import Data.Maybe (fromJust, isJust) +>>> import Data.Monoid (Endo(..), Last(..), Sum(..)) +>>> import Prelude hiding (length, sum, minimum, maximum) + +>>> import Streamly.Data.Array (Array) +>>> import Streamly.Data.Fold (Fold, Tee(..)) +>>> import Streamly.Data.Stream (Stream) + +>>> import qualified Data.Map as Map +>>> import qualified Data.Set as Set +>>> import qualified Data.IntSet as IntSet +>>> import qualified Streamly.Data.Array as Array +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.MutArray as MutArray +>>> import qualified Streamly.Data.Parser as Parser +>>> import qualified Streamly.Data.Scanl as Scanl +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.StreamK as StreamK +>>> import qualified Streamly.Data.Unfold as Unfold + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.Fold as Fold +>>> import qualified Streamly.Internal.Data.RingArray as RingArray +>>> import qualified Streamly.Internal.Data.Scanl as Scanl +>>> import qualified Streamly.Internal.Data.Stream as Stream +-} diff --git a/src/doctest/DocTestDataStream.hs b/src/doctest/DocTestDataStream.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataStream.hs @@ -0,0 +1,45 @@ +{- $setup + +>>> :m +>>> import Control.Concurrent (threadDelay) +>>> import Control.Monad (void, when) +>>> import Control.Monad.IO.Class (MonadIO (liftIO)) +>>> import Control.Monad.Trans.Class (lift) +>>> import Control.Monad.Trans.Identity (runIdentityT) +>>> import Data.Char (isSpace) +>>> import Data.Either (fromLeft, fromRight, isLeft, isRight, either) +>>> import Data.Maybe (fromJust, isJust) +>>> import Data.Function (fix, (&)) +>>> import Data.Functor.Identity (runIdentity) +>>> import Data.IORef +>>> import Data.Semigroup (cycle1) +>>> import Data.Word (Word8, Word16) +>>> import GHC.Exts (Ptr (Ptr)) +>>> import System.IO (stdout, hClose, hSetBuffering, openFile, BufferMode(LineBuffering), IOMode(..)) + +>>> hSetBuffering stdout LineBuffering +>>> effect n = print n >> return n + +>>> import Streamly.Data.Stream (Stream) +>>> import qualified Streamly.Data.Array as Array +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Scanl as Scanl +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.StreamK as StreamK +>>> import qualified Streamly.Data.Unfold as Unfold +>>> import qualified Streamly.Data.Parser as Parser +>>> import qualified Streamly.FileSystem.DirIO as Dir + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Control.Exception as Exception +>>> import qualified Streamly.Internal.FileSystem.Path as Path +>>> import qualified Streamly.Internal.Data.Scanr as Scanr +>>> import qualified Streamly.Internal.Data.Scanl as Scanl +>>> import qualified Streamly.Internal.Data.Fold as Fold +>>> import qualified Streamly.Internal.Data.Parser as Parser +>>> import qualified Streamly.Internal.Data.Stream as Stream +>>> import qualified Streamly.Internal.Data.StreamK as StreamK +>>> import qualified Streamly.Internal.Data.Unfold as Unfold +>>> import qualified Streamly.Internal.FileSystem.DirIO as Dir +-} diff --git a/src/doctest/DocTestDataStreamK.hs b/src/doctest/DocTestDataStreamK.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataStreamK.hs @@ -0,0 +1,24 @@ +{- $setup + +>>> :m +>>> import Control.Concurrent (threadDelay) +>>> import Data.Function (fix, (&)) +>>> import Data.Semigroup (cycle1) + +>>> import Streamly.Data.StreamK (StreamK) +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Parser as Parser +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.StreamK as StreamK +>>> import qualified Streamly.FileSystem.DirIO as Dir + +>>> mk = StreamK.fromStream . Stream.fromList +>>> un = Stream.toList . StreamK.toStream +>>> effect n = print n >> return n + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.FileSystem.Path as Path +>>> import qualified Streamly.Internal.Data.StreamK as StreamK +>>> import qualified Streamly.Internal.FileSystem.DirIO as Dir +-} diff --git a/src/doctest/DocTestDataUnfold.hs b/src/doctest/DocTestDataUnfold.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataUnfold.hs @@ -0,0 +1,13 @@ +{- $setup + +>>> :m +>>> import Streamly.Data.Unfold (Unfold) +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Scanl as Scanl +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.Unfold as Unfold + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.Unfold as Unfold +-} diff --git a/src/doctest/DocTestFileSystemHandle.hs b/src/doctest/DocTestFileSystemHandle.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestFileSystemHandle.hs @@ -0,0 +1,15 @@ +{- $setup +>>> :m +>>> import qualified Streamly.Data.Array as Array +>>> import qualified Streamly.FileSystem.Handle as Handle hiding (readChunks) +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.Unfold as Unfold + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.Array as Array (unsafeCreateOf) +>>> import qualified Streamly.Internal.Data.Unfold as Unfold (first) +>>> import qualified Streamly.Internal.FileSystem.Handle as Handle +>>> import qualified Streamly.Internal.System.IO as IO (defaultChunkSize) +-} diff --git a/src/doctest/DocTestFileSystemPath.hs b/src/doctest/DocTestFileSystemPath.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestFileSystemPath.hs @@ -0,0 +1,20 @@ +{- $setup +>>> :m +>>> :set -XQuasiQuotes +>>> import Control.Exception (SomeException, evaluate, try) +>>> import Data.Either (Either, isLeft) +>>> import Data.Maybe (fromJust, isJust, isNothing) +>>> import Streamly.FileSystem.Path (Path, path) +>>> import qualified Streamly.Data.Array as Array +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.FileSystem.Path as Path +>>> import qualified Streamly.Unicode.Stream as Unicode + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.FileSystem.Path as Path + +Utilities: + +>>> fails x = isLeft <$> (try (evaluate x) :: IO (Either SomeException String)) +-} diff --git a/src/doctest/DocTestFileSystemPosixPath.hs b/src/doctest/DocTestFileSystemPosixPath.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestFileSystemPosixPath.hs @@ -0,0 +1,19 @@ +{- $setup +>>> :m +>>> :set -XQuasiQuotes +>>> import Control.Exception (SomeException, evaluate, try) +>>> import Data.Either (Either, isLeft) +>>> import Data.Maybe (isNothing, isJust) +>>> import qualified Streamly.Data.Array as Array +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Unicode.Stream as Unicode + +For APIs that have not been released yet. + +>>> import Streamly.Internal.FileSystem.PosixPath (PosixPath, path) +>>> import qualified Streamly.Internal.FileSystem.PosixPath as Path + +Utilities: + +>>> fails x = isLeft <$> (try (evaluate x) :: IO (Either SomeException String)) +-} diff --git a/src/doctest/DocTestFileSystemWindowsPath.hs b/src/doctest/DocTestFileSystemWindowsPath.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestFileSystemWindowsPath.hs @@ -0,0 +1,21 @@ +{- $setup +>>> :m +>>> :set -XQuasiQuotes +>>> import Control.Exception (SomeException, evaluate, try) +>>> import Data.Either (Either, isLeft) +>>> import Data.Maybe (fromJust, isNothing, isJust) +>>> import Data.Word (Word16) +>>> import Streamly.Data.Array (Array) +>>> import qualified Streamly.Data.Array as Array +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Unicode.Stream as Unicode + +For APIs that have not been released yet. + +>>> import Streamly.Internal.FileSystem.WindowsPath (WindowsPath, path) +>>> import qualified Streamly.Internal.FileSystem.WindowsPath as Path + +Utilities: + +>>> fails x = isLeft <$> (try (evaluate x) :: IO (Either SomeException String)) +-} diff --git a/src/doctest/DocTestUnicodeParser.hs b/src/doctest/DocTestUnicodeParser.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestUnicodeParser.hs @@ -0,0 +1,10 @@ +{- $setup +>>> :m +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Unicode.Parser as Unicode + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.Stream as Stream (parsePos) +>>> import qualified Streamly.Internal.Unicode.Parser as Unicode (number, mkDouble) +-} diff --git a/src/doctest/DocTestUnicodeStream.hs b/src/doctest/DocTestUnicodeStream.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestUnicodeStream.hs @@ -0,0 +1,12 @@ +{- $setup +>>> :m + +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Unicode.Stream as Unicode + +For APIs that have not been released yet. + +>>> :set -XMagicHash +>>> import qualified Streamly.Internal.Unicode.Stream as Unicode +-} diff --git a/src/doctest/DocTestUnicodeString.hs b/src/doctest/DocTestUnicodeString.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestUnicodeString.hs @@ -0,0 +1,5 @@ +{- $setup +>>> :m +>>> :set -XQuasiQuotes +>>> import Streamly.Internal.Unicode.String +-} diff --git a/streamly-core.cabal b/streamly-core.cabal --- a/streamly-core.cabal +++ b/streamly-core.cabal @@ -1,23 +1,52 @@ -cabal-version: 2.2 +cabal-version: 2.4 name: streamly-core -version: 0.1.0 -synopsis: Streaming, parsers, arrays and more +version: 0.3.1 +synopsis: Streaming, parsers, arrays, serialization and more description: - Streamly consists of two packages: "streamly-core" and "streamly". - - provides basic features, and depends only on GHC boot libraries (see - note below), while - provides - higher-level features like concurrency, time, lifted exceptions, - and networking. For documentation, visit the - . + For upgrading to streamly-0.9.0+ please read the + . . - This package provides streams, arrays, parsers, unicode text, file - IO, and console IO functionality. + Streamly is a high-performance, beginner-friendly standard library + for Haskell. It unifies streaming with list transformers and logic + programming; unifies streaming with concurrency and reactive + programming; unifies arrays with ring arrays, text, bytestring + and vector use cases; unifies arrays with builders and binary + serialization; generalizes parsers to any input type and unifies + attoparsec, parsec use cases with better performance; provides + streaming fileIO — all with a clean, consistent, well-integrated and + streaming enabled API. . - Note: The dependencies "heaps" and "monad-control" are included in - the package solely for backward compatibility, and will be removed in - future versions. + Streams are designed to have a list like interface — no steep + learning curve, no complex types. Streamly is designed to build + general purpose applications in a truly functional manner, from + simple hello-world to advanced high-performance systems. The design + emphasizes simplicity, modularity, and code reuse with minimal + building blocks. Performance is on par with C, tuning is easy, and + it’s hard to get it wrong. + . + Streamly is serial by default, with seamless declarative concurrency + that scales automatically when needed. It provides prompt and safe + resource management, works well with other streaming libraries as well + as core libraries like bytestring and text, and is backed by solid + documentation. + . + @streamly-core@ is a Haskell standard library built on top of @base@ + and GHC boot libraries only. Stream processing abstractions include + streams, scans, folds, parsers; and console I/O, file I/O; text + processing. Array abstractions include pinned, unpinned, mutable, + immutable, boxed and unboxed arrays, and ring arrays. Builders, + binary serialization, and deserialization are built-in features of + arrays. + . + This package provides a high-performance, unified and ergonomic + alternative to many disparate packages, such as @streaming, pipes, + conduit, list-t, logict, foldl, attoparsec, array, primitive, + vector, vector-algorithms, binary, cereal, store, bytestring, text, + stringsearch, interpolate, filepath, and path@. + . + Performant. Unified. Modular. Powerful. Simple. + . + Learn more at . homepage: https://streamly.composewell.com bug-reports: https://github.com/composewell/streamly/issues @@ -27,8 +56,12 @@ , GHC==8.8.4 , GHC==8.10.7 , GHC==9.0.2 - , GHC==9.2.7 - , GHC==9.4.4 + , GHC==9.2.8 + , GHC==9.4.7 + , GHC==9.6.3 + , GHC==9.8.1 + , GHC==9.10.1 + , GHC==9.12.1 author: Composewell Technologies maintainer: streamly@composewell.com copyright: 2017 Composewell Technologies @@ -43,19 +76,14 @@ configure.ac -- doctest include files - src/DocTestDataArray.hs - src/DocTestDataFold.hs - src/DocTestDataMutArray.hs - src/DocTestDataMutArrayGeneric.hs - src/DocTestDataParser.hs - src/DocTestDataStream.hs - src/DocTestDataStreamK.hs - src/DocTestDataUnfold.hs + src/doctest/*.hs -- This is duplicated src/Streamly/Internal/Data/Array/ArrayMacros.h + src/Streamly/Internal/Data/ParserDrivers.h src/assert.hs src/inline.hs + src/deprecation.h src/Streamly/Internal/Data/Time/Clock/config-clock.h src/config.h.in @@ -69,7 +97,7 @@ extra-doc-files: Changelog.md docs/*.md - docs/ApiChangelogs/0.1.0.txt + docs/ApiChangelogs/*.txt source-repository head type: git @@ -80,8 +108,8 @@ manual: True default: False -flag dev - description: Development build +flag internal-dev + description: DO NOT USE, ONLY FOR INTERNAL USE. manual: True default: False @@ -90,16 +118,6 @@ manual: True default: False -flag no-fusion - description: Disable rewrite rules for stream fusion - manual: True - default: False - -flag use-c-malloc - description: Use C malloc instead of GHC malloc - manual: True - default: False - flag opt description: off=GHC default, on=-O2 manual: True @@ -110,8 +128,8 @@ manual: True default: False -flag use-unliftio - description: Use unliftio-core instead of monad-control +flag internal-use-unliftio + description: DO NOT USE, ONLY FOR INTERNAL USE. manual: True default: False @@ -125,17 +143,20 @@ manual: True default: False +flag force-lstat-readdir + description: Use lstat instead of checking for dtype in ReadDir + manual: True + default: False + ------------------------------------------------------------------------------- -- Common stanzas ------------------------------------------------------------------------------- common compile-options - default-language: Haskell2010 - - if flag(no-fusion) - cpp-options: -DDISABLE_FUSION + if flag(force-lstat-readdir) + cpp-options: -DFORCE_LSTAT_READDIR - if flag(dev) + if flag(internal-dev) cpp-options: -DDEVBUILD if flag(use-unfolds) @@ -144,9 +165,6 @@ if flag(use-folds) cpp-options: -DUSE_FOLDS_EVERYWHERE - if flag(use-c-malloc) - cpp-options: -DUSE_C_MALLOC - ghc-options: -Weverything -Wno-implicit-prelude -Wno-missing-deriving-strategies @@ -167,24 +185,48 @@ -Wno-redundant-bang-patterns -Wno-operator-whitespace + if impl(ghc >= 9.8) + ghc-options: + -Wno-missing-role-annotations + + if impl(ghc >= 9.10) + ghc-options: + -Wno-missing-poly-kind-signatures + if flag(has-llvm) ghc-options: -fllvm - if flag(dev) + if flag(internal-dev) ghc-options: -Wmissed-specialisations -Wall-missed-specialisations if flag(limit-build-mem) ghc-options: +RTS -M1000M -RTS - if flag(use-unliftio) + if flag(internal-use-unliftio) cpp-options: -DUSE_UNLIFTIO common default-extensions + default-language: Haskell2010 + + -- GHC2024 may include more extensions than we are actually using, see the + -- full list below. We enable this to ensure that we are able to compile + -- with this i.e. there is no interference by other extensions. + + -- Don't enforce GHC2024 and GHC2021 but We can support the build with them. + + -- if impl(ghc >= 9.10) + -- default-language: GHC2024 + + -- if impl(ghc >= 9.2) && impl(ghc < 9.10) + -- default-language: GHC2021 + + if impl(ghc >= 8.10) + default-extensions: StandaloneKindSignatures + + -- In GHC 2024 default-extensions: BangPatterns - CApiFFI - CPP ConstraintKinds DeriveDataTypeable DeriveGeneric @@ -196,27 +238,42 @@ InstanceSigs KindSignatures LambdaCase - MagicHash MultiParamTypeClasses - PatternSynonyms RankNTypes - RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications - TypeFamilies TypeOperators - ViewPatterns - -- MonoLocalBinds, enabled by TypeFamilies, causes performance - -- regressions. Disable it. This must come after TypeFamilies, + -- Not in GHC2024 + CApiFFI + CPP + DefaultSignatures + MagicHash + RecordWildCards + + -- TypeFamilies is required by IsList, IsMap type classes and + -- Unbox generic deriving code. + -- TypeFamilies + + -- MonoLocalBinds, enabled by TypeFamilies and GHC2024, was + -- once found to cause runtime performance regressions which + -- does not seem to be the case anymore, but need more testing + -- to confirm. It is confirmed that it requires more memory + -- for compilation at least in some cases (Data.Fold.Window + -- benchmark on GHC-9.10.1 macOS). It also causes some + -- code to not compile, so has been disabled in specific + -- modules. Disabling this must come after TypeFamilies, -- otherwise TypeFamilies will enable it again. - NoMonoLocalBinds + -- NoMonoLocalBinds -- UndecidableInstances -- Does not show any perf impact -- UnboxedTuples -- interferes with (#.) + if impl(ghc >= 8.6) + default-extensions: QuantifiedConstraints + common optimization-options if flag(opt) ghc-options: -O2 @@ -225,7 +282,8 @@ -fmax-worker-args=16 -- For this to be effective it must come after the -O2 option - if flag(dev) || flag(debug) || !flag(opt) + if flag(internal-dev) || flag(debug) || !flag(opt) + cpp-options: -DDEBUG ghc-options: -fno-ignore-asserts common threading-options @@ -248,16 +306,19 @@ library import: lib-options - if impl(ghc >= 8.6) - default-extensions: QuantifiedConstraints - js-sources: jsbits/clock.js include-dirs: src + , src/doctest + , src/Streamly/Internal/Data , src/Streamly/Internal/Data/Array , src/Streamly/Internal/Data/Stream + c-sources: src/Streamly/Internal/Data/MutArray/Lib.c + + -- Prefer OS conditionals inside the source files rather than here, + -- conditionals here do not work well with cabal2nix. if os(windows) c-sources: src/Streamly/Internal/Data/Time/Clock/Windows.c @@ -289,81 +350,49 @@ -- streamly-time , Streamly.Internal.Data.Time.TimeSpec , Streamly.Internal.Data.Time.Units - , Streamly.Internal.Data.Time.Clock.Type , Streamly.Internal.Data.Time.Clock + , Streamly.Internal.Data.Path -- streamly-core-stream-types , Streamly.Internal.Data.SVar.Type - , Streamly.Internal.Data.Stream.StreamK.Type - , Streamly.Internal.Data.Fold.Step , Streamly.Internal.Data.Refold.Type - , Streamly.Internal.Data.Fold.Type - , Streamly.Internal.Data.Stream.StreamD.Step - , Streamly.Internal.Data.Stream.StreamD.Type - , Streamly.Internal.Data.Unfold.Type - , Streamly.Internal.Data.Producer.Type , Streamly.Internal.Data.Producer - , Streamly.Internal.Data.Producer.Source - , Streamly.Internal.Data.Parser.ParserK.Type - , Streamly.Internal.Data.Parser.ParserD.Type - , Streamly.Internal.Data.Pipe.Type -- streamly-core-array-types - , Streamly.Internal.Data.Unboxed - -- Unboxed IORef - , Streamly.Internal.Data.IORef.Unboxed + , Streamly.Internal.Data.MutByteArray + , Streamly.Internal.Data.CString + + -- streaming and parsing Haskell types to/from bytes + , Streamly.Internal.Data.Binary.Parser + , Streamly.Internal.Data.Binary.Stream + -- May depend on streamly-core-stream - , Streamly.Internal.Data.Array.Mut.Type - , Streamly.Internal.Data.Array.Mut - , Streamly.Internal.Data.Array.Type - , Streamly.Internal.Data.Array.Generic.Mut.Type + , Streamly.Internal.Data.MutArray + , Streamly.Internal.Data.MutArray.Generic -- streamly-core-streams - , Streamly.Internal.Data.Stream.StreamK + , Streamly.Internal.Data.StreamK -- StreamD depends on streamly-array-types - , Streamly.Internal.Data.Stream.StreamD.Generate - , Streamly.Internal.Data.Stream.StreamD.Eliminate - , Streamly.Internal.Data.Stream.StreamD.Nesting - , Streamly.Internal.Data.Stream.StreamD.Transform - , Streamly.Internal.Data.Stream.StreamD.Exception - , Streamly.Internal.Data.Stream.StreamD.Lift - , Streamly.Internal.Data.Stream.StreamD.Top - , Streamly.Internal.Data.Stream.StreamD - , Streamly.Internal.Data.Stream.Common , Streamly.Internal.Data.Stream - , Streamly.Internal.Data.Parser.ParserD.Tee - , Streamly.Internal.Data.Parser.ParserD - -- streamly-core-data , Streamly.Internal.Data.Builder , Streamly.Internal.Data.Unfold - , Streamly.Internal.Data.Unfold.Enumeration - , Streamly.Internal.Data.Fold.Tee - , Streamly.Internal.Data.Fold - , Streamly.Internal.Data.Fold.Chunked - , Streamly.Internal.Data.Fold.Window , Streamly.Internal.Data.Parser + , Streamly.Internal.Data.ParserK , Streamly.Internal.Data.Pipe - - -- streamly-transformers (non-base) - , Streamly.Internal.Data.Stream.StreamD.Transformer - , Streamly.Internal.Data.Stream.StreamK.Transformer + , Streamly.Internal.Data.Scanr -- streamly-containers (non-base) - , Streamly.Internal.Data.Stream.StreamD.Container - , Streamly.Internal.Data.Fold.Container - - , Streamly.Internal.Data.Stream.Chunked + , Streamly.Internal.Data.Fold + , Streamly.Internal.Data.Scanl -- streamly-core-data-arrays , Streamly.Internal.Data.Array.Generic , Streamly.Internal.Data.Array - , Streamly.Internal.Data.Array.Mut.Stream - -- streamly-serde - , Streamly.Internal.Serialize.FromBytes - , Streamly.Internal.Serialize.ToBytes + -- Unboxed IORef + , Streamly.Internal.Data.IORef -- streamly-unicode-core , Streamly.Internal.Unicode.Stream @@ -372,34 +401,47 @@ , Streamly.Internal.Unicode.Array -- Filesystem/IO + + , Streamly.Internal.FileSystem.Path + , Streamly.Internal.FileSystem.Path.Seg + , Streamly.Internal.FileSystem.Path.Node + , Streamly.Internal.FileSystem.Path.SegNode + + , Streamly.Internal.FileSystem.PosixPath + , Streamly.Internal.FileSystem.PosixPath.Seg + , Streamly.Internal.FileSystem.PosixPath.Node + , Streamly.Internal.FileSystem.PosixPath.SegNode + + , Streamly.Internal.FileSystem.WindowsPath + , Streamly.Internal.FileSystem.WindowsPath.Seg + , Streamly.Internal.FileSystem.WindowsPath.Node + , Streamly.Internal.FileSystem.WindowsPath.SegNode + , Streamly.Internal.FileSystem.Handle - , Streamly.Internal.FileSystem.File - , Streamly.Internal.FileSystem.Dir + , Streamly.Internal.FileSystem.File.Common + , Streamly.Internal.FileSystem.Posix.Errno + , Streamly.Internal.FileSystem.Posix.File + , Streamly.Internal.FileSystem.Posix.ReadDir + , Streamly.Internal.FileSystem.Windows.ReadDir + , Streamly.Internal.FileSystem.Windows.File + , Streamly.Internal.FileSystem.FileIO + , Streamly.Internal.FileSystem.DirIO - -- Ring Arrays - , Streamly.Internal.Data.Ring.Unboxed - , Streamly.Internal.Data.Ring + -- RingArray Arrays + , Streamly.Internal.Data.RingArray + , Streamly.Internal.Data.RingArray.Generic -- streamly-console , Streamly.Internal.Console.Stdio -- To be implemented -- , Streamly.Data.Refold - -- , Streamly.Data.Binary.Encode -- Stream types -- Pre-release modules - -- , Streamly.Data.Fold.Window -- , Streamly.Data.Pipe - -- , Streamly.Data.Array.Stream - -- , Streamly.Data.Array.Fold - -- , Streamly.Data.Array.Mut.Stream - -- , Streamly.Data.Ring - -- , Streamly.Data.Ring.Unboxed - -- , Streamly.Data.IORef.Unboxed + -- , Streamly.Data.RingArray.Generic + -- , Streamly.Data.IORef -- , Streamly.Data.List - -- , Streamly.Data.Binary.Decode - -- , Streamly.FileSystem.File - -- , Streamly.FileSystem.Dir -- , Streamly.Data.Time.Units -- , Streamly.Data.Time.Clock -- , Streamly.Data.Tuple.Strict @@ -407,45 +449,112 @@ -- , Streamly.Data.Either.Strict -- streamly-core released modules in alphabetic order - -- NOTE: these must be added to streamly.cabal as well , Streamly.Console.Stdio + , Streamly.Control.Exception , Streamly.Data.Array , Streamly.Data.Array.Generic + , Streamly.Data.Fold , Streamly.Data.MutArray , Streamly.Data.MutArray.Generic - , Streamly.Data.Fold + , Streamly.Data.MutByteArray , Streamly.Data.Parser , Streamly.Data.ParserK + , Streamly.Data.RingArray + , Streamly.Data.Scanl , Streamly.Data.Stream , Streamly.Data.StreamK , Streamly.Data.Unfold - , Streamly.FileSystem.Dir - , Streamly.FileSystem.File + , Streamly.FileSystem.DirIO + , Streamly.FileSystem.FileIO , Streamly.FileSystem.Handle + , Streamly.FileSystem.Path , Streamly.Unicode.Parser , Streamly.Unicode.Stream , Streamly.Unicode.String - if flag(dev) + -- Deprecated in 0.3.0 + , Streamly.Internal.FileSystem.File + , Streamly.Internal.FileSystem.Dir + , Streamly.FileSystem.Dir + , Streamly.FileSystem.File + + -- Deprecated in 0.2.0 + , Streamly.Internal.Data.MutArray.Stream + , Streamly.Internal.Data.Array.Stream + , Streamly.Internal.Data.Stream.StreamD + , Streamly.Internal.Data.Fold.Chunked + + -- Only those modules should be here which are fully re-exported via some + -- other module. + other-modules: + Streamly.FileSystem.Path.Seg + , Streamly.FileSystem.Path.Node + , Streamly.FileSystem.Path.SegNode + + , Streamly.Internal.Data.Fold.Step + , Streamly.Internal.Data.Fold.Type + , Streamly.Internal.Data.Fold.Combinators + , Streamly.Internal.Data.Fold.Container + , Streamly.Internal.Data.Fold.Exception + , Streamly.Internal.Data.Fold.Tee + , Streamly.Internal.Data.Fold.Window + + , Streamly.Internal.Data.Scanl.Type + , Streamly.Internal.Data.Scanl.Window + , Streamly.Internal.Data.Scanl.Combinators + , Streamly.Internal.Data.Scanl.Container + + , Streamly.Internal.Data.Parser.Type + , Streamly.Internal.Data.Parser.Tee + , Streamly.Internal.Data.ParserK.Type + , Streamly.Internal.Data.ParserDrivers + + , Streamly.Internal.Data.Stream.Container + , Streamly.Internal.Data.Stream.Eliminate + , Streamly.Internal.Data.Stream.Exception + , Streamly.Internal.Data.Stream.Generate + , Streamly.Internal.Data.Stream.Lift + , Streamly.Internal.Data.Stream.Nesting + , Streamly.Internal.Data.Stream.Step + , Streamly.Internal.Data.Stream.Top + , Streamly.Internal.Data.Stream.Transform + , Streamly.Internal.Data.Stream.Transformer + , Streamly.Internal.Data.Stream.Type + + , Streamly.Internal.Data.StreamK.Type + , Streamly.Internal.Data.StreamK.Transformer + + , Streamly.Internal.Data.Pipe.Type + + , Streamly.Internal.Data.Unfold.Type + , Streamly.Internal.Data.Unfold.Enumeration + + , Streamly.Internal.Data.MutArray.Type + + , Streamly.Internal.Data.Array.Type + , Streamly.Internal.Data.Array.Generic.Type + + , Streamly.Internal.Data.MutByteArray.Type + , Streamly.Internal.Data.Unbox + , Streamly.Internal.Data.Unbox.TH + , Streamly.Internal.Data.Serialize.Type + , Streamly.Internal.Data.Serialize.TH + , Streamly.Internal.Data.Serialize.TH.RecHeader + , Streamly.Internal.Data.Serialize.TH.Common + , Streamly.Internal.Data.Serialize.TH.Bottom + + , Streamly.Internal.Data.Producer.Type + , Streamly.Internal.Data.Producer.Source + + , Streamly.Internal.Data.Time.Clock.Type + , Streamly.Internal.FileSystem.Path.Common + , Streamly.Internal.FileSystem.DirOptions + + if flag(internal-dev) exposed-modules: - Streamly.Internal.Data.Stream.StreamK.Alt - , Streamly.Internal.Data.Stream.Type - , Streamly.Internal.Data.Stream.Eliminate - , Streamly.Internal.Data.Stream.Enumerate - , Streamly.Internal.Data.Stream.Generate - , Streamly.Internal.Data.Stream.Transform - , Streamly.Internal.Data.Stream.Bottom - , Streamly.Internal.Data.Stream.Exception - , Streamly.Internal.Data.Stream.Expand - , Streamly.Internal.Data.Stream.Lift - , Streamly.Internal.Data.Stream.Reduce - , Streamly.Internal.Data.Stream.Transformer - , Streamly.Internal.Data.Stream.StreamDK - , Streamly.Internal.Data.Stream.Zip - , Streamly.Internal.Data.Stream.Cross - , Streamly.Internal.Data.List - , Streamly.Data.Stream.Zip - --, Streamly.Internal.Data.Parser.ParserDK + Streamly.Internal.Data.StreamK.Alt + -- XXX Compilation needs to be fixed + -- , Streamly.Internal.Data.List build-depends: -- streamly-base @@ -459,21 +568,27 @@ -- packages depending on the "ghc" package (packages -- depending on doctest is a common example) can -- depend on streamly. - ghc-prim >= 0.5.3 && < 0.10 + ghc-prim >= 0.5.3 && < 0.14 , fusion-plugin-types >= 0.1 && < 0.2 - , base >= 4.12 && < 4.19 + , base >= 4.12 && < 4.23 , exceptions >= 0.8.0 && < 0.11 , transformers >= 0.5.5 && < 0.7 - , filepath >= 1.4.2 && < 1.5 -- streamly-unicode-core - , template-haskell >= 2.14 && < 2.20 - - -- streamly-filesystem-core - , directory >= 1.3.3 && < 1.4 + , template-haskell >= 2.14 && < 2.25 -- XXX to be removed - , containers >= 0.6.0 && < 0.7 + , filepath >= 1.4.2 && < 1.6 + , containers >= 0.6.0 && < 0.9 , heaps >= 0.3 && < 0.5 - if !flag(use-unliftio) + + if impl(ghc >= 9.0) + build-depends: ghc-bignum >= 1.0 && < 2 + else + build-depends: integer-gmp >= 1.0 && < 1.2 + + if !flag(internal-use-unliftio) build-depends: monad-control >= 1.0 && < 1.1 + + if os(windows) + build-depends: Win32 >= 2.6 && < 2.15