diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,32 @@ +# Changelog + +## 0.1.0 (March 2023) + +Also see [streamly-core-0.1.0 API Changelog](/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 +has only GHC boot library depdendecies, and (2) `streamly` that contains +higher level operations (including concurrent ones) with additional +dependencies. + +* Moved the following modules from `streamly` package to the + `streamly-core` package: + * Streamly.Console.Stdio + * Streamly.Data.Fold + * Streamly.Data.Unfold + * Streamly.FileSystem.Handle + * Streamly.Unicode.Stream +* Added the following new modules: + * Streamly.Data.Array + * Streamly.Data.Array.Generic + * Streamly.Data.MutArray + * Streamly.Data.MutArray.Generic + * Streamly.Data.Parser + * Streamly.Data.ParserK + * Streamly.Data.Stream + * Streamly.Data.StreamK + * Streamly.FileSystem.Dir + * Streamly.FileSystem.File + * Streamly.Unicode.Parser + * Streamly.Unicode.String diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,281 @@ +Copyright (c) 2017, Composewell Technologies +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +------------------------------------------------------------------------------- +base-4.12.0.0 (http://hackage.haskell.org/package/base-4.12.0.0) +------------------------------------------------------------------------------- +This library (libraries/base) is derived from code from several +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + * Code from the Haskell Foreign Function Interface specification, + which is (c) Manuel M. T. Chakravarty and freely redistributable + (but see the full license for restrictions). + +The full text of these licenses is reproduced below. All of the +licenses are BSD-style or compatible. + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +Code derived from the document "The Haskell 98 Foreign Function +Interface, An Addendum to the Haskell 98 Report" is distributed under +the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + +------------------------------------------------------------------------------- +bjoern-2008-2009 (http://bjoern.hoehrmann.de/utf-8/decoder/dfa/) +------------------------------------------------------------------------------- +Copyright (c) 2008-2009 Bjoern Hoehrmann + +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. + +------------------------------------------------------------------------------- +clock-0.7.2 (http://hackage.haskell.org/package/clock-0.7.2) +------------------------------------------------------------------------------- +Copyright (c) 2009-2012, Cetin Sert +Copyright (c) 2010, Eugene Kirpichov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +------------------------------------------------------------------------------- +foldl-1.4.5 (http://hackage.haskell.org/package/foldl-1.4.5) +------------------------------------------------------------------------------- +Copyright (c) 2013 Gabriel Gonzalez +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +------------------------------------------------------------------------------- +primitive-0.7.0.0 (https://hackage.haskell.org/package/primitive-0.7.0.0) +------------------------------------------------------------------------------- +Copyright (c) 2008-2009, Roman Leshchinskiy +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +------------------------------------------------------------------------------- +transient-0.5.5 (http://hackage.haskell.org/package/transient-0.5.5) +------------------------------------------------------------------------------- +Copyright © 2014-2016 Alberto G. Corona + +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. + +------------------------------------------------------------------------------- +vector-0.12.0.2 (http://hackage.haskell.org/package/vector-0.12.0.2) +------------------------------------------------------------------------------- +Copyright (c) 2008-2012, Roman Leshchinskiy +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks autoconfUserHooks diff --git a/configure b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -0,0 +1,4349 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.71 for streamly-core 0.1.0. +# +# Report bugs to . +# +# +# Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation, +# Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# 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 + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # 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 #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + + +# Reset variables that may have inherited troublesome values from +# the environment. + +# IFS needs to be set, to space, tab, and newline, in precisely that order. +# (If _AS_PATH_WALK were called with IFS unset, it would have the +# side effect of setting IFS to empty, thus disabling word splitting.) +# Quoting is to prevent editors from complaining about space-tab. +as_nl=' +' +export as_nl +IFS=" "" $as_nl" + +PS1='$ ' +PS2='> ' +PS4='+ ' + +# Ensure predictable behavior from utilities with locale-dependent output. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# We cannot yet rely on "unset" to work, but we need these variables +# to be unset--not just set to an empty or harmless value--now, to +# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct +# also avoids known problems related to "unset" and subshell syntax +# in other old shells (e.g. bash 2.01 and pdksh 5.2.14). +for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH +do eval test \${$as_var+y} \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done + +# Ensure that fds 0, 1, and 2 are open. +if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi +if (exec 3>&2) ; then :; else exec 2>/dev/null; fi + +# The user is always right. +if ${PATH_SEPARATOR+false} :; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + test -r "$as_dir$0" && as_myself=$as_dir$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# 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 +fi +if test ! -f "$as_myself"; then + printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +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'. +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 +then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # 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 #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ) +then : + +else \$as_nop + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +blah=\$(echo \$(echo blah)) +test x\"\$blah\" = xblah || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" + if (eval "$as_required") 2>/dev/null +then : + as_have_required=yes +else $as_nop + as_have_required=no +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 +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null +then : + CONFIG_SHELL=$as_shell as_have_required=yes + if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null +then : + break 2 +fi +fi + done;; + esac + as_found=false +done +IFS=$as_save_IFS +if $as_found +then : + +else $as_nop + 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 + + + if test "x$CONFIG_SHELL" != x +then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +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'. +printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno +then : + printf "%s\n" "$0: This script requires a shell more modern than all" + printf "%s\n" "$0: the shells that I found on your system." + if test ${ZSH_VERSION+y} ; then + printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should" + printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later." + else + printf "%s\n" "$0: Please tell bug-autoconf@gnu.org and +$0: streamly@composewell.com about your system, including +$0: any error possibly output before this message. Then +$0: install a modern shell, or manually run the script +$0: under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + 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 +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null +then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else $as_nop + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null +then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else $as_nop + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +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] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + printf "%s\n" "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + + +# Determine whether it's possible to make 'echo' print without a newline. +# These variables are no longer used directly by Autoconf, but are AC_SUBSTed +# for compatibility with existing Makefiles. +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +# For backward compatibility with old third-party macros, we provide +# the shell variables $as_echo and $as_echo_n. New code should use +# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. +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 +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + 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'. + 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 + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +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'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME='streamly-core' +PACKAGE_TARNAME='streamly-core' +PACKAGE_VERSION='0.1.0' +PACKAGE_STRING='streamly-core 0.1.0' +PACKAGE_BUGREPORT='streamly@composewell.com' +PACKAGE_URL='https://streamly.composewell.com' + +# Factoring default headers for most tests. +ac_includes_default="\ +#include +#ifdef HAVE_STDIO_H +# include +#endif +#ifdef HAVE_STDLIB_H +# include +#endif +#ifdef HAVE_STRING_H +# include +#endif +#ifdef HAVE_INTTYPES_H +# include +#endif +#ifdef HAVE_STDINT_H +# include +#endif +#ifdef HAVE_STRINGS_H +# include +#endif +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_STAT_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif" + +ac_header_c_list= +ac_subst_vars='LTLIBOBJS +LIBOBJS +OBJEXT +EXEEXT +ac_ct_CC +CPPFLAGS +LDFLAGS +CFLAGS +CC +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +runstatedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +with_compiler +' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +runstatedir='${localstatedir}/run' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # 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'" + ac_useropt_orig=$ac_useropt + ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + 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'" + ac_useropt_orig=$ac_useropt + ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -runstatedir | --runstatedir | --runstatedi | --runstated \ + | --runstate | --runstat | --runsta | --runst | --runs \ + | --run | --ru | --r) + ac_prev=runstatedir ;; + -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ + | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ + | --run=* | --ru=* | --r=*) + runstatedir=$ac_optarg ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + 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'" + ac_useropt_orig=$ac_useropt + ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + 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'" + ac_useropt_orig=$ac_useropt + ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --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" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # 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'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir runstatedir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + 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' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + 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_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # 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. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --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 + --cache-file=FILE cache test results in FILE [disabled] + -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 \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --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'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/streamly-core] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF +_ACEOF +fi + +if test -n "$ac_init_help"; then + case $ac_init_help in + short | recursive ) echo "Configuration of streamly-core 0.1.0:";; + esac + cat <<\_ACEOF + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) +GHC + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + 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 +it to find libraries and programs with nonstandard names/locations. + +Report bugs to . +streamly-core home page: . +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for configure.gnu first; this name is used for a wrapper for + # Metaconfig's "Configure" on case-insensitive file systems. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +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 + +Copyright (C) 2021 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_c_try_compile LINENO +# -------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest.beam + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext +then : + ac_retval=0 +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_compile + +# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists and can be compiled using the include files in +# INCLUDES, setting the cache variable VAR accordingly. +ac_fn_c_check_header_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +printf %s "checking for $2... " >&6; } +if eval test \${$3+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + eval "$3=yes" +else $as_nop + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +eval ac_res=\$$3 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_compile + +# ac_fn_c_try_link LINENO +# ----------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + } +then : + ac_retval=0 +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_link + +# ac_fn_c_check_func LINENO FUNC VAR +# ---------------------------------- +# Tests whether FUNC exists, setting the cache variable VAR accordingly +ac_fn_c_check_func () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +printf %s "checking for $2... " >&6; } +if eval test \${$3+y} +then : + printf %s "(cached) " >&6 +else $as_nop + 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. */ + +#include +#undef $2 + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $2 (); +/* 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. */ +#if defined __stub_$2 || defined __stub___$2 +choke me +#endif + +int +main (void) +{ +return $2 (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + eval "$3=yes" +else $as_nop + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +fi +eval ac_res=\$$3 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_func +ac_configure_args_raw= +for ac_arg +do + case $ac_arg in + *\'*) + ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append ac_configure_args_raw " '$ac_arg'" +done + +case $ac_configure_args_raw in + *$as_nl*) + ac_safe_unquote= ;; + *) + ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab. + ac_unsafe_a="$ac_unsafe_z#~" + ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g" + ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;; +esac + +cat >config.log <<_ACEOF +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 + + $ $0$ac_configure_args_raw + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + printf "%s\n" "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Sanitize IFS. + IFS=" "" $as_nl" + # Save into config.log some information that might help in debugging. + { + echo + + printf "%s\n" "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + printf "%s\n" "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + printf "%s\n" "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + printf "%s\n" "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + printf "%s\n" "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + printf "%s\n" "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + printf "%s\n" "$as_me: caught signal $ac_signal" + printf "%s\n" "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +printf "%s\n" "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +if test -n "$CONFIG_SITE"; then + ac_site_files="$CONFIG_SITE" +elif test "x$prefix" != xNONE; then + ac_site_files="$prefix/share/config.site $prefix/etc/config.site" +else + ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" +fi + +for ac_site_file in $ac_site_files +do + case $ac_site_file in #( + */*) : + ;; #( + *) : + ac_site_file=./$ac_site_file ;; +esac + if test -f "$ac_site_file" && test -r "$ac_site_file"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +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;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +printf "%s\n" "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +printf "%s\n" "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Test code for whether the C compiler supports C89 (global declarations) +ac_c_conftest_c89_globals=' +/* Does the compiler advertise C89 conformance? + Do not test the value of __STDC__, because some compilers set it to 0 + while being otherwise adequately conformant. */ +#if !defined __STDC__ +# error "Compiler does not advertise C89 conformance" +#endif + +#include +#include +struct stat; +/* 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; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* 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 + as an "x". The following induces an error, until -std is added to get + proper ANSI mode. Curiously \x00 != x always comes out true, for an + array size at least. It is necessary to write \x00 == 0 to get something + that is true only with -std. */ +int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) '\''x'\'' +int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int), + int, int);' + +# Test code for whether the C compiler supports C89 (body of main). +ac_c_conftest_c89_main=' +ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]); +' + +# Test code for whether the C compiler supports C99 (global declarations) +ac_c_conftest_c99_globals=' +// Does the compiler advertise C99 conformance? +#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L +# error "Compiler does not advertise C99 conformance" +#endif + +#include +extern int puts (const char *); +extern int printf (const char *, ...); +extern int dprintf (int, const char *, ...); +extern void *malloc (size_t); + +// Check varargs macros. These examples are taken from C99 6.10.3.5. +// dprintf is used instead of fprintf to avoid needing to declare +// FILE and stderr. +#define debug(...) dprintf (2, __VA_ARGS__) +#define showlist(...) puts (#__VA_ARGS__) +#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) +static void +test_varargs_macros (void) +{ + int x = 1234; + int y = 5678; + debug ("Flag"); + debug ("X = %d\n", x); + showlist (The first, second, and third items.); + report (x>y, "x is %d but y is %d", x, y); +} + +// Check long long types. +#define BIG64 18446744073709551615ull +#define BIG32 4294967295ul +#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) +#if !BIG_OK + #error "your preprocessor is broken" +#endif +#if BIG_OK +#else + #error "your preprocessor is broken" +#endif +static long long int bignum = -9223372036854775807LL; +static unsigned long long int ubignum = BIG64; + +struct incomplete_array +{ + int datasize; + double data[]; +}; + +struct named_init { + int number; + const wchar_t *name; + double average; +}; + +typedef const char *ccp; + +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) + continue; + return 0; +} + +// Check varargs and va_copy. +static bool +test_varargs (const char *format, ...) +{ + va_list args; + va_start (args, format); + va_list args_copy; + va_copy (args_copy, args); + + const char *str = ""; + int number = 0; + float fnumber = 0; + + while (*format) + { + switch (*format++) + { + case '\''s'\'': // string + str = va_arg (args_copy, const char *); + break; + case '\''d'\'': // int + number = va_arg (args_copy, int); + break; + case '\''f'\'': // float + fnumber = va_arg (args_copy, double); + break; + default: + break; + } + } + va_end (args_copy); + va_end (args); + + return *str && number && fnumber; +} +' + +# Test code for whether the C compiler supports C99 (body of main). +ac_c_conftest_c99_main=' + // Check bool. + _Bool success = false; + success |= (argc != 0); + + // Check restrict. + if (test_restrict ("String literal") == 0) + success = true; + char *restrict newvar = "Another string"; + + // Check varargs. + success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234); + test_varargs_macros (); + + // Check flexible array members. + struct incomplete_array *ia = + malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); + ia->datasize = 10; + for (int i = 0; i < ia->datasize; ++i) + ia->data[i] = i * 1.234; + + // Check named initializers. + struct named_init ni = { + .number = 34, + .name = L"Test wide string", + .average = 543.34343, + }; + + ni.number = 58; + + int dynamic_array[ni.number]; + dynamic_array[0] = argv[0][0]; + dynamic_array[ni.number - 1] = 543; + + // work around unused variable warnings + ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\'' + || dynamic_array[ni.number - 1] != 543); +' + +# Test code for whether the C compiler supports C11 (global declarations) +ac_c_conftest_c11_globals=' +// Does the compiler advertise C11 conformance? +#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L +# error "Compiler does not advertise C11 conformance" +#endif + +// Check _Alignas. +char _Alignas (double) aligned_as_double; +char _Alignas (0) no_special_alignment; +extern char aligned_as_int; +char _Alignas (0) _Alignas (int) aligned_as_int; + +// Check _Alignof. +enum +{ + int_alignment = _Alignof (int), + int_array_alignment = _Alignof (int[100]), + char_alignment = _Alignof (char) +}; +_Static_assert (0 < -_Alignof (int), "_Alignof is signed"); + +// Check _Noreturn. +int _Noreturn does_not_return (void) { for (;;) continue; } + +// Check _Static_assert. +struct test_static_assert +{ + int x; + _Static_assert (sizeof (int) <= sizeof (long int), + "_Static_assert does not work in struct"); + long int y; +}; + +// Check UTF-8 literals. +#define u8 syntax error! +char const utf8_literal[] = u8"happens to be ASCII" "another string"; + +// Check duplicate typedefs. +typedef long *long_ptr; +typedef long int *long_ptr; +typedef long_ptr long_ptr; + +// Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1. +struct anonymous +{ + union { + struct { int i; int j; }; + struct { int k; long int l; } w; + }; + int m; +} v1; +' + +# Test code for whether the C compiler supports C11 (body of main). +ac_c_conftest_c11_main=' + _Static_assert ((offsetof (struct anonymous, i) + == offsetof (struct anonymous, w.k)), + "Anonymous union alignment botch"); + v1.i = 2; + v1.w.k = 5; + ok |= v1.i != 5; +' + +# Test code for whether the C compiler supports C11 (complete). +ac_c_conftest_c11_program="${ac_c_conftest_c89_globals} +${ac_c_conftest_c99_globals} +${ac_c_conftest_c11_globals} + +int +main (int argc, char **argv) +{ + int ok = 0; + ${ac_c_conftest_c89_main} + ${ac_c_conftest_c99_main} + ${ac_c_conftest_c11_main} + return ok; +} +" + +# Test code for whether the C compiler supports C99 (complete). +ac_c_conftest_c99_program="${ac_c_conftest_c89_globals} +${ac_c_conftest_c99_globals} + +int +main (int argc, char **argv) +{ + int ok = 0; + ${ac_c_conftest_c89_main} + ${ac_c_conftest_c99_main} + return ok; +} +" + +# Test code for whether the C compiler supports C89 (complete). +ac_c_conftest_c89_program="${ac_c_conftest_c89_globals} + +int +main (int argc, char **argv) +{ + int ok = 0; + ${ac_c_conftest_c89_main} + return ok; +} +" + +as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H" +as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H" +as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H" +as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H" +as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H" +as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H" +as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H" +as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H" +as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H" +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + 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;} + 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;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + 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;} + 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;} + 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;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + 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: 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' + and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +# To suppress "WARNING: unrecognized options: --with-compiler" + +# Check whether --with-compiler was given. +if test ${with_compiler+y} +then : + withval=$with_compiler; +fi + + +# Check headers and functions required + + + + + + + + + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + 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 +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +printf "%s\n" "$ac_ct_CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + fi +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl.exe + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl.exe +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + 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 +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +printf "%s\n" "$ac_ct_CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$ac_ct_CC" && break +done + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +fi + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args. +set dummy ${ac_tool_prefix}clang; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}clang" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "clang", so it can be a program name with args. +set dummy clang; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + 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 +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="clang" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +printf "%s\n" "$ac_ct_CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +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;} +as_fn_error $? "no acceptable C compiler found in \$PATH +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 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion -version; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main (void) +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 +printf %s "checking whether the C compiler works... " >&6; } +ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + +# The possible output files: +ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" + +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { { ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + 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' +# 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. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no; + then :; else + 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' + # 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. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else $as_nop + ac_file='' +fi +if test -z "$ac_file" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +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;} +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; } +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; } +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +printf "%s\n" "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext + +rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 +printf %s "checking for suffix of executables... " >&6; } +if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + 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'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) 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;} +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest conftest$ac_cv_exeext +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +printf "%s\n" "$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main (void) +{ +FILE *f = fopen ("conftest.out", "w"); + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +printf %s "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + 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;} +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; } + 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 +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 +/* end confdefs.h. */ + +int +main (void) +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +then : + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else $as_nop + 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;} +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 +printf "%s\n" "$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 +printf %s "checking whether the compiler supports GNU C... " >&6; } +if test ${ac_cv_c_compiler_gnu+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main (void) +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_compiler_gnu=yes +else $as_nop + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +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; } +ac_compiler_gnu=$ac_cv_c_compiler_gnu + +if test $ac_compiler_gnu = yes; then + GCC=yes +else + GCC= +fi +ac_test_CFLAGS=${CFLAGS+y} +ac_save_CFLAGS=$CFLAGS +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 +printf %s "checking whether $CC accepts -g... " >&6; } +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 + ac_c_werror_flag=yes + ac_cv_prog_cc_g=no + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main (void) +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_g=yes +else $as_nop + CFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main (void) +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + +else $as_nop + ac_c_werror_flag=$ac_save_c_werror_flag + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main (void) +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_g=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + ac_c_werror_flag=$ac_save_c_werror_flag +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; } +if test $ac_test_CFLAGS; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +ac_prog_cc_stdc=no +if test x$ac_prog_cc_stdc = xno +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 +printf %s "checking for $CC option to enable C11 features... " >&6; } +if test ${ac_cv_prog_cc_c11+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_cv_prog_cc_c11=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_c_conftest_c11_program +_ACEOF +for ac_arg in '' -std=gnu11 +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_c11=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam + test "x$ac_cv_prog_cc_c11" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC +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 +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 +printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } + CC="$CC $ac_cv_prog_cc_c11" +fi + ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 + ac_prog_cc_stdc=c11 +fi +fi +if test x$ac_prog_cc_stdc = xno +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 +printf %s "checking for $CC option to enable C99 features... " >&6; } +if test ${ac_cv_prog_cc_c99+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_cv_prog_cc_c99=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_c_conftest_c99_program +_ACEOF +for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_c99=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam + test "x$ac_cv_prog_cc_c99" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC +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 +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 +printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } + CC="$CC $ac_cv_prog_cc_c99" +fi + ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 + ac_prog_cc_stdc=c99 +fi +fi +if test x$ac_prog_cc_stdc = xno +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 +printf %s "checking for $CC option to enable C89 features... " >&6; } +if test ${ac_cv_prog_cc_c89+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_c_conftest_c89_program +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_c89=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC +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 +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 +printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } + CC="$CC $ac_cv_prog_cc_c89" +fi + ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 + ac_prog_cc_stdc=c89 +fi +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +ac_header= ac_cache= +for ac_item in $ac_header_c_list +do + if test $ac_cache; then + ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default" + if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then + printf "%s\n" "#define $ac_item 1" >> confdefs.h + fi + ac_header= ac_cache= + elif test $ac_header; then + ac_cache=$ac_item + else + ac_header=$ac_item + fi +done + + + + + + + + +if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes +then : + +printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "time.h" "ac_cv_header_time_h" "$ac_includes_default" +if test "x$ac_cv_header_time_h" = xyes +then : + printf "%s\n" "#define HAVE_TIME_H 1" >>confdefs.h + +fi + +ac_fn_c_check_func "$LINENO" "clock_gettime" "ac_cv_func_clock_gettime" +if test "x$ac_cv_func_clock_gettime" = xyes +then : + printf "%s\n" "#define HAVE_CLOCK_GETTIME 1" >>confdefs.h + +fi + + +# Output +ac_config_headers="$ac_config_headers src/config.h" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# 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 +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (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 + # 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. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +printf "%s\n" "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# 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 + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # 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 #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + + +# Reset variables that may have inherited troublesome values from +# the environment. + +# IFS needs to be set, to space, tab, and newline, in precisely that order. +# (If _AS_PATH_WALK were called with IFS unset, it would have the +# side effect of setting IFS to empty, thus disabling word splitting.) +# Quoting is to prevent editors from complaining about space-tab. +as_nl=' +' +export as_nl +IFS=" "" $as_nl" + +PS1='$ ' +PS2='> ' +PS4='+ ' + +# Ensure predictable behavior from utilities with locale-dependent output. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# We cannot yet rely on "unset" to work, but we need these variables +# to be unset--not just set to an empty or harmless value--now, to +# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct +# also avoids known problems related to "unset" and subshell syntax +# in other old shells (e.g. bash 2.01 and pdksh 5.2.14). +for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH +do eval test \${$as_var+y} \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done + +# Ensure that fds 0, 1, and 2 are open. +if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi +if (exec 3>&2) ; then :; else exec 2>/dev/null; fi + +# The user is always right. +if ${PATH_SEPARATOR+false} :; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + test -r "$as_dir$0" && as_myself=$as_dir$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# 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 +fi +if test ! -f "$as_myself"; then + printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + printf "%s\n" "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null +then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else $as_nop + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null +then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else $as_nop + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + +# Determine whether it's possible to make 'echo' print without a newline. +# These variables are no longer used directly by Autoconf, but are AC_SUBSTed +# for compatibility with existing Makefiles. +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +# For backward compatibility with old third-party macros, we provide +# the shell variables $as_echo and $as_echo_n. New code should use +# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. +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 +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + 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'. + 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 + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +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'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# 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 + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + + +case $ac_config_headers in *" +"*) set x $ac_config_headers; shift; ac_config_headers=$*;; +esac + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_headers="$ac_config_headers" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$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. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration headers: +$config_headers + +Report bugs to . +streamly-core home page: ." + +_ACEOF +ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` +ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` +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, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2021 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + printf "%s\n" "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + printf "%s\n" "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --header | --heade | --head | --hea ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append CONFIG_HEADERS " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h) + # Conflict between --help and --header + 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 \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + printf "%s\n" "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + 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;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test ${CONFIG_HEADERS+y} || CONFIG_HEADERS=$config_headers +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# 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'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# 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'. +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 +# here-document in config.status, that substitutes the proper values into +# config.h.in to produce config.h. + +# Create a delimiter string that does not exist in confdefs.h, to ease +# handling of long lines. +ac_delim='%!_!# ' +for ac_last_try in false false :; do + ac_tt=`sed -n "/$ac_delim/p" confdefs.h` + if test -z "$ac_tt"; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done + +# For the awk script, D is an array of macro values keyed by name, +# likewise P contains macro parameters if any. Preserve backslash +# newline sequences. + +ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* +sed -n ' +s/.\{148\}/&'"$ac_delim"'/g +t rset +:rset +s/^[ ]*#[ ]*define[ ][ ]*/ / +t def +d +:def +s/\\$// +t bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3"/p +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p +d +:bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3\\\\\\n"\\/p +t cont +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p +t cont +d +:cont +n +s/.\{148\}/&'"$ac_delim"'/g +t clear +:clear +s/\\$// +t bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/"/p +d +:bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p +b cont +' >$CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + for (key in D) D_is_set[key] = 1 + FS = "" +} +/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { + line = \$ 0 + split(line, arg, " ") + if (arg[1] == "#") { + defundef = arg[2] + mac1 = arg[3] + } else { + defundef = substr(arg[1], 2) + mac1 = arg[2] + } + split(mac1, mac2, "(") #) + macro = mac2[1] + prefix = substr(line, 1, index(line, defundef) - 1) + if (D_is_set[macro]) { + # Preserve the white space surrounding the "#". + print prefix "define", macro P[macro] D[macro] + next + } else { + # Replace #undef with comments. This is necessary, for example, + # in the case of _POSIX_SOURCE, which is predefined and required + # on some systems where configure will not decide to define it. + if (defundef == "undef") { + print "/*", prefix defundef, macro, "*/" + next + } + } +} +{ print } +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 +fi # test -n "$CONFIG_HEADERS" + + +eval set X " :H $CONFIG_HEADERS " +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) 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 `:'. + 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;; + 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 + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +printf "%s\n" "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`printf "%s\n" "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + + :H) + # + # CONFIG_HEADER + # + if test x"$ac_file" != x-; then + { + printf "%s\n" "/* $configure_input */" >&1 \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" + } >"$ac_tmp/config.h" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 +printf "%s\n" "$as_me: $ac_file is unchanged" >&6;} + else + rm -f "$ac_file" + mv "$ac_tmp/config.h" "$ac_file" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + fi + else + printf "%s\n" "/* $configure_input */" >&1 \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ + || as_fn_error $? "could not create -" "$LINENO" 5 + fi + ;; + + + esac + +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + + diff --git a/configure.ac b/configure.ac new file mode 100644 --- /dev/null +++ b/configure.ac @@ -0,0 +1,17 @@ +# Input file for autoconf to generate the configure script. + +# 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]) + +# To suppress "WARNING: unrecognized options: --with-compiler" +AC_ARG_WITH([compiler], [GHC]) + +# Check headers and functions required +AC_CHECK_HEADERS([time.h]) +AC_CHECK_FUNCS([clock_gettime]) + +# Output +AC_CONFIG_HEADERS([src/config.h]) +AC_OUTPUT diff --git a/docs/ApiChangelogs/0.1.0.txt b/docs/ApiChangelogs/0.1.0.txt new file mode 100644 --- /dev/null +++ b/docs/ApiChangelogs/0.1.0.txt @@ -0,0 +1,405 @@ +--------------------------------- +Terminology +--------------------------------- + +[A]: Added +[R]: Removed +[C]: Changed +[D]: Deprecated +[O]: Old +[N]: New + +--------------------------------- +Difference +--------------------------------- + +The moved modules have been compared with their version in streamly v0.8.3 + +[A] Streamly.Unicode.String + [A] str :: QuasiQuoter +[C] Streamly.Unicode.Stream + [C] encodeUtf8' + [O] encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8 + [N] encodeUtf8' :: Monad m => Stream m Char -> Stream m Word8 + [C] encodeUtf8 + [O] encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8 + [N] encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8 + [C] encodeStrings + [O] encodeStrings :: (MonadIO m, IsStream t) => (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8) + [N] encodeStrings :: MonadIO m => (Stream m Char -> Stream m Word8) -> Stream m String -> Stream m (Array Word8) + [C] encodeLatin1' + [O] encodeLatin1' :: (IsStream t, Monad m) => t m Char -> t m Word8 + [N] encodeLatin1' :: Monad m => Stream m Char -> Stream m Word8 + [C] encodeLatin1 + [O] encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8 + [N] encodeLatin1 :: Monad m => Stream m Char -> Stream m Word8 + [A] decodeUtf8Chunks :: MonadIO m => Stream m (Array Word8) -> Stream m Char + [C] decodeUtf8' + [O] decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char + [N] decodeUtf8' :: Monad m => Stream m Word8 -> Stream m Char + [C] decodeUtf8 + [O] decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char + [N] decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char + [C] decodeLatin1 + [O] decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char + [N] decodeLatin1 :: Monad m => Stream m Word8 -> Stream m Char +[A] Streamly.Unicode.Parser + [A] upper :: Monad m => Parser Char m Char + [A] symbol :: Monad m => Parser Char m Char + [A] stringIgnoreCase :: Monad m => String -> Parser Char m String + [A] string :: Monad m => String -> Parser Char m String + [A] space :: Monad m => Parser Char m Char + [A] signed :: (Num a, Monad m) => Parser Char m a -> Parser Char m a + [A] separator :: Monad m => Parser Char m Char + [A] punctuation :: Monad m => Parser Char m Char + [A] printable :: Monad m => Parser Char m Char + [A] octDigit :: Monad m => Parser Char m Char + [A] numeric :: Monad m => Parser Char m Char + [A] mark :: Monad m => Parser Char m Char + [A] lower :: Monad m => Parser Char m Char + [A] letter :: Monad m => Parser Char m Char + [A] latin1 :: Monad m => Parser Char m Char + [A] hexadecimal :: (Monad m, Integral a, Bits a) => Parser Char m a + [A] hexDigit :: Monad m => Parser Char m Char + [A] dropSpace1 :: Monad m => Parser Char m () + [A] dropSpace :: Monad m => Parser Char m () + [A] digit :: Monad m => Parser Char m Char + [A] decimal :: (Monad m, Integral a) => Parser Char m a + [A] charIgnoreCase :: Monad m => Char -> Parser Char m Char + [A] char :: Monad m => Char -> Parser Char m Char + [A] asciiUpper :: Monad m => Parser Char m Char + [A] asciiLower :: Monad m => Parser Char m Char + [A] ascii :: Monad m => Parser Char m Char + [A] alphaNum :: Monad m => Parser Char m Char + [A] alpha :: Monad m => Parser Char m Char +[C] Streamly.FileSystem.Handle + [D] writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 () + [A] writeWith :: MonadIO m => Int -> Handle -> Fold m Word8 () + [C] writeChunks + [O] writeChunks :: (MonadIO m, Storable a) => Handle -> Fold m (Array a) () + [N] writeChunks :: MonadIO m => Handle -> Fold m (Array a) () + [A] readerWith :: MonadIO m => Unfold m (Int, Handle) Word8 + [A] reader :: MonadIO m => Unfold m Handle Word8 + [D] readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8 + [D] readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Handle) (Array Word8) + [D] readChunks :: MonadIO m => Unfold m Handle (Array Word8) + [D] read :: MonadIO m => Unfold m Handle Word8 + [C] putChunk + [O] putChunk :: (MonadIO m, Storable a) => Handle -> Array a -> m () + [N] putChunk :: MonadIO m => Handle -> Array a -> m () + [A] chunkReaderWith :: MonadIO m => Unfold m (Int, Handle) (Array Word8) + [A] chunkReader :: MonadIO m => Unfold m Handle (Array Word8) +[A] Streamly.FileSystem.File + [A] writeWith :: (MonadIO m, MonadCatch m) => Int -> FilePath -> Fold m Word8 () + [A] writeChunks :: (MonadIO m, MonadCatch m) => FilePath -> Fold m (Array a) () + [A] write :: (MonadIO m, MonadCatch m) => FilePath -> Fold m Word8 () + [A] withFile :: (MonadIO m, MonadCatch m) => FilePath -> IOMode -> (Handle -> Stream m a) -> Stream m a + [A] readChunksWith :: (MonadIO m, MonadCatch m) => Int -> FilePath -> Stream m (Array Word8) + [A] readChunks :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array Word8) + [A] read :: (MonadIO m, MonadCatch m) => FilePath -> Stream m Word8 +[A] Streamly.FileSystem.Dir + [A] readEither :: MonadIO m => FilePath -> Stream m (Either FilePath FilePath) + [A] read :: MonadIO m => FilePath -> Stream m FilePath +[C] Streamly.Data.Unfold + [C] take + [O] take :: Monad m => Int -> Unfold m a b -> Unfold m a b + [N] take :: Applicative m => Int -> Unfold m a b -> Unfold m a b + [C] replicateM + [O] replicateM :: Monad m => Int -> Unfold m (m a) a + [N] replicateM :: Applicative m => Unfold m (Int, m a) a + [C] repeatM + [O] repeatM :: Monad m => Unfold m (m a) a + [N] repeatM :: Applicative m => Unfold m (m a) a + [C] many + [O] many :: Monad m => Unfold m a b -> Unfold m b c -> Unfold m a c + [N] many :: Monad m => Unfold m b c -> Unfold m a b -> Unfold m a c + [C] iterateM + [O] iterateM :: Monad m => (a -> m a) -> Unfold m (m a) a + [N] iterateM :: Applicative m => (a -> m a) -> Unfold m (m a) a + [C] fromStream + [O] fromStream :: (IsStream t, Monad m) => Unfold m (t m a) a + [N] fromStream :: Applicative m => Unfold m (Stream m a) a + [C] fromListM + [O] fromListM :: Monad m => Unfold m [m a] a + [N] fromListM :: Applicative m => Unfold m [m a] a + [C] fromList + [O] fromList :: Monad m => Unfold m [a] a + [N] fromList :: Applicative m => Unfold m [a] a + [C] drop + [O] drop :: Monad m => Int -> Unfold m a b -> Unfold m a b + [N] drop :: Applicative m => Int -> Unfold m a b -> Unfold m a b +[A] Streamly.Data.StreamK + [A] StreamK + [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] uncons :: Applicative m => StreamK m a -> m (Maybe (a, StreamK m a)) + [A] toStream :: Applicative m => StreamK m a -> Stream m a + [A] sortBy :: Monad m => (a -> a -> Ordering) -> StreamK m a -> StreamK m a + [A] reverse :: StreamK m a -> StreamK m a + [A] parseChunks :: (Monad m, Unbox a) => ParserK a m b -> StreamK m (Array a) -> m (Either ParseError b) + [A] parseBreakChunks :: (Monad m, Unbox a) => ParserK a m b -> StreamK m (Array a) -> m (Either ParseError b, StreamK m (Array a)) + [A] nilM :: Applicative m => m b -> StreamK m a + [A] nil :: 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] 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] interleave :: StreamK m a -> StreamK m a -> StreamK m a + [A] fromStream :: Monad m => Stream m a -> StreamK m a + [A] fromPure :: a -> StreamK m a + [A] fromFoldable :: Foldable f => f a -> StreamK m a + [A] fromEffect :: Monad m => m a -> StreamK m a + [A] crossWith :: Monad m => (a -> b -> c) -> StreamK m a -> StreamK m b -> StreamK m c + [A] consM :: Monad m => m a -> StreamK m a -> StreamK m a + [A] cons :: 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] concatEffect :: Monad m => m (StreamK m a) -> StreamK m a + [A] append :: StreamK m a -> StreamK m a -> StreamK m a +[A] Streamly.Data.Stream + [A] class Enum a => Enumerable a + [A] Stream + [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] 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] unfoldMany :: 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] trace :: Monad m => (a -> m b) -> Stream m a -> Stream m a + [A] toList :: Monad m => Stream m a -> 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] takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a + [A] take :: Applicative m => Int -> Stream m a -> Stream m a + [A] stripPrefix :: (Monad m, Eq a) => Stream m a -> Stream m a -> m (Maybe (Stream m a)) + [A] sequence :: Monad m => Stream m (m a) -> Stream m a + [A] scanMaybe :: Monad m => Fold m a (Maybe 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] 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] repeatM :: Monad m => m a -> Stream m a + [A] repeat :: Monad m => a -> Stream m a + [A] postscan :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] parseMany :: Monad m => Parser a m b -> Stream m a -> Stream m (Either ParseError b) + [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] 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] 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] 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 -> Stream m b + [A] liftInner :: (Monad m, MonadTrans t, Monad (t m)) => Stream m a -> Stream (t m) a + [A] iterateM :: Monad m => (a -> m a) -> m a -> Stream m a + [A] iterate :: Monad m => (a -> a) -> a -> Stream m a + [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] intersperseM_ :: 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] 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] indexed :: Monad m => Stream m a -> Stream m (Int, a) + [A] handle :: (MonadCatch m, Exception e) => (e -> Stream m a) -> Stream m a -> Stream m a + [A] fromPure :: Applicative m => a -> Stream m a + [A] fromList :: Applicative m => [a] -> Stream m a + [A] fromEffect :: Applicative m => m a -> Stream m a + [A] foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b + [A] foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b + [A] foldMany :: Monad m => Fold m a b -> Stream m a -> Stream m b + [A] foldBreak :: Monad m => Fold m a b -> Stream m a -> m (b, Stream m a) + [A] fold :: Monad m => Fold m a b -> Stream m a -> m b + [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] filter :: Monad m => (a -> Bool) -> Stream 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] enumerateFromTo :: (Enumerable a, Monad m) => a -> a -> Stream m a + [A] enumerateFromThenTo :: (Enumerable a, Monad m) => a -> a -> a -> Stream m a + [A] enumerateFromThen :: (Enumerable a, Monad m) => 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] dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a + [A] dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a + [A] drop :: Monad m => Int -> 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] 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] concatEffect :: Monad m => m (Stream m a) -> Stream m a + [A] cmpBy :: Monad m => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering + [A] chunksOf :: forall m a. (MonadIO m, Unbox a) => Int -> Stream m a -> Stream m (Array a) + [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] 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] afterIO :: MonadIO m => IO b -> Stream m a -> Stream m a +[A] Streamly.Data.ParserK + [A] ParserK + [A] fromPure :: b -> ParserK a m b + [A] fromParser :: (Monad m, Unbox a) => Parser a m b -> ParserK a m b + [A] fromFold :: (MonadIO m, Unbox a) => Fold m a b -> ParserK a m b + [A] fromEffect :: Monad m => m b -> ParserK a m b + [A] die :: String -> ParserK a m b +[A] Streamly.Data.Parser + [A] Parser + [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] wordBy :: Monad m => (a -> Bool) -> Fold m a 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] takeEQ :: Monad m => Int -> Fold m a b -> Parser a m b + [A] streamEqBy :: Monad m => (a -> a -> Bool) -> Stream m a -> Parser a m () + [A] some :: Monad m => Parser a m b -> Fold m b c -> Parser a m c + [A] satisfy :: Monad m => (a -> Bool) -> Parser a m a + [A] rmapM :: Monad m => (b -> m c) -> Parser a m b -> 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] one :: Monad m => Parser a m a + [A] noneOf :: (Monad m, Eq a, Foldable f) => f a -> Parser a m a + [A] manyTill :: Monad m => Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c + [A] many :: Monad m => Parser a m b -> Fold m b c -> Parser a m c + [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] groupBy :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser a m b + [A] fromPure :: Monad m => 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] eof :: Monad m => Parser a m () + [A] dropWhile :: Monad m => (a -> Bool) -> Parser a m () + [A] die :: Monad m => String -> Parser a m b + [A] deintercalate :: Monad m => Parser a m x -> Parser a m y -> Fold m (Either x y) z -> Parser a m z +[A] Streamly.Data.MutArray.Generic + [A] MutArray + [A] writeN :: MonadIO m => Int -> Fold m a (MutArray a) + [A] toList :: MonadIO m => MutArray a -> m [a] + [A] snoc :: MonadIO m => MutArray a -> a -> m (MutArray a) + [A] reader :: MonadIO m => Unfold m (MutArray a) a + [A] putIndex :: MonadIO m => Int -> MutArray a -> a -> m () + [A] new :: forall m a. MonadIO m => Int -> m (MutArray a) + [A] modifyIndex :: MonadIO m => Int -> MutArray a -> (a -> (a, b)) -> m b + [A] getIndex :: MonadIO m => Int -> MutArray a -> m a +[A] Streamly.Data.MutArray + [A] class Unbox a + [A] MutArray + [A] writeN :: forall m a. (MonadIO m, Unbox a) => Int -> 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] toList :: forall m a. (MonadIO m, Unbox a) => MutArray a -> m [a] + [A] snoc :: forall m a. (MonadIO m, Unbox a) => MutArray a -> a -> m (MutArray a) + [A] sizeOf :: (Unbox a, SizeOfRep (Rep a)) => Proxy a -> Int + [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] putIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> a -> m () + [A] pokeByteIndex :: (Unbox a, Generic a, PokeRep (Rep a)) => Int -> MutableByteArray -> a -> IO () + [A] peekByteIndex :: (Unbox a, Generic a, PeekRep (Rep a)) => Int -> MutableByteArray -> IO a + [A] newPinned :: forall m a. (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] new :: (MonadIO m, Unbox a) => Int -> m (MutArray a) + [A] length :: forall a. Unbox a => MutArray a -> Int + [A] getIndex :: forall m a. (MonadIO m, Unbox a) => Int -> MutArray a -> m a + [A] fromListN :: (MonadIO m, Unbox a) => Int -> [a] -> m (MutArray a) + [A] fromList :: (MonadIO m, Unbox a) => [a] -> m (MutArray a) + [A] cast :: forall a b. Unbox b => MutArray a -> Maybe (MutArray b) + [A] asBytes :: MutArray a -> MutArray Word8 +[C] Streamly.Data.Fold + [A] Tee + [A] [unTee] :: Tee m a b -> Fold m a b + [A] Tee :: Fold m a b -> Tee m a b + [D] variance :: (Monad m, Fractional a) => Fold m a a + [A] uniqBy :: Monad m => (a -> a -> Bool) -> Fold m a (Maybe a) + [A] topBy :: (MonadIO m, Unbox a) => (a -> a -> Ordering) -> Int -> Fold m a (MutArray a) + [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] the :: (Monad m, Eq a) => Fold m a (Maybe a) + [D] stdDev :: (Monad m, Floating a) => Fold m a a + [A] splitWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c + [D] serialWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c + [A] scanMaybe :: Monad m => Fold m a (Maybe b) -> Fold m b c -> Fold m a c + [A] scan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c + [A] postscan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c + [A] one :: Monad m => Fold m a (Maybe a) + [A] nubInt :: Monad m => Fold m Int (Maybe Int) + [A] nub :: (Monad m, Ord a) => Fold m a (Maybe a) + [A] morphInner :: (forall x. m x -> n x) -> Fold m a b -> Fold n a b + [A] latest :: Monad m => Fold m a (Maybe a) + [D] last :: Monad m => Fold m a (Maybe a) + [D] head :: Monad m => Fold m a (Maybe a) + [A] groupsOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c + [A] frequency :: (Monad m, Ord a) => Fold m a (Map a Int) + [A] foldr' :: Monad m => (a -> b -> b) -> b -> Fold m a b + [D] foldr :: Monad m => (a -> b -> b) -> b -> Fold m a b + [A] foldlM1' :: Monad m => (a -> a -> m a) -> Fold m a (Maybe a) + [A] foldl1' :: Monad m => (a -> a -> a) -> Fold m a (Maybe a) + [A] findM :: Monad m => (a -> m Bool) -> Fold m a (Maybe a) + [A] findIndices :: Monad m => (a -> Bool) -> Fold m a (Maybe Int) + [A] elemIndices :: (Monad m, Eq a) => a -> Fold m a (Maybe Int) + [A] duplicate :: Monad m => Fold m a b -> Fold m a (Fold m a b) + [A] drive :: Monad m => Stream m a -> Fold m a b -> m b + [A] drainMapM :: Monad m => (a -> m b) -> Fold m a () + [D] drainBy :: Monad m => (a -> m b) -> Fold m a () + [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] demuxIO :: (MonadIO m, Ord k) => (a -> k) -> (a -> m (Fold m a b)) -> Fold m a (m (Map k b), Maybe (k, 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] deleteBy :: Monad m => (a -> a -> Bool) -> a -> Fold m a (Maybe a) + [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] classify :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (m (Map k b), Maybe (k, b)) + [D] chunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c + [A] catRights :: Monad m => Fold m b c -> Fold m (Either a b) c + [A] catLefts :: Monad m => Fold m a c -> Fold m (Either a b) c + [A] catEithers :: Fold m a b -> Fold m (Either a a) b + [A] addStream :: Monad m => Stream m a -> Fold m a b -> m (Fold m a b) + [A] addOne :: Monad m => a -> Fold m a b -> m (Fold m a b) +[A] Streamly.Data.Array.Generic + [A] Array + [A] writeN :: MonadIO m => Int -> Fold m a (Array a) + [A] write :: MonadIO m => Fold m a (Array a) + [A] reader :: Monad m => Unfold m (Array a) a + [A] readRev :: Monad m => Array a -> Stream m a + [A] read :: MonadIO m => Array a -> Stream m a + [A] length :: Array a -> Int + [A] fromListN :: Int -> [a] -> Array a + [A] fromList :: [a] -> Array a +[A] Streamly.Data.Array + [A] class Unbox a + [A] Array + [A] writeN :: forall m a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [A] writeLastN :: (Storable a, Unbox a, MonadIO m) => Int -> Fold m a (Array a) + [A] write :: forall m a. (MonadIO m, Unbox a) => Fold m a (Array a) + [A] toList :: Unbox a => Array a -> [a] + [A] sizeOf :: (Unbox a, SizeOfRep (Rep a)) => Proxy a -> Int + [A] readerRev :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a + [A] reader :: forall m a. (Monad m, Unbox a) => Unfold m (Array a) a + [A] pokeByteIndex :: (Unbox a, Generic a, PokeRep (Rep a)) => Int -> MutableByteArray -> a -> IO () + [A] peekByteIndex :: (Unbox a, Generic a, PeekRep (Rep a)) => Int -> MutableByteArray -> IO a + [A] length :: Unbox a => Array a -> Int + [A] getIndex :: forall a. Unbox a => Int -> Array a -> Maybe a + [A] fromListN :: Unbox a => Int -> [a] -> Array a + [A] fromList :: Unbox a => [a] -> Array a + [A] cast :: forall a b. Unbox b => Array a -> Maybe (Array b) + [A] asBytes :: Array a -> Array Word8 +[C] Streamly.Console.Stdio + [A] reader :: MonadIO m => Unfold m () Word8 + [D] readChunks :: MonadIO m => Unfold m () (Array Word8) + [D] read :: MonadIO m => Unfold m () Word8 + [A] chunkReader :: MonadIO m => Unfold m () (Array Word8) diff --git a/docs/Changelog.md b/docs/Changelog.md new file mode 100644 --- /dev/null +++ b/docs/Changelog.md @@ -0,0 +1,32 @@ +# Changelog + +## 0.1.0 (March 2023) + +Also see [streamly-core-0.1.0 API Changelog](/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 +has only GHC boot library depdendecies, and (2) `streamly` that contains +higher level operations (including concurrent ones) with additional +dependencies. + +* Moved the following modules from `streamly` package to the + `streamly-core` package: + * Streamly.Console.Stdio + * Streamly.Data.Fold + * Streamly.Data.Unfold + * Streamly.FileSystem.Handle + * Streamly.Unicode.Stream +* Added the following new modules: + * Streamly.Data.Array + * Streamly.Data.Array.Generic + * Streamly.Data.MutArray + * Streamly.Data.MutArray.Generic + * Streamly.Data.Parser + * Streamly.Data.ParserK + * Streamly.Data.Stream + * Streamly.Data.StreamK + * Streamly.FileSystem.Dir + * Streamly.FileSystem.File + * Streamly.Unicode.Parser + * Streamly.Unicode.String diff --git a/docs/Readme.md b/docs/Readme.md new file mode 100644 --- /dev/null +++ b/docs/Readme.md @@ -0,0 +1,1 @@ +Please refer to the "streamly" package for tutorials and other documentation. diff --git a/jsbits/clock.js b/jsbits/clock.js new file mode 100644 --- /dev/null +++ b/jsbits/clock.js @@ -0,0 +1,31 @@ +function h$clock_gettime_js(when, p_d, p_o) { + /* XXX: guess if we have to write 64 bit values: + + alloca is often used and will give us 16 bytes + if timespec contains two 64 bit values + + but we really should fix this by not having hsc2hs values + from the build system leak here + */ + var is64 = p_d.i3.length == 4 && p_o == 0; + var o = p_o >> 2, + t = Date.now ? Date.now() : new Date().getTime(), + tf = Math.floor(t / 1000), + tn = 1000000 * (t - (1000 * tf)); + if(is64) { + p_d.i3[o] = tf|0; + p_d.i3[o+1] = 0; + p_d.i3[o+2] = tn|0; + p_d.i3[o+3] = 0; + } else { + p_d.i3[o] = tf|0; + p_d.i3[o+1] = tn|0; + } + return 0; +} +/* Hack! Supporting code for "clock" package + * "hspec" depends on clock. + */ +function h$hs_clock_darwin_gettime(when, p_d, p_o) { + h$clock_gettime_js(when, p_d, p_o); +} diff --git a/src/DocTestDataArray.hs b/src/DocTestDataArray.hs new file mode 100644 --- /dev/null +++ b/src/DocTestDataArray.hs @@ -0,0 +1,14 @@ +{- $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 new file mode 100644 --- /dev/null +++ b/src/DocTestDataFold.hs @@ -0,0 +1,28 @@ +{- $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 new file mode 100644 --- /dev/null +++ b/src/DocTestDataMutArray.hs @@ -0,0 +1,10 @@ +{- $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 new file mode 100644 --- /dev/null +++ b/src/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.Array.Generic.Mut.Type as MutArray +-} diff --git a/src/DocTestDataParser.hs b/src/DocTestDataParser.hs new file mode 100644 --- /dev/null +++ b/src/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/DocTestDataStream.hs b/src/DocTestDataStream.hs new file mode 100644 --- /dev/null +++ b/src/DocTestDataStream.hs @@ -0,0 +1,37 @@ +{- $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 new file mode 100644 --- /dev/null +++ b/src/DocTestDataStreamK.hs @@ -0,0 +1,20 @@ +{- $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 new file mode 100644 --- /dev/null +++ b/src/DocTestDataUnfold.hs @@ -0,0 +1,12 @@ +{- $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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Console/Stdio.hs @@ -0,0 +1,56 @@ +-- | +-- Module : Streamly.Console.Stdio +-- Copyright : (c) 2021 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- Combinators to work with standard input, output and error streams. +-- +-- See also: "Streamly.Internal.Console.Stdio" + +module Streamly.Console.Stdio + ( + -- * Unfolds (stdin) + reader + , chunkReader + + -- * Write (stdout) + , write + , writeChunks + + -- * 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 diff --git a/src/Streamly/Data/Array.hs b/src/Streamly/Data/Array.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Array.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.Array +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- Unboxed immutable arrays with streaming interfaces. +-- +-- Please refer to "Streamly.Internal.Data.Array" for functions that have not +-- yet been released. +-- +-- For arrays that work on boxed types, not requiring the 'Unbox' constraint, +-- please refer to "Streamly.Data.Array.Generic". For arrays that can be +-- mutated in-place, please see "Streamly.Data.MutArray". + +module Streamly.Data.Array + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Overview + -- $overview + + -- * The Array Type + A.Array + + -- * Construction + -- | When performance matters, the fastest way to generate an array is + -- 'writeN'. '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 + + -- Monadic APIs + , A.writeN -- drop new + , A.write -- full buffer + , writeLastN -- drop old (ring buffer) + + -- * Conversion + -- 'GHC.Exts.toList' from "GHC.Exts" can be used to convert an array to a + -- list. + , A.toList + + -- * Unfolds + , A.reader + , A.readerRev + + -- * Casting + , cast + , asBytes + + -- * Random Access + , A.length + -- , (!!) + , A.getIndex + + -- * Unbox Type Class + , Unbox (..) + + -- * Deprecated + , read + , readRev + ) +where + +#include "inline.hs" + +import Streamly.Internal.Data.Unfold (Unfold) +import Streamly.Internal.Data.Array as A hiding (read, readRev) + +import Streamly.Internal.Data.Unboxed (Unbox (..)) +import Prelude hiding (read) + +#include "DocTestDataArray.hs" + +-- $overview +-- +-- This module provides APIs to create and use unboxed immutable arrays. Once +-- created, their contents cannot be modified. Only types that are unboxable +-- via the 'Unbox' type class can be stored in these arrays. Note that the +-- array memory grows automatically when creating a new array, therefore, an +-- array can be created from a variable length stream. +-- +-- == Folding Arrays +-- +-- Convert array to stream, and fold the stream: +-- +-- >>> fold f arr = Stream.unfold Array.reader arr & Stream.fold f +-- >>> fold Fold.sum (Array.fromList [1,2,3::Int]) +-- 6 +-- +-- == Transforming Arrays +-- +-- 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 (+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. +-- +-- Unpinned arrays have the advantage of allowing automatic defragmentation of +-- the memory by GC. Whereas pinned arrays have the advantage of not requiring +-- a copy by GC. Normally you would want to use unpinned arrays. However, in +-- some cases, for example, for long lived large data storage, and for +-- interfacing with the operating system or foreign (non-Haskell) consumers you +-- may want to use pinned arrays. +-- +-- == 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: +-- +-- The 'MonadIO' based folds can be morphed to 'Identity' stream folds: +-- +-- >>> purely = Fold.morphInner (Identity . unsafePerformIO) +-- >>> Stream.fold (purely Array.write) $ Stream.fromList [1,2,3::Int] +-- Identity fromList [1,2,3] +-- +-- Since it is a pure stream we can use 'unsafePerformIO' to extract the result +-- of fold from IO. +-- +-- Alternatively, 'Identity' streams can be generalized to IO streams: +-- +-- >>> 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] +-- +-- == 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Array/Generic.hs @@ -0,0 +1,43 @@ +-- | +-- Module : Streamly.Data.Array.Generic +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Unconstrained version of "Streamly.Data.Array" module. +-- +-- See the "Streamly.Data.Array" module for documentation. +-- +module Streamly.Data.Array.Generic + ( Array + + -- * Construction + , A.fromListN + , A.fromList + + -- MonadicAPIs + , A.writeN + , A.write + + -- * Streams + , A.read + , A.readRev + + -- * Unfolds + , A.reader + + -- * Random Access + , A.length + + -- -- * Folding Arrays + -- , A.streamFold + -- , A.fold + ) +where + +import Streamly.Internal.Data.Array.Generic (Array) + +import qualified Streamly.Internal.Data.Array.Generic as A diff --git a/src/Streamly/Data/Fold.hs b/src/Streamly/Data/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Fold.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.Fold +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- Fast, composable stream consumers with ability to terminate, supporting +-- stream fusion. +-- +-- Please refer to "Streamly.Internal.Data.Fold" for more functions that have +-- not yet been released. + +module Streamly.Data.Fold + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Overview + -- $overview + + -- * Running A Fold + drive + -- XXX Should we have a stream returning function in fold module? + -- , breakStream + + -- * Fold Type + + , Fold -- (..) + , Tee (..) + + -- * Constructors + , foldl' + , foldlM' + , foldl1' + , foldlM1' + , foldr' + + -- * Folds + -- ** Accumulators + -- | Folds that never terminate, these folds 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 folds we could write Monoids and turn them into folds. + + -- Monoids + , sconcat + , mconcat + , foldMap + , foldMapM + + -- Reducers + , drain + , drainMapM + , length + , countDistinct + , countDistinctInt + , frequency + , sum + , product + , mean + , rollingHash + , rollingHashWithSalt + + -- Collectors + , toList + , toListRev + , toSet + , toIntSet + , toMap + , toMapIO + , demuxToMap + , demuxToMapIO + , 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 'scanMaybe' + -- combinator. + , findIndices + , elemIndices + , deleteBy + -- , uniq + , uniqBy + , nub + , nubInt + , classify + , classifyIO + , demux + , demuxIO + + -- ** Terminating Folds + , one + , null + -- , satisfy + -- , maybe + + , index + , the + , find + , findM + , lookup + , findIndex + , elemIndex + , elem + , notElem + , all + , any + , 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 + -- applied either on the input side (contravariant) or on the output side + -- (covariant). Therefore, combinators are of 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) + -- + -- The input side transformations are more interesting for folds. Most of + -- the following sections describe the input transformation operations on a + -- fold. 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 fold maps on the output of the fold: + -- + -- >>> Stream.fold (fmap show Fold.sum) (Stream.enumerateFromTo 1 100) + -- "5050" + -- + , rmapM + + -- ** Mapping on Input + , lmap + , lmapM + + -- ** Scanning and Filtering + , scan + , postscan + , scanMaybe + , filter + , filterM + + -- -- ** Mapping Filters + , mapMaybe + , catMaybes + , catLefts + , catRights + , catEithers + + -- ** Trimming + , take + -- , takeInterval + , takeEndBy + , takeEndBy_ + + -- ** Serial Append + , splitWith + + -- ** Parallel Distribution + -- | For applicative composition using distribution see + -- "Streamly.Internal.Data.Fold.Tee". + + , teeWith + --, teeWithFst + --, teeWithMin + , tee + , distribute + + -- ** Partitioning + -- | Direct items in the input stream to different folds using a binary + -- fold selector. + + , partition + --, partitionByM + --, partitionByFstM + --, partitionByMinM + --, partitionBy + + -- ** Unzipping + , unzip + + -- ** Splitting + , many + , groupsOf + -- , intervalsOf + + -- ** Nesting + , concatMap + + -- * Transforming the Monad + , morphInner + + -- * Deprecated + , chunksOf + , foldr + , drainBy + , last + , head + , sequence + , mapM + , variance + , stdDev + , serialWith + ) +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, + 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 +-------------------------------------------------------------------------------- + +{-# DEPRECATED chunksOf "Please use 'groupsOf' instead" #-} +{-# INLINE chunksOf #-} +chunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c +chunksOf = groupsOf diff --git a/src/Streamly/Data/MutArray.hs b/src/Streamly/Data/MutArray.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/MutArray.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.MutArray +-- Copyright : (c) 2022 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- This module provides a mutable version of "Streamly.Data.Array". The +-- 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 +-- not yet been released. +-- +-- For mutable arrays that work on boxed types, not requiring the 'Unbox' +-- constraint, please refer to "Streamly.Data.MutArray.Generic". + +module Streamly.Data.MutArray + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Mutable Array Type + MutArray + + -- * Construction + + -- Uninitialized Arrays + , new + , newPinned + + -- From containers + , fromListN + , fromList + , writeN -- drop new + , write -- full buffer + -- writeLastN + + -- * Appending elements + , snoc + + -- * Appending streams + , writeAppendN + , writeAppend + + -- * Inplace mutation + , putIndex + + -- * Random access + , getIndex + + -- * Conversion + , toList + + -- * Unfolds + , reader + , readerRev + + -- * Casting + , cast + , asBytes + + -- * Size + , length + + -- * Unbox Type Class + , Unbox (..) + ) +where + +import Prelude hiding (length, read) +import Streamly.Internal.Data.Array.Mut +import Streamly.Internal.Data.Unboxed (Unbox (..)) + +#include "DocTestDataMutArray.hs" diff --git a/src/Streamly/Data/MutArray/Generic.hs b/src/Streamly/Data/MutArray/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/MutArray/Generic.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.MutArray.Generic +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Unconstrained version of "Streamly.Data.MutArray" module. +-- +-- See the "Streamly.Data.MutArray" module for documentation. +-- +module Streamly.Data.MutArray.Generic +( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Type + MutArray + + -- * Construction + , writeN + + -- * Appending elements + , new + , snoc + + -- * Conversion + , toList + + -- * Unfolds + , reader + + -- * Random reads + , getIndex + + -- * Inplace mutation + , putIndex + , modifyIndex + ) +where + +import Streamly.Internal.Data.Array.Generic.Mut.Type + +#include "DocTestDataMutArrayGeneric.hs" diff --git a/src/Streamly/Data/Parser.hs b/src/Streamly/Data/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Parser.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.Parser +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- 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. +-- +-- Please refer to "Streamly.Internal.Data.Parser" for functions that have +-- not yet been released. +-- +module Streamly.Data.Parser + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Overview + -- $overview + + -- * Parser Type + Parser + + -- -- * Downgrade to Fold + -- , toFold + + -- * Parsers + -- ** From Folds + , fromFold + + -- ** Without Input + -- , fromFoldMaybe + , fromPure + , fromEffect + , die + -- , dieM + , peek + , eof + + -- ** Element parsers + + -- All of these can be expressed in terms of either + , one + -- , oneEq + -- , oneNotEq + , oneOf + , noneOf + , satisfy + -- , maybe + -- , either + + -- ** Sequences + , streamEqBy + , listEqBy + , listEq + + -- * Combinators + -- Mapping on output + -- , rmapM + + -- ** Mapping on input + , lmap + , lmapM + + -- * Map on output + , rmapM + + -- ** Filtering + , filter + + -- ** Look Ahead + , lookAhead + + -- ** Tokenize by length + -- , takeBetween + , takeEQ + -- , takeGE + -- , takeP + + -- ** Tokenize by predicate + -- , takeWhileP + , takeWhile + , takeWhile1 + , dropWhile + -- , takeEndBy + -- , takeEndByEsc + -- , takeStartBy + , wordBy + + -- ** Grouping + , groupBy + -- , groupByRolling + -- , groupByRollingEither + + -- ** Framing + -- , wordFramedBy + , wordWithQuotes + -- , wordProcessQuotes + -- , wordKeepQuotes + + -- -- * Alternative + -- , alt + + -- ** Splitting + , many + , some + , manyTill + + -- ** De-interleaving + , deintercalate + ) + +where + +import Streamly.Internal.Data.Parser +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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/ParserK.hs @@ -0,0 +1,44 @@ +-- | +-- Module : Streamly.Data.ParserK +-- Copyright : (c) 2023 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- 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. +-- +-- To run a 'ParserK' use 'Streamly.Data.StreamK.parseChunks'. +-- +module Streamly.Data.ParserK + ( + -- * Parser Type + ParserK + + -- * Parsers + -- ** Conversions + , fromFold + , fromParser + -- , toParser + + -- ** Without Input + , fromPure + , fromEffect + , die + ) + +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.Parser.ParserK.Type + +-- | Convert a 'Fold' to a 'ParserK'. +-- +{-# INLINE fromFold #-} +fromFold :: (MonadIO m, Unbox a) => Fold m a b -> ParserK a m b +fromFold = fromParser . ParserD.fromFold diff --git a/src/Streamly/Data/Stream.hs b/src/Streamly/Data/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Stream.hs @@ -0,0 +1,581 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.Stream +-- Copyright : (c) 2017 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- Fast, composable stream producers with ability to terminate, supporting +-- stream fusion. +-- +-- Please refer to "Streamly.Internal.Data.Stream" for more functions that have +-- not yet been released. +-- +-- For continuation passing style (CPS) stream type, please refer to +-- the "Streamly.Data.StreamK" module. +-- +-- Checkout the +-- repository for many more real world examples of stream programming. + +module Streamly.Data.Stream + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Overview + -- $overview + + -- * The Stream Type + Stream + + -- * Construction + -- | Functions ending in the general shape @b -> Stream m a@. + -- + -- See also: "Streamly.Internal.Data.Stream.Generate" for + -- @Pre-release@ functions. + + -- ** 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. + , nil + , nilM + , cons + , consM + + -- ** Unfolding + -- | 'unfoldrM' is the most general way of generating a stream efficiently. + -- All other generation operations can be expressed using it. + , unfoldr + , unfoldrM + + -- ** From Values + -- | Generate a monadic stream from a seed value or values. + , fromPure + , fromEffect + , 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: + -- + -- @ + -- 'fromList' $ 'Prelude.enumFromThen' from then + -- @ + -- + -- However, this is not particularly efficient. + -- The 'Enumerable' type class provides corresponding functions that + -- generate a stream instead of a list, efficiently. + + , 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. + , fromList + + -- ** From Unfolds + -- | Most of the above stream generation operations can also be expressed + -- using the corresponding unfolds in the "Streamly.Data.Unfold" module. + , unfold -- XXX rename to fromUnfold? + + -- * Elimination + -- | 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. +-- Left and right folds both use a fold function @f@ and an identity element +-- @z@ (@zero@) to deconstruct a recursive data structure and reconstruct a +-- new data structure. The new structure may be a recursive construction (a +-- container) or a non-recursive single value reduction of the original +-- structure. +-- +-- Both right and left folds are mathematical duals of each other, they are +-- functionally equivalent. Operationally, a left fold on a left associated +-- structure behaves exactly in the same way as a right fold on a right +-- associated structure. Similarly, a left fold on a right associated structure +-- behaves in the same way as a right fold on a left associated structure. +-- However, the behavior of a right fold on a right associated structure is +-- operationally different (even though functionally equivalent) than a left +-- fold on the same structure. +-- +-- On right associated structures like Haskell @cons@ lists or Streamly +-- streams, a lazy right fold is naturally suitable for lazy recursive +-- reconstruction of a new structure, while a strict left fold is naturally +-- suitable for efficient reduction. In right folds control is in the hand of +-- the @puller@ whereas in left folds the control is in the hand of the +-- @pusher@. +-- +-- The behavior of right and left folds are described in detail in the +-- individual fold's documentation. To illustrate the two folds for right +-- associated @cons@ lists: +-- +-- > foldr :: (a -> b -> b) -> b -> [a] -> b +-- > foldr f z [] = z +-- > foldr f z (x:xs) = x `f` foldr f z xs +-- > +-- > foldl :: (b -> a -> b) -> b -> [a] -> b +-- > foldl f z [] = z +-- > foldl f z (x:xs) = foldl f (z `f` x) xs +-- +-- @foldr@ is conceptually equivalent to: +-- +-- > foldr f z [] = z +-- > foldr f z [x] = f x z +-- > foldr f z xs = foldr f (foldr f z (tail xs)) [head xs] +-- +-- @foldl@ is conceptually equivalent to: +-- +-- > foldl f z [] = z +-- > foldl f z [x] = f z x +-- > foldl f z xs = foldl f (foldl f z (init xs)) [last xs] +-- +-- Left and right folds are duals of each other. +-- +-- @ +-- foldr f z xs = foldl (flip f) z (reverse xs) +-- foldl f z xs = foldr (flip f) z (reverse xs) +-- @ +-- +-- More generally: +-- +-- @ +-- foldr f z xs = foldl g id xs z where g k x = k . f x +-- foldl f z xs = foldr g id xs z where g x k = k . flip f x +-- @ +-- + +-- NOTE: Folds are inherently serial as each step needs to use the result of +-- the previous step. However, it is possible to fold parts of the stream in +-- parallel and then combine the results using a monoid. + + -- ** Primitives + -- Consuming a part of the stream and returning the rest. Functions + -- ending in the general shape @Stream m a -> m (b, Stream m a)@ + , uncons + + -- ** Strict Left Folds + -- XXX Need to have a general parse operation here which can be used to + -- express all others. + , fold -- XXX rename to run? We can have a Stream.run and Fold.run. + -- XXX fold1 can be achieved using Monoids or Refolds. + -- XXX We can call this just "break" and parseBreak as "munch" + , foldBreak + + -- XXX should we have a Fold returning function in stream module? + -- , foldAdd + -- , buildl + + -- ** Parsing + , parse + -- , parseBreak + + -- ** Lazy Right Folds + -- | Consuming a stream to build a right associated expression, suitable + -- for lazy evaluation. Evaluation of the input happens when the output of + -- the fold is evaluated, the fold output is a lazy thunk. + -- + -- This is suitable for stream transformation operations, for example, + -- operations like mapping a function over the stream. + , foldrM + , foldr + + -- ** 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 + , toList + + -- * Mapping + -- | Stateless one-to-one transformations. Use 'fmap' for mapping a pure + -- function on a stream. + + -- EXPLANATION: + -- In imperative terms a map operation can be considered as a loop over + -- the stream that transforms the stream into another stream by performing + -- an operation on each element of the stream. + -- + -- 'map' is the least powerful transformation operation with strictest + -- guarantees. A map, (1) is a stateless loop which means that no state is + -- allowed to be carried from one iteration to another, therefore, + -- operations on different elements are guaranteed to not affect each + -- other, (2) is a strictly one-to-one transformation of stream elements + -- which means it guarantees that no elements can be added or removed from + -- the stream, it can merely transform them. + , sequence + , mapM + , trace + , tap + , delay + + -- * Scanning + -- | Stateful one-to-one transformations. + -- + -- See also: "Streamly.Internal.Data.Stream.Transform" for + -- @Pre-release@ functions. + + {- + -- ** Left scans + -- | We can perform scans using folds with the 'scan' combinator in the + -- next section. However, the combinators supplied in this section are + -- better amenable to stream fusion when combined with other operations. + -- Note that 'postscan' using folds fuses well and does not require custom + -- combinators like these. + , scanl' + , scanlM' + , scanl1' + , scanl1M' + -} + + -- ** Scanning By 'Fold' + , scan + , postscan + -- XXX postscan1 can be implemented using Monoids or Refolds. + + -- ** Specific scans + -- Indexing can be considered as a special type of zipping where we zip a + -- stream with an index stream. + , indexed + + -- * Insertion + -- | Add elements to the stream. + + -- Inserting elements is a special case of interleaving/merging streams. + , insertBy + , intersperseM + , intersperseM_ + , intersperse + + -- * Filtering + -- | Remove elements from the stream. + + -- ** Stateless Filters + -- | 'mapMaybeM' is the most general stateless filtering operation. All + -- other filtering operations can be expressed using it. + + -- EXPLANATION: + -- In imperative terms a filter over a stream corresponds to a loop with a + -- @continue@ clause for the cases when the predicate fails. + + , mapMaybe + , mapMaybeM + , filter + , filterM + + -- Filter and concat + , catMaybes + , catLefts + , catRights + , catEithers + + -- ** Stateful Filters + -- | '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 + , take + , takeWhile + , takeWhileM + , drop + , dropWhile + , dropWhileM + + -- XXX These are available as scans in folds. We need to check the + -- performance though. If these are common and we need convenient stream + -- ops then we can expose these. + + -- , deleteBy + -- , uniq + -- , uniqBy + + -- -- ** Sampling + -- , strideFromThen + + -- -- ** Searching + -- Finding the presence or location of an element, a sequence of elements + -- or another stream within a stream. + + -- -- ** Searching Elements + -- , findIndices + -- , elemIndices + + -- * Combining Two Streams + -- ** Appending + , 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. + -- + -- 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. + , zipWith + , zipWithM + -- , ZipStream (..) + + -- ** Cross Product + -- XXX The argument order in this operation is such that it seems we are + -- transforming the first stream using the second stream because the second + -- stream is evaluated many times or buffered and better be finite, first + -- stream could potentially be infinite. In the tradition of using the + -- transformed stream at the end we can have a flipped version called + -- "crossMap" or "nestWith". + , crossWith + -- , cross + -- , joinInner + -- , CrossStream (..) + + -- * Unfold Each + , unfoldMany + , intercalate + , intercalateSuffix + + -- * Stream of streams + -- | Stream operations like map and filter represent loop processing 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: + -- + -- > map f m = S.concatMap (\x -> S.fromPure (f x)) m + -- + -- Similarly, 'concatMap' can perform filtering by mapping an element to a + -- 'nil' stream: + -- + -- > filter p m = S.concatMap (\x -> if p x then S.fromPure x else S.nil) m + -- + + , concatEffect + , concatMap + , concatMapM + + -- * Repeated Fold + , foldMany -- XXX Rename to foldRepeat + , parseMany + , Array.chunksOf + + -- * Buffered Operations + -- | Operations that require buffering of the stream. + -- Reverse is essentially a left fold followed by an unfold. + , reverse + + -- * Multi-Stream folds + -- | Operations that consume multiple streams at the same time. + , eqBy + , cmpBy + , isPrefixOf + , isSubsequenceOf + + -- trimming sequences + , stripPrefix + + -- 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 + -- 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. + , before + , afterIO + , finallyIO + , bracketIO + , bracketIO3 + + -- * Transforming Inner Monad + + , morphInner + , liftInner + , runReaderT + , runStateT + + -- -- * Stream Types + -- $serial + -- , Interleave + -- , Zip + ) +where + +import qualified Streamly.Internal.Data.Array.Type as Array +import Streamly.Internal.Data.Stream.StreamD +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) + +#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 diff --git a/src/Streamly/Data/Stream/Zip.hs b/src/Streamly/Data/Stream/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Stream/Zip.hs @@ -0,0 +1,16 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/StreamK.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.StreamK +-- Copyright : (c) 2017 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- 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. +-- +-- Please refer to "Streamly.Internal.Data.Stream.StreamK" for more functions +-- that have not yet been released. + +-- Notes: +-- +-- primitive/open loop operations that can be used recursively e.g. uncons, +-- foldBreak, parseBreak should not be converted from StreamD for use in +-- StreamK, instead native StreamK impl should be used. +-- +-- Closed loop operations like repeat, replicate, iterate etc can be converted +-- from StreamD. +-- +-- In the last phase any operation like (toStreamK . f . toStreamD) should be +-- rewritten to a K version of f. +-- XXX Need to add rewrite rules for all missing StreamD operations. +-- +module Streamly.Data.StreamK + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Overview + -- $overview + + -- * Type + StreamK + + -- * Construction + -- ** Primitives + , nil + , nilM + , cons + , consM + + -- ** From Values + , fromPure + , fromEffect + + -- ** From Stream + , fromStream + , toStream + + -- ** From Containers + , fromFoldable + + -- * Elimination + + -- ** Primitives + , uncons + , drain + + -- -- ** Folding + -- , foldBreak + + -- ** Parsing + -- , parseBreak + , parseBreakChunks + , parseChunks + + -- * Transformation + , mapM + , dropWhile + , take + + -- * Combining Two Streams + -- ** Appending + , append + + -- ** Interleaving + , interleave + + -- ** Merging + , mergeBy + , mergeByM + + -- ** Zipping + , zipWith + , zipWithM + + -- ** Cross Product + -- XXX is "bind/concatFor" better to have than crossWith? + -- crossWith f xs1 xs2 = concatFor xs1 (\x -> fmap (f x) xs2) + , crossWith + -- , cross + -- , joinInner + -- , CrossStreamK (..) + + -- * Stream of streams + , concatEffect + -- , concatMap + , concatMapWith + , mergeMapWith + + -- * Buffered Operations + , reverse + , sortBy + ) +where + +import Streamly.Internal.Data.Stream.StreamK +import Prelude hiding (reverse, zipWith, mapM, dropWhile, take) + +#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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Unfold.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Streamly.Data.Unfold +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- 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 +-- 'Unfold' type, is a fully fusible alternative to +-- 'Streamly.Data.Stream.concatMap'. +-- +-- Please refer to "Streamly.Internal.Data.Unfold" for more functions that have +-- not yet been released. +-- +-- Exception combinators are not exposed, we would like to encourage the use of +-- 'Stream' type instead whenever exception handling is required. We can +-- consider exposing the unfold exception functions if there is a compelling +-- use case to use unfolds instead of stream. + +module Streamly.Data.Unfold + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Overview + -- $overview + + -- * Unfold Type + Unfold + + -- * Unfolds + -- One to one correspondence with + -- "Streamly.Internal.Data.Stream.Generate" + + -- ** Basic Constructors + , unfoldrM + , unfoldr + , function + , functionM + + -- ** Generators + -- | Generate a monadic stream from a seed. + , repeatM + , replicateM + , iterateM + + -- ** From Containers + , fromList + , fromListM + , fromStream + + -- * Combinators + -- ** Mapping on Input + , lmap + , lmapM + + -- ** Mapping on Output + , mapM + + -- ** Filtering + , takeWhileM + , takeWhile + , take + , filter + , filterM + , drop + , dropWhile + , dropWhileM + + -- ** Zipping + , zipWith + + -- ** Cross Product + , crossWith + + -- ** Nesting + , many + + ) +where + +import Prelude hiding + ( concat, map, mapM, takeWhile, take, filter, const, drop, dropWhile + , zipWith + ) +import Streamly.Internal.Data.Unfold + +#include "DocTestDataUnfold.hs" + +-- $overview +-- +-- An 'Unfold' is a source or a producer of a stream of values. It takes a +-- seed value as an input and unfolds it into a sequence of values. +-- +-- For example, the 'fromList' Unfold generates a stream of values from a +-- supplied list. Unfolds can be converted to 'Streamly.Internal.Data.Stream' +-- using the 'Stream.unfold' operation. +-- +-- >>> stream = Stream.unfold Unfold.fromList [1..100] +-- >>> Stream.fold Fold.sum stream +-- 5050 +-- +-- The input seed of an unfold can be transformed using 'lmap': +-- +-- >>> u = Unfold.lmap (fmap (+1)) Unfold.fromList +-- >>> Stream.fold Fold.toList $ Stream.unfold u [1..5] +-- [2,3,4,5,6] +-- +-- Output stream of an 'Unfold' can be transformed using transformation +-- combinators. For example, to retain only the first two elements of an +-- unfold: +-- +-- >>> u = Unfold.take 2 Unfold.fromList +-- >>> Stream.fold Fold.toList $ Stream.unfold u [1..100] +-- [1,2] +-- +-- Unfolds can be nested efficiently. For example, to implement nested looping: +-- +-- >>> u1 = Unfold.lmap fst Unfold.fromList +-- >>> u2 = Unfold.lmap snd Unfold.fromList +-- >>> u = Unfold.crossWith (,) u1 u2 +-- >>> Stream.fold Fold.toList $ Stream.unfold u ([1,2,3], [4,5,6]) +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +-- 'Unfold' @u1@ generates a stream from the first list in the input tuple, +-- @u2@ generates another stream from the second list. The combines 'Unfold' +-- @u@ nests the two streams i.e. for each element in first stream, for each +-- element in second stream apply the supplied function (i.e. @(,)@) to the +-- pair of elements. +-- +-- This is the equivalent of the nested looping construct from imperative +-- languages, also known as the cross product of two streams in functional +-- parlance. +-- +-- Please see "Streamly.Internal.Data.Unfold" for additional @Pre-release@ +-- functions. +-- +-- == Creating New Unfolds +-- +-- There are many commonly used unfolds provided in this module. However, you +-- can always create your own as well. An 'Unfold' is just a data +-- representation of a stream generator function. It consists of an @inject@ +-- function which covnerts the supplied seed into an internal state of the +-- unfold, and a @step@ function which takes the state and generates the next +-- output in the stream. For those familiar with the list "Data.List.unfoldr" +-- function, this is a data representation of the same. +-- +-- Smart constructor functions are provided in this module for constructing new +-- 'Unfolds'. For example, you can use the 'Unfold.unfoldr' constructor to +-- create an 'Unfold' from a pure step function, unfoldr uses 'id' as the +-- @inject@ function. +-- +-- Let's define a simple pure step function: +-- +-- >>> :{ +-- f [] = Nothing +-- f (x:xs) = Just (x, xs) +-- :} +-- +-- Create an 'Unfold' from the step function: +-- +-- >>> u = Unfold.unfoldr f +-- +-- Run the 'Unfold': +-- +-- >>> Stream.fold Fold.toList $ Stream.unfold u [1,2,3] +-- [1,2,3] +-- +-- The 'Unfold.unfoldr' smart constructor is essentially the same as the list +-- "Data.List.unfoldr" function. We can use the same step function in both:: +-- +-- >>> Data.List.unfoldr f [1,2,3] +-- [1,2,3] +-- +-- == Unfolds vs. Streams +-- +-- The 'Unfold' abstraction for representing streams was introduced in Streamly +-- to provide C like performance for nested looping of streams. 'Unfold' and +-- 'Stream' abstractions are similar with the following differences: +-- +-- * 'Stream' is less efficient than 'Unfold' for nesting. +-- * 'Stream' is more powerful than 'Unfold'. +-- * 'Stream' API is more convenient for programming +-- +-- Unfolds can be easily converted to streams using 'Stream.unfold', however, +-- vice versa is not possible. To provide a familiar analogy, 'Unfold' is to +-- 'Stream' as 'Applicative' is to 'Monad'. +-- +-- To demonstrate the efficiency of unfolds, the nested loop example in the +-- previous section can be implemented with concatMap or Monad instance of +-- streams as follows: +-- +-- @ +-- do +-- x <- Stream.unfold Unfold.fromList [1,2,3] +-- y <- Stream.unfold Unfold.fromList [4,5,6] +-- return (x, y) +-- @ +-- +-- As you can see, this is more convenient to write than using the 'crossWith' +-- unfold combinator. However, this turns out to be many times slower than the +-- unfold implementation. The Unfold version is equivalent in performance to +-- the C implementation of the same nested loop. Similarly, unfolds can be +-- nested with streams using the 'unfoldMany' combinator which is a much more +-- efficient alternative to the 'concatMap' operation. +-- +-- Streams use a hybrid implementation approach using direct style as well as +-- CPS. Unfolds do not use CPS, therefore, lack the power that is afforded to +-- streams by CPS. The CPS implementation allows infinitely scalable @cons@ and +-- @append@ operations in streams. It is also used to implement concurrency in +-- streams. +-- +-- To summarize, unfolds are a high performance solution to the nesting +-- problem. Since streams provide a more palatable API for programming, work +-- with streams unless you need unfolds for better performance in nesting +-- situations. There is little difference in the way in which unfolds and +-- streams are written, it is easy to adapt a stream to an unfold. If you are +-- writing an unfold you can convert it to stream for free using +-- 'Stream.unfold'. diff --git a/src/Streamly/FileSystem/Dir.hs b/src/Streamly/FileSystem/Dir.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/FileSystem/Dir.hs @@ -0,0 +1,23 @@ +-- | +-- Module : Streamly.FileSystem.Dir +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : pre-release +-- Portability : GHC +-- +-- Warning\: The API of this module is subject to change in future releases. +-- Especially the type for representing paths may change from 'FilePath' to +-- something else. + +module Streamly.FileSystem.Dir + ( + -- * Streams + read + , readEither + ) +where + +import Streamly.Internal.FileSystem.Dir +import Prelude hiding (read) diff --git a/src/Streamly/FileSystem/File.hs b/src/Streamly/FileSystem/File.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/FileSystem/File.hs @@ -0,0 +1,60 @@ +-- | +-- Module : Streamly.FileSystem.File +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : pre-release +-- Portability : GHC +-- +-- Warning\: The API of this module is subject to change in future releases. +-- Especially the type for representing paths may change from 'FilePath' to +-- something else. +-- +-- Read and write streams and arrays to and from files specified by their paths +-- in the file system. Unlike the handle based APIs which can have a read/write +-- session consisting of multiple reads and writes to the handle, these APIs +-- are one shot read or write APIs. These APIs open the file handle, perform +-- the requested operation and close the handle. These are safer compared to +-- the handle based APIs as there is no possibility of a file descriptor +-- leakage. +-- +-- >>> import qualified Streamly.FileSystem.File as File +-- +module Streamly.FileSystem.File + ( + -- * 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 + + -- ** Folds + , write + , writeWith + , writeChunks + ) +where + +import Streamly.Internal.FileSystem.File +import Prelude hiding (read) diff --git a/src/Streamly/FileSystem/Handle.hs b/src/Streamly/FileSystem/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/FileSystem/Handle.hs @@ -0,0 +1,131 @@ +#include "inline.hs" + +-- | +-- Module : Streamly.FileSystem.Handle +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- >>> import qualified Streamly.FileSystem.Handle as Handle +-- +-- Read and write byte streams and array streams to and from file handles +-- ('Handle'). +-- +-- The 'TextEncoding', 'NewLineMode', and 'Buffering' 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 +-- the input stream on any other type of boundaries. +-- +-- To set the read or write start position use 'hSeek' on the 'Handle', the +-- 'Streamly.Data.Stream.before' combinator may be used to do that on a +-- streaming combinator. To restrict the length of read or write use the stream +-- trimming operations like 'Streamly.Data.Stream.take'. +-- +-- Note that a 'Handle' is inherently stateful, therefore, we cannot use these +-- APIs from multiple threads without serialization; reading or writing in one +-- thread would affect the file position for other threads. +-- +-- For additional, experimental APIs take a look at +-- "Streamly.Internal.FileSystem.Handle" module. + +-- Design notes: +-- +-- By design, file handle IO APIs are quite similar to +-- "Streamly.Data.Array" read write APIs. In that regard, arrays can be +-- considered as in-memory files or files can be considered as on-disk arrays. +-- +module Streamly.FileSystem.Handle + ( + -- * Singleton IO + -- | Read or write a single buffer. + getChunk + , putChunk + + -- * Streaming IO + -- | Read or write a stream of data to or from a file or device + -- sequentially. + -- + -- Read requests to the IO device are performed in chunks limited to a + -- maximum size of 'Streamly.Internal.System.IO.defaultChunkSize'. Note + -- that the size of the actual chunks in the resulting stream may be less + -- than the @defaultChunkSize@ but it can never exceed it. If the whole + -- stream is not consumed, it is possible that we may have read slightly + -- more from the IO device than what the consumer needed. + -- + -- Unless specified otherwise in the API, writes are collected into chunks + -- of 'Streamly.Internal.System.IO.defaultChunkSize' before they are + -- written to the IO device. + + -- Internal notes: + -- + -- 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. + + -- ** Reading + -- | 'TextEncoding', 'NewLineMode', and 'Buffering' options of the + -- underlying handle are ignored. The read occurs from the current seek + -- position of the file handle. The stream ends as soon as EOF is + -- encountered. + + -- -- *** Streams + -- , read + -- , readWith + -- , readChunks + -- , readChunksWith + + -- -- *** Unfolds + , reader + , readerWith + , chunkReader + , chunkReaderWith + + -- ** Folds + -- | 'TextEncoding', 'NewLineMode', and 'Buffering' options of the + -- underlying handle are ignored. The write occurs from the current seek + -- position of the file handle. The write behavior depends on the 'IOMode' + -- of the handle. + + , write + , writeWith + , 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 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 diff --git a/src/Streamly/Internal/BaseCompat.hs b/src/Streamly/Internal/BaseCompat.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/BaseCompat.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Streamly.Internal.BaseCompat +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Compatibility functions for "base" package. +-- +module Streamly.Internal.BaseCompat + ( + (#.) + , unsafeWithForeignPtr + ) +where + +import Data.Coerce (Coercible, coerce) +import GHC.ForeignPtr (ForeignPtr(..)) +import GHC.Ptr (Ptr(..)) + +#if MIN_VERSION_base(4,15,0) +import qualified GHC.ForeignPtr as GHCForeignPtr +#else +import Foreign.ForeignPtr (withForeignPtr) +#endif + + +{-# INLINE (#.) #-} +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce + +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +#if MIN_VERSION_base(4,15,0) +unsafeWithForeignPtr = GHCForeignPtr.unsafeWithForeignPtr +#else +unsafeWithForeignPtr = withForeignPtr +#endif diff --git a/src/Streamly/Internal/Console/Stdio.hs b/src/Streamly/Internal/Console/Stdio.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Console/Stdio.hs @@ -0,0 +1,228 @@ +-- | +-- Module : Streamly.Internal.Console.Stdio +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Console.Stdio + ( + -- * Streams + read + , readChars + , 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 + + -- * Unfolds + , reader + , chunkReader + + -- * Folds + , write + , writeChunks + , writeErr + , writeErrChunks + + -- * Stream writes + , putBytes -- Buffered (32K) + , putChars + , putChunks -- Unbuffered + , putStringsWith + , putStrings + , putStringsLn + ) +where + +#include "inline.hs" + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Word (Word8) +import System.IO (stdin, stdout, stderr) +import Prelude hiding (read) + +import Streamly.Internal.Data.Array.Type (Array(..)) +import Streamly.Internal.Data.Stream.StreamD (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.Unfold as Unfold +import qualified Streamly.Internal.FileSystem.Handle as Handle +import qualified Streamly.Internal.Unicode.Stream as Unicode + +------------------------------------------------------------------------------- +-- Reads +------------------------------------------------------------------------------- + +-- | Unfold standard input into a stream of 'Word8'. +-- +{-# INLINE reader #-} +reader :: MonadIO m => Unfold m () Word8 +reader = Unfold.lmap (\() -> stdin) Handle.reader + +-- | Read a byte stream from standard input. +-- +-- > read = Handle.read stdin +-- > read = Stream.unfold Stdio.reader () +-- +-- /Pre-release/ +-- +{-# INLINE read #-} +read :: MonadIO m => Stream m Word8 +read = Handle.read stdin + +-- | Read a character stream from Utf8 encoded standard input. +-- +-- > readChars = Unicode.decodeUtf8 Stdio.read +-- +-- /Pre-release/ +-- +{-# INLINE readChars #-} +readChars :: MonadIO m => Stream m Char +readChars = Unicode.decodeUtf8 read + +-- | Unfolds standard input into a stream of 'Word8' arrays. +-- +{-# INLINE chunkReader #-} +chunkReader :: MonadIO m => Unfold m () (Array Word8) +chunkReader = Unfold.lmap (\() -> stdin) Handle.chunkReader + +-- | Read a stream of chunks from standard input. The maximum size of a single +-- chunk is limited to @defaultChunkSize@. The actual size read may be less +-- than @defaultChunkSize@. +-- +-- > readChunks = Handle.readChunks stdin +-- > readChunks = Stream.unfold Stdio.chunkReader () +-- +-- /Pre-release/ +-- +{-# INLINE readChunks #-} +readChunks :: MonadIO m => Stream m (Array Word8) +readChunks = Handle.readChunks stdin + +{- +-- | Read UTF8 encoded lines from standard input. +-- +-- You may want to process the input byte stream directly using appropriate +-- folds for more efficient processing. +-- +-- /Pre-release/ +-- +{-# INLINE getChunksLn #-} +getChunksLn :: MonadIO m => Stream m (Array Word8) +getChunksLn = (Stream.splitWithSuffix (== '\n') f) getChars + + -- XXX Need to implement Fold.unfoldMany, should be easy for + -- non-terminating folds, but may be tricky for terminating folds. See + -- Array Stream folds. + where f = Fold.unfoldMany Unicode.readCharUtf8 Array.write +-} + +------------------------------------------------------------------------------- +-- Writes +------------------------------------------------------------------------------- + +-- | Fold a stream of 'Word8' to standard output. +-- +{-# INLINE write #-} +write :: MonadIO m => Fold m Word8 () +write = Handle.write stdout + +-- | Fold a stream of 'Word8' to standard error. +-- +{-# INLINE writeErr #-} +writeErr :: MonadIO m => Fold m Word8 () +writeErr = Handle.write stderr + +-- | Write a stream of bytes to standard output. +-- +-- > putBytes = Handle.putBytes stdout +-- > putBytes = Stream.fold Stdio.write +-- +-- /Pre-release/ +-- +{-# INLINE putBytes #-} +putBytes :: MonadIO m => Stream m Word8 -> m () +putBytes = Handle.putBytes stdout + +-- | Encode a character stream to Utf8 and write it to standard output. +-- +-- > putChars = Stdio.putBytes . Unicode.encodeUtf8 +-- +-- /Pre-release/ +-- +{-# INLINE putChars #-} +putChars :: MonadIO m => Stream m Char -> m () +putChars = putBytes . Unicode.encodeUtf8 + +-- | Fold a stream of @Array Word8@ to standard output. +-- +{-# INLINE writeChunks #-} +writeChunks :: MonadIO m => Fold m (Array Word8) () +writeChunks = Handle.writeChunks stdout + +-- | Fold a stream of @Array Word8@ to standard error. +-- +{-# INLINE writeErrChunks #-} +writeErrChunks :: MonadIO m => Fold m (Array Word8) () +writeErrChunks = Handle.writeChunks stderr + +-- | Write a stream of chunks to standard output. +-- +-- > putChunks = Handle.putChunks stdout +-- > putChunks = Stream.fold Stdio.writeChunks +-- +-- /Pre-release/ +-- +{-# INLINE putChunks #-} +putChunks :: MonadIO m => Stream m (Array Word8) -> m () +putChunks = Handle.putChunks stdout + +------------------------------------------------------------------------------- +-- Line buffered +------------------------------------------------------------------------------- + +-- XXX We need to write transformations as pipes so that they can be applied to +-- 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. +-- +-- /Pre-release/ +-- +{-# INLINE putStringsWith #-} +putStringsWith :: MonadIO m + => (Stream m Char -> Stream m Word8) -> Stream m String -> m () +putStringsWith encode = putChunks . Unicode.encodeStrings encode + +-- | Write a stream of strings to standard output using UTF8 encoding. Output +-- is flushed to the device for each string. +-- +-- /Pre-release/ +-- +{-# INLINE putStrings #-} +putStrings :: MonadIO m => Stream m String -> m () +putStrings = putStringsWith Unicode.encodeUtf8 + +-- | Like 'putStrings' but adds a newline at the end of each string. +-- +-- XXX This is not portable, on Windows we need to use "\r\n" instead. +-- +-- /Pre-release/ +-- +{-# INLINE putStringsLn #-} +putStringsLn :: MonadIO m => Stream m String -> m () +putStringsLn = + putChunks + . Stream.intersperseMSuffix (return $ Array.fromList [10]) + . Unicode.encodeStrings Unicode.encodeUtf8 diff --git a/src/Streamly/Internal/Control/Exception.hs b/src/Streamly/Internal/Control/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Control/Exception.hs @@ -0,0 +1,38 @@ +-- | +-- Module : Streamly.Internal.Control.Exception +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Additional "Control.Exception" utilities. + +module Streamly.Internal.Control.Exception + ( verify + , verifyM + ) +where + +-- | Like 'assert' but is not removed by the compiler, it is always present in +-- production code. +-- +-- /Pre-release/ +-- +{-# INLINE verify #-} +verify :: Bool -> a -> a +verify predicate val = + if predicate + -- XXX it would be nice if we can print the predicate expr. + then error "verify failed" + else val + +-- Like 'verify' but returns @()@ in an 'Applicative' context so that it can be +-- used as an independent statement in a @do@ block. +-- +-- /Pre-release/ +-- +{-# INLINE verifyM #-} +verifyM :: Applicative f => Bool -> f () +verifyM predicate = verify predicate (pure ()) diff --git a/src/Streamly/Internal/Control/ForkIO.hs b/src/Streamly/Internal/Control/ForkIO.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Control/ForkIO.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- | +-- Module : Streamly.Internal.Control.ForkIO +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Control.ForkIO + ( rawForkIO + , forkIOManaged + , forkManagedWith + ) +where + +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Monad.IO.Class (MonadIO(..)) +import GHC.Conc (ThreadId(..)) +import GHC.Exts +import GHC.IO (IO(..)) +import System.Mem.Weak (addFinalizer) + +-- | Stolen from the async package. The perf improvement is modest, 2% on a +-- thread heavy benchmark (parallel composition using noop computations). +-- A version of forkIO that does not include the outer exception +-- handler: saves a bit of time when we will be installing our own +-- exception handler. +{-# INLINE rawForkIO #-} +rawForkIO :: IO () -> IO ThreadId +rawForkIO (IO action) = IO $ \ s -> + case fork# action s of (# s1, tid #) -> (# s1, ThreadId tid #) + +-- | Fork a thread that is automatically killed as soon as the reference to the +-- returned threadId is garbage collected. +-- +{-# INLINABLE forkManagedWith #-} +forkManagedWith :: MonadIO m => (m () -> m ThreadId) -> m () -> m ThreadId +forkManagedWith fork action = do + tid <- fork action + liftIO $ addFinalizer tid (killThread tid) + return tid + +-- | Fork a thread that is automatically killed as soon as the reference to the +-- returned threadId is garbage collected. +-- +{-# INLINABLE forkIOManaged #-} +forkIOManaged :: IO () -> IO ThreadId +forkIOManaged = forkManagedWith forkIO diff --git a/src/Streamly/Internal/Control/Monad.hs b/src/Streamly/Internal/Control/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Control/Monad.hs @@ -0,0 +1,26 @@ +-- | +-- Module : Streamly.Internal.Control.Monad +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Additional "Control.Monad" utilities. + +module Streamly.Internal.Control.Monad + ( discard + ) +where + +import Control.Monad (void) +import Control.Monad.Catch (MonadCatch, catch, SomeException) + +-- | Discard any exceptions or value returned by an effectful action. +-- +-- /Pre-release/ +-- +{-# INLINE discard #-} +discard :: MonadCatch m => m b -> m () +discard action = void action `catch` (\(_ :: SomeException) -> return ()) diff --git a/src/Streamly/Internal/Data/Array.hs b/src/Streamly/Internal/Data/Array.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array.hs @@ -0,0 +1,573 @@ +{-# LANGUAGE CPP #-} +-- | +-- 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) diff --git a/src/Streamly/Internal/Data/Array/ArrayMacros.h b/src/Streamly/Internal/Data/Array/ArrayMacros.h new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/ArrayMacros.h @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------- +-- Macros to access Storable pointers +------------------------------------------------------------------------------- + +-- The Storable instance of () has size 0. We ensure that the size is non-zero +-- to avoid a zero sized element and issues due to that. +-- See https://mail.haskell.org/pipermail/libraries/2022-January/thread.html +-- +-- XXX Check the core to see if max can be statically eliminated. llvm can +-- eliminate the comparison, but not sure if GHC NCG can. +#define STORABLE_SIZE_OF(a) max 1 (sizeOf (undefined :: a)) + +-- Move the pointer to ith element of specified type. Type is specified as the +-- type variable in the signature of the function where this macro is used. +#define PTR_NEXT(ptr,a) ptr `plusPtr` STORABLE_SIZE_OF(a) +#define PTR_PREV(ptr,a) ptr `plusPtr` negate (STORABLE_SIZE_OF(a)) + +#define PTR_INDEX(ptr,i,a) ptr `plusPtr` (STORABLE_SIZE_OF(a) * i) +#define PTR_RINDEX(ptr,i,a) ptr `plusPtr` negate (STORABLE_SIZE_OF(a) * (i + 1)) + +-- XXX If we know that the array is guaranteed to have size multiples of the +-- element size then we can use a simpler check saying "ptr < end". Since we +-- always allocate in multiples of elem we can use the simpler check and assert +-- the rigorous check. +#define PTR_VALID(ptr,end,a) ptr `plusPtr` STORABLE_SIZE_OF(a) <= end +#define PTR_INVALID(ptr,end,a) ptr `plusPtr` STORABLE_SIZE_OF(a) > end + +------------------------------------------------------------------------------- +-- Macros to access array indices (using Unbox type class) +------------------------------------------------------------------------------- + +-- This macro was originally defined as a wrapper to sizeOf so that we can +-- avoid a sizeOf value of 0 and make it 1. +#define SIZE_OF(a) sizeOf (Proxy :: Proxy a) + +#define INDEX_NEXT(i,a) i + SIZE_OF(a) +#define INDEX_PREV(i,a) i - SIZE_OF(a) + +#define INDEX_OF(base,i,a) base + (SIZE_OF(a) * i) +#define RINDEX_OF(base,i,a) base - (SIZE_OF(a) * (i + 1)) + +#define INDEX_VALID(i,end,a) i + SIZE_OF(a) <= end +#define INDEX_INVALID(i,end,a) i + SIZE_OF(a) > end diff --git a/src/Streamly/Internal/Data/Array/Generic.hs b/src/Streamly/Internal/Data/Array/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/Generic.hs @@ -0,0 +1,281 @@ +-- | +-- Module : Streamly.Internal.Data.Array.Generic +-- Copyright : (c) 2019 Composewell Technologies +-- +-- 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 + + -- * Random Access + , getIndexUnsafe + , getSliceUnsafe + , strip + ) +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) + +{-# INLINE_NORMAL read #-} +read :: Monad m => Array a -> Stream m a +read arr@Array{..} = + D.map (`getIndexUnsafe` arr) $ D.enumerateFromToIntegral 0 (arrLen - 1) + +{-# 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 + +------------------------------------------------------------------------------- +-- 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 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 + +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 diff --git a/src/Streamly/Internal/Data/Array/Generic/Mut/Type.hs b/src/Streamly/Internal/Data/Array/Generic/Mut/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/Generic/Mut/Type.hs @@ -0,0 +1,796 @@ +{-# 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/Mut.hs b/src/Streamly/Internal/Data/Array/Mut.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/Mut.hs @@ -0,0 +1,86 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/Mut/Stream.hs @@ -0,0 +1,323 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/Mut/Type.hs @@ -0,0 +1,2356 @@ +{-# 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/Type.hs b/src/Streamly/Internal/Data/Array/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/Type.hs @@ -0,0 +1,592 @@ +{-# 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 = (<>) diff --git a/src/Streamly/Internal/Data/Builder.hs b/src/Streamly/Internal/Data/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Builder.hs @@ -0,0 +1,80 @@ +-- | +-- Module : Streamly.Internal.Data.Builder +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Builder + ( + -- * Imports + -- $setup + + -- * Types + Builder (..) + ) +where + +import Control.Applicative (liftA2) + +------------------------------------------------------------------------------ +-- The Builder type +------------------------------------------------------------------------------ + +-- | A simple stateful function composing monad that chains state passing +-- functions. This can be considered as a simplified version of the State monad +-- 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)) + +-- | 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) + +{-# INLINE fromPure #-} +fromPure :: Applicative m => b -> Builder s m b +fromPure b = Builder (\s -> pure (s, b)) + +-- | Chain the actions and zip the outputs. +{-# INLINE sequenceWith #-} +sequenceWith :: Monad m => + (a -> b -> c) -> Builder x m a -> Builder x m b -> Builder x m c +sequenceWith func (Builder stepL) (Builder stepR) = Builder step + + where + + step s = do + (s1, x) <- stepL s + (s2, y) <- stepR s1 + pure (s2, func x y) + +instance Monad m => Applicative (Builder a m) where + {-# INLINE pure #-} + pure = fromPure + + {-# INLINE (<*>) #-} + (<*>) = sequenceWith id + + {-# INLINE (*>) #-} + (*>) = sequenceWith (const id) + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + +instance Monad m => Monad (Builder a m) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + (Builder stepL) >>= f = Builder step + + where + + step s = do + (s1, x) <- stepL s + let Builder stepR = f x + (s2, y) <- stepR s1 + pure (s2, y) diff --git a/src/Streamly/Internal/Data/Either/Strict.hs b/src/Streamly/Internal/Data/Either/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Either/Strict.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Streamly.Internal.Data.Either.Strict +-- Copyright : (c) 2019 Composewell Technologies +-- (c) 2013 Gabriel Gonzalez +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- | Strict data types to be used as accumulator for strict left folds and +-- scans. For more comprehensive strict data types see +-- https://hackage.haskell.org/package/strict-base-types . The names have been +-- suffixed by a prime so that programmers can easily distinguish the strict +-- versions from the lazy ones. +-- +-- One major advantage of strict data structures as accumulators in folds and +-- scans is that it helps the compiler optimize the code much better by +-- unboxing. In a big tight loop the difference could be huge. +-- +module Streamly.Internal.Data.Either.Strict + ( Either' (..) + -- XXX Remove these and add lazyEither/strictEither to convert to and from + -- lazy Either type. + , isLeft' + , isRight' + , fromLeft' + , fromRight' + ) +where + +-- | A strict 'Either' +data Either' a b = Left' !a | Right' !b deriving Show + +-- | Return 'True' if the given value is a Left', 'False' otherwise. +{-# INLINABLE isLeft' #-} +isLeft' :: Either' a b -> Bool +isLeft' (Left' _) = True +isLeft' (Right' _) = False + +-- | Return 'True' if the given value is a Right', 'False' otherwise. +{-# INLINABLE isRight' #-} +isRight' :: Either' a b -> Bool +isRight' (Left' _) = False +isRight' (Right' _) = True + +-- XXX This is partial. We can use a default value instead. +-- | Return the contents of a Left'-value or errors out. +{-# INLINABLE fromLeft' #-} +fromLeft' :: Either' a b -> a +fromLeft' (Left' a) = a +fromLeft' _ = error "fromLeft' expecting a Left'-value" + +-- | Return the contents of a Right'-value or errors out. +{-# INLINABLE fromRight' #-} +fromRight' :: Either' a b -> b +fromRight' (Right' b) = b +fromRight' _ = error "fromRight' expecting a Right'-value" diff --git a/src/Streamly/Internal/Data/Fold.hs b/src/Streamly/Internal/Data/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold.hs @@ -0,0 +1,2598 @@ +{-# 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" diff --git a/src/Streamly/Internal/Data/Fold/Chunked.hs b/src/Streamly/Internal/Data/Fold/Chunked.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Chunked.hs @@ -0,0 +1,377 @@ +-- | +-- Module : Streamly.Internal.Data.Fold.Chunked +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Use "Streamly.Data.Parser.Chunked" 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@. +-- +-- Though @Fold m a b@ in this module works on a stream of @Array a@ it is +-- different from @Data.Fold m (Array a) b@. While the latter works on arrays +-- as a whole treating them as atomic elements, the folds in this module can +-- work on the stream of arrays as if it is an element stream with all the +-- arrays coalesced together. This module allows adapting the element stream +-- 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 +-- +-- >>> f = ChunkFold.fromFold (Fold.take 7 Fold.toList) +-- >>> s = Stream.chunksOf 5 $ Stream.fromList "hello world" +-- >>> ArrayStream.runArrayFold f (StreamK.fromStream s) +-- Right "hello w" +-- +module Streamly.Internal.Data.Fold.Chunked + ( + ChunkFold (..) + + -- * Construction + , fromFold + , adaptFold + , fromParser + , fromParserD + + -- * Mapping + , rmapM + + -- * Applicative + , fromPure + , fromEffect + , splitWith + + -- * Monad + , concatMap + + -- * Combinators + , take + ) +where + +#include "ArrayMacros.h" + +import Control.Applicative (liftA2) +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 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.Tuple.Strict (Tuple'(..)) + +import qualified Streamly.Internal.Data.Array 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 Parser + +import Prelude hiding (concatMap, take) + +-- | Array stream fold. +-- +-- An array stream fold is basically an array stream "Parser" that does not +-- fail. In case of array stream folds the count in 'Partial', 'Continue' and +-- 'Done' is a count of elements that includes the leftover element count in +-- the array that is currently being processed by the parser. If none of the +-- elements is consumed by the parser the count is at least the whole array +-- length. If the whole array is consumed by the parser then the count will be +-- 0. +-- +-- /Pre-release/ +-- +newtype ChunkFold m a b = ChunkFold (ParserD.Parser (Array a) m b) + +------------------------------------------------------------------------------- +-- Constructing array stream folds from element folds and parsers +------------------------------------------------------------------------------- + +-- | Convert an element 'Fold' into an array stream fold. +-- +-- /Pre-release/ +{-# 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)) + + where + + initial = do + res <- finitial + return + $ case res of + Fold.Partial s1 -> IPartial s1 + Fold.Done b -> IDone b + + step s (Array contents start end) = do + goArray SPEC start s + + where + + goArray !_ !cur !fs | cur >= end = do + assert (cur == end) (return ()) + return $ Partial 0 fs + goArray !_ !cur !fs = do + x <- liftIO $ peekWith contents cur + res <- fstep fs x + let elemSize = SIZE_OF(a) + next = INDEX_NEXT(cur,a) + case res of + Fold.Done b -> + return $ Done ((end - next) `div` elemSize) b + Fold.Partial fs1 -> + goArray SPEC next fs1 + +-- | Convert an element 'ParserD.Parser' into an array stream fold. If the +-- parser fails the fold would throw an exception. +-- +-- /Pre-release/ +{-# INLINE fromParserD #-} +fromParserD :: forall m a b. (MonadIO m, Unbox a) => + ParserD.Parser a m b -> ChunkFold m a b +fromParserD (ParserD.Parser step1 initial1 extract1) = + ChunkFold (ParserD.Parser step initial1 extract1) + + where + + step s (Array contents start end) = do + if start >= end + then return $ Continue 0 s + else goArray SPEC start s + + where + + {-# INLINE partial #-} + partial arrRem cur next elemSize st n fs1 = do + let next1 = next - (n * elemSize) + if next1 >= start && cur < end + then goArray SPEC next1 fs1 + else return $ st (arrRem + n) fs1 + + goArray !_ !cur !fs = do + x <- liftIO $ peekWith contents cur + liftIO $ touch contents + res <- step1 fs x + let elemSize = SIZE_OF(a) + next = INDEX_NEXT(cur,a) + arrRem = (end - next) `div` elemSize + case res of + ParserD.Done n b -> do + return $ Done (arrRem + n) b + ParserD.Partial n fs1 -> + 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 + +-- | Convert an element 'Parser.Parser' into an array stream fold. If the +-- parser fails the fold would throw an exception. +-- +-- /Pre-release/ +{-# INLINE fromParser #-} +fromParser :: forall m a b. (MonadIO m, Unbox a) => + Parser.Parser a m b -> ChunkFold m a b +fromParser = fromParserD + +-- | Adapt an array stream fold. +-- +-- /Pre-release/ +{-# INLINE adaptFold #-} +adaptFold :: forall m a b. (MonadIO m) => + Fold.Fold m (Array a) b -> ChunkFold m a b +adaptFold f = ChunkFold $ ParserD.fromFold f + +------------------------------------------------------------------------------- +-- Functor +------------------------------------------------------------------------------- + +-- | Maps a function over the result of fold. +-- +-- /Pre-release/ +instance Functor m => Functor (ChunkFold m a) where + {-# INLINE fmap #-} + fmap f (ChunkFold p) = ChunkFold $ fmap f p + +-- | Map a monadic function on the output of a fold. +-- +-- /Pre-release/ +{-# INLINE rmapM #-} +rmapM :: Monad m => (b -> m c) -> ChunkFold m a b -> ChunkFold m a c +rmapM f (ChunkFold p) = ChunkFold $ ParserD.rmapM f p + +------------------------------------------------------------------------------- +-- Sequential applicative +------------------------------------------------------------------------------- + +-- | A fold that always yields a pure value without consuming any input. +-- +-- /Pre-release/ +-- +{-# INLINE fromPure #-} +fromPure :: Monad m => b -> ChunkFold m a b +fromPure = ChunkFold . ParserD.fromPure + +-- | A fold that always yields the result of an effectful action without +-- consuming any input. +-- +-- /Pre-release/ +-- +{-# INLINE fromEffect #-} +fromEffect :: Monad m => m b -> ChunkFold m a b +fromEffect = ChunkFold . ParserD.fromEffect + +-- | Applies two folds sequentially on the input stream and combines their +-- results using the supplied function. +-- +-- /Pre-release/ +{-# INLINE split_ #-} +split_ :: Monad m => + ChunkFold m x a -> ChunkFold m x b -> ChunkFold m x b +split_ (ChunkFold p1) (ChunkFold p2) = + ChunkFold $ ParserD.noErrorUnsafeSplit_ p1 p2 + +-- | Applies two folds sequentially on the input stream and combines their +-- results using the supplied function. +-- +-- /Pre-release/ +{-# INLINE splitWith #-} +splitWith :: Monad m + => (a -> b -> c) -> ChunkFold m x a -> ChunkFold m x b -> ChunkFold m x c +splitWith f (ChunkFold p1) (ChunkFold p2) = + ChunkFold $ ParserD.noErrorUnsafeSplitWith f p1 p2 + +-- | 'Applicative' form of 'splitWith'. +-- > (<*>) = splitWith id +instance Monad m => Applicative (ChunkFold m a) where + {-# INLINE pure #-} + pure = fromPure + + {-# INLINE (<*>) #-} + (<*>) = splitWith id + + {-# INLINE (*>) #-} + (*>) = split_ + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + +------------------------------------------------------------------------------- +-- Monad +------------------------------------------------------------------------------- + +-- XXX This should be implemented using CPS +-- +-- | Applies a fold on the input stream, generates the next fold from the +-- output of the previously applied fold and then applies that fold. +-- +-- /Pre-release/ +-- +{-# INLINE concatMap #-} +concatMap :: Monad m => + (b -> ChunkFold m a c) -> ChunkFold m a b -> ChunkFold m a c +concatMap func (ChunkFold p) = + let f x = let ChunkFold y = func x in y + in ChunkFold $ ParserD.noErrorUnsafeConcatMap f p + +-- | Monad instance applies folds sequentially. Next fold can depend on the +-- output of the previous fold. See 'concatMap'. +-- +-- > (>>=) = flip concatMap +instance Monad m => Monad (ChunkFold m a) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + (>>=) = flip concatMap + + {-# INLINE (>>) #-} + (>>) = (*>) + +------------------------------------------------------------------------------- +-- Array to Array folds +------------------------------------------------------------------------------- + +-- | Take @n@ array elements (@a@) from a stream of arrays (@Array a@). +{-# INLINE take #-} +take :: forall m a b. (Monad m, Unbox a) => + Int -> ChunkFold m a b -> ChunkFold m a b +take n (ChunkFold (ParserD.Parser step1 initial1 extract1)) = + ChunkFold $ ParserD.Parser step initial extract + + where + + -- XXX Need to make the Initial type Step to remove this + iextract s = do + r <- extract1 s + return $ case r of + Done _ b -> IDone b + Error err -> IError err + _ -> error "Bug: ChunkFold take invalid state in initial" + + initial = do + res <- initial1 + case res of + IPartial s -> + if n > 0 + then return $ IPartial $ Tuple' n s + else iextract s + IDone b -> return $ IDone b + IError err -> return $ IError err + + {-# INLINE partial #-} + partial i1 st j s = + let i2 = i1 + j + in if i2 > 0 + then return $ st j (Tuple' i2 s) + else do + -- 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" + + -- Tuple' (how many more items to take) (fold state) + step (Tuple' i r) arr = do + let len = Array.length arr + i1 = i - len + if i1 >= 0 + then do + res <- step1 r arr + case res of + 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 + else do + let !(Array contents start _) = arr + end = INDEX_OF(start,i,a) + -- Supply only the required slice of array + arr1 = Array contents start end + remaining = negate i1 -- i1 is negative here + res <- step1 r arr1 + case res of + Partial 0 s -> + ParserD.bimapOverrideCount + remaining (Tuple' 0) id <$> extract1 s + Partial j s -> return $ Partial (remaining + j) (Tuple' j s) + Continue 0 s -> + ParserD.bimapOverrideCount + 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 + + extract (Tuple' i r) = first (Tuple' i) <$> extract1 r diff --git a/src/Streamly/Internal/Data/Fold/Container.hs b/src/Streamly/Internal/Data/Fold/Container.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Container.hs @@ -0,0 +1,704 @@ +-- | +-- Module : Streamly.Internal.Data.Fold.Container +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Streamly.Internal.Data.Fold.Container + ( + -- * Imports + -- $setup + + -- * Set operations + toSet + , toIntSet + , countDistinct + , countDistinctInt + , nub + , nubInt + + -- * Map operations + , frequency + + -- ** Demultiplexing + -- | 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. + , demuxKvToContainer + , demuxKvToMap + + , demuxToContainer + , demuxToContainerIO + , demuxToMap + , demuxToMapIO + + , 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 fold. + -- + -- 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 (length) +import Streamly.Internal.Data.Fold + +-- $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 + +-- | Fold the input to a set. +-- +-- Definition: +-- +-- >>> toSet = Fold.foldl' (flip Set.insert) Set.empty +-- +{-# INLINE toSet #-} +toSet :: (Monad m, Ord a) => Fold m a (Set a) +toSet = foldl' (flip Set.insert) Set.empty + +-- | Fold the input to an int set. For integer inputs this performs better than +-- 'toSet'. +-- +-- Definition: +-- +-- >>> toIntSet = Fold.foldl' (flip IntSet.insert) IntSet.empty +-- +{-# INLINE toIntSet #-} +toIntSet :: Monad m => Fold m Int IntSet +toIntSet = foldl' (flip IntSet.insert) IntSet.empty + +-- XXX Name as nubOrd? Or write a nubGeneric + +-- | Used as a scan. 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.fold Fold.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) + +-- | 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) + +-- 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 Fold.toSet +-- >>> countDistinct = Fold.postscan Fold.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 +-- terminate if the count reaches more than a threshold. +-- +-- /Space/: \(\mathcal{O}(n)\) +-- +-- /Pre-release/ +-- +{-# INLINE countDistinct #-} +countDistinct :: (Monad m, Ord a) => Fold 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 Fold.toIntSet +-- >>> countDistinctInt = Fold.postscan Fold.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 = 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. +-- +-- 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. + +{-# 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 + + where + + initial = return $ Tuple' IsMap.mapEmpty Nothing + + {-# INLINE runFold #-} + runFold kv (Fold step1 initial1 extract1) (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 + 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)) + + step (Tuple' kv _) a = do + let k = getKey a + case IsMap.mapLookup k kv of + Nothing -> do + fld <- getFold a + runFold kv fld (k, a) + Just f -> runFold kv f (k, a) + + extract (Tuple' kv x) = (Prelude.mapM f kv, x) + + where + + f (Fold _ i e) = do + r <- i + case r of + Partial s -> e s + Done b -> return b + +-- | 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. +-- +-- This can be used to scan a stream and collect the results from the scan +-- output. +-- +-- /Pre-release/ +-- +{-# INLINE demux #-} +demux :: (Monad m, Ord k) => + (a -> k) + -> (a -> m (Fold m a b)) + -> Fold m a (m (Map k b), Maybe (k, b)) +demux = demuxGeneric + +{-# 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 + + where + + initial = return $ Tuple' IsMap.mapEmpty Nothing + + {-# INLINE initFold #-} + initFold kv (Fold step1 initial1 extract1) (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 + 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 + res <- initial1 + case res of + Partial s -> do + res1 <- step1 s a + case res1 of + Partial _ -> do + let fld = Fold step1 (return res1) extract1 + 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 + f <- getFold a + initFold kv f (k, a) + Just ref -> do + f <- liftIO $ readIORef ref + runFold kv ref f (k, a) + + extract (Tuple' kv x) = (Prelude.mapM f kv, x) + + where + + f ref = do + (Fold _ i e) <- liftIO $ readIORef ref + r <- i + case r of + Partial s -> e s + Done b -> return b + +-- | This is specialized version of 'demux' that uses mutable IO cells as +-- fold accumulators for better performance. +-- +{-# INLINE demuxIO #-} +demuxIO :: (MonadIO m, Ord k) => + (a -> k) + -> (a -> m (Fold m a b)) + -> Fold m a (m (Map k b), Maybe (k, b)) +demuxIO = demuxGenericIO + +{-# INLINE demuxToContainer #-} +demuxToContainer :: (Monad m, IsMap f, Traversable f) => + (a -> Key f) -> (a -> m (Fold m a b)) -> Fold 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) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) +demuxToMap = demuxToContainer + +{-# INLINE demuxToContainerIO #-} +demuxToContainerIO :: (MonadIO m, IsMap f, Traversable f) => + (a -> Key f) -> (a -> m (Fold m a b)) -> Fold 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) -> (a -> m (Fold m a b)) -> Fold m a (Map k b) +demuxToMapIO = demuxToContainerIO + +{-# 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)) + +-- | 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 (Fold m a b)) -> Fold 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. + +{-# 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) -> 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 + + 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) = (Prelude.mapM extract1 kv, x) + +-- | 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 +-- the in-progress folds. +-- +-- Once the fold for a key is done, any future values of the key are ignored. +-- +-- Definition: +-- +-- >>> classify f fld = Fold.demux f (const fld) +-- +{-# 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 + +-- 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 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 + + 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) = + (Prelude.mapM (\ref -> liftIO (readIORef ref) >>= extract1) kv, x) + +-- | 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) +-- +{-# 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 toContainer #-} +toContainer :: (Monad m, IsMap f, Traversable f, Ord (Key f)) => + (a -> Key f) -> Fold m a b -> Fold 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) -> 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) +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) -> Fold m a b -> Fold 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) => Fold m a b -> Fold 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) => Fold m a (Map a Int) +frequency = toMap id length diff --git a/src/Streamly/Internal/Data/Fold/Step.hs b/src/Streamly/Internal/Data/Fold/Step.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Step.hs @@ -0,0 +1,83 @@ +-- | +-- Module : Streamly.Internal.Data.Fold.Step +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Fold.Step + ( + -- * Types + Step (..) + + , mapMStep + , chainStepM + ) +where + +import Data.Bifunctor (Bifunctor(..)) +import Fusion.Plugin.Types (Fuse(..)) + +------------------------------------------------------------------------------ +-- Step of a fold +------------------------------------------------------------------------------ + +-- The Step functor around b allows expressing early termination like a right +-- fold. Traditional list right folds use function composition and laziness to +-- terminate early whereas we use data constructors. It allows stream fusion in +-- contrast to the foldr/build fusion when composing with functions. + +-- | 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. +-- 'Done' returns the final result and the fold cannot be driven further. +-- +-- /Pre-release/ +-- +{-# ANN type Step Fuse #-} +data Step s b + = Partial !s + | Done !b + +-- | 'first' maps over 'Partial' and 'second' maps over 'Done'. +-- +instance Bifunctor Step where + {-# INLINE bimap #-} + bimap f _ (Partial a) = Partial (f a) + bimap _ g (Done b) = Done (g b) + + {-# INLINE first #-} + first f (Partial a) = Partial (f a) + first _ (Done x) = Done x + + {-# INLINE second #-} + second _ (Partial x) = Partial x + second f (Done a) = Done (f a) + +-- | 'fmap' maps over 'Done'. +-- +-- @ +-- fmap = 'second' +-- @ +-- +instance Functor (Step s) where + {-# INLINE fmap #-} + fmap = second + +-- | 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 s -> pure $ Partial s + Done b -> Done <$> f b + +-- | If 'Partial' then map the state, if 'Done' then call the next step. +{-# INLINE chainStepM #-} +chainStepM :: Applicative m => + (s1 -> m s2) -> (a -> m (Step s2 b)) -> Step s1 a -> m (Step s2 b) +chainStepM f _ (Partial s) = Partial <$> f s +chainStepM _ g (Done b) = g b diff --git a/src/Streamly/Internal/Data/Fold/Tee.hs b/src/Streamly/Internal/Data/Fold/Tee.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Tee.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Fold.Tee +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A newtype wrapper over the 'Fold' type providing distributing 'Applicative', +-- 'Semigroup', 'Monoid', 'Num', 'Floating' and 'Fractional' instances. +-- +module Streamly.Internal.Data.Fold.Tee + ( Tee(..) + , toFold + ) +where + +import Control.Applicative (liftA2) +import Streamly.Internal.Data.Fold.Type (Fold) + +import qualified Streamly.Internal.Data.Fold.Type as Fold + +#include "DocTestDataFold.hs" + +-- | @Tee@ is a newtype wrapper over the 'Fold' type providing distributing +-- 'Applicative', 'Semigroup', 'Monoid', 'Num', 'Floating' and 'Fractional' +-- instances. +-- +-- The input received by the composed 'Tee' is replicated and distributed to +-- the constituent folds of the 'Tee'. +-- +-- For example, to compute the average of numbers in a stream without going +-- through the stream twice: +-- +-- >>> avg = (/) <$> (Tee Fold.sum) <*> (Tee $ fmap fromIntegral Fold.length) +-- >>> Stream.fold (unTee avg) $ Stream.fromList [1.0..100.0] +-- 50.5 +-- +-- Similarly, the 'Semigroup' and 'Monoid' instances of 'Tee' distribute the +-- input to both the folds and combine the outputs using Monoid or Semigroup +-- instances of the output types: +-- +-- >>> import Data.Monoid (Sum(..)) +-- >>> t = Tee Fold.one <> Tee Fold.latest +-- >>> Stream.fold (unTee t) (fmap Sum $ Stream.enumerateFromTo 1.0 100.0) +-- Just (Sum {getSum = 101.0}) +-- +-- The 'Num', 'Floating', and 'Fractional' instances work in the same way. +-- +newtype Tee m a b = + Tee { unTee :: Fold m a b } + deriving (Functor) + +{-# DEPRECATED toFold "Please use 'unTee' instead." #-} +toFold :: Tee m a b -> Fold m a b +toFold = unTee + +-- | '<*>' distributes the input to both the argument 'Tee's and combines their +-- outputs using function application. +-- +instance Monad m => Applicative (Tee m a) where + + {-# INLINE pure #-} + pure a = Tee (Fold.fromPure a) + + {-# INLINE (<*>) #-} + (<*>) a b = Tee (Fold.teeWith ($) (unTee a) (unTee b)) + +-- | '<>' distributes the input to both the argument 'Tee's and combines their +-- outputs using the 'Semigroup' instance of the output type. +-- +instance (Semigroup b, Monad m) => Semigroup (Tee m a b) where + {-# INLINE (<>) #-} + (<>) = liftA2 (<>) + +-- | '<>' 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 + {-# INLINE mempty #-} + mempty = pure mempty + + {-# INLINE mappend #-} + mappend = (<>) + +-- | Binary 'Num' operations distribute the input to both the argument 'Tee's +-- and combine their outputs using the 'Num' instance of the output type. +-- +instance (Monad m, Num b) => Num (Tee m a b) where + {-# INLINE fromInteger #-} + fromInteger = pure . fromInteger + + {-# INLINE negate #-} + negate = fmap negate + + {-# INLINE abs #-} + abs = fmap abs + + {-# INLINE signum #-} + signum = fmap signum + + {-# INLINE (+) #-} + (+) = liftA2 (+) + + {-# INLINE (*) #-} + (*) = liftA2 (*) + + {-# INLINE (-) #-} + (-) = liftA2 (-) + +-- | Binary 'Fractional' operations distribute the input to both the argument +-- 'Tee's and combine their outputs using the 'Fractional' instance of the +-- output type. +-- +instance (Monad m, Fractional b) => Fractional (Tee m a b) where + {-# INLINE fromRational #-} + fromRational = pure . fromRational + + {-# INLINE recip #-} + recip = fmap recip + + {-# INLINE (/) #-} + (/) = liftA2 (/) + +-- | Binary 'Floating' operations distribute the input to both the argument +-- 'Tee's and combine their outputs using the 'Floating' instance of the output +-- type. +instance (Monad m, Floating b) => Floating (Tee m a b) where + {-# INLINE pi #-} + pi = pure pi + + {-# INLINE exp #-} + exp = fmap exp + + {-# INLINE sqrt #-} + sqrt = fmap sqrt + + {-# INLINE log #-} + log = fmap log + + {-# INLINE sin #-} + sin = fmap sin + + {-# INLINE tan #-} + tan = fmap tan + + {-# INLINE cos #-} + cos = fmap cos + + {-# INLINE asin #-} + asin = fmap asin + + {-# INLINE atan #-} + atan = fmap atan + + {-# INLINE acos #-} + acos = fmap acos + + {-# INLINE sinh #-} + sinh = fmap sinh + + {-# INLINE tanh #-} + tanh = fmap tanh + + {-# INLINE cosh #-} + cosh = fmap cosh + + {-# INLINE asinh #-} + asinh = fmap asinh + + {-# INLINE atanh #-} + atanh = fmap atanh + + {-# INLINE acosh #-} + acosh = fmap acosh + + {-# INLINE (**) #-} + (**) = liftA2 (**) + + {-# INLINE logBase #-} + logBase = liftA2 logBase diff --git a/src/Streamly/Internal/Data/Fold/Type.hs b/src/Streamly/Internal/Data/Fold/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Type.hs @@ -0,0 +1,1856 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Fold.Type +-- Copyright : (c) 2019 Composewell Technologies +-- (c) 2013 Gabriel Gonzalez +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- = Stream Consumers +-- +-- We can classify stream consumers in the following categories in order of +-- increasing complexity and power: +-- +-- * Accumulators: Tee/Zip is simple, cannot be appended, good for scanning. +-- * Terminating folds: Tee/Zip varies based on termination, can be appended, +-- good for scanning, nesting (many) is easy. +-- * Non-failing (backtracking only) parsers: cannot be used as scans because +-- of backtracking, nesting is complicated because of backtracking, appending +-- is efficient because of no Alternative, Alternative does not make sense +-- because it cannot fail. +-- * Parsers: Alternative on failure, appending is not as efficient because of +-- buffering for Alternative. +-- +-- First two are represented by the 'Fold' type and the last two by the +-- 'Parser' type. +-- +-- == Folds that never terminate (Accumulators) +-- +-- An @Accumulator@ is the simplest type of fold, it never fails and never +-- terminates. It can always accept more inputs (never terminates) and the +-- accumulator is always valid. For example 'Streamly.Internal.Data.Fold.sum'. +-- Traditional Haskell left folds like 'foldl' are accumulators. +-- +-- Accumulators can be composed in parallel where we distribute the input +-- stream to all accumulators. Since accumulators never terminate they cannot +-- be appended. +-- +-- An accumulator can be represented as: +-- +-- @ +-- data Fold0 m a b = +-- forall s. Fold0 +-- (s -> a -> m s) -- step +-- (m s) -- initial +-- (s -> m b) -- extract +-- @ +-- +-- This is just a traditional left fold, compare with @foldl@. The driver of +-- the fold would call @initial@ at the beginning and then keep accumulating +-- inputs into its result using @step@ and finally extract the result using +-- @extract@. +-- +-- == Folds that terminate after one or more input +-- +-- @Terminating folds@ are accumulators that can terminate, like accumulators +-- they do not fail. Once a fold terminates it no longer accepts any more +-- inputs. Terminating folds can be appended, the next fold can be +-- applied after the first one terminates. Because they cannot fail, they do +-- not need backtracking. +-- +-- The 'Streamly.Internal.Data.Fold.take' operation is an example of a +-- terminating fold. It terminates after consuming @n@ items. Coupled with an +-- accumulator (e.g. sum) it can be used to process the stream into chunks of +-- fixed size. +-- +-- A terminating fold can be represented as: +-- +-- @ +-- data Step s b +-- = Partial !s -- the fold can accept more input +-- | Done !b -- the fold is done +-- +-- data Fold1 m a b = +-- forall s. Fold1 +-- (s -> a -> m (Step s b)) -- step +-- (m s) -- initial +-- (s -> m b) -- extract +-- @ +-- +-- The fold driver stops driving the fold as soon as the fold returns a @Done@. +-- @extract@ is required only if the fold has not stopped yet and the input +-- ends. @extract@ can never be called if the fold is @Done@. +-- +-- Notice that the @initial@ of `Fold1` type does not return a "Step" type, +-- therefore, it cannot say "Done" in initial. It always has to consume at +-- least one element before it can say "Done" for termination, via the @step@ +-- function. +-- +-- == Folds that terminate after 0 or more input +-- +-- The `Fold1` type makes combinators like @take 0@ impossible to implement +-- because they need to terminate even before they can consume any elements at +-- all. Implementing this requires the @initial@ function to be able to return +-- @Done@. +-- +-- @ +-- data Fold m a b = +-- forall s. Fold +-- (s -> a -> m (Step s b)) -- step +-- (m (Step s b)) -- initial +-- (s -> m b) -- extract +-- @ +-- +-- This is also required if we want to compose terminating folds using an +-- Applicative or Monadic composition. @pure@ needs to yield an output without +-- having to consume an input. +-- +-- @initial@ now has the ability to terminate the fold without consuming any +-- input based on the state of the monad. +-- +-- In some cases it does not make sense to use a fold that does not consume any +-- items at all, and it may even lead to an infinite loop. It might make sense +-- to use a `Fold1` type for such cases because it guarantees to consume at +-- least one input, therefore, guarantees progress. For example, in +-- classifySessionsBy or any other splitting operations it may not make sense +-- to pass a fold that never consumes an input. However, we do not have a +-- separate Fold1 type for the sake of simplicity of types/API. +-- +-- Adding this capability adds a certain amount of complexity in the +-- implementation of fold combinators. @initial@ has to always handle two cases +-- now. We could potentially not implement this in folds to keep fold +-- implementation simpler, and these use cases can be transferred to the parser +-- type. However, it would be a bit inconvenient to not have a `take` operation +-- or to not be able to use `take 0` if we have it. Also, applicative and +-- monadic composition of folds would not be possible. +-- +-- == Terminating Folds with backtracking +-- +-- Consider the example of @takeWhile@ operation, it needs to inspect an +-- element for termination decision. However, it does not consume the element +-- on which it terminates. To implement @takeWhile@ a terminating fold will +-- have to implement a way to return the unconsumed input to the fold driver. +-- +-- Single element leftover case is quite common and its easy to implement it in +-- terminating folds by adding a @Done1@ constructor in the 'Step' type which +-- indicates that the last element was not consumed by the fold. The following +-- additional operations can be implemented as terminating folds if we do that. +-- +-- @ +-- takeWhile +-- groupBy +-- wordBy +-- @ +-- +-- However, it creates several complications. The most important one is that we +-- cannot use such folds for scanning. We cannot backtrack after producing an +-- output in a scan. +-- +-- === Nested backtracking +-- +-- Nesting of backtracking folds increases the amount of backtracking required +-- exponentially. +-- +-- For example, the combinator @many inner outer@ applies the outer fold on the +-- input stream and applies the inner fold on the results of the outer fold. +-- +-- many :: Monad m => Fold m b c -> Fold m a b -> Fold m a c +-- +-- If the inner fold itself returns a @Done1@ then we need to backtrack all +-- the elements that have been consumed by the outer fold to generate that +-- value. We need backtracking of more than one element. +-- +-- Arbitrary backtracking requires arbitrary buffering. However, we do not want +-- to buffer unconditionally, only if the buffer is needed. One way to do this +-- is to use a "Continue" constructor like parsers. When we have nested folds, +-- the top level fold always returns a "Continue" to the driver until an output +-- is generated by it, this means the top level driver keeps buffering until an +-- output is generated via Partial or Done. Intermediate level "Continue" keep +-- propagating up to the top level. +-- +-- === Parallel backtracking +-- +-- In compositions like Alternative and Distributive we may have several +-- branches. Each branch can backtrack independently. We need to keep the input +-- as long as any of the branches need it. We can use a single copy of the +-- buffer and maintain it based on all the branches, or we can make each branch +-- have its own buffer. The latter approach may be simpler to implement. +-- Whenever we branch we can introduce an independent buffer for backtracking. +-- Or we can use a newtype that allows branched composition to handle +-- backtracking. +-- +-- === Implementation Approach +-- +-- To avoid these issues we can enforce, by using types, that the collecting +-- folds can never return a leftover. This leads us to define a type that can +-- never return a leftover. The use cases of single leftover can be transferred +-- to parsers where we have general backtracking mechanism and single leftover +-- is just a special case of backtracking. +-- +-- 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 +-- will be equivalent to just throwing an error. They won't have an +-- alternative. +-- +-- Because of the complexity of implementing a distributive composition in +-- presence of backtracking we could possibly have a type without backtracking +-- but with the "Continue" constructor, and use either the Parser type or +-- another type for backtracking. +-- +-- == Folds with an additional input +-- +-- The `Fold` type does not allow a dynamic input to be used to generate the +-- initial value of the fold accumulator. We can extend the type further to +-- allow that: +-- +-- @ +-- data Refold m i a b = +-- forall s. Refold +-- (s -> a -> m (Step s b)) -- step +-- (i -> m (Step s b)) -- initial +-- (s -> m b) -- extract +-- @ +-- +-- == Parsers +-- +-- The next upgrade after terminating folds with a leftover are parsers. +-- Parsers are terminating folds that can fail and backtrack. Parsers can be +-- composed using an @alternative@ style composition where they can backtrack +-- and apply another parser if one parser fails. +-- 'Streamly.Internal.Data.Parser.satisfy' is a simple example of a parser, it +-- 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 +-- skip producing an output or to backtrack. We also add the ability to +-- backtrack in @Partial@ and @Done@.: +-- +-- Also @extract@ now needs to be able to express an error. We could have it +-- return the @Step@ type as well but that makes the implementation more +-- complicated. +-- +-- @ +-- data Step s b = +-- 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 +-- +-- data Parser a m b = +-- forall s. Fold +-- (s -> a -> m (Step s b)) -- step +-- (m (Step s b)) -- initial +-- (s -> m (Either String b)) -- extract +-- @ +-- +-- = Types for Stream Consumers +-- +-- We do not have a separate type for accumulators. Terminating folds are a +-- superset of accumulators and to avoid too many types we represent both using +-- the same type, 'Fold'. +-- +-- We do not club the leftovers functionality with terminating folds because of +-- the reasons explained earlier. Instead combinators that require leftovers +-- are implemented as the 'Streamly.Internal.Data.Parser.Parser' type. This is +-- a sweet spot to balance ease of use, type safety and performance. Using +-- separate Accumulator and terminating fold types would encode more +-- information in types but it would make ease of use, implementation, +-- maintenance effort worse. Combining Accumulator, terminating folds and +-- Parser into a single 'Streamly.Internal.Data.Parser.Parser' type would make +-- ease of use even better but type safety and performance worse. +-- +-- One of the design requirements that we have placed for better ease of use +-- and code reuse is that 'Streamly.Internal.Data.Parser.Parser' type should be +-- a strict superset of the 'Fold' type i.e. it can do everything that a 'Fold' +-- can do and more. Therefore, folds can be easily upgraded to parsers and we +-- can use parser combinators on folds as well when needed. +-- +-- = Fold Design +-- +-- A fold is represented by a collection of "initial", "step" and "extract" +-- functions. The "initial" action generates the initial state of the fold. The +-- state is internal to the fold and maintains the accumulated output. The +-- "step" function is invoked using the current state and the next input value +-- and results in a @Partial@ or @Done@. A @Partial@ returns the next intermediate +-- state of the fold, a @Done@ indicates that the fold has terminated and +-- returns the final value of the accumulator. +-- +-- Every @Partial@ indicates that a new accumulated output is available. The +-- accumulated output can be extracted from the state at any point using +-- "extract". "extract" can never fail. A fold returns a valid output even +-- without any input i.e. even if you call "extract" on "initial" state it +-- provides an output. This is not true for parsers. +-- +-- In general, "extract" is used in two cases: +-- +-- * When the fold is used as a scan @extract@ is called on the intermediate +-- state every time it is yielded by the fold, the resulting value is yielded +-- as a stream. +-- * When the fold is used as a regular fold, @extract@ is called once when +-- we are done feeding input to the fold. +-- +-- = Alternate Designs +-- +-- An alternate and simpler design would be to return the intermediate output +-- via @Partial@ along with the state, instead of using "extract" on the yielded +-- state and remove the extract function altogether. +-- +-- This may even facilitate more efficient implementation. Extract from the +-- intermediate state after each yield may be more costly compared to the fold +-- step itself yielding the output. The fold may have more efficient ways to +-- retrieve the output rather than stuffing it in the state and using extract +-- on the state. +-- +-- However, removing extract altogether may lead to less optimal code in some +-- cases because the driver of the fold needs to thread around the intermediate +-- output to return it if the stream stops before the fold could return @Done@. +-- When using this approach, the @parseMany (FL.take filesize)@ benchmark shows +-- a 2x worse performance even after ensuring everything fuses. So we keep the +-- "extract" approach to ensure better perf in all cases. +-- +-- But we could still yield both state and the output in @Partial@, the output +-- can be used for the scan use case, instead of using extract. Extract would +-- then be used only for the case when the stream stops before the fold +-- completes. +-- +-- = Monoids +-- +-- Monoids allow generalized, modular folding. The accumulators in this module +-- can be expressed using 'mconcat' and a suitable 'Monoid'. Instead of +-- writing folds we can write Monoids and turn them into folds. +-- +module Streamly.Internal.Data.Fold.Type + ( + -- * Imports + -- $setup + + -- * Types + Step (..) + , Fold (..) + + -- * Constructors + , foldl' + , foldlM' + , foldl1' + , foldlM1' + , foldt' + , foldtM' + , foldr' + , foldrM' + + -- * Folds + , fromPure + , fromEffect + , fromRefold + , drain + , toList + , toStreamK + , toStreamKRev + + -- * Combinators + + -- ** Mapping output + , rmapM + + -- ** Mapping Input + , lmap + , lmapM + , postscan + + -- ** Filtering + , catMaybes + , scanMaybe + , filter + , filtering + , filterM + , catLefts + , catRights + , catEithers + + -- ** Trimming + , take + , taking + , 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 + , teeWithMin + + -- ** Parallel Alternative + , shortest + , longest + + -- * Running A Fold + , extractM + , reduce + , snoc + , addOne + , snocM + , snocl + , snoclM + , close + , isClosed + + -- * Transforming inner monad + , morphInner + , generalizeInner + + -- * Deprecated + , foldr + , serialWith + ) +where + +#include "inline.hs" + +import Control.Applicative (liftA2) +import Control.Monad ((>=>)) +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.Refold.Type (Refold(..)) + +import qualified Streamly.Internal.Data.Stream.StreamK.Type as K + +import Prelude hiding (concatMap, filter, foldr, map, take) + +#include "DocTestDataFold.hs" + +------------------------------------------------------------------------------ +-- The Fold 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". + +-- | 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@. +-- +-- 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. +-- +-- 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) + +------------------------------------------------------------------------------ +-- Mapping on the output +------------------------------------------------------------------------------ + +-- | Map a monadic function on the output of a fold. +-- +{-# 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) + + where + + initial1 = initial >>= mapMStep f + step1 s a = step s a >>= mapMStep f + +------------------------------------------------------------------------------ +-- Left fold constructors +------------------------------------------------------------------------------ + +-- | Make a fold from a left fold style pure step function and initial value of +-- the accumulator. +-- +-- If your 'Fold' returns only 'Partial' (i.e. never returns a 'Done') then you +-- can use @foldl'*@ constructors. +-- +-- A fold with an extract function can be expressed using fmap: +-- +-- @ +-- mkfoldlx :: Monad m => (s -> a -> s) -> s -> (s -> b) -> Fold m a b +-- mkfoldlx step initial extract = fmap extract (foldl' step initial) +-- @ +-- +{-# 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 + +-- | Make a fold from a left fold style monadic step function and initial value +-- of the accumulator. +-- +-- A fold with an extract function can be expressed using rmapM: +-- +-- @ +-- mkFoldlxM :: Functor m => (s -> a -> m s) -> m s -> (s -> m b) -> Fold m a b +-- mkFoldlxM step initial extract = rmapM extract (foldlM' step initial) +-- @ +-- +{-# 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 + +-- | Make a strict left fold, for non-empty streams, using first element as the +-- starting value. Returns Nothing if the stream is empty. +-- +-- /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 + +-- | Like 'foldl1\'' but with a monadic step function. +-- +-- /Pre-release/ +{-# INLINE foldlM1' #-} +foldlM1' :: Monad m => (a -> a -> m a) -> Fold m a (Maybe a) +foldlM1' step = fmap toMaybe $ foldlM' step1 (return Nothing') + + where + + step1 Nothing' a = return $ Just' a + step1 (Just' x) a = Just' <$> step x a + +------------------------------------------------------------------------------ +-- Right fold constructors +------------------------------------------------------------------------------ + +-- | Make a fold 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: +-- +-- >>> foldr' f z = fmap (flip appEndo z) $ Fold.foldMap (Endo . f) +-- >>> foldr' f z = fmap ($ z) $ Fold.foldl' (\g x -> g . f x) id +-- +-- Example: +-- +-- >>> Stream.fold (Fold.foldr' (:) []) $ Stream.enumerateFromTo 1 5 +-- [1,2,3,4,5] +-- +{-# 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 + +{-# DEPRECATED foldr "Please use foldr' instead." #-} +{-# INLINE foldr #-} +foldr :: Monad m => (a -> b -> b) -> b -> Fold m a b +foldr = foldr' + +-- XXX we have not seen any use of this yet, not releasing until we have a use +-- case. + +-- | Like foldr' but with a monadic step function. +-- +-- Example: +-- +-- >>> toList = Fold.foldrM' (\a xs -> return $ a : xs) (return []) +-- +-- See also: 'Streamly.Internal.Data.Stream.foldrM' +-- +-- /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) + +------------------------------------------------------------------------------ +-- General fold 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 -> Fold 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 fold using a pure step function, a pure initial state +-- and a pure state extraction function. +-- +-- /Pre-release/ +-- +{-# 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) + +-- | Make a terminating fold with an effectful step function and initial state, +-- and a state extraction function. +-- +-- >>> foldtM' = Fold.Fold +-- +-- We can just use 'Fold' but it is provided for completeness. +-- +-- /Pre-release/ +-- +{-# INLINE foldtM' #-} +foldtM' :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> Fold m a b +foldtM' = Fold + +------------------------------------------------------------------------------ +-- 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 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 + +------------------------------------------------------------------------------ +-- Basic Folds +------------------------------------------------------------------------------ + +-- | A fold that drains all its input, running the effects and discarding the +-- results. +-- +-- >>> drain = Fold.drainMapM (const (return ())) +-- >>> drain = Fold.foldl' (\_ _ -> ()) () +-- +{-# INLINE drain #-} +drain :: Monad m => Fold m a () +drain = foldl' (\_ _ -> ()) () + +-- | Folds the input stream to a list. +-- +-- /Warning!/ working on large lists accumulated as buffers in memory could be +-- very inefficient, consider using "Streamly.Data.Array" +-- instead. +-- +-- >>> toList = Fold.foldr' (:) [] +-- +{-# INLINE toList #-} +toList :: Monad m => Fold m a [a] +toList = foldr' (:) [] + +-- | Buffers the input stream to a pure stream in the reverse order of the +-- input. +-- +-- >>> toStreamKRev = Foldable.foldl' (flip StreamK.cons) StreamK.nil +-- +-- 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 => Fold m a (K.StreamK n a) +toStreamKRev = foldl' (flip K.cons) K.nil + +-- | A fold that buffers its input to a pure stream. +-- +-- >>> toStreamK = foldr StreamK.cons StreamK.nil +-- >>> toStreamK = fmap StreamK.reverse Fold.toStreamKRev +-- +-- /Internal/ +{-# INLINE toStreamK #-} +toStreamK :: Monad m => Fold m a (K.StreamK n a) +toStreamK = foldr K.cons K.nil + +------------------------------------------------------------------------------ +-- Instances +------------------------------------------------------------------------------ + +-- | 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) + + where + + initial = fmap2 f initial1 + step s b = fmap2 f (step1 s b) + fmap2 g = fmap (fmap g) + +-- 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 fold that yields the supplied value without consuming any further +-- input. +-- +-- /Pre-release/ +-- +{-# INLINE fromPure #-} +fromPure :: Applicative m => b -> Fold m a b +fromPure b = Fold undefined (pure $ Done b) pure + +-- | Make a fold that yields the result of the supplied effectful action +-- without consuming any further input. +-- +-- /Pre-release/ +-- +{-# INLINE fromEffect #-} +fromEffect :: Applicative m => m b -> Fold m a b +fromEffect b = Fold undefined (Done <$> b) 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 = Fold.take 8 Fold.toList +-- >>> line = Fold.takeEndBy (== '\n') Fold.toList +-- >>> f = Fold.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. When you need +-- scaling use parser monad instead. +-- +-- /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 + + 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 + + extract (SeqFoldR f sR) = fmap f (extractR sR) + extract (SeqFoldL sL) = do + rL <- extractL sL + res <- initialR + fmap (func rL) + $ case res of + Partial sR -> extractR sR + Done rR -> return rR + +{-# DEPRECATED serialWith "Please use \"splitWith\" instead" #-} +{-# INLINE serialWith #-} +serialWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c +serialWith = splitWith + +{-# 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 _) (Fold stepR initialR extractR) = + Fold step initial extract + + 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 + + extract (SeqFoldR_ sR) = extractR sR + extract (SeqFoldL_ _) = do + res <- initialR + case res of + Partial sR -> extractR 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 + +-- | @teeWith k f1 f2@ distributes its input to both @f1@ and @f2@ until both +-- of them terminate and combines their output using @k@. +-- +-- Definition: +-- +-- >>> teeWith k f1 f2 = fmap (uncurry k) (Fold.tee f1 f2) +-- +-- Example: +-- +-- >>> avg = Fold.teeWith (/) Fold.sum (fmap fromIntegral Fold.length) +-- >>> Stream.fold avg $ Stream.fromList [1.0..100.0] +-- 50.5 +-- +-- For applicative composition using this combinator see +-- "Streamly.Data.Fold.Tee". +-- +-- See also: "Streamly.Data.Fold.Tee" +-- +-- Note that nested applications of teeWith do not fuse. +-- +{-# 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 + + 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 + +{-# ANN type TeeFstState Fuse #-} +data TeeFstState sL sR b + = TeeFstBoth !sL !sR + | TeeFstLeft !b !sL + +-- | Like 'teeWith' but terminates as soon as the first fold terminates. +-- +-- /Pre-release/ +-- +{-# 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 + + 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 -> extractR 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 + +-- | Like 'teeWith' but terminates as soon as any one of the two folds +-- terminates. +-- +-- /Pre-release/ +-- +{-# 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 + + 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) <$> extractL sl + + Done bl -> do + Done . f bl <$> + case resR of + Partial sr -> extractR 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 + +-- | 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 => 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 + + where + + {-# INLINE runBoth #-} + runBoth actionL actionR = do + resL <- actionL + resR <- actionR + return $ + case resL of + Partial sL -> bimap (Tuple' sL) Right resR + Done bL -> 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 + +{-# 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 => 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 + + 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 + + left sL = Left <$> extractL sL + extract (LongestLeft sL) = left sL + extract (LongestRight sR) = Right <$> extractR sR + extract (LongestBoth sL _) = left sL + +data ConcatMapState m sa a c + = B !sa + | forall s. C (s -> a -> m (Step s c)) !s (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 +-- 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 Fold.one +-- >>> total n = Fold.take n Fold.sum +-- >>> Stream.fold (Fold.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 -> Fold m a c) -> Fold m a b -> Fold m a c +concatMap f (Fold stepa initiala extracta) = Fold stepc initialc extractc + where + initialc = do + r <- initiala + case r of + Partial s -> return $ Partial (B s) + Done b -> initInnerFold (f b) + + stepc (B s) a = do + r <- stepa s a + case r of + Partial s1 -> return $ Partial (B s1) + Done b -> initInnerFold (f b) + + stepc (C stepInner s extractInner) a = do + r <- stepInner s a + return $ case r of + Partial sc -> Partial (C stepInner sc extractInner) + Done c -> Done c + + extractc (B s) = do + r <- extracta s + initExtract (f r) + extractc (C _ sInner extractInner) = extractInner sInner + + initInnerFold (Fold step i e) = do + r <- i + return $ case r of + Partial s -> Partial (C step s e) + Done c -> Done c + + initExtract (Fold _ i e) = do + r <- i + case r of + Partial s -> e s + Done c -> return c + +------------------------------------------------------------------------------ +-- Mapping on input +------------------------------------------------------------------------------ + +-- | @lmap f fold@ maps the function @f@ on the input of the fold. +-- +-- Definition: +-- +-- >>> lmap = Fold.lmapM return +-- +-- Example: +-- +-- >>> sumSquared = Fold.lmap (\x -> x * x) Fold.sum +-- >>> Stream.fold sumSquared (Stream.enumerateFromTo 1 100) +-- 338350 +-- +{-# INLINE lmap #-} +lmap :: (a -> b) -> Fold m b r -> Fold m a r +lmap f (Fold step begin done) = Fold step' begin done + where + step' x a = step x (f a) + +-- | @lmapM f fold@ maps the monadic function @f@ on the input of the fold. +-- +{-# 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 + where + step' x a = f a >>= step x + +-- | Postscan the input of a 'Fold' to change it in a stateful manner using +-- another 'Fold'. +-- +-- @postscan scanner collector@ +-- +-- /Pre-release/ +{-# 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 + + 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 <$> 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 + rL <- initialL + case r of + Partial sR -> + case rL of + Done _ -> Done <$> extractR sR + Partial sL -> return $ Partial (sL, sR) + Done b -> return $ Done b + + step (sL, sR) x = runStep (stepL sL x) sR + + extract = extractR . snd + +------------------------------------------------------------------------------ +-- Filtering +------------------------------------------------------------------------------ + +-- | Modify a fold to receive a 'Maybe' input, the 'Just' values are unwrapped +-- and sent to the original fold, 'Nothing' values are discarded. +-- +-- >>> catMaybes = Fold.mapMaybe id +-- >>> catMaybes = Fold.filter isJust . Fold.lmap fromJust +-- +{-# INLINE_NORMAL catMaybes #-} +catMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b +catMaybes (Fold step initial extract) = Fold step1 initial extract + + where + + step1 s a = + case a of + Nothing -> return $ Partial s + Just x -> step s x + +-- | Use a 'Maybe' returning fold as a filtering scan. +-- +-- >>> scanMaybe p f = Fold.postscan p (Fold.catMaybes f) +-- +-- /Pre-release/ +{-# 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) + +-- | A scanning fold for filtering elements based on a predicate. +-- +{-# INLINE filtering #-} +filtering :: Monad m => (a -> Bool) -> Fold m a (Maybe a) +filtering f = foldl' step Nothing + + where + + step _ a = if f a then Just a else Nothing + +-- | Include only those elements that pass a predicate. +-- +-- >>> 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 + 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 = Fold.mapMaybeM (f p) +-- +{-# 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 + 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) => Fold m a c -> Fold 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) => Fold m b c -> Fold 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 = Fold.lmap (either id id) +-- +-- /Pre-release/ +-- +{-# INLINE catEithers #-} +catEithers :: Fold m a b -> Fold 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 -> 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 + +{-# 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 + +-- | Take at most @n@ input elements and fold them using the supplied fold. A +-- negative count is treated as 0. +-- +-- >>> Stream.fold (Fold.take 2 Fold.toList) $ Stream.fromList [1..10] +-- [1,2] +-- +{-# 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 + + 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 <$> fextract 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 + +------------------------------------------------------------------------------ +-- 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 => 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) + + where + + initial = second fromPure <$> initial1 + + step s a = second fromPure <$> step1 s a + +-- 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. + +-- | 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 => Fold m a b -> m (Fold m a b) +reduce (Fold step initial extract) = do + i <- initial + return $ Fold step (return i) extract + +-- 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 => Fold m a b -> m a -> Fold m a b +snoclM (Fold fstep finitial fextract) action = Fold fstep initial fextract + + 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 = Fold.snoclM f . return +-- +-- Example: +-- +-- >>> import qualified Data.Foldable as Foldable +-- >>> Fold.extractM $ 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 + + 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 = Fold.reduce . Fold.snoclM f +-- +-- /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 + res <- initial + r <- case res of + Partial fs -> action >>= step fs + Done _ -> return res + return $ Fold step (return r) extract + +-- Definitions: +-- +-- >>> snoc f = Fold.reduce . Fold.snocl f +-- >>> snoc f = Fold.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 Fold.snoc Fold.toList [1..3] >>= Fold.drive Stream.nil +-- [1,2,3] +-- +-- /Pre-release/ +{-# INLINE snoc #-} +snoc :: Monad m => Fold m a b -> a -> m (Fold m a b) +snoc (Fold step initial extract) a = do + res <- initial + r <- case res of + Partial fs -> step fs a + Done _ -> return res + return $ Fold step (return r) extract + +-- | Append a singleton value to the fold. +-- +-- See examples under 'addStream'. +-- +-- /Pre-release/ +{-# INLINE addOne #-} +addOne :: Monad m => a -> Fold m a b -> m (Fold 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 = Fold.drive Stream.nil +-- +-- Example: +-- +-- >>> Fold.extractM Fold.toList +-- [] +-- +-- /Pre-release/ +{-# 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 + +-- | 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 + + where + + initial = do + res <- initial1 + case res of + Partial s -> Done <$> extract1 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 => Fold m a b -> m Bool +isClosed (Fold _ 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. + +{-# 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 = Fold.take 2 Fold.toList +-- >>> twos = Fold.many two Fold.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 => 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 + + 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 + +-- | 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 => 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 + + 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 + +-- | @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 = Fold.many (Fold.take n split) +-- +-- Example: +-- +-- >>> twos = Fold.groupsOf 2 Fold.toList Fold.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 -> Fold m a b -> Fold m b c -> Fold 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 => Fold m a b -> Refold m x b c -> Refold m x a c +refoldMany (Fold sstep sinitial sextract) (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 -> Fold m b c -> Refold m x a c +refoldMany1 (Refold sstep sinject sextract) (Fold cstep cinitial 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 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 -> Fold m a b -> Fold m a c +refold (Refold step inject extract) f = + Fold step (extractM f >>= inject) extract + +------------------------------------------------------------------------------ +-- morphInner +------------------------------------------------------------------------------ + +-- | Change the underlying monad of a fold. Also known as hoist. +-- +-- /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) + +-- | Adapt a pure fold to any monad. +-- +-- >>> generalizeInner = Fold.morphInner (return . runIdentity) +-- +-- /Pre-release/ +generalizeInner :: Monad m => Fold Identity a b -> Fold m a b +generalizeInner = morphInner (return . runIdentity) diff --git a/src/Streamly/Internal/Data/Fold/Window.hs b/src/Streamly/Internal/Data/Fold/Window.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Window.hs @@ -0,0 +1,351 @@ +-- | +-- Module : Streamly.Internal.Data.Fold.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 fold can be driven either using the Ring.slidingWindow +-- combinator or by zipping nthLast fold and last fold. + +module Streamly.Internal.Data.Fold.Window + ( + -- * Incremental Folds + -- | Folds of type @Fold m (a, Maybe a) b@ are incremental sliding window + -- folds. An input of type @(a, Nothing)@ 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 @(a, Just a)@ + -- indicates that the first element is being inserted in the window and the + -- second element is being removed from 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 sliding + -- window folds by keeping the second element of the input tuple as + -- @Nothing@. + -- + lmap + , cumulative + + , rollingMap + , rollingMapM + + -- ** Sums + , length + , sum + , sumInt + , powerSum + , powerSumFrac + + -- ** Location + , minimum + , maximum + , range + , mean + ) +where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Bifunctor(bimap) +import Foreign.Storable (Storable, peek) + +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 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) + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- | Map a function on the incoming as well as outgoing element of a rolling +-- window fold. +-- +-- >>> 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 <$>)) + +-- | Convert an incremental fold to a cumulative fold using the entire input +-- stream as a single window. +-- +-- >>> cumulative f = Fold.lmap (\x -> (x, Nothing)) f +-- +{-# INLINE cumulative #-} +cumulative :: Fold m (a, Maybe a) b -> Fold m a b +cumulative = Fold.lmap (, Nothing) + +-- XXX Exchange the first two arguments of rollingMap or exchange the order in +-- the fold input tuple. + +-- | Apply an effectful function on the latest and the oldest element of the +-- window. +{-# INLINE rollingMapM #-} +rollingMapM :: Monad m => + (Maybe a -> a -> m (Maybe b)) -> Fold m (a, Maybe a) (Maybe b) +rollingMapM f = Fold.foldlM' f1 initial + + where + + initial = return Nothing + + f1 _ (a, ma) = f ma a + +-- | Apply a pure function on the latest and the oldest element of the window. +-- +-- >>> rollingMap f = FoldW.rollingMapM (\x y -> return $ f x y) +-- +{-# INLINE rollingMap #-} +rollingMap :: Monad m => + (Maybe a -> a -> Maybe b) -> Fold m (a, Maybe a) (Maybe b) +rollingMap f = Fold.foldl' f1 initial + + where + + initial = Nothing + + f1 _ (a, ma) = f ma a + +------------------------------------------------------------------------------- +-- Sum +------------------------------------------------------------------------------- + +-- XXX Overflow. +-- +-- | The sum of all the elements in a rolling window. The input elements are +-- required to be intergal numbers. +-- +-- This was written in the hope that it would be a tiny bit faster than 'sum' +-- for 'Integral' values. But turns out that 'sum' is 2% faster than this even +-- for intergal values! +-- +-- /Internal/ +-- +{-# INLINE sumInt #-} +sumInt :: forall m a. (Monad m, Integral a) => Fold m (a, Maybe a) a +sumInt = Fold step initial extract + + where + + initial = return $ Partial (0 :: a) + + step s (a, ma) = + return + $ Partial + $ case ma of + Nothing -> s + a + Just old -> s + a - 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. +-- +-- >>> sum = powerSum 1 +-- +-- Uses Kahan-Babuska-Neumaier style summation for numerical stability of +-- floating precision arithmetic. +-- +-- /Space/: \(\mathcal{O}(1)\) +-- +-- /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 + + where + + initial = + return + $ Partial + $ Tuple' + (0 :: a) -- running sum + (0 :: a) -- accumulated rounding error + + step (Tuple' total err) (new, mOld) = + let incr = + case mOld of + -- XXX new may be large and err may be small we may lose it + Nothing -> new - err + -- XXX if (new - old) is large we may lose err + Just old -> (new - old) - err + -- 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 Nothing case above we may lose err, therefore we + -- should use ((total1 - total) - new) + err here. + -- Or even in the just 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 + + extract (Tuple' total _) = return total + +-- | The number of elements in the rolling window. +-- +-- This is the \(0\)th power sum. +-- +-- >>> length = powerSum 0 +-- +{-# INLINE length #-} +length :: (Monad m, Num b) => Fold m (a, Maybe a) b +length = Fold.foldl' step 0 + + where + + step w (_, Nothing) = w + 1 + step w _ = w + +-- | Sum of the \(k\)th power of all the elements in a rolling window: +-- +-- \(S_k = \sum_{i=1}^n x_{i}^k\) +-- +-- >>> powerSum k = lmap (^ k) sum +-- +-- /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 + +-- | Like 'powerSum' but powers can be negative or fractional. This is slower +-- than 'powerSum' for positive intergal powers. +-- +-- >>> powerSumFrac p = lmap (** p) sum +-- +{-# INLINE powerSumFrac #-} +powerSumFrac :: (Monad m, Floating a) => a -> Fold m (a, Maybe a) a +powerSumFrac p = lmap (** p) sum + +------------------------------------------------------------------------------- +-- Location +------------------------------------------------------------------------------- + +-- XXX Remove MonadIO constraint + +-- | Determine the maximum and minimum in a rolling window. +-- +-- If you want to compute the range of the entire stream @Fold.teeWith (,) +-- Fold.maximum Fold.minimum@ 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 range #-} +range :: (MonadIO m, Storable a, Ord a) => Int -> Fold m a (Maybe (a, a)) +range n = Fold step initial 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) + + -- 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 + + 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 + +-- | Find the minimum element in a rolling window. +-- +-- This implementation traverses the entire window buffer to compute the +-- minimum 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 minimum of the entire stream +-- 'Streamly.Data.Fold.minimum' is much faster. +-- +-- /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 + +-- | The maximum element in a rolling window. +-- +-- See the performance related comments in 'minimum'. +-- +-- If you want to compute the maximum of the entire stream 'Fold.maximum' would +-- be much faster. +-- +-- /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 + +-- | 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. +-- +-- >>> mean = Fold.teeWith (/) sum length +-- +-- /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 diff --git a/src/Streamly/Internal/Data/IOFinalizer.hs b/src/Streamly/Internal/Data/IOFinalizer.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/IOFinalizer.hs @@ -0,0 +1,91 @@ +-- | +-- Module : Streamly.Internal.Data.IOFinalizer +-- Copyright : (c) 2020 Composewell Technologies and Contributors +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A value associated with an IO action that is automatically called whenever +-- the value is garbage collected. + +module Streamly.Internal.Data.IOFinalizer + ( + IOFinalizer(..) + , newIOFinalizer + , runIOFinalizer + , clearingIOFinalizer + ) +where + +import Control.Exception (mask_) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef, IORef) + +-- | An 'IOFinalizer' has an associated IO action that is automatically called +-- whenever the finalizer is garbage collected. The action can be run and +-- cleared prematurely. +-- +-- You can hold a reference to the finalizer in your data structure, if the +-- data structure gets garbage collected the finalizer will be called. +-- +-- It is implemented using 'mkWeakIORef'. +-- +-- /Pre-release/ +newtype IOFinalizer = IOFinalizer (IORef (Maybe (IO ()))) + +-- | GC hook to run an IO action stored in a finalized IORef. +runFinalizerGC :: IORef (Maybe (IO ())) -> IO () +runFinalizerGC ref = do + res <- readIORef ref + case res of + Nothing -> return () + Just f -> f + +-- | Create a finalizer that calls the supplied function automatically when the +-- it is garbage collected. +-- +-- /The finalizer is always run using the state of the monad that is captured +-- at the time of calling 'newFinalizer'./ +-- +-- Note: To run it on garbage collection we have no option but to use the monad +-- state captured at some earlier point of time. For the case when the +-- finalizer is run manually before GC we could run it with the current state +-- of the monad but we want to keep both the cases consistent. +-- +-- /Pre-release/ +newIOFinalizer :: MonadIO m => IO a -> m IOFinalizer +newIOFinalizer finalizer = liftIO $ do + let f = void finalizer + ref <- newIORef $ Just f + _ <- mkWeakIORef ref (runFinalizerGC ref) + return $ IOFinalizer ref + +-- | Run the action associated with the finalizer and deactivate it so that it +-- never runs again. Note, the finalizing action runs with async exceptions +-- masked. +-- +-- /Pre-release/ +runIOFinalizer :: MonadIO m => IOFinalizer -> m () +runIOFinalizer (IOFinalizer ref) = liftIO $ do + res <- readIORef ref + case res of + Nothing -> return () + Just action -> do + -- if an async exception comes after writing 'Nothing' then the + -- finalizing action will never be run. We need to do this + -- atomically wrt async exceptions. + mask_ $ do + writeIORef ref Nothing + action + +-- | Run an action clearing the finalizer atomically wrt async exceptions. The +-- action is run with async exceptions masked. +-- +-- /Pre-release/ +clearingIOFinalizer :: MonadIO m => IOFinalizer -> IO a -> m a +clearingIOFinalizer (IOFinalizer ref) action = do + liftIO $ mask_ $ do + writeIORef ref Nothing + action diff --git a/src/Streamly/Internal/Data/IORef/Unboxed.hs b/src/Streamly/Internal/Data/IORef/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/IORef/Unboxed.hs @@ -0,0 +1,100 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/IsMap.hs @@ -0,0 +1,52 @@ +-- | +-- Module : Streamly.Internal.Data.IsMap +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.IsMap (IsMap(..)) where + +import Data.Kind (Type) +import Data.Map.Strict (Map) + +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map + +-- XXX Try unpacked-containers + +class IsMap f where + type Key f :: Type + + mapEmpty :: f a + mapAlterF :: Functor g => + (Maybe a -> g (Maybe a)) -> Key f -> f a -> g (f a) + -- These can be implemented in terms of alterF itself + mapLookup :: Key f -> f a -> Maybe a + mapInsert :: Key f -> a -> f a -> f a + mapDelete :: Key f -> f a -> f a + mapUnion :: f a -> f a -> f a + mapNull :: f a -> Bool + +instance Ord k => IsMap (Map k) where + type Key (Map k) = k + + mapEmpty = Map.empty + mapAlterF = Map.alterF + mapLookup = Map.lookup + mapInsert = Map.insert + mapDelete = Map.delete + mapUnion = Map.union + mapNull = Map.null + +instance IsMap IntMap.IntMap where + type Key IntMap.IntMap = Int + + mapEmpty = IntMap.empty + mapAlterF = IntMap.alterF + mapLookup = IntMap.lookup + mapInsert = IntMap.insert + mapDelete = IntMap.delete + mapUnion = IntMap.union + mapNull = IntMap.null diff --git a/src/Streamly/Internal/Data/List.hs b/src/Streamly/Internal/Data/List.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/List.hs @@ -0,0 +1,169 @@ +{-# 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/Maybe/Strict.hs b/src/Streamly/Internal/Data/Maybe/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Maybe/Strict.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Streamly.Internal.Data.Maybe.Strict +-- Copyright : (c) 2019 Composewell Technologies +-- (c) 2013 Gabriel Gonzalez +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- | Strict data types to be used as accumulator for strict left folds and +-- scans. For more comprehensive strict data types see +-- https://hackage.haskell.org/package/strict-base-types . The names have been +-- suffixed by a prime so that programmers can easily distinguish the strict +-- versions from the lazy ones. +-- +-- One major advantage of strict data structures as accumulators in folds and +-- scans is that it helps the compiler optimize the code much better by +-- unboxing. In a big tight loop the difference could be huge. + +-- Notes: The purpose of the strict Maybe type is to force storing an evaluated +-- value instead of a lazy thunk. To enforce that we use a strict Maybe type in +-- a data structure. If we need to operate on such strict values, the simplest +-- way to do that is to convert it to a lazy type and operate on that. +-- Therefore, we do not provide any other operations other than ways to +-- construct a strict type and convert it to a lazy type. +-- +module Streamly.Internal.Data.Maybe.Strict + ( Maybe' (..) + -- XXX rename to lazyMaybe, also supply a strictMaybe function. + , toMaybe + -- XXX Remove these, use isJust . toMaybe etc instead. + , isJust' + , fromJust' + ) +where + +-- | A strict 'Maybe' +data Maybe' a = Just' !a | Nothing' deriving Show + +-- | Convert strict Maybe' to lazy Maybe +{-# INLINE toMaybe #-} +toMaybe :: Maybe' a -> Maybe a +toMaybe Nothing' = Nothing +toMaybe (Just' a) = Just a + +-- | Extract the element out of a Just' and throws an error if its argument is +-- Nothing'. +{-# INLINE fromJust' #-} +fromJust' :: Maybe' a -> a +fromJust' (Just' a) = a +fromJust' Nothing' = error "fromJust' cannot be run in Nothing'" + +-- | Returns True iff its argument is of the form "Just' _". +{-# INLINE isJust' #-} +isJust' :: Maybe' a -> Bool +isJust' (Just' _) = True +isJust' Nothing' = False diff --git a/src/Streamly/Internal/Data/Parser.hs b/src/Streamly/Internal/Data/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser.hs @@ -0,0 +1,14 @@ +-- | +-- 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 diff --git a/src/Streamly/Internal/Data/Parser/ParserD.hs b/src/Streamly/Internal/Data/Parser/ParserD.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser/ParserD.hs @@ -0,0 +1,3629 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser/ParserD/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.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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser/ParserD/Type.hs @@ -0,0 +1,1429 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser/ParserK/Type.hs @@ -0,0 +1,545 @@ +-- | +-- 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/Pipe.hs b/src/Streamly/Internal/Data/Pipe.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Pipe.hs @@ -0,0 +1,276 @@ +-- | +-- Module : Streamly.Internal.Data.Pipe +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- 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"). +-- 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. +-- +-- > 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 +-} + ) +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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Pipe/Type.hs @@ -0,0 +1,443 @@ +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Pipe.Type +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Pipe.Type + ( Step (..) + , Pipe (..) + , PipeState (..) + , zipWith + , tee + , map + , compose + ) +where + +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 qualified Prelude + +------------------------------------------------------------------------------ +-- 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. +-- +-- 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. +-- +-- 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. +-- +-- 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. +-- +data Step s a = + Yield a s + | Continue s + +-- | Represents a stateful transformation over an input stream of values of +-- type @a@ to outputs of type @b@ in 'Monad' @m@. + +-- 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. +-- +-- 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. +-- +-- 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. +-- +-- XXX In general the starting state could either be for generation or for +-- consumption. Currently we are only starting with a consumption state. +-- +-- An explicit either type for better readability of the code +data PipeState s1 s2 = Consume s1 | Produce s2 + +isProduce :: PipeState s1 s2 -> Bool +isProduce s = + case s of + Produce _ -> True + Consume _ -> False + +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 + +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_LATE produce' #-} + produce' st = do + r <- produce st + return $ case r of + Yield x s -> Yield (f x) s + Continue s -> Continue s + +-- XXX move this to a separate module +data Deque a = Deque [a] [a] + +{-# INLINE null #-} +null :: Deque a -> Bool +null (Deque [] []) = True +null _ = False + +{-# INLINE snoc #-} +snoc :: a -> Deque a -> Deque a +snoc a (Deque snocList consList) = Deque (a : snocList) consList + +{-# INLINE uncons #-} +uncons :: Deque a -> Maybe (a, Deque a) +uncons (Deque snocList consList) = + case consList of + h : t -> Just (h, Deque snocList t) + _ -> + case Prelude.reverse snocList of + h : t -> Just (h, Deque [] t) + _ -> Nothing + +-- | The composed pipe distributes the input to both the constituent pipes and +-- zips the output of the two using a supplied zipping function. +-- +-- @since 0.7.0 +{-# INLINE_NORMAL zipWith #-} +zipWith :: Monad m => (a -> b -> c) -> Pipe m i a -> Pipe m i b -> Pipe m i c +zipWith f (Pipe consumeL produceL stateL) (Pipe consumeR produceR stateR) = + Pipe consume produce state + where + + -- Left state means we need to consume input from the source. A Right + -- state means we either have buffered input or we are in generation + -- mode so we do not need input from source in either case. + -- + state = Tuple' (Consume stateL, Nothing, Nothing) + (Consume stateR, Nothing, Nothing) + + -- XXX for heavy buffering we need to have the (ring) buffer in pinned + -- memory using the Storable instance. + {-# INLINE_LATE consume #-} + consume (Tuple' (sL, resL, lq) (sR, resR, rq)) a = do + s1 <- drive sL resL lq consumeL produceL a + s2 <- drive sR resR rq consumeR produceR a + yieldOutput s1 s2 + + where + + {-# INLINE drive #-} + drive st res queue fConsume fProduce val = + case res of + Nothing -> goConsume st queue val fConsume fProduce + Just x -> return $ + case queue of + Nothing -> (st, Just x, Just $ Deque [val] []) + Just q -> (st, Just x, Just $ snoc val q) + + {-# INLINE goConsume #-} + goConsume stt queue val fConsume stp2 = + case stt of + Consume st -> + case queue of + Nothing -> do + r <- fConsume st val + return $ case r of + Yield x s -> (s, Just x, Nothing) + Continue s -> (s, Nothing, Nothing) + Just queue' -> + case uncons queue' of + Just (v, q) -> do + r <- fConsume st v + let q' = snoc val q + return $ case r of + Yield x s -> (s, Just x, Just q') + Continue s -> (s, Nothing, Just q') + Nothing -> undefined -- never occurs + Produce st -> do + r <- stp2 st + return $ case r of + Yield x s -> (s, Just x, queue) + Continue s -> (s, Nothing, queue) + + {-# INLINE_LATE produce #-} + produce (Tuple' (sL, resL, lq) (sR, resR, rq)) = do + s1 <- drive sL resL lq consumeL produceL + s2 <- drive sR resR rq consumeR produceR + yieldOutput s1 s2 + + where + + {-# INLINE drive #-} + drive stt res q fConsume fProduce = + case res of + Nothing -> goProduce stt q fConsume fProduce + Just x -> return (stt, Just x, q) + + {-# INLINE goProduce #-} + goProduce stt queue fConsume fProduce = + case stt of + Consume st -> + case queue of + -- See yieldOutput. We enter produce mode only when + -- each pipe is either in Produce state or the + -- queue is non-empty. So this case cannot occur. + Nothing -> undefined + Just queue' -> + case uncons queue' of + Just (v, q) -> do + r <- fConsume st v + -- We provide a guarantee that if the + -- queue is "Just" it is always + -- non-empty. yieldOutput and goConsume + -- depend on it. + let q' = if null q + then Nothing + else Just q + return $ case r of + Yield x s -> (s, Just x, q') + Continue s -> (s, Nothing, q') + Nothing -> return (stt, Nothing, Nothing) + Produce st -> do + r <- fProduce st + return $ case r of + Yield x s -> (s, Just x, queue) + Continue s -> (s, Nothing, queue) + + {-# INLINE yieldOutput #-} + yieldOutput s1@(sL', resL', lq') s2@(sR', resR', rq') = return $ + -- switch to produce mode if we do not need input + if (isProduce sL' || isJust lq') && (isProduce sR' || isJust rq') + then + case (resL', resR') of + (Just xL, Just xR) -> + Yield (f xL xR) (Produce (Tuple' (clear s1) (clear s2))) + _ -> Continue (Produce (Tuple' s1 s2)) + else + case (resL', resR') of + (Just xL, Just xR) -> + Yield (f xL xR) (Consume (Tuple' (clear s1) (clear s2))) + _ -> Continue (Consume (Tuple' s1 s2)) + where clear (s, _, q) = (s, Nothing, q) + +instance Monad m => Applicative (Pipe m a) where + {-# INLINE pure #-} + pure b = Pipe (\_ _ -> pure $ Yield b (Consume ())) undefined () + + (<*>) = 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 + where + + state = Tuple' (Consume stateL) (Consume stateR) + + 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)) + -} + + 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) + + 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)) + +instance Monad m => Semigroup (Pipe m a b) where + {-# INLINE (<>) #-} + (<>) = tee + +-- | Lift a pure function to a 'Pipe'. +-- +-- @since 0.7.0 +{-# INLINE map #-} +map :: Monad m => (a -> b) -> Pipe m a b +map f = Pipe consume undefined () + 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 +-} + +-- | Compose two pipes such that the output of the second pipe is attached to +-- the input of the first pipe. +-- +-- @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 + + where + + state = Tuple' (Consume stateL) (Consume stateR) + + 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 + + -- 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) + +instance Monad m => Category (Pipe m) where + {-# INLINE id #-} + id = map Prelude.id + + {-# INLINE (.) #-} + (.) = compose + +unzip :: Pipe m a x -> Pipe m b y -> Pipe m (a, b) (x, y) +unzip = undefined + +instance Monad m => Arrow (Pipe m) where + {-# INLINE arr #-} + arr = map + + {-# INLINE (***) #-} + (***) = unzip + + {-# INLINE (&&&) #-} + (&&&) = zipWith (,) diff --git a/src/Streamly/Internal/Data/Producer.hs b/src/Streamly/Internal/Data/Producer.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Producer.hs @@ -0,0 +1,88 @@ +-- | +-- Module : Streamly.Internal.Data.Producer +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A 'Producer' is an 'Unfold' with an 'extract' function added to extract +-- the state. It is more powerful but less general than an Unfold. +-- +-- A 'Producer' represents steps of a loop generating a sequence of elements. +-- While unfolds are closed representation of imperative loops with some opaque +-- internal state, producers are open loops with the state being accessible to +-- the user. +-- +-- Unlike an unfold, which runs a loop till completion, a producer can be +-- stopped in the middle, its state can be extracted, examined, changed, and +-- then it can be resumed later from the stopped state. +-- +-- A producer can be used in places where a CPS stream would otherwise be +-- needed, because the state of the loop can be passed around. However, it can +-- be much more efficient than CPS because it allows stream fusion and +-- unecessary function calls can be avoided. + +module Streamly.Internal.Data.Producer + ( Producer (..) + + -- * 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.SVar.Type (defState) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) + +import Streamly.Internal.Data.Producer.Type +import Prelude hiding (concat) + +-- XXX We should write unfolds as producers where possible and define +-- unfolds using "simplify". +-- +------------------------------------------------------------------------------- +-- Converting to unfolds +------------------------------------------------------------------------------- + +-- | Simplify a producer to an unfold. +-- +-- /Pre-release/ +{-# INLINE simplify #-} +simplify :: Producer m a b -> Unfold m a b +simplify (Producer step inject _) = Unfold step inject + +------------------------------------------------------------------------------- +-- Unfolds +------------------------------------------------------------------------------- + +-- | Convert a StreamD stream into a producer. +-- +-- /Pre-release/ +{-# INLINE_NORMAL fromStreamD #-} +fromStreamD :: Monad m => Producer m (Stream m a) a +fromStreamD = Producer step return return + + where + + {-# INLINE_LATE step #-} + step (UnStream step1 state1) = do + r <- step1 defState state1 + return $ case r of + Yield x s -> Yield x (Stream step1 s) + Skip s -> Skip (Stream step1 s) + Stop -> Stop diff --git a/src/Streamly/Internal/Data/Producer/Source.hs b/src/Streamly/Internal/Data/Producer/Source.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Producer/Source.hs @@ -0,0 +1,290 @@ +-- | +-- Module : Streamly.Internal.Data.Producer.Source +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A 'Source' is a seed that can be unfolded to a stream with a buffer. Allows +-- to 'unread' data i.e. push unused data back to the source buffer. This is +-- useful in parsing applications with backtracking. +-- + +module Streamly.Internal.Data.Producer.Source + ( Source + + -- * Creation + , source + + -- * Transformation + , unread + + -- * Consumption + , isEmpty + , producer + + -- * Parsing + , parse + , parseMany + , parseManyD + ) +where + +#include "inline.hs" + +import Control.Exception (assert) +import GHC.Exts (SpecConstrAnnotation(..)) +import GHC.Types (SPEC(..)) +import Streamly.Internal.Data.Parser.ParserD (ParseError(..), Step(..)) +import Streamly.Internal.Data.Producer.Type (Producer(..)) +import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) + +import qualified Streamly.Internal.Data.Parser.ParserD as ParserD +-- import qualified Streamly.Internal.Data.Parser.ParserK.Type as ParserK + +import Prelude hiding (read) + +-- | A seed with a buffer. It allows us to 'unread' or return some data +-- after reading it. Useful in backtracked parsing. +-- +data Source a b = Source [b] (Maybe a) + +-- | Make a source from a seed value. The buffer would start as empty. +-- +-- /Pre-release/ +source :: Maybe a -> Source a b +source = Source [] + +-- | Return some unused data back to the source. The data is prepended (or +-- consed) to the source. +-- +-- /Pre-release/ +unread :: [b] -> Source a b -> Source a b +unread xs (Source ys seed) = Source (xs ++ ys) seed + +-- | Determine if the source is empty. +isEmpty :: Source a b -> Bool +isEmpty (Source [] Nothing) = True +isEmpty _ = False + +-- | Convert a producer to a producer from a buffered source. Any buffered data +-- is read first and then the seed is unfolded. +-- +-- /Pre-release/ +{-# INLINE_NORMAL producer #-} +producer :: Monad m => Producer m a b -> Producer m (Source a b) b +producer (Producer step1 inject1 extract1) = Producer step inject extract + + where + + inject (Source [] (Just a)) = do + s <- inject1 a + return $ Left s + inject (Source xs a) = return $ Right (xs, a) + + {-# INLINE_LATE step #-} + step (Left s) = do + r <- step1 s + return $ case r of + Yield x s1 -> Yield x (Left s1) + Skip s1 -> Skip (Left s1) + Stop -> Stop + step (Right ([], Nothing)) = return Stop + step (Right ([], Just _)) = error "Bug: unreachable" + step (Right (x:[], Just a)) = do + s <- inject1 a + return $ Yield x (Left s) + step (Right (x:xs, a)) = return $ Yield x (Right (xs, a)) + + extract (Left s) = Source [] . Just <$> extract1 s + extract (Right (xs, a)) = return $ Source xs a + +------------------------------------------------------------------------------- +-- Parsing +------------------------------------------------------------------------------- + +-- 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]} + +{-# INLINE_NORMAL parse #-} +parse + :: Monad m => + ParserD.Parser a m b + -> Producer m (Source s a) a + -> Source s a + -> m (Either ParseError b, Source s a) +parse + (ParserD.Parser pstep initial extract) + (Producer ustep uinject uextract) + seed = do + + res <- initial + case res of + ParserD.IPartial s -> do + state <- uinject seed + go SPEC state (List []) s + ParserD.IDone b -> return (Right b, seed) + ParserD.IError err -> return (Left (ParseError 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 + 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 + 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 + 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 + 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 + s1 <- uextract s + return (Left (ParseError err), unread [x] s1) + Skip s -> go SPEC s buf pst + Stop -> goStop buf pst + + 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 + Partial 0 pst1 -> + gobuf SPEC s (List []) (List xs) pst1 + 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 + Continue 0 pst1 -> + gobuf SPEC s (List (x:getList buf)) (List xs) pst1 + 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 + Done n b -> do + 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 + s1 <- uextract s + return (Left (ParseError err), unread (x:xs) s1) + + -- This is a simplified gobuf + goExtract !_ buf (List []) !pst = goStop buf pst + goExtract !_ buf (List (x:xs)) !pst = do + pRes <- pstep pst x + case pRes of + Partial 0 pst1 -> + goExtract SPEC (List []) (List xs) pst1 + 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 + Continue 0 pst1 -> + goExtract SPEC (List (x:getList buf)) (List xs) pst1 + 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 + 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, unread src (source Nothing)) + Error err -> + return (Left (ParseError err), unread (x:xs) (source Nothing)) + + -- This is a simplified goExtract + {-# INLINE goStop #-} + goStop buf pst = do + pRes <- extract pst + case pRes of + Partial _ _ -> error "Bug: parseD: Partial in extract" + Continue 0 pst1 -> + goStop buf pst1 + 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 + Done 0 b -> return (Right b, source Nothing) + Done n b -> do + 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) + +{- +-- | Parse a buffered source using a parser, returning the parsed value and the +-- remaining source. +-- +-- /Pre-release/ +{-# INLINE [3] parseK #-} +parseK :: Monad m => + ParserK.Parser a m b + -> Producer m (Source s a) a + -> Source s a + -> m (Either ParseError b, Source s a) +parseK = parse . ParserK.toParser +-} + +------------------------------------------------------------------------------- +-- Nested parsing +------------------------------------------------------------------------------- + +{-# INLINE parseManyD #-} +parseManyD :: Monad m => + ParserD.Parser a m b + -> Producer m (Source x a) a + -> Producer m (Source x a) (Either ParseError b) +parseManyD parser reader = Producer step return return + + where + + {-# INLINE_LATE step #-} + step src = do + if isEmpty src + then return Stop + else do + (b, s1) <- parse parser reader src + case b of + Right b1 -> return $ Yield (Right b1) s1 + Left _ -> return Stop + +-- | Apply a parser repeatedly on a buffered source producer to generate a +-- producer of parsed values. +-- +-- /Pre-release/ +{-# INLINE parseMany #-} +parseMany :: Monad m => + ParserD.Parser a m b + -> Producer m (Source x a) a + -> Producer m (Source x a) (Either ParseError b) +parseMany = parseManyD diff --git a/src/Streamly/Internal/Data/Producer/Type.hs b/src/Streamly/Internal/Data/Producer/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Producer/Type.hs @@ -0,0 +1,186 @@ +-- | +-- Module : Streamly.Internal.Data.Producer.Type +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- See "Streamly.Internal.Data.Producer" for introduction. +-- + +module Streamly.Internal.Data.Producer.Type + ( + -- * Type + Producer (..) + + -- * Producers + , nil + , nilM + , unfoldrM + , fromList + + -- * Mapping + , translate + , lmap + + -- * Nesting + , NestedLoop (..) + , concat + ) +where + +#include "inline.hs" + +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) +import Prelude hiding (concat, map) + +------------------------------------------------------------------------------ +-- Type +------------------------------------------------------------------------------ + +-- | 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@. +-- +-- /Pre-release/ + +data Producer m a b = + -- | @Producer step inject extract@ + forall s. Producer (s -> m (Step s b)) (a -> m s) (s -> m a) + +------------------------------------------------------------------------------ +-- Producers +------------------------------------------------------------------------------ + +{-# INLINE nilM #-} +nilM :: Monad m => (a -> m c) -> Producer m a b +nilM f = Producer step return return + + where + + {-# INLINE_LATE step #-} + step x = f x >> return Stop + +{-# INLINE nil #-} +nil :: Monad m => Producer m a b +nil = nilM (\_ -> return ()) + +{-# INLINE unfoldrM #-} +unfoldrM :: Monad m => (a -> m (Maybe (b, a))) -> Producer m a b +unfoldrM next = Producer step return return + + where + + {-# INLINE_LATE step #-} + step st = do + r <- next st + return $ case r of + Just (x, s) -> Yield x s + Nothing -> Stop + +-- | Convert a list of pure values to a 'Stream' +-- +-- /Pre-release/ +{-# INLINE_LATE fromList #-} +fromList :: Monad m => Producer m [a] a +fromList = Producer step return return + + where + + {-# INLINE_LATE step #-} + step (x:xs) = return $ Yield x xs + step [] = return Stop + +------------------------------------------------------------------------------ +-- Mapping +------------------------------------------------------------------------------ + +-- | Interconvert the producer between two interconvertible input types. +-- +-- /Pre-release/ +{-# INLINE_NORMAL translate #-} +translate :: Functor m => + (a -> c) -> (c -> a) -> Producer m c b -> Producer m a b +translate f g (Producer step inject extract) = + Producer step (inject . f) (fmap g . extract) + +-- | Map the producer input to another value of the same type. +-- +-- /Pre-release/ +{-# INLINE_NORMAL lmap #-} +lmap :: (a -> a) -> Producer m a b -> Producer m a b +lmap f (Producer step inject extract) = Producer step (inject . f) extract + +------------------------------------------------------------------------------ +-- Functor +------------------------------------------------------------------------------ + +-- | Map a function on the output of the producer (the type @b@). +-- +-- /Pre-release/ +{-# INLINE_NORMAL map #-} +map :: Functor m => (b -> c) -> Producer m a b -> Producer m a c +map f (Producer ustep uinject uextract) = Producer step uinject uextract + + where + + {-# INLINE_LATE step #-} + step st = fmap (fmap f) (ustep st) + +-- | Maps a function on the output of the producer (the type @b@). +instance Functor m => Functor (Producer m a) where + {-# INLINE fmap #-} + fmap = map + +------------------------------------------------------------------------------ +-- Nesting +------------------------------------------------------------------------------ + +-- | State representing a nested loop. +{-# ANN type NestedLoop Fuse #-} +data NestedLoop s1 s2 = OuterLoop s1 | InnerLoop s1 s2 + +-- | Apply the second unfold to each output element of the first unfold and +-- flatten the output in a single stream. +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL concat #-} +concat :: Monad m => + Producer m a b -> Producer m b c -> Producer m (NestedLoop a b) c +concat (Producer step1 inject1 extract1) (Producer step2 inject2 extract2) = + Producer step inject extract + + where + + inject (OuterLoop x) = do + s <- inject1 x + return $ OuterLoop s + inject (InnerLoop x y) = do + s1 <- inject1 x + s2 <- inject2 y + return $ InnerLoop s1 s2 + + {-# INLINE_LATE step #-} + step (OuterLoop st) = do + r <- step1 st + case r of + Yield x s -> do + innerSt <- inject2 x + return $ Skip (InnerLoop s innerSt) + Skip s -> return $ Skip (OuterLoop s) + Stop -> return Stop + + step (InnerLoop ost ist) = do + r <- step2 ist + return $ case r of + Yield x s -> Yield x (InnerLoop ost s) + Skip s -> Skip (InnerLoop ost s) + Stop -> Skip (OuterLoop ost) + + extract (OuterLoop s1) = OuterLoop <$> extract1 s1 + extract (InnerLoop s1 s2) = do + r1 <- extract1 s1 + r2 <- extract2 s2 + return (InnerLoop r1 r2) diff --git a/src/Streamly/Internal/Data/Refold/Type.hs b/src/Streamly/Internal/Data/Refold/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Refold/Type.hs @@ -0,0 +1,251 @@ +-- | +-- Module : Streamly.Internal.Data.Refold.Type +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- The 'Fold' type embeds a default initial value, therefore, it is like a +-- 'Monoid' whereas the 'Refold' type has to be supplied with an initial +-- value, therefore, it is more like a 'Semigroup' operation. +-- +-- Refolds can be appended to each other or to a fold to build the fold +-- incrementally. This is useful in incremental builder like use cases. +-- +-- See the file splitting example in the @streamly-examples@ repository for an +-- application of the 'Refold' type. The 'Fold' type does not perform as well +-- in this situation. +-- +-- 'Refold' type is to 'Fold' as 'Unfold' type is to 'Stream'. 'Unfold' +-- provides better optimizaiton than stream in nested operations, similarly, +-- 'Refold' provides better optimization than 'Fold'. +-- +module Streamly.Internal.Data.Refold.Type + ( + -- * Types + Refold (..) + + -- * Constructors + , foldl' + + -- * Refolds + -- ** Accumulators + , sconcat + , drainBy + , iterate + + -- * Combinators + , lmapM + , rmapM + , append + , take + ) +where + +import Control.Monad ((>=>)) +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Data.Fold.Step (Step(..), mapMStep) + +import Prelude hiding (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.Stream as Stream + +-- All folds in the Fold module should be implemented using Refolds. +-- +-- | Like 'Fold' except that the initial state of the accmulator can be +-- generated using a dynamically supplied input. This affords better stream +-- fusion optimization in nested fold operations where the initial fold state +-- is determined based on a dynamic value. +-- +-- /Internal/ +data Refold m c a b = + -- | @Fold @ @ step @ @ inject @ @ extract@ + forall s. Refold (s -> a -> m (Step s b)) (c -> m (Step s b)) (s -> m b) + +------------------------------------------------------------------------------ +-- Left fold constructors +------------------------------------------------------------------------------ + +-- | Make a consumer from a left fold style pure step function. +-- +-- If your 'Fold' returns only 'Partial' (i.e. never returns a 'Done') then you +-- can use @foldl'*@ constructors. +-- +-- See also: @Streamly.Data.Fold.foldl'@ +-- +-- /Internal/ +-- +{-# INLINE foldl' #-} +foldl' :: Monad m => (b -> a -> b) -> Refold m b a b +foldl' step = + Refold + (\s a -> return $ Partial $ step s a) + (return . Partial) + return + +------------------------------------------------------------------------------ +-- Mapping on input +------------------------------------------------------------------------------ + +-- | @lmapM f fold@ maps the monadic function @f@ on the input of the fold. +-- +-- /Internal/ +{-# INLINE lmapM #-} +lmapM :: Monad m => (a -> m b) -> Refold m c b r -> Refold m c a r +lmapM f (Refold step inject extract) = Refold step1 inject extract + + where + + step1 x a = f a >>= step x + +------------------------------------------------------------------------------ +-- Mapping on the output +------------------------------------------------------------------------------ + +-- | Map a monadic function on the output of a fold. +-- +-- /Internal/ +{-# INLINE rmapM #-} +rmapM :: Monad m => (b -> m c) -> Refold m x a b -> Refold m x a c +rmapM f (Refold step inject extract) = Refold step1 inject1 (extract >=> f) + + where + + inject1 x = inject x >>= mapMStep f + step1 s a = step s a >>= mapMStep f + +------------------------------------------------------------------------------ +-- Refolds +------------------------------------------------------------------------------ + +-- | +-- +-- /Internal/ +{-# INLINE drainBy #-} +drainBy :: Monad m => (c -> a -> m b) -> Refold m c a () +drainBy f = Refold step inject extract + + where + + inject = return . Partial + + step c a = f c a >> return (Partial c) + + extract _ = return () + +------------------------------------------------------------------------------ +-- Semigroup +------------------------------------------------------------------------------ + +-- | Append the elements of an input stream to a provided starting value. +-- +-- >>> stream = fmap Data.Monoid.Sum $ Stream.enumerateFromTo 1 10 +-- >>> Stream.fold (Fold.fromRefold Refold.sconcat 10) stream +-- Sum {getSum = 65} +-- +-- >>> sconcat = Refold.foldl' (<>) +-- +-- /Internal/ +{-# INLINE sconcat #-} +sconcat :: (Monad m, Semigroup a) => Refold m a a a +sconcat = foldl' (<>) + +------------------------------------------------------------------------------ +-- append +------------------------------------------------------------------------------ + +-- | Supply the output of the first consumer as input to the second consumer. +-- +-- /Internal/ +{-# INLINE append #-} +append :: Monad m => Refold m x a b -> Refold m b a b -> Refold m x a b +append (Refold step1 inject1 extract1) (Refold step2 inject2 extract2) = + Refold step inject extract + + where + + goLeft r = do + case r of + Partial s -> return $ Partial $ Left s + Done b -> do + r1 <- inject2 b + return $ case r1 of + Partial s -> Partial $ Right s + Done b1 -> Done b1 + + inject x = inject1 x >>= goLeft + + step (Left s) a = step1 s a >>= goLeft + + step (Right s) a = do + r <- step2 s a + case r of + Partial s1 -> return $ Partial (Right s1) + Done b -> return $ Done b + + extract (Left s) = extract1 s + extract (Right s) = extract2 s + +-- | Keep running the same consumer over and over again on the input, feeding +-- the output of the previous run to the next. +-- +-- /Internal/ +iterate :: Monad m => Refold m b a b -> Refold m b a b +iterate (Refold step1 inject1 extract1) = + Refold step inject extract1 + + where + + go r = + case r of + Partial s -> return $ Partial s + Done b -> inject b + + inject x = inject1 x >>= go + + step s a = step1 s a >>= go + +------------------------------------------------------------------------------ +-- Transformation +------------------------------------------------------------------------------ + +-- 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 + +-- | Take at most @n@ input elements and fold them using the supplied fold. A +-- negative count is treated as 0. +-- +-- /Internal/ +{-# INLINE take #-} +take :: Monad m => Int -> Refold m x a b -> Refold m x a b +take n (Refold fstep finject fextract) = Refold step inject extract + + where + + inject x = do + res <- finject x + case res of + Partial s -> + if n > 0 + then return $ Partial $ Tuple'Fused 0 s + else Done <$> fextract s + Done b -> return $ Done b + + step (Tuple'Fused i r) a = do + res <- fstep r a + case res of + Partial sres -> do + let i1 = i + 1 + s1 = Tuple'Fused i1 sres + if i1 < n + then return $ Partial s1 + else Done <$> fextract sres + Done bres -> return $ Done bres + + extract (Tuple'Fused _ r) = fextract r diff --git a/src/Streamly/Internal/Data/Ring.hs b/src/Streamly/Internal/Data/Ring.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Ring.hs @@ -0,0 +1,164 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Ring/Unboxed.hs @@ -0,0 +1,615 @@ +-- | +-- 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/SVar/Type.hs b/src/Streamly/Internal/Data/SVar/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/SVar/Type.hs @@ -0,0 +1,540 @@ +-- | +-- Module : Streamly.Internal.Data.SVar.Type +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.SVar.Type + ( + -- * Parent child communication + ThreadAbort (..) + , ChildEvent (..) + , RunInIO(..) + , AheadHeapEntry (..) + + -- * SVar + , Count (..) + , Limit (..) + , SVarStyle (..) + , SVarStopStyle (..) + , SVarStats (..) + , WorkerInfo (..) + , PushBufferPolicy(..) + , LatencyRange (..) + , YieldRateInfo (..) + , SVar (..) + + -- * State threaded around the stream + , Rate (..) + , State (streamVar) + + -- ** Default State + , magicMaxBuffer + , defState + + -- ** Type cast + , adaptState + + -- ** State accessors + , getMaxThreads + , setMaxThreads + , getMaxBuffer + , setMaxBuffer + , getStreamRate + , setStreamRate + , getStreamLatency + , setStreamLatency + , getYieldLimit + , setYieldLimit + , getInspectMode + , setInspectMode + ) +where + +import Control.Concurrent (ThreadId) +import Control.Concurrent.MVar (MVar) +import Control.Exception (SomeException(..), Exception) +#ifndef USE_UNLIFTIO +import Control.Monad.Trans.Control (MonadBaseControl(StM)) +#endif +import Data.Heap (Heap, Entry(..)) +import Data.Int (Int64) +import Data.IORef (IORef) +import Data.Kind (Type) +import Data.Set (Set) + +import Streamly.Internal.Data.Time.Units (AbsTime, NanoSecond64(..)) + +newtype Count = Count Int64 + deriving ( Eq + , Read + , Show + , Enum + , Bounded + , Num + , Real + , Integral + , Ord + ) + +------------------------------------------------------------------------------ +-- Parent child thread communication type +------------------------------------------------------------------------------ + +data ThreadAbort = ThreadAbort deriving Show + +instance Exception ThreadAbort + +-- | Events that a child thread may send to a parent thread. +data ChildEvent a = + ChildYield a + | ChildStop ThreadId (Maybe SomeException) + +#ifdef USE_UNLIFTIO +newtype RunInIO m = RunInIO { runInIO :: forall b. m b -> IO b } +#else +newtype RunInIO m = RunInIO { runInIO :: forall b. m b -> IO (StM m b) } +#endif + +-- | Sorting out-of-turn outputs in a heap for Ahead style streams +data AheadHeapEntry (t :: (Type -> Type) -> Type -> Type) m a = + AheadEntryNull + | AheadEntryPure a + | AheadEntryStream (RunInIO m, t m a) +#undef Type + +------------------------------------------------------------------------------ +-- SVar: the state for thread management +------------------------------------------------------------------------------ + +-- | Identify the type of the SVar. Two computations using the same style can +-- be scheduled on the same SVar. +data SVarStyle = + AsyncVar -- depth first concurrent + | WAsyncVar -- breadth first concurrent + | ParallelVar -- all parallel + | AheadVar -- Concurrent look ahead + deriving (Eq, Show) + +-- | An SVar or a Stream Var is a conduit to the output from multiple streams +-- running concurrently and asynchronously. An SVar can be thought of as an +-- asynchronous IO handle. We can write any number of streams to an SVar in a +-- non-blocking manner and then read them back at any time at any pace. The +-- SVar would run the streams asynchronously and accumulate results. An SVar +-- may not really execute the stream completely and accumulate all the results. +-- However, it ensures that the reader can read the results at whatever paces +-- it wants to read. The SVar monitors and adapts to the consumer's pace. +-- +-- An SVar is a mini scheduler, it has an associated workLoop that holds the +-- stream tasks to be picked and run by a pool of worker threads. It has an +-- associated output queue where the output stream elements are placed by the +-- worker threads. A outputDoorBell is used by the worker threads to intimate the +-- consumer thread about availability of new results in the output queue. More +-- workers are added to the SVar by 'fromStreamVar' on demand if the output +-- produced is not keeping pace with the consumer. On bounded SVars, workers +-- block on the output queue to provide throttling of the producer when the +-- consumer is not pulling fast enough. The number of workers may even get +-- reduced depending on the consuming pace. +-- +-- New work is enqueued either at the time of creation of the SVar or as a +-- result of executing the parallel combinators i.e. '<|' and '<|>' when the +-- already enqueued computations get evaluated. See 'joinStreamVarAsync'. + +-- We measure the individual worker latencies to estimate the number of workers +-- needed or the amount of time we have to sleep between dispatches to achieve +-- a particular rate when controlled pace mode it used. +data WorkerInfo = WorkerInfo + { workerYieldMax :: Count -- 0 means unlimited + -- total number of yields by the worker till now + , workerYieldCount :: IORef Count + -- yieldCount at start, timestamp + , workerLatencyStart :: IORef (Count, AbsTime) + } + +data LatencyRange = LatencyRange + { minLatency :: NanoSecond64 + , maxLatency :: NanoSecond64 + } deriving Show + +-- Rate control. +data YieldRateInfo = YieldRateInfo + { svarLatencyTarget :: NanoSecond64 + , svarLatencyRange :: LatencyRange + , svarRateBuffer :: Int + + -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely + -- read by the worker threads + , svarGainedLostYields :: IORef Count + + -- Actual latency/througput as seen from the consumer side, we count the + -- yields and the time it took to generates those yields. This is used to + -- increase or decrease the number of workers needed to achieve the desired + -- rate. The idle time of workers is adjusted in this, so that we only + -- account for the rate when the consumer actually demands data. + -- XXX interval latency is enough, we can move this under diagnostics build + -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely + -- read by the worker threads + , svarAllTimeLatency :: IORef (Count, AbsTime) + + -- XXX Worker latency specified by the user to be used before the first + -- actual measurement arrives. Not yet implemented + , workerBootstrapLatency :: Maybe NanoSecond64 + + -- After how many yields the worker should update the latency information. + -- If the latency is high, this count is kept lower and vice-versa. XXX If + -- the latency suddenly becomes too high this count may remain too high for + -- long time, in such cases the consumer can change it. + -- 0 means no latency computation + -- XXX this is derivable from workerMeasuredLatency, can be removed. + -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely + -- read by the worker threads + , workerPollingInterval :: IORef Count + + -- This is in progress latency stats maintained by the workers which we + -- empty into workerCollectedLatency stats at certain intervals - whenever + -- we process the stream elements yielded in this period. The first count + -- is all yields, the second count is only those yields for which the + -- latency was measured to be non-zero (note that if the timer resolution + -- is low the measured latency may be zero e.g. on JS platform). + -- [LOCKING] Locked access. Modified by the consumer thread as well as + -- worker threads. Workers modify it periodically based on + -- workerPollingInterval and not on every yield to reduce the locking + -- overhead. + -- (allYieldCount, yieldCount, timeTaken) + , workerPendingLatency :: IORef (Count, Count, NanoSecond64) + + -- This is the second level stat which is an accmulation from + -- workerPendingLatency stats. We keep accumulating latencies in this + -- bucket until we have stats for a sufficient period and then we reset it + -- to start collecting for the next period and retain the computed average + -- latency for the last period in workerMeasuredLatency. + -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely + -- read by the worker threads + -- (allYieldCount, yieldCount, timeTaken) + , workerCollectedLatency :: IORef (Count, Count, NanoSecond64) + + -- Latency as measured by workers, aggregated for the last period. + -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely + -- read by the worker threads + , workerMeasuredLatency :: IORef NanoSecond64 + } + +data SVarStats = SVarStats { + totalDispatches :: IORef Int + , maxWorkers :: IORef Int + , maxOutQSize :: IORef Int + , maxHeapSize :: IORef Int + , maxWorkQSize :: IORef Int + , avgWorkerLatency :: IORef (Count, NanoSecond64) + , minWorkerLatency :: IORef NanoSecond64 + , maxWorkerLatency :: IORef NanoSecond64 + , svarStopTime :: IORef (Maybe AbsTime) +} + +-- This is essentially a 'Maybe Word' type +data Limit = Unlimited | Limited Word deriving Show + +instance Eq Limit where + Unlimited == Unlimited = True + Unlimited == Limited _ = False + Limited _ == Unlimited = False + Limited x == Limited y = x == y + +instance Ord Limit where + Unlimited <= Unlimited = True + Unlimited <= Limited _ = False + Limited _ <= Unlimited = True + Limited x <= Limited y = x <= y + +-- When to stop the composed stream. +data SVarStopStyle = + StopNone -- stops only when all streams are finished + | StopAny -- stop when any stream finishes + | StopBy -- stop when a specific stream finishes + deriving (Eq, Show) + +-- | Buffering policy for persistent push workers (in ParallelT). In a pull +-- style SVar (in AsyncT, AheadT etc.), the consumer side dispatches workers on +-- demand, workers terminate if the buffer is full or if the consumer is not +-- cosuming fast enough. In a push style SVar, a worker is dispatched only +-- once, workers are persistent and keep pushing work to the consumer via a +-- bounded buffer. If the buffer becomes full the worker either blocks, or it +-- can drop an item from the buffer to make space. +-- +-- Pull style SVars are useful in lazy stream evaluation whereas push style +-- SVars are useful in strict left Folds. +-- +-- XXX Maybe we can separate the implementation in two different types instead +-- of using a common SVar type. +-- +data PushBufferPolicy = + PushBufferDropNew -- drop the latest element and continue + | PushBufferDropOld -- drop the oldest element and continue + | PushBufferBlock -- block the thread until space + -- becomes available + +-- IMPORTANT NOTE: we cannot update the SVar after generating it as we have +-- references to the original SVar stored in several functions which will keep +-- pointing to the original data and the new updates won't reflect there. +-- Any updateable parts must be kept in mutable references (IORef). +-- +data SVar t m a = SVar + { + -- Read only state + svarStyle :: SVarStyle + , svarMrun :: RunInIO m + , svarStopStyle :: SVarStopStyle + , svarStopBy :: IORef ThreadId + + -- Shared output queue (events, length) + -- XXX For better efficiency we can try a preallocated array type (perhaps + -- something like a vector) that allows an O(1) append. That way we will + -- avoid constructing and reversing the list. Possibly we can also avoid + -- the GC copying overhead. When the size increases we should be able to + -- allocate the array in chunks. + -- + -- [LOCKING] Frequent locked access. This is updated by workers on each + -- yield and once in a while read by the consumer thread. This could have + -- big locking overhead if the number of workers is high. + -- + -- XXX We can use a per-CPU data structure to reduce the locking overhead. + -- However, a per-cpu structure cannot guarantee the exact sequence in + -- which the elements were added, though that may not be important. + , outputQueue :: IORef ([ChildEvent a], Int) + + -- [LOCKING] Infrequent MVar. Used when the outputQ transitions from empty + -- to non-empty, or a work item is queued by a worker to the work queue and + -- needDoorBell is set by the consumer. + , outputDoorBell :: MVar () -- signal the consumer about output + , readOutputQ :: m [ChildEvent a] + , postProcess :: m Bool + + -- channel to send events from the consumer to the worker. Used to send + -- exceptions from a fold driver to the fold computation running as a + -- consumer thread in the concurrent fold cases. Currently only one event + -- is sent by the fold so we do not really need a queue for it. + , outputQueueFromConsumer :: IORef ([ChildEvent a], Int) + , outputDoorBellFromConsumer :: MVar () + + -- Combined/aggregate parameters + -- This is truncated to maxBufferLimit if set to more than that. Otherwise + -- potentially each worker may yield one value to the buffer in the worst + -- case exceeding the requested buffer size. + , maxWorkerLimit :: Limit + , maxBufferLimit :: Limit + -- These two are valid and used only when maxBufferLimit is Limited. + , pushBufferSpace :: IORef Count + , pushBufferPolicy :: PushBufferPolicy + -- [LOCKING] The consumer puts this MVar after emptying the buffer, workers + -- block on it when the buffer becomes full. No overhead unless the buffer + -- becomes full. + , pushBufferMVar :: MVar () + + -- [LOCKING] Read only access by consumer when dispatching a worker. + -- Decremented by workers when picking work and undo decrement if the + -- worker does not yield a value. + , remainingWork :: Maybe (IORef Count) + , yieldRateInfo :: Maybe YieldRateInfo + + -- Used only by bounded SVar types + , enqueue :: (RunInIO m, t m a) -> IO () + , isWorkDone :: IO Bool + , isQueueDone :: IO Bool + , needDoorBell :: IORef Bool + , workLoop :: Maybe WorkerInfo -> m () + + -- Shared, thread tracking + -- [LOCKING] Updated unlocked only by consumer thread in case of + -- Async/Ahead style SVars. Updated locked by worker threads in case of + -- Parallel style. + , workerThreads :: IORef (Set ThreadId) + -- [LOCKING] Updated locked by consumer thread when dispatching a worker + -- and by the worker threads when the thread stops. This is read unsafely + -- at several places where we want to rely on an approximate value. + , workerCount :: IORef Int + , accountThread :: ThreadId -> m () + , workerStopMVar :: MVar () + + , svarStats :: SVarStats + -- to track garbage collection of SVar + , svarRef :: Maybe (IORef ()) + + -- Only for diagnostics + , svarInspectMode :: Bool + , svarCreator :: ThreadId + , outputHeap :: IORef ( Heap (Entry Int (AheadHeapEntry t m a)) + , Maybe Int) + -- Shared work queue (stream, seqNo) + , aheadWorkQueue :: IORef ([t m a], Int) + } + +------------------------------------------------------------------------------- +-- Overall state threaded around a stream +------------------------------------------------------------------------------- + +-- | Specifies the stream yield rate in yields per second (@Hertz@). +-- We keep accumulating yield credits at 'rateGoal'. At any point of time we +-- allow only as many yields as we have accumulated as per 'rateGoal' since the +-- start of time. If the consumer or the producer is slower or faster, the +-- actual rate may fall behind or exceed 'rateGoal'. We try to recover the gap +-- between the two by increasing or decreasing the pull rate from the producer. +-- However, if the gap becomes more than 'rateBuffer' we try to recover only as +-- much as 'rateBuffer'. +-- +-- 'rateLow' puts a bound on how low the instantaneous rate can go when +-- recovering the rate gap. In other words, it determines the maximum yield +-- latency. Similarly, 'rateHigh' puts a bound on how high the instantaneous +-- rate can go when recovering the rate gap. In other words, it determines the +-- minimum yield latency. We reduce the latency by increasing concurrency, +-- therefore we can say that it puts an upper bound on concurrency. +-- +-- If the 'rateGoal' is 0 or negative the stream never yields a value. +-- If the 'rateBuffer' is 0 or negative we do not attempt to recover. +-- +-- /Since: 0.5.0 ("Streamly")/ +-- +-- @since 0.8.0 +data Rate = Rate + { rateLow :: Double -- ^ The lower rate limit + , rateGoal :: Double -- ^ The target rate we want to achieve + , rateHigh :: Double -- ^ The upper rate limit + , rateBuffer :: Int -- ^ Maximum slack from the goal + } + +-- XXX we can put the resettable fields in a oneShotConfig field and others in +-- a persistentConfig field. That way reset would be fast and scalable +-- irrespective of the number of fields. +-- +-- XXX make all these Limited types and use phantom types to distinguish them +data State t m a = State + { -- one shot configuration, automatically reset for each API call + streamVar :: Maybe (SVar t m a) + , _yieldLimit :: Maybe Count + + -- persistent configuration, state that remains valid until changed by + -- an explicit setting via a combinator. + , _threadsHigh :: Limit + , _bufferHigh :: Limit + -- XXX these two can be collapsed into a single type + , _streamLatency :: Maybe NanoSecond64 -- bootstrap latency + , _maxStreamRate :: Maybe Rate + , _inspectMode :: Bool + } + +------------------------------------------------------------------------------- +-- State defaults and reset +------------------------------------------------------------------------------- + +-- A magical value for the buffer size arrived at by running the smallest +-- possible task and measuring the optimal value of the buffer for that. This +-- is obviously dependent on hardware, this figure is based on a 2.2GHz intel +-- core-i7 processor. +magicMaxBuffer :: Word +magicMaxBuffer = 1500 + +defaultMaxThreads, defaultMaxBuffer :: Limit +defaultMaxThreads = Limited magicMaxBuffer +defaultMaxBuffer = Limited magicMaxBuffer + +-- The fields prefixed by an _ are not to be accessed or updated directly but +-- via smart accessor APIs. +defState :: State t m a +defState = State + { streamVar = Nothing + , _yieldLimit = Nothing + , _threadsHigh = defaultMaxThreads + , _bufferHigh = defaultMaxBuffer + , _maxStreamRate = Nothing + , _streamLatency = Nothing + , _inspectMode = False + } + +-- XXX if perf gets affected we can have all the Nothing params in a single +-- structure so that we reset is fast. We can also use rewrite rules such that +-- reset occurs only in concurrent streams to reduce the impact on serial +-- streams. +-- We can optimize this so that we clear it only if it is a Just value, it +-- results in slightly better perf for zip/zipM but the performance of scan +-- worsens a lot, it does not fuse. +-- +-- XXX This has a side effect of clearing the SVar and yieldLimit, therefore it +-- should not be used to convert from the same type to the same type, unless +-- you want to clear the SVar. For clearing the SVar you should be using the +-- appropriate unStream functions instead. +-- +-- | Adapt the stream state from one type to another. +adaptState :: State t m a -> State t n b +adaptState st = st + { streamVar = Nothing + , _yieldLimit = Nothing + } + +------------------------------------------------------------------------------- +-- Smart get/set routines for State +------------------------------------------------------------------------------- + +-- Use get/set routines instead of directly accessing the State fields +setYieldLimit :: Maybe Int64 -> State t m a -> State t m a +setYieldLimit lim st = + st { _yieldLimit = + case lim of + Nothing -> Nothing + Just n -> + if n <= 0 + then Just 0 + else Just (fromIntegral n) + } + +getYieldLimit :: State t m a -> Maybe Count +getYieldLimit = _yieldLimit + +setMaxThreads :: Int -> State t m a -> State t m a +setMaxThreads n st = + st { _threadsHigh = + if n < 0 + then Unlimited + else if n == 0 + then defaultMaxThreads + else Limited (fromIntegral n) + } + +getMaxThreads :: State t m a -> Limit +getMaxThreads = _threadsHigh + +setMaxBuffer :: Int -> State t m a -> State t m a +setMaxBuffer n st = + st { _bufferHigh = + if n < 0 + then Unlimited + else if n == 0 + then defaultMaxBuffer + else Limited (fromIntegral n) + } + +getMaxBuffer :: State t m a -> Limit +getMaxBuffer = _bufferHigh + +setStreamRate :: Maybe Rate -> State t m a -> State t m a +setStreamRate r st = st { _maxStreamRate = r } + +getStreamRate :: State t m a -> Maybe Rate +getStreamRate = _maxStreamRate + +setStreamLatency :: Int -> State t m a -> State t m a +setStreamLatency n st = + st { _streamLatency = + if n <= 0 + then Nothing + else Just (fromIntegral n) + } + +getStreamLatency :: State t m a -> Maybe NanoSecond64 +getStreamLatency = _streamLatency + +setInspectMode :: State t m a -> State t m a +setInspectMode st = st { _inspectMode = True } + +getInspectMode :: State t m a -> Bool +getInspectMode = _inspectMode diff --git a/src/Streamly/Internal/Data/Stream.hs b/src/Streamly/Internal/Data/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream.hs @@ -0,0 +1,14 @@ +-- | +-- Module : Streamly.Internal.Data.Stream +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Stream + ( module Streamly.Internal.Data.Stream.StreamD + ) +where + +import Streamly.Internal.Data.Stream.StreamD diff --git a/src/Streamly/Internal/Data/Stream/Bottom.hs b/src/Streamly/Internal/Data/Stream/Bottom.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Bottom.hs @@ -0,0 +1,670 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Chunked.hs @@ -0,0 +1,1215 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Common.hs @@ -0,0 +1,105 @@ +{-# 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/Cross.hs b/src/Streamly/Internal/Data/Stream/Cross.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Cross.hs @@ -0,0 +1,143 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Eliminate.hs @@ -0,0 +1,377 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Eliminate +-- Copyright : (c) 2017 Composewell Technologies +-- 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@. + +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 + + -- * 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. + , uncons + , init + + -- * Right Folds + , foldrM + , foldr + + -- * Left Folds + -- Lazy left folds are useful only for reversing the stream + , foldlS + + -- * Multi-Stream folds + -- Full equivalence + , eqBy + , cmpBy + + -- finding subsequences + , isPrefixOf + , isInfixOf + , isSuffixOf + , isSubsequenceOf + + -- trimming sequences + , stripPrefix + -- , stripInfix + , stripSuffix + ) +where + +#include "inline.hs" + +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 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 Prelude hiding (foldr, init, reverse) + +-- $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 + +------------------------------------------------------------------------------ +-- Deconstruction +------------------------------------------------------------------------------ + +-- | 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) + +------------------------------------------------------------------------------ +-- Left Folds +------------------------------------------------------------------------------ + +-- | 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 +------------------------------------------------------------------------------ + +-- | Parse a stream using the supplied ParserD 'PRD.Parser'. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL parseD #-} +parseD :: Monad m => PRD.Parser a m b -> Stream m a -> m (Either ParseError b) +parseD p = D.parseD p . toStreamD + +-- XXX Drive directly as parserK rather than converting to parserD first. + +-- | Parse a stream using the supplied ParserK 'PRK.Parser'. +-- +-- /Internal/ +--{-# INLINE parseK #-} +--parseK :: Monad m => PRK.Parser a m b -> Stream m a -> m (Either ParseError b) +--parseK = parse + +-- | 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 => Parser a m b -> Stream m a -> m (Either ParseError b) +parse = parseD + +{-# 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) + +-- | Parse a stream using the supplied 'Parser'. +-- +-- /CPS/ +-- +--{-# 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 + +------------------------------------------------------------------------------ +-- 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 isPrefixOf #-} +isPrefixOf :: (Monad m, Eq a) => Stream m a -> Stream m a -> m Bool +isPrefixOf m1 m2 = D.isPrefixOf (toStreamD m1) (toStreamD m2) + +-- | 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 <- D.null $ D.drop 1 $ D.splitOnSeq arr Fold.drain $ toStreamD 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 = 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. + +-- | @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) + +-- | 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 reverse <$> stripPrefix (reverse m1) (reverse m2) diff --git a/src/Streamly/Internal/Data/Stream/Enumerate.hs b/src/Streamly/Internal/Data/Stream/Enumerate.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Enumerate.hs @@ -0,0 +1,560 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Exception.hs @@ -0,0 +1,222 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Exception +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Stream.Exception + ( + before + , afterUnsafe + , afterIO + , bracketUnsafe + , bracketIO + , bracketIO3 + , onException + , finallyUnsafe + , finallyIO + , ghandle + , handle + ) +where + +import Control.Exception (Exception) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO) +import Streamly.Internal.Data.Stream.Type (Stream, fromStreamD, toStreamD) + +import qualified Streamly.Internal.Data.Stream.StreamD as D + +-- $setup +-- >>> :m +-- >>> import qualified Streamly.Internal.Data.Stream as Stream + +------------------------------------------------------------------------------ +-- Exceptions +------------------------------------------------------------------------------ + +-- | 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 #-} +before :: Monad m => m b -> Stream m a -> Stream m a +before action xs = fromStreamD $ D.before action $ toStreamD xs + +-- | 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 afterUnsafe #-} +afterUnsafe :: Monad m => m b -> Stream m a -> Stream m a +afterUnsafe action xs = fromStreamD $ D.afterUnsafe action $ toStreamD xs + +-- | 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 afterIO #-} +afterIO :: MonadIO m => IO b -> Stream m a -> Stream m a +afterIO action xs = fromStreamD $ D.afterIO action $ toStreamD xs + +-- | 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 onException #-} +onException :: MonadCatch m => m b -> Stream m a -> Stream m a +onException action xs = fromStreamD $ D.onException action $ toStreamD xs + +-- | 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 + +-- | 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 + +-- | 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 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 + +-- 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 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) + +-- | 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 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 + +-- | 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 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 diff --git a/src/Streamly/Internal/Data/Stream/Expand.hs b/src/Streamly/Internal/Data/Stream/Expand.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Expand.hs @@ -0,0 +1,893 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Generate.hs @@ -0,0 +1,460 @@ +{-# 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 diff --git a/src/Streamly/Internal/Data/Stream/Lift.hs b/src/Streamly/Internal/Data/Stream/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Lift.hs @@ -0,0 +1,95 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Lift +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Stream.Lift + ( + -- * Generalize Inner Monad + morphInner + , generalizeInner + + -- * Transform Inner Monad + , liftInnerWith + , runInnerWith + , runInnerWithState + ) +where + +import Data.Functor.Identity (Identity (..)) +import Streamly.Internal.Data.Stream.Type + (Stream, fromStreamD, toStreamD, fromStreamK, toStreamK) + +import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream.StreamK as K + +-- $setup +-- >>> :m +-- >>> import Data.Functor.Identity (runIdentity) +-- >>> import Streamly.Internal.Data.Stream as Stream + +------------------------------------------------------------------------------ +-- Generalize the underlying 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. +-- +-- /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) + +-- | Generalize the inner monad of the stream from 'Identity' to any monad. +-- +-- Definition: +-- +-- >>> 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 +------------------------------------------------------------------------------ + +-- | 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) + +-- | Evaluate the inner monad of a stream using the supplied runner function. +-- +{-# INLINE runInnerWith #-} +runInnerWith :: (Monad m, Applicative (t m)) => + (forall b. t m b -> m b) -> Stream (t m) a -> Stream m a +runInnerWith run xs = fromStreamD $ D.runInnerWith run (toStreamD xs) + +-- | 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)) + -> m s + -> Stream (t m) a + -> Stream m (s, a) +runInnerWithState run initial xs = + fromStreamD $ D.runInnerWithState run initial (toStreamD xs) diff --git a/src/Streamly/Internal/Data/Stream/Reduce.hs b/src/Streamly/Internal/Data/Stream/Reduce.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Reduce.hs @@ -0,0 +1,444 @@ +-- | +-- 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/StreamD.hs b/src/Streamly/Internal/Data/Stream/StreamD.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD.hs @@ -0,0 +1,42 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.StreamD +-- 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.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 + ( + 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 + ) +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 diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Container.hs b/src/Streamly/Internal/Data/Stream/StreamD/Container.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Container.hs @@ -0,0 +1,302 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs @@ -0,0 +1,833 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Exception.hs @@ -0,0 +1,479 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Generate.hs @@ -0,0 +1,1205 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Lift.hs @@ -0,0 +1,129 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs @@ -0,0 +1,3111 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Step.hs @@ -0,0 +1,39 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Top.hs @@ -0,0 +1,353 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Transform.hs @@ -0,0 +1,1945 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Transformer.hs @@ -0,0 +1,182 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD/Type.hs @@ -0,0 +1,2074 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamDK.hs @@ -0,0 +1,52 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamK.hs @@ -0,0 +1,1372 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/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.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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamK/Transformer.hs @@ -0,0 +1,79 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamK/Type.hs @@ -0,0 +1,2063 @@ +{-# 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/Transform.hs b/src/Streamly/Internal/Data/Stream/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Transform.hs @@ -0,0 +1,1056 @@ +-- | +-- 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) diff --git a/src/Streamly/Internal/Data/Stream/Transformer.hs b/src/Streamly/Internal/Data/Stream/Transformer.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Transformer.hs @@ -0,0 +1,135 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Transformer +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Stream.Transformer + ( + foldlT + , foldrT + + , liftInner + , usingReaderT + , runReaderT + , evalStateT + , usingStateT + , runStateT + ) +where + +import Control.Monad.Trans.Class (MonadTrans) +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.State.Strict (StateT) +import Streamly.Internal.Data.Stream.Type (Stream, fromStreamD, toStreamD) + +import qualified Streamly.Internal.Data.Stream.StreamD.Transformer as D + +-- $setup +-- >>> :m +-- >>> import Control.Monad.Trans.Class (lift) +-- >>> import Control.Monad.Trans.Identity (runIdentityT) +-- >>> import qualified Streamly.Internal.Data.Stream as Stream + +-- | Lazy left fold to a transformer monad. +-- +{-# INLINE 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) + +-- | 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 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) + +------------------------------------------------------------------------------ +-- Add and remove a monad transformer +------------------------------------------------------------------------------ + +-- | Lift the inner monad @m@ of @Stream m a@ to @t m@ where @t@ is a monad +-- transformer. +-- +{-# INLINE liftInner #-} +liftInner :: (Monad m, MonadTrans t, Monad (t m)) + => Stream m a -> Stream (t m) a +liftInner xs = fromStreamD $ D.liftInner (toStreamD xs) + +------------------------------------------------------------------------------ +-- Sharing read only state in a stream +------------------------------------------------------------------------------ + +-- | Evaluate the inner monad of a stream as 'ReaderT'. +-- +{-# INLINE runReaderT #-} +runReaderT :: Monad m => m s -> Stream (ReaderT s m) a -> Stream m a +runReaderT s xs = fromStreamD $ D.runReaderT s (toStreamD xs) + +-- | Run a stream transformation using a given environment. +-- +-- See also: 'Serial.map' +-- +-- / Internal/ +-- +{-# 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 +-- +-- / Internal/ +-- +{-# 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) + +-- | Run a stateful (StateT) stream transformation using a given state. +-- +-- >>> usingStateT s f = Stream.evalStateT s . f . Stream.liftInner +-- +-- 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 m a +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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Type.hs @@ -0,0 +1,491 @@ +{-# 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 diff --git a/src/Streamly/Internal/Data/Stream/Zip.hs b/src/Streamly/Internal/Data/Stream/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Zip.hs @@ -0,0 +1,91 @@ +{-# 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/Time/Clock.hs b/src/Streamly/Internal/Data/Time/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Time/Clock.hs @@ -0,0 +1,180 @@ +-- | +-- Module : Streamly.Internal.Data.Time.Clock +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : pre-release +-- Portability : GHC + +module Streamly.Internal.Data.Time.Clock + ( + -- * System clock + Clock(..) + , getTime + + -- * Async clock + , asyncClock + , readClock + + -- * Adjustable Timer + , Timer + , timer + , resetTimer + , extendTimer + , shortenTimer + , readTimer + , waitTimer + ) +where + +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 + +------------------------------------------------------------------------------ +-- Async clock +------------------------------------------------------------------------------ + +{-# INLINE updateTimeVar #-} +updateTimeVar :: Clock -> Unboxed.IORef MicroSecond64 -> IO () +updateTimeVar clock timeVar = do + t <- fromAbsTime <$> getTime clock + Unboxed.modifyIORef' timeVar (const t) + +{-# INLINE updateWithDelay #-} +updateWithDelay :: RealFrac a => + Clock -> a -> Unboxed.IORef MicroSecond64 -> IO () +updateWithDelay clock precision timeVar = do + threadDelay (delayTime precision) + updateTimeVar clock timeVar + + where + + -- Keep the minimum at least a millisecond to avoid high CPU usage + {-# INLINE delayTime #-} + delayTime g + | g' >= fromIntegral (maxBound :: Int) = maxBound + | g' < 1000 = 1000 + | otherwise = round g' + + where + + g' = g * 10 ^ (6 :: Int) + +-- | @asyncClock g@ starts a clock thread that updates an IORef with current +-- time as a 64-bit value in microseconds, every 'g' seconds. The IORef can be +-- read asynchronously. The thread exits automatically when the reference to +-- the returned 'ThreadId' is lost. +-- +-- Minimum granularity of clock update is 1 ms. Higher is better for +-- performance. +-- +-- CAUTION! This is safe only on a 64-bit machine. On a 32-bit machine a 64-bit +-- 'Var' cannot be read consistently without a lock while another thread is +-- writing to it. +asyncClock :: Clock -> Double -> IO (ThreadId, Unboxed.IORef MicroSecond64) +asyncClock clock g = do + timeVar <- Unboxed.newIORef 0 + updateTimeVar clock timeVar + tid <- forkIOManaged $ forever (updateWithDelay clock g timeVar) + return (tid, timeVar) + +{-# INLINE readClock #-} +readClock :: (ThreadId, Unboxed.IORef MicroSecond64) -> IO MicroSecond64 +readClock (_, timeVar) = Unboxed.readIORef timeVar + +------------------------------------------------------------------------------ +-- Adjustable Timer +------------------------------------------------------------------------------ + +-- | Adjustable periodic timer. +data Timer = Timer ThreadId (MVar ()) (IO ()) + +-- Set the expiry to current time + timer period +{-# INLINE resetTimerExpiry #-} +resetTimerExpiry :: Clock -> MicroSecond64 -> Unboxed.IORef MicroSecond64 -> IO () +resetTimerExpiry clock period timeVar = do + t <- getTime clock + let t1 = addToAbsTime t (toRelTime period) + Unboxed.modifyIORef' timeVar (const (fromAbsTime t1)) + +{-# INLINE processTimerTick #-} +processTimerTick :: RealFrac a => + Clock -> a -> Unboxed.IORef MicroSecond64 -> MVar () -> IO () -> IO () +processTimerTick clock precision timeVar mvar reset = do + threadDelay (delayTime precision) + t <- fromAbsTime <$> getTime clock + expiry <- Unboxed.readIORef timeVar + when (t >= expiry) $ do + -- non-blocking put so that we can process multiple timers in a + -- non-blocking manner in future. + void $ tryPutMVar mvar () + reset + + where + + -- Keep the minimum at least a millisecond to avoid high CPU usage + {-# INLINE delayTime #-} + delayTime g + | g' >= fromIntegral (maxBound :: Int) = maxBound + | g' < 1000 = 1000 + | otherwise = round g' + + where + + g' = g * 10 ^ (6 :: Int) + +-- XXX In future we can add a timer in a heap of timers. +-- +-- | @timer clockType granularity period@ creates a timer. The timer produces +-- timer ticks at specified time intervals that can be waited upon using +-- 'waitTimer'. If the previous tick is not yet processed, the new tick is +-- lost. +timer :: Clock -> Double -> Double -> IO Timer +timer clock g period = do + mvar <- newEmptyMVar + timeVar <- Unboxed.newIORef 0 + let p = round (period * 1e6) :: Int + p1 = fromIntegral p :: MicroSecond64 + reset = resetTimerExpiry clock p1 timeVar + process = processTimerTick clock g timeVar mvar reset + reset + tid <- forkIOManaged $ forever process + return $ Timer tid mvar reset + +-- | Blocking wait for a timer tick. +{-# INLINE waitTimer #-} +waitTimer :: Timer -> IO () +waitTimer (Timer _ mvar _) = takeMVar mvar + +-- | Resets the current period. +{-# INLINE resetTimer #-} +resetTimer :: Timer -> IO () +resetTimer (Timer _ _ reset) = reset + +-- | Elongates the current period by specified amount. +-- +-- /Unimplemented/ +{-# INLINE extendTimer #-} +extendTimer :: Timer -> Double -> IO () +extendTimer = undefined + +-- | Shortens the current period by specified amount. +-- +-- /Unimplemented/ +{-# INLINE shortenTimer #-} +shortenTimer :: Timer -> Double -> IO () +shortenTimer = undefined + +-- | Show the remaining time in the current time period. +-- +-- /Unimplemented/ +{-# INLINE readTimer #-} +readTimer :: Timer -> IO Double +readTimer = undefined diff --git a/src/Streamly/Internal/Data/Time/Clock/Darwin.c b/src/Streamly/Internal/Data/Time/Clock/Darwin.c new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Time/Clock/Darwin.c @@ -0,0 +1,36 @@ +/* + * Code taken from the Haskell "clock" package. + * + * Copyright (c) 2009-2012, Cetin Sert + * Copyright (c) 2010, Eugene Kirpichov + * + * OS X code was contributed by Gerolf Seitz on 2013-10-15. + */ + +#ifdef __MACH__ +#include +#include +#include + +void clock_gettime_darwin(clock_id_t clock, struct timespec *ts) +{ + clock_serv_t cclock; + mach_timespec_t mts; + host_get_clock_service(mach_host_self(), clock, &cclock); + clock_get_time(cclock, &mts); + mach_port_deallocate(mach_task_self(), cclock); + ts->tv_sec = mts.tv_sec; + ts->tv_nsec = mts.tv_nsec; +} + +void clock_getres_darwin(clock_id_t clock, struct timespec *ts) +{ + clock_serv_t cclock; + int nsecs; + mach_msg_type_number_t count; + host_get_clock_service(mach_host_self(), clock, &cclock); + clock_get_attributes(cclock, CLOCK_GET_TIME_RES, (clock_attr_t)&nsecs, &count); + mach_port_deallocate(mach_task_self(), cclock); +} + +#endif /* __MACH__ */ diff --git a/src/Streamly/Internal/Data/Time/Clock/Type.hsc b/src/Streamly/Internal/Data/Time/Clock/Type.hsc new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Time/Clock/Type.hsc @@ -0,0 +1,252 @@ +{-# OPTIONS_GHC -Wno-identities #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +#ifndef __GHCJS__ +#include "config.h" +#endif + +#include "Streamly/Internal/Data/Time/Clock/config-clock.h" + +-- | +-- Module : Streamly.Internal.Data.Time.Clock.Type +-- Copyright : (c) 2019 Composewell Technologies +-- (c) 2009-2012, Cetin Sert +-- (c) 2010, Eugene Kirpichov +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +-- A majority of the code below has been stolen from the "clock" package. + +module Streamly.Internal.Data.Time.Clock.Type + ( + -- * get time from the system clock + Clock(..) + , getTime + ) +where + +import Data.Int (Int32, Int64) +import Data.Typeable (Typeable) +import Data.Word (Word32) +import Foreign.C (CInt(..), throwErrnoIfMinus1_, CTime(..), CLong(..)) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..), peek) +import GHC.Generics (Generic) + +import Streamly.Internal.Data.Time.Units (TimeSpec(..), AbsTime(..)) + +------------------------------------------------------------------------------- +-- Clock Types +------------------------------------------------------------------------------- + +#if HS_CLOCK_POSIX +#include + +#if defined(CLOCK_MONOTONIC_RAW) +#define HAVE_CLOCK_MONOTONIC_RAW +#endif + +-- XXX this may be RAW on apple not RAW on linux +#if __linux__ && defined(CLOCK_MONOTONIC_COARSE) +#define HAVE_CLOCK_MONOTONIC_COARSE +#endif + +#if __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX) +#define HAVE_CLOCK_MONOTONIC_COARSE +#endif + +#if __linux__ && defined(CLOCK_BOOTTIME) +#define HAVE_CLOCK_MONOTONIC_UPTIME +#endif + +#if __APPLE__ && defined(CLOCK_UPTIME_RAW) +#define HAVE_CLOCK_MONOTONIC_UPTIME +#endif + +#if __linux__ && defined(CLOCK_REALTIME_COARSE) +#define HAVE_CLOCK_REALTIME_COARSE +#endif + +#endif + +-- | Clock types. A clock may be system-wide (that is, visible to all processes) +-- or per-process (measuring time that is meaningful only within a process). +-- All implementations shall support CLOCK_REALTIME. (The only suspend-aware +-- monotonic is CLOCK_BOOTTIME on Linux.) +data Clock + + -- | The identifier for the system-wide monotonic clock, which is defined as + -- a clock measuring real time, whose value cannot be set via + -- @clock_settime@ and which cannot have negative clock jumps. The maximum + -- possible clock jump shall be implementation defined. For this clock, + -- the value returned by 'getTime' represents the amount of time (in + -- seconds and nanoseconds) since an unspecified point in the past (for + -- example, system start-up time, or the Epoch). This point does not + -- change after system start-up time. Note that the absolute value of the + -- monotonic clock is meaningless (because its origin is arbitrary), and + -- thus there is no need to set it. Furthermore, realtime applications can + -- rely on the fact that the value of this clock is never set. + = Monotonic + + -- | The identifier of the system-wide clock measuring real time. For this + -- clock, the value returned by 'getTime' represents the amount of time (in + -- seconds and nanoseconds) since the Epoch. + | Realtime + +#ifndef HS_CLOCK_GHCJS + -- | The identifier of the CPU-time clock associated with the calling + -- process. For this clock, the value returned by 'getTime' represents the + -- amount of execution time of the current process. + | ProcessCPUTime + + -- | The identifier of the CPU-time clock associated with the calling OS + -- thread. For this clock, the value returned by 'getTime' represents the + -- amount of execution time of the current OS thread. + | ThreadCPUTime +#endif + +#if defined (HAVE_CLOCK_MONOTONIC_RAW) + -- | (since Linux 2.6.28; Linux and Mac OSX) + -- Similar to CLOCK_MONOTONIC, but provides access to a + -- raw hardware-based time that is not subject to NTP + -- adjustments or the incremental adjustments performed by + -- adjtime(3). + | MonotonicRaw +#endif + +#if defined (HAVE_CLOCK_MONOTONIC_COARSE) + -- | (since Linux 2.6.32; Linux and Mac OSX) + -- A faster but less precise version of CLOCK_MONOTONIC. + -- Use when you need very fast, but not fine-grained timestamps. + | MonotonicCoarse +#endif + +#if defined (HAVE_CLOCK_MONOTONIC_UPTIME) + -- | (since Linux 2.6.39; Linux and Mac OSX) + -- Identical to CLOCK_MONOTONIC, except it also includes + -- any time that the system is suspended. This allows + -- applications to get a suspend-aware monotonic clock + -- without having to deal with the complications of + -- CLOCK_REALTIME, which may have discontinuities if the + -- time is changed using settimeofday(2). + | Uptime +#endif + +#if defined (HAVE_CLOCK_REALTIME_COARSE) + -- | (since Linux 2.6.32; Linux-specific) + -- A faster but less precise version of CLOCK_REALTIME. + -- Use when you need very fast, but not fine-grained timestamps. + | RealtimeCoarse +#endif + + deriving (Eq, Enum, Generic, Read, Show) + +------------------------------------------------------------------------------- +-- Translate the Haskell "Clock" type to C +------------------------------------------------------------------------------- + +#if HS_CLOCK_POSIX +-- Posix systems (Linux and Mac OSX 10.12 and later) +clockToPosixClockId :: Clock -> #{type clockid_t} +clockToPosixClockId Monotonic = #const CLOCK_MONOTONIC +clockToPosixClockId Realtime = #const CLOCK_REALTIME +clockToPosixClockId ProcessCPUTime = #const CLOCK_PROCESS_CPUTIME_ID +clockToPosixClockId ThreadCPUTime = #const CLOCK_THREAD_CPUTIME_ID + +#if defined(CLOCK_MONOTONIC_RAW) +clockToPosixClockId MonotonicRaw = #const CLOCK_MONOTONIC_RAW +#endif + +#if __linux__ && defined (CLOCK_MONOTONIC_COARSE) +clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_COARSE +#elif __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX) +clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_RAW_APPROX +#endif + +#if __linux__ && defined (CLOCK_REALTIME_COARSE) +clockToPosixClockId RealtimeCoarse = #const CLOCK_REALTIME_COARSE +#endif + +#if __linux__ && defined(CLOCK_BOOTTIME) +clockToPosixClockId Uptime = #const CLOCK_BOOTTIME +#elif __APPLE__ && defined(CLOCK_UPTIME_RAW) +clockToPosixClockId Uptime = #const CLOCK_UPTIME_RAW +#endif + +#elif HS_CLOCK_OSX +-- Mac OSX versions prior to 10.12 +#include +#include + +clockToOSXClockId :: Clock -> #{type clock_id_t} +clockToOSXClockId Monotonic = #const SYSTEM_CLOCK +clockToOSXClockId Realtime = #const CALENDAR_CLOCK +clockToOSXClockId ProcessCPUTime = #const SYSTEM_CLOCK +clockToOSXClockId ThreadCPUTime = #const SYSTEM_CLOCK +#elif HS_CLOCK_GHCJS +-- XXX need to implement a monotonic clock for JS using performance.now() +clockToJSClockId :: Clock -> CInt +clockToJSClockId Monotonic = 0 +clockToJSClockId Realtime = 0 +#endif + +------------------------------------------------------------------------------- +-- Clock time +------------------------------------------------------------------------------- + +{-# INLINE getTimeWith #-} +getTimeWith :: (Ptr TimeSpec -> IO ()) -> IO AbsTime +getTimeWith f = do + t <- alloca (\ptr -> f ptr >> peek ptr) + return $ AbsTime t + +#if HS_CLOCK_GHCJS + +foreign import ccall unsafe "time.h clock_gettime_js" + clock_gettime_js :: CInt -> Ptr TimeSpec -> IO CInt + +{-# INLINABLE getTime #-} +getTime :: Clock -> IO AbsTime +getTime clock = + getTimeWith (throwErrnoIfMinus1_ "clock_gettime" . + clock_gettime_js (clockToJSClockId clock)) + +#elif HS_CLOCK_POSIX + +foreign import ccall unsafe "time.h clock_gettime" + clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO CInt + +{-# INLINABLE getTime #-} +getTime :: Clock -> IO AbsTime +getTime clock = + getTimeWith (throwErrnoIfMinus1_ "clock_gettime" . + clock_gettime (clockToPosixClockId clock)) + +#elif HS_CLOCK_OSX + +-- XXX perform error checks inside c implementation +foreign import ccall + clock_gettime_darwin :: #{type clock_id_t} -> Ptr TimeSpec -> IO () + +{-# INLINABLE getTime #-} +getTime :: Clock -> IO AbsTime +getTime clock = getTimeWith $ clock_gettime_darwin (clockToOSXClockId clock) + +#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 () + +{-# INLINABLE getTime #-} +getTime :: Clock -> IO AbsTime +getTime Monotonic = getTimeWith $ clock_gettime_win32_monotonic +getTime Realtime = getTimeWith $ clock_gettime_win32_realtime +getTime ProcessCPUTime = getTimeWith $ clock_gettime_win32_processtime +getTime ThreadCPUTime = getTimeWith $ clock_gettime_win32_threadtime +#endif diff --git a/src/Streamly/Internal/Data/Time/Clock/Windows.c b/src/Streamly/Internal/Data/Time/Clock/Windows.c new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Time/Clock/Windows.c @@ -0,0 +1,115 @@ +/* + * Code taken from the Haskell "clock" package. + * + * Copyright (c) 2009-2012, Cetin Sert + * Copyright (c) 2010, Eugene Kirpichov + */ + +#ifdef _WIN32 +#include + +#if defined(_MSC_VER) || defined(_MSC_EXTENSIONS) + #define U64(x) x##Ui64 +#else + #define U64(x) x##ULL +#endif + +#define DELTA_EPOCH_IN_100NS U64(116444736000000000) + +static long ticks_to_nanos(LONGLONG subsecond_time, LONGLONG frequency) +{ + return (long)((1e9 * subsecond_time) / frequency); +} + +static ULONGLONG to_quad_100ns(FILETIME ft) +{ + ULARGE_INTEGER li; + li.LowPart = ft.dwLowDateTime; + li.HighPart = ft.dwHighDateTime; + return li.QuadPart; +} + +static void to_timespec_from_100ns(ULONGLONG t_100ns, long long *t) +{ + t[0] = (long)(t_100ns / 10000000UL); + t[1] = 100*(long)(t_100ns % 10000000UL); +} + +void clock_gettime_win32_monotonic(long long* t) +{ + LARGE_INTEGER time; + LARGE_INTEGER frequency; + QueryPerformanceCounter(&time); + QueryPerformanceFrequency(&frequency); + // seconds + t[0] = time.QuadPart / frequency.QuadPart; + // nanos = + t[1] = ticks_to_nanos(time.QuadPart % frequency.QuadPart, frequency.QuadPart); +} + +void clock_gettime_win32_realtime(long long* t) +{ + FILETIME ft; + ULONGLONG tmp; + + GetSystemTimeAsFileTime(&ft); + + tmp = to_quad_100ns(ft); + tmp -= DELTA_EPOCH_IN_100NS; + + to_timespec_from_100ns(tmp, t); +} + +void clock_gettime_win32_processtime(long long* t) +{ + FILETIME creation_time, exit_time, kernel_time, user_time; + ULONGLONG time; + + GetProcessTimes(GetCurrentProcess(), &creation_time, &exit_time, &kernel_time, &user_time); + // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117 + + time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time); + to_timespec_from_100ns(time, t); +} + +void clock_gettime_win32_threadtime(long long* t) +{ + FILETIME creation_time, exit_time, kernel_time, user_time; + ULONGLONG time; + + GetThreadTimes(GetCurrentThread(), &creation_time, &exit_time, &kernel_time, &user_time); + // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117 + + time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time); + to_timespec_from_100ns(time, t); +} + +void clock_getres_win32_monotonic(long long* t) +{ + LARGE_INTEGER frequency; + QueryPerformanceFrequency(&frequency); + + ULONGLONG resolution = U64(1000000000)/frequency.QuadPart; + t[0] = resolution / U64(1000000000); + t[1] = resolution % U64(1000000000); +} + +void clock_getres_win32_realtime(long long* t) +{ + t[0] = 0; + t[1] = 100; +} + +void clock_getres_win32_processtime(long long* t) +{ + t[0] = 0; + t[1] = 100; +} + +void clock_getres_win32_threadtime(long long* t) +{ + t[0] = 0; + t[1] = 100; +} + +#endif /* _WIN32 */ diff --git a/src/Streamly/Internal/Data/Time/Clock/config-clock.h b/src/Streamly/Internal/Data/Time/Clock/config-clock.h new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Time/Clock/config-clock.h @@ -0,0 +1,11 @@ +#if __GHCJS__ +#define HS_CLOCK_GHCJS 1 +#elif defined(_WIN32) +#define HS_CLOCK_WINDOWS 1 +#elif HAVE_TIME_H && HAVE_CLOCK_GETTIME +#define HS_CLOCK_POSIX 1 +#elif __APPLE__ +#define HS_CLOCK_OSX 1 +#else +#error "Time/Clock functionality not implemented for this system" +#endif diff --git a/src/Streamly/Internal/Data/Time/TimeSpec.hsc b/src/Streamly/Internal/Data/Time/TimeSpec.hsc new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Time/TimeSpec.hsc @@ -0,0 +1,152 @@ +{-# OPTIONS_GHC -Wno-identities #-} + +#ifndef __GHCJS__ +#include "config.h" +#endif + +#include "Streamly/Internal/Data/Time/Clock/config-clock.h" + +#include "MachDeps.h" + +-- | +-- Module : Streamly.Internal.Data.Time.TimeSpec +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Time.TimeSpec + ( + TimeSpec(..) + ) +where + +import Data.Int (Int64) +#if (WORD_SIZE_IN_BITS == 32) +import Data.Int (Int32) +#endif +import Foreign.Storable (Storable(..), peek) + +#ifdef HS_CLOCK_GHCJS +import Foreign.C (CTime(..), CLong(..)) +#endif + +------------------------------------------------------------------------------- +-- Some constants +------------------------------------------------------------------------------- + +{-# INLINE tenPower9 #-} +tenPower9 :: Int64 +tenPower9 = 1000000000 + +------------------------------------------------------------------------------- +-- TimeSpec representation +------------------------------------------------------------------------------- + +-- A structure storing seconds and nanoseconds as 'Int64' is the simplest and +-- fastest way to store practically large quantities of time with efficient +-- arithmetic operations. If we store nanoseconds using 'Integer' it can store +-- practically unbounded quantities but it may not be as efficient to +-- manipulate in performance critical applications. XXX need to measure the +-- performance. +-- +-- | Data type to represent practically large quantities of time efficiently. +-- It can represent time up to ~292 billion years at nanosecond resolution. +data TimeSpec = TimeSpec + { sec :: {-# UNPACK #-} !Int64 -- ^ seconds + , nsec :: {-# UNPACK #-} !Int64 -- ^ nanoseconds + } deriving (Eq, Read, Show) + +-- We assume that nsec is always less than 10^9. When TimeSpec is negative then +-- both sec and nsec are negative. +instance Ord TimeSpec where + compare (TimeSpec s1 ns1) (TimeSpec s2 ns2) = + if s1 == s2 + then compare ns1 ns2 + else compare s1 s2 + +-- make sure nsec is less than 10^9 +{-# INLINE addWithOverflow #-} +addWithOverflow :: TimeSpec -> TimeSpec -> TimeSpec +addWithOverflow (TimeSpec s1 ns1) (TimeSpec s2 ns2) = + let nsum = ns1 + ns2 + (s', ns) = if nsum > tenPower9 || nsum < negate tenPower9 + then nsum `divMod` tenPower9 + else (0, nsum) + in TimeSpec (s1 + s2 + s') ns + +-- make sure both sec and nsec have the same sign +{-# INLINE adjustSign #-} +adjustSign :: TimeSpec -> TimeSpec +adjustSign t@(TimeSpec s ns) + | s > 0 && ns < 0 = TimeSpec (s - 1) (ns + tenPower9) + | s < 0 && ns > 0 = TimeSpec (s + 1) (ns - tenPower9) + | otherwise = t + +{-# INLINE timeSpecToInteger #-} +timeSpecToInteger :: TimeSpec -> Integer +timeSpecToInteger (TimeSpec s ns) = toInteger $ s * tenPower9 + ns + +instance Num TimeSpec where + {-# INLINE (+) #-} + t1 + t2 = adjustSign (addWithOverflow t1 t2) + + -- XXX will this be more optimal if imlemented without "negate"? + {-# INLINE (-) #-} + t1 - t2 = t1 + negate t2 + t1 * t2 = fromInteger $ timeSpecToInteger t1 * timeSpecToInteger t2 + + {-# INLINE negate #-} + negate (TimeSpec s ns) = TimeSpec (negate s) (negate ns) + {-# INLINE abs #-} + abs (TimeSpec s ns) = TimeSpec (abs s) (abs ns) + {-# INLINE signum #-} + signum (TimeSpec s ns) | s == 0 = TimeSpec (signum ns) 0 + | otherwise = TimeSpec (signum s) 0 + -- This is fromNanoSecond64 Integer + {-# INLINE fromInteger #-} + fromInteger nanosec = TimeSpec (fromInteger s) (fromInteger ns) + where (s, ns) = nanosec `divMod` toInteger tenPower9 + +#if HS_CLOCK_POSIX +#include +#endif + +#ifdef HS_CLOCK_GHCJS +instance Storable TimeSpec where + sizeOf _ = 8 + alignment _ = 4 + peek p = do + CTime s <- peekByteOff p 0 + CLong ns <- peekByteOff p 4 + return (TimeSpec (fromIntegral s) (fromIntegral ns)) + poke p (TimeSpec s ns) = do + pokeByteOff p 0 ((fromIntegral s) :: CTime) + pokeByteOff p 4 ((fromIntegral ns) :: CLong) + +#elif HS_CLOCK_WINDOWS +instance Storable TimeSpec where + sizeOf _ = sizeOf (undefined :: Int64) * 2 + alignment _ = alignment (undefined :: Int64) + peek ptr = do + s <- peekByteOff ptr 0 + ns <- peekByteOff ptr (sizeOf (undefined :: Int64)) + return (TimeSpec s ns) + poke ptr ts = do + pokeByteOff ptr 0 (sec ts) + pokeByteOff ptr (sizeOf (undefined :: Int64)) (nsec ts) +#else +instance Storable TimeSpec where + sizeOf _ = #{size struct timespec} + alignment _ = #{alignment struct timespec} + peek ptr = do + s :: #{type time_t} <- #{peek struct timespec, tv_sec} ptr + ns :: #{type long} <- #{peek struct timespec, tv_nsec} ptr + return $ TimeSpec (fromIntegral s) (fromIntegral ns) + poke ptr ts = do + let s :: #{type time_t} = fromIntegral $ sec ts + ns :: #{type long} = fromIntegral $ nsec ts + #{poke struct timespec, tv_sec} ptr (s) + #{poke struct timespec, tv_nsec} ptr (ns) +#endif diff --git a/src/Streamly/Internal/Data/Time/Units.hs b/src/Streamly/Internal/Data/Time/Units.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Time/Units.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | +-- Module : Streamly.Internal.Data.Time.Units +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : pre-release +-- Portability : GHC + +module Streamly.Internal.Data.Time.Units + ( + -- * Time Unit Conversions + TimeUnit() + -- , TimeUnitWide() + , TimeUnit64() + + -- * Time Units + , TimeSpec(..) + , NanoSecond64(..) + , MicroSecond64(..) + , MilliSecond64(..) + , showNanoSecond64 + + -- * Absolute times (using TimeSpec) + , AbsTime(..) + , toAbsTime + , fromAbsTime + + -- * Relative times (using TimeSpec) + , RelTime + , toRelTime + , fromRelTime + , diffAbsTime + , addToAbsTime + + -- * Relative times (using NanoSecond64) + , RelTime64 + , toRelTime64 + , fromRelTime64 + , diffAbsTime64 + , addToAbsTime64 + , showRelTime64 + ) +where + +#include "inline.hs" + +import Text.Printf (printf) + +import Data.Int +import Foreign.Storable (Storable) +import Streamly.Internal.Data.Unboxed (Unbox) +import Streamly.Internal.Data.Time.TimeSpec + +------------------------------------------------------------------------------- +-- Some constants +------------------------------------------------------------------------------- + +{-# INLINE tenPower3 #-} +tenPower3 :: Int64 +tenPower3 = 1000 + +{-# INLINE tenPower6 #-} +tenPower6 :: Int64 +tenPower6 = 1000000 + +{-# INLINE tenPower9 #-} +tenPower9 :: Int64 +tenPower9 = 1000000000 + + +------------------------------------------------------------------------------- +-- Time Unit Representations +------------------------------------------------------------------------------- + +-- XXX We should be able to use type families to use different represenations +-- for a unit. +-- +-- Second Rational +-- Second Double +-- Second Int64 +-- Second Integer +-- NanoSecond Int64 +-- ... + +-- Double or Fixed would be a much better representation so that we do not lose +-- information between conversions. However, for faster arithmetic operations +-- we use an 'Int64' here. When we need convservation of values we can use a +-- different system of units with a Fixed precision. + +------------------------------------------------------------------------------- +-- Integral Units +------------------------------------------------------------------------------- + +-- | An 'Int64' time representation with a nanosecond resolution. It can +-- represent time up to ~292 years. +newtype NanoSecond64 = NanoSecond64 Int64 + deriving ( Eq + , Read + , Show + , Enum + , Bounded + , Num + , Real + , Integral + , Ord + , Storable + , Unbox + ) + +-- | An 'Int64' time representation with a microsecond resolution. +-- It can represent time up to ~292,000 years. +newtype MicroSecond64 = MicroSecond64 Int64 + deriving ( Eq + , Read + , Show + , Enum + , Bounded + , Num + , Real + , Integral + , Ord + , Storable + , Unbox + ) + +-- | An 'Int64' time representation with a millisecond resolution. +-- It can represent time up to ~292 million years. +newtype MilliSecond64 = MilliSecond64 Int64 + deriving ( Eq + , Read + , Show + , Enum + , Bounded + , Num + , Real + , Integral + , Ord + , Storable + , Unbox + ) + +------------------------------------------------------------------------------- +-- Fractional Units +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Time unit conversions +------------------------------------------------------------------------------- + +-- TODO: compare whether using TimeSpec instead of Integer provides significant +-- performance boost. If not then we can just use Integer nanoseconds and get +-- rid of TimeUnitWide. +-- +-- | A type class for converting between time units using 'Integer' as the +-- intermediate and the widest representation with a nanosecond resolution. +-- This system of units can represent arbitrarily large times but provides +-- least efficient arithmetic operations due to 'Integer' arithmetic. +-- +-- NOTE: Converting to and from units may truncate the value depending on the +-- original value and the size and resolution of the destination unit. +{- +class TimeUnitWide a where + toTimeInteger :: a -> Integer + fromTimeInteger :: Integer -> a +-} + +-- | A type class for converting between units of time using 'TimeSpec' as the +-- intermediate representation. This system of units can represent up to ~292 +-- billion years at nanosecond resolution with reasonably efficient arithmetic +-- operations. +-- +-- NOTE: Converting to and from units may truncate the value depending on the +-- original value and the size and resolution of the destination unit. +class TimeUnit a where + toTimeSpec :: a -> TimeSpec + fromTimeSpec :: TimeSpec -> a + +-- XXX we can use a fromNanoSecond64 for conversion with overflow check and +-- fromNanoSecond64Unsafe for conversion without overflow check. +-- +-- | A type class for converting between units of time using 'Int64' as the +-- intermediate representation with a nanosecond resolution. This system of +-- units can represent up to ~292 years at nanosecond resolution with fast +-- arithmetic operations. +-- +-- NOTE: Converting to and from units may truncate the value depending on the +-- original value and the size and resolution of the destination unit. +class TimeUnit64 a where + toNanoSecond64 :: a -> NanoSecond64 + fromNanoSecond64 :: NanoSecond64 -> a + +------------------------------------------------------------------------------- +-- Time units +------------------------------------------------------------------------------- + +instance TimeUnit TimeSpec where + toTimeSpec = id + fromTimeSpec = id + +instance TimeUnit NanoSecond64 where + {-# INLINE toTimeSpec #-} + toTimeSpec (NanoSecond64 t) = TimeSpec s ns + where (s, ns) = t `divMod` tenPower9 + + {-# INLINE fromTimeSpec #-} + fromTimeSpec (TimeSpec s ns) = + NanoSecond64 $ s * tenPower9 + ns + +instance TimeUnit64 NanoSecond64 where + {-# INLINE toNanoSecond64 #-} + toNanoSecond64 = id + + {-# INLINE fromNanoSecond64 #-} + fromNanoSecond64 = id + +instance TimeUnit MicroSecond64 where + {-# INLINE toTimeSpec #-} + toTimeSpec (MicroSecond64 t) = TimeSpec s (us * tenPower3) + where (s, us) = t `divMod` tenPower6 + + {-# INLINE fromTimeSpec #-} + fromTimeSpec (TimeSpec s ns) = + -- XXX round ns to nearest microsecond? + MicroSecond64 $ s * tenPower6 + (ns `div` tenPower3) + +instance TimeUnit64 MicroSecond64 where + {-# INLINE toNanoSecond64 #-} + toNanoSecond64 (MicroSecond64 us) = NanoSecond64 $ us * tenPower3 + + {-# INLINE fromNanoSecond64 #-} + -- XXX round ns to nearest microsecond? + fromNanoSecond64 (NanoSecond64 ns) = MicroSecond64 $ ns `div` tenPower3 + +instance TimeUnit MilliSecond64 where + {-# INLINE toTimeSpec #-} + toTimeSpec (MilliSecond64 t) = TimeSpec s (ms * tenPower6) + where (s, ms) = t `divMod` tenPower3 + + {-# INLINE fromTimeSpec #-} + fromTimeSpec (TimeSpec s ns) = + -- XXX round ns to nearest millisecond? + MilliSecond64 $ s * tenPower3 + (ns `div` tenPower6) + +instance TimeUnit64 MilliSecond64 where + {-# INLINE toNanoSecond64 #-} + toNanoSecond64 (MilliSecond64 ms) = NanoSecond64 $ ms * tenPower6 + + {-# INLINE fromNanoSecond64 #-} + -- XXX round ns to nearest millisecond? + fromNanoSecond64 (NanoSecond64 ns) = MilliSecond64 $ ns `div` tenPower6 + +------------------------------------------------------------------------------- +-- Absolute time +------------------------------------------------------------------------------- + +-- | Absolute times are relative to a predefined epoch in time. 'AbsTime' +-- represents times using 'TimeSpec' which can represent times up to ~292 +-- billion years at a nanosecond resolution. +newtype AbsTime = AbsTime TimeSpec + deriving (Eq, Ord, Show) + +-- | Convert a 'TimeUnit' to an absolute time. +{-# INLINE_NORMAL toAbsTime #-} +toAbsTime :: TimeUnit a => a -> AbsTime +toAbsTime = AbsTime . toTimeSpec + +-- | Convert absolute time to a 'TimeUnit'. +{-# INLINE_NORMAL fromAbsTime #-} +fromAbsTime :: TimeUnit a => AbsTime -> a +fromAbsTime (AbsTime t) = fromTimeSpec t + +-- XXX We can also write rewrite rules to simplify divisions multiplications +-- and additions when manipulating units. Though, that might get simplified at +-- the assembly (llvm) level as well. Note to/from conversions may be lossy and +-- therefore this equation may not hold, but that's ok. +{-# RULES "fromAbsTime/toAbsTime" forall a. toAbsTime (fromAbsTime a) = a #-} +{-# RULES "toAbsTime/fromAbsTime" forall a. fromAbsTime (toAbsTime a) = a #-} + +------------------------------------------------------------------------------- +-- Relative time using NaonoSecond64 as the underlying representation +------------------------------------------------------------------------------- + +-- We use a separate type to represent relative time for safety and speed. +-- RelTime has a Num instance, absolute time doesn't. Relative times are +-- usually shorter and for our purposes an Int64 nanoseconds can hold close to +-- thousand year duration. It is also faster to manipulate. We do not check for +-- overflows during manipulations so use it only when you know the time cannot +-- be too big. If you need a bigger RelTime representation then use RelTimeBig. + +-- | Relative times are relative to some arbitrary point of time. Unlike +-- 'AbsTime' they are not relative to a predefined epoch. +newtype RelTime64 = RelTime64 NanoSecond64 + deriving ( Eq + , Read + , Show + , Enum + , Bounded + , Num + , Real + , Integral + , Ord + ) + +-- | Convert a 'TimeUnit' to a relative time. +{-# INLINE_NORMAL toRelTime64 #-} +toRelTime64 :: TimeUnit64 a => a -> RelTime64 +toRelTime64 = RelTime64 . toNanoSecond64 + +-- | Convert relative time to a 'TimeUnit'. +{-# INLINE_NORMAL fromRelTime64 #-} +fromRelTime64 :: TimeUnit64 a => RelTime64 -> a +fromRelTime64 (RelTime64 t) = fromNanoSecond64 t + +{-# RULES "fromRelTime64/toRelTime64" forall a . + toRelTime64 (fromRelTime64 a) = a #-} + +{-# RULES "toRelTime64/fromRelTime64" forall a . + fromRelTime64 (toRelTime64 a) = a #-} + +-- | Difference between two absolute points of time. +{-# INLINE diffAbsTime64 #-} +diffAbsTime64 :: AbsTime -> AbsTime -> RelTime64 +diffAbsTime64 (AbsTime (TimeSpec s1 ns1)) (AbsTime (TimeSpec s2 ns2)) = + RelTime64 $ NanoSecond64 $ ((s1 - s2) * tenPower9) + (ns1 - ns2) + +{-# INLINE addToAbsTime64 #-} +addToAbsTime64 :: AbsTime -> RelTime64 -> AbsTime +addToAbsTime64 (AbsTime (TimeSpec s1 ns1)) (RelTime64 (NanoSecond64 ns2)) = + AbsTime $ TimeSpec (s1 + s) ns + where (s, ns) = (ns1 + ns2) `divMod` tenPower9 + +------------------------------------------------------------------------------- +-- Relative time using TimeSpec as the underlying representation +------------------------------------------------------------------------------- + +newtype RelTime = RelTime TimeSpec + deriving ( Eq + , Read + , Show + -- , Enum + -- , Bounded + , Num + -- , Real + -- , Integral + , Ord + ) + +{-# INLINE_NORMAL toRelTime #-} +toRelTime :: TimeUnit a => a -> RelTime +toRelTime = RelTime . toTimeSpec + +{-# INLINE_NORMAL fromRelTime #-} +fromRelTime :: TimeUnit a => RelTime -> a +fromRelTime (RelTime t) = fromTimeSpec t + +{-# RULES "fromRelTime/toRelTime" forall a. toRelTime (fromRelTime a) = a #-} +{-# RULES "toRelTime/fromRelTime" forall a. fromRelTime (toRelTime a) = a #-} + +-- XXX rename to diffAbsTimes? +{-# INLINE diffAbsTime #-} +diffAbsTime :: AbsTime -> AbsTime -> RelTime +diffAbsTime (AbsTime t1) (AbsTime t2) = RelTime (t1 - t2) + +{-# INLINE addToAbsTime #-} +addToAbsTime :: AbsTime -> RelTime -> AbsTime +addToAbsTime (AbsTime t1) (RelTime t2) = AbsTime $ t1 + t2 + +------------------------------------------------------------------------------- +-- Formatting and printing +------------------------------------------------------------------------------- + +-- | Convert nanoseconds to a string showing time in an appropriate unit. +showNanoSecond64 :: NanoSecond64 -> String +showNanoSecond64 time@(NanoSecond64 ns) + | time < 0 = '-' : showNanoSecond64 (-time) + | ns < 1000 = fromIntegral ns `with` "ns" +#ifdef mingw32_HOST_OS + | ns < 1000000 = (fromIntegral ns / 1000) `with` "us" +#else + | ns < 1000000 = (fromIntegral ns / 1000) `with` "μs" +#endif + | ns < 1000000000 = (fromIntegral ns / 1000000) `with` "ms" + | ns < (60 * 1000000000) = (fromIntegral ns / 1000000000) `with` "s" + | ns < (60 * 60 * 1000000000) = + (fromIntegral ns / (60 * 1000000000)) `with` "min" + | ns < (24 * 60 * 60 * 1000000000) = + (fromIntegral ns / (60 * 60 * 1000000000)) `with` "hr" + | ns < (365 * 24 * 60 * 60 * 1000000000) = + (fromIntegral ns / (24 * 60 * 60 * 1000000000)) `with` "days" + | otherwise = + (fromIntegral ns / (365 * 24 * 60 * 60 * 1000000000)) `with` "years" + where with (t :: Double) (u :: String) + | t >= 1e9 = printf "%.4g %s" t u + | t >= 1e3 = printf "%.0f %s" t u + | t >= 1e2 = printf "%.1f %s" t u + | t >= 1e1 = printf "%.2f %s" t u + | otherwise = printf "%.3f %s" t u + +-- In general we should be able to show the time in a specified unit, if we +-- omit the unit we can show it in an automatically chosen one. +{- +data UnitName = + Nano + | Micro + | Milli + | Sec +-} + +showRelTime64 :: RelTime64 -> String +showRelTime64 = showNanoSecond64 . fromRelTime64 diff --git a/src/Streamly/Internal/Data/Tuple/Strict.hs b/src/Streamly/Internal/Data/Tuple/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Tuple/Strict.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Streamly.Internal.Data.Tuple.Strict +-- Copyright : (c) 2019 Composewell Technologies +-- (c) 2013 Gabriel Gonzalez +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- | Strict data types to be used as accumulator for strict left folds and +-- scans. For more comprehensive strict data types see +-- https://hackage.haskell.org/package/strict-base-types . The names have been +-- suffixed by a prime so that programmers can easily distinguish the strict +-- versions from the lazy ones. +-- +-- One major advantage of strict data structures as accumulators in folds and +-- scans is that it helps the compiler optimize the code much better by +-- unboxing. In a big tight loop the difference could be huge. +-- +module Streamly.Internal.Data.Tuple.Strict + ( + Tuple' (..) + , Tuple3' (..) + -- XXX Remove this type, use a fuse annotation in Tuple3' itself or use a + -- custom type where fuse annotation is needed. + , Tuple3Fused' (..) + , Tuple4' (..) + ) +where + +import Fusion.Plugin.Types (Fuse(..)) + +-- | A strict '(,)' +data Tuple' a b = Tuple' !a !b deriving Show + +-- XXX Add TupleFused' + +-- | A strict '(,,)' +{-# ANN type Tuple3Fused' Fuse #-} +data Tuple3' a b c = Tuple3' !a !b !c deriving Show + +-- | A strict '(,,)' +data Tuple3Fused' a b c = Tuple3Fused' !a !b !c deriving Show + +-- | A strict '(,,,)' +data Tuple4' a b c d = Tuple4' !a !b !c !d deriving Show diff --git a/src/Streamly/Internal/Data/Unboxed.hs b/src/Streamly/Internal/Data/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Unboxed.hs @@ -0,0 +1,855 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Unfold.hs @@ -0,0 +1,1140 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Unfold +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Unfold + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * Unfold Type + Step(..) + , Unfold + + -- * 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 + , 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 + + -- ** From Containers + , fromList + , fromListM + + -- ** From Memory + , fromPtr + + -- ** From Stream + , fromStreamK + , fromStreamD + , fromStream + + -- * Combinators + -- ** Mapping on Input + , lmap + , lmapM + , both + , first + , second + , discardFirst + , discardSecond + , swap + -- coapply + -- comonad + + -- * 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 + , foldMany + -- pipe + + -- ** Either Wrapped Input + , either + + -- ** Filtering + , takeWhileM + , takeWhile + , take + , filter + , filterM + , drop + , dropWhile + , dropWhileM + + -- ** Zipping + , zipWithM + , zipWith + + -- ** Cross product + , crossWithM + , crossWith + , cross + , joinInnerGeneric + , crossApply + + -- ** Nesting + , ConcatState (..) + , many + , many2 + , concatMapM + , bind + + -- ** 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. + , gbracket_ + , gbracketIO + , before + , afterIO + , after_ + , finallyIO + , finally_ + , bracketIO + , bracket_ + + -- ** Exceptions + -- | 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. + , onException + , handle + ) +where + +#include "inline.hs" +#include "ArrayMacros.h" + +import Control.Exception (Exception, mask_) +import Control.Monad.Catch (MonadCatch) +import Data.Functor (($>)) +import GHC.Types (SPEC(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.IOFinalizer + (newIOFinalizer, runIOFinalizer, clearingIOFinalizer) +import Streamly.Internal.Data.Stream.StreamD.Type (Stream(..), Step(..)) +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 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) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Foreign (Storable, peek, sizeOf) +import Foreign.Ptr + +#include "DocTestDataUnfold.hs" + +-- | 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. +-- +-- @ +-- discardFirst = Unfold.lmap snd +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL discardFirst #-} +discardFirst :: Unfold m a b -> Unfold m (c, a) b +discardFirst = lmap snd + +-- | Convert an 'Unfold' into an unfold accepting a tuple as an argument, +-- using the argument of the original fold as the first element of tuple and +-- discarding the second element of the tuple. +-- +-- @ +-- discardSecond = Unfold.lmap fst +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL discardSecond #-} +discardSecond :: Unfold m a b -> Unfold m (a, c) b +discardSecond = lmap fst + +-- | Convert an 'Unfold' that accepts a tuple as an argument into an unfold +-- that accepts a tuple with elements swapped. +-- +-- @ +-- swap = Unfold.lmap Tuple.swap +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL swap #-} +swap :: Unfold m (a, c) b -> Unfold m (c, a) b +swap = lmap Tuple.swap + +------------------------------------------------------------------------------- +-- Output operations +------------------------------------------------------------------------------- + +-- XXX Do we need this combinator or the stream based idiom is enough? + +-- | Compose an 'Unfold' and a 'Fold'. Given an @Unfold m a b@ and a +-- @Fold m b c@, returns a monadic action @a -> m c@ representing the +-- application of the fold on the unfolded stream. +-- +-- >>> Unfold.fold Fold.sum Unfold.fromList [1..100] +-- 5050 +-- +-- >>> fold f u = Stream.fold f . Stream.unfold u +-- +-- /Pre-release/ +-- +{-# 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 + res <- initial + case res of + FL.Partial x -> inject a >>= go SPEC x + FL.Done b -> return b + + where + + {-# INLINE_LATE go #-} + go !_ !fs st = do + r <- ustep st + case r of + Yield x s -> do + res <- fstep fs x + case res of + FL.Partial fs1 -> go SPEC fs1 s + FL.Done c -> return c + Skip s -> go SPEC fs s + Stop -> extract fs + +-- {-# 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 + +-- | Apply a fold multiple times on the output of an unfold. +-- +-- /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) = + Unfold step inject + + where + + inject x = do + r <- inject1 x + return (FoldManyStart r) + + {-# 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 (FoldManyFirst fs st) = do + r <- ustep st + case r of + Yield x s -> consume x s fs + Skip s -> return $ Skip (FoldManyFirst fs s) + Stop -> 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 + return $ Skip (FoldManyYield b FoldManyDone) + step (FoldManyYield b next) = return $ Yield b next + step FoldManyDone = return Stop + +------------------------------------------------------------------------------- +-- Either +------------------------------------------------------------------------------- + +-- | Choose left or right unfold based on an either input. +-- +-- /Pre-release/ +{-# INLINE_NORMAL either #-} +either :: Applicative m => + Unfold m a c -> Unfold m b c -> Unfold m (Either a b) c +either (Unfold stepL injectL) (Unfold stepR injectR) = Unfold step inject + + where + + inject (Left x) = Left <$> injectL x + inject (Right x) = Right <$> injectR x + + {-# INLINE_LATE step #-} + step (Left st) = do + (\case + Yield x s -> Yield x (Left s) + Skip s -> Skip (Left s) + Stop -> Stop) <$> stepL st + step (Right st) = do + (\case + Yield x s -> Yield x (Right s) + Skip s -> Skip (Right s) + Stop -> Stop) <$> stepR st + +-- postscan2 :: 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. +-- +-- /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) = + Unfold step inject + + where + + inject a = do + r <- initial + case r of + FL.Partial fs -> Just . (fs,) <$> injectU a + FL.Done _ -> return Nothing + + {-# INLINE_LATE step #-} + step (Just (fs, us)) = do + ru <- stepU us + case ru of + Yield x s -> do + rf <- stepF fs x + case rf of + FL.Done v -> return $ Yield v Nothing + FL.Partial fs1 -> do + v <- extract fs1 + return $ Yield v (Just (fs1, s)) + Skip s -> return $ Skip (Just (fs, s)) + Stop -> 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) = + Unfold step inject + + where + + inject a = ScanInit <$> injectU a + + {-# INLINE runStep #-} + runStep us action = do + r <- action + case r of + FL.Partial fs -> do + !b <- extract fs + return $ Yield b (ScanDo us fs) + FL.Done b -> + let next = if restart then ScanInit us else ScanDone + in return $ Yield b next + + {-# INLINE_LATE step #-} + step (ScanInit us) = runStep us initial + step (ScanDo us fs) = do + res <- stepU us + 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 + +-- | 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 +-- >>> Unfold.fold Fold.toList u [1,2,3,4,5] +-- [0,1,3,0,3,7,0,5] +-- +-- /Pre-release/ +{-# INLINE_NORMAL scanMany #-} +scanMany :: Monad m => Fold m b c -> Unfold m a b -> Unfold m a c +scanMany = scanWith True + +-- 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 +-- >>> Unfold.fold Fold.toList u [1,2,3,4,5] +-- [0,1,3] +-- +-- /Pre-release/ +{-# INLINE_NORMAL scan #-} +scan :: Monad m => Fold m b c -> Unfold m a b -> Unfold m a c +scan = scanWith False + +-- | Scan the output of an 'Unfold' to change it in a stateful manner. +-- +-- /Pre-release/ +{-# INLINE_NORMAL postscanlM' #-} +postscanlM' :: Monad m => (b -> a -> m b) -> m b -> Unfold m c a -> Unfold m c b +postscanlM' f z = postscan (FL.foldlM' f z) + +------------------------------------------------------------------------------- +-- Convert streams into unfolds +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL fromStreamD #-} +fromStreamD :: Applicative m => Unfold m (Stream m a) a +fromStreamD = Unfold step pure + + where + + {-# INLINE_LATE step #-} + step (UnStream step1 state1) = + (\case + Yield x s -> Yield x (Stream step1 s) + Skip s -> Skip (Stream step1 s) + Stop -> Stop) <$> step1 defState state1 + +{-# INLINE_NORMAL fromStreamK #-} +fromStreamK :: Applicative m => Unfold m (K.StreamK m a) a +fromStreamK = Unfold step pure + + where + + {-# INLINE_LATE step #-} + step stream = do + (\case + Just (x, xs) -> Yield x xs + Nothing -> Stop) <$> K.uncons stream + +{-# INLINE fromStream #-} +fromStream :: Applicative m => Unfold m (Stream m a) a +fromStream = fromStreamD + +------------------------------------------------------------------------------- +-- Unfolds +------------------------------------------------------------------------------- + +-- | Lift a monadic function into an unfold generating a nil stream with a side +-- effect. +-- +{-# INLINE nilM #-} +nilM :: Applicative m => (a -> m c) -> Unfold m a b +nilM f = Unfold step pure + + where + + {-# INLINE_LATE step #-} + step x = f x $> Stop + +-- | An empty stream. +{-# INLINE nil #-} +nil :: Applicative m => Unfold m a b +nil = Unfold (Prelude.const (pure Stop)) pure + +-- | Prepend a monadic single element generator function to an 'Unfold'. The +-- same seed is used in the action as well as the unfold. +-- +-- /Pre-release/ +{-# INLINE_NORMAL consM #-} +consM :: Applicative m => (a -> m b) -> Unfold m a b -> Unfold m a b +consM action unf = Unfold step inject + + where + + inject = pure . Left + + {-# INLINE_LATE step #-} + step (Left a) = (`Yield` Right (D.unfold unf a)) <$> action a + step (Right (UnStream step1 st)) = do + (\case + Yield x s -> Yield x (Right (Stream step1 s)) + Skip s -> Skip (Right (Stream step1 s)) + Stop -> Stop) <$> step1 defState st + +-- | Convert a list of monadic values to a 'Stream' +-- +{-# INLINE_LATE fromListM #-} +fromListM :: Applicative m => Unfold m [m a] a +fromListM = Unfold step pure + + where + + {-# INLINE_LATE step #-} + step (x:xs) = (`Yield` xs) <$> x + step [] = pure Stop + +{-# INLINE fromPtr #-} +fromPtr :: forall m a. (MonadIO m, Storable a) => Unfold m (Ptr a) a +fromPtr = Unfold step return + + where + + {-# INLINE_LATE step #-} + step p = do + x <- liftIO $ peek p + return $ Yield x (PTR_NEXT(p, a)) + +------------------------------------------------------------------------------ +-- Specialized Generation +------------------------------------------------------------------------------ + +-- | Given a seed @(n, action)@, generates a stream replicating the @action@ @n@ +-- times. +-- +{-# INLINE replicateM #-} +replicateM :: Applicative m => Unfold m (Int, m a) a +replicateM = Unfold step inject + + where + + inject seed = pure seed + + {-# INLINE_LATE step #-} + step (i, action) = + if i <= 0 + then pure Stop + else (\x -> Yield x (i - 1, action)) <$> action + +-- | Generates an infinite stream repeating the seed. +-- +{-# INLINE repeatM #-} +repeatM :: Applicative m => Unfold m (m a) a +repeatM = Unfold step pure + + where + + {-# INLINE_LATE step #-} + step action = (`Yield` action) <$> action + +-- | Generates an infinite stream starting with the given seed and applying the +-- given function repeatedly. +-- +{-# INLINE iterateM #-} +iterateM :: Applicative m => (a -> m a) -> Unfold m (m a) a +iterateM f = Unfold step id + + where + + {-# INLINE_LATE step #-} + step x = Yield x <$> f x + +-- | @fromIndicesM gen@ generates an infinite stream of values using @gen@ +-- starting from the seed. +-- +-- @ +-- fromIndicesM f = Unfold.mapM f $ Unfold.enumerateFrom 0 +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL fromIndicesM #-} +fromIndicesM :: Applicative m => (Int -> m a) -> Unfold m Int a +fromIndicesM gen = Unfold step pure + + where + + {-# INLINE_LATE step #-} + step i = (`Yield` (i + 1)) <$> gen i + +------------------------------------------------------------------------------- +-- Filtering +------------------------------------------------------------------------------- + +-- | +-- >>> u = Unfold.take 2 Unfold.fromList +-- >>> Unfold.fold Fold.toList u [1..100] +-- [1,2] +-- +{-# INLINE_NORMAL take #-} +take :: Applicative m => Int -> Unfold m a b -> Unfold m a b +take n (Unfold step1 inject1) = Unfold step inject + + where + + inject x = (, 0) <$> inject1 x + + {-# INLINE_LATE step #-} + step (st, i) | i < n = do + (\case + Yield x s -> Yield x (s, i + 1) + Skip s -> Skip (s, i) + Stop -> Stop) <$> step1 st + step (_, _) = pure Stop + +-- | Same as 'filter' but with a monadic predicate. +-- +{-# INLINE_NORMAL filterM #-} +filterM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b +filterM f (Unfold step1 inject1) = Unfold step inject1 + where + {-# INLINE_LATE step #-} + step st = do + r <- step1 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. +-- +{-# INLINE filter #-} +filter :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b +filter f = filterM (return . f) + +-- | @drop n unf@ drops @n@ elements from the stream generated by @unf@. +-- +{-# INLINE_NORMAL drop #-} +drop :: Applicative m => Int -> Unfold m a b -> Unfold m a b +drop n (Unfold step inject) = Unfold step' inject' + + where + + inject' a = (, n) <$> inject a + + {-# INLINE_LATE step' #-} + step' (st, i) + | i > 0 = do + (\case + Yield _ s -> Skip (s, i - 1) + Skip s -> Skip (s, i) + Stop -> Stop) <$> step st + | otherwise = do + (\case + Yield x s -> Yield x (s, 0) + Skip s -> Skip (s, 0) + Stop -> Stop) <$> step st + +-- | @dropWhileM f unf@ drops elements from the stream generated by @unf@ while +-- the condition holds true. The condition function @f@ is /monadic/ in nature. +-- +{-# INLINE_NORMAL dropWhileM #-} +dropWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b +dropWhileM f (Unfold step inject) = Unfold step' inject' + + where + + inject' a = do + b <- inject a + return $ Left b + + {-# INLINE_LATE step' #-} + step' (Left st) = do + r <- step st + case r of + Yield x s -> do + b <- f x + return + $ if b + then Skip (Left s) + else Yield x (Right s) + Skip s -> return $ Skip (Left s) + Stop -> return Stop + step' (Right st) = do + r <- step st + return + $ case r of + Yield x s -> Yield x (Right s) + Skip s -> Skip (Right s) + Stop -> Stop + +-- | Similar to 'dropWhileM' but with a pure condition function. +-- +{-# INLINE dropWhile #-} +dropWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b +dropWhile f = dropWhileM (return . f) + +{-# INLINE_NORMAL joinInnerGeneric #-} +joinInnerGeneric :: 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 + +------------------------------------------------------------------------------ +-- Exceptions +------------------------------------------------------------------------------ + +-- | Like 'gbracketIO' but with following differences: +-- +-- * alloc action @a -> 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 + => (a -> m c) -- ^ before + -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) + -> (c -> m d) -- ^ after, on normal stop + -> Unfold m (c, e) b -- ^ on exception + -> Unfold m c b -- ^ unfold to run + -> Unfold m a b +gbracket_ bef exc aft (Unfold estep einject) (Unfold step1 inject1) = + Unfold step inject + + where + + inject x = do + r <- bef x + s <- inject1 r + return $ Right (s, r) + + {-# INLINE_LATE step #-} + step (Right (st, v)) = do + res <- exc $ step1 st + case res of + Right r -> case r of + Yield x s -> return $ Yield x (Right (s, v)) + Skip s -> return $ Skip (Right (s, v)) + Stop -> aft v >> return Stop + -- XXX Do not handle async exceptions, just rethrow them. + Left e -> do + r <- einject (v, e) + return $ Skip (Left r) + step (Left st) = do + res <- estep st + return $ case res of + Yield x s -> Yield x (Left s) + Skip s -> Skip (Left s) + Stop -> Stop + +-- | Run the alloc action @a -> m c@ with async exceptions disabled but keeping +-- blocking operations interruptible (see 'Control.Exception.mask'). Use the +-- output @c@ as input to @Unfold m c b@ to generate an output stream. When +-- unfolding use the supplied @try@ operation @forall s. m s -> m (Either e s)@ +-- to catch synchronous exceptions. If an exception occurs run the exception +-- handling unfold @Unfold m (c, e) b@. +-- +-- 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 gbracketIO #-} +gbracketIO + :: MonadIO m + => (a -> IO c) -- ^ before + -> (c -> IO d) -- ^ after, on normal stop, or GC + -> (c -> IO ()) -- ^ action on exception + -> Unfold m e b -- ^ stream on exception + -> (forall s. m s -> IO (Either e s)) -- ^ try (exception handling) + -> Unfold m c b -- ^ unfold to run + -> Unfold m a b +gbracketIO bef aft onExc (Unfold estep einject) ftry (Unfold step1 inject1) = + Unfold step inject + + where + + inject x = do + -- Mask asynchronous exceptions to make the execution of 'bef' and + -- the registration of 'aft' atomic. See comment in 'D.gbracketIO'. + (r, ref) <- liftIO $ mask_ $ do + r <- bef x + ref <- newIOFinalizer (aft r) + return (r, ref) + s <- inject1 r + return $ Right (s, r, ref) + + {-# INLINE_LATE step #-} + step (Right (st, v, ref)) = do + res <- liftIO $ ftry $ step1 st + case res of + Right r -> case r of + Yield x s -> return $ Yield x (Right (s, v, ref)) + Skip s -> return $ Skip (Right (s, v, ref)) + Stop -> do + runIOFinalizer ref + 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. + liftIO $ clearingIOFinalizer ref (onExc v) + r <- einject e + return $ Skip (Left r) + step (Left st) = do + res <- estep st + return $ case res of + Yield x s -> Yield x (Left s) + Skip s -> Skip (Left s) + Stop -> Stop + +-- | Run a side effect @a -> m c@ on the input @a@ before unfolding it using +-- @Unfold m a b@. +-- +-- > before f = lmapM (\a -> f a >> return a) +-- +-- /Pre-release/ +{-# INLINE_NORMAL before #-} +before :: (a -> m c) -> Unfold m a b -> Unfold m a b +before action (Unfold step inject) = Unfold step (action >> inject) + +-- The custom implementation of "after_" is slightly faster (5-7%) than +-- "_after". This is just to document and make sure that we can always use +-- gbracket to implement after_ The same applies to other combinators as well. +-- +{-# INLINE_NORMAL _after #-} +_after :: Monad m => (a -> m c) -> Unfold m a b -> Unfold m a b +_after aft = gbracket_ return (fmap Right) aft undefined + +-- | Like 'after' with following differences: +-- +-- * action @a -> m c@ won't run if the stream is garbage collected +-- after partial evaluation. +-- * Monad @m@ does not require any other constraints. +-- +-- /Pre-release/ +{-# INLINE_NORMAL after_ #-} +after_ :: Monad m => (a -> m c) -> Unfold m a b -> Unfold m a b +after_ action (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + s <- inject1 x + return (s, x) + + {-# INLINE_LATE step #-} + step (st, v) = do + res <- step1 st + case res of + Yield x s -> return $ Yield x (s, v) + Skip s -> return $ Skip (s, v) + Stop -> action v >> return Stop + +-- | Unfold the input @a@ using @Unfold m a b@, run an action on @a@ whenever +-- the unfold stops normally, or if it is garbage collected after a partial +-- lazy evaluation. +-- +-- The semantics of the action @a -> m c@ are similar to the cleanup action +-- semantics in 'bracket'. +-- +-- /See also 'after_'/ +-- +-- /Pre-release/ +{-# INLINE_NORMAL afterIO #-} +afterIO :: MonadIO m + => (a -> IO c) -> Unfold m a b -> Unfold m a b +afterIO action (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + s <- inject1 x + ref <- liftIO $ newIOFinalizer (action x) + return (s, ref) + + {-# INLINE_LATE step #-} + step (st, ref) = do + res <- step1 st + case res of + Yield x s -> return $ Yield x (s, ref) + Skip s -> return $ Skip (s, ref) + Stop -> do + runIOFinalizer ref + return Stop + +{-# INLINE_NORMAL _onException #-} +_onException :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b +_onException action = + gbracket_ return MC.try + (\_ -> return ()) + (nilM (\(a, e :: MC.SomeException) -> action a >> MC.throwM e)) + +-- | Unfold the input @a@ using @Unfold m a b@, run the action @a -> m c@ on +-- @a@ if the unfold aborts due to an exception. +-- +-- /Inhibits stream fusion/ +-- +-- /Pre-release/ +{-# INLINE_NORMAL onException #-} +onException :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b +onException action (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + s <- inject1 x + return (s, x) + + {-# INLINE_LATE step #-} + step (st, v) = do + res <- step1 st `MC.onException` action v + return $ case res of + Yield x s -> Yield x (s, v) + Skip s -> Skip (s, v) + Stop -> Stop + +{-# INLINE_NORMAL _finally #-} +_finally :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b +_finally action = + gbracket_ return MC.try action + (nilM (\(a, e :: MC.SomeException) -> action a >> MC.throwM e)) + +-- | Like 'finallyIO' with following differences: +-- +-- * action @a -> m c@ won't run if the stream is garbage collected +-- after partial evaluation. +-- +-- /Inhibits stream fusion/ +-- +-- /Pre-release/ +{-# INLINE_NORMAL finally_ #-} +finally_ :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b +finally_ action (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + s <- inject1 x + return (s, x) + + {-# INLINE_LATE step #-} + step (st, v) = do + res <- step1 st `MC.onException` action v + case res of + Yield x s -> return $ Yield x (s, v) + Skip s -> return $ Skip (s, v) + Stop -> action v >> return Stop + +-- | Unfold the input @a@ using @Unfold m a b@, run an action on @a@ whenever +-- the unfold stops normally, aborts due to an exception or if it is garbage +-- collected after a partial lazy evaluation. +-- +-- The semantics of the action @a -> m c@ are similar to the cleanup action +-- semantics in 'bracket'. +-- +-- @ +-- finally release = bracket return release +-- @ +-- +-- /See also 'finally_'/ +-- +-- /Inhibits stream fusion/ +-- +-- /Pre-release/ +{-# INLINE_NORMAL finallyIO #-} +finallyIO :: (MonadIO m, MonadCatch m) + => (a -> IO c) -> Unfold m a b -> Unfold m a b +finallyIO action (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + s <- inject1 x + ref <- liftIO $ newIOFinalizer (action x) + return (s, ref) + + {-# INLINE_LATE step #-} + step (st, ref) = do + res <- step1 st `MC.onException` runIOFinalizer ref + case res of + Yield x s -> return $ Yield x (s, ref) + Skip s -> return $ Skip (s, ref) + Stop -> do + runIOFinalizer ref + return Stop + +{-# INLINE_NORMAL _bracket #-} +_bracket :: MonadCatch m + => (a -> m c) -> (c -> m d) -> Unfold m c b -> Unfold m a b +_bracket bef aft = + gbracket_ bef MC.try aft (nilM (\(a, e :: MC.SomeException) -> aft a >> + MC.throwM e)) + +-- | Like 'bracketIO' but with following differences: +-- +-- * alloc action @a -> 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 bracket_ #-} +bracket_ :: MonadCatch m + => (a -> m c) -> (c -> m d) -> Unfold m c b -> Unfold m a b +bracket_ bef aft (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + r <- bef x + s <- inject1 r + return (s, r) + + {-# INLINE_LATE step #-} + step (st, v) = do + res <- step1 st `MC.onException` aft v + case res of + Yield x s -> return $ Yield x (s, v) + Skip s -> return $ Skip (s, v) + Stop -> aft v >> return Stop + +-- | Run the alloc action @a -> m c@ with async exceptions disabled but keeping +-- blocking operations interruptible (see 'Control.Exception.mask'). Use the +-- output @c@ as input to @Unfold m c b@ to generate an output stream. +-- +-- @c@ is usually a resource under the state of monad @m@, e.g. a file +-- handle, that requires a cleanup after use. 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. +-- +-- 'bracket' 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: 'bracket_', 'gbracket'/ +-- +-- /Inhibits stream fusion/ +-- +-- /Pre-release/ +{-# INLINE_NORMAL bracketIO #-} +bracketIO :: (MonadIO m, MonadCatch m) + => (a -> IO c) -> (c -> IO d) -> Unfold m c b -> Unfold m a b +bracketIO bef aft (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + -- Mask asynchronous exceptions to make the execution of 'bef' and + -- the registration of 'aft' atomic. See comment in 'D.gbracketIO'. + (r, ref) <- liftIO $ mask_ $ do + r <- bef x + ref <- newIOFinalizer (aft r) + return (r, ref) + s <- inject1 r + return (s, ref) + + {-# INLINE_LATE step #-} + step (st, ref) = do + res <- step1 st `MC.onException` runIOFinalizer ref + case res of + Yield x s -> return $ Yield x (s, ref) + Skip s -> return $ Skip (s, ref) + Stop -> do + runIOFinalizer ref + return Stop + +-- | When unfolding @Unfold m a b@ if an exception @e@ occurs, unfold @e@ using +-- @Unfold m e b@. +-- +-- /Inhibits stream fusion/ +-- +-- /Pre-release/ +{-# INLINE_NORMAL handle #-} +handle :: (MonadCatch m, Exception e) + => Unfold m e b -> Unfold m a b -> Unfold m a b +handle exc = + gbracket_ return MC.try (\_ -> return ()) (discardFirst exc) diff --git a/src/Streamly/Internal/Data/Unfold/Enumeration.hs b/src/Streamly/Internal/Data/Unfold/Enumeration.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Unfold/Enumeration.hs @@ -0,0 +1,574 @@ +-- | +-- Module : Streamly.Internal.Data.Unfold.Enumeration +-- Copyright : (c) 2019, 2021 Composewell Technologies +-- License : BSD-3-Clause +-- 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 +-- operations 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. +-- +module Streamly.Internal.Data.Unfold.Enumeration + ( + Enumerable (..) + + -- ** Enumerating 'Num' Types + , enumerateFromStepNum + , enumerateFromNum + , enumerateFromThenNum + + -- ** Enumerating unbounded 'Integral' Types + , enumerateFromStepIntegral + , enumerateFromIntegral + , enumerateFromThenIntegral + , enumerateFromToIntegral + , enumerateFromThenToIntegral + + -- ** Enumerating 'Bounded' 'Integral' Types + , enumerateFromIntegralBounded + , enumerateFromThenIntegralBounded + , enumerateFromToIntegralBounded + , enumerateFromThenToIntegralBounded + + -- ** Enumerating small 'Integral' Types + -- | Small types are always bounded. + , enumerateFromSmallBounded + , enumerateFromThenSmallBounded + , enumerateFromToSmall + , enumerateFromThenToSmall + + -- ** Enumerating 'Fractional' Types + -- | Enumeration of 'Num' specialized to 'Fractional' types. + , enumerateFromFractional + , enumerateFromThenFractional + , enumerateFromToFractional + , enumerateFromThenToFractional + ) +where + +#include "inline.hs" +import Data.Fixed +import Data.Bifunctor (bimap) +import Data.Int +import Data.Ratio +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 + , drop, dropWhile) + +-- $setup +-- >>> :m +-- >>> import qualified Streamly.Data.Fold as Fold +-- >>> import qualified Streamly.Data.Stream as Stream +-- >>> import qualified Streamly.Internal.Data.Unfold as Unfold +-- >>> import Streamly.Internal.Data.Unfold.Type +-- >>> import Data.Word + +------------------------------------------------------------------------------ +-- Enumeration of Num +------------------------------------------------------------------------------ + +-- | Unfolds @(from, stride)@ generating an infinite stream starting from +-- @from@ and incrementing every time by @stride@. For 'Bounded' types, after +-- the value overflows it keeps enumerating in a cycle: +-- +-- @ +-- >>> Stream.fold Fold.toList $ Stream.take 10 $ Stream.unfold Unfold.enumerateFromStepNum (255::Word8,1) +-- [255,0,1,2,3,4,5,6,7,8] +-- +-- @ +-- +-- The implementation is numerically stable for floating point values. +-- +-- Note 'enumerateFromStepIntegral' is faster for integrals. +-- +-- /Internal/ +-- +{-# INLINE enumerateFromStepNum #-} +enumerateFromStepNum :: (Monad m, Num a) => Unfold m (a, a) a +enumerateFromStepNum = Unfold step inject + + where + + inject (!from, !stride) = return (from, stride, 0) + + -- Note that the counter "i" is the same type as the type being enumerated. + -- It may overflow, for example, if we are enumerating Word8, after 255 the + -- counter will become 0, but the overflow does not affect the enumeration + -- behavior. + {-# INLINE_LATE step #-} + step (from, stride, i) = + return $ + (Yield $! (from + i * stride)) $! (from, stride, i + 1) + +-- | Same as 'enumerateFromStepNum (from, next)' using a stride of @next - from@: +-- +-- @ +-- >>> enumerateFromThenNum = lmap (\(from, next) -> (from, next - from)) Unfold.enumerateFromStepNum +-- +-- @ +-- +-- Example: +-- @ +-- >>> Stream.fold Fold.toList $ Stream.take 10 $ Stream.unfold enumerateFromThenNum (255::Word8,0) +-- [255,0,1,2,3,4,5,6,7,8] +-- +-- @ +-- +-- The implementation is numerically stable for floating point values. +-- +-- Note that 'enumerateFromThenIntegral' is faster for integrals. +-- +-- Note that in the strange world of floating point numbers, using +-- @enumerateFromThenNum (from, from + 1)@ is almost exactly the same as +-- @enumerateFromStepNum (from, 1) but not precisely the same. Because @(from + +-- 1) - from@ is not exactly 1, it may lose some precision, the loss may also +-- be aggregated in each step, if you want that precision then use +-- 'enumerateFromStepNum' instead. +-- +-- /Internal/ +-- +{-# INLINE enumerateFromThenNum #-} +enumerateFromThenNum :: (Monad m, Num a) => Unfold m (a, a) a +enumerateFromThenNum = + lmap (\(from, next) -> (from, next - from)) enumerateFromStepNum + +-- | Same as 'enumerateFromStepNum' using a stride of 1: +-- +-- @ +-- >>> enumerateFromNum = lmap (\from -> (from, 1)) Unfold.enumerateFromStepNum +-- >>> Stream.fold Fold.toList $ Stream.take 6 $ Stream.unfold enumerateFromNum (0.9) +-- [0.9,1.9,2.9,3.9,4.9,5.9] +-- +-- @ +-- +-- Also, same as 'enumerateFromThenNum' using a stride of 1 but see the note in +-- 'enumerateFromThenNum' about the loss of precision: +-- +-- @ +-- >>> enumerateFromNum = lmap (\from -> (from, from + 1)) Unfold.enumerateFromThenNum +-- >>> Stream.fold Fold.toList $ Stream.take 6 $ Stream.unfold enumerateFromNum (0.9) +-- [0.9,1.9,2.9,3.8999999999999995,4.8999999999999995,5.8999999999999995] +-- +-- @ +-- +-- /Internal/ +-- +{-# INLINE enumerateFromNum #-} +enumerateFromNum :: (Monad m, Num a) => Unfold m a a +enumerateFromNum = lmap (\from -> (from, 1)) enumerateFromStepNum + +------------------------------------------------------------------------------ +-- Enumeration of Integrals +------------------------------------------------------------------------------ + +-- | Can be used to enumerate unbounded integrals. This does not check for +-- overflow or underflow for bounded integrals. +-- +-- /Internal/ +{-# INLINE_NORMAL enumerateFromStepIntegral #-} +enumerateFromStepIntegral :: (Monad m, Integral a) => Unfold m (a, a) a +enumerateFromStepIntegral = Unfold step inject + + where + + inject (from, stride) = from `seq` stride `seq` return (from, stride) + + {-# INLINE_LATE step #-} + step (x, stride) = return $ Yield x $! (x + stride, stride) + +-- Enumerate Unbounded Integrals ---------------------------------------------- +{-# INLINE enumerateFromIntegral #-} +enumerateFromIntegral :: (Monad m, Integral a) => Unfold m a a +enumerateFromIntegral = lmap (\from -> (from, 1)) enumerateFromStepIntegral + +{-# INLINE enumerateFromThenIntegral #-} +enumerateFromThenIntegral :: (Monad m, Integral a ) => Unfold m (a, a) a +enumerateFromThenIntegral = + lmap (\(from, next) -> (from, next - from)) enumerateFromStepIntegral + +{-# INLINE enumerateFromToIntegral #-} +enumerateFromToIntegral :: (Monad m, Integral a) => Unfold m (a, a) a +enumerateFromToIntegral = + takeWhileMWithInput (\(_, to) b -> return $ b <= to) + $ lmap (\(from, _) -> (from, 1)) enumerateFromStepIntegral + +{-# INLINE enumerateFromThenToIntegral #-} +enumerateFromThenToIntegral :: (Monad m, Integral a) => Unfold m (a, a, a) a +enumerateFromThenToIntegral = + takeWhileMWithInput cond $ lmap toFromStep enumerateFromStepIntegral + + where + + toFromStep (from, next, _) = (from, next - from) + + cond (from, next, to) b = + return + $ if next >= from + then b <= to + else b >= to + +-- Enumerate Bounded Integrals ------------------------------------------------ +{-# INLINE enumerateFromIntegralBounded #-} +enumerateFromIntegralBounded :: (Monad m, Integral a, Bounded a) => + Unfold m a a +enumerateFromIntegralBounded = second maxBound enumerateFromToIntegral + +{-# INLINE enumerateFromThenIntegralBounded #-} +enumerateFromThenIntegralBounded :: (Monad m, Integral a, Bounded a ) => + Unfold m (a, a) a +enumerateFromThenIntegralBounded = + takeWhileMWithInput cond $ lmap toFromStep enumerateFromStepIntegral + + where + + toFromStep (from, next) = (from, next - from) + + cond (from, next) b = + return + $ if next >= from + then b <= maxBound + else b >= minBound + +{-# INLINE enumerateFromToIntegralBounded #-} +enumerateFromToIntegralBounded :: (Monad m, Integral a, Bounded a) => + Unfold m (a, a) a +enumerateFromToIntegralBounded = + takeWhileMWithInput (\(_, to) b -> return $ b <= to) + $ lmap fst enumerateFromIntegralBounded + +{-# INLINE enumerateFromThenToIntegralBounded #-} +enumerateFromThenToIntegralBounded :: (Monad m, Integral a, Bounded a) => + Unfold m (a, a, a) a +enumerateFromThenToIntegralBounded = + takeWhileMWithInput cond $ lmap toFromThen enumerateFromThenIntegralBounded + + where + + toFromThen (from, next, _) = (from, next) + + cond (from, next, to) b = + return + $ if next >= from + then b <= to + else b >= to + +------------------------------------------------------------------------------ +-- Enumeration of Fractionals +------------------------------------------------------------------------------ + +{-# INLINE_NORMAL enumerateFromFractional #-} +enumerateFromFractional :: (Monad m, Fractional a) => Unfold m a a +enumerateFromFractional = enumerateFromNum + +{-# INLINE_NORMAL enumerateFromThenFractional #-} +enumerateFromThenFractional :: (Monad m, Fractional a) => Unfold m (a, a) a +enumerateFromThenFractional = enumerateFromThenNum + +-- | Same as 'enumerateFromStepNum' with a step of 1 and enumerating up to the +-- specified upper limit rounded to the nearest integral value: +-- +-- @ +-- >>> Stream.fold Fold.toList $ Stream.unfold Unfold.enumerateFromToFractional (0.1, 6.3) +-- [0.1,1.1,2.1,3.1,4.1,5.1,6.1] +-- +-- @ +-- +-- /Internal/ +-- +{-# INLINE_NORMAL enumerateFromToFractional #-} +enumerateFromToFractional :: (Monad m, Fractional a, Ord a) => + Unfold m (a, a) a +enumerateFromToFractional = + takeWhileMWithInput (\(_, to) b -> return $ b <= to + 1 / 2) + $ lmap (\(from, _) -> (from, 1)) enumerateFromStepNum + +{-# INLINE enumerateFromThenToFractional #-} +enumerateFromThenToFractional :: (Monad m, Fractional a, Ord a) => + Unfold m (a, a, a) a +enumerateFromThenToFractional = + takeWhileMWithInput cond $ lmap toFromStep enumerateFromStepNum + + where + + toFromStep (from, next, _) = (from, next - from) + + cond (from, next, to) b = + let stride = next - from + in return + $ if next >= from + then b <= to + stride / 2 + else b >= to + stride / 2 + +------------------------------------------------------------------------------- +-- Enumeration of Enum types not larger than Int +------------------------------------------------------------------------------- + +-- | Enumerate from given starting Enum value 'from' and to Enum value 'to' +-- with stride of 1 till to value. +-- +-- /Internal/ +-- +{-# INLINE enumerateFromToSmall #-} +enumerateFromToSmall :: (Monad m, Enum a) => Unfold m (a, a) a +enumerateFromToSmall = + fmap toEnum (lmap (bimap fromEnum fromEnum) enumerateFromToIntegral) + +-- | Enumerate from given starting Enum value 'from' and then Enum value 'next' +-- and to Enum value 'to' with stride of (fromEnum next - fromEnum from) +-- till to value. +-- +-- /Internal/ +-- +{-# INLINE enumerateFromThenToSmall #-} +enumerateFromThenToSmall :: (Monad m, Enum a) => Unfold m (a, a, a) a +enumerateFromThenToSmall = + let toInts (x, y, z) = (fromEnum x, fromEnum y, fromEnum z) + in fmap toEnum (lmap toInts enumerateFromThenToIntegral) + +------------------------------------------------------------------------------- +-- Bounded Enumeration of Enum types not larger than Int +------------------------------------------------------------------------------- + +-- | Enumerate from given starting Enum value 'from' with stride of 1 till +-- maxBound +-- +-- /Internal/ +-- +{-# INLINE enumerateFromSmallBounded #-} +enumerateFromSmallBounded :: (Monad m, Enum a, Bounded a) => Unfold m a a +enumerateFromSmallBounded = second maxBound enumerateFromToSmall + +-- | Enumerate from given starting Enum value 'from' and next Enum value 'next' +-- with stride of (fromEnum next - fromEnum from) till maxBound. +-- +-- /Internal/ +-- +{-# INLINE enumerateFromThenSmallBounded #-} +enumerateFromThenSmallBounded :: forall m a. (Monad m, Enum a, Bounded a) => + Unfold m (a, a) a +enumerateFromThenSmallBounded = + let adapt (from, next) = + let frm = fromEnum from + nxt = fromEnum next + stride = nxt - frm + to = if stride >= 0 + then fromEnum (maxBound :: a) + else fromEnum (minBound :: a) + in (frm, nxt, to) + in fmap toEnum (lmap adapt enumerateFromThenToIntegral) + +------------------------------------------------------------------------------- +-- Enumerable type class +------------------------------------------------------------------------------- + +-- | 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.Unfold.Enumeration" module to define new instances. +-- +-- /Pre-release/ +class Enum a => Enumerable a where + + -- | Unfolds @from@ generating 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'. + -- + -- >>> 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) + -- [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 + -- [1.1,2.1,3.1,4.1] + -- + -- @ + -- + -- /Pre-release/ + -- + enumerateFrom :: Monad m => Unfold m a a + + -- | Unfolds @(from, to)@ generating 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. + -- + -- >>> 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) + -- [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) + -- [1.1,2.1,3.1,4.1] + -- + -- >>> Stream.fold Fold.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 + + -- | Unfolds @(from, then)@ generating a stream whose first element is + -- @from@ and the successive elements are in increments of @then@. 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. + -- + -- >>> 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) + -- [0,2,4,6] + -- + -- >>> Stream.fold Fold.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFromThen (0,(-2)) + -- [0,-2,-4,-6] + -- + -- @ + -- + -- /Pre-release/ + enumerateFromThen :: Monad m => Unfold m (a, a) a + + -- | Unfolds @(from, then, to)@ generating a finite stream whose first element + -- is @from@ and the successive elements are in increments of @then@ up to + -- @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) + -- [0,2,4,6] + -- + -- >>> Stream.fold Fold.toList $ Stream.unfold Unfold.enumerateFromThenTo (0, (-2), (-6)) + -- [0,-2,-4,-6] + -- + -- @ + -- + -- /Pre-release/ + enumerateFromThenTo :: Monad m => Unfold m (a, a, a) a + +------------------------------------------------------------------------------- +-- 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 = enumerateFromSmallBounded; \ + {-# 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 = enumerateFromIntegralBounded; \ + {-# INLINE enumerateFromThen #-}; \ + enumerateFromThen = enumerateFromThenIntegralBounded; \ + {-# INLINE enumerateFromTo #-}; \ + enumerateFromTo = enumerateFromToIntegralBounded; \ + {-# INLINE enumerateFromThenTo #-}; \ + enumerateFromThenTo = enumerateFromThenToIntegralBounded } + +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 = enumerateFromIntegral; \ + {-# INLINE enumerateFromThen #-}; \ + enumerateFromThen = enumerateFromThenIntegral; \ + {-# 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 = + map Identity $ lmap runIdentity enumerateFrom + {-# INLINE enumerateFromThen #-} + enumerateFromThen = + map Identity $ lmap (bimap runIdentity runIdentity) enumerateFromThen + {-# INLINE enumerateFromTo #-} + enumerateFromTo = + map Identity $ lmap (bimap runIdentity runIdentity) enumerateFromThen + {-# INLINE enumerateFromThenTo #-} + enumerateFromThenTo = + map Identity $ + lmap + (\(from, next, to) -> + (runIdentity from, runIdentity next, runIdentity to)) + enumerateFromThenTo diff --git a/src/Streamly/Internal/Data/Unfold/Type.hs b/src/Streamly/Internal/Data/Unfold/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Unfold/Type.hs @@ -0,0 +1,1003 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Unfold.Type +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- An unfold is akin to a reader. It is the streaming equivalent of a reader. +-- The argument @a@ is the environment of the reader. That's the reason the +-- default unfolds in various modules are named "reader". + +-- = Performance Notes +-- +-- 'Unfold' representation is more efficient than using streams when combining +-- streams. 'Unfold' type allows multiple unfold actions to be composed into a +-- single unfold function in an efficient manner by enabling the compiler to +-- perform stream fusion optimization. +-- @Unfold m a b@ can be considered roughly equivalent to an action @a -> t m +-- b@ (where @t@ is a stream type). Instead of using an 'Unfold' one could just +-- use a function of the shape @a -> t m b@. However, working with stream types +-- like t'Streamly.SerialT' does not allow the compiler to perform stream fusion +-- optimization when merging, appending or concatenating multiple streams. +-- Even though stream based combinator have excellent performance, they are +-- 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'. +-- +-- On the other hand, transformation operations on stream types are as +-- efficient as transformations on 'Unfold'. +-- +-- We should note that in some cases working with stream types may be more +-- convenient compared to working with the 'Unfold' type. However, if extra +-- performance boost is important then 'Unfold' based composition should be +-- preferred compared to stream based composition when merging or concatenating +-- streams. + +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 (..) + + -- * Basic Constructors + , mkUnfoldM + , mkUnfoldrM + , unfoldrM + , unfoldr + , functionM + , function + , identity + + -- * From Values + , fromEffect + , fromPure + + -- * From Containers + , fromList + + -- * Transformations + , lmap + , lmapM + , map + , map2 + , mapM + , mapM2 + , both + , first + , second + + -- * Trimming + , takeWhileMWithInput + , takeWhileM + , takeWhile + + -- * Nesting + , ConcatState (..) + , many + , many2 + , manyInterleave + -- , manyInterleave2 + + -- Applicative + , crossApplySnd + , crossApplyFst + , crossWithM + , crossWith + , cross + , crossApply + + -- Monad + , concatMapM + , concatMap + , bind + + , zipWithM + , zipWith + ) +where + +#include "inline.hs" + +-- import Control.Arrow (Arrow(..)) +-- import Control.Category (Category(..)) +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 Prelude hiding (map, mapM, concatMap, zipWith, takeWhile) + +#include "DocTestDataUnfold.hs" + +-- $notes +-- +-- What makes streams less efficient is also what makes them more convenient to +-- use and powerful. The stream data type (Stream m a) bundles the state along +-- with the stream generator function making it opaque, whereas an unfold +-- exposes the state (Unfold m s a) to the user. This allows the Unfold to be +-- unfolded (inlined) inside a nested loop without having to bundle the state +-- and the generator together, the stream state can be saved and passed +-- independent of the generator function. On the other hand in a stream type we +-- have to bundle the stream state and the generator function together to save +-- the stream. This makes it inefficient because it requires boxing and +-- constructor allocation. However, this makes streams more convenient as we do +-- not need to pass around the state/seed separately. +-- +-- Unfold Type: +-- +-- The order of arguments allows 'Category' and 'Arrow' instances but precludes +-- contravariant and contra-applicative. +-- +-- = Unfolds and Streams +-- +-- An 'Unfold' type is the same as the direct style 'Stream' type except that +-- it uses an inject function to determine the initial state of the stream +-- based on an input. A stream is a special case of Unfold when the static +-- input is unit or Void. +-- +-- 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' +-- 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 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 +-- to the consumer in case of unfolds, the consumer knows how to generate the +-- stream from a seed using a known "inject" and "step" functions. +-- +-- A Stream is like a data object whereas unfold is like a function. Being +-- function like, an Unfold is an instance of 'Category' and 'Arrow' type +-- classes. +-- +-- = Unfolds and Folds +-- +-- Streams forcing a closed control flow loop can be categorized under +-- two types, unfolds and folds, both of these are duals of each other. +-- +-- Unfold streams are really generators of a sequence of elements, we can also +-- call them pull style streams. These are lazy producers of streams. On each +-- evaluation the producer generates the next element. A consumer can +-- therefore pull elements from the stream whenever it wants to. A stream +-- consumer can multiplex pull streams by pulling elements from the chosen +-- streams, therefore, pull streams allow merging or multiplexing. On the +-- other hand, with this representation we cannot split or demultiplex a +-- stream. So really these are stream sources that can be generated from a +-- seed and can be merged or zipped into a single stream. +-- +-- The dual of Unfolds are Folds. Folds can also be called as push style +-- streams or reducers. These are strict consumers of streams. We keep pushing +-- elements to a fold and we can extract the result at any point. A driver can +-- choose which fold to push to and can also push the same element to multiple +-- folds. Therefore, folds allow splitting or demultiplexing a stream. On the +-- other hand, we cannot merge streams using this representation. So really +-- these are stream consumers that reduce the stream to a single value, these +-- consumers can be composed such that a stream can be split over multiple +-- consumers. +-- +-- Performance: +-- +-- Composing a tree or graph of computations with unfolds can be much more +-- efficient compared to composing with the Monad instance. The reason is that +-- unfolds allow the compiler to statically know the state and optimize it +-- using stream fusion whereas it is not possible with the monad bind because +-- the state is determined dynamically. +-- +-- Reader: +-- +-- An unfold acts as a reader (see 'Reader' monad). The input to an unfold acts +-- as the read-only environment. The environment can be extracted using the +-- 'identity' unfold (equivalent to 'ask') and transformed using 'lmap'. + +------------------------------------------------------------------------------ +-- Monadic Unfolds +------------------------------------------------------------------------------ + +-- | An @Unfold m a b@ is a generator of a stream of values of type @b@ from a +-- seed of type 'a' in 'Monad' @m@. +-- +data Unfold m a b = + -- | @Unfold step inject@ + forall s. Unfold (s -> m (Step s b)) (a -> m s) + +------------------------------------------------------------------------------ +-- Basic constructors +------------------------------------------------------------------------------ + +-- | Make an unfold from @step@ and @inject@ functions. +-- +-- /Pre-release/ +{-# INLINE mkUnfoldM #-} +mkUnfoldM :: (s -> m (Step s b)) -> (a -> m s) -> Unfold m a b +mkUnfoldM = Unfold + +-- | Make an unfold from a step function. +-- +-- See also: 'unfoldrM' +-- +-- /Pre-release/ +{-# INLINE mkUnfoldrM #-} +mkUnfoldrM :: Applicative m => (a -> m (Step a b)) -> Unfold m a b +mkUnfoldrM step = Unfold step pure + +-- The type 'Step' is isomorphic to 'Maybe'. Ideally unfoldrM should be the +-- same as mkUnfoldrM, this is for compatibility with traditional Maybe based +-- unfold step functions. + +-- | 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. +-- +{-# INLINE unfoldrM #-} +unfoldrM :: Applicative m => (a -> m (Maybe (b, a))) -> Unfold m a b +unfoldrM next = Unfold step pure + where + {-# INLINE_LATE step #-} + step st = + (\case + Just (x, s) -> Yield x s + Nothing -> Stop) <$> next st + +-- | Like 'unfoldrM' but uses a pure step function. +-- +-- >>> :{ +-- f [] = Nothing +-- f (x:xs) = Just (x, xs) +-- :} +-- +-- >>> Unfold.fold Fold.toList (Unfold.unfoldr f) [1,2,3] +-- [1,2,3] +-- +{-# INLINE unfoldr #-} +unfoldr :: Applicative m => (a -> Maybe (b, a)) -> Unfold m a b +unfoldr step = unfoldrM (pure . step) + +------------------------------------------------------------------------------ +-- Map input +------------------------------------------------------------------------------ + +-- | Map a function on the input argument of the 'Unfold'. +-- +-- >>> u = Unfold.lmap (fmap (+1)) Unfold.fromList +-- >>> Unfold.fold Fold.toList u [1..5] +-- [2,3,4,5,6] +-- +-- @ +-- lmap f = Unfold.many (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) +-- @ +-- +{-# 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) +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL both #-} +both :: a -> Unfold m a b -> Unfold m Void b +both a = lmap (Prelude.const a) + +-- | Supply the first component of the tuple to an unfold that accepts a tuple +-- as a seed resulting in a fold that accepts the second component of the tuple +-- as a seed. +-- +-- @ +-- first a = Unfold.lmap (a, ) +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL first #-} +first :: a -> Unfold m (a, b) c -> Unfold m b c +first a = lmap (a, ) + +-- | Supply the second component of the tuple to an unfold that accepts a tuple +-- as a seed resulting in a fold that accepts the first component of the tuple +-- as a seed. +-- +-- @ +-- second b = Unfold.lmap (, b) +-- @ +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL second #-} +second :: b -> Unfold m (a, b) c -> Unfold m a c +second b = lmap (, b) + +------------------------------------------------------------------------------ +-- Filter input +------------------------------------------------------------------------------ + +{-# INLINE_NORMAL takeWhileMWithInput #-} +takeWhileMWithInput :: Monad m => + (a -> b -> m Bool) -> Unfold m a b -> Unfold m a b +takeWhileMWithInput f (Unfold step1 inject1) = Unfold step inject + + where + + inject a = do + s <- inject1 a + return $ Tuple' a s + + {-# INLINE_LATE step #-} + step (Tuple' a st) = do + r <- step1 st + case r of + Yield x s -> do + b <- f a x + 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. +-- +{-# INLINE_NORMAL takeWhileM #-} +takeWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b +-- XXX Check if the compiler simplifies the following to the same as the custom +-- implementation below (the Tuple' should help eliminate the unused param): +-- +-- takeWhileM f = takeWhileMWithInput (\_ b -> f b) +takeWhileM f (Unfold step1 inject1) = Unfold step inject1 + where + {-# INLINE_LATE step #-} + step st = do + r <- step1 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 generated by the 'Unfold' as soon as the predicate fails +-- on an element. +-- +{-# INLINE takeWhile #-} +takeWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b +takeWhile f = takeWhileM (return . f) + +------------------------------------------------------------------------------ +-- Functor +------------------------------------------------------------------------------ + +{-# INLINE_NORMAL mapM2 #-} +mapM2 :: Monad m => (a -> b -> m c) -> Unfold m a b -> Unfold m a c +mapM2 f (Unfold ustep uinject) = Unfold step inject + where + inject a = do + r <- uinject a + return (a, r) + + {-# INLINE_LATE step #-} + step (inp, st) = do + r <- ustep st + case r of + 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) +mapM f (Unfold ustep uinject) = Unfold step uinject + where + {-# INLINE_LATE step #-} + step st = do + r <- ustep st + case r of + Yield x s -> f x >>= \a -> return $ Yield a s + 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. + +-- | +-- +-- >>> map2 f = Unfold.mapM2 (\a b -> pure (f a b)) +-- +-- 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. +-- +{-# 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) + + where + + func a r = + case r of + Yield x s -> Yield (f a x) (a, s) + Skip s -> Skip (a, s) + Stop -> Stop + + {-# INLINE_LATE step #-} + step (a, st) = fmap (func a) (ustep st) + +-- | 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 +-- map f = map2 (const f) +map f (Unfold ustep uinject) = Unfold step uinject + + where + + {-# INLINE_LATE step #-} + step st = fmap (fmap f) (ustep st) + +-- | Maps a function on the output of the unfold (the type @b@). +instance Functor m => Functor (Unfold m a) where + {-# INLINE fmap #-} + fmap = map + +------------------------------------------------------------------------------ +-- Applicative +------------------------------------------------------------------------------ + +-- XXX Shouldn't this be Unfold m (m a) a ? + +-- | The unfold discards its input and generates a function stream using the +-- supplied monadic action. +-- +-- /Pre-release/ +{-# INLINE fromEffect #-} +fromEffect :: Applicative m => m b -> Unfold m a b +fromEffect m = Unfold step inject + + where + + inject _ = pure False + + step False = (`Yield` True) <$> m + step True = pure Stop + +-- XXX Shouldn't this be Unfold m a a ? Which is identity. Should this function +-- even exist for Unfolds. Should we have applicative/Monad for unfolds? + +-- | Discards the unfold input and always returns the argument of 'fromPure'. +-- +-- > fromPure = fromEffect . pure +-- +-- /Pre-release/ +fromPure :: Applicative m => b -> Unfold m a b +fromPure = fromEffect Prelude.. pure + +-- XXX Check if "unfold (fromList [1..10])" fuses, if it doesn't we can use +-- rewrite rules to rewrite list enumerations to unfold enumerations. + +-- | Convert a list of pure values to a 'Stream' +-- +{-# INLINE_LATE fromList #-} +fromList :: Applicative m => Unfold m [a] a +fromList = Unfold step pure + + where + + {-# INLINE_LATE step #-} + step (x:xs) = pure $ Yield x xs + step [] = pure Stop + +-- | Outer product discarding the first element. +-- +-- /Unimplemented/ +-- +{-# INLINE_NORMAL crossApplySnd #-} +crossApplySnd :: -- Monad m => + Unfold m a b -> Unfold m a c -> Unfold m a c +crossApplySnd (Unfold _step1 _inject1) (Unfold _step2 _inject2) = undefined + +-- | Outer product discarding the second element. +-- +-- /Unimplemented/ +-- +{-# INLINE_NORMAL crossApplyFst #-} +crossApplyFst :: -- Monad m => + 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 + +{-# 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 + + where + + inject a = do + s <- inject1 a + return $ Many2Outer a s + + {-# INLINE_LATE step #-} + step (Many2Outer a st) = do + r <- step1 st + case r of + Yield b s -> do + innerSt <- inject2 (a, b) + return $ Skip (Many2Inner a s innerSt) + Skip s -> return $ Skip (Many2Outer a s) + Stop -> return Stop + + step (Many2Inner a ost ist) = do + r <- step2 ist + return $ case r of + 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 + +-- | 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 => + (b -> c -> m d) -> Unfold m a b -> Unfold m a c -> Unfold m a d +-- crossWithM f u1 u2 = many2 (mapM2 (\(_, b) c -> f b c) (lmap fst u2)) u1 +crossWithM f (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject + + where + + inject a = do + s1 <- inject1 a + return $ CrossOuter a s1 + + {-# INLINE_LATE step #-} + step (CrossOuter a s1) = do + r <- step1 s1 + case r of + Yield b s -> do + s2 <- inject2 a + return $ Skip (CrossInner a s b s2) + Skip s -> return $ Skip (CrossOuter a s) + Stop -> return Stop + + step (CrossInner a s1 b s2) = do + r <- step2 s2 + case r of + Yield c s -> f b c >>= \d -> return $ Yield d (CrossInner a s1 b s) + Skip s -> return $ Skip (CrossInner a s1 b s) + Stop -> return $ Skip (CrossOuter a s1) + +-- | Like 'crossWithM' but uses a pure combining function. +-- +-- > crossWith f = crossWithM (\b c -> return $ f b c) +-- +-- >>> u1 = Unfold.lmap fst Unfold.fromList +-- >>> u2 = Unfold.lmap snd Unfold.fromList +-- >>> u = Unfold.crossWith (,) u1 u2 +-- >>> Unfold.fold Fold.toList u ([1,2,3], [4,5,6]) +-- [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] +-- +{-# INLINE crossWith #-} +crossWith :: Monad m => + (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d +crossWith f = crossWithM (\b c -> return $ f b c) + +-- | See 'crossWith'. +-- +-- Definition: +-- +-- >>> cross = Unfold.crossWith (,) +-- +-- To create a cross product of the streams generated from a tuple we can +-- write: +-- +-- >>> :{ +-- cross :: Monad m => Unfold m a b -> Unfold m c d -> Unfold m (a, c) (b, d) +-- cross u1 u2 = Unfold.cross (Unfold.lmap fst u1) (Unfold.lmap snd u2) +-- :} +-- +-- /Pre-release/ +{-# INLINE_NORMAL cross #-} +cross :: Monad m => Unfold m a b -> Unfold m a c -> Unfold m a (b, c) +cross = crossWith (,) + +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) + +-- XXX Applicative makes sense for unfolds, but monad does not. Use streams for +-- monad. + +{- +-- | Example: +-- +-- >>> rlist = Unfold.lmap fst Unfold.fromList +-- >>> llist = Unfold.lmap snd Unfold.fromList +-- >>> Stream.fold Fold.toList $ Stream.unfold ((,) <$> rlist <*> llist) ([1,2],[3,4]) +-- [(1,3),(1,4),(2,3),(2,4)] +-- +instance Monad m => Applicative (Unfold m a) where + {-# INLINE pure #-} + pure = fromPure + + {-# INLINE (<*>) #-} + (<*>) = apply + + -- {-# INLINE (*>) #-} + -- (*>) = apSequence + + -- {-# INLINE (<*) #-} + -- (<*) = apDiscardSnd +-} + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + +data ConcatMapState m b s1 x = + ConcatMapOuter x s1 + | forall s2. ConcatMapInner x s1 s2 (s2 -> m (Step s2 b)) + +-- XXX This is experimental. We should rather use streams if concatMap like +-- functionality is needed. This is no more efficient than streams. + +-- | Map an unfold generating action to each element of an unfold and +-- flatten the results into a single stream. +-- +{-# INLINE_NORMAL concatMapM #-} +concatMapM :: Monad m + => (b -> m (Unfold m a c)) -> Unfold m a b -> Unfold m a c +concatMapM f (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + s <- inject1 x + return $ ConcatMapOuter x s + + {-# INLINE_LATE step #-} + step (ConcatMapOuter seed st) = do + r <- step1 st + case r of + Yield x s -> do + Unfold step2 inject2 <- f x + innerSt <- inject2 seed + return $ Skip (ConcatMapInner seed s innerSt step2) + Skip s -> return $ Skip (ConcatMapOuter seed s) + Stop -> return Stop + + step (ConcatMapInner seed ost ist istep) = do + r <- istep ist + return $ case r of + Yield x s -> Yield x (ConcatMapInner seed ost s istep) + Skip s -> Skip (ConcatMapInner seed ost s istep) + Stop -> Skip (ConcatMapOuter seed ost) + +{-# INLINE concatMap #-} +concatMap :: Monad m => (b -> Unfold m a c) -> Unfold m a b -> Unfold m a c +concatMap f = concatMapM (return Prelude.. f) + +infixl 1 `bind` + +{-# INLINE bind #-} +bind :: Monad m => Unfold m a b -> (b -> Unfold m a c) -> Unfold m a c +bind = flip concatMap + +{- +-- Note: concatMap and Monad instance for unfolds have performance comparable +-- to Stream. In fact, concatMap is slower than Stream, that may be some +-- optimization issue though. +-- +-- Monad allows an unfold to depend on the output of a previous unfold. +-- However, it is probably easier to use streams in such situations. +-- +-- | Example: +-- +-- >>> :{ +-- u = do +-- x <- Unfold.enumerateFromToIntegral 4 +-- y <- Unfold.enumerateFromToIntegral x +-- return (x, y) +-- :} +-- >>> Stream.fold Fold.toList $ Stream.unfold u 1 +-- [(1,1),(2,1),(2,2),(3,1),(3,2),(3,3),(4,1),(4,2),(4,3),(4,4)] +-- +instance Monad m => Monad (Unfold m a) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + (>>=) = flip concatMap + + -- {-# INLINE (>>) #-} + -- (>>) = (*>) +-} + +------------------------------------------------------------------------------- +-- Category +------------------------------------------------------------------------------- + +-- | Lift a monadic function into an unfold. The unfold generates a singleton +-- stream. +-- +{-# INLINE functionM #-} +functionM :: Applicative m => (a -> m b) -> Unfold m a b +functionM f = Unfold step inject + + where + + inject x = pure $ Just x + + {-# INLINE_LATE step #-} + step (Just x) = (`Yield` Nothing) <$> f x + step Nothing = pure Stop + +-- | Lift a pure function into an unfold. The unfold generates a singleton +-- stream. +-- +-- > function f = functionM $ return . f +-- +{-# INLINE function #-} +function :: Applicative m => (a -> b) -> Unfold m a b +function f = functionM $ pure Prelude.. f + +-- | Identity unfold. The unfold generates a singleton stream having the input +-- as the only element. +-- +-- > identity = function Prelude.id +-- +-- /Pre-release/ +{-# INLINE identity #-} +identity :: Applicative m => Unfold m a a +identity = function Prelude.id + +{-# ANN type ConcatState Fuse #-} +data ConcatState s1 s2 = ConcatOuter s1 | ConcatInner s1 s2 + +-- | 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 +-- many u1 = many2 (lmap snd u1) +many (Unfold step2 inject2) (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + s <- inject1 x + return $ ConcatOuter s + + {-# INLINE_LATE step #-} + step (ConcatOuter st) = do + r <- step1 st + case r of + Yield x s -> do + innerSt <- inject2 x + return $ Skip (ConcatInner s innerSt) + Skip s -> return $ Skip (ConcatOuter s) + Stop -> return Stop + + step (ConcatInner ost ist) = do + r <- step2 ist + return $ case r of + Yield x s -> Yield x (ConcatInner ost s) + Skip s -> Skip (ConcatInner ost s) + Stop -> Skip (ConcatOuter ost) + +{- +-- XXX There are multiple possible ways to combine the unfolds, "many" appends +-- them, we could also have other variants of "many" e.g. manyInterleave. +-- Should we even have a category instance or just use these functions +-- directly? +-- +instance Monad m => Category (Unfold m) where + {-# INLINE id #-} + id = identity + + {-# INLINE (.) #-} + (.) = many +-} + +------------------------------------------------------------------------------- +-- Zipping +------------------------------------------------------------------------------- + +-- | Distribute the input to two unfolds and then zip the outputs to a single +-- stream using a monadic zip function. +-- +-- 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 (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject + + where + + inject x = do + s1 <- inject1 x + s2 <- inject2 x + 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 + +-- | Like 'zipWithM' but with a pure zip function. +-- +-- >>> square = fmap (\x -> x * x) Unfold.fromList +-- >>> cube = fmap (\x -> x * x * x) Unfold.fromList +-- >>> u = Unfold.zipWith (,) square cube +-- >>> Unfold.fold Fold.toList u [1..5] +-- [(1,1),(4,8),(9,27),(16,64),(25,125)] +-- +-- > zipWith f = zipWithM (\a b -> return $ f a b) +-- +{-# INLINE zipWith #-} +zipWith :: Monad m + => (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d +zipWith f = zipWithM (\a b -> return (f a b)) + +------------------------------------------------------------------------------- +-- Arrow +------------------------------------------------------------------------------- + +{- +-- XXX There are multiple ways of combining the outputs of two unfolds, we +-- could zip, merge, append and more. What is the preferred way for Arrow +-- instance? Should we even have an arrow instance or just use these functions +-- directly? +-- +-- | '***' is a zip like operation, in fact it is the same as @Unfold.zipWith +-- (,)@, '&&&' is a tee like operation i.e. distributes the input to both the +-- unfolds and then zips the output. +-- +{-# ANN module "HLint: ignore Use zip" #-} +instance Monad m => Arrow (Unfold m) where + {-# INLINE arr #-} + arr = function + + {-# INLINE (***) #-} + u1 *** u2 = zipWith (,) (lmap fst u1) (lmap snd u2) +-} + +------------------------------------------------------------------------------ +-- Interleaving +------------------------------------------------------------------------------ + +-- We can possibly have an "interleave" operation to interleave the streams +-- from two seeds: +-- +-- interleave :: Unfold m x a -> Unfold m x a -> Unfold m (x, x) a +-- +-- Alternatively, we can use a signature like zipWith: +-- interleave :: Unfold m x a -> Unfold m x a -> Unfold m x a +-- +-- We can implement this in terms of manyInterleave, but that may +-- not be as efficient as a custom implementation. +-- +-- Similarly we can also have other binary combining ops like append, mergeBy. +-- We already have zipWith. +-- + +data ManyInterleaveState o i = + ManyInterleaveOuter o [i] + | ManyInterleaveInner o [i] + | ManyInterleaveInnerL [i] [i] + | ManyInterleaveInnerR [i] [i] + +-- | 'Streamly.Internal.Data.Stream.unfoldManyInterleave' 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) = + Unfold step inject + + where + + inject x = do + ost <- oinject x + return (ManyInterleaveOuter ost []) + + {-# INLINE_LATE step #-} + step (ManyInterleaveOuter o ls) = do + r <- ostep o + case r of + Yield a o' -> do + i <- iinject a + i `seq` return (Skip (ManyInterleaveInner o' (i : ls))) + Skip o' -> return $ Skip (ManyInterleaveOuter o' ls) + Stop -> return $ Skip (ManyInterleaveInnerL ls []) + + step (ManyInterleaveInner _ []) = undefined + step (ManyInterleaveInner o (st:ls)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ManyInterleaveOuter o (s:ls)) + Skip s -> Skip (ManyInterleaveInner o (s:ls)) + Stop -> Skip (ManyInterleaveOuter o ls) + + step (ManyInterleaveInnerL [] []) = return Stop + step (ManyInterleaveInnerL [] rs) = + return $ Skip (ManyInterleaveInnerR [] rs) + + step (ManyInterleaveInnerL (st:ls) rs) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ManyInterleaveInnerL ls (s:rs)) + Skip s -> Skip (ManyInterleaveInnerL (s:ls) rs) + Stop -> Skip (ManyInterleaveInnerL ls rs) + + step (ManyInterleaveInnerR [] []) = return Stop + step (ManyInterleaveInnerR ls []) = + return $ Skip (ManyInterleaveInnerL ls []) + + step (ManyInterleaveInnerR ls (st:rs)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ManyInterleaveInnerR (s:ls) rs) + Skip s -> Skip (ManyInterleaveInnerR ls (s:rs)) + Stop -> Skip (ManyInterleaveInnerR ls rs) diff --git a/src/Streamly/Internal/FileSystem/Dir.hs b/src/Streamly/Internal/FileSystem/Dir.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Dir.hs @@ -0,0 +1,463 @@ +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.FileSystem.Dir +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : pre-release +-- Portability : GHC + +module Streamly.Internal.FileSystem.Dir + ( + -- * Streams + read + + -- read not just the names but also the inode attrs of the children. This + -- abstraction makes sense because when we read the dir contents we also + -- get the inodes, and it is cheaper to get the attrs from the inodes + -- instead of resolving the paths and get those. This abstraction may be + -- less portable as different platforms may have different attrs. To + -- optimize, we can also add a filter/pattern/parser on the names of the + -- children that we want to read. We can call that readAttrsWith? Or just + -- have the default readAttrs do that? Usually we won't need that, so it + -- may be better to keep that a separate API. + -- , readAttrs + + -- recursive read requires us to read the attributes of the children to + -- determine if something is a dirctory or not. Therefore, it may be a good + -- idea to have a low level routine that also spits out the attributes of + -- the files, we get that for free. We can also add a filter/pattern/parser + -- on the names of the children that we want to read. + --, readAttrsRecursive -- Options: acyclic, follow symlinks + , readFiles + , readDirs + , readEither + , readEitherPaths + + -- 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 + -} + -- * Deprecated + , toStream + , toEither + , toFiles + , toDirs + ) +where + +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) + +-- 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 + +-- | Read a directory emitting a stream with names of the children. Filter out +-- "." and ".." entries. +-- +-- /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. + +-- | Read directories as Left and files as Right. Filter out "." and ".." +-- entries. +-- +-- /Internal/ +-- +{-# INLINE eitherReader #-} +eitherReader :: MonadIO m => Unfold m FilePath (Either FilePath FilePath) +eitherReader = UF.mapM2 classify reader + + 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 + +-- +-- | Read files only. +-- +-- /Internal/ +-- +{-# INLINE fileReader #-} +fileReader :: MonadIO m => Unfold m FilePath FilePath +fileReader = fmap (fromRight undefined) $ UF.filter isRight eitherReader + +-- | 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 + +-- | Raw read of a directory. +-- +-- /Pre-release/ +{-# INLINE read #-} +read :: MonadIO 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 = read + +-- | 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 => 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 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 = readEither + +-- | Read files only. +-- +-- /Internal/ +-- +{-# INLINE readFiles #-} +readFiles :: MonadIO 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 = readFiles + +-- | Read directories only. +-- +-- /Internal/ +-- +{-# INLINE readDirs #-} +readDirs :: MonadIO 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 = 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/File.hs b/src/Streamly/Internal/FileSystem/File.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/File.hs @@ -0,0 +1,679 @@ +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.FileSystem.File +-- 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. Unlike the handle based APIs which can have a read/write +-- session consisting of multiple reads and writes to the handle, these APIs +-- are one shot read or write APIs. These APIs open the file handle, perform +-- the requested operation and close the handle. Thease are safer compared to +-- the handle based APIs as there is no possibility of a file descriptor +-- leakage. +-- +-- > import qualified Streamly.Internal.FileSystem.File as File +-- + +module Streamly.Internal.FileSystem.File + ( + -- * 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 -- putBytes? + , fromBytesWith + , fromChunks + + -- ** Append To File + , append + , appendWith + -- , appendShared + , appendArray + , appendChunks + + -- * Deprecated + , readWithBufferOf + , readChunksWithBufferOf + , readChunksFromToWith + , toBytes + , toChunks + , toChunksWithBufferOf + , writeWithBufferOf + , fromBytesWithBufferOf + ) +where + +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Word (Word8) +import System.IO (Handle, openFile, IOMode(..), hClose) +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.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.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 + +------------------------------------------------------------------------------- +-- 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 using 'openFile' and passes +-- the resulting handle to the computation @act@. The handle will be +-- closed on exit from 'withFile', whether by normal termination or by +-- raising an exception. If closing the handle raises an exception, then +-- this exception will be raised by 'withFile' rather than any exception +-- raised by 'act'. +-- +-- /Pre-release/ +-- +{-# 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 + +-- | 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 +-- or in case of an exception. If closing the handle raises an exception, then +-- this exception will be raised by 'usingFile'. +-- +-- /Pre-release/ +-- +{-# INLINE usingFile #-} +usingFile :: (MonadIO m, MonadCatch m) + => Unfold m Handle a -> Unfold m FilePath a +usingFile = UF.bracketIO (`openFile` ReadMode) hClose + +{-# INLINE usingFile2 #-} +usingFile2 :: (MonadIO m, MonadCatch m) + => Unfold m (x, Handle) a -> Unfold m (x, FilePath) a +usingFile2 = UF.bracketIO before after + + where + + before (x, file) = do + h <- openFile file ReadMode + 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, FilePath) a +usingFile3 = UF.bracketIO before after + + where + + before (x, y, z, file) = do + h <- openFile file ReadMode + 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 :: 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) + +------------------------------------------------------------------------------- +-- 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 -> FilePath -> Stream m (Array Word8) +readChunksWith size file = + withFile file ReadMode (FH.readChunksWith size) + +{-# DEPRECATED toChunksWithBufferOf "Please use 'readChunksWith' instead" #-} +{-# INLINE toChunksWithBufferOf #-} +toChunksWithBufferOf :: (MonadIO m, MonadCatch m) + => Int -> FilePath -> Stream m (Array Word8) +toChunksWithBufferOf = readChunksWith + +-- 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) + => FilePath -> Stream m (Array Word8) +readChunks = readChunksWith defaultChunkSize + +{-# DEPRECATED toChunks "Please use 'readChunks' instead" #-} +{-# INLINE toChunks #-} +toChunks :: (MonadIO m, MonadCatch m) => FilePath -> Stream m (Array Word8) +toChunks = readChunks + +------------------------------------------------------------------------------- +-- 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, FilePath) (Array Word8) +chunkReaderWith = usingFile2 FH.chunkReaderWith + +{-# DEPRECATED readChunksWithBufferOf + "Please use 'chunkReaderWith' instead" #-} +{-# INLINE readChunksWithBufferOf #-} +readChunksWithBufferOf :: (MonadIO m, MonadCatch m) + => Unfold m (Int, FilePath) (Array Word8) +readChunksWithBufferOf = 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, FilePath) (Array Word8) +chunkReaderFromToWith = usingFile3 FH.chunkReaderFromToWith + +{-# DEPRECATED readChunksFromToWith + "Please use 'chunkReaderFromToWith' instead" #-} +{-# INLINE readChunksFromToWith #-} +readChunksFromToWith :: (MonadIO m, MonadCatch m) => + Unfold m (Int, Int, Int, FilePath) (Array Word8) +readChunksFromToWith = chunkReaderFromToWith + +-- | Unfolds a 'FilePath' 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 FilePath (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, FilePath) Word8 +readerWith = usingFile2 FH.readerWith + +{-# DEPRECATED readWithBufferOf "Please use 'readerWith' instead" #-} +{-# INLINE readWithBufferOf #-} +readWithBufferOf :: (MonadIO m, MonadCatch m) => + Unfold m (Int, FilePath) Word8 +readWithBufferOf = 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 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 + +-- | 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) => FilePath -> Stream m Word8 +read file = concatChunks $ withFile file ReadMode FH.readChunks + +{-# DEPRECATED toBytes "Please use 'read' instead" #-} +{-# INLINE toBytes #-} +toBytes :: (MonadIO m, MonadCatch m) => FilePath -> Stream m Word8 +toBytes = read + +{- +-- | 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 -> FilePath -> 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) + => FilePath -> 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 -> FilePath -> Stream m Word8 -> m () +fromBytesWith n file xs = fromChunks file $ S.chunksOf n xs + +{-# DEPRECATED fromBytesWithBufferOf "Please use 'fromBytesWith' instead" #-} +{-# INLINE fromBytesWithBufferOf #-} +fromBytesWithBufferOf :: (MonadIO m, MonadCatch m) + => Int -> FilePath -> Stream m Word8 -> m () +fromBytesWithBufferOf = fromBytesWith + +-- > 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) => FilePath -> 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 handle. Each chunk in the stream is written +-- to the device as a separate IO request. +-- +-- /Pre-release/ +{-# INLINE writeChunks #-} +writeChunks :: (MonadIO m, MonadCatch m) + => FilePath -> Fold m (Array a) () +writeChunks path = Fold step initial extract + where + initial = do + h <- liftIO (openFile path WriteMode) + 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 + liftIO $ hClose h + res <- initial1 + case res of + FL.Partial fs -> extract1 fs + FL.Done fb -> return fb + +-- | @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 -> FilePath -> Fold m Word8 () +writeWith n path = + groupsOf n (writeNUnsafe n) (writeChunks path) + +{-# DEPRECATED writeWithBufferOf "Please use 'writeWith' instead" #-} +{-# INLINE writeWithBufferOf #-} +writeWithBufferOf :: (MonadIO m, MonadCatch m) + => Int -> FilePath -> Fold m Word8 () +writeWithBufferOf = writeWith + +-- > 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) => FilePath -> Fold m Word8 () +write = writeWith defaultChunkSize + +-- | Append a stream of arrays to a file. +-- +-- /Pre-release/ +-- +{-# INLINE appendChunks #-} +appendChunks :: (MonadIO m, MonadCatch m) + => FilePath -> Stream m (Array a) -> m () +appendChunks = 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 appendWith #-} +appendWith :: (MonadIO m, MonadCatch m) + => Int -> FilePath -> Stream m Word8 -> m () +appendWith n file xs = appendChunks file $ S.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 append #-} +append :: (MonadIO m, MonadCatch m) => FilePath -> Stream m Word8 -> m () +append = appendWith 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Handle.hs @@ -0,0 +1,713 @@ +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.FileSystem.Handle +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- The fundamental singleton IO APIs are 'getChunk' and 'putChunk' and the +-- fundamental stream IO APIs built on top of those are +-- 'readChunksWith' and 'writeChunks'. Rest of this module is just +-- combinatorial programming using these. +-- +-- We can achieve line buffering by folding lines in the input stream into a +-- stream of arrays using Stream.splitOn or Fold.takeEndBy_ and similar +-- operations. One can wrap the input stream in 'Maybe' type and then use +-- 'writeMaybesWith' to achieve user controlled buffering. + +-- TODO: Need a separate module for pread/pwrite based reading writing for +-- seekable devices. Stateless read/write can be helpful in multithreaded +-- applications. +-- +module Streamly.Internal.FileSystem.Handle + ( + -- * Singleton APIs + getChunk + , getChunkOf + , putChunk + + -- * Streams + , read + , readWith + , readChunksWith + , readChunks + + -- * Unfolds + , reader + -- , readUtf8 + -- , readLines + -- , readFrames + , readerWith + , chunkReader + , chunkReaderWith + + -- * Folds + , write + -- , writeUtf8 + -- , writeUtf8ByLines + -- , writeByFrames + -- , writeLines + , writeWith + , writeChunks + , writeChunksWith + , writeMaybesWith + + -- * Refolds + , writer + , writerWith + , chunkWriter + -- , chunkWriterWith + + -- * Stream writes + , putBytes + , putBytesWith + , putChunksWith + , putChunks + + -- * Random Access (Seek) + -- | Unlike the streaming APIs listed above, these APIs apply to devices or + -- files that have random access or seek capability. This type of devices + -- include disks, files, memory devices and exclude terminals, pipes, + -- sockets and fifos. + + -- We can also generate the request pattern using a funciton. + -- + -- , readIndex + -- , readFrom -- read from a given position to the end of file + -- , readFromRev -- read from a given position the beginning of file + -- , readTo -- read from beginning up to the given position + -- , readToRev -- read from end to the given position in file + -- , readFromTo + -- , readFromThenTo + + -- , readChunksFrom + -- , readChunksFromTo + , chunkReaderFromToWith + -- , readChunksFromThenToWith + + -- , writeIndex + -- , writeFrom -- start writing at the given position + -- , writeFromRev + -- , writeTo -- write from beginning up to the given position + -- , writeToRev + -- , writeFromTo + -- , writeFromThenTo + -- + -- , writeChunksFrom + -- , writeChunksFromTo + -- , writeChunksFromToWith + -- , writeChunksFromThenToWith + + -- * Deprecated + , readChunksWithBufferOf + , readWithBufferOf + , writeChunksWithBufferOf + , writeWithBufferOf + ) +where + +import Control.Exception (assert) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Function ((&)) +import Data.Maybe (isNothing, fromJust) +import Data.Word (Word8) +import Streamly.Internal.Data.Unboxed (Unbox) +import System.IO (Handle, SeekMode(..), hGetBufSome, hPutBuf, hSeek) +import Prelude hiding (read) + +import Streamly.Internal.Data.Fold (Fold) +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) +-- 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.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 + (Stream(..), Step(..)) +import qualified Streamly.Internal.Data.Unfold as UF +import qualified Streamly.Internal.Data.Stream.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) + +------------------------------------------------------------------------------- +-- 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. + +------------------------------------------------------------------------------- +-- Array IO (Input) +------------------------------------------------------------------------------- + +-- | 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 +-- without blocking. As a result of this behavior, it may read less than or +-- equal to the size requested. +-- +{-# 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 } + +-- 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 +-- later requires more copying. +-- +-- | Read a 'ByteArray' consisting of exactly the specified number of bytes +-- from a file handle. +-- +-- /Unimplemented/ +{-# INLINABLE getChunkOf #-} +getChunkOf :: Int -> Handle -> IO (Array Word8) +getChunkOf = undefined + +------------------------------------------------------------------------------- +-- Stream of Arrays IO +------------------------------------------------------------------------------- + +-- | @getChunksWith 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 _getChunksWith #-} +_getChunksWith :: MonadIO m => Int -> Handle -> Stream m (Array Word8) +_getChunksWith size h = S.fromStreamK go + where + -- XXX use cons/nil instead + go = K.mkStream $ \_ yld _ stp -> do + arr <- getChunk size h + if byteLength arr == 0 + then stp + else yld arr go + +-- | @readChunksWith 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@. +-- +-- >>> readChunksWith size h = Stream.unfold Handle.chunkReaderWith (size, h) +-- +{-# INLINE_NORMAL readChunksWith #-} +readChunksWith :: MonadIO m => Int -> Handle -> Stream m (Array Word8) +readChunksWith size h = D.Stream step () + where + {-# INLINE_LATE step #-} + step _ _ = do + arr <- getChunk size h + return $ + case byteLength 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@. +-- +{-# INLINE_NORMAL chunkReaderWith #-} +chunkReaderWith :: MonadIO m => Unfold m (Int, Handle) (Array Word8) +chunkReaderWith = + UF.lmap (uncurry getChunk) UF.repeatM + & UF.takeWhile ((/= 0) . byteLength) + +-- | Same as 'chunkReaderWith' +-- +{-# DEPRECATED readChunksWithBufferOf "Please use chunkReaderWith instead." #-} +{-# INLINE_NORMAL readChunksWithBufferOf #-} +readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Handle) (Array Word8) +readChunksWithBufferOf = chunkReaderWith + +-- There are two ways to implement this. +-- +-- 1. Idiomatic: use a scan on the output of readChunksWith to total +-- the array lengths and trim the last array to correct size. +-- 2. Simply implement it from scratch like readChunksWith. +-- +-- XXX Change this to readChunksWithFromTo (bufferSize, from, to, h)? + +-- | The input to the unfold is @(from, to, bufferSize, handle)@. It starts +-- reading from the offset `from` in the file and reads up to the offset `to`. +-- +{-# INLINE_NORMAL chunkReaderFromToWith #-} +chunkReaderFromToWith :: MonadIO m => + Unfold m (Int, Int, Int, Handle) (Array Word8) +chunkReaderFromToWith = Unfold step inject + + where + + inject (from, to, bufSize, h) = do + liftIO $ hSeek h AbsoluteSeek $ fromIntegral from + -- XXX Use a strict Tuple? + return (to - from + 1, bufSize, h) + + {-# INLINE_LATE step #-} + step (remaining, bufSize, h) = + if remaining <= 0 + then return D.Stop + else do + arr <- getChunk (min bufSize remaining) h + return $ + case byteLength arr of + 0 -> D.Stop + len -> + assert (len <= remaining) + $ D.Yield arr (remaining - len, bufSize, h) + +-- | @getChunks 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@. +-- +-- >>> readChunks = Handle.readChunksWith IO.defaultChunkSize +-- +-- /Pre-release/ +{-# INLINE readChunks #-} +readChunks :: MonadIO m => Handle -> Stream m (Array Word8) +readChunks = readChunksWith 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'. +-- +-- >>> chunkReader = Unfold.first IO.defaultChunkSize Handle.chunkReaderWith +-- +{-# INLINE chunkReader #-} +chunkReader :: MonadIO m => Unfold m Handle (Array Word8) +chunkReader = UF.first defaultChunkSize chunkReaderWith + +------------------------------------------------------------------------------- +-- 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. + +-- | 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 +-- +{-# INLINE readerWith #-} +readerWith :: MonadIO m => Unfold m (Int, Handle) Word8 +readerWith = UF.many A.reader chunkReaderWith + +-- | Same as 'readerWith' +-- +{-# DEPRECATED readWithBufferOf "Please use 'readerWith' instead." #-} +{-# INLINE readWithBufferOf #-} +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 +-- +-- /Pre-release/ +{-# INLINE readWith #-} +readWith :: MonadIO m => Int -> Handle -> Stream m Word8 +readWith size h = concatChunks $ 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 +-- +{-# INLINE reader #-} +reader :: MonadIO m => Unfold m Handle Word8 +reader = UF.many A.reader chunkReader + +-- | Generate a byte stream from a file 'Handle'. +-- +-- >>> read h = Stream.unfoldMany Array.reader $ Handle.readChunks h +-- +-- /Pre-release/ +{-# INLINE read #-} +read :: MonadIO m => Handle -> Stream m Word8 +read = concatChunks . readChunks + +------------------------------------------------------------------------------- +-- Writing +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Array IO (output) +------------------------------------------------------------------------------- + +-- | Write an 'Array' to a file handle. +-- +{-# INLINABLE putChunk #-} +putChunk :: 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 + +------------------------------------------------------------------------------- +-- Stream of Arrays IO +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Writing +------------------------------------------------------------------------------- + +-- XXX use an unfold to fromObjects or fromUnfold so that we can put any object +-- | Write a stream of arrays to a handle. +-- +-- >>> putChunks h = Stream.fold (Fold.drainBy (Handle.putChunk h)) +-- +{-# INLINE putChunks #-} +putChunks :: 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 +-- AS.concat is written in terms of foldMany. Once that is done we can write +-- idiomatic def in the docs. +-- +-- | @putChunksWith 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. +-- +{-# INLINE putChunksWith #-} +putChunksWith :: (MonadIO m, Unbox a) + => Int -> Handle -> Stream m (Array a) -> m () +putChunksWith n h xs = putChunks h $ AS.compact n xs + +-- | @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 + +-- | 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. +-- +-- >>> putBytes = Handle.putBytesWith IO.defaultChunkSize +-- +{-# INLINE putBytes #-} +putBytes :: MonadIO m => Handle -> Stream m Word8 -> m () +putBytes = putBytesWith defaultChunkSize + +-- | Write a stream of arrays to a handle. Each array in the stream is written +-- to the device as a separate IO request. +-- +-- writeChunks h = Fold.drainBy (Handle.putChunk h) +-- +{-# INLINE writeChunks #-} +writeChunks :: 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 = 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 +-- it emitted as it is. Multiple arrays are coalesed as long as the total size +-- remains below the specified size. +-- +{-# INLINE writeChunksWith #-} +writeChunksWith :: (MonadIO m, Unbox a) + => Int -> Handle -> Fold m (Array a) () +writeChunksWith n h = lpackArraysChunksOf n (writeChunks h) + +-- | Same as 'writeChunksWith' +-- +{-# DEPRECATED writeChunksWithBufferOf "Please use writeChunksWith instead." #-} +{-# INLINE writeChunksWithBufferOf #-} +writeChunksWithBufferOf :: (MonadIO m, Unbox a) + => Int -> Handle -> Fold m (Array a) () +writeChunksWithBufferOf = writeChunksWith + +-- 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. + +-- XXX Maybe we should have a Fold.chunksOf like we have Stream.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) +-- +{-# INLINE writeWith #-} +writeWith :: MonadIO m => Int -> Handle -> Fold m Word8 () +writeWith n h = FL.groupsOf n (writeNUnsafe n) (writeChunks h) + +-- | Same as 'writeWith' +-- +{-# DEPRECATED writeWithBufferOf "Please use writeWith instead." #-} +{-# INLINE writeWithBufferOf #-} +writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 () +writeWithBufferOf = writeWith + +-- | Write a stream of 'Maybe' values. Keep buffering the just values in an +-- array until a 'Nothing' is encountered or the buffer size exceeds the +-- specified limit, at that point flush the buffer to the handle. +-- +-- /Pre-release/ +{-# INLINE writeMaybesWith #-} +writeMaybesWith :: (MonadIO m ) + => Int -> Handle -> Fold m (Maybe Word8) () +writeMaybesWith n h = + let writeNJusts = FL.lmap fromJust $ A.writeN n + writeOnNothing = FL.takeEndBy_ isNothing writeNJusts + in FL.many writeOnNothing (writeChunks h) + +-- | Like 'writeWith' but uses the experimental 'Refold' API. +-- +-- /Internal/ +{-# INLINE writerWith #-} +writerWith :: MonadIO m => Int -> Refold m Handle Word8 () +writerWith n = + FL.refoldMany (FL.take n $ writeNUnsafe 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 +-- to the IO device. +-- +-- >>> write = Handle.writeWith IO.defaultChunkSize +-- +{-# INLINE write #-} +write :: MonadIO m => Handle -> Fold m Word8 () +write = writeWith defaultChunkSize + +-- | Like 'write' but uses the experimental 'Refold' API. +-- +-- /Internal/ +{-# INLINE writer #-} +writer :: MonadIO m => Refold m Handle Word8 () +writer = writerWith defaultChunkSize + +-- XXX mmap a file into an array. This could be useful for in-place operations +-- on a file. For example, we can quicksort the contents of a file by mmapping +-- it. + +------------------------------------------------------------------------------- +-- IO with encoding/decoding Unicode characters +------------------------------------------------------------------------------- + +{- +-- | +-- > readUtf8 = decodeUtf8 . read +-- +-- Read a UTF8 encoded stream of unicode characters from a file handle. +-- +{-# 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. +-- +{-# 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. +-- +{-# 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. +-- +{-# 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. +-- +{-# INLINE readFrames #-} +readFrames :: (MonadIO m, Unboxed 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@. +-- +{-# INLINE writeByFrames #-} +writeByFrames :: (MonadIO m, Unboxed a) + => Array a -> Handle -> Stream m a -> m () +writeByFrames = undefined + +------------------------------------------------------------------------------- +-- Framing by time +------------------------------------------------------------------------------- + +-- | Write collecting the input in sessions of n seconds or if chunkSize +-- gets exceeded. +{-# INLINE writeByChunksOrSessionsOf #-} +writeByChunksOrSessionsOf :: MonadIO m + => Int -> Double -> Handle -> Stream m Word8 -> m () +writeByChunksOrSessionsOf chunkSize sessionSize h m = undefined + +-- | Write collecting the input in sessions of n seconds or if defaultChunkSize +-- gets exceeded. +{-# INLINE writeBySessionsOf #-} +writeBySessionsOf :: MonadIO m => Double -> Handle -> Stream m Word8 -> m () +writeBySessionsOf n = writeByChunksOrSessionsOf defaultChunkSize n + +------------------------------------------------------------------------------- +-- 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. +-- +{-# INLINE readIndex #-} +readIndex :: Unboxed 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, Unboxed 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@. +-- +{-# INLINE readSlice #-} +readSlice :: (MonadIO m, Unboxed a) + => Handle -> Int -> Int -> Stream m a +readSlice = readSliceWith A.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@. +-- +{-# INLINE readSliceRev #-} +readSliceRev :: (MonadIO m, Unboxed a) + => Handle -> Int -> Int -> Stream m a +readSliceRev h i count = undefined + +-- | Write the given element at the given index in the file. +-- +{-# INLINE writeIndex #-} +writeIndex :: (MonadIO m, Unboxed 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@. +-- +{-# INLINE writeSlice #-} +writeSlice :: (Monad m, Unboxed 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@. +-- +{-# INLINE writeSliceRev #-} +writeSliceRev :: (Monad m, Unboxed a) + => Handle -> Int -> Int -> Stream m a -> m () +writeSliceRev arr i len s = undefined +-} diff --git a/src/Streamly/Internal/Serialize/FromBytes.hs b/src/Streamly/Internal/Serialize/FromBytes.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Serialize/FromBytes.hs @@ -0,0 +1,394 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Serialize/ToBytes.hs @@ -0,0 +1,374 @@ +-- | +-- 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/System/IO.hs b/src/Streamly/Internal/System/IO.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/System/IO.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- | +-- Module : Streamly.Internal.System.IO +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Streamly.Internal.System.IO + ( defaultChunkSize + , arrayPayloadSize + , unsafeInlineIO + , byteArrayOverhead + ) + +where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +#include "MachDeps.h" + +import GHC.Base (realWorld#) +import GHC.IO (IO(IO)) + +------------------------------------------------------------------------------- +-- API +------------------------------------------------------------------------------- + +{-# INLINE unsafeInlineIO #-} +unsafeInlineIO :: IO a -> a +unsafeInlineIO (IO m) = case m realWorld# of (# _, r #) -> r + +-- | Returns the heap allocation overhead for allocating a byte array. Each +-- heap object contains a one word header. Byte arrays contain the size of the +-- array after the header. +-- +-- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/rts/storage/heap-objects#arrays +-- +byteArrayOverhead :: Int +byteArrayOverhead = 2 * SIZEOF_HSWORD + +-- | When we allocate a byte array of size @k@ the allocator actually allocates +-- memory of size @k + byteArrayOverhead@. @arrayPayloadSize n@ returns the +-- size of the array in bytes that would result in an allocation of @n@ bytes. +-- +arrayPayloadSize :: Int -> Int +arrayPayloadSize n = let size = n - byteArrayOverhead in max size 0 + +-- | Default maximum buffer size in bytes, for reading from and writing to IO +-- devices, the value is 32KB minus GHC allocation overhead, which is a few +-- bytes, so that the actual allocation is 32KB. +defaultChunkSize :: Int +defaultChunkSize = arrayPayloadSize (32 * 1024) diff --git a/src/Streamly/Internal/Unicode/Array.hs b/src/Streamly/Internal/Unicode/Array.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Unicode/Array.hs @@ -0,0 +1,98 @@ +-- | +-- Module : Streamly.Internal.Unicode.Array +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +-- XXX Remove this or move this to Unicode.Utf32 making "Array Char" as a +-- newtype wrapper for Utf32. Is this any better than the [Char] (String) type? +-- This provides random access and the length of the string in O(1). Also, +-- better append performance. +-- +module Streamly.Internal.Unicode.Array + ( + -- * Streams of Strings + lines + , words + , unlines + , unwords + ) +where + +import Control.Monad.IO.Class (MonadIO) +import Streamly.Data.Stream (Stream) +import Streamly.Internal.Data.Array (Array) + +import qualified Streamly.Data.Array as A +import qualified Streamly.Internal.Unicode.Stream as S + +import Prelude hiding (String, lines, words, unlines, unwords) + +-- $setup +-- >>> :m +-- >>> :set -XOverloadedStrings +-- >>> import Prelude hiding (String, lines, words, unlines, unwords) +-- >>> import qualified Streamly.Data.Stream as Stream +-- >>> import qualified Streamly.Data.Fold as Fold +-- >>> import qualified Streamly.Internal.Unicode.Array as Unicode + +-- | Break a string up into a stream of strings at newline characters. +-- The resulting strings do not contain newlines. +-- +-- > lines = S.lines A.write +-- +-- >>> Stream.fold Fold.toList $ Unicode.lines $ Stream.fromList "lines\nthis\nstring\n\n\n" +-- [fromList "lines",fromList "this",fromList "string",fromList "",fromList ""] +-- +{-# INLINE lines #-} +lines :: MonadIO m => Stream m Char -> Stream m (Array Char) +lines = S.lines A.write + +-- | Break a string up into a stream of strings, which were delimited +-- by characters representing white space. +-- +-- > words = S.words A.write +-- +-- >>> Stream.fold Fold.toList $ Unicode.words $ Stream.fromList "A newline\nis considered white space?" +-- [fromList "A",fromList "newline",fromList "is",fromList "considered",fromList "white",fromList "space?"] +-- +{-# INLINE words #-} +words :: MonadIO m => Stream m Char -> Stream m (Array Char) +words = S.words A.write + +-- | Flattens the stream of @Array Char@, after appending a terminating +-- newline to each string. +-- +-- 'unlines' is an inverse operation to 'lines'. +-- +-- >>> Stream.fold Fold.toList $ Unicode.unlines $ Stream.fromList ["lines", "this", "string"] +-- "lines\nthis\nstring\n" +-- +-- > unlines = S.unlines A.read +-- +-- Note that, in general +-- +-- > unlines . lines /= id +{-# INLINE unlines #-} +unlines :: MonadIO m => Stream m (Array Char) -> Stream m Char +unlines = S.unlines A.reader + +-- | Flattens the stream of @Array Char@, after appending a separating +-- space to each string. +-- +-- 'unwords' is an inverse operation to 'words'. +-- +-- >>> Stream.fold Fold.toList $ Unicode.unwords $ Stream.fromList ["unwords", "this", "string"] +-- "unwords this string" +-- +-- > unwords = S.unwords A.read +-- +-- Note that, in general +-- +-- > unwords . words /= id +{-# INLINE unwords #-} +unwords :: MonadIO m => Stream m (Array Char) -> Stream m Char +unwords = S.unwords A.reader diff --git a/src/Streamly/Internal/Unicode/Parser.hs b/src/Streamly/Internal/Unicode/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Unicode/Parser.hs @@ -0,0 +1,298 @@ +-- | +-- Module : Streamly.Internal.Unicode.Parser +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- To parse a text input, use the decode routines from +-- "Streamly.Unicode.Stream" module to convert an input byte stream to a +-- Unicode Char stream and then use these parsers on the Char stream. + +module Streamly.Internal.Unicode.Parser + ( + -- * Generic + char + , charIgnoreCase + + -- * Sequences + , string + , stringIgnoreCase + , dropSpace + , dropSpace1 + + -- * Classes + , alpha + , alphaNum + , letter + , ascii + , asciiLower + , asciiUpper + , latin1 + , lower + , upper + , mark + , printable + , punctuation + , separator + , space + , symbol + + -- digits + , digit + , octDigit + , hexDigit + , numeric + + -- * Numeric + , signed + , double + , decimal + , hexadecimal + ) +where + +import Control.Applicative (Alternative(..)) +import Data.Bits (Bits, (.|.), shiftL) +import Data.Char (ord) +import Streamly.Internal.Data.Parser (Parser) + +import qualified Data.Char as Char +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Internal.Data.Parser as Parser + ( + lmap + , satisfy + , listEq + , takeWhile1 + , dropWhile + ) + +-------------------------------------------------------------------------------- +-- Character classification +-------------------------------------------------------------------------------- + +-- XXX It may be possible to implement faster predicates for ASCII byte stream. +-- We can measure if there is a signficant difference and if so we can add such +-- predicates to Streamly.Unicode.Parser.Latin1. +-- +#define CHAR_PARSER_SIG(NAME) NAME :: Monad m => Parser Char m Char +-- XXX Need to use the predicates from Unicode.Char module/unicode-data package +#define CHAR_PARSER(NAME, PREDICATE) NAME = Parser.satisfy Char.PREDICATE +#define CHAR_PARSER_DOC(PREDICATE) -- | Match any character that satisfies 'Char.PREDICATE' +#define CHAR_PARSER_INLINE(NAME) {-# INLINE NAME #-} + +CHAR_PARSER_DOC(isSpace) +CHAR_PARSER_INLINE(space) +CHAR_PARSER_SIG(space) +CHAR_PARSER(space,isSpace) + +CHAR_PARSER_DOC(isLower) +CHAR_PARSER_INLINE(lower) +CHAR_PARSER_SIG(lower) +CHAR_PARSER(lower,isLower) + +CHAR_PARSER_DOC(isUpper) +CHAR_PARSER_INLINE(upper) +CHAR_PARSER_SIG(upper) +CHAR_PARSER(upper,isUpper) + +CHAR_PARSER_DOC(isAlpha) +CHAR_PARSER_INLINE(alpha) +CHAR_PARSER_SIG(alpha) +CHAR_PARSER(alpha,isAlpha) + +CHAR_PARSER_DOC(isAlphaNum) +CHAR_PARSER_INLINE(alphaNum) +CHAR_PARSER_SIG(alphaNum) +CHAR_PARSER(alphaNum,isAlphaNum) + +CHAR_PARSER_DOC(isPrint) +CHAR_PARSER_INLINE(printable) +CHAR_PARSER_SIG(printable) +CHAR_PARSER(printable,isPrint) + +CHAR_PARSER_DOC(isDigit) +CHAR_PARSER_INLINE(digit) +CHAR_PARSER_SIG(digit) +CHAR_PARSER(digit,isDigit) + +CHAR_PARSER_DOC(isOctDigit) +CHAR_PARSER_INLINE(octDigit) +CHAR_PARSER_SIG(octDigit) +CHAR_PARSER(octDigit,isOctDigit) + +CHAR_PARSER_DOC(isHexDigit) +CHAR_PARSER_INLINE(hexDigit) +CHAR_PARSER_SIG(hexDigit) +CHAR_PARSER(hexDigit,isHexDigit) + +CHAR_PARSER_DOC(isLetter) +CHAR_PARSER_INLINE(letter) +CHAR_PARSER_SIG(letter) +CHAR_PARSER(letter,isLetter) + +CHAR_PARSER_DOC(isMark) +CHAR_PARSER_INLINE(mark) +CHAR_PARSER_SIG(mark) +CHAR_PARSER(mark,isMark) + +CHAR_PARSER_DOC(isNumber) +CHAR_PARSER_INLINE(numeric) +CHAR_PARSER_SIG(numeric) +CHAR_PARSER(numeric,isNumber) + +CHAR_PARSER_DOC(isPunctuation) +CHAR_PARSER_INLINE(punctuation) +CHAR_PARSER_SIG(punctuation) +CHAR_PARSER(punctuation,isPunctuation) + +CHAR_PARSER_DOC(isSymbol) +CHAR_PARSER_INLINE(symbol) +CHAR_PARSER_SIG(symbol) +CHAR_PARSER(symbol,isSymbol) + +CHAR_PARSER_DOC(isSeparator) +CHAR_PARSER_INLINE(separator) +CHAR_PARSER_SIG(separator) +CHAR_PARSER(separator,isSeparator) + +CHAR_PARSER_DOC(isAscii) +CHAR_PARSER_INLINE(ascii) +CHAR_PARSER_SIG(ascii) +CHAR_PARSER(ascii,isAscii) + +CHAR_PARSER_DOC(isLatin1) +CHAR_PARSER_INLINE(latin1) +CHAR_PARSER_SIG(latin1) +CHAR_PARSER(latin1,isLatin1) + +CHAR_PARSER_DOC(isAsciiUpper) +CHAR_PARSER_INLINE(asciiUpper) +CHAR_PARSER_SIG(asciiUpper) +CHAR_PARSER(asciiUpper,isAsciiUpper) + +CHAR_PARSER_DOC(isAsciiLower) +CHAR_PARSER_INLINE(asciiLower) +CHAR_PARSER_SIG(asciiLower) +CHAR_PARSER(asciiLower,isAsciiLower) + +-------------------------------------------------------------------------------- +-- Character parsers +-------------------------------------------------------------------------------- + +-- | Match a specific character. +{-# INLINE char #-} +char :: Monad m => Char -> Parser Char m Char +char c = Parser.satisfy (== c) + +-- XXX Case conversion may lead to change in number of chars +-- | Match a specific character ignoring case. +{-# INLINE charIgnoreCase #-} +charIgnoreCase :: Monad m => Char -> Parser Char m Char +charIgnoreCase c = Parser.lmap Char.toLower (Parser.satisfy (== Char.toLower c)) + +-------------------------------------------------------------------------------- +-- Character sequences +-------------------------------------------------------------------------------- + +-- | Match the input with the supplied string and return it if successful. +string :: Monad m => String -> Parser Char m String +string = Parser.listEq + +-- XXX Not accurate unicode case conversion +-- | Match the input with the supplied string and return it if successful. +stringIgnoreCase :: Monad m => String -> Parser Char m String +stringIgnoreCase s = + Parser.lmap Char.toLower (Parser.listEq (map Char.toLower s)) + +-- | Drop /zero/ or more white space characters. +dropSpace :: Monad m => Parser Char m () +dropSpace = Parser.dropWhile Char.isSpace + +-- | Drop /one/ or more white space characters. +dropSpace1 :: Monad m => Parser Char m () +dropSpace1 = Parser.takeWhile1 Char.isSpace Fold.drain + +-------------------------------------------------------------------------------- +-- Numeric parsers +-------------------------------------------------------------------------------- + +-- XXX It should fail if the number is larger than the size of the type. +-- +-- | Parse and decode an unsigned integral decimal number. +{-# INLINE decimal #-} +decimal :: (Monad m, Integral a) => Parser Char m a +decimal = Parser.takeWhile1 Char.isDigit (Fold.foldl' step 0) + + where + + step a c = a * 10 + fromIntegral (ord c - 48) + +-- | Parse and decode an unsigned integral hexadecimal number. The hex digits +-- @\'a\'@ through @\'f\'@ may be upper or lower case. +-- +-- Note: This parser does not accept a leading @\"0x\"@ string. +{-# INLINE hexadecimal #-} +hexadecimal :: (Monad m, Integral a, Bits a) => Parser Char m a +hexadecimal = Parser.takeWhile1 isHexDigit (Fold.foldl' step 0) + + where + + isHexDigit c = + (c >= '0' && c <= '9') + || (c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') + + step a c + | w >= 48 && w <= 57 = + (a `shiftL` 4) .|. fromIntegral (w - 48) + | w >= 97 = + (a `shiftL` 4) .|. fromIntegral (w - 87) + | otherwise = + (a `shiftL` 4) .|. fromIntegral (w - 55) + + where + + w = ord c + +-- | Allow an optional leading @\'+\'@ or @\'-\'@ sign character before any +-- parser. +{-# INLINE signed #-} +signed :: (Num a, Monad m) => Parser Char m a -> Parser Char m a +signed p = (negate <$> (char '-' *> p)) <|> (char '+' *> p) <|> p + +-- | Parse a 'Double'. +-- +-- 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. +-- +-- === Examples +-- +-- Examples with behaviour identical to 'read', if you feed an empty +-- continuation to the first result: +-- +-- > 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 +-- +-- Examples with behaviour identical to 'read': +-- +-- > IS.parse (IS.fromList ".3") == error "Parse failed" +-- > IS.parse (IS.fromList "e3") == error "Parse failed" +-- +-- Example of difference from 'read': +-- +-- > IS.parse double (IS.fromList "3.foo") == 3.0 +-- +-- This function does not accept string representations of \"NaN\" or +-- \"Infinity\". +-- +-- /Unimplemented/ +double :: Parser Char m Double +double = undefined diff --git a/src/Streamly/Internal/Unicode/Stream.hs b/src/Streamly/Internal/Unicode/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Unicode/Stream.hs @@ -0,0 +1,1095 @@ +-- | +-- Module : Streamly.Internal.Unicode.Stream +-- Copyright : (c) 2018 Composewell Technologies +-- (c) Bjoern Hoehrmann 2008-2009 +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Streamly.Internal.Unicode.Stream + ( + -- * Construction (Decoding) + decodeLatin1 + + -- ** UTF-8 Decoding + , CodingFailureMode(..) + , writeCharUtf8' + , parseCharUtf8With + , decodeUtf8 + , decodeUtf8' + , decodeUtf8_ + + -- ** Resumable UTF-8 Decoding + , DecodeError(..) + , DecodeState + , CodePoint + , decodeUtf8Either + , resumeDecodeUtf8Either + + -- ** UTF-8 Array Stream Decoding + , decodeUtf8Chunks + , decodeUtf8Chunks' + , decodeUtf8Chunks_ + + -- * Elimination (Encoding) + -- ** Latin1 Encoding + , encodeLatin1 + , encodeLatin1' + , encodeLatin1_ + + -- ** UTF-8 Encoding + , readCharUtf8' + , readCharUtf8 + , readCharUtf8_ + , encodeUtf8 + , encodeUtf8' + , encodeUtf8_ + , encodeStrings + {- + -- * Operations on character strings + , strip -- (dropAround isSpace) + , stripEnd + -} + + -- * Transformation + , stripHead + , lines + , words + , unlines + , unwords + + -- * StreamD UTF8 Encoding / Decoding transformations. + , decodeUtf8D + , decodeUtf8D' + , decodeUtf8D_ + , encodeUtf8D + , encodeUtf8D' + , encodeUtf8D_ + , decodeUtf8EitherD + , resumeDecodeUtf8EitherD + + -- * Decoding String Literals + , fromStr# + + -- * Deprecations + , decodeUtf8Lax + , encodeLatin1Lax + , encodeUtf8Lax + ) +where + +#include "inline.hs" + +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Bits (shiftR, shiftL, (.|.), (.&.)) +import Data.Char (chr, ord) +#if MIN_VERSION_base(4,17,0) +import Data.Char (generalCategory, GeneralCategory(Space)) +#endif +import Data.Word (Word8) +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Storable (Storable(..)) +#ifndef __GHCJS__ +import Fusion.Plugin.Types (Fuse(..)) +#endif +import GHC.Base (assert, unsafeChr) +import GHC.Exts (Addr#) +import GHC.IO.Encoding.Failure (isSurrogate) +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.Fold (Fold) +import Streamly.Internal.Data.Stream.StreamD (Stream) +import Streamly.Internal.Data.Stream.StreamD (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.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.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 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 + +------------------------------------------------------------------------------- +-- Latin1 decoding +------------------------------------------------------------------------------- + +-- | Decode a stream of bytes to Unicode characters by mapping each byte to a +-- corresponding Unicode 'Char' in 0-255 range. +-- +{-# INLINE decodeLatin1 #-} +decodeLatin1 :: Monad m => Stream m Word8 -> Stream m Char +decodeLatin1 = fmap (unsafeChr . fromIntegral) + +------------------------------------------------------------------------------- +-- Latin1 encoding +------------------------------------------------------------------------------- + +-- | Encode a stream of Unicode characters to bytes by mapping each character +-- to a byte in 0-255 range. Throws an error if the input stream contains +-- characters beyond 255. +-- +{-# INLINE encodeLatin1' #-} +encodeLatin1' :: Monad m => Stream m Char -> Stream m Word8 +encodeLatin1' = fmap convert + where + convert c = + let codepoint = ord c + in if codepoint > 255 + then error $ "Streamly.Unicode.encodeLatin1 invalid " ++ + "input char codepoint " ++ show codepoint + else fromIntegral codepoint + +-- XXX Should we instead replace the invalid chars by NUL or whitespace or some +-- other control char? That may affect the perf a bit but may be a better +-- behavior. +-- +-- | Like 'encodeLatin1'' but silently maps input codepoints beyond 255 to +-- arbitrary Latin1 chars in 0-255 range. No error or exception is thrown when +-- such mapping occurs. +-- +{-# INLINE encodeLatin1 #-} +encodeLatin1 :: Monad m => Stream m Char -> Stream m Word8 +encodeLatin1 = fmap (fromIntegral . ord) + +-- | Like 'encodeLatin1' but drops the input characters beyond 255. +-- +{-# INLINE encodeLatin1_ #-} +encodeLatin1_ :: Monad m => Stream m Char -> Stream m Word8 +encodeLatin1_ = fmap (fromIntegral . ord) . Stream.filter (<= chr 255) + +-- | Same as 'encodeLatin1' +-- +{-# DEPRECATED encodeLatin1Lax "Please use 'encodeLatin1' instead" #-} +{-# INLINE encodeLatin1Lax #-} +encodeLatin1Lax :: Monad m => Stream m Char -> Stream m Word8 +encodeLatin1Lax = encodeLatin1 + +------------------------------------------------------------------------------- +-- UTF-8 decoding +------------------------------------------------------------------------------- + +-- Int helps in cheaper conversion from Int to Char +type CodePoint = Int +type DecodeState = Word8 + +-- We can divide the errors in three general categories: +-- * A non-starter was encountered in a begin state +-- * A starter was encountered without completing a codepoint +-- * The last codepoint was not complete (input underflow) +-- +-- Need to separate resumable and non-resumable error. In case of non-resumable +-- error we can also provide the failing byte. In case of resumable error the +-- state can be opaque. +-- +data DecodeError = DecodeError !DecodeState !CodePoint deriving Show + +-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details. + +-- XXX Use names decodeSuccess = 0, decodeFailure = 12 + +decodeTable :: [Word8] +decodeTable = [ + -- The first part of the table maps bytes to character classes that + -- to reduce the size of the transition table and create bitmasks. + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, + 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, + 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, + + -- The second part is a transition table that maps a combination + -- of a state of the automaton and a character class to a state. + 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12, + 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12, + 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12, + 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12, + 12,36,12,12,12,12,12,12,12,12,12,12 + ] + +{-# INLINE utf8dLength #-} +utf8dLength :: Int +utf8dLength = length decodeTable + +-- | We do not want to garbage collect this and free the memory, we want to +-- keep this persistent. We don't know how to do that with GHC without having a +-- reference in some global structure. So we use a hack, use mallocBytes so +-- that the GC has no way to free it. +{-# NOINLINE utf8d #-} +utf8d :: Ptr Word8 +utf8d = unsafePerformIO $ do + let size = utf8dLength + p <- liftIO $ mallocBytes size + void $ D.fold + (Fold.foldlM' (\b a -> poke b a >> return (b `plusPtr` 1)) (return p)) + (D.fromList decodeTable) + return p + +-- | Return element at the specified index without checking the bounds. +-- and without touching the foreign ptr. +{-# INLINE_NORMAL unsafePeekElemOff #-} +unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a +unsafePeekElemOff p i = + let !x = unsafeInlineIO $ peekElemOff p i + in x + +-- XXX We can use a fromPtr stream to implement it. +{-# INLINE showMemory #-} +showMemory :: + forall a. (Show a, Storable a) => Ptr a -> Ptr a -> String +showMemory cur end + | cur < end = + let cur1 = cur `plusPtr` sizeOf (undefined :: a) + in show (unsafeInlineIO $ peek cur) ++ " " ++ showMemory cur1 end +showMemory _ _ = "" + +-- decode is split into two separate cases to avoid branching instructions. +-- From the higher level flow we already know which case we are in so we can +-- call the appropriate decode function. +-- +-- When the state is 0 +{-# INLINE decode0 #-} +decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint +decode0 table byte = + let !t = table `unsafePeekElemOff` fromIntegral byte + !codep' = (0xff `shiftR` fromIntegral t) .&. fromIntegral byte + !state' = table `unsafePeekElemOff` (256 + fromIntegral t) + in assert ((byte > 0x7f || error showByte) + && (state' /= 0 || error (showByte ++ showTable))) + (Tuple' state' codep') + + where + + utf8tableEnd = table `plusPtr` 364 + showByte = "Streamly: decode0: byte: " ++ show byte + showTable = " table: " ++ showMemory table utf8tableEnd + +-- When the state is not 0 +{-# INLINE decode1 #-} +decode1 + :: Ptr Word8 + -> DecodeState + -> CodePoint + -> Word8 + -> Tuple' DecodeState CodePoint +decode1 table state codep byte = + -- Remember codep is Int type! + -- Can it be unsafe to convert the resulting Int to Char? + let !t = table `unsafePeekElemOff` fromIntegral byte + !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6) + !state' = table `unsafePeekElemOff` + (256 + fromIntegral state + fromIntegral t) + in assert (codep' <= 0x10FFFF + || error (showByte ++ showState state codep)) + (Tuple' state' codep') + where + + utf8tableEnd = table `plusPtr` 364 + showByte = "Streamly: decode1: byte: " ++ show byte + showState st cp = + " state: " ++ show st ++ + " codepoint: " ++ show cp ++ + " table: " ++ showMemory table utf8tableEnd + +------------------------------------------------------------------------------- +-- Resumable UTF-8 decoding +------------------------------------------------------------------------------- + +-- Strangely, GHCJS hangs linking template-haskell with this +#ifndef __GHCJS__ +{-# ANN type UTF8DecodeState Fuse #-} +#endif +data UTF8DecodeState s a + = UTF8DecodeInit s + | UTF8DecodeInit1 s Word8 + | UTF8DecodeFirst s Word8 + | UTF8Decoding s !DecodeState !CodePoint + | YieldAndContinue a (UTF8DecodeState s a) + | Done + +{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-} +resumeDecodeUtf8EitherD + :: Monad m + => DecodeState + -> CodePoint + -> D.Stream m Word8 + -> D.Stream m (Either DecodeError Char) +resumeDecodeUtf8EitherD dst codep (D.Stream step state) = + let stt = + if dst == 0 + then UTF8DecodeInit state + else UTF8Decoding state dst codep + in D.Stream (step' utf8d) stt + where + {-# INLINE_LATE step' #-} + step' _ gst (UTF8DecodeInit st) = do + r <- step (adaptState gst) st + return $ case r of + Yield x s -> Skip (UTF8DecodeInit1 s x) + Skip s -> Skip (UTF8DecodeInit s) + Stop -> Skip Done + + step' _ _ (UTF8DecodeInit1 st x) = do + -- 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 versions, we need a more reliable + -- "likely" primitive to control branch predication. + case x > 0x7f of + False -> + return $ Skip $ YieldAndContinue + (Right $ unsafeChr (fromIntegral x)) + (UTF8DecodeInit st) + -- Using a separate state here generates a jump to a + -- separate code block in the core which seems to perform + -- slightly better for the non-ascii case. + True -> return $ Skip $ UTF8DecodeFirst st x + + -- XXX should we merge it with UTF8DecodeInit1? + step' table _ (UTF8DecodeFirst st x) = do + let (Tuple' sv cp) = decode0 table x + return $ + case sv of + 12 -> + Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x)) + (UTF8DecodeInit st) + 0 -> error "unreachable state" + _ -> Skip (UTF8Decoding st sv cp) + + -- We recover by trying the new byte x a starter of a new codepoint. + -- XXX on error need to report the next byte "x" as well. + -- XXX need to use the same recovery in array decoding routine as well + step' table gst (UTF8Decoding st statePtr codepointPtr) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + let (Tuple' sv cp) = decode1 table statePtr codepointPtr x + return $ + case sv of + 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp) + (UTF8DecodeInit s) + 12 -> + Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) + (UTF8DecodeInit1 s x) + _ -> Skip (UTF8Decoding s sv cp) + Skip s -> return $ Skip (UTF8Decoding s statePtr codepointPtr) + Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done + + step' _ _ (YieldAndContinue c s) = return $ Yield c s + step' _ _ Done = return Stop + +-- XXX We can use just one API, and define InitState = 0 and InitCodePoint = 0 +-- to use as starting state. +-- +{-# INLINE_NORMAL decodeUtf8EitherD #-} +decodeUtf8EitherD :: Monad m + => D.Stream m Word8 -> D.Stream m (Either DecodeError Char) +decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0 + +-- | +-- +-- /Pre-release/ +{-# INLINE decodeUtf8Either #-} +decodeUtf8Either :: Monad m + => Stream m Word8 -> Stream m (Either DecodeError Char) +decodeUtf8Either = decodeUtf8EitherD + +-- | +-- +-- /Pre-release/ +{-# INLINE resumeDecodeUtf8Either #-} +resumeDecodeUtf8Either + :: Monad m + => DecodeState + -> CodePoint + -> Stream m Word8 + -> Stream m (Either DecodeError Char) +resumeDecodeUtf8Either = resumeDecodeUtf8EitherD + +------------------------------------------------------------------------------- +-- One shot decoding +------------------------------------------------------------------------------- + +data CodingFailureMode + = TransliterateCodingFailure + | ErrorOnCodingFailure + | DropOnCodingFailure + deriving (Show) + +{-# INLINE replacementChar #-} +replacementChar :: Char +replacementChar = '\xFFFD' + +data UTF8CharDecodeState a + = UTF8CharDecodeInit + | UTF8CharDecoding !DecodeState !CodePoint + +{-# INLINE parseCharUtf8WithD #-} +parseCharUtf8WithD :: + Monad m => CodingFailureMode -> ParserD.Parser Word8 m Char +parseCharUtf8WithD cfm = ParserD.Parser (step' utf8d) initial extract + + where + + prefix = "Streamly.Internal.Data.Stream.parseCharUtf8WithD:" + + {-# INLINE initial #-} + initial = return $ ParserD.IPartial UTF8CharDecodeInit + + handleError err souldBackTrack = + case cfm of + ErrorOnCodingFailure -> ParserD.Error err + TransliterateCodingFailure -> + case souldBackTrack of + True -> ParserD.Done 1 replacementChar + False -> ParserD.Done 0 replacementChar + DropOnCodingFailure -> + case souldBackTrack of + True -> ParserD.Continue 1 UTF8CharDecodeInit + False -> ParserD.Continue 0 UTF8CharDecodeInit + + {-# INLINE step' #-} + step' table UTF8CharDecodeInit x = + -- 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 versions, we need a more reliable + -- "likely" primitive to control branch predication. + return $ case x > 0x7f of + False -> ParserD.Done 0 $ unsafeChr $ fromIntegral x + True -> + let (Tuple' sv cp) = decode0 table x + in case sv of + 12 -> + let msg = prefix + ++ "Invalid first UTF8 byte" ++ show x + in handleError msg False + 0 -> error $ prefix ++ "unreachable state" + _ -> ParserD.Continue 0 (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 + 12 -> + let msg = prefix + ++ "Invalid subsequent UTF8 byte" + ++ show x + ++ "in state" + ++ show statePtr + ++ "accumulated value" + ++ show codepointPtr + in handleError msg True + _ -> ParserD.Continue 0 (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" + TransliterateCodingFailure -> + return (ParserD.Done 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" + +-- XXX This should ideally accept a "CodingFailureMode" and perform appropriate +-- error handling. This isn't possible now as "TransliterateCodingFailure"'s +-- 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) + +-- XXX The initial idea was to have "parseCharUtf8" and offload the error +-- handling to another parser. So, say we had "parseCharUtf8'", +-- +-- >>> parseCharUtf8Smart = parseCharUtf8' <|> Parser.fromPure replacementChar +-- +-- But unfortunately parseCharUtf8Smart used in conjunction with "parseMany" - +-- that is "parseMany parseCharUtf8Smart" on a stream causes the heap to +-- overflow. Even a heap size of 500 MB was not sufficient. +-- +-- This needs to be investigated futher. +{-# INLINE parseCharUtf8With #-} +parseCharUtf8With :: + Monad m => CodingFailureMode -> Parser.Parser Word8 m Char +parseCharUtf8With = parseCharUtf8WithD + +-- XXX write it as a parser and use parseMany to decode a stream, need to check +-- if that preserves the same performance. Or we can use a resumable parser +-- that parses a chunk at a time. +-- +-- XXX Implement this in terms of decodeUtf8Either. Need to make sure that +-- decodeUtf8Either preserves the performance characterstics. +-- +{-# INLINE_NORMAL decodeUtf8WithD #-} +decodeUtf8WithD :: Monad m + => CodingFailureMode -> D.Stream m Word8 -> D.Stream m Char +decodeUtf8WithD cfm (D.Stream step state) = + D.Stream (step' utf8d) (UTF8DecodeInit state) + + where + + prefix = "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: " + + {-# INLINE handleError #-} + handleError e s = + case cfm of + ErrorOnCodingFailure -> error e + TransliterateCodingFailure -> YieldAndContinue replacementChar s + DropOnCodingFailure -> s + + {-# INLINE handleUnderflow #-} + handleUnderflow = + case cfm of + ErrorOnCodingFailure -> error $ prefix ++ "Not enough input" + TransliterateCodingFailure -> YieldAndContinue replacementChar Done + DropOnCodingFailure -> Done + + {-# INLINE_LATE step' #-} + step' _ gst (UTF8DecodeInit st) = do + r <- step (adaptState gst) st + return $ case r of + Yield x s -> Skip (UTF8DecodeInit1 s x) + Skip s -> Skip (UTF8DecodeInit s) + Stop -> Skip Done + + step' _ _ (UTF8DecodeInit1 st x) = do + -- 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 versions, we need a more reliable + -- "likely" primitive to control branch predication. + case x > 0x7f of + False -> + return $ Skip $ YieldAndContinue + (unsafeChr (fromIntegral x)) + (UTF8DecodeInit st) + -- Using a separate state here generates a jump to a + -- separate code block in the core which seems to perform + -- slightly better for the non-ascii case. + True -> return $ Skip $ UTF8DecodeFirst st x + + -- XXX should we merge it with UTF8DecodeInit1? + step' table _ (UTF8DecodeFirst st x) = do + let (Tuple' sv cp) = decode0 table x + return $ + case sv of + 12 -> + let msg = prefix ++ "Invalid first UTF8 byte " ++ show x + in Skip $ handleError msg (UTF8DecodeInit st) + 0 -> error "unreachable state" + _ -> Skip (UTF8Decoding st sv cp) + + -- We recover by trying the new byte x as a starter of a new codepoint. + -- XXX need to use the same recovery in array decoding routine as well + step' table gst (UTF8Decoding st statePtr codepointPtr) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + let (Tuple' sv cp) = decode1 table statePtr codepointPtr x + return $ case sv of + 0 -> Skip $ YieldAndContinue + (unsafeChr cp) (UTF8DecodeInit s) + 12 -> + let msg = prefix + ++ "Invalid subsequent UTF8 byte " + ++ show x + ++ " in state " + ++ show statePtr + ++ " accumulated value " + ++ show codepointPtr + in Skip $ handleError msg (UTF8DecodeInit1 s x) + _ -> Skip (UTF8Decoding s sv cp) + Skip s -> return $ + Skip (UTF8Decoding s statePtr codepointPtr) + Stop -> return $ Skip handleUnderflow + + step' _ _ (YieldAndContinue c s) = return $ Yield c s + step' _ _ Done = return Stop + +{-# INLINE decodeUtf8D #-} +decodeUtf8D :: Monad m => D.Stream m Word8 -> D.Stream m Char +decodeUtf8D = decodeUtf8WithD TransliterateCodingFailure + +-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters. +-- Any invalid codepoint encountered is replaced with the unicode replacement +-- character. +-- +{-# INLINE decodeUtf8 #-} +decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char +decodeUtf8 = decodeUtf8D + +{-# INLINE decodeUtf8D' #-} +decodeUtf8D' :: Monad m => D.Stream m Word8 -> D.Stream m Char +decodeUtf8D' = decodeUtf8WithD ErrorOnCodingFailure + +-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters. +-- The function throws an error if an invalid codepoint is encountered. +-- +{-# INLINE decodeUtf8' #-} +decodeUtf8' :: Monad m => Stream m Word8 -> Stream m Char +decodeUtf8' = decodeUtf8D' + +{-# INLINE decodeUtf8D_ #-} +decodeUtf8D_ :: Monad m => D.Stream m Word8 -> D.Stream m Char +decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure + +-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters. +-- Any invalid codepoint encountered is dropped. +-- +{-# INLINE decodeUtf8_ #-} +decodeUtf8_ :: Monad m => Stream m Word8 -> Stream m Char +decodeUtf8_ = decodeUtf8D_ + +-- | Same as 'decodeUtf8' +-- +{-# DEPRECATED decodeUtf8Lax "Please use 'decodeUtf8' instead" #-} +{-# INLINE decodeUtf8Lax #-} +decodeUtf8Lax :: Monad m => Stream m Word8 -> Stream m Char +decodeUtf8Lax = decodeUtf8 + +------------------------------------------------------------------------------- +-- Decoding Array Streams +------------------------------------------------------------------------------- + +#ifndef __GHCJS__ +{-# ANN type FlattenState Fuse #-} +#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 + !DecodeState !CodePoint + | YAndC !Char (FlattenState s) -- These constructors can be + -- encoded in the UTF8DecodeState + -- type, I prefer to keep these + -- flat even though that means + -- coming up with new names + | D + +-- The normal decodeUtf8 above should fuse with flattenArrays +-- to create this exact code but it doesn't for some reason, as of now this +-- remains the fastest way I could figure out to decodeUtf8. +-- +-- XXX Add Proper error messages +{-# INLINE_NORMAL decodeUtf8ArraysWithD #-} +decodeUtf8ArraysWithD :: + MonadIO m + => CodingFailureMode + -> D.Stream m (Array Word8) + -> D.Stream m Char +decodeUtf8ArraysWithD cfm (D.Stream step state) = + D.Stream (step' utf8d) (OuterLoop state Nothing) + where + {-# INLINE transliterateOrError #-} + transliterateOrError e s = + case cfm of + ErrorOnCodingFailure -> error e + TransliterateCodingFailure -> YAndC replacementChar s + DropOnCodingFailure -> s + {-# INLINE inputUnderflow #-} + inputUnderflow = + case cfm of + ErrorOnCodingFailure -> + error $ + show "Streamly.Internal.Data.Stream.StreamD." + ++ "decodeUtf8ArraysWith: Input Underflow" + TransliterateCodingFailure -> YAndC replacementChar D + DropOnCodingFailure -> D + {-# INLINE_LATE step' #-} + step' _ gst (OuterLoop st Nothing) = do + r <- step (adaptState gst) st + return $ + case r of + Yield Array {..} s -> + Skip (InnerLoopDecodeInit s arrContents arrStart arrEnd) + Skip s -> Skip (OuterLoop s Nothing) + Stop -> Skip D + step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do + r <- step (adaptState gst) st + return $ + case r of + Yield Array {..} s -> + Skip (InnerLoopDecoding s arrContents arrStart arrEnd ds cp) + Skip s -> Skip (OuterLoop s dst) + Stop -> Skip inputUnderflow + step' _ _ (InnerLoopDecodeInit st _ p end) + | p == end = do + return $ Skip $ OuterLoop st Nothing + step' _ _ (InnerLoopDecodeInit st contents p end) = do + x <- liftIO $ peekWith contents p + -- 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 + -- versions, we need a more reliable "likely" primitive to control + -- branch predication. + case x > 0x7f of + False -> + return $ Skip $ YAndC + (unsafeChr (fromIntegral x)) + (InnerLoopDecodeInit st contents (p + 1) end) + -- Using a separate state here generates a jump to a separate code + -- block in the core which seems to perform slightly better for the + -- non-ascii case. + True -> return $ Skip $ InnerLoopDecodeFirst st contents p end x + + step' table _ (InnerLoopDecodeFirst st contents p end x) = do + let (Tuple' sv cp) = decode0 table x + return $ + case sv of + 12 -> + Skip $ + transliterateOrError + ( + "Streamly.Internal.Data.Stream.StreamD." + ++ "decodeUtf8ArraysWith: Invalid UTF8" + ++ " codepoint encountered" + ) + (InnerLoopDecodeInit st contents (p + 1) end) + 0 -> error "unreachable state" + _ -> Skip (InnerLoopDecoding st contents (p + 1) end sv cp) + 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 + let (Tuple' sv cp) = decode1 table statePtr codepointPtr x + return $ + case sv of + 0 -> + Skip $ + YAndC + (unsafeChr cp) + (InnerLoopDecodeInit st contents (p + 1) end) + 12 -> + Skip $ + transliterateOrError + ( + "Streamly.Internal.Data.Stream.StreamD." + ++ "decodeUtf8ArraysWith: Invalid UTF8" + ++ " codepoint encountered" + ) + (InnerLoopDecodeInit st contents (p + 1) end) + _ -> + Skip + (InnerLoopDecoding st contents (p + 1) end sv cp) + step' _ _ (YAndC c s) = return $ Yield c s + step' _ _ D = return Stop + +-- | Like 'decodeUtf8' but for a chunked stream. It may be slightly faster than +-- flattening the stream and then decoding with 'decodeUtf8'. +{-# INLINE decodeUtf8Chunks #-} +decodeUtf8Chunks :: + MonadIO m + => D.Stream m (Array Word8) + -> D.Stream m Char +decodeUtf8Chunks = decodeUtf8ArraysWithD TransliterateCodingFailure + +-- | Like 'decodeUtf8\'' but for a chunked stream. It may be slightly faster +-- than flattening the stream and then decoding with 'decodeUtf8\''. +{-# INLINE decodeUtf8Chunks' #-} +decodeUtf8Chunks' :: + MonadIO m + => D.Stream m (Array Word8) + -> D.Stream m Char +decodeUtf8Chunks' = decodeUtf8ArraysWithD ErrorOnCodingFailure + +-- | Like 'decodeUtf8_' but for a chunked stream. It may be slightly faster +-- than flattening the stream and then decoding with 'decodeUtf8_'. +{-# INLINE decodeUtf8Chunks_ #-} +decodeUtf8Chunks_ :: + MonadIO m + => D.Stream m (Array Word8) + -> D.Stream m Char +decodeUtf8Chunks_ = decodeUtf8ArraysWithD DropOnCodingFailure + +------------------------------------------------------------------------------- +-- Encoding Unicode (UTF-8) Characters +------------------------------------------------------------------------------- + +data WList = WCons !Word8 !WList | WNil + +-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8. + +{-# INLINE ord2 #-} +ord2 :: Char -> WList +ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil)) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (n .&. 0x3F) + 0x80 + +{-# INLINE ord3 #-} +ord3 :: Char -> WList +ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil))) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (n .&. 0x3F) + 0x80 + +{-# INLINE ord4 #-} +ord4 :: Char -> WList +ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil)))) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (n .&. 0x3F) + 0x80 + +{-# INLINE_NORMAL readCharUtf8With #-} +readCharUtf8With :: Monad m => WList -> Unfold m Char Word8 +readCharUtf8With surr = Unfold step inject + + where + + inject c = + return $ case ord c of + x | x <= 0x7F -> fromIntegral x `WCons` WNil + | x <= 0x7FF -> ord2 c + | x <= 0xFFFF -> if isSurrogate c then surr else ord3 c + | otherwise -> ord4 c + + {-# INLINE_LATE step #-} + step WNil = return Stop + step (WCons x xs) = return $ Yield x xs + +{-# INLINE_NORMAL readCharUtf8' #-} +readCharUtf8' :: Monad m => Unfold m Char Word8 +readCharUtf8' = + readCharUtf8With $ + error "Streamly.Internal.Unicode.readCharUtf8': Encountered a surrogate" + +-- More yield points improve performance, but I am not sure if they can cause +-- too much code bloat or some trouble with fusion. So keeping only two yield +-- points for now, one for the ascii chars (fast path) and one for all other +-- paths (slow path). +{-# INLINE_NORMAL encodeUtf8D' #-} +encodeUtf8D' :: Monad m => D.Stream m Char -> D.Stream m Word8 +encodeUtf8D' = D.unfoldMany 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 +-- function errors out. +-- +{-# INLINE encodeUtf8' #-} +encodeUtf8' :: Monad m => Stream m Char -> Stream m Word8 +encodeUtf8' = encodeUtf8D' + +{-# INLINE_NORMAL readCharUtf8 #-} +readCharUtf8 :: Monad m => Unfold m Char Word8 +readCharUtf8 = readCharUtf8With $ WCons 239 (WCons 191 (WCons 189 WNil)) + +-- | See section "3.9 Unicode Encoding Forms" in +-- https://www.unicode.org/versions/Unicode13.0.0/UnicodeStandard-13.0.pdf +-- +{-# INLINE_NORMAL encodeUtf8D #-} +encodeUtf8D :: Monad m => D.Stream m Char -> D.Stream m Word8 +encodeUtf8D = D.unfoldMany 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 +-- Unicode replacement character U+FFFD. +-- +{-# INLINE encodeUtf8 #-} +encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8 +encodeUtf8 = encodeUtf8D + +{-# INLINE_NORMAL readCharUtf8_ #-} +readCharUtf8_ :: Monad m => Unfold m Char Word8 +readCharUtf8_ = readCharUtf8With WNil + +{-# INLINE_NORMAL encodeUtf8D_ #-} +encodeUtf8D_ :: Monad m => D.Stream m Char -> D.Stream m Word8 +encodeUtf8D_ = D.unfoldMany 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. +-- +{-# INLINE encodeUtf8_ #-} +encodeUtf8_ :: Monad m => Stream m Char -> Stream m Word8 +encodeUtf8_ = encodeUtf8D_ + +-- | Same as 'encodeUtf8' +-- +{-# DEPRECATED encodeUtf8Lax "Please use 'encodeUtf8' instead" #-} +{-# INLINE encodeUtf8Lax #-} +encodeUtf8Lax :: Monad m => Stream m Char -> Stream m Word8 +encodeUtf8Lax = encodeUtf8 + +------------------------------------------------------------------------------- +-- Decoding string literals +------------------------------------------------------------------------------- + +-- | 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. +-- +-- /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 (Unicode.fromStr# "Haskell"#) +-- "Haskell" +-- +{-# INLINE fromStr# #-} +fromStr# :: MonadIO m => Addr# -> Stream m Char +fromStr# addr = decodeUtf8 $ Stream.fromByteStr# addr + +------------------------------------------------------------------------------- +-- Encode streams of containers +------------------------------------------------------------------------------- + +-- | Encode a container to @Array Word8@ provided an unfold to covert it to a +-- Char stream and an encoding function. +-- +-- /Internal/ +{-# INLINE encodeObject #-} +encodeObject :: MonadIO m => + (Stream m Char -> Stream m Word8) + -> Unfold m a Char + -> a + -> m (Array Word8) +encodeObject encode u = Stream.fold Array.write . encode . Stream.unfold u + +-- | Encode a stream of container objects using the supplied encoding scheme. +-- Each object is encoded as an @Array Word8@. +-- +-- /Internal/ +{-# INLINE encodeObjects #-} +encodeObjects :: MonadIO m => + (Stream m Char -> Stream m Word8) + -> Unfold m a Char + -> Stream m a + -> Stream m (Array Word8) +encodeObjects encode u = Stream.mapM (encodeObject encode u) + +-- | Encode a stream of 'String' using the supplied encoding scheme. Each +-- string is encoded as an @Array Word8@. +-- +{-# INLINE encodeStrings #-} +encodeStrings :: MonadIO m => + (Stream m Char -> Stream m Word8) + -> Stream m String + -> Stream m (Array Word8) +encodeStrings encode = encodeObjects encode Unfold.fromList + +{- +------------------------------------------------------------------------------- +-- Utility operations on strings +------------------------------------------------------------------------------- + +strip :: IsStream t => Stream m Char -> Stream m Char +strip = undefined + +stripTail :: IsStream t => Stream m Char -> Stream m Char +stripTail = undefined +-} + +-- | Remove leading whitespace from a string. +-- +-- > stripHead = Stream.dropWhile isSpace +-- +-- /Pre-release/ +{-# INLINE stripHead #-} +stripHead :: Monad m => Stream m Char -> Stream m Char +stripHead = Stream.dropWhile isSpace + +-- | 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","",""] +-- +-- > lines = Stream.splitOnSuffix (== '\n') +-- +-- /Pre-release/ +{-# INLINE lines #-} +lines :: Monad m => Fold m Char b -> Stream m Char -> Stream m b +lines f = Stream.foldMany (Fold.takeEndBy_ (== '\n') f) + +#if !MIN_VERSION_base(4,17,0) +foreign import ccall unsafe "u_iswspace" + iswspace :: Int -> Int +#endif + +-- | Code copied from base/Data.Char to INLINE it +{-# INLINE isSpace #-} +isSpace :: Char -> Bool +isSpace c + | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0 +#if MIN_VERSION_base(4,17,0) + | otherwise = generalCategory c == Space +#else + | otherwise = iswspace (ord c) /= 0 +#endif + where + uc = fromIntegral (ord c) :: Word + +-- | Fold each word of the stream using the supplied 'Fold' +-- and stream the result. +-- +-- >>> Stream.fold Fold.toList $ words Fold.toList (Stream.fromList "fold these words") +-- ["fold","these","words"] +-- +-- > words = Stream.wordsBy isSpace +-- +-- /Pre-release/ +{-# INLINE words #-} +words :: Monad m => Fold m Char b -> Stream m Char -> Stream m b +words f = D.wordsBy isSpace f + +-- | 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" +-- @ +-- +-- /Pre-release/ +{-# INLINE unlines #-} +unlines :: MonadIO m => Unfold m a Char -> Stream m a -> Stream m Char +unlines = Stream.interposeSuffix '\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 " " +-- @ +-- +-- /Pre-release/ +{-# INLINE unwords #-} +unwords :: MonadIO m => Unfold m a Char -> Stream m a -> Stream m Char +unwords = Stream.interpose ' ' diff --git a/src/Streamly/Internal/Unicode/String.hs b/src/Streamly/Internal/Unicode/String.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Unicode/String.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Streamly.Internal.Unicode.String +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Convenient template Haskell quasiquoters to format strings. + +-- Design Notes: +-- +-- Essential requirements are: +-- +-- Haskell expression expansion +-- Newline treatment (continue without introducing a newline) +-- Indentation treatment +-- +-- We choose #{expr} for patching a Haskell expression's value in a string. "$" +-- instead of "#" was another option (like in neat-interpolation package) but +-- we did not use that to avoid conflict with strings that are used as shell +-- commands. Another option was to use just "{}" (like in PyF package) but we +-- did not use that to avoid conflict with "${}" used in shell. +-- +-- We use a "#" at the end of line to continue the line. We could use a "\" +-- as well but that may interfere with CPP. +-- +-- Stripping is not part of the quasiquoter as it can be done by a Haskell +-- function. Other type of formatting on the Haskell expression can be done +-- using Haskell functions. + +module Streamly.Internal.Unicode.String + ( str + ) where + + +import Control.Applicative (Alternative(..)) +import Control.Exception (displayException) +import Data.Functor.Identity (runIdentity) +import Streamly.Internal.Data.Parser (Parser) + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Internal.Data.Parser as Parser + (some, many, takeWhile1) +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 +-- +-------------------------------------------------------------------------------- +-- Parsing +-------------------------------------------------------------------------------- + +data StrSegment + = StrText String + | StrVar String + deriving (Show, Eq) + +haskellIdentifier :: Monad m => Parser Char m String +haskellIdentifier = + let p = Parser.alphaNum <|> Parser.char '\'' <|> Parser.char '_' + in Parser.some p Fold.toList + +strParser :: Monad m => Parser Char m [StrSegment] +strParser = Parser.many content Fold.toList + + where + + plainText = StrText <$> Parser.takeWhile1 (/= '#') Fold.toList + escHash = StrText . (: []) <$> (Parser.char '#' *> Parser.char '#') + lineCont = StrText [] <$ (Parser.char '#' *> Parser.char '\n') + var = StrVar <$> + ( Parser.char '#' + *> Parser.char '{' + *> haskellIdentifier + <* Parser.char '}' + ) + plainHash = StrText . (: []) <$> Parser.char '#' + + -- order is important + content = plainText <|> escHash <|> lineCont <|> var <|> plainHash + +strSegmentExp :: StrSegment -> Q Exp +strSegmentExp (StrText text) = stringE text +strSegmentExp (StrVar name) = do + valueName <- lookupValueName name + case valueName of + Just vn -> varE vn + Nothing -> + fail + $ "str quote: Haskell symbol `" ++ name + ++ "` is not in scope" + +strExp :: [StrSegment] -> Q Exp +strExp xs = appE [| concat |] $ listE $ map strSegmentExp xs + +expandVars :: String -> Q Exp +expandVars ln = + case runIdentity $ Stream.parse strParser (Stream.fromList ln) of + Left e -> + fail $ "str QuasiQuoter parse error: " ++ displayException e + Right x -> + strExp x + +-- | A QuasiQuoter that treats the input as a string literal: +-- +-- >>> [str|x|] +-- "x" +-- +-- Any @#{symbol}@ is replaced by the value of the Haskell symbol @symbol@ +-- which is in scope: +-- +-- >>> x = "hello" +-- >>> [str|#{x} world!|] +-- "hello world!" +-- +-- @##@ means a literal @#@ without the special meaning for referencing +-- haskell symbols: +-- +-- >>> [str|##{x} world!|] +-- "#{x} world!" +-- +-- A @#@ at the end of line means the line continues to the next line without +-- introducing a newline character: +-- +-- >>> :{ +-- [str|hello# +-- world!|] +-- :} +-- "hello world!" +-- +-- Bugs: because of a bug in parsers, a lone # at the end of input gets +-- removed. +-- +str :: QuasiQuoter +str = + QuasiQuoter + { quoteExp = expandVars + , quotePat = notSupported + , quoteType = notSupported + , quoteDec = notSupported + } + + where + + notSupported = error "str: Not supported." diff --git a/src/Streamly/Unicode/Parser.hs b/src/Streamly/Unicode/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Unicode/Parser.hs @@ -0,0 +1,59 @@ +-- | +-- Module : Streamly.Unicode.Parser +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- To parse a text input, use the decode routines from +-- "Streamly.Unicode.Stream" module to convert an input byte stream to a +-- Unicode Char stream and then use these parsers on the Char stream. + +module Streamly.Unicode.Parser + ( + -- * Single Chars + + -- Any char + char + , charIgnoreCase + + -- Char classes + , alpha + , alphaNum + , letter + , ascii + , asciiLower + , asciiUpper + , latin1 + , lower + , upper + , mark + , printable + , punctuation + , separator + , space + , symbol + + -- Digits + , digit + , octDigit + , hexDigit + , numeric + + -- * Char Sequences + , string + , stringIgnoreCase + , dropSpace + , dropSpace1 + + -- * Digit Sequences (Numbers) + , decimal + , hexadecimal + + -- * Modifiers + , signed + ) +where + +import Streamly.Internal.Unicode.Parser diff --git a/src/Streamly/Unicode/Stream.hs b/src/Streamly/Unicode/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Unicode/Stream.hs @@ -0,0 +1,107 @@ +-- | +-- Module : Streamly.Unicode.Stream +-- Copyright : (c) 2020 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- = Processing Unicode Strings +-- +-- A 'Char' stream is the canonical representation to process Unicode strings. +-- It can be processed efficiently using regular stream processing operations. +-- A byte stream of Unicode text read from an IO device or from an +-- 'Streamly.Data.Array.Array' in memory can be decoded into a 'Char' stream +-- using the decoding routines in this module. A 'String' (@[Char]@) can be +-- converted into a 'Char' stream using 'Streamly.Data.Stream.fromList'. An +-- @Array Char@ can be 'Streamly.Data.Stream.unfold'ed into a stream using the +-- array 'Streamly.Data.Array.read' unfold. +-- +-- = Storing Unicode Strings +-- +-- A stream of 'Char' can be encoded into a byte stream using the encoding +-- 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 +-- '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 +-- 'encodeUtf8'' on the 'Char' stream before writing it to an 'Array' providing +-- an even more compact representation. +-- +-- = String Literals +-- +-- @Stream Identity Char@ and @Array Char@ are instances of 'IsString' and +-- 'IsList', therefore, 'OverloadedStrings' and 'OverloadedLists' extensions +-- can be used for convenience when specifying unicode strings literals using +-- these types. +-- +-- = Idioms +-- +-- Some simple text processing operations can be represented simply as +-- operations on Char streams. Follow the links for the following idioms: +-- +-- * 'Streamly.Internal.Unicode.Stream.lines' +-- * 'Streamly.Internal.Unicode.Stream.words' +-- * 'Streamly.Internal.Unicode.Stream.unlines' +-- * 'Streamly.Internal.Unicode.Stream.unwords' +-- +-- = Pitfalls +-- +-- * Case conversion: Some unicode characters translate to more than one code +-- point on case conversion. The 'toUpper' and 'toLower' functions in @base@ +-- package do not handle such characters. Therefore, operations like @map +-- toUpper@ on a character stream or character array may not always perform +-- correct conversion. +-- * String comparison: In some cases, visually identical strings may have +-- different unicode representations, therefore, a character stream or +-- character array cannot be directly compared. A normalized comparison may be +-- needed to check string equivalence correctly. +-- +-- = Experimental APIs +-- +-- 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 + ( + -- * Construction (Decoding) + decodeLatin1 + , decodeUtf8 + , decodeUtf8' + , decodeUtf8Chunks + + -- * Elimination (Encoding) + , encodeLatin1 + , encodeLatin1' + , encodeUtf8 + , encodeUtf8' + , encodeStrings + {- + -- * Operations on character strings + , strip -- (dropAround isSpace) + , stripEnd + , stripStart + -} + -- Not exposing these yet as we have consider these with respect to Unicode + -- segmentation routines which are yet to be implemented. + -- -- * Transformation + -- , lines + -- , words + -- , unlines + -- , unwords + ) +where + +import Streamly.Internal.Unicode.Stream +import Prelude hiding (lines, words, unlines, unwords) diff --git a/src/Streamly/Unicode/String.hs b/src/Streamly/Unicode/String.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Unicode/String.hs @@ -0,0 +1,16 @@ +-- | +-- Module : Streamly.Unicode.String +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- Convenient template Haskell quasiquoters to format strings. + +module Streamly.Unicode.String + ( str + ) +where + +import Streamly.Internal.Unicode.String diff --git a/src/assert.hs b/src/assert.hs new file mode 100644 --- /dev/null +++ b/src/assert.hs @@ -0,0 +1,6 @@ +-- A convenient macro to assert in a do block. We cannot define this as a +-- Haskell function because then the compiler reports the assert location +-- inside the wrapper function rather than the original location. + +import Control.Exception (assert) +#define assertM(p) assert (p) (return ()) diff --git a/src/config.h.in b/src/config.h.in new file mode 100644 --- /dev/null +++ b/src/config.h.in @@ -0,0 +1,57 @@ +/* src/config.h.in. Generated from configure.ac by autoheader. */ + +/* Define to 1 if you have the `clock_gettime' function. */ +#undef HAVE_CLOCK_GETTIME + +/* Define to 1 if you have the header file. */ +#undef HAVE_INTTYPES_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDINT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDIO_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDLIB_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRINGS_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRING_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_STAT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_TYPES_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_TIME_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_UNISTD_H + +/* Define to the address where bug reports for this package should be sent. */ +#undef PACKAGE_BUGREPORT + +/* Define to the full name of this package. */ +#undef PACKAGE_NAME + +/* Define to the full name and version of this package. */ +#undef PACKAGE_STRING + +/* Define to the one symbol short name of this package. */ +#undef PACKAGE_TARNAME + +/* Define to the home page for this package. */ +#undef PACKAGE_URL + +/* 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 + 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/inline.hs b/src/inline.hs new file mode 100644 --- /dev/null +++ b/src/inline.hs @@ -0,0 +1,27 @@ +-- We use fromStreamK/toStreamK to convert the direct style stream to CPS +-- style. In the first phase we try fusing the fromStreamK/toStreamK using: +-- +-- {-# RULES "fromStreamK/toStreamK fusion" +-- forall s. toStreamK (fromStreamK s) = s #-} +-- +-- If for some reason some of the operations could not be fused then we have +-- fallback rules in the second phase. For example: +-- +-- {-# INLINE_EARLY unfoldr #-} +-- unfoldr :: (Monad m, IsStream t) => (b -> Maybe (a, b)) -> b -> t m a +-- unfoldr step seed = fromStreamD (S.unfoldr step seed) +-- {-# RULES "unfoldr fallback to StreamK" [1] +-- forall a b. S.toStreamK (S.unfoldr a b) = K.unfoldr a b #-}``` +-- +-- Then, fromStreamK/toStreamK are inlined in the last phase: +-- +-- {-# INLINE_LATE toStreamK #-} +-- toStreamK :: Monad m => Stream m a -> K.StreamK m a``` +-- +-- The fallback rules make sure that if we could not fuse the direct style +-- operations then better use the CPS style operation, because unfused direct +-- style would have worse performance than the CPS style ops. + +#define INLINE_EARLY INLINE [2] +#define INLINE_NORMAL INLINE [1] +#define INLINE_LATE INLINE [0] diff --git a/streamly-core.cabal b/streamly-core.cabal new file mode 100644 --- /dev/null +++ b/streamly-core.cabal @@ -0,0 +1,479 @@ +cabal-version: 2.2 +name: streamly-core +version: 0.1.0 +synopsis: Streaming, parsers, arrays 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 + . + . + This package provides streams, arrays, parsers, unicode text, file + IO, and console IO functionality. + . + Note: The dependencies "heaps" and "monad-control" are included in + the package solely for backward compatibility, and will be removed in + future versions. + +homepage: https://streamly.composewell.com +bug-reports: https://github.com/composewell/streamly/issues +license: BSD-3-Clause +license-file: LICENSE +tested-with: GHC==8.6.5 + , GHC==8.8.4 + , GHC==8.10.7 + , GHC==9.0.2 + , GHC==9.2.7 + , GHC==9.4.4 +author: Composewell Technologies +maintainer: streamly@composewell.com +copyright: 2017 Composewell Technologies +category: + Streamly, Streaming, Dataflow, Pipes, List, + Logic, Non-determinism, Parsing, Array, Time +stability: Stable +build-type: Configure + +extra-source-files: + configure + 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 + + -- This is duplicated + src/Streamly/Internal/Data/Array/ArrayMacros.h + src/assert.hs + src/inline.hs + + src/Streamly/Internal/Data/Time/Clock/config-clock.h + src/config.h.in + +extra-tmp-files: + config.log + config.status + autom4te.cache + src/config.h + +extra-doc-files: + Changelog.md + docs/*.md + docs/ApiChangelogs/0.1.0.txt + +source-repository head + type: git + location: https://github.com/composewell/streamly + +flag debug + description: Debug build with asserts enabled + manual: True + default: False + +flag dev + description: Development build + manual: True + default: False + +flag has-llvm + description: Use llvm backend for code generation + 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 + default: True + +flag limit-build-mem + description: Limits memory when building + manual: True + default: False + +flag use-unliftio + description: Use unliftio-core instead of monad-control + manual: True + default: False + +flag use-unfolds + description: Use unfolds for generation everywhere + manual: True + default: False + +flag use-folds + description: Use folds for elimination everywhere + manual: True + default: False + +------------------------------------------------------------------------------- +-- Common stanzas +------------------------------------------------------------------------------- + +common compile-options + default-language: Haskell2010 + + if flag(no-fusion) + cpp-options: -DDISABLE_FUSION + + if flag(dev) + cpp-options: -DDEVBUILD + + if flag(use-unfolds) + cpp-options: -DUSE_UNFOLDS_EVERYWHERE + + 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 + -Wno-missing-exported-signatures + -Wno-missing-import-lists + -Wno-missing-local-signatures + -Wno-missing-safe-haskell-mode + -Wno-missed-specialisations + -Wno-all-missed-specialisations + -Wno-monomorphism-restriction + -Wno-prepositive-qualified-module + -Wno-unsafe + -Rghc-timing + + if impl(ghc >= 9.2) + ghc-options: + -Wno-missing-kind-signatures + -Wno-redundant-bang-patterns + -Wno-operator-whitespace + + if flag(has-llvm) + ghc-options: -fllvm + + if flag(dev) + ghc-options: -Wmissed-specialisations + -Wall-missed-specialisations + + if flag(limit-build-mem) + ghc-options: +RTS -M1000M -RTS + + if flag(use-unliftio) + cpp-options: -DUSE_UNLIFTIO + +common default-extensions + default-extensions: + BangPatterns + CApiFFI + CPP + ConstraintKinds + DeriveDataTypeable + DeriveGeneric + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + 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, + -- otherwise TypeFamilies will enable it again. + NoMonoLocalBinds + + -- UndecidableInstances -- Does not show any perf impact + -- UnboxedTuples -- interferes with (#.) + +common optimization-options + if flag(opt) + ghc-options: -O2 + -fdicts-strict + -fspec-constr-recursive=16 + -fmax-worker-args=16 + + -- For this to be effective it must come after the -O2 option + if flag(dev) || flag(debug) || !flag(opt) + ghc-options: -fno-ignore-asserts + +common threading-options + ghc-options: -threaded + -with-rtsopts=-N + +-- We need optimization options here to optimize internal (non-inlined) +-- versions of functions. Also, we have some benchmarking inspection tests +-- part of the library when built with --benchmarks flag. Thos tests fail +-- if we do not use optimization options here. It was observed that due to +-- -O2 here some concurrent/nested benchmarks improved and others regressed. +-- We can investigate a bit more here why the regression occurred. +common lib-options + import: compile-options, optimization-options, default-extensions + +------------------------------------------------------------------------------- +-- Library +------------------------------------------------------------------------------- + +library + import: lib-options + + if impl(ghc >= 8.6) + default-extensions: QuantifiedConstraints + + js-sources: jsbits/clock.js + + include-dirs: + src + , src/Streamly/Internal/Data/Array + , src/Streamly/Internal/Data/Stream + + if os(windows) + c-sources: src/Streamly/Internal/Data/Time/Clock/Windows.c + + if os(darwin) + include-dirs: src/Streamly/Internal + c-sources: src/Streamly/Internal/Data/Time/Clock/Darwin.c + + hs-source-dirs: src + exposed-modules: + -- Internal modules, listed roughly in bottom up + -- dependency order To view dependency graph: + -- graphmod | dot -Tps > deps.ps + + -- streamly-base + Streamly.Internal.BaseCompat + , Streamly.Internal.Control.Exception + , Streamly.Internal.Control.Monad + , Streamly.Internal.Control.ForkIO + Streamly.Internal.Data.IsMap + , Streamly.Internal.System.IO + + -- streamly-strict-data + , Streamly.Internal.Data.Tuple.Strict + , Streamly.Internal.Data.Maybe.Strict + , Streamly.Internal.Data.Either.Strict + + , Streamly.Internal.Data.IOFinalizer + + -- streamly-time + , Streamly.Internal.Data.Time.TimeSpec + , Streamly.Internal.Data.Time.Units + , Streamly.Internal.Data.Time.Clock.Type + , Streamly.Internal.Data.Time.Clock + + -- 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 + -- 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-core-streams + , Streamly.Internal.Data.Stream.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.Pipe + + -- streamly-transformers (non-base) + , Streamly.Internal.Data.Stream.StreamD.Transformer + , Streamly.Internal.Data.Stream.StreamK.Transformer + + -- streamly-containers (non-base) + , Streamly.Internal.Data.Stream.StreamD.Container + , Streamly.Internal.Data.Fold.Container + + , Streamly.Internal.Data.Stream.Chunked + + -- 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 + + -- streamly-unicode-core + , Streamly.Internal.Unicode.Stream + , Streamly.Internal.Unicode.String + , Streamly.Internal.Unicode.Parser + , Streamly.Internal.Unicode.Array + + -- Filesystem/IO + , Streamly.Internal.FileSystem.Handle + , Streamly.Internal.FileSystem.File + , Streamly.Internal.FileSystem.Dir + + -- Ring Arrays + , Streamly.Internal.Data.Ring.Unboxed + , Streamly.Internal.Data.Ring + + -- 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.List + -- , Streamly.Data.Binary.Decode + -- , Streamly.FileSystem.File + -- , Streamly.FileSystem.Dir + -- , Streamly.Data.Time.Units + -- , Streamly.Data.Time.Clock + -- , Streamly.Data.Tuple.Strict + -- , Streamly.Data.Maybe.Strict + -- , 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.Data.Array + , Streamly.Data.Array.Generic + , Streamly.Data.MutArray + , Streamly.Data.MutArray.Generic + , Streamly.Data.Fold + , Streamly.Data.Parser + , Streamly.Data.ParserK + , Streamly.Data.Stream + , Streamly.Data.StreamK + , Streamly.Data.Unfold + , Streamly.FileSystem.Dir + , Streamly.FileSystem.File + , Streamly.FileSystem.Handle + , Streamly.Unicode.Parser + , Streamly.Unicode.Stream + , Streamly.Unicode.String + + if flag(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 + + build-depends: + -- streamly-base + -- + -- These dependencies can be reversed if we want + -- streamly-base to depend only on base. + -- + -- Core libraries shipped with ghc, the min and max + -- constraints of these libraries should match with + -- the GHC versions we support. This is to make sure that + -- 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 + , fusion-plugin-types >= 0.1 && < 0.2 + , base >= 4.12 && < 4.19 + , 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 + + -- XXX to be removed + , containers >= 0.6.0 && < 0.7 + , heaps >= 0.3 && < 0.5 + if !flag(use-unliftio) + build-depends: monad-control >= 1.0 && < 1.1